import cicm2022.examples.Proj.degree_zero_part
import cicm2022.examples.Proj.structure_sheaf
import cicm2022.examples.Proj.lemmas

import algebraic_geometry.structure_sheaf
import algebraic_geometry.Spec

noncomputable theory

namespace algebraic_geometry

open_locale direct_sum big_operators pointwise big_operators
open direct_sum set_like.graded_monoid localization finset (hiding mk_zero)

variables {R A : Type*}
variables [comm_ring R] [comm_ring A] [algebra R A]

variables (𝒜 : ℕ → submodule R A)
variables [graded_algebra 𝒜]

open Top topological_space
open category_theory opposite
open projective_spectrum.structure_sheaf

local notation `Proj` := Proj.to_LocallyRingedSpace 𝒜
-- `Proj` as a locally ringed space
local notation `Proj.T` := Proj .1.1.1
-- the underlying topological space of `Proj`
local notation `Proj| ` U := Proj .restrict (opens.open_embedding (U : opens Proj.T))
-- `Proj` restrict to some open set
local notation `Proj.T| ` U :=
  (Proj .restrict (opens.open_embedding (U : opens Proj.T))).to_SheafedSpace.to_PresheafedSpace.1
-- the underlying topological space of `Proj` restricted to some open set
local notation `pbo` x := projective_spectrum.basic_open 𝒜 x
-- basic open sets in `Proj`
local notation `sbo` f := prime_spectrum.basic_open f
-- basic open sets in `Spec`
local notation `Spec` ring := Spec.LocallyRingedSpace_obj (CommRing.of ring)
-- `Spec` as a locally ringed space
local notation `Spec.T` ring :=
  (Spec.LocallyRingedSpace_obj (CommRing.of ring)).to_SheafedSpace.to_PresheafedSpace.1
-- the underlying topological space of `Spec`
local notation `A⁰_` f_deg := degree_zero_part f_deg

namespace Proj_iso_Spec_Top_component

namespace to_Spec

open ideal

variables {𝒜} {f : A} {m : ℕ} (f_deg : f ∈ 𝒜 m) (x : Proj| (pbo f))

/--For any `x` in `Proj| (pbo f)`, the corresponding ideal in `Spec A⁰_f`. This fact that this ideal
is prime is proven in `Top_component.forward.to_fun`-/
def carrier : ideal (A⁰_ f_deg) :=
ideal.comap (algebra_map (A⁰_ f_deg) (away f))
  (ideal.span $ algebra_map A (away f) '' x.1.as_homogeneous_ideal)

lemma mem_carrier_iff (z : A⁰_ f_deg) :
  z ∈ carrier f_deg x ↔
  ↑z ∈ ideal.span (algebra_map A (away f) '' x.1.as_homogeneous_ideal) :=
iff.rfl

lemma mem_carrier.clear_denominator [decidable_eq (away f)]
  {z : A⁰_ f_deg} (hz : z ∈ carrier f_deg x) :
  ∃ (c : algebra_map A (away f) '' x.1.as_homogeneous_ideal →₀ away f)
    (N : ℕ)
    (acd : Π y ∈ c.support.image c, A),
    f ^ N • ↑z =
    algebra_map A (away f) (∑ i in c.support.attach,
      acd (c i) (finset.mem_image.mpr ⟨i, ⟨i.2, rfl⟩⟩) * classical.some i.1.2) :=
begin
  rw [mem_carrier_iff, ←submodule_span_eq, finsupp.span_eq_range_total, linear_map.mem_range] at hz,
  rcases hz with ⟨c, eq1⟩,
  rw [finsupp.total_apply, finsupp.sum] at eq1,
  obtain ⟨⟨_, N, rfl⟩, hN⟩ := is_localization.exist_integer_multiples_of_finset (submonoid.powers f)
    (c.support.image c),
  choose acd hacd using hN,
  have prop1 : ∀ i, i ∈ c.support → c i ∈ finset.image c c.support,
  { intros i hi, rw finset.mem_image, refine ⟨_, hi, rfl⟩, },

  refine ⟨c, N, acd, _⟩,
  rw [← eq1, smul_sum, map_sum, ← sum_attach],
  congr' 1,
  ext i,
  rw [_root_.map_mul, hacd, (classical.some_spec i.1.2).2, smul_eq_mul, smul_mul_assoc],
  refl
end

def carrier' : ideal (A⁰_ f_deg) :=
ideal.span
  { z | ∃ (s : A) (hs : s ∈ x.1.as_homogeneous_ideal) (n : ℕ) (s_mem : s ∈ 𝒜 (m * n)),
      z = ⟨mk s ⟨f^n, ⟨_, rfl⟩⟩, ⟨n, ⟨s, s_mem⟩, rfl⟩⟩ }

lemma carrier_eq_carrier' :
  carrier f_deg x = carrier' f_deg x :=
begin
  classical,
  -- haveI : decidable_eq (away f) := classical.dec_eq _,
  ext z, split; intros hz,
  { rw mem_carrier_iff at hz,
    change z ∈ ideal.span _,
    have mem1 := z.prop,
    change ∃ _, _ at mem1,
    obtain ⟨k, ⟨a, a_mem⟩, hk⟩ := mem1,
    erw [hk] at hz,

    erw [←ideal.submodule_span_eq, finsupp.span_eq_range_total, set.mem_range] at hz,
    obtain ⟨c, eq1⟩ := hz,
    erw [finsupp.total_apply, finsupp.sum] at eq1,
    dsimp only [subtype.coe_mk] at eq1,

    suffices mem1 : a ∈ x.1.as_homogeneous_ideal,
    apply ideal.subset_span,
    exact ⟨a, mem1, _, a_mem, subtype.ext hk⟩,

    obtain ⟨N, hN⟩ := clear_denominator (finset.image (λ i, c i * i) c.support),
    -- N is the common denom
    choose after_clear_denominator hacd using hN,
    have prop1 : ∀ i, i ∈ c.support → c i * i ∈ (finset.image (λ i, c i * i) c.support),
    { intros i hi, rw finset.mem_image, refine ⟨_, hi, rfl⟩, },
    have eq3 := calc (localization.mk a 1 : localization.away f) * localization.mk (f^N) 1
            = localization.mk a ⟨f^k, ⟨_, rfl⟩⟩ * localization.mk (f^k) 1 * localization.mk (f^N) 1
            : begin
              congr,
              rw [localization.mk_mul, localization.mk_eq_mk', is_localization.eq],
              use 1,
              erw [mul_one, mul_one, mul_one, mul_one, subtype.coe_mk],
            end
        ... = localization.mk (f^k) 1 * localization.mk a ⟨f^k, ⟨_, rfl⟩⟩ * localization.mk (f^N) 1
            : by ring
        ... = localization.mk (f^k) 1 * localization.mk (f^N) 1 * ∑ i in c.support, c i * i
            : begin
              erw eq1, ring,
            end
        ... = localization.mk (f^k) 1 * (localization.mk (f^N) 1 * ∑ i in c.support, c i * i) : by ring
        ... = localization.mk (f^k) 1 * ∑ i in c.support, (localization.mk (f^N) 1) * (c i * i)
            : begin
              congr' 1,
              rw finset.mul_sum,
            end
        ... = localization.mk (f^k) 1 * ∑ i in c.support.attach, (localization.mk (f^N) 1) * (c i * i.1.1)
            : begin
              congr' 1,
              symmetry,
              convert finset.sum_attach,
              refl,
            end
        ... = localization.mk (f^k) 1 * ∑ i in c.support.attach, (localization.mk (after_clear_denominator (c i * i.1.1) (prop1 i i.prop)) 1)
            : begin
              congr' 1,
              rw finset.sum_congr rfl (λ j hj, _),
              have eq2 := (hacd (c j * j.1.1) (prop1 j.1 j.2)).2,
              dsimp only at eq2,
              erw eq2,
              rw mul_comm,
            end
        ... = ∑ i in c.support.attach, (localization.mk (f^k) 1) * (localization.mk (after_clear_denominator (c i * i.1.1) (prop1 i i.prop)) 1)
            : begin
              rw finset.mul_sum,
            end
        ... = ∑ i in c.support.attach, localization.mk (f^k * (after_clear_denominator (c i * i.1.1) (prop1 i i.prop))) 1
            : begin
              rw finset.sum_congr rfl (λ j hj, _),
              erw [localization.mk_mul, one_mul],
            end
        ... = localization.mk (∑ i in c.support.attach, (f^k * (after_clear_denominator (c i * i.1.1) (prop1 i i.prop)))) 1
            : begin
              induction c.support.attach using finset.induction_on with y s hy ih,
              rw [finset.sum_empty, finset.sum_empty, localization.mk_zero],

              erw [finset.sum_insert hy, finset.sum_insert hy, ih, localization.add_mk, mul_one, one_mul, one_mul, add_comm],
            end,
    erw [localization.mk_mul, one_mul] at eq3,
    simp only [localization.mk_eq_mk', is_localization.eq] at eq3,
    obtain ⟨⟨_, ⟨l, rfl⟩⟩, eq3⟩ := eq3,
    erw [mul_one, mul_one] at eq3,
    dsimp only [subtype.coe_mk] at eq3,

    suffices : (∑ i in c.support.attach, (f^k * (after_clear_denominator (c i * i.1.1) (prop1 i i.prop)))) * f^l ∈ x.1.as_homogeneous_ideal,
    erw ←eq3 at this,
    rcases x.1.is_prime.mem_or_mem this with H1 | H3,
    rcases x.1.is_prime.mem_or_mem H1 with H1 | H2,
    { exact H1 },
    { exfalso,
      have mem3 := x.2,
      have mem4 := x.1.is_prime.mem_of_pow_mem _ H2,
      erw projective_spectrum.mem_basic_open at mem3,
      apply mem3,
      exact mem4, },
    { exfalso,
      have mem3 := x.2,
      have mem4 := x.1.is_prime.mem_of_pow_mem _ H3,
      erw projective_spectrum.mem_basic_open at mem3,
      apply mem3,
      exact mem4, },

    apply ideal.mul_mem_right,
    apply ideal.sum_mem,
    intros j hj,
    apply ideal.mul_mem_left,
    set g := classical.some j.1.2 with g_eq,
    have mem3 : g ∈ x.1.as_homogeneous_ideal := (classical.some_spec j.1.2).1,
    have eq3 := (classical.some_spec j.1.2).2,
    have eq3 : j.1.1 = localization.mk g 1 := (classical.some_spec j.1.2).2.symm,
    have eq4 := (hacd (c j.1 * j.1.1) (prop1 j.1 j.2)).2,
    dsimp only at eq4,

    have eq5 : ∃ (a : A) (z : ℕ), c j.1 = localization.mk a ⟨f^z, ⟨z, rfl⟩⟩,
    { induction (c j.1) using localization.induction_on with data,
      rcases data with ⟨a, ⟨_, ⟨z, rfl⟩⟩⟩,
      refine ⟨a, z, rfl⟩, },
    obtain ⟨α, z, hz⟩ := eq5,

    have eq6 := calc localization.mk (after_clear_denominator (c j.1 * j.1.1) (prop1 j.1 j.2)) 1
            = c j.1 * j.1.1 * localization.mk (f^N) 1 : eq4
        ... = (localization.mk α ⟨f^z, ⟨z, rfl⟩⟩ : localization.away f) * j.1.1 * localization.mk (f^N) 1
            : by erw hz
        ... = (localization.mk α ⟨f^z, ⟨z, rfl⟩⟩ : localization.away f) * localization.mk g 1 * localization.mk (f^N) 1
            : by erw eq3
        ... = localization.mk (α * g * f^N) ⟨f^z, ⟨z, rfl⟩⟩
            : begin
              erw [localization.mk_mul, localization.mk_mul, mul_one, mul_one],
            end,
    simp only [localization.mk_eq_mk', is_localization.eq] at eq6,
    obtain ⟨⟨_, ⟨v, rfl⟩⟩, eq6⟩ := eq6,
    erw [mul_one] at eq6,
    dsimp only at eq6,

    have mem4 : α * g * f ^ N * f ^ v ∈ x.1.as_homogeneous_ideal,
    { apply ideal.mul_mem_right,
      apply ideal.mul_mem_right,
      apply ideal.mul_mem_left,
      exact mem3, },
    erw ←eq6 at mem4,

    rcases x.1.is_prime.mem_or_mem mem4 with H1 | H3,
    rcases x.1.is_prime.mem_or_mem H1 with H1 | H2,
    { exact H1 },
    { exfalso,
      have mem3 := x.2,
      have mem4 := x.1.is_prime.mem_of_pow_mem _ H2,
      erw projective_spectrum.mem_basic_open at mem3,
      apply mem3,
      exact mem4, },
    { exfalso,
      have mem3 := x.2,
      have mem4 := x.1.is_prime.mem_of_pow_mem _ H3,
      erw projective_spectrum.mem_basic_open at mem3,
      apply mem3,
      exact mem4, } },

  { change z ∈ ideal.span _ at hz,
    rw mem_carrier_iff,

    erw [←ideal.submodule_span_eq, finsupp.span_eq_range_total, set.mem_range] at hz,
    obtain ⟨c, eq1⟩ := hz,
    erw [finsupp.total_apply, finsupp.sum] at eq1,
    erw [←eq1, add_submonoid_class.coe_finset_sum],

    apply ideal.sum_mem (ideal.span _),

    rintros j hj,
    rw [smul_eq_mul, subring.coe_mul],
    apply ideal.mul_mem_left (ideal.span _),
    have hj2 := j.prop,
    change ∃ s, _ at hj2,
    obtain ⟨s, hs, n, s_mem, hj2⟩ := hj2,
    erw hj2, dsimp only [subtype.coe_mk],
    have eq2 : (localization.mk s ⟨f ^ n, ⟨_, rfl⟩⟩ : localization.away f) =
      localization.mk 1 ⟨f^n, ⟨_, rfl⟩⟩ * localization.mk s 1,
    { rw [localization.mk_mul, one_mul, mul_one], },
    erw eq2,
    convert ideal.mul_mem_left _ _ _,
    apply ideal.subset_span,
    refine ⟨s, hs, rfl⟩, },
end

lemma no_intersection :
  (x.1.as_homogeneous_ideal.to_ideal ∩ submonoid.powers f : set A) = ∅ :=
begin
  by_contra rid,
  rw [←ne.def, set.ne_empty_iff_nonempty] at rid,
  choose g hg using rid,
  obtain ⟨hg1, ⟨k, rfl⟩⟩ := hg,
  by_cases k_ineq : 0 < k,
  { erw x.1.is_prime.pow_mem_iff_mem _ k_ineq at hg1,
    exact x.2 hg1 },
  { erw [show k = 0, by linarith, pow_zero, ←ideal.eq_top_iff_one] at hg1,
    apply x.1.is_prime.1,
    exact hg1 },
end

lemma carrier_ne_top :
  carrier f_deg x ≠ ⊤ :=
begin
  have eq_top := no_intersection x,
  classical,
  contrapose! eq_top,
  obtain ⟨c, N, acd, eq1⟩ := mem_carrier.clear_denominator _ x ((ideal.eq_top_iff_one _).mp eq_top),
  rw [algebra.smul_def, subring.coe_one, mul_one] at eq1,
  change localization.mk (f ^ N) 1 = mk (∑ _, _) 1 at eq1,
  simp only [mk_eq_mk', is_localization.eq] at eq1,
  rcases eq1 with ⟨⟨_, ⟨M, rfl⟩⟩, eq1⟩,
  erw [mul_one, mul_one] at eq1,
  refine set.ne_empty_iff_nonempty.mpr ⟨f^N * f^M, eq1.symm ▸ mul_mem_right _ _
    (sum_mem _ (λ i hi, mul_mem_left _ _ _)), ⟨N+M, by rw pow_add⟩⟩,
  generalize_proofs h,
  exact (classical.some_spec h).1,
end

/--The function between the basic open set `D(f)` in `Proj` to the corresponding basic open set in
`Spec A⁰_f`. This is bundled into a continuous map in `Top_component.forward`.
-/
def to_fun : (Proj.T| (pbo f)) → (Spec.T (A⁰_ f_deg)) := λ x,
⟨carrier f_deg x, carrier_ne_top f_deg x, λ x1 x2 hx12, begin
  haveI : decidable_eq (away f) := classical.dec_eq _,
  rcases ⟨x1, x2⟩ with ⟨⟨x1, hx1⟩, ⟨x2, hx2⟩⟩,
  induction x1 using localization.induction_on with data_x1,
  induction x2 using localization.induction_on with data_x2,
  rcases ⟨data_x1, data_x2⟩ with ⟨⟨a1, _, ⟨n1, rfl⟩⟩, ⟨a2, _, ⟨n2, rfl⟩⟩⟩,
  rcases mem_carrier.clear_denominator f_deg x hx12 with ⟨c, N, acd, eq1⟩,
  simp only [subring.coe_mul, localization.mk_mul, mul_one, algebra.smul_def, subtype.coe_mk] at eq1,
  change localization.mk (f ^ N) 1 * mk _ (⟨f ^ n1 * f ^ n2, _⟩) = mk (∑ _, _) _ at eq1,
  rw [mk_mul, one_mul] at eq1,
  simp only [mk_mul, mk_eq_mk', is_localization.eq] at eq1,
  rcases eq1 with ⟨⟨_, ⟨M, rfl⟩⟩, eq1⟩,
  rw [submonoid.coe_one, mul_one] at eq1,
  simp only [← subtype.val_eq_coe, submonoid.coe_mul] at eq1,

  rcases x.1.is_prime.mem_or_mem (show a1 * a2 * f ^ N * f ^ M ∈ _, from _) with h1|rid2,
  rcases x.1.is_prime.mem_or_mem h1 with h1|rid1,
  rcases x.1.is_prime.mem_or_mem h1 with h1|h2,
  { left,
    rw mem_carrier_iff,
    simp only [show (mk a1 ⟨f ^ n1, _⟩ : away f) = mk a1 1 * mk 1 ⟨f^n1, ⟨n1, rfl⟩⟩,
      by rw [localization.mk_mul, mul_one, one_mul]],
    exact ideal.mul_mem_right _ _ (ideal.subset_span ⟨_, h1, rfl⟩), },
  { right,
    rw mem_carrier_iff,
    simp only [show (mk a2 ⟨f ^ n2, _⟩ : away f) = mk a2 1 * mk 1 ⟨f^n2, ⟨n2, rfl⟩⟩,
      by rw [localization.mk_mul, mul_one, one_mul]],
    exact ideal.mul_mem_right _ _ (ideal.subset_span ⟨_, h2, rfl⟩), },
  { exact false.elim (x.2 (x.1.is_prime.mem_of_pow_mem N rid1)), },
  { exact false.elim (x.2 (x.1.is_prime.mem_of_pow_mem M rid2)), },
  { rw [mul_comm _ (f^N), eq1],
    refine mul_mem_right _ _ (mul_mem_right _ _ (sum_mem _ (λ i hi, mul_mem_left _ _ _))),
    generalize_proofs h,
    exact (classical.some_spec h).1 },
end⟩

/-
The preimage of basic open set `D(a/f^n)` in `Spec A⁰_f` under the forward map from `Proj A` to
`Spec A⁰_f` is the basic open set `D(a) ∩ D(f)` in  `Proj A`. This lemma is used to prove that the
forward map is continuous.
-/
lemma preimage_eq (a : A) (n : ℕ)
  (a_mem_degree_zero : (mk a ⟨f ^ n, ⟨n, rfl⟩⟩ : away f) ∈ A⁰_ f_deg) :
  to_fun 𝒜 f_deg ⁻¹'
      (sbo (⟨mk a ⟨f ^ n, ⟨_, rfl⟩⟩, a_mem_degree_zero⟩ : A⁰_ f_deg)).1
  = {x | x.1 ∈ (pbo f) ⊓ (pbo a)} :=
begin
  haveI : decidable_eq (away f) := classical.dec_eq _,
  ext1 y, split; intros hy,
  { refine ⟨y.2, _⟩,
    rw [set.mem_preimage, subtype.val_eq_coe, opens.mem_coe, prime_spectrum.mem_basic_open] at hy,
    rw projective_spectrum.mem_coe_basic_open,
    intro a_mem_y,
    apply hy,
    rw [to_fun, mem_carrier_iff],
    simp only [show (mk a ⟨f^n, ⟨_, rfl⟩⟩ : away f) = mk 1 ⟨f^n, ⟨_, rfl⟩⟩ * mk a 1,
      by rw [mk_mul, one_mul, mul_one]],
    exact ideal.mul_mem_left _ _ (ideal.subset_span ⟨_, a_mem_y, rfl⟩), },
  { change y.1 ∈ _ at hy,
    rcases hy with ⟨hy1, hy2⟩,
    rw projective_spectrum.mem_coe_basic_open at hy1 hy2,
    rw [set.mem_preimage, to_fun, subtype.val_eq_coe, opens.mem_coe, prime_spectrum.mem_basic_open],
    intro rid,
    rcases mem_carrier.clear_denominator f_deg _ rid with ⟨c, N, acd, eq1⟩,
    rw [algebra.smul_def] at eq1,
    change localization.mk (f^N) 1 * mk _ _ = mk (∑ _, _) _ at eq1,
    rw [mk_mul, one_mul, mk_eq_mk', is_localization.eq] at eq1,
    rcases eq1 with ⟨⟨_, ⟨M, rfl⟩⟩, eq1⟩,
    rw [submonoid.coe_one, mul_one] at eq1,
    simp only [subtype.coe_mk] at eq1,

    rcases y.1.is_prime.mem_or_mem (show a * f ^ N * f ^ M ∈ _, from _) with H1 | H3,
    rcases y.1.is_prime.mem_or_mem H1 with H1 | H2,
    { exact hy2 H1, },
    { exact y.2 (y.1.is_prime.mem_of_pow_mem N H2), },
    { exact y.2 (y.1.is_prime.mem_of_pow_mem M H3), },
    { rw [mul_comm _ (f^N), eq1],
      refine mul_mem_right _ _ (mul_mem_right _ _ (sum_mem _ (λ i hi, mul_mem_left _ _ _))),
      generalize_proofs h,
      exact (classical.some_spec h).1, }, },
end

end to_Spec

section

variable {𝒜}

/--The continuous function between the basic open set `D(f)` in `Proj` to the corresponding basic
open set in `Spec A⁰_f`.
-/
def to_Spec {f : A} (m : ℕ) (f_deg : f ∈ 𝒜 m) :
  (Proj.T| (pbo f)) ⟶ (Spec.T (A⁰_ f_deg)) :=
{ to_fun := to_Spec.to_fun 𝒜 f_deg,
  continuous_to_fun := begin
    apply is_topological_basis.continuous (prime_spectrum.is_topological_basis_basic_opens),
    rintros _ ⟨⟨g, hg⟩, rfl⟩,
    induction g using localization.induction_on with data,
    obtain ⟨a, ⟨_, ⟨n, rfl⟩⟩⟩ := data,

    erw to_Spec.preimage_eq,
    refine is_open_induced_iff.mpr ⟨(pbo f).1 ⊓ (pbo a).1, is_open.inter (pbo f).2 (pbo a).2, _⟩,
    ext z, split; intros hz; simpa [set.mem_preimage],
  end }

end

end Proj_iso_Spec_Top_component

end algebraic_geometry


import Categories.Functor
import Categories.Initial

set_option autoImplicit false

namespace Mathematics

section
  variable (C : Category) {a b c : C.obj}

  def isProduct (π₁ : Hom C c a) (π₂ : Hom C c b) :=
  ∀ (x : C.obj) (f₁ : Hom C x a) (f₂ : Hom C x b), ∃! (f : Hom C x c), π₁ ∘ f = f₁ ∧ π₂ ∘ f = f₂

  def isCoproduct (i : Hom C a c) (j : Hom C b c) :=
  isProduct Cᵒᵖ i j
end

class HasCoproducts (C : Category) :=
(μ        : C.obj → C.obj → C.obj)
(inl      : Π x y, Hom C x (μ x y))
(inr      : Π x y, Hom C y (μ x y))
(property : Π x y, isCoproduct C (inl x y) (inr x y))

instance (C : Category) [H : HasCoproducts C] : Add C.obj := ⟨H.μ⟩
open HasCoproducts (inl inr)

namespace HasCoproducts
  variable {C : Category} [HasCoproducts C] {a b c : C.obj} (f : Hom C a c) (g : Hom C b c)

  def recur : Hom C (a + b) c :=
  (HasCoproducts.property a b c f g).val

  def recurβ₁ : recur f g ∘ inl a b = f :=
  (HasCoproducts.property a b c f g).property.left.left

  def recurβ₂ : recur f g ∘ inr a b = g :=
  (HasCoproducts.property a b c f g).property.left.right

  def uniq : ∀ (φ : Hom C (a + b) c), φ ∘ inl a b = f → φ ∘ inr a b = g → recur f g = φ :=
  λ _ h₁ h₂, (HasCoproducts.property _ _ _ _ _).property.right _ (And.intro h₁ h₂)

  def prop : ∀ (φ ψ : Hom C (a + b) c), φ ∘ inl a b = f → φ ∘ inr a b = g → ψ ∘ inl a b = f → ψ ∘ inr a b = g → φ = ψ :=
  begin intros; apply Eq.trans; apply Eq.symm; repeat { apply uniq <;> assumption } end

  def comm {d : C.obj} (h : Hom C c d) : recur (h ∘ f) (h ∘ g) = h ∘ recur f g :=
  begin apply uniq <;> rw [C.assoc]; rw [recurβ₁]; rw [recurβ₂] end
end HasCoproducts

section
  variable {C : Category} [HasCoproducts C] {a₁ a₂ b₁ b₂ : C.obj} (f : Hom C a₁ a₂) (g : Hom C b₁ b₂)

  def madd : Hom C (a₁ + b₁) (a₂ + b₂) :=
  HasCoproducts.recur (inl _ _ ∘ f) (inr _ _ ∘ g)

  lemma maddInl : madd f g ∘ inl a₁ b₁ = inl a₂ b₂ ∘ f :=
  HasCoproducts.recurβ₁ _ _

  lemma maddInr : madd f g ∘ inr a₁ b₁ = inr a₂ b₂ ∘ g :=
  HasCoproducts.recurβ₂ _ _
end

lemma maddId {C : Category} [HasCoproducts C] (a b : C.obj) : madd (C.id a) (C.id b) = 1 :=
begin apply HasCoproducts.uniq <;> rw [C.rid] <;> apply C.lid end

theorem maddCom {C : Category} [HasCoproducts C] {a₁ a₂ a₃ b₁ b₂ b₃ : C.obj}
  (f₁ : Hom C a₂ a₃) (g₁ : Hom C b₂ b₃) (f₂ : Hom C a₁ a₂) (g₂ : Hom C b₁ b₂) :
  madd f₁ g₁ ∘ madd f₂ g₂ = madd (f₁ ∘ f₂) (g₁ ∘ g₂) :=
begin
  apply Eq.symm; apply HasCoproducts.uniq;
  { apply Eq.trans; apply C.assoc; rw [maddInl, ←C.assoc, maddInl]; apply C.assoc };
  { apply Eq.trans; apply C.assoc; rw [maddInr, ←C.assoc, maddInr]; apply C.assoc }
end

theorem maddRec {C : Category} [HasCoproducts C] {a₁ a₂ b₁ b₂ c : C.obj}
  (f : Hom C a₁ a₂) (g : Hom C b₁ b₂) (φ : Hom C a₂ c) (ψ : Hom C b₂ c) :
  HasCoproducts.recur φ ψ ∘ madd f g = HasCoproducts.recur (φ ∘ f) (ψ ∘ g) :=
begin
  apply Eq.symm; apply HasCoproducts.uniq <;> rw [C.assoc];
  rw [maddInl, ←C.assoc, HasCoproducts.recurβ₁];
  rw [maddInr, ←C.assoc, HasCoproducts.recurβ₂]
end

section
  variable {A B : Category} [HasCoproducts B] (F G : Functor A B)

  def Functor.add : Functor A B :=
  { apply := λ i, F i + G i,
    map   := λ φ, madd (F.map φ) (G.map φ),
    idm   := begin
               intros; apply (HasCoproducts.property _ _ _ _ _).property.right; constructor;
               { rw [F.idm]; apply Eq.trans; apply B.lid; apply Eq.symm; apply B.rid };
               { rw [G.idm]; apply Eq.trans; apply B.lid; apply Eq.symm; apply B.rid }
             end,
    com   := begin
               intros; apply (HasCoproducts.property _ _ _ _ _).property.right; constructor;
               { rw [F.com]; apply Eq.trans; apply B.assoc; simp [*];
                 rw [maddInl, ←B.assoc, maddInl]; apply B.assoc };
               { rw [G.com]; apply Eq.trans; apply B.assoc; simp [*];
                 rw [maddInr, ←B.assoc, maddInr]; apply B.assoc }
             end }

  def Natural.inl : Natural F (Functor.add F G) :=
  ⟨λ _, HasCoproducts.inl _ _, λ _, Eq.symm (maddInl _ _)⟩

  def Natural.inr : Natural G (Functor.add F G) :=
  ⟨λ _, HasCoproducts.inr _ _, λ _, Eq.symm (maddInr _ _)⟩

  variable {H : Functor A B} (η : Natural F H) (ε : Natural G H)

  def Natural.recur : Natural (Functor.add F G) H :=
  ⟨λ x, HasCoproducts.recur (η x) (ε x),
   begin
     intros a b f; apply Eq.trans; apply maddRec; apply HasCoproducts.uniq;
     rw [B.assoc, HasCoproducts.recurβ₁, η.property];
     rw [B.assoc, HasCoproducts.recurβ₂, ε.property]
   end⟩

  def Natural.recurβ₁ : Natural.vert (Natural.recur F G η ε) (Natural.inl F G) = η :=
  begin apply Subtype.eq; funext _; apply HasCoproducts.recurβ₁ end

  def Natural.recurβ₂ : Natural.vert (Natural.recur F G η ε) (Natural.inr F G) = ε :=
  begin apply Subtype.eq; funext _; apply HasCoproducts.recurβ₂ end

  def Natural.uniq (φ : Natural (Functor.add F G) H) (h₁ : vert φ (inl F G) = η) (h₂ : vert φ (inr F G) = ε) : Natural.recur F G η ε = φ :=
  begin apply Subtype.eq; funext _; subst h₁; subst h₂; apply HasCoproducts.uniq <;> rfl end
end

def isAdditive {A B : Category} (F : Functor A B) :=
∀ (a b c : A.obj) (i : Hom A a c) (j : Hom A b c), isCoproduct A i j → isCoproduct B (F.map i) (F.map j)

def coproductIso {C : Category} {a b c₁ c₂ : C.obj} (f₁ : Hom C a c₁) (g₁ : Hom C b c₁) (f₂ : Hom C a c₂) (g₂ : Hom C b c₂)
  (φ : c₁ ≅ c₂) : φ.1 ∘ f₁ = f₂ → φ.1 ∘ g₁ = g₂ → isCoproduct C f₁ g₁ → isCoproduct C f₂ g₂ :=
begin
  intro H₁ H₂ H c h₁ h₂; apply Subtype.mk _ _;
  { apply _ ∘ φ.2.1; apply (H _ h₁ h₂).1 }; constructor;
  { constructor <;> show C.com _ _ = _;
    { rw [C.assoc, ←isoInterchange₁ H₁]; apply (H _ _ _).2.1.1 };
    { rw [C.assoc, ←isoInterchange₁ H₂]; apply (H _ _ _).2.1.2 } };
  { intro y G; apply isoEpic φ; rw [C.assoc, φ.2.2.2];
    apply Eq.trans (C.rid _); apply (H _ _ _).2.2;
    constructor <;> show C.com _ _ = _ <;> rw [C.assoc];
    { rw [H₁]; apply G.1 }; { rw [H₂]; apply G.2 } }
end

def coproductUniq {C : Category} {a b c₁ c₂ : C.obj} (f₁ : Hom C a c₁) (g₁ : Hom C b c₁)
  (f₂ : Hom C a c₂) (g₂ : Hom C b c₂) : isCoproduct C f₁ g₁ → isCoproduct C f₂ g₂ → c₁ ≅ c₂ :=
begin
  intro H₁ H₂; exists (H₁ c₂ f₂ g₂).1; exists (H₂ c₁ f₁ g₁).1; constructor;
  { apply Eq.trans; apply Eq.symm; apply (H₂ c₂ f₂ g₂).2.2; constructor;
    { apply Eq.trans; apply C.assoc; apply Eq.trans; apply congrArg;
      apply (H₂ c₁ f₁ g₁).2.1.1; apply (H₁ _ _ _).2.1.1 };
    { apply Eq.trans; apply C.assoc; apply Eq.trans; apply congrArg;
      apply (H₂ c₁ f₁ g₁).2.1.2; apply (H₁ _ _ _).2.1.2 };
    apply (H₂ c₂ f₂ g₂).2.2; constructor <;> apply C.lid };
  { apply Eq.trans; apply Eq.symm; apply (H₁ c₁ f₁ g₁).2.2; constructor;
    { apply Eq.trans; apply C.assoc; apply Eq.trans; apply congrArg;
      apply (H₁ c₂ f₂ g₂).2.1.1; apply (H₂ _ _ _).2.1.1 };
    { apply Eq.trans; apply C.assoc; apply Eq.trans; apply congrArg;
      apply (H₁ c₂ f₂ g₂).2.1.2; apply (H₂ _ _ _).2.1.2 };
    apply (H₁ c₁ f₁ g₁).2.2; constructor <;> apply C.lid }
end

def additiveCriteria {A B : Category} [HasCoproducts A] [HasCoproducts B]
  (F : Functor A B) (H : ∀ x y, F x + F y ≅ F (x + y))
  (G₁ : ∀ x y, (H x y).1 ∘ inl (F x) (F y) = F.map (inl x y))
  (G₂ : ∀ x y, (H x y).1 ∘ inr (F x) (F y) = F.map (inr x y)) : isAdditive F :=
begin
  intro a b c i j G; apply coproductIso (inl _ _) (inr _ _) (F.map i) (F.map j) _ _ _ _;
  apply Iso.trans; apply H; apply functorIso; apply coproductUniq;
  apply HasCoproducts.property; apply G;
  { apply Eq.trans; apply B.assoc; rw [G₁ a b];
    apply Eq.trans; apply Eq.symm (F.com _ _);
    apply congrArg; apply HasCoproducts.recurβ₁ };
  { apply Eq.trans; apply B.assoc; rw [G₂ a b];
    apply Eq.trans; apply Eq.symm (F.com _ _);
    apply congrArg; apply HasCoproducts.recurβ₂ };
  apply HasCoproducts.property
end

def additiveIso {A B : Category} [HasCoproducts A] [HasCoproducts B] {F : Functor A B}
  (H : isAdditive F) {x y : A.obj} : F x + F y ≅ F (x + y) :=
begin apply coproductUniq; apply HasCoproducts.property; apply H; apply HasCoproducts.property end

def coproductInitialLeft {C : Category} [HasCoproducts C] (a b : C.obj) (H : isInitial C b) : a + b ≅ a :=
begin
  exists HasCoproducts.recur (C.id a) (H a).inh; exists inl _ _;
  constructor; apply HasCoproducts.recurβ₁;
  { apply HasCoproducts.prop;
    { show _ = inl _ _; rw [C.assoc, HasCoproducts.recurβ₁]; apply C.rid };
    { show _ = inr _ _; rw [C.assoc, HasCoproducts.recurβ₂]; apply (H _).prop };
    repeat { apply C.lid } }
end

def coproductInitialRight {C : Category} [HasCoproducts C] (a b : C.obj) (H : isInitial C a) : a + b ≅ b :=
begin
  exists HasCoproducts.recur (H b).inh (C.id b); exists inr _ _;
  constructor; apply HasCoproducts.recurβ₂;
  { apply HasCoproducts.prop;
    { show _ = inl _ _; rw [C.assoc, HasCoproducts.recurβ₁]; apply (H _).prop };
    { show _ = inr _ _; rw [C.assoc, HasCoproducts.recurβ₂]; apply C.rid };
    repeat { apply C.lid } }
end

def coproductComm {C : Category} [HasCoproducts C] (a b : C.obj) : a + b ≅ b + a :=
begin
  exists HasCoproducts.recur (inr b a) (inl b a);
  exists HasCoproducts.recur (inr a b) (inl a b);
  constructor <;>
  { apply HasCoproducts.prop;
    { show _ = inl _ _; rw [C.assoc, HasCoproducts.recurβ₁, HasCoproducts.recurβ₂] };
    { show _ = inr _ _; rw [C.assoc, HasCoproducts.recurβ₂, HasCoproducts.recurβ₁] };
    repeat { apply C.lid } };
end

def coproductAssoc {C : Category} [HasCoproducts C] (a b c : C.obj) : a + (b + c) ≅ (a + b) + c :=
begin
  exists HasCoproducts.recur (inl _ _ ∘ inl _ _) (HasCoproducts.recur (inl _ _ ∘ inr _ _) (inr _ _));
  exists HasCoproducts.recur (HasCoproducts.recur (inl _ _) (inr _ _ ∘ inl _ _)) (inr _ _ ∘ inr _ _); constructor;
  { apply HasCoproducts.prop;
    { show _ = inl _ _; rw [C.assoc, HasCoproducts.recurβ₁]; apply HasCoproducts.prop;
      { show _ = inl _ _ ∘ inl _ _; rw [C.assoc, HasCoproducts.recurβ₁]; apply HasCoproducts.recurβ₁ };
      { show _ = inl _ _ ∘ inr _ _; rw [C.assoc, HasCoproducts.recurβ₂, ←C.assoc, HasCoproducts.recurβ₂]; apply HasCoproducts.recurβ₁ }; rfl; rfl };
    { show _ = inr _ _; rw [C.assoc, HasCoproducts.recurβ₂, ←C.assoc, HasCoproducts.recurβ₂, HasCoproducts.recurβ₂] };
    repeat { apply C.lid } };
  { apply HasCoproducts.prop;
    { show _ = inl _ _; rw [C.assoc, HasCoproducts.recurβ₁, ←C.assoc, HasCoproducts.recurβ₁, HasCoproducts.recurβ₁] };
    { show _ = inr _ _; rw [C.assoc, HasCoproducts.recurβ₂]; apply HasCoproducts.prop;
      { show _ = inr _ _ ∘ inl _ _; rw [C.assoc, HasCoproducts.recurβ₁, ←C.assoc, HasCoproducts.recurβ₁]; apply HasCoproducts.recurβ₂ };
      { show _ = inr _ _ ∘ inr _ _; rw [C.assoc, HasCoproducts.recurβ₂]; apply HasCoproducts.recurβ₂ }; rfl; rfl };
    { apply C.lid };
    { apply C.lid } }
end

def coproductApLeft {C : Category} [HasCoproducts C] {a b c : C.obj} (H : a ≅ b) : c + a ≅ c + b :=
begin
  exists madd (C.id c) H.1; exists madd (C.id c) H.2.1; constructor;
  { rw [maddCom, C.lid, H.2.2.1]; apply maddId };
  { rw [maddCom, C.lid, H.2.2.2]; apply maddId }
end

def coproductApRight {C : Category} [HasCoproducts C] {a b c : C.obj} (H : a ≅ b) : a + c ≅ b + c :=
begin
  exists madd H.1 (C.id c); exists madd H.2.1 (C.id c); constructor;
  { rw [maddCom, C.lid, H.2.2.1]; apply maddId };
  { rw [maddCom, C.lid, H.2.2.2]; apply maddId }
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Mon.limits
import Mathlib.algebra.category.Group.preadditive
import Mathlib.category_theory.over
import Mathlib.category_theory.limits.concrete_category
import Mathlib.category_theory.limits.shapes.concrete_category
import Mathlib.group_theory.subgroup
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# The category of (commutative) (additive) groups has all limits

Further, these limits are preserved by the forgetful functor --- that is,
the underlying types are just the limits in the category of types.

-/

namespace Group

protected instance Mathlib.AddGroup.add_group_obj {J : Type u} [category_theory.small_category J]
    (F : J ⥤ AddGroup) (j : J) :
    add_group (category_theory.functor.obj (F ⋙ category_theory.forget AddGroup) j) :=
  id (AddGroup.add_group (category_theory.functor.obj F j))

/--
The flat sections of a functor into `Group` form a subgroup of all sections.
-/
def Mathlib.AddGroup.sections_add_subgroup {J : Type u} [category_theory.small_category J]
    (F : J ⥤ AddGroup) : add_subgroup ((j : J) → ↥(category_theory.functor.obj F j)) :=
  add_subgroup.mk (category_theory.functor.sections (F ⋙ category_theory.forget AddGroup)) sorry
    sorry sorry

protected instance limit_group {J : Type u} [category_theory.small_category J] (F : J ⥤ Group) :
    group
        (category_theory.limits.cone.X
          (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget Group))) :=
  id (subgroup.to_group (sections_subgroup F))

/--
We show that the forgetful functor `Group ⥤ Mon` creates limits.

All we need to do is notice that the limit point has a `group` instance available,
and then reuse the existing limit.
-/
protected instance category_theory.forget₂.category_theory.creates_limit {J : Type u}
    [category_theory.small_category J] (F : J ⥤ Group) :
    category_theory.creates_limit F (category_theory.forget₂ Group Mon) :=
  sorry

/--
A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)
-/
def Mathlib.AddGroup.limit_cone {J : Type u} [category_theory.small_category J] (F : J ⥤ AddGroup) :
    category_theory.limits.cone F :=
  category_theory.lift_limit
    (category_theory.limits.limit.is_limit (F ⋙ category_theory.forget₂ AddGroup AddMon))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
def Mathlib.AddGroup.limit_cone_is_limit {J : Type u} [category_theory.small_category J]
    (F : J ⥤ AddGroup) : category_theory.limits.is_limit (AddGroup.limit_cone F) :=
  category_theory.lifted_limit_is_limit
    (category_theory.limits.limit.is_limit (F ⋙ category_theory.forget₂ AddGroup AddMon))

/-- The category of groups has all limits. -/
protected instance has_limits : category_theory.limits.has_limits Group :=
  category_theory.limits.has_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_limits_of_shape.mk
        fun (F : J ⥤ Group) =>
          category_theory.has_limit_of_created F (category_theory.forget₂ Group Mon)

/--
The forgetful functor from groups to monoids preserves all limits.
(That is, the underlying monoid could have been computed instead as limits in the category
of monoids.)
-/
protected instance Mathlib.AddGroup.forget₂_AddMon_preserves_limits :
    category_theory.limits.preserves_limits (category_theory.forget₂ AddGroup AddMon) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ AddGroup) =>
          category_theory.preserves_limit_of_creates_limit_and_has_limit F
            (category_theory.forget₂ AddGroup AddMon)

/--
The forgetful functor from groups to types preserves all limits. (That is, the underlying
types could have been computed instead as limits in the category of types.)
-/
protected instance forget_preserves_limits :
    category_theory.limits.preserves_limits (category_theory.forget Group) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ Group) =>
          category_theory.limits.comp_preserves_limit (category_theory.forget₂ Group Mon)
            (category_theory.forget Mon)

end Group

namespace CommGroup

protected instance Mathlib.AddCommGroup.add_comm_group_obj {J : Type u}
    [category_theory.small_category J] (F : J ⥤ AddCommGroup) (j : J) :
    add_comm_group (category_theory.functor.obj (F ⋙ category_theory.forget AddCommGroup) j) :=
  id (AddCommGroup.add_comm_group_instance (category_theory.functor.obj F j))

protected instance limit_comm_group {J : Type u} [category_theory.small_category J]
    (F : J ⥤ CommGroup) :
    comm_group
        (category_theory.limits.cone.X
          (category_theory.limits.types.limit_cone (F ⋙ category_theory.forget CommGroup))) :=
  subgroup.to_comm_group (Group.sections_subgroup (F ⋙ category_theory.forget₂ CommGroup Group))

/--
We show that the forgetful functor `CommGroup ⥤ Group` creates limits.

All we need to do is notice that the limit point has a `comm_group` instance available,
and then reuse the existing limit.
-/
protected instance Mathlib.AddCommGroup.category_theory.forget₂.category_theory.creates_limit
    {J : Type u} [category_theory.small_category J] (F : J ⥤ AddCommGroup) :
    category_theory.creates_limit F (category_theory.forget₂ AddCommGroup AddGroup) :=
  sorry

/--
A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)
-/
def Mathlib.AddCommGroup.limit_cone {J : Type u} [category_theory.small_category J]
    (F : J ⥤ AddCommGroup) : category_theory.limits.cone F :=
  category_theory.lift_limit
    (category_theory.limits.limit.is_limit (F ⋙ category_theory.forget₂ AddCommGroup AddGroup))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
def limit_cone_is_limit {J : Type u} [category_theory.small_category J] (F : J ⥤ CommGroup) :
    category_theory.limits.is_limit (limit_cone F) :=
  category_theory.lifted_limit_is_limit
    (category_theory.limits.limit.is_limit (F ⋙ category_theory.forget₂ CommGroup Group))

/-- The category of commutative groups has all limits. -/
protected instance has_limits : category_theory.limits.has_limits CommGroup :=
  category_theory.limits.has_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_limits_of_shape.mk
        fun (F : J ⥤ CommGroup) =>
          category_theory.has_limit_of_created F (category_theory.forget₂ CommGroup Group)

/--
The forgetful functor from commutative groups to groups preserves all limits.
(That is, the underlying group could have been computed instead as limits in the category
of groups.)
-/
protected instance Mathlib.AddCommGroup.forget₂_AddGroup_preserves_limits :
    category_theory.limits.preserves_limits (category_theory.forget₂ AddCommGroup AddGroup) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ AddCommGroup) =>
          category_theory.preserves_limit_of_creates_limit_and_has_limit F
            (category_theory.forget₂ AddCommGroup AddGroup)

/--
An auxiliary declaration to speed up typechecking.
-/
def forget₂_CommMon_preserves_limits_aux {J : Type u} [category_theory.small_category J]
    (F : J ⥤ CommGroup) :
    category_theory.limits.is_limit
        (category_theory.functor.map_cone (category_theory.forget₂ CommGroup CommMon)
          (limit_cone F)) :=
  CommMon.limit_cone_is_limit (F ⋙ category_theory.forget₂ CommGroup CommMon)

/--
The forgetful functor from commutative groups to commutative monoids preserves all limits.
(That is, the underlying commutative monoids could have been computed instead as limits
in the category of commutative monoids.)
-/
protected instance forget₂_CommMon_preserves_limits :
    category_theory.limits.preserves_limits (category_theory.forget₂ CommGroup CommMon) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ CommGroup) =>
          category_theory.limits.preserves_limit_of_preserves_limit_cone (limit_cone_is_limit F)
            (forget₂_CommMon_preserves_limits_aux F)

/--
The forgetful functor from commutative groups to types preserves all limits. (That is, the
underlying types could have been computed instead as limits in the category of types.)
-/
protected instance forget_preserves_limits :
    category_theory.limits.preserves_limits (category_theory.forget CommGroup) :=
  category_theory.limits.preserves_limits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_limits_of_shape.mk
        fun (F : J ⥤ CommGroup) =>
          category_theory.limits.comp_preserves_limit (category_theory.forget₂ CommGroup Group)
            (category_theory.forget Group)

end CommGroup

namespace AddCommGroup

/--
The categorical kernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical kernel.
-/
def kernel_iso_ker {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.limits.kernel f ≅ of ↥(add_monoid_hom.ker f) :=
  category_theory.iso.mk
    (add_monoid_hom.mk
      (fun (g : ↥(category_theory.limits.kernel f)) =>
        { val := coe_fn (category_theory.limits.kernel.ι f) g, property := sorry })
      sorry sorry)
    (category_theory.limits.kernel.lift f (add_subgroup.subtype (add_monoid_hom.ker f)) sorry)

@[simp] theorem kernel_iso_ker_hom_comp_subtype {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.iso.hom (kernel_iso_ker f) ≫ add_subgroup.subtype (add_monoid_hom.ker f) =
        category_theory.limits.kernel.ι f :=
  sorry

@[simp] theorem kernel_iso_ker_inv_comp_ι {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.iso.inv (kernel_iso_ker f) ≫ category_theory.limits.kernel.ι f =
        add_subgroup.subtype (add_monoid_hom.ker f) :=
  sorry

/--
The categorical kernel inclusion for `f : G ⟶ H`, as an object over `G`,
agrees with the `subtype` map.
-/
@[simp] theorem kernel_iso_ker_over_inv_left {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.comma_morphism.left (category_theory.iso.inv (kernel_iso_ker_over f)) =
        category_theory.iso.inv (kernel_iso_ker f) :=
  Eq.refl (category_theory.iso.inv (kernel_iso_ker f))

end Mathlib


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.sheaf_of_types
import Mathlib.order.closure
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Closed sieves

A natural closure operator on sieves is a closure operator on `sieve X` for each `X` which commutes
with pullback.
We show that a Grothendieck topology `J` induces a natural closure operator, and define what the
closed sieves are. The collection of `J`-closed sieves forms a presheaf which is a sheaf for `J`,
and further this presheaf can be used to determine the Grothendieck topology from the sheaf
predicate.
Finally we show that a natural closure operator on sieves induces a Grothendieck topology, and hence
that natural closure operators are in bijection with Grothendieck topologies.

## Main definitions

* `category_theory.grothendieck_topology.close`: Sends a sieve `S` on `X` to the set of arrows
  which it covers. This has all the usual properties of a closure operator, as well as commuting
  with pullback.
* `category_theory.grothendieck_topology.closure_operator`: The bundled `closure_operator` given
  by `category_theory.grothendieck_topology.close`.
* `category_theory.grothendieck_topology.closed`: A sieve `S` on `X` is closed for the topology `J`
   if it contains every arrow it covers.
* `category_theory.functor.closed_sieves`: The presheaf sending `X` to the collection of `J`-closed
  sieves on `X`. This is additionally shown to be a sheaf for `J`, and if this is a sheaf for a
  different topology `J'`, then `J' ≤ J`.
* `category_theory.grothendieck_topology.topology_of_closure_operator`: A closure operator on the
  set of sieves on every object which commutes with pullback additionally induces a Grothendieck
  topology, giving a bijection with `category_theory.grothendieck_topology.closure_operator`.

## Tags

closed sieve, closure, Grothendieck topology

## References

* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
-/

namespace category_theory

namespace grothendieck_topology

/-- The `J`-closure of a sieve is the collection of arrows which it covers. -/
def close {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C} (S : sieve X) :
    sieve X :=
  sieve.mk (fun (Y : C) (f : Y ⟶ X) => covers J₁ S f) sorry

/-- Any sieve is smaller than its closure. -/
theorem le_close {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    (S : sieve X) : S ≤ close J₁ S :=
  fun (Y : C) (g : Y ⟶ X) (hg : coe_fn S Y g) =>
    covering_of_eq_top J₁ (sieve.pullback_eq_top_of_mem S hg)

/--
A sieve is closed for the Grothendieck topology if it contains every arrow it covers.
In the case of the usual topology on a topological space, this means that the open cover contains
every open set which it covers.

Note this has no relation to a closed subset of a topological space.
-/
def is_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    (S : sieve X) :=
  ∀ {Y : C} (f : Y ⟶ X), covers J₁ S f → coe_fn S Y f

/-- If `S` is `J₁`-closed, then `S` covers exactly the arrows it contains. -/
theorem covers_iff_mem_of_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C)
    {X : C} {S : sieve X} (h : is_closed J₁ S) {Y : C} (f : Y ⟶ X) : covers J₁ S f ↔ coe_fn S Y f :=
  { mp := h f, mpr := arrow_max J₁ f S }

/-- Being `J`-closed is stable under pullback. -/
theorem is_closed_pullback {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    {Y : C} (f : Y ⟶ X) (S : sieve X) : is_closed J₁ S → is_closed J₁ (sieve.pullback f S) :=
  sorry

/--
The closure of a sieve `S` is the largest closed sieve which contains `S` (justifying the name
"closure").
-/
theorem le_close_of_is_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    {S : sieve X} {T : sieve X} (h : S ≤ T) (hT : is_closed J₁ T) : close J₁ S ≤ T :=
  fun (Y : C) (f : Y ⟶ X) (hf : coe_fn (close J₁ S) Y f) =>
    hT f (superset_covering J₁ (sieve.pullback_monotone f h) hf)

/-- The closure of a sieve is closed. -/
theorem close_is_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    (S : sieve X) : is_closed J₁ (close J₁ S) :=
  fun (Y : C) (g : Y ⟶ X) (hg : covers J₁ (close J₁ S) g) =>
    arrow_trans J₁ g (close J₁ S) S hg fun (Z : C) (h : Z ⟶ X) (hS : coe_fn (close J₁ S) Z h) => hS

/-- The sieve `S` is closed iff its closure is equal to itself. -/
theorem is_closed_iff_close_eq_self {C : Type u} [small_category C] (J₁ : grothendieck_topology C)
    {X : C} (S : sieve X) : is_closed J₁ S ↔ close J₁ S = S :=
  sorry

theorem close_eq_self_of_is_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C)
    {X : C} {S : sieve X} (hS : is_closed J₁ S) : close J₁ S = S :=
  iff.mp (is_closed_iff_close_eq_self J₁ S) hS

/-- Closing under `J` is stable under pullback. -/
theorem pullback_close {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    {Y : C} (f : Y ⟶ X) (S : sieve X) :
    close J₁ (sieve.pullback f S) = sieve.pullback f (close J₁ S) :=
  sorry

theorem monotone_close {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C} :
    monotone (close J₁) :=
  fun (S₁ S₂ : sieve X) (h : S₁ ≤ S₂) =>
    le_close_of_is_closed J₁ (has_le.le.trans h (le_close J₁ S₂)) (close_is_closed J₁ S₂)

@[simp] theorem close_close {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    (S : sieve X) : close J₁ (close J₁ S) = close J₁ S :=
  le_antisymm (le_close_of_is_closed J₁ (le_refl (close J₁ S)) (close_is_closed J₁ S))
    (monotone_close J₁ (le_close J₁ S))

/--
The sieve `S` is in the topology iff its closure is the maximal sieve. This shows that the closure
operator determines the topology.
-/
theorem close_eq_top_iff_mem {C : Type u} [small_category C] (J₁ : grothendieck_topology C) {X : C}
    (S : sieve X) : close J₁ S = ⊤ ↔ S ∈ coe_fn J₁ X :=
  sorry

/-- A Grothendieck topology induces a natural family of closure operators on sieves. -/
@[simp] theorem closure_operator_to_preorder_hom_to_fun_apply {C : Type u} [small_category C]
    (J₁ : grothendieck_topology C) (X : C) (S : sieve X) (Y : C) (f : Y ⟶ X) :
    coe_fn (coe_fn (closure_operator.to_preorder_hom (closure_operator J₁ X)) S) Y f =
        covers J₁ S f :=
  Eq.refl (coe_fn (coe_fn (closure_operator.to_preorder_hom (closure_operator J₁ X)) S) Y f)

@[simp] theorem closed_iff_closed {C : Type u} [small_category C] (J₁ : grothendieck_topology C)
    {X : C} (S : sieve X) : S ∈ closure_operator.closed (closure_operator J₁ X) ↔ is_closed J₁ S :=
  iff.symm (is_closed_iff_close_eq_self J₁ S)

end grothendieck_topology

/--
The presheaf sending each object to the set of `J`-closed sieves on it. This presheaf is a `J`-sheaf
(and will turn out to be a subobject classifier for the category of `J`-sheaves).
-/
@[simp] theorem functor.closed_sieves_map_coe {C : Type u} [small_category C]
    (J₁ : grothendieck_topology C) (X : Cᵒᵖ) (Y : Cᵒᵖ) (f : X ⟶ Y)
    (S : Subtype fun (S : sieve (opposite.unop X)) => grothendieck_topology.is_closed J₁ S) :
    ↑(functor.map (functor.closed_sieves J₁) f S) =
        sieve.pullback (has_hom.hom.unop f) (subtype.val S) :=
  Eq.refl ↑(functor.map (functor.closed_sieves J₁) f S)

/--
The presheaf of `J`-closed sieves is a `J`-sheaf.
The proof of this is adapted from [MM92], Chatper III, Section 7, Lemma 1.
-/
theorem classifier_is_sheaf {C : Type u} [small_category C] (J₁ : grothendieck_topology C) :
    presieve.is_sheaf J₁ (functor.closed_sieves J₁) :=
  sorry

/--
If presheaf of `J₁`-closed sieves is a `J₂`-sheaf then `J₁ ≤ J₂`. Note the converse is true by
`classifier_is_sheaf` and `is_sheaf_of_le`.
-/
theorem le_topology_of_closed_sieves_is_sheaf {C : Type u} [small_category C]
    {J₁ : grothendieck_topology C} {J₂ : grothendieck_topology C}
    (h : presieve.is_sheaf J₁ (functor.closed_sieves J₂)) : J₁ ≤ J₂ :=
  sorry

/-- If being a sheaf for `J₁` is equivalent to being a sheaf for `J₂`, then `J₁ = J₂`. -/
theorem topology_eq_iff_same_sheaves {C : Type u} [small_category C] {J₁ : grothendieck_topology C}
    {J₂ : grothendieck_topology C} :
    J₁ = J₂ ↔ ∀ (P : Cᵒᵖ ⥤ Type u), presieve.is_sheaf J₁ P ↔ presieve.is_sheaf J₂ P :=
  sorry

/--
A closure (increasing, inflationary and idempotent) operation on sieves that commutes with pullback
induces a Grothendieck topology.
In fact, such operations are in bijection with Grothendieck topologies.
-/
@[simp] theorem topology_of_closure_operator_sieves {C : Type u} [small_category C]
    (c : (X : C) → closure_operator (sieve X))
    (hc :
      ∀ {X Y : C} (f : Y ⟶ X) (S : sieve X),
        coe_fn (c Y) (sieve.pullback f S) = sieve.pullback f (coe_fn (c X) S))
    (X : C) :
    coe_fn (topology_of_closure_operator c hc) X = set_of fun (S : sieve X) => coe_fn (c X) S = ⊤ :=
  Eq.refl (coe_fn (topology_of_closure_operator c hc) X)

/--
The topology given by the closure operator `J.close` on a Grothendieck topology is the same as `J`.
-/
theorem topology_of_closure_operator_self {C : Type u} [small_category C]
    (J₁ : grothendieck_topology C) :
    (topology_of_closure_operator (grothendieck_topology.closure_operator J₁)
          fun (X Y : C) => grothendieck_topology.pullback_close J₁) =
        J₁ :=
  grothendieck_topology.ext
    (funext
      fun (X : C) => set.ext fun (S : sieve X) => grothendieck_topology.close_eq_top_iff_mem J₁ S)

theorem topology_of_closure_operator_close {C : Type u} [small_category C]
    (c : (X : C) → closure_operator (sieve X))
    (pb :
      ∀ {X Y : C} (f : Y ⟶ X) (S : sieve X),
        coe_fn (c Y) (sieve.pullback f S) = sieve.pullback f (coe_fn (c X) S))
    (X : C) (S : sieve X) :
    grothendieck_topology.close (topology_of_closure_operator c pb) S = coe_fn (c X) S :=
  sorry

end Mathlib


/-|
=======
 Title
=======

Prose. *Emphasis*; **strong emphasis**; ``code``; `coq code`; `link <url>`__.
|-/

#check Bool

#print "Hello World"

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := by
  apply Iff.intro
  . intro h
    apply Or.elim (And.right h)
    . intro hq
      apply Or.inl
      apply And.intro
      . exact And.left h
      . exact hq
    . intro hr
      apply Or.inr
      apply And.intro
      . exact And.left h
      . exact hr
  . intro h
    apply Or.elim h
    . intro hpq
      apply And.intro
      . exact And.left hpq
      . apply Or.inl
        exact And.right hpq
    . intro hpr
      apply And.intro
      . exact And.left hpr
      . apply Or.inr
        exact And.right hpr


/-
This contains the definitions related to numeric expression
normalization.
-/
import ClausalExtraction.ArithTheory.ArithM
import ClausalExtraction.SimpRule
import Lean

open Lean
open Lean.Meta

namespace ClausalExtraction

namespace ArithTheory

-- | Create an int
def mkIntRefl (e:IntExpr) : Expr := mkApp (mkApp (mkConst ``rfl [levelOne]) intExpr) e

def getVarExprFn : ArithM (TheoryVar → IO IntExpr) := do
  let svc ← (read : SolverM _)
  let ref ← read
  pure (thvarExpr ref svc.varExpr)

-- @polyAddProof s poly q _ v@ returns a proof that
--   @poly.expr varExpr s + firstScalarProd s.varExpr (m, v) = (poly.add m v).expr s.varExpr@.
def getPolyAddProof (poly:Poly) (q:Int) (q_ne:q ≠ 0) (v:TheoryVar) : ArithM Expr := do
  let svc ← (read : SolverM _)
  let ref ← read
  Poly.addProof (thvarExpr ref svc.varExpr) poly q q_ne v

section Normalization

def matchBinOp (f tp : Expr) (e:Expr) : MetaM (Option (Expr × Expr)) := do
  let x ← mkFreshExprMVar tp
  let y ← mkFreshExprMVar tp
  pure $ if ← isDefEq (mkAppN f #[x, y]) e then some (x, y) else none

def matchUnaryOp (f tp : Expr) (e:Expr) : MetaM (Option Expr) := do
  let x ← mkFreshExprMVar tp
  let d := mkApp f x
  pure $ if ← isDefEq d e then some x else none

def matchOfNatNatLit (e:Expr) : MetaM (Option Nat) := do
  let acts : List (Expr → MetaM (Option Nat)) := [
    matchrule `(@OfNat.ofNat Nat $(x) _) => do
      match ← whnf x with
      | Expr.lit (Literal.natVal n) _ => pure (some n)
      | _ => pure none
   ]
  for act in acts do
    match ← act e with
    | some n =>
       return n
    | none => pure ()
  pure none

def matchIntLit (e:Expr) : MetaM (Option Int) := do
  let acts := [
    matchrule `(Int.ofNat $(x)) => do
      match ← whnf x with
      | Expr.lit (Literal.natVal n) _ => pure (some (n:Int))
      | _ => pure none,
    matchrule `(Int.negSucc $(x)) => do
      match ← whnf x with
      | Expr.lit (Literal.natVal n) _ => pure (some (Int.negSucc n))
      | _ => pure none
   ]
  for act in acts do
    match ← act e with
    | some n => return n
    | none => pure ()
  pure none

def matchOfNatofNatInt : Expr → MetaM (Option Expr) :=
  matchrule `(@OfNat.ofNat Int $(n) _) => pure (some n)

theorem int_add_poly_lemma {m x y a b c:Int}  (g : a + m*x = b) (h : b + m*y = c) : a + m*(x+y) = c := by
  rw [h.symm, g.symm, Int.mul_add, Int.add_assoc]

theorem nat_add_poly_lemma {m:Int} {x y:Nat} {a b c:Int}
    (g : a + m*OfNat.ofNat x = b) (h : b + m*OfNat.ofNat y = c) : a + m * OfNat.ofNat (x+y) = c := by
  apply int_add_poly_lemma g h

theorem sub_poly_lemma {m x y a b c:Int}  (g : a + m*x = b) (h : b + -m*y = c) : a + m*(x-y) = c := by
  rw [h.symm, g.symm]
  rw [Int.sub_to_add_neg, Int.mul_add, Int.mul_neg, Int.add_assoc]
theorem neg_poly_lemma {m x a b:Int}  (g : a + (-m)*x = b) : a + m*(-x) = b := by
  rw [g.symm, Int.mul_neg]

private theorem mul_zero_lhs_poly_lemma {m y a:Int} : a + m*(0*y) = a := by
  simp only [Int.zero_mul, Int.mul_zero, Int.add_zero]
private theorem mul_zero_rhs_poly_lemma (m x a:Int): a + m*(x*0) = a := by
  simp only [Int.add_zero, Int.mul_zero]

private theorem mul_lhs_poly_lemma {m x y a b:Int} (g: a + (m*x)*y = b) : a + m*(x*y) = b := by
  rw [Int.mul_assoc] at g
  exact g
private theorem mul_rhs_poly_lemma {m x y a b:Int} (g: a + (m*y)*x = b) : a + m*(x*y) = b := by
  rw [Int.mul_assoc, Int.mul_comm y x] at g
  exact g

theorem uninterpIntLemma {e v a m b:Int} (eq:e = v) (pr:a + m * v = b) : a + m * e = b := by
  rw [eq]
  exact pr

theorem uninterpNatLemma {e v : Nat} {a m b:Int} (eq:e = v) (pr:a + m * OfNat.ofNat v = b) : a + m * OfNat.ofNat e = b := by
  rw [eq]
  exact pr

structure AddResult where
  poly : Poly
  polyExpr : Expr
  equivProof : Expr

-- | @appendAddExprFromNat poly m _ e@ returns poly equivalent to `poly + m*OfNat.ofNat e` along with
--  proof that that poly.expr + m*e = ret.expr
private
partial def appendAddExprFromNat (m:Int) (m_ne:m ≠ 0) (e:Expr) (poly:Poly) : ArithM AddResult := do
  let varExpr ← getVarExprFn
  let aexpr ← poly.expr varExpr
  match ← matchOfNatNatLit e with
  | some x => do
    let r ←
      if xpr : (OfNat.ofNat x : Int) = 0 then
        let aexpr ← getPolyExpr poly
        let pr := mkIntRefl aexpr
        pure {
          poly := poly
          polyExpr := ← getPolyExpr poly
          equivProof := pr
        }
      else
        let y := m * x
        let svc ← (read : SolverM _)
        let pr ← Poly.addcProof varExpr poly y (Int.mul_ne_zero m_ne xpr)
        let poly := poly.addc y
        pure {
          poly := poly,
          polyExpr := ← getPolyExpr poly,
          equivProof := pr
        }
    return r
  | _ => pure ()

  -- Match addition
  let natAddConst : Expr :=
        let f := mkConst ``HAdd.hAdd [levelZero, levelZero, levelZero]
        let inst := mkAppN (mkConst ``instHAdd [levelZero]) #[natExpr, mkConst ``instAddNat]
        mkAppN f #[natExpr, natExpr, natExpr, inst]
  match ← matchBinOp natAddConst natExpr e with
  | none => pure ()
  | some (x, y) => do
    let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
          ← appendAddExprFromNat m m_ne x poly
    let { poly := poly, polyExpr := cexpr, equivProof := y_pr }
          ← appendAddExprFromNat m m_ne y poly
    let pr := mkAppN (mkConst ``nat_add_poly_lemma) #[m, x, y, aexpr, bexpr, cexpr, x_pr, y_pr]
    return { poly := poly, polyExpr := ← getPolyExpr poly, equivProof := pr }

  let ⟨v, vExpr, eq⟩ ← getVarForExpr e
  let v ← getTheoryVar (Decl.uninterpNat v)
  let pr ← poly.addProof varExpr m m_ne v
  let poly := poly.add m v
  let bexpr ← poly.expr varExpr
  let pr := mkAppN (mkConst ``uninterpNatLemma) #[e, vExpr, aexpr, m, bexpr, eq, pr]
  return { poly := poly, polyExpr := bexpr, equivProof := pr }

-- | @appendAddExprFromInt poly m _ e@ returns poly equivalent to `poly + m*e` along with proof that that
-- poly.expr + m*e = ret.expr
private
partial def appendAddExprFromInt (m:Int) (m_ne:m ≠ 0) (e:Expr) (poly:Poly) : ArithM AddResult := do
  let e ← instantiateMVars e
  let varExpr ← getVarExprFn

  match ← matchIntLit e with
  | none => pure ()
  | some x =>
    let r ←
      if xpr : x = 0 then
        let aexpr ← getPolyExpr poly
        let pr := mkIntRefl aexpr
        pure {
          poly := poly
          polyExpr := ← getPolyExpr poly
          equivProof := pr
        }
      else
        let y := m * x
        -- pr: poly + m * x * 1 = r
        let svc ← (read : SolverM _)
        let pr ← Poly.addcProof varExpr poly y (Int.mul_ne_zero m_ne xpr)
        let poly := poly.addc y
        pure {
          poly := poly,
          polyExpr := ← getPolyExpr poly,
          equivProof := pr
        }
    return r

  -- Match addition
  let aexpr ← poly.expr varExpr
  match ← matchBinOp intAddConst intExpr e with
  | none => pure ()
  | some (x, y) => do
    let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
          ← appendAddExprFromInt m m_ne x poly
    let { poly := poly, polyExpr := cexpr, equivProof := y_pr }
          ← appendAddExprFromInt m m_ne y poly
    let pr := mkAppN (mkConst ``int_add_poly_lemma) #[m, x, y, aexpr, bexpr, cexpr, x_pr, y_pr]
    return { poly := poly, polyExpr := ← getPolyExpr poly, equivProof := pr }

  -- Match sub
  match ← matchBinOp intSubConst intExpr e with
  | none => pure ()
  | some (x, y) => do
    let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
          ← appendAddExprFromInt m m_ne x poly
    let bexpr ← poly.expr varExpr
    let { poly := poly, polyExpr := cexpr, equivProof := y_pr }
          ← appendAddExprFromInt (- m) (Int.neg_ne_zero m_ne) y poly
    let pr := mkAppN (mkConst ``sub_poly_lemma) #[m, x, y, aexpr, bexpr, cexpr, x_pr, y_pr]
    return { poly := poly, polyExpr := ← getPolyExpr poly, equivProof := pr }

  -- Match negation
  let negExpr := mkAppN (mkConst ``Neg.neg [levelZero]) #[intExpr, mkConst ``Int.instNegInt]
  match ← matchUnaryOp intNegConst intExpr e with
  | none => pure ()
  | some x => do
    let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
          ← appendAddExprFromInt (-m) (Int.neg_ne_zero m_ne) x poly
    let pr := mkAppN (mkConst ``neg_poly_lemma) #[m, x, aexpr, bexpr, x_pr]
    return { poly := poly, polyExpr := ← getPolyExpr poly, equivProof := pr }

  -- Match scalar multiplication
  match ← matchBinOp intMulConst intExpr e with
  | none => pure ()
  | some (x, y) => do
    -- Match first term is int literal.
    match ← matchIntLit x with
    | none => pure ()
    | some xn =>
      let r ←
        if xn_ne:xn = 0 then
          let pr := mkAppN (mkConst ``mul_zero_lhs_poly_lemma) #[m, y, aexpr]
          -- aexpr + m*(0*y) = aexpr
          pure { poly := poly, polyExpr := aexpr, equivProof := pr }
        else
          -- y_eq: aexpr + (m*x)*y = poly'.expr
          let { poly := poly, polyExpr := bexpr, equivProof := y_pr }
                ← appendAddExprFromInt (m * xn) (Int.mul_ne_zero m_ne xn_ne) y poly
          let pr := mkAppN (mkConst ``mul_lhs_poly_lemma) #[m, x, y, aexpr, bexpr, y_pr]
          pure { poly := poly, polyExpr := bexpr, equivProof := pr }
      return r
    -- Match second term is int literal.
    match ← matchIntLit y with
    | none => pure ()
    | some yn =>
      let r ←
        if n_ne:yn = 0 then
          let pr := mkAppN (mkConst ``mul_zero_rhs_poly_lemma) #[m, x, aexpr]
          pure { poly := poly, polyExpr := aexpr, equivProof := pr }
        else
          let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
                ← appendAddExprFromInt (m * yn) (Int.mul_ne_zero m_ne n_ne) x poly
          let { poly := poly, polyExpr := bexpr, equivProof := x_pr }
                ← appendAddExprFromInt (m * yn) (Int.mul_ne_zero m_ne n_ne) x poly
          let pr := mkAppN (mkConst ``mul_rhs_poly_lemma) #[m, x, y, aexpr, bexpr, x_pr]
          pure { poly := poly, polyExpr := bexpr, equivProof := pr }
      return r

  match ← matchOfNatofNatInt e with
  | none => pure ()
  | some e => do
    return ← appendAddExprFromNat m m_ne e poly

  let ⟨v, vExpr, eq⟩ ← getVarForExpr e
  let v ← getTheoryVar (Decl.uninterpInt v)
  let pr ← getPolyAddProof poly m m_ne v
  let poly := poly.add m v
  let bexpr ← getPolyExpr poly
  let pr := mkAppN (mkConst ``uninterpIntLemma) #[e, vExpr, aexpr, m, bexpr, eq, pr]
  pure { poly := poly, polyExpr := bexpr, equivProof := pr }

theorem purifyIntLemmaPoly {x y:Int} (p:0 + 1 * x = y) : x = y := by
  simp [Int.zero_add, Int.one_mul] at p
  exact p

theorem purifyIntLemmaVar {x y:Int} (p:0 + 1 * x = 1 * y) : x = y :=
  Eq.trans (purifyIntLemmaPoly p) (Int.one_mul y)

-- | This traverses an expression (which should have type int) to normalize
-- the expression.  It produces a variable along with a proof that
-- e = v.expr
def purifyIntExpr (e:Expr) : ArithM (VarDefinition TheoryVar) := do
  let e ← instantiateMVars e
  let one_ne : (1:Int) ≠ 0 := by simp only [ne_eq]
  let r ← appendAddExprFromInt 1 one_ne e Poly.zero
  -- pr  has type" 0 + 1 * e = p.expr"
--  let { poly := p, polyExpr := pexpr := equivProof := pr} := r

  match r.poly with
  | ⟨#[(1, v)]⟩ => do
    -- Make pr have type e = v
    let ve ← getThvarExpr v
    let pr := mkAppN (mkConst ``purifyIntLemmaVar) #[e, ve, r.equivProof]
    pure {var := v, varExpr := ve, eq := r.equivProof }
  | p => do
    let v ← getPolyVar p
    -- Make pr have type e = v
    let pr := mkAppN (mkConst ``purifyIntLemmaPoly) #[e, r.polyExpr, r.equivProof]
    pure {var := v, varExpr := r.polyExpr, eq := pr }

end Normalization

def ops (r:IO.Ref State) : TheoryOps :=
  { varExpr := mthvarExpr r,
    predExpr := ArithTheory.predExpr r
  }

section PredicateNormalizationLemmas

theorem nat_lt_prop {x y : Nat} (p : x < y)
  : Int.NonNeg (OfNat.ofNat y - OfNat.ofNat (x + 1)) := Int.nonNeg_of_nat_le p
def nat_ge_prop {x y : Nat} (p : x ≥ y) := Int.nonNeg_of_nat_le p
def nat_gt_prop {x y : Nat} (p : x > y) := Int.nonNeg_of_nat_le p

theorem nat_not_le_prop {x y : Nat} (p : ¬(x ≤ y)) : Int.NonNeg (OfNat.ofNat x - OfNat.ofNat (y + 1)) :=
  match Nat.lt_or_ge y x with
  | Or.inl q => Int.nonNeg_of_nat_le q
  | Or.inr q => False.elim (p q)
theorem nat_not_lt_prop {x y : Nat} (p : ¬(x < y))
  : Int.NonNeg (OfNat.ofNat x - OfNat.ofNat y) :=
  match Nat.lt_or_ge x y with
  | Or.inl q => False.elim (p q)
  | Or.inr q => Int.nonNeg_of_nat_le q
def nat_not_ge_prop {x y : Nat} (p : ¬(x ≥ y)) := nat_not_le_prop p
def nat_not_gt_prop {x y : Nat} (p : ¬(x > y)) := nat_not_lt_prop p

theorem int_le_prop {x y : Int} (p : x ≤ y) : Int.NonNeg (y - x) := p
theorem int_lt_prop {x y : Int} (p : x < y) : Int.NonNeg (y - (x + 1)) := p
def int_ge_prop {x y : Int} (p : x ≥ y) := int_le_prop p
def int_gt_prop {x y : Int} (p : x > y) := int_lt_prop p

theorem int_not_le_prop {x y : Int} (p : ¬(x ≤ y))
  : Int.NonNeg (x - (y + 1)) :=
  match Int.lt_or_ge y x with
  | Or.inl q => int_lt_prop q
  | Or.inr q => False.elim (p q)

theorem int_not_lt_prop {x y : Int} (p : ¬(x < y))
  : Int.NonNeg (x - y) :=
  match Int.lt_or_ge x y with
  | Or.inl q => False.elim (p q)
  | Or.inr q => int_le_prop q
def int_not_ge_prop {x y : Int} (p : ¬(x ≥ y)) := int_not_le_prop p
def int_not_gt_prop {x y : Int} (p : ¬(x > y)) := int_not_lt_prop p

theorem int_eq_prop (x y : Int) (p : x = y)
  : x - y = 0 := by simp [p, Int.sub_self]

theorem nat_eq_prop {x y : Nat} (p : x = y)
  : @OfNat.ofNat Int x _ - OfNat.ofNat y = 0 := by
    apply int_eq_prop
    simp only [OfNat.ofNat, p]

theorem int_not_eq_prop {x y : Int} (p : ¬(x = y))  : ¬(x - y = 0) := by
  intro q
  apply p (Int.sub_eq_zero_implies_eq q)

theorem nat_not_eq_prop {x y : Nat} (p : ¬(x = y))
  : ¬(@OfNat.ofNat Int x _ - OfNat.ofNat y = 0) := by
  apply int_not_eq_prop
  simp only [OfNat.ofNat, Int.ofNat.injEq]
  exact p

def transformerNames : Array Name :=
  #[
    ``nat_eq_prop,
    ``nat_lt_prop,
    ``Int.nonNeg_of_nat_le,
    ``nat_gt_prop,
    ``nat_ge_prop,
    ``nat_not_eq_prop,
    ``nat_not_lt_prop,
    ``nat_not_le_prop,
    ``nat_not_gt_prop,
    ``nat_not_ge_prop,
    ``int_eq_prop,
    ``int_lt_prop,
    ``int_le_prop,
    ``int_gt_prop,
    ``int_ge_prop,
    ``int_not_eq_prop,
    ``int_not_lt_prop,
    ``int_not_le_prop,
    ``int_not_gt_prop,
    ``int_not_ge_prop
  ]

end PredicateNormalizationLemmas

-- Lemma used for convert proofs from one type of predicate to another.
private theorem intNonNeg_lemma {x y :Int} (eq:x = y) (p:Int.NonNeg x) : Int.NonNeg y := eq.subst p
private theorem intEq0_lemma {x y :Int} (eq:x = y) (p:x = 0) : y = 0 := @Eq.subst Int (λd => d = 0) _ _ eq p
private theorem intNe0_lemma {x y :Int} (eq:x = y) (p:¬(x = 0)) : ¬(y = 0) := @Eq.subst Int (λd => ¬(d = 0)) _ _ eq p

-- | Match `(Int.NonNeg e) and return proof term and property.
def matchIntNonNeg (r:IO.Ref ArithTheory.State)  (prop : Expr) : SolverM (Option (TheoryPred × Expr)) := do
  let mvar ← mkFreshExprMVar intExpr MetavarKind.natural `n
  unless ← isDefEq (mkIntNonNegExpr mvar) prop do
    return none
  let res ← purifyIntExpr mvar r
  let pred ← getTheoryPred (Pred.IsGe0 res.var) r
  let proofFn := mkAppN (mkConst ``intNonNeg_lemma) #[mvar, ← getThvarExpr res.var r, res.eq]
  return (some (pred, proofFn))

-- | Match `(Int.NonNeg e) and return proof term and property.
def matchIntNonNeg2 (r:IO.Ref ArithTheory.State) : Expr → SolverM (Option (TheoryPred × Expr)) :=
  matchrule `(Int.NonNeg $(mvar)) => do
    let res ← purifyIntExpr mvar r
    let pred ← getTheoryPred (Pred.IsGe0 res.var) r
    let proofFn := mkAppN (mkConst ``intNonNeg_lemma) #[mvar, ← getThvarExpr res.var r, res.eq]
    return (some (pred, proofFn))

def matchIntEq0 (r:IO.Ref ArithTheory.State) (prop : Expr) : SolverM (Option (TheoryPred × Expr)) := do
  let mvar ← mkFreshExprMVar intExpr MetavarKind.natural `n
  unless ← isDefEq (mkIntEq0Expr mvar) prop do
    return none
  let res ← purifyIntExpr mvar r
  let proofFn := mkAppN (mkConst ``intEq0_lemma) #[mvar, ← getThvarExpr res.var r, res.eq]
  return (some (← getTheoryPred (Pred.IsEq0 res.var) r, proofFn))

def matchNotIntEq0 (r:IO.Ref ArithTheory.State) (prop : Expr) : SolverM (Option (TheoryPred × Expr)) := do
  let mvar ← mkFreshExprMVar intExpr MetavarKind.natural `n
  unless ← isDefEq (mkApp (mkConst ``Not) (mkIntEq0Expr mvar)) prop do
    return none
  let res ← purifyIntExpr mvar r
  let proofFn := mkAppN (mkConst ``intNe0_lemma) #[mvar, ← getThvarExpr res.var r, res.eq]
  return (some (← getTheoryPred (Pred.IsNe0 res.var) r, proofFn))

end ArithTheory
end ClausalExtraction


/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.nat.cast.with_top
import ring_theory.prime
import ring_theory.polynomial.content
import ring_theory.ideal.quotient_operations
/-!
# Eisenstein's criterion

A proof of a slight generalisation of Eisenstein's criterion for the irreducibility of
a polynomial over an integral domain.
-/

open polynomial ideal.quotient
variables {R : Type*} [comm_ring R]

namespace polynomial
open_locale polynomial
namespace eisenstein_criterion_aux
/- Section for auxiliary lemmas used in the proof of `irreducible_of_eisenstein_criterion`-/

lemma map_eq_C_mul_X_pow_of_forall_coeff_mem {f : R[X]} {P : ideal R}
  (hfP : ∀ (n : ℕ), ↑n < f.degree → f.coeff n ∈ P) :
  map (mk P) f = C ((mk P) f.leading_coeff) * X ^ f.nat_degree :=
polynomial.ext (λ n, begin
  by_cases hf0 : f = 0, { simp [hf0], },
  rcases lt_trichotomy ↑n (degree f) with h | h | h,
  { erw [coeff_map, eq_zero_iff_mem.2 (hfP n h), coeff_C_mul, coeff_X_pow, if_neg, mul_zero],
    rintro rfl, exact not_lt_of_ge degree_le_nat_degree h },
  { have : nat_degree f = n, from nat_degree_eq_of_degree_eq_some h.symm,
    rw [coeff_C_mul, coeff_X_pow, if_pos this.symm, mul_one, leading_coeff, this, coeff_map] },
  { rw [coeff_eq_zero_of_degree_lt, coeff_eq_zero_of_degree_lt],
    { refine lt_of_le_of_lt (degree_C_mul_X_pow_le _ _) _,
      rwa ← degree_eq_nat_degree hf0 },
    { exact lt_of_le_of_lt (degree_map_le _ _) h } }
end)

lemma le_nat_degree_of_map_eq_mul_X_pow {n : ℕ}
  {P : ideal R} (hP : P.is_prime) {q : R[X]} {c : polynomial (R ⧸ P)}
  (hq : map (mk P) q = c * X ^ n) (hc0 : c.degree = 0) : n ≤ q.nat_degree :=
with_bot.coe_le_coe.1
  (calc ↑n = degree (q.map (mk P)) :
      by rw [hq, degree_mul, hc0, zero_add, degree_pow, degree_X, nsmul_one, nat.cast_with_bot]
      ... ≤ degree q : degree_map_le _ _
      ... ≤ nat_degree q : degree_le_nat_degree)

lemma eval_zero_mem_ideal_of_eq_mul_X_pow {n : ℕ} {P : ideal R}
  {q : R[X]} {c : polynomial (R ⧸ P)}
  (hq : map (mk P) q = c * X ^ n) (hn0 : 0 < n) : eval 0 q ∈ P :=
by rw [← coeff_zero_eq_eval_zero, ← eq_zero_iff_mem, ← coeff_map,
    coeff_zero_eq_eval_zero, hq, eval_mul, eval_pow, eval_X, zero_pow hn0, mul_zero]

lemma is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit {p q : R[X]}
  (hu : ∀ (x : R), C x ∣ p * q → is_unit x) (hpm : p.nat_degree = 0) :
  is_unit p :=
begin
  rw [eq_C_of_degree_le_zero (nat_degree_eq_zero_iff_degree_le_zero.1 hpm), is_unit_C],
  refine hu _ _,
  rw [← eq_C_of_degree_le_zero (nat_degree_eq_zero_iff_degree_le_zero.1 hpm)],
  exact dvd_mul_right _ _
end

end eisenstein_criterion_aux

open eisenstein_criterion_aux

variables [is_domain R]

/-- If `f` is a non constant polynomial with coefficients in `R`, and `P` is a prime ideal in `R`,
then if every coefficient in `R` except the leading coefficient is in `P`, and
the trailing coefficient is not in `P^2` and no non units in `R` divide `f`, then `f` is
irreducible. -/
theorem irreducible_of_eisenstein_criterion {f : R[X]} {P : ideal R} (hP : P.is_prime)
  (hfl : f.leading_coeff ∉ P)
  (hfP : ∀ n : ℕ, ↑n < degree f → f.coeff n ∈ P)
  (hfd0 : 0 < degree f) (h0 : f.coeff 0 ∉ P^2)
  (hu : f.is_primitive) : irreducible f :=
have hf0 : f ≠ 0, from λ _, by simp only [*, not_true, submodule.zero_mem, coeff_zero] at *,
have hf : f.map (mk P) = C (mk P (leading_coeff f)) * X ^ nat_degree f,
  from map_eq_C_mul_X_pow_of_forall_coeff_mem hfP,
have hfd0 : 0 < f.nat_degree, from with_bot.coe_lt_coe.1
  (lt_of_lt_of_le hfd0 degree_le_nat_degree),
⟨mt degree_eq_zero_of_is_unit (λ h, by simp only [*, lt_irrefl] at *),
begin
  rintros p q rfl,
  rw [polynomial.map_mul] at hf,
  rcases mul_eq_mul_prime_pow (show prime (X : polynomial (R ⧸ P)),
    from monic_X.prime_of_degree_eq_one degree_X) hf with
      ⟨m, n, b, c, hmnd, hbc, hp, hq⟩,
  have hmn : 0 < m → 0 < n → false,
  { assume hm0 hn0,
    refine h0 _,
    rw [coeff_zero_eq_eval_zero, eval_mul, sq],
    exact ideal.mul_mem_mul
      (eval_zero_mem_ideal_of_eq_mul_X_pow hp hm0)
      (eval_zero_mem_ideal_of_eq_mul_X_pow hq hn0) },
  have hpql0 : (mk P) (p * q).leading_coeff ≠ 0,
  { rwa [ne.def, eq_zero_iff_mem] },
  have hp0 : p ≠ 0, from λ h, by simp only [*, zero_mul, eq_self_iff_true, not_true, ne.def] at *,
  have hq0 : q ≠ 0, from λ h, by simp only [*, eq_self_iff_true, not_true, ne.def, mul_zero] at *,
  have hbc0 : degree b = 0 ∧ degree c = 0,
  { apply_fun degree at hbc,
    rwa [degree_C hpql0, degree_mul, eq_comm, nat.with_bot.add_eq_zero_iff] at hbc },
  have hmp : m ≤ nat_degree p,
    from le_nat_degree_of_map_eq_mul_X_pow hP hp hbc0.1,
  have hnq : n ≤ nat_degree q,
    from le_nat_degree_of_map_eq_mul_X_pow hP hq hbc0.2,
  have hpmqn : p.nat_degree = m ∧ q.nat_degree = n,
  { rw [nat_degree_mul hp0 hq0] at hmnd,
    clear_except hmnd hmp hnq,
    contrapose hmnd,
    apply ne_of_lt,
    rw not_and_distrib at hmnd,
    cases hmnd,
    { exact add_lt_add_of_lt_of_le (lt_of_le_of_ne hmp (ne.symm hmnd)) hnq },
    { exact add_lt_add_of_le_of_lt hmp (lt_of_le_of_ne hnq (ne.symm hmnd)) } },
  obtain rfl | rfl : m = 0 ∨ n = 0,
  { rwa [pos_iff_ne_zero, pos_iff_ne_zero, imp_false, not_not,
      ← or_iff_not_imp_left] at hmn },
  { exact or.inl (is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit hu hpmqn.1) },
  { exact or.inr (is_unit_of_nat_degree_eq_zero_of_forall_dvd_is_unit
      (by simpa only [mul_comm] using hu) hpmqn.2) }
end⟩

end polynomial


import SciLean.Prelude
import SciLean.Data.Quotient.Lattice
import SciLean.AutoImpl

/-- Function between Setoids
  Not sure about the name: Morphism, QFunction, QuotFun, QuotientFun, SetoidFun
  -/
class Setoid.Morphism {α : Type u} {β : Type v} [Setoid α] [Setoid β] (f : α → β) : Prop where
  is_sound : ∀ a a', a ≈ a' → f a ≈ f a'

class Setoid.Morphism₂ {α : Type u} {β : Type v} {γ : Type w} [Setoid α] [Setoid β] [Setoid γ] (f : α → β → γ) : Prop where
  is_sound : ∀ a a' b b', a ≈ a' → b ≈ b' → f a b ≈ f a' b'

class Setoid.Map {α : Type u} {β : Type v} [Setoid α] (f : α → β) : Prop where
  is_sound : ∀ a a', a ≈ a' → f a = f a'

noncomputable
def Quotient.repr {α : Type u} [inst : Setoid α] (a : Quotient inst) : α := Classical.choose a.exists_rep

namespace Setoid

  variable {α : Type u} [SA : Setoid α]
  variable {β : Type v} [SB : Setoid β]
  variable {γ : Type w} [SC : Setoid γ]

  instance id_is_mor : Morphism (λ x : α => x) where
    is_sound := by simp

  instance comp_is_mor (f : β → γ) [mf : Morphism f] (g : α → β) [mg : Morphism g]
    : Morphism (λ x => f (g x)) where
    is_sound :=
  by
    intros; apply mf.is_sound; apply mg.is_sound; assumption; done

  instance comp_is_map (f : β → δ) [mf : Map f] (g : α → β) [mg : Morphism g]
    : Map (λ x => f (g x)) where
    is_sound :=
  by
    intros; apply mf.is_sound; apply mg.is_sound; assumption; done

  instance scomb_is_mor (f : α → β → γ) [mf : Morphism₂ f] (g : α → β) [mg : Morphism g]
    : Morphism (λ x => f x (g x)) where
    is_sound :=
  by
    intros; apply mf.is_sound; assumption; apply mg.is_sound; assumption; done

  -- class QuotBracket {α : Type u} (a : α) (β : Type v) where
  --   quotBracket : β

  -- instance (α : Type u) [s : Setoid α] : QuotBracket α (β := Type u) where
  --   quotBracket := Quotient s

  -- instance {α} (a : α) [s : Setoid α] : QuotBracket a (Quotient s) where
  --   quotBracket := Quotient.mk _ a

  -- instance {α β} (f : α → β) [sa : Setoid α] [sb : Setoid β] [Morphism f] : QuotBracket f (Quotient sa → Quotient sb) where
  --   quotBracket := Quotient.lift (λ x : α => ⟦f x⟧) sorry_proof

  @[simp]
  theorem quotient_of_id (x : Quotient SA) : ⟦x.repr⟧ = x := sorry_proof   -- How do I prove this??

  @[simp]
  theorem quotient_of_morphism (f : α → β) [m : Morphism f] (x : α)
    : ⟦f x⟧ = Quotient.lift (λ x' => ⟦hold f x'⟧) (by intros; simp; apply Quot.sound; apply m.is_sound; sorry_proof /- wtf? this fails: assumption; done -/) ⟦x⟧
    := sorry_proof

  @[simp]
  theorem quotient_of_morphism₂ (f : α → β → γ) [m : Morphism₂ f] (x : α) (y : β)
    : ⟦f x y⟧ = Quotient.lift₂ (λ x' y' => ⟦hold f x' y'⟧) (by intros; simp; apply Quot.sound; apply m.is_sound; sorry_proof; sorry_proof) ⟦x⟧ ⟦y⟧
    := sorry_proof

  -- Should not be simp as it is variable head lhs :/
  theorem quotient_of_map (f : α → β) [m : Map f] (x : α)
    : f x = Quotient.lift (λ x' => hold f x') (by intros; simp; apply m.is_sound; sorry_proof) ⟦x⟧
    := sorry_proof

  section Operations

    -- variable {α : Type u} {β : Type v} {γ : Type w} [SA : Setoid α] [SB : Setoid β] [SC : Setoid γ]

    -- instance [HAdd α β γ] [Morphism₂ λ (x : α) (y : β) => x + y] : HAdd (Quotient SA) (Quotient SB) (Quotient SC)
    --   := ⟨λ x y => ⟦x.repr + y.repr⟧ rewrite_by simp⟩
    -- instance [HSub α β γ] [Morphism₂ λ (x : α) (y : β) => x - y] : HSub (Quotient SA) (Quotient SB) (Quotient SC)
    --   := ⟨λ x y => ⟦x.repr - y.repr⟧ rewrite_by simp⟩
    -- instance [HMul α β γ] [Morphism₂ λ (x : α) (y : β) => x * y] : HMul (Quotient SA) (Quotient SB) (Quotient SC)
    --   := ⟨λ x y => ⟦x.repr * y.repr⟧ rewrite_by simp⟩
    -- instance [HDiv α β γ] [Morphism₂ λ (x : α) (y : β) => x / y] : HDiv (Quotient SA) (Quotient SB) (Quotient SC)
    --   := ⟨λ x y => ⟦x.repr / y.repr⟧ rewrite_by simp⟩

    -- instance [Zero α] : One (Quotient SA) := ⟨⟦0⟧⟩
    -- instance [One α] : One (Quotient SA) := ⟨⟦1⟧⟩

  end Operations

end Setoid


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison

! This file was ported from Lean 3 source module category_theory.preadditive.additive_functor
! leanprover-community/mathlib commit ee89acdf96a0b45afe3eea493bceb2a80a0f2efa
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.ExactFunctor
import Mathlib.CategoryTheory.Limits.Preserves.Finite
import Mathlib.CategoryTheory.Preadditive.Biproducts
import Mathlib.CategoryTheory.Preadditive.FunctorCategory

/-!
# Additive Functors

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.
Conversely, if `F : C ⥤ D` is a functor between preadditive categories, where `C` has binary
biproducts, and if `F` preserves binary biproducts, then `F` is additive.

We also define the category of bundled additive functors.

# Implementation details

`Functor.Additive` is a `Prop`-valued class, defined by saying that for every two objects `X` and
`Y`, the map `F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian groups.

-/

universe v₁ v₂ u₁ u₂

namespace CategoryTheory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class Functor.Additive {C D : Type _} [Category C] [Category D] [Preadditive C] [Preadditive D]
  (F : C ⥤ D) : Prop where
  /-- the addition of two morphisms is mapped to the sum of their images -/
  map_add : ∀ {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g := by aesop_cat
#align category_theory.functor.additive CategoryTheory.Functor.Additive

section Preadditive

namespace Functor

section

variable {C D : Type _} [Category C] [Category D] [Preadditive C] [Preadditive D] (F : C ⥤ D)
  [Functor.Additive F]

@[simp]
theorem map_add {X Y : C} {f g : X ⟶ Y} : F.map (f + g) = F.map f + F.map g :=
  Functor.Additive.map_add
#align category_theory.functor.map_add CategoryTheory.Functor.map_add

-- porting note: it was originally @[simps (config := { fullyApplied := false })]
/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps!]
def mapAddHom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
  AddMonoidHom.mk' (fun f => F.map f) fun _ _ => F.map_add
#align category_theory.functor.map_add_hom CategoryTheory.Functor.mapAddHom

theorem coe_mapAddHom {X Y : C} : ⇑(F.mapAddHom : (X ⟶ Y) →+ _) = F.map :=
  rfl
#align category_theory.functor.coe_map_add_hom CategoryTheory.Functor.coe_mapAddHom

instance (priority := 100) preservesZeroMorphisms_of_additive : PreservesZeroMorphisms F
    where map_zero _ _ := F.mapAddHom.map_zero
#align category_theory.functor.preserves_zero_morphisms_of_additive CategoryTheory.Functor.preservesZeroMorphisms_of_additive

instance : Additive (𝟭 C) where

instance {E : Type _} [Category E] [Preadditive E] (G : D ⥤ E) [Functor.Additive G] :
    Additive (F ⋙ G) where

@[simp]
theorem map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = -F.map f :=
  (F.mapAddHom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_neg _
#align category_theory.functor.map_neg CategoryTheory.Functor.map_neg

@[simp]
theorem map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
  (F.mapAddHom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_sub _ _
#align category_theory.functor.map_sub CategoryTheory.Functor.map_sub

theorem map_nsmul {X Y : C} {f : X ⟶ Y} {n : ℕ} : F.map (n • f) = n • F.map f :=
  (F.mapAddHom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_nsmul _ _
#align category_theory.functor.map_nsmul CategoryTheory.Functor.map_nsmul

-- You can alternatively just use `Functor.map_smul` here, with an explicit `(r : ℤ)` argument.
theorem map_zsmul {X Y : C} {f : X ⟶ Y} {r : ℤ} : F.map (r • f) = r • F.map f :=
  (F.mapAddHom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_zsmul _ _
#align category_theory.functor.map_zsmul CategoryTheory.Functor.map_zsmul

open BigOperators

@[simp]
theorem map_sum {X Y : C} {α : Type _} (f : α → (X ⟶ Y)) (s : Finset α) :
    F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
  (F.mapAddHom : (X ⟶ Y) →+ _).map_sum f s
#align category_theory.functor.map_sum CategoryTheory.Functor.map_sum

end

section InducedCategory

variable {C : Type _} {D : Type _} [Category D] [Preadditive D] (F : C → D)

instance inducedFunctor_additive : Functor.Additive (inducedFunctor F) where
#align category_theory.functor.induced_functor_additive CategoryTheory.Functor.inducedFunctor_additive

end InducedCategory

instance fullSubcategoryInclusion_additive {C : Type _} [Category C] [Preadditive C]
    (Z : C → Prop) : (fullSubcategoryInclusion Z).Additive where
#align category_theory.functor.full_subcategory_inclusion_additive CategoryTheory.Functor.fullSubcategoryInclusion_additive

section

-- To talk about preservation of biproducts we need to specify universes explicitly.
noncomputable section

variable {C : Type u₁} {D : Type u₂} [Category.{v₁} C] [Category.{v₂} D] [Preadditive C]
  [Preadditive D] (F : C ⥤ D)

open CategoryTheory.Limits

open CategoryTheory.Preadditive

instance (priority := 100) preservesFiniteBiproductsOfAdditive [Additive F] :
    PreservesFiniteBiproducts F where
  preserves :=
    { preserves :=
      { preserves := fun hb =>
          isBilimitOfTotal _ (by
            simp_rw [F.mapBicone_π, F.mapBicone_ι, ← F.map_comp]
            erw [← F.map_sum, ← F.map_id, IsBilimit.total hb])} }
#align category_theory.functor.preserves_finite_biproducts_of_additive CategoryTheory.Functor.preservesFiniteBiproductsOfAdditive

theorem additive_of_preservesBinaryBiproducts [HasBinaryBiproducts C] [PreservesZeroMorphisms F]
    [PreservesBinaryBiproducts F] : Additive F where
  map_add {X Y f g} := by
    rw [biprod.add_eq_lift_id_desc,  F.map_comp, ← biprod.lift_mapBiprod,
      ←  biprod.mapBiprod_hom_desc, Category.assoc, Iso.inv_hom_id_assoc, F.map_id,
      biprod.add_eq_lift_id_desc]
#align category_theory.functor.additive_of_preserves_binary_biproducts CategoryTheory.Functor.additive_of_preservesBinaryBiproducts

end

end

end Functor

namespace Equivalence

variable {C D : Type _} [Category C] [Category D] [Preadditive C] [Preadditive D]

instance inverse_additive (e : C ≌ D) [e.functor.Additive] : e.inverse.Additive where
  map_add {f g} := e.functor.map_injective (by simp)
#align category_theory.equivalence.inverse_additive CategoryTheory.Equivalence.inverse_additive

end Equivalence

section

variable (C D : Type _) [Category C] [Category D] [Preadditive C] [Preadditive D]

-- porting note: removed @[nolint has_nonempty_instance]
/-- Bundled additive functors. -/
def AdditiveFunctor :=
  FullSubcategory fun F : C ⥤ D => F.Additive
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor CategoryTheory.AdditiveFunctor

instance : Category (AdditiveFunctor C D) :=
  FullSubcategory.category _

/-- the category of additive functors is denoted `C ⥤+ D` -/
infixr:26 " ⥤+ " => AdditiveFunctor

instance : Preadditive (C ⥤+ D) :=
  Preadditive.inducedCategory _

/-- An additive functor is in particular a functor. -/
def AdditiveFunctor.forget : (C ⥤+ D) ⥤ C ⥤ D :=
  fullSubcategoryInclusion _
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.forget CategoryTheory.AdditiveFunctor.forget

instance : Full (AdditiveFunctor.forget C D) :=
  FullSubcategory.full _

variable {C D}

/-- Turn an additive functor into an object of the category `AdditiveFunctor C D`. -/
def AdditiveFunctor.of (F : C ⥤ D) [F.Additive] : C ⥤+ D :=
  ⟨F, inferInstance⟩
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of CategoryTheory.AdditiveFunctor.of

@[simp]
theorem AdditiveFunctor.of_fst (F : C ⥤ D) [F.Additive] : (AdditiveFunctor.of F).1 = F :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_fst CategoryTheory.AdditiveFunctor.of_fst

@[simp]
theorem AdditiveFunctor.forget_obj (F : C ⥤+ D) : (AdditiveFunctor.forget C D).obj F = F.1 :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.forget_obj CategoryTheory.AdditiveFunctor.forget_obj

theorem AdditiveFunctor.forget_obj_of (F : C ⥤ D) [F.Additive] :
    (AdditiveFunctor.forget C D).obj (AdditiveFunctor.of F) = F :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.forget_obj_of CategoryTheory.AdditiveFunctor.forget_obj_of

@[simp]
theorem AdditiveFunctor.forget_map (F G : C ⥤+ D) (α : F ⟶ G) :
    (AdditiveFunctor.forget C D).map α = α :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.forget_map CategoryTheory.AdditiveFunctor.forget_map

instance : Functor.Additive (AdditiveFunctor.forget C D) where map_add := rfl

instance (F : C ⥤+ D) : Functor.Additive F.1 :=
  F.2

end

section Exact

open CategoryTheory.Limits

variable (C : Type u₁) (D : Type u₂) [Category.{v₁} C] [Category.{v₂} D] [Preadditive C]

variable [Preadditive D] [HasZeroObject C] [HasZeroObject D] [HasBinaryBiproducts C]

section

attribute [local instance] preservesBinaryBiproductsOfPreservesBinaryProducts

attribute [local instance] preservesBinaryBiproductsOfPreservesBinaryCoproducts

/-- Turn a left exact functor into an additive functor. -/
def AdditiveFunctor.ofLeftExact : (C ⥤ₗ D) ⥤ C ⥤+ D :=
  FullSubcategory.map fun F ⟨_⟩ =>
    Functor.additive_of_preservesBinaryBiproducts F
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_left_exact CategoryTheory.AdditiveFunctor.ofLeftExact

instance : Full (AdditiveFunctor.ofLeftExact C D) := FullSubcategory.full_map _
instance : Faithful (AdditiveFunctor.ofLeftExact C D) := FullSubcategory.faithful_map _

/-- Turn a right exact functor into an additive functor. -/
def AdditiveFunctor.ofRightExact : (C ⥤ᵣ D) ⥤ C ⥤+ D :=
  FullSubcategory.map fun F ⟨_⟩ =>
    Functor.additive_of_preservesBinaryBiproducts F
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_right_exact CategoryTheory.AdditiveFunctor.ofRightExact

instance : Full (AdditiveFunctor.ofRightExact C D) := FullSubcategory.full_map _
instance : Faithful (AdditiveFunctor.ofRightExact C D) := FullSubcategory.faithful_map _

/-- Turn an exact functor into an additive functor. -/
def AdditiveFunctor.ofExact : (C ⥤ₑ D) ⥤ C ⥤+ D :=
  FullSubcategory.map fun F ⟨⟨_⟩, _⟩ =>
    Functor.additive_of_preservesBinaryBiproducts F
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_exact CategoryTheory.AdditiveFunctor.ofExact

instance : Full (AdditiveFunctor.ofExact C D) := FullSubcategory.full_map _
instance : Faithful (AdditiveFunctor.ofExact C D) := FullSubcategory.faithful_map _

end

variable {C D}

@[simp]
theorem AdditiveFunctor.ofLeftExact_obj_fst (F : C ⥤ₗ D) :
    ((AdditiveFunctor.ofLeftExact C D).obj F).obj = F.obj :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_left_exact_obj_fst CategoryTheory.AdditiveFunctor.ofLeftExact_obj_fst

@[simp]
theorem AdditiveFunctor.ofRightExact_obj_fst (F : C ⥤ᵣ D) :
    ((AdditiveFunctor.ofRightExact C D).obj F).obj = F.obj :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.AdditiveFunctor.of_right_exact_obj_fst CategoryTheory.AdditiveFunctor.ofRightExact_obj_fst

@[simp]

@[simp]
theorem AdditiveFunctor.ofLeftExact_map {F G : C ⥤ₗ D} (α : F ⟶ G) :
    (AdditiveFunctor.ofLeftExact C D).map α = α :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.Additive_Functor.of_left_exact_map CategoryTheory.AdditiveFunctor.ofLeftExact_map

@[simp]
theorem AdditiveFunctor.ofRightExact_map {F G : C ⥤ᵣ D} (α : F ⟶ G) :
    (AdditiveFunctor.ofRightExact C D).map α = α :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.Additive_Functor.of_right_exact_map CategoryTheory.AdditiveFunctor.ofRightExact_map

@[simp]
theorem AdditiveFunctor.ofExact_map {F G : C ⥤ₑ D} (α : F ⟶ G) :
    (AdditiveFunctor.ofExact C D).map α = α :=
  rfl
set_option linter.uppercaseLean3 false in
#align category_theory.Additive_Functor.of_exact_map CategoryTheory.AdditiveFunctor.ofExact_map

end Exact

end Preadditive

end CategoryTheory


import Rings.ToMathlib.fol
import Rings.ToMathlib.list
import Rings.ToMathlib.nat
import Rings.Rings

open Rings fol

namespace realize_ring_term

variables
  {A : Type*} [comm_ring A]
  {c : ℕ} (xs : dvector (struc_to_ring_struc.Structure A) c)

@[simp] lemma list_sumr :
  Π {l : list (bounded_ring_term c)},
  realize_bounded_term xs (list.sumr l) dvector.nil
  =
  list.sumr (list.map (λ t, realize_bounded_term xs t dvector.nil) l)
| list.nil := by simp
| (list.cons t ts) :=
begin
  simp only [list.map, models_ring_theory_to_comm_ring.realize_add,
    ring_signature.add, list.sumr, realize_bounded_term],
  simp only [struc_to_ring_struc.func_map, dvector.last,
    struc_to_ring_struc.binaries_map, add_right_inj, dvector.nth],
  rw list_sumr,
end

def add_zero_hom :
  add_zero_hom (bounded_ring_term c) A :=
⟨ λ t, realize_bounded_term xs t dvector.nil ,
  models_ring_theory_to_comm_ring.realize_zero ,
  λ t s, models_ring_theory_to_comm_ring.realize_add ⟩

lemma sumr
  {ts : list (bounded_ring_term c)} :
  realize_bounded_term xs (ts).sumr dvector.nil
  =
  (list.map (add_zero_hom xs).to_fun ts).sumr :=
begin
  rw ← list.add_zero_hom_sumr (add_zero_hom xs) ts,
  refl,
end

lemma nat_non_comm_prod :
  Π (n : ℕ) (ts : fin n → bounded_ring_term c),
  realize_bounded_term xs (nat.non_comm_prod _ ts) dvector.nil
  =
  nat.non_comm_prod n (λ i, realize_bounded_term xs (ts i) dvector.nil)
| nat.zero ts :=
begin
  simp only [nat.non_comm_prod],
  refl,
end
| (nat.succ n) ts :=
begin
  simp only [nat.non_comm_prod, struc_to_ring_struc.func_map,
    dvector.last, struc_to_ring_struc.binaries_map, realize_bounded_term,
    ring_signature.mul, dvector.nth],
  rw nat_non_comm_prod n,
end

lemma pow (t : bounded_ring_term c) : Π (n : ℕ),
  realize_bounded_term xs (npow_rec n t) dvector.nil
  =
  (realize_bounded_term xs t dvector.nil) ^ n
| nat.zero := by simp only [nat.nat_zero_eq_zero, ring_signature.pow_zero,
    realize_bounded_term, models_ring_theory_to_comm_ring.realize_one,
    ring_signature.one, models_ring_theory_to_comm_ring.realize_one, pow_zero]
| (nat.succ n) := by simp only [struc_to_ring_struc.func_map,
  dvector.last, ring_signature.pow_succ, struc_to_ring_struc.binaries_map,
  realize_bounded_term, ring_signature.mul, dvector.nth, pow n, pow_succ]

end realize_ring_term


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/

import data.finset.basic

/-!
# Finsets of ordered types
-/

universes u v w
variables {α : Type u}

theorem directed.finset_le {r : α → α → Prop} [is_trans α r]
  {ι} [hι : nonempty ι] {f : ι → α} (D : directed r f) (s : finset ι) :
  ∃ z, ∀ i ∈ s, r (f i) (f z) :=
show ∃ z, ∀ i ∈ s.1, r (f i) (f z), from
multiset.induction_on s.1 (let ⟨z⟩ := hι in ⟨z, λ _, false.elim⟩) $
λ i s ⟨j, H⟩, let ⟨k, h₁, h₂⟩ := D i j in
⟨k, λ a h, or.cases_on (multiset.mem_cons.1 h)
  (λ h, h.symm ▸ h₁)
  (λ h, trans (H _ h) h₂)⟩

lemma finset.exists_le [nonempty α] [preorder α] [is_directed α (≤)] (s : finset α) :
  ∃ M, ∀ i ∈ s, i ≤ M :=
directed_id.finset_le _