/-
Copyright (c) 2022 Benjamin Davidson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Benjamin Davidson, Devon Tuma, Eric Rodriguez, Oliver Nash
-/

import tactic.positivity
import tactic.linarith
import topology.algebra.order.group
import topology.algebra.field

/-!
# Topologies on linear ordered fields

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

-/

open set filter topological_space
open function
open order_dual (to_dual of_dual)
open_locale topology classical filter

variables {α β : Type*}
variables [linear_ordered_field α] [topological_space α] [order_topology α]
variables {l : filter β} {f g : β → α}

section continuous_mul

lemma mul_tendsto_nhds_zero_right (x : α) :
  tendsto (uncurry ((*) : α → α → α)) (𝓝 0 ×ᶠ 𝓝 x) $ 𝓝 0 :=
begin
  have hx : 0 < 2 * (1 + |x|) := by positivity,
  rw ((nhds_basis_zero_abs_sub_lt α).prod $ nhds_basis_abs_sub_lt x).tendsto_iff
     (nhds_basis_zero_abs_sub_lt α),
  refine λ ε ε_pos, ⟨(ε/(2 * (1 + |x|)), 1), ⟨div_pos ε_pos hx, zero_lt_one⟩, _⟩,
  suffices : ∀ (a b : α), |a| < ε / (2 * (1 + |x|)) → |b - x| < 1 → |a| * |b| < ε,
  by simpa only [and_imp, prod.forall, mem_prod, ← abs_mul],
  intros a b h h',
  refine lt_of_le_of_lt (mul_le_mul_of_nonneg_left _ (abs_nonneg a)) ((lt_div_iff hx).1 h),
  calc |b| = |(b - x) + x| : by rw sub_add_cancel b x
    ... ≤ |b - x| + |x| : abs_add (b - x) x
    ... ≤ 2 * (1 + |x|) : by linarith,
end

lemma mul_tendsto_nhds_zero_left (x : α) :
  tendsto (uncurry ((*) : α → α → α)) (𝓝 x ×ᶠ 𝓝 0) $ 𝓝 0 :=
begin
  intros s hs,
  have := mul_tendsto_nhds_zero_right x hs,
  rw [filter.mem_map, mem_prod_iff] at this ⊢,
  obtain ⟨U, hU, V, hV, h⟩ := this,
  exact ⟨V, hV, U, hU, λ y hy, ((mul_comm y.2 y.1) ▸
    h (⟨hy.2, hy.1⟩ : (prod.mk y.2 y.1) ∈ U ×ˢ V) : y.1 * y.2 ∈ s)⟩,
end

lemma nhds_eq_map_mul_left_nhds_one {x₀ : α} (hx₀ : x₀ ≠ 0) :
  𝓝 x₀ = map (λ x, x₀*x) (𝓝 1) :=
begin
  have hx₀' : 0 < |x₀| := abs_pos.2 hx₀,
  refine filter.ext (λ t, _),
  simp only [exists_prop, set_of_subset_set_of, (nhds_basis_abs_sub_lt x₀).mem_iff,
    (nhds_basis_abs_sub_lt (1 : α)).mem_iff, filter.mem_map'],
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨i, hi, hit⟩ := h,
    refine ⟨i / (|x₀|), div_pos hi (abs_pos.2 hx₀), λ x hx, hit _⟩,
    calc |x₀ * x - x₀| = |x₀ * (x - 1)| : congr_arg abs (by ring_nf)
      ... = |x₀| * |x - 1| : abs_mul x₀ (x - 1)
      ... < |x₀| * (i / |x₀|) : mul_lt_mul' le_rfl hx (by positivity) (abs_pos.2 hx₀)
      ... = |x₀| * i / |x₀| : by ring
      ... = i : mul_div_cancel_left i (λ h, hx₀ (abs_eq_zero.1 h)) },
  { obtain ⟨i, hi, hit⟩ := h,
    refine ⟨i * |x₀|, mul_pos hi (abs_pos.2 hx₀), λ x hx, _⟩,
    have : |x / x₀ - 1| < i,
    calc |x / x₀ - 1| = |x / x₀ - x₀ / x₀| : (by rw div_self hx₀)
    ... = |(x - x₀) / x₀| : congr_arg abs (sub_div x x₀ x₀).symm
    ... = |x - x₀| / |x₀| : abs_div (x - x₀) x₀
    ... < i * |x₀| / |x₀| : div_lt_div_of_lt (abs_pos.2 hx₀) hx
    ... = i : by rw [← mul_div_assoc', div_self (ne_of_lt $ abs_pos.2 hx₀).symm, mul_one],
    specialize hit (x / x₀) this,
    rwa [mul_div_assoc', mul_div_cancel_left x hx₀] at hit }
end

lemma nhds_eq_map_mul_right_nhds_one {x₀ : α} (hx₀ : x₀ ≠ 0) :
  𝓝 x₀ = map (λ x, x*x₀) (𝓝 1) :=
by simp_rw [mul_comm _ x₀, nhds_eq_map_mul_left_nhds_one hx₀]

lemma mul_tendsto_nhds_one_nhds_one :
  tendsto (uncurry ((*) : α → α → α)) (𝓝 1 ×ᶠ 𝓝 1) $ 𝓝 1 :=
begin
  rw ((nhds_basis_Ioo_pos (1 : α)).prod $ nhds_basis_Ioo_pos (1 : α)).tendsto_iff
     (nhds_basis_Ioo_pos_of_pos (zero_lt_one : (0 : α) < 1)),
  intros ε hε,
  have hε' : 0 ≤ 1 - ε / 4 := by linarith,
  have ε_pos : 0 < ε / 4 := by linarith,
  have ε_pos' : 0 < ε / 2 := by linarith,
  simp only [and_imp, prod.forall, mem_Ioo, function.uncurry_apply_pair, mem_prod, prod.exists],
  refine ⟨ε/4, ε/4, ⟨ε_pos, ε_pos⟩, λ a b ha ha' hb hb', _⟩,
  have ha0 : 0 ≤ a := le_trans hε' (le_of_lt ha),
  have hb0 : 0 ≤ b := le_trans hε' (le_of_lt hb),
  refine ⟨lt_of_le_of_lt _ (mul_lt_mul'' ha hb hε' hε'),
    lt_of_lt_of_le (mul_lt_mul'' ha' hb' ha0 hb0) _⟩,
  { calc 1 - ε = 1 - ε / 2 - ε/2 : by ring_nf
    ... ≤ 1 - ε/2 - ε/2 + (ε/2)*(ε/2) : le_add_of_nonneg_right (by positivity)
    ... = (1 - ε/2) * (1 - ε/2) : by ring_nf
    ... ≤ (1 - ε/4) * (1 - ε/4) : mul_le_mul (by linarith) (by linarith) (by linarith) hε' },
  { calc (1 + ε/4) * (1 + ε/4) = 1 + ε/2 + (ε/4)*(ε/4) : by ring_nf
    ... = 1 + ε/2 + (ε * ε) / 16 : by ring_nf
    ... ≤ 1 + ε/2 + ε/2 : add_le_add_left (div_le_div (le_of_lt hε.1) (le_trans
      ((mul_le_mul_left hε.1).2 hε.2) (le_of_eq $ mul_one ε)) zero_lt_two (by linarith)) (1 + ε/2)
    ... ≤ 1 + ε : by ring_nf }
end

@[priority 100] -- see Note [lower instance priority]
instance linear_ordered_field.has_continuous_mul : has_continuous_mul α :=
⟨begin
  rw continuous_iff_continuous_at,
  rintro ⟨x₀, y₀⟩,
  by_cases hx₀ : x₀ = 0,
  { rw [hx₀, continuous_at, zero_mul, nhds_prod_eq],
    exact mul_tendsto_nhds_zero_right y₀ },
  by_cases hy₀ : y₀ = 0,
  { rw [hy₀, continuous_at, mul_zero, nhds_prod_eq],
    exact mul_tendsto_nhds_zero_left x₀ },
  have hxy : x₀ * y₀ ≠ 0 := mul_ne_zero hx₀ hy₀,
  have key : (λ p : α × α, x₀ * p.1 * (p.2 * y₀)) = ((λ x, x₀*x) ∘ (λ x, x*y₀)) ∘ (uncurry (*)),
  { ext p, simp [uncurry, mul_assoc] },
  have key₂ : (λ x, x₀*x) ∘ (λ x, y₀*x) = λ x, (x₀ *y₀)*x,
  { ext x, simp },
  calc map (uncurry (*)) (𝓝 (x₀, y₀))
      = map (uncurry (*)) (𝓝 x₀ ×ᶠ 𝓝 y₀) : by rw nhds_prod_eq
  ... = map (λ (p : α × α), x₀ * p.1 * (p.2 * y₀)) ((𝓝 1) ×ᶠ (𝓝 1))
          : by rw [uncurry, nhds_eq_map_mul_left_nhds_one hx₀, nhds_eq_map_mul_right_nhds_one hy₀,
                    prod_map_map_eq, filter.map_map]
  ... = map ((λ x, x₀ * x) ∘ λ x, x * y₀) (map (uncurry (*)) (𝓝 1 ×ᶠ 𝓝 1))
          : by rw [key, ← filter.map_map]
  ... ≤ map ((λ (x : α), x₀ * x) ∘ λ x, x * y₀) (𝓝 1) : map_mono (mul_tendsto_nhds_one_nhds_one)
  ... = 𝓝 (x₀*y₀) : by rw [← filter.map_map, ← nhds_eq_map_mul_right_nhds_one hy₀,
    nhds_eq_map_mul_left_nhds_one hy₀, filter.map_map, key₂, ← nhds_eq_map_mul_left_nhds_one hxy],
end⟩

end continuous_mul

/-- In a linearly ordered field with the order topology, if `f` tends to `at_top` and `g` tends to
a positive constant `C` then `f * g` tends to `at_top`. -/
lemma filter.tendsto.at_top_mul {C : α} (hC : 0 < C) (hf : tendsto f l at_top)
  (hg : tendsto g l (𝓝 C)) :
  tendsto (λ x, (f x * g x)) l at_top :=
begin
  refine tendsto_at_top_mono' _ _ (hf.at_top_mul_const (half_pos hC)),
  filter_upwards [hg.eventually (lt_mem_nhds (half_lt_self hC)),
    hf.eventually (eventually_ge_at_top 0)] with x hg hf using mul_le_mul_of_nonneg_left hg.le hf,
end

/-- In a linearly ordered field with the order topology, if `f` tends to a positive constant `C` and
`g` tends to `at_top` then `f * g` tends to `at_top`. -/
lemma filter.tendsto.mul_at_top {C : α} (hC : 0 < C) (hf : tendsto f l (𝓝 C))
  (hg : tendsto g l at_top) :
  tendsto (λ x, (f x * g x)) l at_top :=
by simpa only [mul_comm] using hg.at_top_mul hC hf

/-- In a linearly ordered field with the order topology, if `f` tends to `at_top` and `g` tends to
a negative constant `C` then `f * g` tends to `at_bot`. -/
lemma filter.tendsto.at_top_mul_neg {C : α} (hC : C < 0) (hf : tendsto f l at_top)
  (hg : tendsto g l (𝓝 C)) :
  tendsto (λ x, (f x * g x)) l at_bot :=
by simpa only [(∘), neg_mul_eq_mul_neg, neg_neg]
  using tendsto_neg_at_top_at_bot.comp (hf.at_top_mul (neg_pos.2 hC) hg.neg)

/-- In a linearly ordered field with the order topology, if `f` tends to a negative constant `C` and
`g` tends to `at_top` then `f * g` tends to `at_bot`. -/
lemma filter.tendsto.neg_mul_at_top {C : α} (hC : C < 0) (hf : tendsto f l (𝓝 C))
  (hg : tendsto g l at_top) :
  tendsto (λ x, (f x * g x)) l at_bot :=
by simpa only [mul_comm] using hg.at_top_mul_neg hC hf

/-- In a linearly ordered field with the order topology, if `f` tends to `at_bot` and `g` tends to
a positive constant `C` then `f * g` tends to `at_bot`. -/
lemma filter.tendsto.at_bot_mul {C : α} (hC : 0 < C) (hf : tendsto f l at_bot)
  (hg : tendsto g l (𝓝 C)) :
  tendsto (λ x, (f x * g x)) l at_bot :=
by simpa [(∘)]
  using tendsto_neg_at_top_at_bot.comp ((tendsto_neg_at_bot_at_top.comp hf).at_top_mul hC hg)

/-- In a linearly ordered field with the order topology, if `f` tends to `at_bot` and `g` tends to
a negative constant `C` then `f * g` tends to `at_top`. -/
lemma filter.tendsto.at_bot_mul_neg {C : α} (hC : C < 0) (hf : tendsto f l at_bot)
  (hg : tendsto g l (𝓝 C)) :
  tendsto (λ x, (f x * g x)) l at_top :=
by simpa [(∘)]
  using tendsto_neg_at_bot_at_top.comp ((tendsto_neg_at_bot_at_top.comp hf).at_top_mul_neg hC hg)

/-- In a linearly ordered field with the order topology, if `f` tends to a positive constant `C` and
`g` tends to `at_bot` then `f * g` tends to `at_bot`. -/
lemma filter.tendsto.mul_at_bot {C : α} (hC : 0 < C) (hf : tendsto f l (𝓝 C))
  (hg : tendsto g l at_bot) :
  tendsto (λ x, (f x * g x)) l at_bot :=
by simpa only [mul_comm] using hg.at_bot_mul hC hf

/-- In a linearly ordered field with the order topology, if `f` tends to a negative constant `C` and
`g` tends to `at_bot` then `f * g` tends to `at_top`. -/
lemma filter.tendsto.neg_mul_at_bot {C : α} (hC : C < 0) (hf : tendsto f l (𝓝 C))
  (hg : tendsto g l at_bot) :
  tendsto (λ x, (f x * g x)) l at_top :=
by simpa only [mul_comm] using hg.at_bot_mul_neg hC hf

/-- The function `x ↦ x⁻¹` tends to `+∞` on the right of `0`. -/
lemma tendsto_inv_zero_at_top : tendsto (λx:α, x⁻¹) (𝓝[>] (0:α)) at_top :=
begin
  refine (at_top_basis' 1).tendsto_right_iff.2 (λ b hb, _),
  have hb' : 0 < b := by positivity,
  filter_upwards [Ioc_mem_nhds_within_Ioi ⟨le_rfl, inv_pos.2 hb'⟩]
    with x hx using (le_inv hx.1 hb').1 hx.2,
end

/-- The function `r ↦ r⁻¹` tends to `0` on the right as `r → +∞`. -/
lemma tendsto_inv_at_top_zero' : tendsto (λr:α, r⁻¹) at_top (𝓝[>] (0:α)) :=
begin
  refine (has_basis.tendsto_iff at_top_basis ⟨λ s, mem_nhds_within_Ioi_iff_exists_Ioc_subset⟩).2 _,
  refine λ b hb, ⟨b⁻¹, trivial, λ x hx, _⟩,
  have : 0 < x := lt_of_lt_of_le (inv_pos.2 hb) hx,
  exact ⟨inv_pos.2 this, (inv_le this hb).2 hx⟩
end

lemma tendsto_inv_at_top_zero : tendsto (λr:α, r⁻¹) at_top (𝓝 0) :=
tendsto_inv_at_top_zero'.mono_right inf_le_left

lemma filter.tendsto.div_at_top [has_continuous_mul α] {f g : β → α} {l : filter β} {a : α}
  (h : tendsto f l (𝓝 a)) (hg : tendsto g l at_top) : tendsto (λ x, f x / g x) l (𝓝 0) :=
by { simp only [div_eq_mul_inv], exact mul_zero a ▸ h.mul (tendsto_inv_at_top_zero.comp hg) }

lemma filter.tendsto.inv_tendsto_at_top (h : tendsto f l at_top) : tendsto (f⁻¹) l (𝓝 0) :=
tendsto_inv_at_top_zero.comp h

lemma filter.tendsto.inv_tendsto_zero (h : tendsto f l (𝓝[>] 0)) :
  tendsto (f⁻¹) l at_top :=
tendsto_inv_zero_at_top.comp h

/-- The function `x^(-n)` tends to `0` at `+∞` for any positive natural `n`.
A version for positive real powers exists as `tendsto_rpow_neg_at_top`. -/
lemma tendsto_pow_neg_at_top {n : ℕ} (hn : n ≠ 0) : tendsto (λ x : α, x ^ (-(n:ℤ))) at_top (𝓝 0) :=
by simpa only [zpow_neg, zpow_coe_nat] using (@tendsto_pow_at_top α _ _ hn).inv_tendsto_at_top

lemma tendsto_zpow_at_top_zero {n : ℤ} (hn : n < 0) :
  tendsto (λ x : α, x^n) at_top (𝓝 0) :=
begin
  lift -n to ℕ using le_of_lt (neg_pos.mpr hn) with N,
  rw [← neg_pos, ← h, nat.cast_pos] at hn,
  simpa only [h, neg_neg] using tendsto_pow_neg_at_top hn.ne'
end

lemma tendsto_const_mul_zpow_at_top_zero {n : ℤ} {c : α} (hn : n < 0) :
  tendsto (λ x, c * x ^ n) at_top (𝓝 0) :=
(mul_zero c) ▸ (filter.tendsto.const_mul c (tendsto_zpow_at_top_zero hn))

lemma tendsto_const_mul_pow_nhds_iff' {n : ℕ} {c d : α} :
  tendsto (λ x : α, c * x ^ n) at_top (𝓝 d) ↔ (c = 0 ∨ n = 0) ∧ c = d :=
begin
  rcases eq_or_ne n 0 with (rfl|hn),
  { simp [tendsto_const_nhds_iff] },
  rcases lt_trichotomy c 0 with hc|rfl|hc,
  { have := tendsto_const_mul_pow_at_bot_iff.2 ⟨hn, hc⟩,
    simp [not_tendsto_nhds_of_tendsto_at_bot this, hc.ne, hn] },
  { simp [tendsto_const_nhds_iff] },
  { have := tendsto_const_mul_pow_at_top_iff.2 ⟨hn, hc⟩,
    simp [not_tendsto_nhds_of_tendsto_at_top this, hc.ne', hn] }
end

lemma tendsto_const_mul_pow_nhds_iff {n : ℕ} {c d : α} (hc : c ≠ 0) :
  tendsto (λ x : α, c * x ^ n) at_top (𝓝 d) ↔ n = 0 ∧ c = d :=
by simp [tendsto_const_mul_pow_nhds_iff', hc]

lemma tendsto_const_mul_zpow_at_top_nhds_iff {n : ℤ} {c d : α} (hc : c ≠ 0) :
  tendsto (λ x : α, c * x ^ n) at_top (𝓝 d) ↔ (n = 0 ∧ c = d) ∨ (n < 0 ∧ d = 0) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { by_cases hn : 0 ≤ n,
    { lift n to ℕ using hn,
      simp only [zpow_coe_nat] at h,
      rw [tendsto_const_mul_pow_nhds_iff hc, ← int.coe_nat_eq_zero] at h,
      exact or.inl h },
    { rw not_le at hn,
      refine or.inr ⟨hn, tendsto_nhds_unique h (tendsto_const_mul_zpow_at_top_zero hn)⟩ } },
  { cases h,
    { simp only [h.left, h.right, zpow_zero, mul_one],
      exact tendsto_const_nhds },
    { exact h.2.symm ▸ tendsto_const_mul_zpow_at_top_zero h.1} }
end

-- TODO: With a different proof, this could be possibly generalised to only require a
-- `linear_ordered_semifield` instance, which would also remove the need for the
-- `nnreal` instance of `has_continuous_inv₀`.
@[priority 100] -- see Note [lower instance priority]
instance linear_ordered_field.to_topological_division_ring : topological_division_ring α :=
{ continuous_at_inv₀ :=
  begin
    suffices : ∀ {x : α}, 0 < x → continuous_at has_inv.inv x,
    { intros x hx,
      cases hx.symm.lt_or_lt,
      { exact this h },
      convert (this $ neg_pos.mpr h).neg.comp continuous_neg.continuous_at,
      ext,
      simp [neg_inv] },
    intros t ht,
    rw [continuous_at,
        (nhds_basis_Ioo_pos t).tendsto_iff $ nhds_basis_Ioo_pos_of_pos $ inv_pos.2 ht],
    rintros ε ⟨hε : ε > 0, hεt : ε ≤ t⁻¹⟩,
    refine ⟨min (t ^ 2 * ε / 2) (t / 2), by positivity, λ x h, _⟩,
    have hx : t / 2 < x,
    { rw [set.mem_Ioo, sub_lt_comm, lt_min_iff] at h,
      nlinarith },
    have hx' : 0 < x := (half_pos ht).trans hx,
    have aux : 0 < 2 / t ^ 2 := by positivity,
    rw [set.mem_Ioo, ←sub_lt_iff_lt_add', sub_lt_comm, ←abs_sub_lt_iff] at h ⊢,
    rw [inv_sub_inv ht.ne' hx'.ne', abs_div, div_eq_mul_inv],
    suffices : |t * x|⁻¹ < 2 / t ^ 2,
    { rw [←abs_neg, neg_sub],
      refine (mul_lt_mul'' h this (by positivity) (by positivity)).trans_le _,
      rw [mul_comm, mul_min_of_nonneg _ _ aux.le],
      apply min_le_of_left_le,
      rw [←mul_div, ←mul_assoc, div_mul_cancel _ (sq_pos_of_pos ht).ne',
          mul_div_cancel' ε two_ne_zero] },
    refine inv_lt_of_inv_lt aux _,
    rw [inv_div, abs_of_pos $ mul_pos ht hx', sq, ←mul_div_assoc'],
    exact mul_lt_mul_of_pos_left hx ht
  end }

lemma nhds_within_pos_comap_mul_left {x : α} (hx : 0 < x) :
  comap (λ ε, x * ε) (𝓝[>] 0) = 𝓝[>] 0 :=
begin
  suffices : ∀ {x : α} (hx : 0 < x), 𝓝[>] 0 ≤ comap (λ ε, x * ε) (𝓝[>] 0),
  { refine le_antisymm _ (this hx),
    have hr : 𝓝[>] (0 : α) = ((𝓝[>] (0 : α)).comap (λ ε, x⁻¹ * ε)).comap (λ ε, x * ε),
    { simp [comap_comap, inv_mul_cancel hx.ne.symm, comap_id, one_mul_eq_id], },
    conv_rhs { rw hr, },
    rw comap_le_comap_iff (by convert univ_mem; exact (mul_left_surjective₀ hx.ne.symm).range_eq),
    exact this (inv_pos.mpr hx), },
  intros x hx,
  convert nhds_within_le_comap (continuous_mul_left x).continuous_within_at,
  { exact (mul_zero _).symm, },
  { rw image_const_mul_Ioi_zero hx, },
end

lemma eventually_nhds_within_pos_mul_left {x : α} (hx : 0 < x)
  {p : α → Prop} (h : ∀ᶠ ε in 𝓝[>] 0, p ε) : ∀ᶠ ε in 𝓝[>] 0, p (x * ε) :=
begin
  convert h.comap (λ ε, x * ε),
  exact (nhds_within_pos_comap_mul_left hx).symm,
end


import topology.constructions
import topology.locally_finite

open set function filter
open_locale topology filter

universe u
variables {ι : Type u} {X Y : Type*} [topological_space X] [topological_space Y]

-- This needs to go into topology.constructions which imports locally_finite and defines the
-- product topology.
lemma locally_finite.prod_right {f : ι → set X} (hf : locally_finite f) (g : ι → set Y) :
  locally_finite (λ i, f i ×ˢ g i) :=
begin
  rintros ⟨x, y⟩,
  rcases hf x with ⟨U, U_in, hU⟩,
  refine ⟨U ×ˢ univ, prod_mem_nhds U_in univ_mem, _⟩,
  apply finite.subset hU,
  rintros i ⟨⟨x', y'⟩, ⟨⟨H, -⟩, ⟨H', -⟩⟩⟩,
  exact ⟨x', H, H'⟩
end

lemma locally_finite.prod_left {f : ι → set X} (hf : locally_finite f) (g : ι → set Y) :
  locally_finite (λ i, g i ×ˢ f i) :=
begin
  rintros ⟨y, x⟩,
  rcases hf x with ⟨U, U_in, hU⟩,
  refine ⟨univ ×ˢ U, prod_mem_nhds univ_mem U_in, _⟩,
  apply finite.subset hU,
  rintros i ⟨⟨y', x'⟩, ⟨⟨-, H⟩, ⟨-, H'⟩⟩⟩,
  exact ⟨x', H, H'⟩
end


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

! This file was ported from Lean 3 source module ring_theory.integral_closure
! leanprover-community/mathlib commit 641b6a82006416ec431b2987b354af9311fed4f2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Polynomial.Expand
import Mathbin.LinearAlgebra.FiniteDimensional
import Mathbin.LinearAlgebra.Matrix.Charpoly.LinearMap
import Mathbin.RingTheory.Adjoin.Fg
import Mathbin.RingTheory.FiniteType
import Mathbin.RingTheory.Polynomial.ScaleRoots
import Mathbin.RingTheory.Polynomial.Tower
import Mathbin.RingTheory.TensorProduct

/-!
# Integral closure of a subring.

If A is an R-algebra then `a : A` is integral over R if it is a root of a monic polynomial
with coefficients in R. Enough theory is developed to prove that integral elements
form a sub-R-algebra of A.

## Main definitions

Let `R` be a `comm_ring` and let `A` be an R-algebra.

* `ring_hom.is_integral_elem (f : R →+* A) (x : A)` : `x` is integral with respect to the map `f`,

* `is_integral (x : A)`  : `x` is integral over `R`, i.e., is a root of a monic polynomial with
                           coefficients in `R`.
* `integral_closure R A` : the integral closure of `R` in `A`, regarded as a sub-`R`-algebra of `A`.
-/

open Classical

open BigOperators Polynomial

open Polynomial Submodule

section Ring

variable {R S A : Type _}

variable [CommRing R] [Ring A] [Ring S] (f : R →+* S)

/-- An element `x` of `A` is said to be integral over `R` with respect to `f`
if it is a root of a monic polynomial `p : R[X]` evaluated under `f` -/
def RingHom.IsIntegralElem (f : R →+* A) (x : A) :=
  ∃ p : R[X], Monic p ∧ eval₂ f x p = 0
#align ring_hom.is_integral_elem RingHom.IsIntegralElem

/-- A ring homomorphism `f : R →+* A` is said to be integral
if every element `A` is integral with respect to the map `f` -/
def RingHom.IsIntegral (f : R →+* A) :=
  ∀ x : A, f.IsIntegralElem x
#align ring_hom.is_integral RingHom.IsIntegral

variable [Algebra R A] (R)

/-- An element `x` of an algebra `A` over a commutative ring `R` is said to be *integral*,
if it is a root of some monic polynomial `p : R[X]`.
Equivalently, the element is integral over `R` with respect to the induced `algebra_map` -/
def IsIntegral (x : A) : Prop :=
  (algebraMap R A).IsIntegralElem x
#align is_integral IsIntegral

variable (A)

/-- An algebra is integral if every element of the extension is integral over the base ring -/
protected def Algebra.IsIntegral : Prop :=
  (algebraMap R A).IsIntegral
#align algebra.is_integral Algebra.IsIntegral

variable {R A}

theorem RingHom.is_integral_map {x : R} : f.IsIntegralElem (f x) :=
  ⟨X - C x, monic_X_sub_C _, by simp⟩
#align ring_hom.is_integral_map RingHom.is_integral_map

theorem isIntegral_algebraMap {x : R} : IsIntegral R (algebraMap R A x) :=
  (algebraMap R A).is_integral_map
#align is_integral_algebra_map isIntegral_algebraMap

theorem isIntegral_of_noetherian (H : IsNoetherian R A) (x : A) : IsIntegral R x :=
  by
  let leval : R[X] →ₗ[R] A := (aeval x).toLinearMap
  let D : ℕ → Submodule R A := fun n => (degree_le R n).map leval
  let M := WellFounded.min (isNoetherian_iff_wellFounded.1 H) (Set.range D) ⟨_, ⟨0, rfl⟩⟩
  have HM : M ∈ Set.range D := WellFounded.min_mem _ _ _
  cases' HM with N HN
  have HM : ¬M < D (N + 1) :=
    WellFounded.not_lt_min (isNoetherian_iff_wellFounded.1 H) (Set.range D) _ ⟨N + 1, rfl⟩
  rw [← HN] at HM
  have HN2 : D (N + 1) ≤ D N :=
    by_contradiction fun H =>
      HM (lt_of_le_not_le (map_mono (degree_le_mono (WithBot.coe_le_coe.2 (Nat.le_succ N)))) H)
  have HN3 : leval (X ^ (N + 1)) ∈ D N := HN2 (mem_map_of_mem (mem_degree_le.2 (degree_X_pow_le _)))
  rcases HN3 with ⟨p, hdp, hpe⟩
  refine' ⟨X ^ (N + 1) - p, monic_X_pow_sub (mem_degree_le.1 hdp), _⟩
  show leval (X ^ (N + 1) - p) = 0
  rw [LinearMap.map_sub, hpe, sub_self]
#align is_integral_of_noetherian isIntegral_of_noetherian

theorem isIntegral_of_submodule_noetherian (S : Subalgebra R A) (H : IsNoetherian R S.toSubmodule)
    (x : A) (hx : x ∈ S) : IsIntegral R x :=
  by
  suffices IsIntegral R (show S from ⟨x, hx⟩)
    by
    rcases this with ⟨p, hpm, hpx⟩
    replace hpx := congr_arg S.val hpx
    refine' ⟨p, hpm, Eq.trans _ hpx⟩
    simp only [aeval_def, eval₂, sum_def]
    rw [S.val.map_sum]
    refine' Finset.sum_congr rfl fun n hn => _
    rw [S.val.map_mul, S.val.map_pow, S.val.commutes, S.val_apply, Subtype.coe_mk]
  refine' isIntegral_of_noetherian H ⟨x, hx⟩
#align is_integral_of_submodule_noetherian isIntegral_of_submodule_noetherian

end Ring

section

variable {R A B S : Type _}

variable [CommRing R] [CommRing A] [CommRing B] [CommRing S]

variable [Algebra R A] [Algebra R B] (f : R →+* S)

theorem map_isIntegral {B C F : Type _} [Ring B] [Ring C] [Algebra R B] [Algebra A B] [Algebra R C]
    [IsScalarTower R A B] [Algebra A C] [IsScalarTower R A C] {b : B} [AlgHomClass F A B C] (f : F)
    (hb : IsIntegral R b) : IsIntegral R (f b) :=
  by
  obtain ⟨P, hP⟩ := hb
  refine' ⟨P, hP.1, _⟩
  rw [← aeval_def, show (aeval (f b)) P = (aeval (f b)) (P.map (algebraMap R A)) by simp,
    aeval_alg_hom_apply, aeval_map_algebra_map, aeval_def, hP.2, _root_.map_zero]
#align map_is_integral map_isIntegral

theorem isIntegral_map_of_comp_eq_of_isIntegral {R S T U : Type _} [CommRing R] [CommRing S]
    [CommRing T] [CommRing U] [Algebra R S] [Algebra T U] (φ : R →+* T) (ψ : S →+* U)
    (h : (algebraMap T U).comp φ = ψ.comp (algebraMap R S)) {a : S} (ha : IsIntegral R a) :
    IsIntegral T (ψ a) := by
  rw [IsIntegral, RingHom.IsIntegralElem] at ha⊢
  obtain ⟨p, hp⟩ := ha
  refine' ⟨p.map φ, hp.left.map _, _⟩
  rw [← eval_map, map_map, h, ← map_map, eval_map, eval₂_at_apply, eval_map, hp.right,
    RingHom.map_zero]
#align is_integral_map_of_comp_eq_of_is_integral isIntegral_map_of_comp_eq_of_isIntegral

theorem isIntegral_algHom_iff {A B : Type _} [Ring A] [Ring B] [Algebra R A] [Algebra R B]
    (f : A →ₐ[R] B) (hf : Function.Injective f) {x : A} : IsIntegral R (f x) ↔ IsIntegral R x :=
  by
  refine' ⟨_, map_isIntegral f⟩
  rintro ⟨p, hp, hx⟩
  use p, hp
  rwa [← f.comp_algebra_map, ← AlgHom.coe_toRingHom, ← Polynomial.hom_eval₂, AlgHom.coe_toRingHom,
    map_eq_zero_iff f hf] at hx
#align is_integral_alg_hom_iff isIntegral_algHom_iff

@[simp]
theorem isIntegral_algEquiv {A B : Type _} [Ring A] [Ring B] [Algebra R A] [Algebra R B]
    (f : A ≃ₐ[R] B) {x : A} : IsIntegral R (f x) ↔ IsIntegral R x :=
  ⟨fun h => by simpa using map_isIntegral f.symm.to_alg_hom h, map_isIntegral f.toAlgHom⟩
#align is_integral_alg_equiv isIntegral_algEquiv

theorem isIntegral_of_isScalarTower [Algebra A B] [IsScalarTower R A B] {x : B}
    (hx : IsIntegral R x) : IsIntegral A x :=
  let ⟨p, hp, hpx⟩ := hx
  ⟨p.map <| algebraMap R A, hp.map _, by rw [← aeval_def, aeval_map_algebra_map, aeval_def, hpx]⟩
#align is_integral_of_is_scalar_tower isIntegral_of_isScalarTower

theorem map_isIntegral_int {B C F : Type _} [Ring B] [Ring C] {b : B} [RingHomClass F B C] (f : F)
    (hb : IsIntegral ℤ b) : IsIntegral ℤ (f b) :=
  map_isIntegral (f : B →+* C).toIntAlgHom hb
#align map_is_integral_int map_isIntegral_int

theorem isIntegral_ofSubring {x : A} (T : Subring R) (hx : IsIntegral T x) : IsIntegral R x :=
  isIntegral_of_isScalarTower hx
#align is_integral_of_subring isIntegral_ofSubring

theorem IsIntegral.algebraMap [Algebra A B] [IsScalarTower R A B] {x : A} (h : IsIntegral R x) :
    IsIntegral R (algebraMap A B x) :=
  by
  rcases h with ⟨f, hf, hx⟩
  use f, hf
  rw [IsScalarTower.algebraMap_eq R A B, ← hom_eval₂, hx, RingHom.map_zero]
#align is_integral.algebra_map IsIntegral.algebraMap

theorem isIntegral_algebraMap_iff [Algebra A B] [IsScalarTower R A B] {x : A}
    (hAB : Function.Injective (algebraMap A B)) :
    IsIntegral R (algebraMap A B x) ↔ IsIntegral R x :=
  isIntegral_algHom_iff (IsScalarTower.toAlgHom R A B) hAB
#align is_integral_algebra_map_iff isIntegral_algebraMap_iff

theorem isIntegral_iff_isIntegral_closure_finite {r : A} :
    IsIntegral R r ↔ ∃ s : Set R, s.Finite ∧ IsIntegral (Subring.closure s) r :=
  by
  constructor <;> intro hr
  · rcases hr with ⟨p, hmp, hpr⟩
    refine' ⟨_, Finset.finite_toSet _, p.restriction, monic_restriction.2 hmp, _⟩
    rw [← aeval_def, ← aeval_map_algebra_map R r p.restriction, map_restriction, aeval_def, hpr]
  rcases hr with ⟨s, hs, hsr⟩
  exact isIntegral_ofSubring _ hsr
#align is_integral_iff_is_integral_closure_finite isIntegral_iff_isIntegral_closure_finite

theorem fg_adjoin_singleton_of_integral (x : A) (hx : IsIntegral R x) :
    (Algebra.adjoin R ({x} : Set A)).toSubmodule.Fg :=
  by
  rcases hx with ⟨f, hfm, hfx⟩
  exists Finset.image ((· ^ ·) x) (Finset.range (nat_degree f + 1))
  apply le_antisymm
  · rw [span_le]
    intro s hs
    rw [Finset.mem_coe] at hs
    rcases Finset.mem_image.1 hs with ⟨k, hk, rfl⟩
    clear hk
    exact (Algebra.adjoin R {x}).pow_mem (Algebra.subset_adjoin (Set.mem_singleton _)) k
  intro r hr; change r ∈ Algebra.adjoin R ({x} : Set A) at hr
  rw [Algebra.adjoin_singleton_eq_range_aeval] at hr
  rcases(aeval x).mem_range.mp hr with ⟨p, rfl⟩
  rw [← mod_by_monic_add_div p hfm]
  rw [← aeval_def] at hfx
  rw [AlgHom.map_add, AlgHom.map_mul, hfx, MulZeroClass.zero_mul, add_zero]
  have : degree (p %ₘ f) ≤ degree f := degree_mod_by_monic_le p hfm
  generalize p %ₘ f = q at this⊢
  rw [← sum_C_mul_X_pow_eq q, aeval_def, eval₂_sum, sum_def]
  refine' sum_mem fun k hkq => _
  rw [eval₂_mul, eval₂_C, eval₂_pow, eval₂_X, ← Algebra.smul_def]
  refine' smul_mem _ _ (subset_span _)
  rw [Finset.mem_coe]; refine' Finset.mem_image.2 ⟨_, _, rfl⟩
  rw [Finset.mem_range, Nat.lt_succ_iff]; refine' le_of_not_lt fun hk => _
  rw [degree_le_iff_coeff_zero] at this
  rw [mem_support_iff] at hkq; apply hkq; apply this
  exact lt_of_le_of_lt degree_le_nat_degree (WithBot.coe_lt_coe.2 hk)
#align fg_adjoin_singleton_of_integral fg_adjoin_singleton_of_integral

theorem fg_adjoin_of_finite {s : Set A} (hfs : s.Finite) (his : ∀ x ∈ s, IsIntegral R x) :
    (Algebra.adjoin R s).toSubmodule.Fg :=
  Set.Finite.induction_on hfs
    (fun _ =>
      ⟨{1},
        Submodule.ext fun x =>
          by
          erw [Algebra.adjoin_empty, Finset.coe_singleton, ← one_eq_span, one_eq_range,
            LinearMap.mem_range, Algebra.mem_bot]
          rfl⟩)
    (fun a s has hs ih his => by
      rw [← Set.union_singleton, Algebra.adjoin_union_coe_submodule] <;>
        exact
          fg.mul (ih fun i hi => his i <| Set.mem_insert_of_mem a hi)
            (fg_adjoin_singleton_of_integral _ <| his a <| Set.mem_insert a s))
    his
#align fg_adjoin_of_finite fg_adjoin_of_finite

theorem isNoetherian_adjoin_finset [IsNoetherianRing R] (s : Finset A)
    (hs : ∀ x ∈ s, IsIntegral R x) : IsNoetherian R (Algebra.adjoin R (↑s : Set A)) :=
  isNoetherian_of_fg_of_noetherian _ (fg_adjoin_of_finite s.finite_toSet hs)
#align is_noetherian_adjoin_finset isNoetherian_adjoin_finset

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- If `S` is a sub-`R`-algebra of `A` and `S` is finitely-generated as an `R`-module,
  then all elements of `S` are integral over `R`. -/
theorem isIntegral_of_mem_of_fg (S : Subalgebra R A) (HS : S.toSubmodule.Fg) (x : A) (hx : x ∈ S) :
    IsIntegral R x :=
  by
  -- say `x ∈ S`. We want to prove that `x` is integral over `R`.
  -- Say `S` is generated as an `R`-module by the set `y`.
  cases' HS with y hy
  -- We can write `x` as `∑ rᵢ yᵢ` for `yᵢ ∈ Y`.
  obtain ⟨lx, hlx1, hlx2⟩ :
    ∃ (l : A →₀ R)(H : l ∈ Finsupp.supported R R ↑y), (Finsupp.total A A R id) l = x := by
    rwa [← @Finsupp.mem_span_image_iff_total A A R _ _ _ id (↑y) x, Set.image_id ↑y, hy]
  -- Note that `y ⊆ S`.
  have hyS : ∀ {p}, p ∈ y → p ∈ S := fun p hp =>
    show p ∈ S.to_submodule by
      rw [← hy]
      exact subset_span hp
  -- Now `S` is a subalgebra so the product of two elements of `y` is also in `S`.
  have : ∀ jk : (↑(y ×ˢ y) : Set (A × A)), jk.1.1 * jk.1.2 ∈ S.to_submodule := fun jk =>
    S.mul_mem (hyS (Finset.mem_product.1 jk.2).1) (hyS (Finset.mem_product.1 jk.2).2)
  rw [← hy, ← Set.image_id ↑y] at this
  simp only [Finsupp.mem_span_image_iff_total] at this
  -- Say `yᵢyⱼ = ∑rᵢⱼₖ yₖ`
  choose ly hly1 hly2
  -- Now let `S₀` be the subring of `R` generated by the `rᵢ` and the `rᵢⱼₖ`.
  let S₀ : Subring R :=
    Subring.closure ↑(lx.frange ∪ Finset.bunionᵢ Finset.univ (Finsupp.frange ∘ ly))
  -- It suffices to prove that `x` is integral over `S₀`.
  refine' isIntegral_ofSubring S₀ _
  letI : CommRing S₀ := SubringClass.toCommRing S₀
  letI : Algebra S₀ A := Algebra.ofSubring S₀
  -- Claim: the `S₀`-module span (in `A`) of the set `y ∪ {1}` is closed under
  -- multiplication (indeed, this is the motivation for the definition of `S₀`).
  have :
    span S₀ (insert 1 ↑y : Set A) * span S₀ (insert 1 ↑y : Set A) ≤ span S₀ (insert 1 ↑y : Set A) :=
    by
    rw [span_mul_span]
    refine' span_le.2 fun z hz => _
    rcases Set.mem_mul.1 hz with ⟨p, q, rfl | hp, hq, rfl⟩
    · rw [one_mul]
      exact subset_span hq
    rcases hq with (rfl | hq)
    · rw [mul_one]
      exact subset_span (Or.inr hp)
    erw [← hly2 ⟨(p, q), Finset.mem_product.2 ⟨hp, hq⟩⟩]
    rw [Finsupp.total_apply, Finsupp.sum]
    refine' (span S₀ (insert 1 ↑y : Set A)).sum_mem fun t ht => _
    have : ly ⟨(p, q), Finset.mem_product.2 ⟨hp, hq⟩⟩ t ∈ S₀ :=
      Subring.subset_closure
        (Finset.mem_union_right _ <|
          Finset.mem_bunionᵢ.2
            ⟨⟨(p, q), Finset.mem_product.2 ⟨hp, hq⟩⟩, Finset.mem_univ _,
              Finsupp.mem_frange.2 ⟨Finsupp.mem_support_iff.1 ht, _, rfl⟩⟩)
    change (⟨_, this⟩ : S₀) • t ∈ _
    exact smul_mem _ _ (subset_span <| Or.inr <| hly1 _ ht)
  -- Hence this span is a subring. Call this subring `S₁`.
  let S₁ : Subring A :=
    { carrier := span S₀ (insert 1 ↑y : Set A)
      one_mem' := subset_span <| Or.inl rfl
      mul_mem' := fun p q hp hq => this <| mul_mem_mul hp hq
      zero_mem' := (span S₀ (insert 1 ↑y : Set A)).zero_mem
      add_mem' := fun _ _ => (span S₀ (insert 1 ↑y : Set A)).add_mem
      neg_mem' := fun _ => (span S₀ (insert 1 ↑y : Set A)).neg_mem }
  have : S₁ = Subalgebra.toSubring (Algebra.adjoin S₀ (↑y : Set A)) :=
    by
    ext z
    suffices
      z ∈ span (↥S₀) (insert 1 ↑y : Set A) ↔ z ∈ (Algebra.adjoin (↥S₀) (y : Set A)).toSubmodule by
      simpa
    constructor <;> intro hz
    ·
      exact
        (span_le.2 (Set.insert_subset.2 ⟨(Algebra.adjoin S₀ ↑y).one_mem, Algebra.subset_adjoin⟩)) hz
    · rw [Subalgebra.mem_toSubmodule, Algebra.mem_adjoin_iff] at hz
      suffices Subring.closure (Set.range ⇑(algebraMap (↥S₀) A) ∪ ↑y) ≤ S₁ by exact this hz
      refine' Subring.closure_le.2 (Set.union_subset _ fun t ht => subset_span <| Or.inr ht)
      rw [Set.range_subset_iff]
      intro y
      rw [Algebra.algebraMap_eq_smul_one]
      exact smul_mem _ y (subset_span (Or.inl rfl))
  have foo : ∀ z, z ∈ S₁ ↔ z ∈ Algebra.adjoin (↥S₀) (y : Set A)
  simp [this]
  haveI : IsNoetherianRing ↥S₀ := is_noetherian_subring_closure _ (Finset.finite_toSet _)
  refine'
    isIntegral_of_submodule_noetherian (Algebra.adjoin S₀ ↑y)
      (isNoetherian_of_fg_of_noetherian _
        ⟨insert 1 y, by
          rw [Finset.coe_insert]
          ext z
          simp [S₁]
          convert foo z⟩)
      _ _
  rw [← hlx2, Finsupp.total_apply, Finsupp.sum]
  refine' Subalgebra.sum_mem _ fun r hr => _
  have : lx r ∈ S₀ :=
    Subring.subset_closure (Finset.mem_union_left _ (Finset.mem_image_of_mem _ hr))
  change (⟨_, this⟩ : S₀) • r ∈ _
  rw [Finsupp.mem_supported] at hlx1
  exact Subalgebra.smul_mem _ (Algebra.subset_adjoin <| hlx1 hr) _
#align is_integral_of_mem_of_fg isIntegral_of_mem_of_fg

theorem Module.End.isIntegral {M : Type _} [AddCommGroup M] [Module R M] [Module.Finite R M] :
    Algebra.IsIntegral R (Module.End R M) :=
  LinearMap.exists_monic_and_aeval_eq_zero R
#align module.End.is_integral Module.End.isIntegral

/-- Suppose `A` is an `R`-algebra, `M` is an `A`-module such that `a • m ≠ 0` for all non-zero `a`
and `m`. If `x : A` fixes a nontrivial f.g. `R`-submodule `N` of `M`, then `x` is `R`-integral. -/
theorem isIntegral_of_smul_mem_submodule {M : Type _} [AddCommGroup M] [Module R M] [Module A M]
    [IsScalarTower R A M] [NoZeroSMulDivisors A M] (N : Submodule R M) (hN : N ≠ ⊥) (hN' : N.Fg)
    (x : A) (hx : ∀ n ∈ N, x • n ∈ N) : IsIntegral R x :=
  by
  let A' : Subalgebra R A :=
    { carrier := { x | ∀ n ∈ N, x • n ∈ N }
      mul_mem' := fun a b ha hb n hn => smul_smul a b n ▸ ha _ (hb _ hn)
      one_mem' := fun n hn => (one_smul A n).symm ▸ hn
      add_mem' := fun a b ha hb n hn => (add_smul a b n).symm ▸ N.add_mem (ha _ hn) (hb _ hn)
      zero_mem' := fun n hn => (zero_smul A n).symm ▸ N.zero_mem
      algebraMap_mem' := fun r n hn => (algebraMap_smul A r n).symm ▸ N.smul_mem r hn }
  let f : A' →ₐ[R] Module.End R N :=
    AlgHom.ofLinearMap
      { toFun := fun x => (DistribMulAction.toLinearMap R M x).restrict x.Prop
        map_add' := fun x y => LinearMap.ext fun n => Subtype.ext <| add_smul x y n
        map_smul' := fun r s => LinearMap.ext fun n => Subtype.ext <| smul_assoc r s n }
      (LinearMap.ext fun n => Subtype.ext <| one_smul _ _) fun x y =>
      LinearMap.ext fun n => Subtype.ext <| mul_smul x y n
  obtain ⟨a, ha₁, ha₂⟩ : ∃ a ∈ N, a ≠ (0 : M) :=
    by
    by_contra h'
    push_neg  at h'
    apply hN
    rwa [eq_bot_iff]
  have : Function.Injective f :=
    by
    show Function.Injective f.to_linear_map
    rw [← LinearMap.ker_eq_bot, eq_bot_iff]
    intro s hs
    have : s.1 • a = 0 := congr_arg Subtype.val (LinearMap.congr_fun hs ⟨a, ha₁⟩)
    exact Subtype.ext ((eq_zero_or_eq_zero_of_smul_eq_zero this).resolve_right ha₂)
  show IsIntegral R (A'.val ⟨x, hx⟩)
  rw [isIntegral_algHom_iff A'.val Subtype.val_injective, ← isIntegral_algHom_iff f this]
  haveI : Module.Finite R N := by rwa [Module.finite_def, Submodule.fg_top]
  apply Module.End.isIntegral
#align is_integral_of_smul_mem_submodule isIntegral_of_smul_mem_submodule

variable {f}

theorem RingHom.Finite.to_isIntegral (h : f.Finite) : f.IsIntegral :=
  letI := f.to_algebra
  fun x => isIntegral_of_mem_of_fg ⊤ h.1 _ trivial
#align ring_hom.finite.to_is_integral RingHom.Finite.to_isIntegral

alias RingHom.Finite.to_isIntegral ← RingHom.IsIntegral.of_finite
#align ring_hom.is_integral.of_finite RingHom.IsIntegral.of_finite

theorem RingHom.IsIntegral.to_finite (h : f.IsIntegral) (h' : f.FiniteType) : f.Finite :=
  by
  letI := f.to_algebra
  obtain ⟨s, hs⟩ := h'
  constructor
  change (⊤ : Subalgebra R S).toSubmodule.Fg
  rw [← hs]
  exact fg_adjoin_of_finite (Set.toFinite _) fun x _ => h x
#align ring_hom.is_integral.to_finite RingHom.IsIntegral.to_finite

alias RingHom.IsIntegral.to_finite ← RingHom.Finite.of_isIntegral_of_finiteType
#align ring_hom.finite.of_is_integral_of_finite_type RingHom.Finite.of_isIntegral_of_finiteType

/-- finite = integral + finite type -/
theorem RingHom.finite_iff_isIntegral_and_finiteType : f.Finite ↔ f.IsIntegral ∧ f.FiniteType :=
  ⟨fun h => ⟨h.to_isIntegral, h.to_finiteType⟩, fun ⟨h, h'⟩ => h.toFinite h'⟩
#align ring_hom.finite_iff_is_integral_and_finite_type RingHom.finite_iff_isIntegral_and_finiteType

theorem Algebra.IsIntegral.finite (h : Algebra.IsIntegral R A) [h' : Algebra.FiniteType R A] :
    Module.Finite R A :=
  by
  have :=
    h.to_finite
      (by
        delta RingHom.FiniteType
        convert h'
        ext
        exact (Algebra.smul_def _ _).symm)
  delta RingHom.Finite at this; convert this; ext; exact Algebra.smul_def _ _
#align algebra.is_integral.finite Algebra.IsIntegral.finite

theorem Algebra.IsIntegral.of_finite [h : Module.Finite R A] : Algebra.IsIntegral R A :=
  by
  apply RingHom.Finite.to_isIntegral
  delta RingHom.Finite; convert h; ext; exact (Algebra.smul_def _ _).symm
#align algebra.is_integral.of_finite Algebra.IsIntegral.of_finite

/-- finite = integral + finite type -/
theorem Algebra.finite_iff_isIntegral_and_finiteType :
    Module.Finite R A ↔ Algebra.IsIntegral R A ∧ Algebra.FiniteType R A :=
  ⟨fun h => ⟨Algebra.IsIntegral.of_finite, inferInstance⟩, fun ⟨h, h'⟩ => h.finite⟩
#align algebra.finite_iff_is_integral_and_finite_type Algebra.finite_iff_isIntegral_and_finiteType

variable (f)

theorem RingHom.is_integral_of_mem_closure {x y z : S} (hx : f.IsIntegralElem x)
    (hy : f.IsIntegralElem y) (hz : z ∈ Subring.closure ({x, y} : Set S)) : f.IsIntegralElem z :=
  by
  letI : Algebra R S := f.to_algebra
  have := (fg_adjoin_singleton_of_integral x hx).mul (fg_adjoin_singleton_of_integral y hy)
  rw [← Algebra.adjoin_union_coe_submodule, Set.singleton_union] at this
  exact
    isIntegral_of_mem_of_fg (Algebra.adjoin R {x, y}) this z
      (Algebra.mem_adjoin_iff.2 <| Subring.closure_mono (Set.subset_union_right _ _) hz)
#align ring_hom.is_integral_of_mem_closure RingHom.is_integral_of_mem_closure

theorem isIntegral_of_mem_closure {x y z : A} (hx : IsIntegral R x) (hy : IsIntegral R y)
    (hz : z ∈ Subring.closure ({x, y} : Set A)) : IsIntegral R z :=
  (algebraMap R A).is_integral_of_mem_closure hx hy hz
#align is_integral_of_mem_closure isIntegral_of_mem_closure

theorem RingHom.is_integral_zero : f.IsIntegralElem 0 :=
  f.map_zero ▸ f.is_integral_map
#align ring_hom.is_integral_zero RingHom.is_integral_zero

theorem isIntegral_zero : IsIntegral R (0 : A) :=
  (algebraMap R A).is_integral_zero
#align is_integral_zero isIntegral_zero

theorem RingHom.is_integral_one : f.IsIntegralElem 1 :=
  f.map_one ▸ f.is_integral_map
#align ring_hom.is_integral_one RingHom.is_integral_one

theorem isIntegral_one : IsIntegral R (1 : A) :=
  (algebraMap R A).is_integral_one
#align is_integral_one isIntegral_one

theorem RingHom.is_integral_add {x y : S} (hx : f.IsIntegralElem x) (hy : f.IsIntegralElem y) :
    f.IsIntegralElem (x + y) :=
  f.is_integral_of_mem_closure hx hy <|
    Subring.add_mem _ (Subring.subset_closure (Or.inl rfl)) (Subring.subset_closure (Or.inr rfl))
#align ring_hom.is_integral_add RingHom.is_integral_add

theorem isIntegral_add {x y : A} (hx : IsIntegral R x) (hy : IsIntegral R y) :
    IsIntegral R (x + y) :=
  (algebraMap R A).is_integral_add hx hy
#align is_integral_add isIntegral_add

theorem RingHom.is_integral_neg {x : S} (hx : f.IsIntegralElem x) : f.IsIntegralElem (-x) :=
  f.is_integral_of_mem_closure hx hx (Subring.neg_mem _ (Subring.subset_closure (Or.inl rfl)))
#align ring_hom.is_integral_neg RingHom.is_integral_neg

theorem isIntegral_neg {x : A} (hx : IsIntegral R x) : IsIntegral R (-x) :=
  (algebraMap R A).is_integral_neg hx
#align is_integral_neg isIntegral_neg

theorem RingHom.is_integral_sub {x y : S} (hx : f.IsIntegralElem x) (hy : f.IsIntegralElem y) :
    f.IsIntegralElem (x - y) := by
  simpa only [sub_eq_add_neg] using f.is_integral_add hx (f.is_integral_neg hy)
#align ring_hom.is_integral_sub RingHom.is_integral_sub

theorem isIntegral_sub {x y : A} (hx : IsIntegral R x) (hy : IsIntegral R y) :
    IsIntegral R (x - y) :=
  (algebraMap R A).is_integral_sub hx hy
#align is_integral_sub isIntegral_sub

theorem RingHom.is_integral_mul {x y : S} (hx : f.IsIntegralElem x) (hy : f.IsIntegralElem y) :
    f.IsIntegralElem (x * y) :=
  f.is_integral_of_mem_closure hx hy
    (Subring.mul_mem _ (Subring.subset_closure (Or.inl rfl)) (Subring.subset_closure (Or.inr rfl)))
#align ring_hom.is_integral_mul RingHom.is_integral_mul

theorem isIntegral_mul {x y : A} (hx : IsIntegral R x) (hy : IsIntegral R y) :
    IsIntegral R (x * y) :=
  (algebraMap R A).is_integral_mul hx hy
#align is_integral_mul isIntegral_mul

theorem isIntegral_smul [Algebra S A] [Algebra R S] [IsScalarTower R S A] {x : A} (r : R)
    (hx : IsIntegral S x) : IsIntegral S (r • x) :=
  by
  rw [Algebra.smul_def, IsScalarTower.algebraMap_apply R S A]
  exact isIntegral_mul isIntegral_algebraMap hx
#align is_integral_smul isIntegral_smul

theorem isIntegral_of_pow {x : A} {n : ℕ} (hn : 0 < n) (hx : IsIntegral R <| x ^ n) :
    IsIntegral R x := by
  rcases hx with ⟨p, ⟨hmonic, heval⟩⟩
  exact
    ⟨expand R n p, monic.expand hn hmonic, by
      rwa [eval₂_eq_eval_map, map_expand, expand_eval, ← eval₂_eq_eval_map]⟩
#align is_integral_of_pow isIntegral_of_pow

variable (R A)

/-- The integral closure of R in an R-algebra A. -/
def integralClosure : Subalgebra R A
    where
  carrier := { r | IsIntegral R r }
  zero_mem' := isIntegral_zero
  one_mem' := isIntegral_one
  add_mem' _ _ := isIntegral_add
  mul_mem' _ _ := isIntegral_mul
  algebraMap_mem' x := isIntegral_algebraMap
#align integral_closure integralClosure

theorem mem_integralClosure_iff_mem_fg {r : A} :
    r ∈ integralClosure R A ↔ ∃ M : Subalgebra R A, M.toSubmodule.Fg ∧ r ∈ M :=
  ⟨fun hr =>
    ⟨Algebra.adjoin R {r}, fg_adjoin_singleton_of_integral _ hr, Algebra.subset_adjoin rfl⟩,
    fun ⟨M, Hf, hrM⟩ => isIntegral_of_mem_of_fg M Hf _ hrM⟩
#align mem_integral_closure_iff_mem_fg mem_integralClosure_iff_mem_fg

variable {R} {A}

theorem adjoin_le_integralClosure {x : A} (hx : IsIntegral R x) :
    Algebra.adjoin R {x} ≤ integralClosure R A :=
  by
  rw [Algebra.adjoin_le_iff]
  simp only [SetLike.mem_coe, Set.singleton_subset_iff]
  exact hx
#align adjoin_le_integral_closure adjoin_le_integralClosure

theorem le_integralClosure_iff_isIntegral {S : Subalgebra R A} :
    S ≤ integralClosure R A ↔ Algebra.IsIntegral R S :=
  SetLike.forall.symm.trans
    (forall_congr' fun x =>
      show IsIntegral R (algebraMap S A x) ↔ IsIntegral R x from
        isIntegral_algebraMap_iff Subtype.coe_injective)
#align le_integral_closure_iff_is_integral le_integralClosure_iff_isIntegral

theorem isIntegral_sup {S T : Subalgebra R A} :
    Algebra.IsIntegral R ↥(S ⊔ T) ↔ Algebra.IsIntegral R S ∧ Algebra.IsIntegral R T := by
  simp only [← le_integralClosure_iff_isIntegral, sup_le_iff]
#align is_integral_sup isIntegral_sup

/-- Mapping an integral closure along an `alg_equiv` gives the integral closure. -/
theorem integralClosure_map_algEquiv (f : A ≃ₐ[R] B) :
    (integralClosure R A).map (f : A →ₐ[R] B) = integralClosure R B :=
  by
  ext y
  rw [Subalgebra.mem_map]
  constructor
  · rintro ⟨x, hx, rfl⟩
    exact map_isIntegral f hx
  · intro hy
    use f.symm y, map_isIntegral (f.symm : B →ₐ[R] A) hy
    simp
#align integral_closure_map_alg_equiv integralClosure_map_algEquiv

theorem integralClosure.isIntegral (x : integralClosure R A) : IsIntegral R x :=
  let ⟨p, hpm, hpx⟩ := x.2
  ⟨p, hpm,
    Subtype.eq <| by
      rwa [← aeval_def, Subtype.val_eq_coe, ← Subalgebra.val_apply, aeval_alg_hom_apply] at hpx⟩
#align integral_closure.is_integral integralClosure.isIntegral

theorem RingHom.is_integral_of_is_integral_mul_unit (x y : S) (r : R) (hr : f r * y = 1)
    (hx : f.IsIntegralElem (x * y)) : f.IsIntegralElem x :=
  by
  obtain ⟨p, ⟨p_monic, hp⟩⟩ := hx
  refine' ⟨scale_roots p r, ⟨(monic_scale_roots_iff r).2 p_monic, _⟩⟩
  convert scale_roots_eval₂_eq_zero f hp
  rw [mul_comm x y, ← mul_assoc, hr, one_mul]
#align ring_hom.is_integral_of_is_integral_mul_unit RingHom.is_integral_of_is_integral_mul_unit

theorem isIntegral_of_isIntegral_mul_unit {x y : A} {r : R} (hr : algebraMap R A r * y = 1)
    (hx : IsIntegral R (x * y)) : IsIntegral R x :=
  (algebraMap R A).is_integral_of_is_integral_mul_unit x y r hr hx
#align is_integral_of_is_integral_mul_unit isIntegral_of_isIntegral_mul_unit

/-- Generalization of `is_integral_of_mem_closure` bootstrapped up from that lemma -/
theorem isIntegral_of_mem_closure' (G : Set A) (hG : ∀ x ∈ G, IsIntegral R x) :
    ∀ x ∈ Subring.closure G, IsIntegral R x := fun x hx =>
  Subring.closure_induction hx hG isIntegral_zero isIntegral_one (fun _ _ => isIntegral_add)
    (fun _ => isIntegral_neg) fun _ _ => isIntegral_mul
#align is_integral_of_mem_closure' isIntegral_of_mem_closure'

theorem is_integral_of_mem_closure'' {S : Type _} [CommRing S] {f : R →+* S} (G : Set S)
    (hG : ∀ x ∈ G, f.IsIntegralElem x) : ∀ x ∈ Subring.closure G, f.IsIntegralElem x := fun x hx =>
  @isIntegral_of_mem_closure' R S _ _ f.toAlgebra G hG x hx
#align is_integral_of_mem_closure'' is_integral_of_mem_closure''

theorem IsIntegral.pow {x : A} (h : IsIntegral R x) (n : ℕ) : IsIntegral R (x ^ n) :=
  (integralClosure R A).pow_mem h n
#align is_integral.pow IsIntegral.pow

theorem IsIntegral.nsmul {x : A} (h : IsIntegral R x) (n : ℕ) : IsIntegral R (n • x) :=
  (integralClosure R A).nsmul_mem h n
#align is_integral.nsmul IsIntegral.nsmul

theorem IsIntegral.zsmul {x : A} (h : IsIntegral R x) (n : ℤ) : IsIntegral R (n • x) :=
  (integralClosure R A).zsmul_mem h n
#align is_integral.zsmul IsIntegral.zsmul

theorem IsIntegral.multiset_prod {s : Multiset A} (h : ∀ x ∈ s, IsIntegral R x) :
    IsIntegral R s.Prod :=
  (integralClosure R A).multiset_prod_mem h
#align is_integral.multiset_prod IsIntegral.multiset_prod

theorem IsIntegral.multiset_sum {s : Multiset A} (h : ∀ x ∈ s, IsIntegral R x) :
    IsIntegral R s.Sum :=
  (integralClosure R A).multiset_sum_mem h
#align is_integral.multiset_sum IsIntegral.multiset_sum

theorem IsIntegral.prod {α : Type _} {s : Finset α} (f : α → A) (h : ∀ x ∈ s, IsIntegral R (f x)) :
    IsIntegral R (∏ x in s, f x) :=
  (integralClosure R A).prod_mem h
#align is_integral.prod IsIntegral.prod

theorem IsIntegral.sum {α : Type _} {s : Finset α} (f : α → A) (h : ∀ x ∈ s, IsIntegral R (f x)) :
    IsIntegral R (∑ x in s, f x) :=
  (integralClosure R A).sum_mem h
#align is_integral.sum IsIntegral.sum

theorem IsIntegral.det {n : Type _} [Fintype n] [DecidableEq n] {M : Matrix n n A}
    (h : ∀ i j, IsIntegral R (M i j)) : IsIntegral R M.det :=
  by
  rw [Matrix.det_apply]
  exact IsIntegral.sum _ fun σ hσ => IsIntegral.zsmul (IsIntegral.prod _ fun i hi => h _ _) _
#align is_integral.det IsIntegral.det

@[simp]
theorem IsIntegral.pow_iff {x : A} {n : ℕ} (hn : 0 < n) : IsIntegral R (x ^ n) ↔ IsIntegral R x :=
  ⟨isIntegral_of_pow hn, fun hx => IsIntegral.pow hx n⟩
#align is_integral.pow_iff IsIntegral.pow_iff

open TensorProduct

theorem IsIntegral.tmul (x : A) {y : B} (h : IsIntegral R y) : IsIntegral A (x ⊗ₜ[R] y) :=
  by
  obtain ⟨p, hp, hp'⟩ := h
  refine' ⟨(p.map (algebraMap R A)).scaleRoots x, _, _⟩
  · rw [Polynomial.monic_scaleRoots_iff]
    exact hp.map _
  convert@Polynomial.scaleRoots_eval₂_mul (A ⊗[R] B) A _ _ _
      algebra.tensor_product.include_left.to_ring_hom (1 ⊗ₜ y) x using
    2
  ·
    simp only [AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, mul_one, one_mul,
      Algebra.TensorProduct.includeLeft_apply, Algebra.TensorProduct.tmul_mul_tmul]
  convert(MulZeroClass.mul_zero _).symm
  rw [Polynomial.eval₂_map, Algebra.TensorProduct.includeLeft_comp_algebraMap, ←
    Polynomial.eval₂_map]
  convert Polynomial.eval₂_at_apply algebra.tensor_product.include_right.to_ring_hom y
  rw [Polynomial.eval_map, hp', _root_.map_zero]
#align is_integral.tmul IsIntegral.tmul

section

variable (p : R[X]) (x : S)

/-- The monic polynomial whose roots are `p.leading_coeff * x` for roots `x` of `p`. -/
noncomputable def normalizeScaleRoots (p : R[X]) : R[X] :=
  ∑ i in p.support,
    monomial i (if i = p.natDegree then 1 else p.coeff i * p.leadingCoeff ^ (p.natDegree - 1 - i))
#align normalize_scale_roots normalizeScaleRoots

theorem normalizeScaleRoots_coeff_mul_leadingCoeff_pow (i : ℕ) (hp : 1 ≤ natDegree p) :
    (normalizeScaleRoots p).coeff i * p.leadingCoeff ^ i =
      p.coeff i * p.leadingCoeff ^ (p.natDegree - 1) :=
  by
  simp only [normalizeScaleRoots, finset_sum_coeff, coeff_monomial, Finset.sum_ite_eq', one_mul,
    MulZeroClass.zero_mul, mem_support_iff, ite_mul, Ne.def, ite_not]
  split_ifs with h₁ h₂
  · simp [h₁]
  · rw [h₂, leading_coeff, ← pow_succ, tsub_add_cancel_of_le hp]
  · rw [mul_assoc, ← pow_add, tsub_add_cancel_of_le]
    apply Nat.le_pred_of_lt
    rw [lt_iff_le_and_ne]
    exact ⟨le_nat_degree_of_ne_zero h₁, h₂⟩
#align normalize_scale_roots_coeff_mul_leading_coeff_pow normalizeScaleRoots_coeff_mul_leadingCoeff_pow

theorem leadingCoeff_smul_normalizeScaleRoots (p : R[X]) :
    p.leadingCoeff • normalizeScaleRoots p = scaleRoots p p.leadingCoeff :=
  by
  ext
  simp only [coeff_scale_roots, normalizeScaleRoots, coeff_monomial, coeff_smul, Finset.smul_sum,
    Ne.def, Finset.sum_ite_eq', finset_sum_coeff, smul_ite, smul_zero, mem_support_iff]
  split_ifs with h₁ h₂
  · simp [*]
  · simp [*]
  · rw [Algebra.id.smul_eq_mul, mul_comm, mul_assoc, ← pow_succ', tsub_right_comm,
      tsub_add_cancel_of_le]
    rw [Nat.succ_le_iff]
    exact tsub_pos_of_lt (lt_of_le_of_ne (le_nat_degree_of_ne_zero h₁) h₂)
#align leading_coeff_smul_normalize_scale_roots leadingCoeff_smul_normalizeScaleRoots

theorem normalizeScaleRoots_support : (normalizeScaleRoots p).support ≤ p.support :=
  by
  intro x
  contrapose
  simp only [not_mem_support_iff, normalizeScaleRoots, finset_sum_coeff, coeff_monomial,
    Finset.sum_ite_eq', mem_support_iff, Ne.def, Classical.not_not, ite_eq_right_iff]
  intro h₁ h₂
  exact (h₂ h₁).rec _
#align normalize_scale_roots_support normalizeScaleRoots_support

theorem normalizeScaleRoots_degree : (normalizeScaleRoots p).degree = p.degree :=
  by
  apply le_antisymm
  · exact Finset.sup_mono (normalizeScaleRoots_support p)
  · rw [← degree_scale_roots, ← leadingCoeff_smul_normalizeScaleRoots]
    exact degree_smul_le _ _
#align normalize_scale_roots_degree normalizeScaleRoots_degree

theorem normalizeScaleRoots_eval₂_leadingCoeff_mul (h : 1 ≤ p.natDegree) (f : R →+* S) (x : S) :
    (normalizeScaleRoots p).eval₂ f (f p.leadingCoeff * x) =
      f p.leadingCoeff ^ (p.natDegree - 1) * p.eval₂ f x :=
  by
  rw [eval₂_eq_sum_range, eval₂_eq_sum_range, Finset.mul_sum]
  apply Finset.sum_congr
  · rw [nat_degree_eq_of_degree_eq (normalizeScaleRoots_degree p)]
  intro n hn
  rw [mul_pow, ← mul_assoc, ← f.map_pow, ← f.map_mul,
    normalizeScaleRoots_coeff_mul_leadingCoeff_pow _ _ h, f.map_mul, f.map_pow]
  ring
#align normalize_scale_roots_eval₂_leading_coeff_mul normalizeScaleRoots_eval₂_leadingCoeff_mul

theorem normalizeScaleRoots_monic (h : p ≠ 0) : (normalizeScaleRoots p).Monic :=
  by
  delta monic leading_coeff
  rw [nat_degree_eq_of_degree_eq (normalizeScaleRoots_degree p)]
  suffices p = 0 → (0 : R) = 1 by simpa [normalizeScaleRoots, coeff_monomial]
  exact fun h' => (h h').rec _
#align normalize_scale_roots_monic normalizeScaleRoots_monic

/-- Given a `p : R[X]` and a `x : S` such that `p.eval₂ f x = 0`,
`f p.leading_coeff * x` is integral. -/
theorem RingHom.isIntegralElem_leadingCoeff_mul (h : p.eval₂ f x = 0) :
    f.IsIntegralElem (f p.leadingCoeff * x) :=
  by
  by_cases h' : 1 ≤ p.nat_degree
  · use normalizeScaleRoots p
    have : p ≠ 0 := fun h'' => by
      rw [h'', nat_degree_zero] at h'
      exact Nat.not_succ_le_zero 0 h'
    use normalizeScaleRoots_monic p this
    rw [normalizeScaleRoots_eval₂_leadingCoeff_mul p h' f x, h, MulZeroClass.mul_zero]
  · by_cases hp : p.map f = 0
    · apply_fun fun q => coeff q p.nat_degree  at hp
      rw [coeff_map, coeff_zero, coeff_nat_degree] at hp
      rw [hp, MulZeroClass.zero_mul]
      exact f.is_integral_zero
    · rw [Nat.one_le_iff_ne_zero, Classical.not_not] at h'
      rw [eq_C_of_nat_degree_eq_zero h', eval₂_C] at h
      suffices p.map f = 0 by exact (hp this).rec _
      rw [eq_C_of_nat_degree_eq_zero h', map_C, h, C_eq_zero]
#align ring_hom.is_integral_elem_leading_coeff_mul RingHom.isIntegralElem_leadingCoeff_mul

/-- Given a `p : R[X]` and a root `x : S`,
then `p.leading_coeff • x : S` is integral over `R`. -/
theorem isIntegral_leadingCoeff_smul [Algebra R S] (h : aeval x p = 0) :
    IsIntegral R (p.leadingCoeff • x) :=
  by
  rw [aeval_def] at h
  rw [Algebra.smul_def]
  exact (algebraMap R S).isIntegralElem_leadingCoeff_mul p x h
#align is_integral_leading_coeff_smul isIntegral_leadingCoeff_smul

end

end

section IsIntegralClosure

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`algebraMap_injective] [] -/
/-- `is_integral_closure A R B` is the characteristic predicate stating `A` is
the integral closure of `R` in `B`,
i.e. that an element of `B` is integral over `R` iff it is an element of (the image of) `A`.
-/
class IsIntegralClosure (A R B : Type _) [CommRing R] [CommSemiring A] [CommRing B] [Algebra R B]
  [Algebra A B] : Prop where
  algebraMap_injective : Function.Injective (algebraMap A B)
  isIntegral_iff : ∀ {x : B}, IsIntegral R x ↔ ∃ y, algebraMap A B y = x
#align is_integral_closure IsIntegralClosure

instance integralClosure.isIntegralClosure (R A : Type _) [CommRing R] [CommRing A] [Algebra R A] :
    IsIntegralClosure (integralClosure R A) R A :=
  ⟨Subtype.coe_injective, fun x =>
    ⟨fun h => ⟨⟨x, h⟩, rfl⟩, by
      rintro ⟨⟨_, h⟩, rfl⟩
      exact h⟩⟩
#align integral_closure.is_integral_closure integralClosure.isIntegralClosure

namespace IsIntegralClosure

variable {R A B : Type _} [CommRing R] [CommRing A] [CommRing B]

variable [Algebra R B] [Algebra A B] [IsIntegralClosure A R B]

variable (R) {A} (B)

protected theorem isIntegral [Algebra R A] [IsScalarTower R A B] (x : A) : IsIntegral R x :=
  (isIntegral_algebraMap_iff (algebraMap_injective A R B)).mp <|
    show IsIntegral R (algebraMap A B x) from isIntegral_iff.mpr ⟨x, rfl⟩
#align is_integral_closure.is_integral IsIntegralClosure.isIntegral

theorem isIntegral_algebra [Algebra R A] [IsScalarTower R A B] : Algebra.IsIntegral R A := fun x =>
  IsIntegralClosure.isIntegral R B x
#align is_integral_closure.is_integral_algebra IsIntegralClosure.isIntegral_algebra

theorem noZeroSMulDivisors [Algebra R A] [IsScalarTower R A B] [NoZeroSMulDivisors R B] :
    NoZeroSMulDivisors R A :=
  by
  refine'
    Function.Injective.noZeroSMulDivisors _ (IsIntegralClosure.algebraMap_injective A R B)
      (map_zero _) fun _ _ => _
  simp only [Algebra.algebraMap_eq_smul_one, IsScalarTower.smul_assoc]
#align is_integral_closure.no_zero_smul_divisors IsIntegralClosure.noZeroSMulDivisors

variable {R} (A) {B}

/-- If `x : B` is integral over `R`, then it is an element of the integral closure of `R` in `B`. -/
noncomputable def mk' (x : B) (hx : IsIntegral R x) : A :=
  Classical.choose (isIntegral_iff.mp hx)
#align is_integral_closure.mk' IsIntegralClosure.mk'

@[simp]
theorem algebraMap_mk' (x : B) (hx : IsIntegral R x) : algebraMap A B (mk' A x hx) = x :=
  Classical.choose_spec (isIntegral_iff.mp hx)
#align is_integral_closure.algebra_map_mk' IsIntegralClosure.algebraMap_mk'

@[simp]
theorem mk'_one (h : IsIntegral R (1 : B) := isIntegral_one) : mk' A 1 h = 1 :=
  algebraMap_injective A R B <| by rw [algebra_map_mk', RingHom.map_one]
#align is_integral_closure.mk'_one IsIntegralClosure.mk'_one

@[simp]
theorem mk'_zero (h : IsIntegral R (0 : B) := isIntegral_zero) : mk' A 0 h = 0 :=
  algebraMap_injective A R B <| by rw [algebra_map_mk', RingHom.map_zero]
#align is_integral_closure.mk'_zero IsIntegralClosure.mk'_zero

@[simp]
theorem mk'_add (x y : B) (hx : IsIntegral R x) (hy : IsIntegral R y) :
    mk' A (x + y) (isIntegral_add hx hy) = mk' A x hx + mk' A y hy :=
  algebraMap_injective A R B <| by simp only [algebra_map_mk', RingHom.map_add]
#align is_integral_closure.mk'_add IsIntegralClosure.mk'_add

@[simp]
theorem mk'_mul (x y : B) (hx : IsIntegral R x) (hy : IsIntegral R y) :
    mk' A (x * y) (isIntegral_mul hx hy) = mk' A x hx * mk' A y hy :=
  algebraMap_injective A R B <| by simp only [algebra_map_mk', RingHom.map_mul]
#align is_integral_closure.mk'_mul IsIntegralClosure.mk'_mul

@[simp]
theorem mk'_algebraMap [Algebra R A] [IsScalarTower R A B] (x : R)
    (h : IsIntegral R (algebraMap R B x) := isIntegral_algebraMap) :
    IsIntegralClosure.mk' A (algebraMap R B x) h = algebraMap R A x :=
  algebraMap_injective A R B <| by rw [algebra_map_mk', ← IsScalarTower.algebraMap_apply]
#align is_integral_closure.mk'_algebra_map IsIntegralClosure.mk'_algebraMap

section lift

variable {R} (A B) {S : Type _} [CommRing S] [Algebra R S] [Algebra S B] [IsScalarTower R S B]

variable [Algebra R A] [IsScalarTower R A B] (h : Algebra.IsIntegral R S)

/-- If `B / S / R` is a tower of ring extensions where `S` is integral over `R`,
then `S` maps (uniquely) into an integral closure `B / A / R`. -/
noncomputable def lift : S →ₐ[R] A
    where
  toFun x := mk' A (algebraMap S B x) (IsIntegral.algebraMap (h x))
  map_one' := by simp only [RingHom.map_one, mk'_one]
  map_zero' := by simp only [RingHom.map_zero, mk'_zero]
  map_add' x y := by simp_rw [← mk'_add, RingHom.map_add]
  map_mul' x y := by simp_rw [← mk'_mul, RingHom.map_mul]
  commutes' x := by simp_rw [← IsScalarTower.algebraMap_apply, mk'_algebra_map]
#align is_integral_closure.lift IsIntegralClosure.lift

@[simp]
theorem algebraMap_lift (x : S) : algebraMap A B (lift A B h x) = algebraMap S B x :=
  algebraMap_mk' _ _ _
#align is_integral_closure.algebra_map_lift IsIntegralClosure.algebraMap_lift

end lift

section Equiv

variable (R A B) (A' : Type _) [CommRing A'] [Algebra A' B] [IsIntegralClosure A' R B]

variable [Algebra R A] [Algebra R A'] [IsScalarTower R A B] [IsScalarTower R A' B]

/-- Integral closures are all isomorphic to each other. -/
noncomputable def equiv : A ≃ₐ[R] A' :=
  AlgEquiv.ofAlgHom (lift _ B (isIntegral_algebra R B)) (lift _ B (isIntegral_algebra R B))
    (by
      ext x
      apply algebra_map_injective A' R B
      simp)
    (by
      ext x
      apply algebra_map_injective A R B
      simp)
#align is_integral_closure.equiv IsIntegralClosure.equiv

@[simp]
theorem algebraMap_equiv (x : A) : algebraMap A' B (equiv R A B A' x) = algebraMap A B x :=
  algebraMap_lift _ _ _ _
#align is_integral_closure.algebra_map_equiv IsIntegralClosure.algebraMap_equiv

end Equiv

end IsIntegralClosure

end IsIntegralClosure

section Algebra

open Algebra

variable {R A B S T : Type _}

variable [CommRing R] [CommRing A] [CommRing B] [CommRing S] [CommRing T]

variable [Algebra A B] [Algebra R B] (f : R →+* S) (g : S →+* T)

theorem isIntegral_trans_aux (x : B) {p : A[X]} (pmonic : Monic p) (hp : aeval x p = 0) :
    IsIntegral (adjoin R (↑(p.map <| algebraMap A B).frange : Set B)) x :=
  by
  generalize hS : (↑(p.map <| algebraMap A B).frange : Set B) = S
  have coeffs_mem : ∀ i, (p.map <| algebraMap A B).coeff i ∈ adjoin R S :=
    by
    intro i
    by_cases hi : (p.map <| algebraMap A B).coeff i = 0
    · rw [hi]
      exact Subalgebra.zero_mem _
    rw [← hS]
    exact subset_adjoin (coeff_mem_frange _ _ hi)
  obtain ⟨q, hq⟩ :
    ∃ q : (adjoin R S)[X], q.map (algebraMap (adjoin R S) B) = (p.map <| algebraMap A B) :=
    by
    rw [← Set.mem_range]
    exact (Polynomial.mem_map_range _).2 fun i => ⟨⟨_, coeffs_mem i⟩, rfl⟩
  use q
  constructor
  · suffices h : (q.map (algebraMap (adjoin R S) B)).Monic
    · refine' monic_of_injective _ h
      exact Subtype.val_injective
    · rw [hq]
      exact pmonic.map _
  · convert hp using 1
    replace hq := congr_arg (eval x) hq
    convert hq using 1 <;> symm <;> apply eval_map
#align is_integral_trans_aux isIntegral_trans_aux

variable [Algebra R A] [IsScalarTower R A B]

/-- If A is an R-algebra all of whose elements are integral over R,
and x is an element of an A-algebra that is integral over A, then x is integral over R.-/
theorem isIntegral_trans (A_int : Algebra.IsIntegral R A) (x : B) (hx : IsIntegral A x) :
    IsIntegral R x := by
  rcases hx with ⟨p, pmonic, hp⟩
  let S : Set B := ↑(p.map <| algebraMap A B).frange
  refine' isIntegral_of_mem_of_fg (adjoin R (S ∪ {x})) _ _ (subset_adjoin <| Or.inr rfl)
  refine' fg_trans (fg_adjoin_of_finite (Finset.finite_toSet _) fun x hx => _) _
  · rw [Finset.mem_coe, frange, Finset.mem_image] at hx
    rcases hx with ⟨i, _, rfl⟩
    rw [coeff_map]
    exact map_isIntegral (IsScalarTower.toAlgHom R A B) (A_int _)
  · apply fg_adjoin_singleton_of_integral
    exact isIntegral_trans_aux _ pmonic hp
#align is_integral_trans isIntegral_trans

/-- If A is an R-algebra all of whose elements are integral over R,
and B is an A-algebra all of whose elements are integral over A,
then all elements of B are integral over R.-/
theorem Algebra.isIntegral_trans (hA : Algebra.IsIntegral R A) (hB : Algebra.IsIntegral A B) :
    Algebra.IsIntegral R B := fun x => isIntegral_trans hA x (hB x)
#align algebra.is_integral_trans Algebra.isIntegral_trans

theorem RingHom.isIntegral_trans (hf : f.IsIntegral) (hg : g.IsIntegral) : (g.comp f).IsIntegral :=
  @Algebra.isIntegral_trans R S T _ _ _ g.toAlgebra (g.comp f).toAlgebra f.toAlgebra
    (@IsScalarTower.of_algebraMap_eq R S T _ _ _ f.toAlgebra g.toAlgebra (g.comp f).toAlgebra
      (RingHom.comp_apply g f))
    hf hg
#align ring_hom.is_integral_trans RingHom.isIntegral_trans

theorem RingHom.isIntegral_of_surjective (hf : Function.Surjective f) : f.IsIntegral := fun x =>
  (hf x).recOn fun y hy => (hy ▸ f.is_integral_map : f.IsIntegralElem x)
#align ring_hom.is_integral_of_surjective RingHom.isIntegral_of_surjective

theorem isIntegral_of_surjective (h : Function.Surjective (algebraMap R A)) :
    Algebra.IsIntegral R A :=
  (algebraMap R A).isIntegral_of_surjective h
#align is_integral_of_surjective isIntegral_of_surjective

/-- If `R → A → B` is an algebra tower with `A → B` injective,
then if the entire tower is an integral extension so is `R → A` -/
theorem isIntegral_tower_bot_of_isIntegral (H : Function.Injective (algebraMap A B)) {x : A}
    (h : IsIntegral R (algebraMap A B x)) : IsIntegral R x :=
  by
  rcases h with ⟨p, ⟨hp, hp'⟩⟩
  refine' ⟨p, ⟨hp, _⟩⟩
  rw [IsScalarTower.algebraMap_eq R A B, ← eval₂_map, eval₂_hom, ←
    RingHom.map_zero (algebraMap A B)] at hp'
  rw [eval₂_eq_eval_map]
  exact H hp'
#align is_integral_tower_bot_of_is_integral isIntegral_tower_bot_of_isIntegral

theorem RingHom.isIntegral_tower_bot_of_isIntegral (hg : Function.Injective g)
    (hfg : (g.comp f).IsIntegral) : f.IsIntegral := fun x =>
  @isIntegral_tower_bot_of_isIntegral R S T _ _ _ g.toAlgebra (g.comp f).toAlgebra f.toAlgebra
    (@IsScalarTower.of_algebraMap_eq R S T _ _ _ f.toAlgebra g.toAlgebra (g.comp f).toAlgebra
      (RingHom.comp_apply g f))
    hg x (hfg (g x))
#align ring_hom.is_integral_tower_bot_of_is_integral RingHom.isIntegral_tower_bot_of_isIntegral

theorem isIntegral_tower_bot_of_isIntegral_field {R A B : Type _} [CommRing R] [Field A]
    [CommRing B] [Nontrivial B] [Algebra R A] [Algebra A B] [Algebra R B] [IsScalarTower R A B]
    {x : A} (h : IsIntegral R (algebraMap A B x)) : IsIntegral R x :=
  isIntegral_tower_bot_of_isIntegral (algebraMap A B).Injective h
#align is_integral_tower_bot_of_is_integral_field isIntegral_tower_bot_of_isIntegral_field

theorem RingHom.isIntegralElem_of_isIntegralElem_comp {x : T} (h : (g.comp f).IsIntegralElem x) :
    g.IsIntegralElem x :=
  let ⟨p, ⟨hp, hp'⟩⟩ := h
  ⟨p.map f, hp.map f, by rwa [← eval₂_map] at hp'⟩
#align ring_hom.is_integral_elem_of_is_integral_elem_comp RingHom.isIntegralElem_of_isIntegralElem_comp

theorem RingHom.isIntegral_tower_top_of_isIntegral (h : (g.comp f).IsIntegral) : g.IsIntegral :=
  fun x => RingHom.isIntegralElem_of_isIntegralElem_comp f g (h x)
#align ring_hom.is_integral_tower_top_of_is_integral RingHom.isIntegral_tower_top_of_isIntegral

/-- If `R → A → B` is an algebra tower,
then if the entire tower is an integral extension so is `A → B`. -/
theorem isIntegral_tower_top_of_isIntegral {x : B} (h : IsIntegral R x) : IsIntegral A x :=
  by
  rcases h with ⟨p, ⟨hp, hp'⟩⟩
  refine' ⟨p.map (algebraMap R A), ⟨hp.map (algebraMap R A), _⟩⟩
  rw [IsScalarTower.algebraMap_eq R A B, ← eval₂_map] at hp'
  exact hp'
#align is_integral_tower_top_of_is_integral isIntegral_tower_top_of_isIntegral

theorem RingHom.isIntegral_quotient_of_isIntegral {I : Ideal S} (hf : f.IsIntegral) :
    (Ideal.quotientMap I f le_rfl).IsIntegral :=
  by
  rintro ⟨x⟩
  obtain ⟨p, ⟨p_monic, hpx⟩⟩ := hf x
  refine' ⟨p.map (Ideal.Quotient.mk _), ⟨p_monic.map _, _⟩⟩
  simpa only [hom_eval₂, eval₂_map] using congr_arg (Ideal.Quotient.mk I) hpx
#align ring_hom.is_integral_quotient_of_is_integral RingHom.isIntegral_quotient_of_isIntegral

theorem isIntegral_quotient_of_isIntegral {I : Ideal A} (hRA : Algebra.IsIntegral R A) :
    Algebra.IsIntegral (R ⧸ I.comap (algebraMap R A)) (A ⧸ I) :=
  (algebraMap R A).isIntegral_quotient_of_isIntegral hRA
#align is_integral_quotient_of_is_integral isIntegral_quotient_of_isIntegral

theorem isIntegral_quotientMap_iff {I : Ideal S} :
    (Ideal.quotientMap I f le_rfl).IsIntegral ↔
      ((Ideal.Quotient.mk I).comp f : R →+* S ⧸ I).IsIntegral :=
  by
  let g := Ideal.Quotient.mk (I.comap f)
  have := Ideal.quotientMap_comp_mk le_rfl
  refine' ⟨fun h => _, fun h => RingHom.isIntegral_tower_top_of_isIntegral g _ (this ▸ h)⟩
  refine' this ▸ RingHom.isIntegral_trans g (Ideal.quotientMap I f le_rfl) _ h
  exact RingHom.isIntegral_of_surjective g Ideal.Quotient.mk_surjective
#align is_integral_quotient_map_iff isIntegral_quotientMap_iff

/-- If the integral extension `R → S` is injective, and `S` is a field, then `R` is also a field. -/
theorem isField_of_isIntegral_of_isField {R S : Type _} [CommRing R] [Nontrivial R] [CommRing S]
    [IsDomain S] [Algebra R S] (H : Algebra.IsIntegral R S)
    (hRS : Function.Injective (algebraMap R S)) (hS : IsField S) : IsField R :=
  by
  refine' ⟨⟨0, 1, zero_ne_one⟩, mul_comm, fun a ha => _⟩
  -- Let `a_inv` be the inverse of `algebra_map R S a`,
  -- then we need to show that `a_inv` is of the form `algebra_map R S b`.
  obtain ⟨a_inv, ha_inv⟩ := hS.mul_inv_cancel fun h => ha (hRS (trans h (RingHom.map_zero _).symm))
  -- Let `p : R[X]` be monic with root `a_inv`,
  -- and `q` be `p` with coefficients reversed (so `q(a) = q'(a) * a + 1`).
  -- We claim that `q(a) = 0`, so `-q'(a)` is the inverse of `a`.
  obtain ⟨p, p_monic, hp⟩ := H a_inv
  use -∑ i : ℕ in Finset.range p.nat_degree, p.coeff i * a ^ (p.nat_degree - i - 1)
  -- `q(a) = 0`, because multiplying everything with `a_inv^n` gives `p(a_inv) = 0`.
  -- TODO: this could be a lemma for `polynomial.reverse`.
  have hq : (∑ i : ℕ in Finset.range (p.nat_degree + 1), p.coeff i * a ^ (p.nat_degree - i)) = 0 :=
    by
    apply (injective_iff_map_eq_zero (algebraMap R S)).mp hRS
    have a_inv_ne_zero : a_inv ≠ 0 := right_ne_zero_of_mul (mt ha_inv.symm.trans one_ne_zero)
    refine' (mul_eq_zero.mp _).resolve_right (pow_ne_zero p.nat_degree a_inv_ne_zero)
    rw [eval₂_eq_sum_range] at hp
    rw [RingHom.map_sum, Finset.sum_mul]
    refine' (Finset.sum_congr rfl fun i hi => _).trans hp
    rw [RingHom.map_mul, mul_assoc]
    congr
    have : a_inv ^ p.nat_degree = a_inv ^ (p.nat_degree - i) * a_inv ^ i := by
      rw [← pow_add a_inv, tsub_add_cancel_of_le (Nat.le_of_lt_succ (finset.mem_range.mp hi))]
    rw [RingHom.map_pow, this, ← mul_assoc, ← mul_pow, ha_inv, one_pow, one_mul]
  -- Since `q(a) = 0` and `q(a) = q'(a) * a + 1`, we have `a * -q'(a) = 1`.
  -- TODO: we could use a lemma for `polynomial.div_X` here.
  rw [Finset.sum_range_succ_comm, p_monic.coeff_nat_degree, one_mul, tsub_self, pow_zero,
    add_eq_zero_iff_eq_neg, eq_comm] at hq
  rw [mul_comm, neg_mul, Finset.sum_mul]
  convert hq using 2
  refine' Finset.sum_congr rfl fun i hi => _
  have : 1 ≤ p.nat_degree - i := le_tsub_of_add_le_left (finset.mem_range.mp hi)
  rw [mul_assoc, ← pow_succ', tsub_add_cancel_of_le this]
#align is_field_of_is_integral_of_is_field isField_of_isIntegral_of_isField

theorem isField_of_isIntegral_of_is_field' {R S : Type _} [CommRing R] [CommRing S] [IsDomain S]
    [Algebra R S] (H : Algebra.IsIntegral R S) (hR : IsField R) : IsField S :=
  by
  letI := hR.to_field
  refine' ⟨⟨0, 1, zero_ne_one⟩, mul_comm, fun x hx => _⟩
  let A := Algebra.adjoin R ({x} : Set S)
  haveI : IsNoetherian R A :=
    isNoetherian_of_fg_of_noetherian A.to_submodule (fg_adjoin_singleton_of_integral x (H x))
  haveI : Module.Finite R A := Module.IsNoetherian.finite R A
  obtain ⟨y, hy⟩ :=
    LinearMap.surjective_of_injective
      (@LinearMap.mulLeft_injective R A _ _ _ _ ⟨x, subset_adjoin (Set.mem_singleton x)⟩ fun h =>
        hx (subtype.ext_iff.mp h))
      1
  exact ⟨y, subtype.ext_iff.mp hy⟩
#align is_field_of_is_integral_of_is_field' isField_of_isIntegral_of_is_field'

theorem Algebra.IsIntegral.isField_iff_isField {R S : Type _} [CommRing R] [Nontrivial R]
    [CommRing S] [IsDomain S] [Algebra R S] (H : Algebra.IsIntegral R S)
    (hRS : Function.Injective (algebraMap R S)) : IsField R ↔ IsField S :=
  ⟨isField_of_isIntegral_of_is_field' H, isField_of_isIntegral_of_isField H hRS⟩
#align algebra.is_integral.is_field_iff_is_field Algebra.IsIntegral.isField_iff_isField

end Algebra

theorem integralClosure_idem {R : Type _} {A : Type _} [CommRing R] [CommRing A] [Algebra R A] :
    integralClosure (integralClosure R A : Set A) A = ⊥ :=
  eq_bot_iff.2 fun x hx =>
    Algebra.mem_bot.2
      ⟨⟨x,
          @isIntegral_trans _ _ _ _ _ _ _ _ (integralClosure R A).Algebra _
            integralClosure.isIntegral x hx⟩,
        rfl⟩
#align integral_closure_idem integralClosure_idem

section IsDomain

variable {R S : Type _} [CommRing R] [CommRing S] [IsDomain S] [Algebra R S]

instance : IsDomain (integralClosure R S) :=
  inferInstance

theorem roots_mem_integralClosure {f : R[X]} (hf : f.Monic) {a : S}
    (ha : a ∈ (f.map <| algebraMap R S).roots) : a ∈ integralClosure R S :=
  ⟨f, hf, (eval₂_eq_eval_map _).trans <| (mem_roots <| (hf.map _).NeZero).1 ha⟩
#align roots_mem_integral_closure roots_mem_integralClosure

end IsDomain


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import category_theory.limits.shapes.regular_mono
import category_theory.limits.shapes.zero_morphisms

/-!

# Categories where inclusions into coproducts are monomorphisms

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

If `C` is a category, the class `mono_coprod C` expresses that left
inclusions `A ⟶ A ⨿ B` are monomorphisms when `has_coproduct A B`
is satisfied. If it is so, it is shown that right inclusions are
also monomorphisms.

TODO @joelriou: show that if `X : I → C` and `ι : J → I` is an injective map,
then the canonical morphism `∐ (X ∘ ι) ⟶ ∐ X` is a monomorphism.

TODO: define distributive categories, and show that they satisfy `mono_coprod`, see
<https://ncatlab.org/toddtrimble/published/distributivity+implies+monicity+of+coproduct+inclusions>

-/

noncomputable theory

open category_theory category_theory.category category_theory.limits

universe u

namespace category_theory

namespace limits

variables (C : Type*) [category C]

/-- This condition expresses that inclusion morphisms into coproducts are monomorphisms. -/
class mono_coprod : Prop :=
(binary_cofan_inl : ∀ ⦃A B : C⦄ (c : binary_cofan A B) (hc : is_colimit c), mono c.inl)

variable {C}

@[priority 100]
instance mono_coprod_of_has_zero_morphisms
  [has_zero_morphisms C] : mono_coprod C :=
⟨λ A B c hc, begin
  haveI : is_split_mono c.inl := is_split_mono.mk'
    (split_mono.mk (hc.desc (binary_cofan.mk (𝟙 A) 0)) (is_colimit.fac _ _ _)),
  apply_instance,
end⟩

namespace mono_coprod

instance {A B : C} [mono_coprod C] [has_binary_coproduct A B] :
  mono (coprod.inl : A ⟶ A ⨿ B) :=
binary_cofan_inl _ (colimit.is_colimit _)

instance {A B : C} [mono_coprod C] [has_binary_coproduct A B] :
  mono (coprod.inr : B ⟶ A ⨿ B) :=
binary_cofan_inr _ (colimit.is_colimit _)

lemma mono_inl_iff {A B : C} {c₁ c₂ : binary_cofan A B} (hc₁ : is_colimit c₁)
  (hc₂ : is_colimit c₂) : mono c₁.inl ↔ mono c₂.inl :=
begin
  suffices : ∀ (c₁ c₂ : binary_cofan A B) (hc₁ : is_colimit c₁) (hc₂ : is_colimit c₂)
    (h : mono c₁.inl), mono c₂.inl,
  { exact ⟨λ h₁, this _ _ hc₁ hc₂ h₁, λ h₂, this _ _ hc₂ hc₁ h₂⟩, },
  intros c₁ c₂ hc₁ hc₂,
  introI,
  simpa only [is_colimit.comp_cocone_point_unique_up_to_iso_hom]
    using mono_comp c₁.inl (hc₁.cocone_point_unique_up_to_iso hc₂).hom,
end

lemma mk' (h : ∀ (A B : C), ∃ (c : binary_cofan A B) (hc : is_colimit c), mono c.inl) :
  mono_coprod C :=
⟨λ A B c' hc', begin
  obtain ⟨c, hc₁, hc₂⟩ := h A B,
  simpa only [mono_inl_iff hc' hc₁] using hc₂,
end⟩

instance mono_coprod_type : mono_coprod (Type u) :=
mono_coprod.mk' (λ A B, begin
  refine ⟨binary_cofan.mk (sum.inl : A ⟶ A ⊕ B) sum.inr, _, _⟩,
  { refine binary_cofan.is_colimit.mk _ (λ Y f₁ f₂ x, by { cases x, exacts [f₁ x, f₂ x], })
      (λ Y f₁ f₂, rfl) (λ Y f₁ f₂, rfl) _,
    intros Y f₁ f₂ m h₁ h₂,
    ext x,
    cases x,
    { dsimp, exact congr_fun h₁ x, },
    { dsimp, exact congr_fun h₂ x, }, },
  { rw mono_iff_injective,
    intros a₁ a₂ h,
    simp only [binary_cofan.mk_inl] at h,
    dsimp at h,
    simpa only using h, },
end)

end mono_coprod

end limits

end category_theory


import algebra.big_operators

import to_mathlib_maybe.Hilbert_space
import to_mathlib_maybe.pTrace

import to_qShannon_theory_maybe.entropy
import to_qShannon_theory_maybe.state
import to_qShannon_theory_maybe.channel

open_locale big_operators

variables
{ι : Type} [fintype ι] [decidable_eq ι]
{ℋ : Type} [complex_hilbert_space ℋ]
{ρ ρ' : ℋ →ₗ[ℂ] ℋ} [quantum_state ρ] [quantum_state ρ']
[H(ρ) < H(ρ')]

-- notation ρ `^⊗` n := ⊗[ℂ] i, λ _, ρ

def majorizes (ρ : ℋ →ₗ[ℂ] ℋ) (ρ' : ℋ →ₗ[ℂ] ℋ) :=
∃ (q : ι → ℝ) (V : ι → module.End ℂ ℋ) [∀ i, unitary (V i)],  ρ' = ∑ i, (q i) • (evolve (V i) ρ)

notation ρ `≽` ρ' := majorizes ρ ρ'

lemma typicality_and_majorization :
∀ ε > 0, ∃ n, ∃ (τ : module.End ℂ ℋ) [quantum_state τ], -- not sure we can put this constraint here
ρ^⊗n ≽ τ
∧
D(ρ^⊗n, τ) ≤ ε :=
begin
  sorry
end


theorem not_not_not (P : Prop) :
    ¬ ¬ ¬ P → ¬ P :=
λ h p, h $ not_not_intro p

theorem not_not_not' (P : Prop) :
    ¬ P → ¬ ¬ ¬ P :=
λ x y, y x


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

This file effectively deals with the cartesian-closed category
of finite posets and the associated "strong homotopy category".
However, we have taken an ad hoc approach rather than using the
category theory library.
-/

import order.basic
import data.equiv.basic
import data.fintype
import logic.relation
import algebra.punit_instances
import sort_rank fin_extra

universes uP uQ uR uS

variables (P : Type uP) [partial_order P]
variables (Q : Type uQ) [partial_order Q]
variables (R : Type uR) [partial_order R]
variables (S : Type uS) [partial_order S]

namespace poset

structure hom :=
(val : P → Q)
(property : monotone val)

instance : has_coe_to_fun (hom P Q) := {
 F := λ _, P → Q,
 coe := λ f, f.val
}

@[ext]
lemma hom_ext (f g : hom P Q) :
  (∀ (p : P), f p = g p) → f = g :=
begin
  rcases f with ⟨f,hf⟩,
  rcases g with ⟨g,hg⟩,
  intro h,
  have h' : f = g := funext h,
  rcases h', refl,
end

def id : hom P P := ⟨_root_.id,monotone_id⟩

lemma id_val : (id P).val = _root_.id := rfl

variables {P Q R}

instance hom_order : partial_order (hom P Q) := {
 le := λ f g, ∀ p, (f p) ≤ (g p),
 le_refl := λ f p,le_refl (f p),
 le_antisymm := λ f g f_le_g g_le_f,
  begin ext p, exact le_antisymm (f_le_g p) (g_le_f p), end,
 le_trans := λ f g h f_le_g g_le_h p,
   le_trans (f_le_g p) (g_le_h p)
}

@[simp]
lemma id_eval (p : P) : (id P) p = p := rfl

variable (P)
def const (q : Q) : hom P Q := ⟨λ p,q, λ p₀ p₁ hp, le_refl q⟩

def terminal : hom P punit.{uP + 1} := const P punit.star
variable {P}

lemma eq_terminal (f : hom P punit.{uP + 1}) : f = terminal P :=
begin
  ext p, cases f p, cases terminal P p, refl
end

@[irreducible]
def adjoint (f : hom P Q) (g : hom Q P) : Prop :=
  ∀ {p : P} {q : Q}, f p ≤ q ↔ p ≤ g q

def adjoint.iff {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  ∀ {p : P} {q : Q}, f p ≤ q ↔ p ≤ g q :=
    by { intros p q, unfold adjoint at h, exact h }

def comp : (hom Q R) → (hom P Q) → (hom P R) :=
 λ g f, ⟨g.val ∘ f.val, monotone.comp g.property f.property ⟩

lemma comp_val (g : hom Q R) (f : hom P Q) :
 (comp g f).val = g.val ∘ f.val := rfl

lemma id_comp (f : hom P Q) : comp (id Q) f = f := by {ext, refl}
lemma comp_id (f : hom P Q) : comp f (id P) = f := by {ext, refl}
lemma comp_assoc (h : hom R S) (g : hom Q R) (f : hom P Q) :
 comp (comp h g) f = comp h (comp g f) := by {ext, refl}

lemma const_comp (r : R) (f : hom P Q) :
 comp (const Q r) f = const P r := by {ext, refl}

lemma comp_const (g : hom Q R) (q : Q) :
 comp g (const P q) = const P (g q) := by {ext, refl}

lemma comp_mono₂ {g₀ g₁ : hom Q R} {f₀ f₁ : hom P Q}
 (eg : g₀ ≤ g₁) (ef : f₀ ≤ f₁) : comp g₀ f₀ ≤ comp g₁ f₁ :=
 λ p, calc
  g₀.val (f₀.val p) ≤ g₀.val (f₁.val p) : g₀.property (ef p)
  ... ≤ g₁.val (f₁.val p) : eg (f₁.val p)

@[simp]
lemma comp_eval (g : hom Q R) (f : hom P Q) (p : P) :
 (comp g f) p = g (f p) := rfl

def comp' : (hom Q R) × (hom P Q) → (hom P R) :=
 λ ⟨g,f⟩, comp g f

lemma comp'_mono : monotone (@comp' P _ Q _ R _) :=
 λ ⟨g₀,f₀⟩ ⟨g₁,f₁⟩ ⟨eg,ef⟩, comp_mono₂ eg ef

def eval : (hom P Q) → P → Q := λ f p, f.val p

lemma eval_mono₂ {f₀ f₁ : hom P Q} {p₀ p₁ : P}
 (ef : f₀ ≤ f₁) (ep : p₀ ≤ p₁) : eval f₀ p₀ ≤ eval f₁ p₁ :=
calc
  f₀.val p₀ ≤ f₀.val p₁ : f₀.property ep
  ... ≤ f₁.val p₁ : ef p₁

def eval' : (hom P Q) × P → Q := λ ⟨f,p⟩, eval f p

lemma eval'_mono : monotone (@eval' P _ Q _) :=
 λ ⟨f₀,p₀⟩ ⟨f₁,p₁⟩ ⟨ef,ep⟩, eval_mono₂ ef ep

def ins' : P → (hom Q (P × Q)) :=
 λ p, ⟨λ q,⟨p,q⟩, λ q₀ q₁ eq, ⟨le_refl p,eq⟩⟩

lemma ins_mono : monotone (@ins' P _ Q _) :=
 λ p₀ p₁ ep q, ⟨ep,le_refl q⟩

lemma adjoint.unit {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  id P ≤ comp g f := λ p, h.iff.mp (le_refl (f p))

lemma adjoint.counit {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  comp f g ≤ id Q := λ q, h.iff.mpr (le_refl (g q))

variable (P)
def π₀ : Type* := quot (has_le.le : P → P → Prop)
variable {P}

def component (p : P) : π₀ P := quot.mk _ p

def connected : P → P → Prop := λ p₀ p₁, component p₀ = component p₁

lemma π₀.sound {p₀ p₁ : P} (hp : p₀ ≤ p₁) :
 component p₀ = component p₁ := quot.sound hp

lemma π₀.epi {X : Type*} (f₀ f₁ : π₀ P → X)
 (h : ∀ p, f₀ (component p) = f₁ (component p)) : f₀ = f₁ :=
  by {apply funext, rintro ⟨p⟩, exact (h p),}

def π₀.lift {X : Type*} (f : P → X)
 (h : ∀ p₀ p₁ : P, p₀ ≤ p₁ → f p₀ = f p₁) :
  (π₀ P) → X := @quot.lift P has_le.le X f h

lemma π₀.lift_beta {X : Type*} (f : P → X)
 (h : ∀ p₀ p₁ : P, p₀ ≤ p₁ → f p₀ = f p₁) (p : P) :
  π₀.lift f h (component p) = f p :=
   @quot.lift_beta P has_le.le X f h p

def π₀.lift₂ {X : Type*} (f : P → Q → X)
 (h : ∀ p₀ p₁ q₀ q₁, p₀ ≤ p₁ → q₀ ≤ q₁ → f p₀ q₀ = f p₁ q₁) :
  (π₀ P) → (π₀ Q) → X :=
begin
 let h1 := λ p q₀ q₁ hq, h p p q₀ q₁ (le_refl p) hq,
 let f1 : P → (π₀ Q) → X := λ p, π₀.lift (f p) (h1 p),
 let hf1 : ∀ p q, f1 p (component q) = f p q := λ p, π₀.lift_beta (f p) (h1 p),
 let h2 : ∀ p₀ p₁, p₀ ≤ p₁ → f1 p₀ = f1 p₁ := λ p₀ p₁ hp,
  begin
   apply π₀.epi,intro q,rw[hf1,hf1],
   exact h p₀ p₁ q q hp (le_refl q),
  end,
 exact π₀.lift f1 h2
end

lemma π₀.lift₂_beta {X : Type*} (f : P → Q → X)
 (h : ∀ p₀ p₁ q₀ q₁, p₀ ≤ p₁ → q₀ ≤ q₁ → f p₀ q₀ = f p₁ q₁)
  (p : P) (q : Q) : (π₀.lift₂ f h) (component p) (component q) = f p q :=
begin
 unfold π₀.lift₂,simp only [],rw[π₀.lift_beta,π₀.lift_beta],
end

lemma parity_induction (u : ℕ → Prop)
  (h_zero : u 0)
  (h_even : ∀ i, u (2 * i) → u (2 * i + 1))
  (h_odd  : ∀ i, u (2 * i + 1) → u (2 * i + 2)) :
  ∀ i, u i
| 0 := h_zero
| (i + 1) :=
begin
  have ih := parity_induction i,
  let k := i.div2,
  have hi : cond i.bodd 1 0 + 2 * k = i := nat.bodd_add_div2 i,
  rcases i.bodd ; intro hk; rw[cond] at hk,
  { rw [zero_add] at hk,
    rw [← hk] at ih ⊢,
    exact h_even k ih },
  { rw [add_comm] at hk,
    rw [← hk] at ih ⊢,
    exact h_odd k ih }
end

lemma zigzag (u : ℕ → P)
  (h_even : ∀ i, u (2 * i) ≤ u (2 * i + 1))
  (h_odd : ∀ i, u (2 * i + 2) ≤ u(2 * i + 1)) :
   ∀ i, component (u i) = component (u 0) :=
parity_induction
 (λ i, component (u i) = component (u 0))
 rfl
 (λ i h, (π₀.sound (h_even i)).symm.trans h)
 (λ i h, (π₀.sound (h_odd i)).trans h)

variables (P Q)
def homₕ := π₀ (hom P Q)

def idₕ : homₕ P P := component (id P)

variables {P Q}

def compₕ : (homₕ Q R) → (homₕ P Q) → (homₕ P R) :=
 π₀.lift₂ (λ g f, component (comp g f)) (begin
  intros g₀ g₁ f₀ f₁ hg hf,
  let hgf := comp_mono₂ hg hf,
  let hgf' := π₀.sound hgf,
  exact (π₀.sound (comp_mono₂ hg hf))
 end)

lemma compₕ_def (g : hom Q R) (f : hom P Q) :
 compₕ (component g) (component f) = component (comp g f) :=
  by {simp[compₕ,π₀.lift₂_beta]}

lemma id_compₕ (f : homₕ P Q) : compₕ (idₕ Q) f = f :=
 begin
  rcases f with f,
  change compₕ (component (id Q)) (component f) = component f,
  rw[compₕ_def,id_comp],
 end

lemma comp_idₕ (f : homₕ P Q) : compₕ f (idₕ P) = f :=
 begin
  rcases f with f,
  change compₕ (component f) (component (id P)) = component f,
  rw[compₕ_def,comp_id],
 end

lemma comp_assocₕ (h : homₕ R S) (g : homₕ Q R) (f : homₕ P Q) :
 compₕ (compₕ h g) f = compₕ h (compₕ g f) :=
 begin
  rcases h with h, rcases g with g, rcases f with f,
  change compₕ (compₕ (component h) (component g)) (component f) =
         compₕ (component h) (compₕ (component g) (component f)),
  repeat {rw[compₕ_def]},rw[comp_assoc],
 end

variables (P Q)
structure equivₕ :=
(to_fun : homₕ P Q)
(inv_fun : homₕ Q P)
(left_inv : compₕ inv_fun to_fun = idₕ P)
(right_inv : compₕ to_fun inv_fun = idₕ Q)

@[refl] def equivₕ.refl : equivₕ P P :=
{ to_fun := idₕ P, inv_fun := idₕ P,
  left_inv := comp_idₕ _,
  right_inv := comp_idₕ _ }

variables {P Q}

@[symm] def equivₕ.symm (e : equivₕ P Q) : equivₕ Q P :=
{ to_fun := e.inv_fun, inv_fun := e.to_fun,
  left_inv := e.right_inv, right_inv := e.left_inv }

@[trans] def equivₕ.trans (e : equivₕ P Q) (f : equivₕ Q R) : (equivₕ P R) :=
{ to_fun  := compₕ f.to_fun e.to_fun,
  inv_fun := compₕ e.inv_fun f.inv_fun,
  left_inv := by
    rw [comp_assocₕ, ← comp_assocₕ _ f.inv_fun, f.left_inv,
        id_compₕ, e.left_inv],
  right_inv := by
    rw [comp_assocₕ, ← comp_assocₕ _ e.to_fun, e.right_inv,
        id_compₕ, f.right_inv] }

lemma adjoint.unitₕ {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  compₕ (component g) (component f) = idₕ P :=
begin
  have : id P ≤ comp g f := by { apply adjoint.unit, assumption },
  exact (π₀.sound this).symm
end

lemma adjoint.counitₕ {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  compₕ (component f) (component g) = idₕ Q :=
begin
  have : comp f g ≤ id Q := by { apply adjoint.counit, assumption },
  exact (π₀.sound this)
end

/-- LaTeX: rem-adjoint-strong -/
def equivₕ_of_adjoint {f : hom P Q} {g : hom Q P} (h : adjoint f g) :
  equivₕ P Q :=
{ to_fun := component f,
  inv_fun := component g,
  left_inv := adjoint.unitₕ h,
  right_inv := adjoint.counitₕ h }

variable (P)

/-- defn-strongly-contractible -/
def contractibleₕ := nonempty (equivₕ P punit.{uP + 1})

variable {P}

lemma contractibleₕ_of_smallest {m : P} (h : ∀ p, m ≤ p) : contractibleₕ P :=
begin
  have : adjoint (const punit.{uP + 1} m) (terminal P) :=
  begin
    unfold adjoint,
    rintro ⟨⟩ p,
    change m ≤ p ↔ punit.star ≤ punit.star,
    simp only [le_refl, h p],
  end,
  let hh := equivₕ_of_adjoint this,
  exact ⟨hh.symm⟩,
end

def π₀.map (f : hom P Q) : (π₀ P) → (π₀ Q) :=
 π₀.lift (λ p, component (f p)) (λ p₀ p₁ ep, quot.sound (f.property ep))

lemma π₀.map_def (f : hom P Q) (p : P) : π₀.map f (component p) = component (f p) :=
 by { simp [π₀.map, π₀.lift_beta] }

lemma π₀.map_congr {f₀ f₁ : hom P Q} (ef : f₀ ≤ f₁) : π₀.map f₀ = π₀.map f₁ :=
begin
  apply π₀.epi,
  intro p,
  rw [π₀.map_def, π₀.map_def],
  exact π₀.sound (ef p)
end

variable (P)
lemma π₀.map_id : π₀.map (id P) = _root_.id :=
 by { apply π₀.epi, intro p, rw[π₀.map_def], refl }
variable {P}

lemma π₀.map_comp (g : hom Q R) (f : hom P Q) :
 π₀.map (comp g f) = (π₀.map g) ∘ (π₀.map f) :=
  by { apply π₀.epi, intro p, rw[π₀.map_def], refl }

def evalₕ : (homₕ P Q) → (π₀ P) → (π₀ Q) :=
 π₀.lift π₀.map (@π₀.map_congr _ _ _ _)

variables {P Q}

def comma (f : hom P Q) (q : Q) := { p : P // f p ≤ q }

instance comma_order (f : hom P Q) (q : Q) :
  partial_order (comma f q) := by { dsimp[comma], apply_instance }

def cocomma (f : hom P Q) (q : Q) := { p : P // q ≤ f p }

instance cocomma_order (f : hom P Q) (q : Q) :
  partial_order (cocomma f q) := by { dsimp[cocomma], apply_instance }

/-- Here we define predicates finalₕ and cofinalₕ.
  If (finalₕ f) holds then f is homotopy cofinal, by
  prop-cofinal.  The dual is also valid, but the converse
  is not.
-/

def finalₕ (f : hom P Q) : Prop :=
  ∀ q, contractibleₕ (cocomma f q)

def cofinalₕ (f : hom P Q) : Prop :=
  ∀ q, contractibleₕ (comma f q)

variable (P)

structure fin_ranking :=
(card : ℕ)
(rank : P ≃ fin card)
(rank_mono : monotone rank.to_fun)

section sort

variable {P}
variable [decidable_rel (has_le.le : P → P → Prop)]

def is_semisorted (l : list P) : Prop :=
  l.pairwise (λ a b, ¬ b < a)

lemma mem_ordered_insert (x p : P) (l : list P) :
  x ∈ (l.ordered_insert has_le.le p) ↔ x = p ∨ x ∈ l :=
begin
  rw [list.mem_of_perm (list.perm_ordered_insert _ _ _)],
  apply list.mem_cons_iff
end

lemma insert_semisorted (p : P) (l : list P) (h : is_semisorted l) :
  is_semisorted (l.ordered_insert has_le.le p) :=
begin
  induction h with q l hq hl ih,
  { apply list.pairwise_singleton },
  { dsimp [list.ordered_insert],
    split_ifs with hpq,
    { apply list.pairwise.cons,
      { intros x x_in_ql,
        rcases (list.mem_cons_iff _ _ _).mp x_in_ql with ⟨⟨⟩⟩ | x_in_l,
        { exact not_lt_of_ge hpq },
        { intro x_lt_p,
          exact hq x x_in_l (lt_of_lt_of_le x_lt_p hpq) } },
      { exact list.pairwise.cons hq hl } },
    { apply list.pairwise.cons,
      { intros x x_in_pl x_lt_q,
        rw [mem_ordered_insert] at x_in_pl,
        rcases x_in_pl with ⟨⟨⟩⟩ | x_in_l,
        { exact hpq (le_of_lt x_lt_q) },
        { exact hq x x_in_l x_lt_q } },
      { exact ih } } }
end

lemma insertion_sort_semisorted (l : list P) :
  is_semisorted (l.insertion_sort (has_le.le : P → P → Prop)) :=
begin
  induction l with p l ih,
  { apply list.pairwise.nil },
  { dsimp [list.insertion_sort],
    apply insert_semisorted,
    exact ih }
end

variable (P)

lemma exists_fin_ranking [fintype P] : nonempty (fin_ranking P) :=
begin
  rcases fintype.exists_equiv_fin P with ⟨n,⟨f⟩⟩,
  let l := (fin.elems_list n).map f.symm,
  have l_nodup : l.nodup :=
    list.nodup_map f.symm.injective (fin.elems_list_nodup n),
  have l_univ : ∀ p, p ∈ l := λ p,
  begin
    apply list.mem_map.mpr,
    exact ⟨f.to_fun p, ⟨fin.elems_list_complete (f.to_fun p),f.left_inv p⟩⟩
  end,
  have l_length : l.length = n :=
    (list.length_map f.symm (fin.elems_list n)).trans (fin.elems_list_length n),
  let ls := l.insertion_sort has_le.le,
  let ls_perm := list.perm_insertion_sort has_le.le l,
  have ls_sorted : is_semisorted ls :=
    insertion_sort_semisorted l,
  have ls_nodup : ls.nodup :=
    (list.perm_nodup ls_perm).mpr l_nodup,
  have ls_univ : ∀ p, p ∈ ls := λ p,
    (list.mem_of_perm ls_perm).mpr (l_univ p),
  have ls_length : ls.length = n := (list.perm_length ls_perm).trans l_length,
  let inv_fun : (fin n) → P :=
    λ i, ls.nth_le i.val (@eq.subst ℕ (nat.lt i.val) _ _ ls_length.symm i.is_lt),
  let to_fun_aux : P → {i : fin n // inv_fun i = a} :=
  begin
    intro p,
    let i_val := ls.index_of p,
    let i_lt_l := list.index_of_lt_length.mpr (ls_univ p),
    let i_lt_n : i_val < n := @eq.subst ℕ (nat.lt i_val) _ _ ls_length i_lt_l,
    let i : fin n := ⟨i_val,i_lt_n⟩,
    have : inv_fun i = p := list.index_of_nth_le i_lt_l,
    exact ⟨i,this⟩
  end,
  let to_fun : P → (fin n) := λ p, (to_fun_aux p).val,
  let left_inv : ∀ p : P, inv_fun (to_fun p) = p :=
    λ p, (to_fun_aux p).property,
  let right_inv : ∀ i : (fin n), to_fun (inv_fun i) = i :=
  begin
   intro i,cases i,
   apply fin.eq_of_veq,
   let i_lt_l : i_val < ls.length :=
    @eq.subst ℕ (nat.lt i_val) _ _ ls_length.symm i_is_lt,
   exact list.nth_le_index_of ls_nodup i_val i_lt_l,
  end,
  let g : P ≃ (fin n) := ⟨to_fun,inv_fun,left_inv,right_inv⟩,
  have g_mono : monotone g.to_fun := λ p q hpq,
  begin
    let i := g.to_fun p,
    let j := g.to_fun q,
    have hp : g.inv_fun i = p := g.left_inv p,
    have hq : g.inv_fun j = q := g.left_inv q,
    have hi : i.val < ls.length := by { rw [ls_length], exact i.is_lt },
    have hj : j.val < ls.length := by { rw [ls_length], exact j.is_lt },
    by_cases h : i ≤ j, { exact h },
    exfalso,
    replace h := lt_of_not_ge h,
    have hp' : ls.nth_le i.val hi = g.inv_fun i := rfl,
    have hq' : ls.nth_le j.val hj = g.inv_fun j := rfl,
    let h_ne  := list.pairwise_nth_iff.mp ls_nodup h hi,
    let h_ngt := list.pairwise_nth_iff.mp ls_sorted h hi,
    rw [hp', hq', hp, hq] at h_ne h_ngt,
    exact h_ngt (lt_of_le_of_ne hpq h_ne.symm),
  end,
  exact ⟨⟨n,g,g_mono⟩⟩
end

end sort

end poset