import .formula .asubst

variables {α β : Type}

open list atom tactic

def formula.atoms : formula → list atom
| ⊤' := []
| ⊥' := []
| (A' a) := [a]
| (¬' p) := p.atoms
| (p ∨' q) := p.atoms ++ q.atoms
| (p ∧' q) := p.atoms ++ q.atoms
| (∃' p) := p.atoms

def head_coeff : atom → znum
| (le i [])         := 0
| (le i (k::_))     := k
| (dvd d i [])      := 0
| (dvd d i (k::_))  := k
| (ndvd d i [])     := 0
| (ndvd d i (k::_)) := k

def dep_0 (a : atom) := head_coeff a ≠ 0

instance dec_dep_0 : decidable_pred dep_0 :=
begin intro a, cases a; simp [dep_0, head_coeff]; apply_instance end

def formula.atoms_dep_0 (p : formula) : list atom :=
p.atoms.filter dep_0

def atom.unify : znum → atom → atom
| m (atom.le i (k::ks)) :=
  if k = 0
  then (atom.le i (0::ks))
  else let m' := (m / (abs k)) in
       atom.le (m' * i) (znum.sign k :: map_mul m' ks)
| m (atom.dvd d i (k::ks)) :=
  if k = 0
  then (atom.dvd d i (0::ks))
  else let m' := (m / k) in
       atom.dvd (m' * d) (m' * i) (1 :: map_mul m' ks)
| m (atom.ndvd d i (k::ks)) :=
  if k = 0
  then (atom.ndvd d i (0::ks))
  else let m' := (m / k) in
       atom.ndvd (m' * d) (m' * i) (1 :: map_mul m' ks)
| m (atom.le i []) := (atom.le i [])
| m (atom.dvd d i []) := (atom.dvd d i [])
| m (atom.ndvd d i []) := (atom.ndvd d i [])

def coeffs_lcm (p : formula) :=
  znum.lcms (map head_coeff p.atoms_dep_0)

def divisor : atom → znum
| (atom.le i ks)     := 1
| (atom.dvd d i ks)  := d
| (atom.ndvd d i ks) := d

def divisors_lcm (p : formula) :=
  znum.lcms (map divisor (p.atoms_dep_0))

def formula.unify (p : formula) : formula :=
A' (atom.dvd (coeffs_lcm p) 0 [1]) ∧' (p.map (atom.unify (coeffs_lcm p)))

def inf_minus : formula → formula
| ⊤' := ⊤'
| ⊥' := ⊥'
| (A' (atom.le i (k::ks))) :=
  if k < 0
  then ⊤'
  else if k > 0
       then ⊥'
       else A' (atom.le i (0::ks))
| (A' a) := A' a
| (p ∧' q) := and_o (inf_minus p) (inf_minus q)
| (p ∨' q) := or_o (inf_minus p) (inf_minus q)
| (¬' p) := ¬' p
| (∃' p) := ∃' p

lemma inf_minus_le_eq_of_lt {i k ks} :
  k < 0 → inf_minus (A' (atom.le i (k::ks))) = ⊤' :=
begin intro h, simp [inf_minus], rw if_pos, assumption end

lemma inf_minus_le_eq_of_eq {i ks} :
  inf_minus (A' (atom.le i (0::ks))) = (A' (atom.le i (0::ks))) :=
begin
  simp [inf_minus], rw if_neg,
  rw if_neg, exact_dec_trivial, exact_dec_trivial
end

lemma inf_minus_le_eq_of_gt {i k ks} :
  k > 0 → inf_minus (A' (atom.le i (k::ks))) = ⊥' :=
begin
  intro h, simp [inf_minus], rw if_neg,
  rw if_pos, apply h, rw not_lt, apply le_of_lt h,
end

def inf_minus_le_eq {i k ks} :
  inf_minus (A' (atom.le i (k::ks))) =
  if k < 0
  then ⊤'
  else if k > 0
       then ⊥'
       else A' (atom.le i (0::ks)) := rfl

def subst (i ks) (p : formula) := p.map (asubst i ks)

def get_lb : atom → option (znum × list znum)
| (atom.le i (k::ks)) :=
  if k > 0 then (i,ks) else none
| (atom.le _ []) := none
| (atom.dvd _ _ _) := none
| (atom.ndvd _ _ _) := none

def bnd_points (p : formula) :=
  filter_map get_lb (p.atoms_dep_0)

lemma bnd_points_le_eq {i k ks} :
  k > 0 → bnd_points (A' (atom.le i (k::ks))) = [(i,ks)] :=
begin
  intro h, simp [formula.atoms, bnd_points,
    formula.atoms_dep_0, dep_0, filter, head_coeff],
  rw if_pos, simp [filter_map, get_lb],
  rw if_pos, refl, assumption, intro hc,
  subst hc, cases h
end

lemma znum.range_neg_eq_range :
  ∀ {z}, znum.range (-z) = znum.range z :=
begin intro z, cases z; simp [znum.range, znum.abs]; refl end

lemma znum.mem_range {z y : znum} :
  0 ≤ z → z < y → z ∈ znum.range y :=
begin
  intros hz hzy, have hy : 0 ≤ y := le_of_lt (lt_of_le_of_lt hz hzy),
  unfold znum.range, rewrite mem_map, rewrite znum.nonneg_iff_exists at hz,
  cases hz with n hn, subst hn, existsi n, apply and.intro _ rfl,
  rewrite num.mem_range, rewrite iff.symm num.lt_to_znum,
  rw znum.to_znum_abs hy, assumption,
end

lemma znum.mem_range' {z y : znum} :
  0 ≤ z → z < (abs y) → z ∈ znum.range y :=
begin
  by_cases hy : (0 ≤ y),
  { rw abs_of_nonneg hy, apply znum.mem_range },
  { simp [not_le] at hy, rw abs_of_nonpos (le_of_lt hy),
    rw znum.range_neg_eq_range.symm, apply znum.mem_range }
end

lemma znum.mem_range_iff {x y : znum} :
   0 ≤ y → (x ∈ znum.range y ↔ (0 ≤ x ∧ x < y)) :=
begin
  intro h1, constructor; intro h2,
  { simp [znum.range] at h2, cases h2 with n hn,
    cases hn with hn1 hn2, subst hn2, constructor,
    apply num.to_znum_nonneg, simp [num.mem_range] at hn1,
    rw num.lt_to_znum.symm at hn1,
    rw znum.to_znum_abs h1 at hn1, assumption },
  { apply znum.mem_range h2.left h2.right }
end

def sqe_inf (p : formula) : formula :=
  disj_map (znum.range (divisors_lcm p)) (λ n, subst n [] (inf_minus p))

def sqe_bnd  (p : formula) : formula :=
  disj_map (bnd_points p)
   (λ iks, disj_map (znum.range (divisors_lcm p))
     (λ n, subst (iks^.fst + n) (map_neg iks^.snd) p))

def sqe_core (p : formula) : formula :=
  or_o (sqe_inf p) (sqe_bnd p)

def sqe (p : formula) : formula := sqe_core p.unify


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import analysis.analytic.basic

/-!
# Linear functions are analytic

In this file we prove that a `continuous_linear_map` defines an analytic function with
the formal power series `f x = f a + f (x - a)`.
-/

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
{G : Type*} [normed_group G] [normed_space 𝕜 G]

open_locale topological_space classical big_operators nnreal ennreal
open set filter asymptotics

noncomputable theory

namespace continuous_linear_map

/-- Formal power series of a continuous linear map `f : E →L[𝕜] F` at `x : E`:
`f y = f x + f (y - x)`. -/
@[simp] def fpower_series (f : E →L[𝕜] F) (x : E) : formal_multilinear_series 𝕜 E F
| 0 := continuous_multilinear_map.curry0 𝕜 _ (f x)
| 1 := (continuous_multilinear_curry_fin1 𝕜 E F).symm f
| _ := 0

@[simp] lemma fpower_series_apply_add_two (f : E →L[𝕜] F) (x : E) (n : ℕ) :
  f.fpower_series x (n + 2) = 0 := rfl

@[simp] lemma fpower_series_radius (f : E →L[𝕜] F) (x : E) : (f.fpower_series x).radius = ∞ :=
(f.fpower_series x).radius_eq_top_of_forall_image_add_eq_zero 2 $ λ n, rfl

protected theorem has_fpower_series_on_ball (f : E →L[𝕜] F) (x : E) :
  has_fpower_series_on_ball f (f.fpower_series x) x ∞ :=
{ r_le := by simp,
  r_pos := ennreal.coe_lt_top,
  has_sum := λ y _, (has_sum_nat_add_iff' 2).1 $
    by simp [finset.sum_range_succ, ← sub_sub, has_sum_zero] }

protected theorem has_fpower_series_at (f : E →L[𝕜] F) (x : E) :
  has_fpower_series_at f (f.fpower_series x) x :=
⟨∞, f.has_fpower_series_on_ball x⟩

protected theorem analytic_at (f : E →L[𝕜] F) (x : E) : analytic_at 𝕜 f x :=
(f.has_fpower_series_at x).analytic_at

/-- Reinterpret a bilinear map `f : E →L[𝕜] F →L[𝕜] G` as a multilinear map
`(E × F) [×2]→L[𝕜] G`. This multilinear map is the second term in the formal
multilinear series expansion of `uncurry f`. It is given by
`f.uncurry_bilinear ![(x, y), (x', y')] = f x y'`. -/
def uncurry_bilinear (f : E →L[𝕜] F →L[𝕜] G) : (E × F) [×2]→L[𝕜] G :=
@continuous_linear_map.uncurry_left 𝕜 1 (λ _, E × F) G _ _ _ _ _ $
  (↑(continuous_multilinear_curry_fin1 𝕜 (E × F) G).symm : (E × F →L[𝕜] G) →L[𝕜] _).comp $
    f.bilinear_comp (fst _ _ _) (snd _ _ _)

@[simp] lemma uncurry_bilinear_apply (f : E →L[𝕜] F →L[𝕜] G) (m : fin 2 → E × F) :
  f.uncurry_bilinear m = f (m 0).1 (m 1).2 :=
rfl

/-- Formal multilinear series expansion of a bilinear function `f : E →L[𝕜] F →L[𝕜] G`. -/
@[simp] def fpower_series_bilinear (f : E →L[𝕜] F →L[𝕜] G) (x : E × F) :
  formal_multilinear_series 𝕜 (E × F) G
| 0 := continuous_multilinear_map.curry0 𝕜 _ (f x.1 x.2)
| 1 := (continuous_multilinear_curry_fin1 𝕜 (E × F) G).symm (f.deriv₂ x)
| 2 := f.uncurry_bilinear
| _ := 0

@[simp] lemma fpower_series_bilinear_radius (f : E →L[𝕜] F →L[𝕜] G) (x : E × F) :
  (f.fpower_series_bilinear x).radius = ∞ :=
(f.fpower_series_bilinear x).radius_eq_top_of_forall_image_add_eq_zero 3 $ λ n, rfl

protected

protected theorem has_fpower_series_at_bilinear (f : E →L[𝕜] F →L[𝕜] G) (x : E × F) :
  has_fpower_series_at (λ x : E × F, f x.1 x.2) (f.fpower_series_bilinear x) x :=
⟨∞, f.has_fpower_series_on_ball_bilinear x⟩

protected theorem analytic_at_bilinear (f : E →L[𝕜] F →L[𝕜] G) (x : E × F) :
  analytic_at 𝕜 (λ x : E × F, f x.1 x.2) x :=
(f.has_fpower_series_at_bilinear x).analytic_at

end continuous_linear_map


import system_of_complexes.basic

universe variables u

noncomputable theory
open_locale nnreal
open category_theory opposite normed_add_group_hom system_of_complexes

variables (M M' N : system_of_complexes.{u}) (f : M ⟶ M') (g : M' ⟶ N)

/-- The normed snake lemma, weak version. See Proposition 9.10 from Analytic.pdf -/
--TODO Add the non weak version for complete system of complexes
lemma weak_normed_snake {k k' k'' K K' K'' : ℝ≥0}
  [hk : fact (1 ≤ k)] [hk' : fact (1 ≤ k')] [hk'' : fact (1 ≤ k'')]
  {m : ℕ} {c₀ : ℝ≥0}
  (hM : M.is_weak_bounded_exact k K (m+1) c₀)
  (hM' : M'.is_weak_bounded_exact k' K' (m+1) c₀)
  (hM'_adm : M'.admissible)
  (hf : ∀ c i, (f.apply : M c i ⟶ M' c i).norm_noninc)
  (Hf : ∀ (c : ℝ≥0) [fact (c₀ ≤ c)] (i : ℕ) (hi : i ≤ m+1+1) (x : M (k'' * c) i),
    ∥(res x : M c i)∥ ≤ K'' * ∥f x∥)
  (hg : ∀ c i, (g.apply : M' c i ⟶ N c i).ker = f.apply.range)
  (hgquot : system_of_complexes.is_quotient g) :
  N.is_weak_bounded_exact (k''*k*k') (K'*(K*K'' + 1)) m c₀ :=
begin
  introsI c hc i hi,
  let c₁ := k'' * (k * (k' * c)),
  suffices : ∀ n : N c₁ i, ∀ ε > 0,
    ∃ i₀ (hi₀ : i₀ = i - 1) (y : N c i₀),
      ∥res n - N.d _ _ y∥ ≤ K' * (K * K'' + 1) * ∥N.d i (i+1) n∥ + ε,
  { dsimp [c₁] at this,
    intros n₁ ε hε,
    haveI hc : fact (k'' * k * k' * c = c₁) :=
      { out := (mul_assoc _ _ _).trans ((mul_assoc _ _ _).trans rfl) },
    rcases this (res n₁) ε hε with ⟨i₀, hi₀, y, hy⟩,
    rw [res_res, d_res] at hy,
    refine ⟨i₀, _, hi₀, rfl, _⟩,
    refine ⟨y, hy.trans (add_le_add_right (mul_le_mul_of_nonneg_left _ _) ε)⟩,
    { apply (admissible_of_quotient hgquot hM'_adm).res_norm_noninc },
    { exact (nnreal.zero_le_coe : 0 ≤ K' * (K * K'' + 1)) } },
  intros n ε hε,
  let ε₁ := ε/(K' * (K * K'' + 2) + 1),

  have hε₁ : 0 < ε₁ :=
    div_pos hε (lt_of_lt_of_le zero_lt_one (nnreal.one_le_add'.out : 1 ≤ K' * (K * K'' + 2) + 1)),

  obtain ⟨m' : M' c₁ i, rfl : g m' = n⟩ := (hgquot _ _).surjective _,
  let m₁' := M'.d i (i+1) m',
  have hm₁' : g m₁' = N.d i (i+1) (g m') := (d_apply _ _ g m').symm,
  obtain ⟨m₁'' : M' c₁ (i+1),
          hgm₁'' : g m₁'' = N.d i (i+1) (g m'),
          hnorm_m₁'' : ∥m₁''∥ < ∥N.d i (i+1) (g m')∥ + ε₁⟩ :=
    (hgquot _ _).norm_lift hε₁ (N.d i (i+1) (g m')),
  obtain ⟨m₁, hm₁⟩ : ∃ m₁ : M c₁ (i+1), f m₁ + m₁'' = m₁',
  { have hrange : m₁' - m₁'' ∈ f.apply.range,
    { rw [← hg _ _, mem_ker  _ _, _root_.map_sub],
      change g m₁' - g m₁'' = 0,
      rw [hm₁', hgm₁'', sub_self] },
    obtain ⟨m₁, hm₁ : f m₁ = m₁' - m₁''⟩ := (mem_range _ _).1 hrange,
    exact ⟨m₁, by rw [hm₁, sub_add_cancel]⟩ },

  have him : i+2 ≤ m+2 := add_le_add_right hi _,
  have hm₂ : f (M.d (i+1) (i+2) m₁) = -M'.d (i+1) (i+2) m₁'',
  { rw [← d_apply, eq_sub_of_add_eq hm₁, _root_.map_sub, ← category_theory.comp_apply,
       d_comp_d, coe_zero, ← neg_inj, pi.zero_apply, zero_sub], },
  have hle : ∥res (M.d (i+1) (i+2) m₁)∥ ≤ K'' * ∥m₁''∥,
  { calc ∥res (M.d (i+1) (i+2) m₁)∥
        ≤ K'' * ∥f (M.d (i+1) (i+2) m₁)∥ : Hf _ _ him _
    ... = K'' * ∥M'.d (i+1) (i+2) m₁''∥ : by rw [hm₂, norm_neg]
    ... ≤ K'' * ∥m₁''∥ : (mul_le_mul_of_nonneg_left
                           (hM'_adm.d_norm_noninc _ _ _ _ m₁'') $ nnreal.coe_nonneg K'') },
  obtain ⟨i', j, hi', rfl, m₀, hm₀⟩ :=
    hM _ ⟨hc.out.trans $ le_mul_of_one_le_left' hk'.out⟩ _ (nat.succ_le_succ hi) (res m₁) ε₁ hε₁,
  rw [← nat.pred_eq_sub_one, i.pred_succ] at hi', subst i',
  replace hm₀ : ∥res m₁ - M.d i (i+1) m₀∥ ≤ K * K'' * ∥N.d i (i+1) (g m')∥ + K*K''*ε₁ + ε₁,
  { calc ∥res m₁ - M.d i (i+1) m₀∥  = ∥res (res m₁) - M.d i (i+1) m₀∥ : by rw res_res
    ... ≤ K * ∥M.d (i+1) (i+2) (res m₁)∥ + ε₁ : hm₀
    ... = K * ∥res (M.d (i+1) (i+2) m₁)∥ + ε₁ : by rw d_res
    ... ≤ K*(K'' * ∥m₁''∥) + ε₁ : add_le_add_right (mul_le_mul_of_nonneg_left hle nnreal.zero_le_coe) _
    ... ≤ K*(K'' * (∥N.d i (i+1) (g m')∥ + ε₁)) + ε₁ :  add_le_add_right (mul_le_mul_of_nonneg_left
                                        (mul_le_mul_of_nonneg_left hnorm_m₁''.le nnreal.zero_le_coe)
                                         nnreal.zero_le_coe) ε₁
    ... = K * K'' * ∥N.d i (i+1) (g m')∥ + K*K''*ε₁ + ε₁ : by ring },

  let mnew₁' := M'.d i (i+1) (res m' - f m₀),
  have hmnew' : mnew₁' = res m₁'' + f (res m₁ - M.d i (i+1) m₀),
  { calc mnew₁'
        = M'.d i (i+1) (res m' - f m₀) : rfl
    ... = res (M'.d i (i+1) m') - (f (M.d i (i+1) m₀)) : by rw [_root_.map_sub, d_res _, d_apply]
    ... = res (M'.d i (i+1) m') - (f (res m₁)) + (f (res m₁) - f (M.d i (i+1) m₀)) : by abel
    ... = res m₁'' + f ((res m₁) - (M.d i (i+1) m₀)) : by
                        { rw [← system_of_complexes.map_sub, ← res_apply,
                              ← _root_.map_sub, ← sub_eq_of_eq_add' hm₁.symm] } },
  have hnormle : ∥mnew₁'∥ ≤ (K*K'' + 1)*∥N.d i (i+1) (g m')∥ + (K*K'' + 2) * ε₁,
  { calc ∥mnew₁'∥
        = ∥res m₁'' + f (res m₁ - M.d i (i+1) m₀)∥ : by rw [hmnew']
    ... ≤ ∥res m₁''∥ + ∥f (res m₁ - M.d i (i+1) m₀)∥ : norm_add_le _ _
    ... ≤ ∥m₁''∥ + ∥f (res m₁ - M.d i (i+1) m₀)∥ : add_le_add_right
                                      (hM'_adm.res_norm_noninc _ _ _ _ m₁'') _
    ... ≤ ∥m₁''∥ + ∥res m₁ - M.d i (i+1) m₀∥ : add_le_add_left (hf _ _ _) _
    ... ≤ ∥N.d i (i+1) (g m')∥ + ε₁ + ∥res m₁ - M.d i (i+1) m₀∥ : add_le_add_right (le_of_lt hnorm_m₁'')  _
    ... ≤ ∥N.d i (i+1) (g m')∥ + ε₁ + (K * K'' * ∥N.d i (i+1) (g m')∥ + K * K'' * ε₁ + ε₁) : add_le_add_left hm₀ _
    ... = (K*K'' + 1)*∥d _ _ (i+1) (g m')∥ + (K*K'' + 2) * ε₁ : by ring },
  obtain ⟨i₀, _, hi₀, rfl, mnew₀, hmnew₀⟩ := hM' _ hc _ (hi.trans m.le_succ) (res m' - f m₀) _ hε₁,
  replace hmnew₀ : ∥res (res m' - f m₀) - d _ _ _ mnew₀∥ ≤
    K' * ((K * K'' + 1) * ∥N.d i (i+1) (g m')∥ + (K * K'' + 2) * ε₁) + ε₁ :=
    hmnew₀.trans (add_le_add_right (mul_le_mul_of_nonneg_left hnormle nnreal.zero_le_coe) ε₁),
  let nnew₀ : ↥(N c i₀) := g mnew₀,
  have hmnewlift : g (res (res m' - f m₀) - M'.d i₀ i mnew₀) = res (g m') - N.d i₀ i nnew₀,
  { suffices h : g (res m' - f m₀) = res (g m'),
    { rw [system_of_complexes.map_sub, ← res_apply, ← d_apply, h, res_res] },
    rw system_of_complexes.map_sub,
    have hker : f m₀ ∈ g.apply.ker,
    { rw [hg _ _, mem_range _ _],
      exact ⟨m₀, rfl⟩ },
    replace hker : g (f m₀) = 0, { rwa mem_ker at hker },
    rw [hker, sub_zero, ← res_apply] },
  refine ⟨i₀, hi₀, nnew₀, _⟩,
  rw ← hmnewlift,
  refine ((hgquot _ _).norm_le _).trans (hmnew₀.trans (le_of_eq _)),
  have hε₁_ε : (K' * (K * K'' + 2) + 1 : ℝ)*ε₁ = ε := mul_div_cancel' _
    (by { refine (lt_of_lt_of_le zero_lt_one _).ne',
          exact (nnreal.one_le_add'.out : 1 ≤ K' * (K * K'' + 2) + 1) }),
  rw ← hε₁_ε,
  ring,
end


inductive direction | left | right
instance : decidable_eq direction := by tactic.mk_dec_eq_instance

local prefix ^ := option

def nondet_turing_machine (state symbol : Type) [decidable_eq state] [decidable_eq symbol] :=
state → ^symbol → state → ^symbol → direction → bool

def turing_machine (state symbol : Type) [decidable_eq state] [decidable_eq symbol] :=
state → ^symbol → ^(state × ^symbol × direction)

variables {S A : Type} [decidable_eq S] [decidable_eq A]

def to_nondet (TM : turing_machine S A) : nondet_turing_machine S A :=
λ s a s' a' d', (TM s a = some (s', a', d') : bool)

instance : has_coe (turing_machine S A) (nondet_turing_machine S A) :=
⟨to_nondet⟩

structure TM_config (S A : Type) :=
(cur : S)
(head : ^A)
(left : list (^A))
(right : list (^A))

def uncons : list (^A) → ^A × list (^A)
| []       := (none, [])
| (a :: s) := (a, s)

def cons' : ^A → list (^A) → list (^A)
| none [] := []
| v    s  := v::s

def apply_step
  (l r : list (^A)) (c : S) (v : ^A) : direction → TM_config S A
| direction.left  := let ⟨a, l'⟩ := uncons l in ⟨c, a, l', cons' v r⟩
| direction.right := let ⟨a, r'⟩ := uncons r in ⟨c, a, cons' v l, r'⟩

inductive step (TM : nondet_turing_machine S A) :
  TM_config S A → TM_config S A → Prop
| mk {c h l r c' v d} :
  TM c h c' v d → step ⟨c, h, l, r⟩ (apply_step l r c' v d)

def halts (TM) (s : TM_config S A) : Prop := ∀ s', ¬ step TM s s'

inductive computes (TM) (res : TM_config S A) : nat → TM_config S A → Prop
| done : halts TM res → computes 0 res
| step {s s' n} : step TM s s' → computes n s' → computes (n+1) s

def next (TM : turing_machine S A) : TM_config S A → option (TM_config S A)
| ⟨c, h, l, r⟩ := match TM c h with
  | none := none
  | some (c', v, d) := some (apply_step l r c' v d)
  end

theorem next_step {TM : turing_machine S A}
  (s s' : TM_config S A) : next TM s = some s' ↔ @step S A _ _ TM s s' :=
begin
  constructor,
  { cases s, simp [next],
    ginduction TM cur head with e,
    { intro e, injection e },
    { cases a with s' a, cases a with v d,
      simp [next], intro i, injection i with h, subst h,
      exact ⟨to_bool_true e⟩ } },
  { intro h, induction h,
    simp [next],
    conv at a {whnf}, rw of_to_bool_true a,
    refl }
end

theorem next_halts {TM : turing_machine S A}
  (s : TM_config S A) : next TM s = none ↔ @halts S A _ _ TM s :=
begin
  ginduction (next TM s) with e,
  { simp, intros s' h,
    injection e.symm.trans ((next_step _ _).2 h) },
  { constructor; intro h, {contradiction},
    exact absurd ((next_step _ _).1 e) (h _) }
end

inductive tape_alpha (n : nat) : Type
| input {} : bool → tape_alpha
| delim {} : tape_alpha
| work {} : fin n → tape_alpha
instance (n) : decidable_eq (tape_alpha n) := by tactic.mk_dec_eq_instance

def TATM (s n : nat) := turing_machine (fin (s+1)) (tape_alpha n)

def NTATM (s n : nat) := nondet_turing_machine (fin (s+1)) (tape_alpha n)

instance (s n) : has_coe (TATM s n) (NTATM s n) := ⟨to_nondet⟩

def encode {n} : list (list bool) → list (^tape_alpha n)
| [] := []
| ([] :: ls) := some tape_alpha.delim :: encode ls
| ((a::l) :: ls) := some (tape_alpha.input a) :: encode (l::ls)

def computes_fn_in_time {s n} (TM : NTATM s n) {m}
  (f : (fin m → list bool) → list bool)
  (tm : (fin m → list bool) → nat) : Prop :=
∀ i : fin m → list bool,
∃ (n ≤ tm i) e,
  computes TM
    ⟨e, none, [], encode [f i]⟩ n
    ⟨0, none, [], encode (array.to_list ⟨i⟩)⟩


import algebra.field
import algebra.char_zero
import algebra.char_p
import gtm106.naive_plane
import gtm106.weierstrass_equation.basic
import gtm106.weierstrass_equation.linear_change_of_variable
import myhelper.char
import tactic

namespace weierstrass_equation

def is_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) :=
E.a1 = 0 ∧ E.a3 = 0

@[simp]
lemma b2_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.b2 = 4*E.a2 :=
begin
  simp [b2, h.1, zero_pow],
end

@[simp]
lemma b4_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.b4 = 2*E.a4 :=
begin
  simp [b4, h.1, h.2],
end

@[simp]
lemma b6_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.b6 = 4*E.a6 :=
begin
  simp [b6, h.2, zero_pow],
end

@[simp]
lemma b8_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.b8 = 4*E.a2*E.a6 - E.a4^2 :=
begin
  simp [b8, h.1, h.2, zero_pow],
end

@[simp]
lemma c4_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.c4 = 16*E.a2^2 - 48*E.a4 :=
begin
  simp [c4, h],
  ring,
end

@[simp]
lemma c6_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.c6 = -64*E.a2^3 + 288*E.a2*E.a4 - 864*E.a6 :=
begin
  simp [c6, h],
  ring,
end

@[simp]
lemma disc_of_model_of_char_neq_2 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2) :
E.disc = -64*E.a2^3*E.a6 + 16*E.a2^2*E.a4^2 - 64*E.a4^3 - 432*E.a6^2 +288*E.a2*E.a4*E.a6 :=
begin
  simp [disc, h],
  ring,
end

lemma have_model_of_char_neq_2 {K : Type*} [field K]
(E : weierstrass_equation K) (hchar2 : ring_char K ≠ 2)
: ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_neq_2 :=
begin
  replace hchar2 := prime_neq_char_is_non_zero K 2 (by norm_num) hchar2,
  norm_cast at hchar2,
  use ⟨ 1, 0, -E.a1/2, -E.a3/2, by simp ⟩,
  simp [is_model_of_char_neq_2, linear_change_of_variable.change_curve],
  field_simp [hchar2],
  simp [mul_comm],
end

def is_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) :=
E.a1 = 0 ∧ E.a2 = 0 ∧ E.a3 = 0

@[simp]
lemma b2_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.b2 = 0 :=
begin
  simp [b2, h.1, h.2.1, zero_pow],
end

@[simp]
lemma b4_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.b4 = 2*E.a4 := E.b4_of_model_of_char_neq_2 ⟨ h.1, h.2.2 ⟩

@[simp]
lemma b6_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.b6 = 4*E.a6 := E.b6_of_model_of_char_neq_2 ⟨ h.1, h.2.2 ⟩

@[simp]
lemma b8_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.b8 = -E.a4^2 :=
begin
  simp [b8, h.1, h.2.1, h.2.2, zero_pow],
end

@[simp]
lemma c4_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.c4 = -48*E.a4 :=
begin
  simp [c4, h],
  ring,
end

@[simp]
lemma c6_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.c6 = -864*E.a6 :=
begin
  simp [c6, h],
  ring,
end

@[simp]
lemma disc_of_model_of_char_neq_2_and_3 {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) :
E.disc = -16*(4*E.a4^3 + 27*E.a6^2) :=
begin
  simp [disc, h],
  ring,
end

@[simp]
lemma j_of_model_of_char_neq_2_and_3 {K : Type*} [field K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) (hchar2 : ring_char K ≠ 2) :
E.j = 6912*E.a4^3/(4*E.a4^3 + 27*E.a6^2) :=
begin
  simp [j, h],
  by_cases h : 4*E.a4^3 + 27*E.a6^2 = 0, {
    rw h, simp,
  },
  have h16 := power_of_prime_neq_char_is_non_zero K 16 2 4 (by norm_num) (by norm_num) hchar2,
  norm_num at h16,
  field_simp [h, h16],
  ring,
end

lemma have_model_of_char_neq_2_and_3 {K : Type*} [field K]
(E : weierstrass_equation K) (hchar2 : ring_char K ≠ 2) (hchar3 : ring_char K ≠ 3)
: ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_neq_2_and_3 :=
begin
  rcases E.have_model_of_char_neq_2 hchar2 with ⟨ C, h1 ⟩,
  set E' := C.change_curve E with hE,
  replace hchar3 := prime_neq_char_is_non_zero K 3 (by norm_num) hchar3,
  norm_cast at hchar3,
  let C' : linear_change_of_variable K := ⟨ 1, -E'.a2/3, 0, 0, by simp ⟩,
  use C'.composite C,
  rw [linear_change_of_variable.change_curve.comp, ← hE],
  simp [is_model_of_char_neq_2_and_3,
    linear_change_of_variable.change_curve,
    h1.1, h1.2, zero_pow],
  field_simp [hchar3],
  ring,
end

def is_model_of_char_3_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) :=
E.a1 = 0 ∧ E.a3 = 0 ∧ E.a4 = 0

@[simp]
lemma c4_of_model_of_char_3_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_3_j_non_zero) (hchar3 : ring_char K = 3) :
E.c4 = E.a2^2 :=
begin
  simp [c4, b2, b4,
    h.1, h.2.1, h.2.2, zero_pow],
  ring_char3,
end

@[simp]
lemma disc_of_model_of_char_3_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_3_j_non_zero) (hchar3 : ring_char K = 3) :
E.disc = -E.a2^3*E.a6 :=
begin
  simp [disc, b2, b4,
    b6, b8,
    h.1, h.2.1, h.2.2, zero_pow],
  ring_char3,
end

@[simp]
lemma j_of_model_of_char_3_j_non_zero {K : Type*} [field K]
(E : weierstrass_equation K) (h : E.is_model_of_char_3_j_non_zero) (hchar3 : ring_char K = 3) :
E.j = -E.a2^3/E.a6 :=
begin
  simp [j, h, hchar3],
  by_cases ha6 : E.a6 = 0, {
    rw ha6, simp,
  },
  by_cases ha2 : E.a2 = 0, {
    rw ha2, simp [zero_pow],
  },
  field_simp [ha2, ha6], ring,
end

@[simp]
lemma c4_of_model_of_char_3_j_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) (hchar3 : ring_char K = 3) :
E.c4 = 0 :=
begin
  simp [h],
  ring_char3,
end

@[simp]
lemma disc_of_model_of_char_3_j_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) (hchar3 : ring_char K = 3) :
E.disc = -E.a4^3 :=
begin
  simp [h],
  ring_char3,
end

@[simp]
lemma j_of_model_of_char_3_j_zero {K : Type*} [field K]
(E : weierstrass_equation K) (h : E.is_model_of_char_neq_2_and_3) (hchar3 : ring_char K = 3) :
E.j = 0 :=
begin
  simp [j, h, hchar3],
end

lemma have_model_of_char_3 {K : Type*} [field K]
(E : weierstrass_equation K) (hchar3 : ring_char K = 3)
: ((E.non_singular' → E.j ≠ 0) ∧ ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_3_j_non_zero)
∨ (E.j = 0 ∧ ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_neq_2_and_3) :=
begin
  have hchar2 : ring_char K ≠ 2 := by {
    rw hchar3, norm_num,
  },
  rcases E.have_model_of_char_neq_2 hchar2 with ⟨ C, h1 ⟩,
  set E' := C.change_curve E with hE,
  have hdisc : E'.disc = E'.a2^2*E'.a4^2 - E'.a2^3*E'.a6 - E'.a4^3 := by {
    clear_value E',
    simp [h1],
    ring_char3,
  },
  have hc4 : E'.c4 = E'.a2^2 := by {
    clear_value E',
    simp [h1],
    ring_char3,
  },
  have hj : E'.j = E.j := C.j E,
  have hnonsing : E.non_singular' ↔ E'.non_singular' := C.preserve_non_singular' E,
  rw [← hj, hnonsing],
  unfold j non_singular',
  rw hc4,
  by_cases ha2 : E'.a2 = 0, {
    right,
    split, { rw ha2, ring, },
    use C,
    exact ⟨ h1.1, ha2, h1.2 ⟩,
  },
  left,
  clear_value E',
  split, {
    intro hdisc,
    simp [ha2, hdisc],
  },
  let C' : linear_change_of_variable K := ⟨ 1, E'.a4/E'.a2, 0, 0, by simp ⟩,
  use C'.composite C,
  rw [linear_change_of_variable.change_curve.comp, ← hE],
  simp [is_model_of_char_3_j_non_zero,
    linear_change_of_variable.change_curve,
    h1.1, h1.2],
  field_simp [ha2],
  ring_char3,
end

def is_model_of_char_2_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) :=
E.a1 = 1 ∧ E.a3 = 0 ∧ E.a4 = 0

def is_model_of_char_2_j_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) :=
E.a1 = 0 ∧ E.a2 = 0

@[simp]
lemma c4_of_model_of_char_2_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_non_zero) (hchar2 : ring_char K = 2) :
E.c4 = 1 :=
begin
  simp [c4, b2, b4,
    h.1, h.2.1, h.2.2, zero_pow],
  ring_char2,
end

@[simp]
lemma disc_of_model_of_char_2_j_non_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_non_zero) (hchar2 : ring_char K = 2) :
E.disc = E.a6 :=
sub_eq_zero.1 begin
  simp [disc, b2, b4,
    b6, b8,
    h.1, h.2.1, h.2.2, zero_pow],
  ring_char2,
end

@[simp]
lemma j_of_model_of_char_2_j_non_zero {K : Type*} [field K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_non_zero) (hchar2 : ring_char K = 2) :
E.j = 1/E.a6 :=
begin
  simp [j, h, hchar2],
end

@[simp]
lemma c4_of_model_of_char_2_j_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_zero) (hchar2 : ring_char K = 2) :
E.c4 = 0 :=
begin
  simp [c4, b2, b4,
    h.1, h.2, zero_pow],
  ring_char2,
end

@[simp]
lemma disc_of_model_of_char_2_j_zero {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_zero) (hchar2 : ring_char K = 2) :
E.disc = E.a3^4 :=
sub_eq_zero.1 begin
  simp [disc, b2, b4,
    b6, b8,
    h.1, h.2, zero_pow],
  ring_char2,
end

@[simp]
lemma j_of_model_of_char_2_j_zero {K : Type*} [field K]
(E : weierstrass_equation K) (h : E.is_model_of_char_2_j_zero) (hchar2 : ring_char K = 2) :
E.j = 0 :=
begin
  simp [j, h, hchar2],
end

lemma have_model_of_char_2 {K : Type*} [field K]
(E : weierstrass_equation K) (hchar2 : ring_char K = 2)
: ((E.non_singular' → E.j ≠ 0) ∧ ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_2_j_non_zero)
∨ (E.j = 0 ∧ ∃ (C : linear_change_of_variable K), (C.change_curve E).is_model_of_char_2_j_zero) :=
begin
  have hc4 : E.c4 = E.a1^4 := by {
    simp [c4, b2, b4],
    ring_char2,
  },
  unfold j,
  rw hc4,
  by_cases ha1 : E.a1 = 0, {
    right,
    split, {
      rw ha1,
      ring,
    },
    use ⟨ 1, E.a2, 0, 0, by simp ⟩,
    simp [is_model_of_char_2_j_zero,
      linear_change_of_variable.change_curve,
      ha1],
    ring_char2,
  },
  left,
  split, {
    unfold non_singular',
    intro hdisc,
    field_simp [ha1, hdisc],
  },
  use ⟨ E.a1, E.a3/E.a1, 0, (E.a1^2*E.a4+E.a3^2)/E.a1^3, ha1 ⟩,
  simp [is_model_of_char_2_j_non_zero,
    linear_change_of_variable.change_curve,
    ha1],
  split, {
    field_simp [ha1], ring_char2,
  },
  field_simp [pow_succ, ha1], ring_char2,
end

end weierstrass_equation


/-
Copyright (c) 2018 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import .consistency ..encode

open nat set classical

local attribute [instance, priority 0] prop_decidable

variables {σ : nat}

/- maximal set of a context -/

namespace ctx
def is_max (Γ : ctx σ) := is_consist Γ ∧ ∀ p, p ∈ Γ ∨ (~p) ∈ Γ

def insert_form (Γ : ctx σ) (p : form σ) : ctx σ :=
if is_consist (Γ ⸴ p) then Γ ⸴ p else Γ ⸴ ~p

def insert_code (Γ : ctx σ) (n : nat) : ctx σ :=
match encodable.decode (form σ) n with
| none := Γ
| some p := insert_form Γ p
end

@[simp]
def maxn (Γ : ctx σ) : nat → ctx σ
| 0     := Γ
| (n+1) := insert_code (maxn n) n

@[simp]
def max (Γ : ctx σ) : ctx σ :=
⋃ n, maxn Γ n

/- maximal extensions are extensions -/

lemma subset_insert_code {Γ : ctx σ} (n) :
  Γ ⊆ insert_code Γ n :=
begin
  intros v hv,
  unfold insert_code,
  cases (encodable.decode (form σ) _); unfold insert_code insert_form,
  { assumption },
  { split_ifs; exact set.mem_insert_of_mem _ hv },
end

lemma subset_maxn {Γ : ctx σ} :
  ∀ n, Γ ⊆ maxn Γ n
| 0        := by refl
| (succ n) := subset.trans (subset_maxn n) (subset_insert_code _)

lemma maxn_subset_max {Γ : ctx σ} (n) :
  maxn Γ n ⊆ max Γ :=
subset_Union _ _

lemma subset_max_self {Γ : ctx σ} :
  Γ ⊆ max Γ :=
maxn_subset_max 0

lemma maxn_subset_succ {Γ : ctx σ} {n : nat} :
  maxn Γ n ⊆ maxn Γ (n+1) :=
subset_insert_code _

lemma maxn_mono {Γ : ctx σ} {m n : nat} (h : n ≤ m) :
  maxn Γ n ⊆ maxn Γ m :=
by induction h; [refl, exact subset.trans h_ih (subset_insert_code _)]

/- maximal extensions are maximal -/

lemma insert_form_self {Γ : ctx σ} {p : form σ} :
  p ∈ insert_form Γ p ∨ (~p) ∈ insert_form Γ p :=
begin
  unfold insert_form, split_ifs,
  { exact or.inl (mem_insert _ _) },
  { exact or.inr (mem_insert _ _) },
end

lemma insert_code_self {Γ : ctx σ} (p : form σ) :
  p ∈ insert_code Γ (encodable.encode p) ∨ (~p) ∈ insert_code Γ (encodable.encode p) :=
begin
  unfold insert_code,
  rw (encodable.encodek p),
  apply insert_form_self,
end

lemma mem_or_mem_max {Γ : ctx σ} (p : form σ) :
  p ∈ max Γ ∨ (~p) ∈ max Γ :=
begin
  have := maxn_subset_max (encodable.encode p + 1),
  exact (insert_code_self p).imp (@this _) (@this _),
end

/- maximal extensions preserves consistency -/

lemma is_consist_insert_form {Γ : ctx σ} {p : form σ}
  (H : is_consist Γ) : is_consist (insert_form Γ p) :=
begin
  rw insert_form, split_ifs,
  { exact h },
  { exact inconsist_to_neg_consist H h },
end

lemma is_consist_insert_code {Γ : ctx σ} (n)
  (H : is_consist Γ) : is_consist (insert_code Γ n) :=
begin
  rw insert_code, cases encodable.decode _ _,
  { exact H },
  { exact is_consist_insert_form H }
end

lemma is_consist_maxn {Γ : ctx σ} :
  ∀ n, is_consist Γ → is_consist (maxn Γ n)
| 0 H := H
| (n+1) H := is_consist_insert_code _ (is_consist_maxn _ H)

lemma in_ext_ctx_max_set_is_in_ext_ctx_at {Γ : ctx σ} {p : form σ} :
  (p ∈ max Γ) → ∃ n, p ∈ maxn Γ n :=
mem_Union.1

lemma ext_ctx_lvl {Γ : ctx σ} {p : form σ} :
  (max Γ ⊢ₛ₅ p) → ∃ n, maxn Γ n ⊢ₛ₅ p :=
begin
  generalize eq : max Γ = Γ',
  intro h, induction h; subst eq,
    { cases in_ext_ctx_max_set_is_in_ext_ctx_at h_h,
      constructor,
      apply prf.ax,
      assumption },

    repeat {
      constructor,
      apply prf.pl1 <|> apply prf.pl2 <|> apply prf.pl3,
      exact 0
    },

    { cases h_ih_hpq rfl with n0 h_ext_pq,
      cases h_ih_hp rfl with n1 h_ext_p,
        cases (prop_decidable (n0 ≤ n1)),
            have hh: n1 ≤ n0 :=
              begin
                cases nat.le_total,
                assumption,
                contradiction
            end,
          constructor,
            apply prf.mp,
            assumption,
              apply prf.sub_weak,
                exact h_ext_p,
                apply maxn_mono,
                assumption,
          constructor,
            apply prf.mp,
              apply prf.sub_weak,
                exact h_ext_pq,
                apply maxn_mono,
                assumption,
              assumption },

    { constructor,
      apply prf.k,
      exact 0 },

    { constructor,
      apply prf.t,
      exact 0 },

    { constructor,
      apply prf.s4,
      exact 0 },

    { constructor,
      apply prf.b,
      exact 0 },

    { constructor,
      apply prf.nec h_h,
      exact 0 }
end

lemma is_consist_max {Γ : ctx σ} :
  is_consist Γ → is_consist (max Γ) :=
λ hc nc, let ⟨n, ht⟩ := ext_ctx_lvl nc in is_consist_maxn _ hc ht

/- maximal consistent sets are closed under derivability -/

lemma max_of_max {Γ : ctx σ} {p : form σ} (h : is_consist Γ) : is_max (max Γ) :=
⟨ is_consist_max h , mem_or_mem_max⟩

lemma mem_max_of_prf {Γ : ctx σ} {p : form σ} (h₁ : is_max Γ)
  (h₂ : Γ ⊢ₛ₅ p) : p ∈ Γ :=
(h₁.2 p).resolve_right $ λ hn,
h₁.1 (prf.mp (prf.ax hn) h₂)

end ctx

/- the canonical model construction -/

-- domain

namespace canonical
def domain (σ : nat) : set (wrld σ) := {w | ctx.is_max w}

lemma mem_domain_max {w : wrld σ} :
  w ∈ domain σ → ∀ p, (p ∈ w) ∨ ((~p) ∈ w) :=
and.right

lemma mem_domain_consist {w : wrld σ} :
  w ∈ domain σ → is_consist w :=
and.left

lemma mem_domain {w : wrld σ}
  (h : is_consist w) : ctx.max w ∈ domain σ :=
⟨ctx.is_consist_max h, ctx.mem_or_mem_max⟩

lemma mem_domain_of_prf {p : form σ} (w ∈ domain σ)
  (h : w ⊢ₛ₅ p) : p ∈ w :=
(mem_domain_max H p).resolve_right $
λ hn, (mem_domain_consist H) (prf.mp (prf.ax hn) h)

-- accessibility

def unbox (w : wrld σ) : wrld σ := {p | (◻p) ∈ w}

noncomputable def access : wrld σ → wrld σ → bool :=
assume w v, if (unbox w ⊆ v) then tt else ff

lemma subset_unbox_iff_access {w v : wrld σ} : access w v = tt ↔ unbox w ⊆ v :=
by unfold access; simp

lemma mem_unbox_iff_mem_box {p : form σ} {w : wrld σ} :
  p ∈ unbox w ↔ (◻p) ∈ w :=
⟨ id, id ⟩

lemma not_mem_unbox_of_mem_not_box {p : form σ} {w : wrld σ} (hc : w ∈ domain σ) :
  (~◻p) ∈ w → p ∉ unbox w :=
λ h np, (mem_domain_consist hc) (prf.mp (prf.ax h) (prf.ax (mem_unbox_iff_mem_box.1 np)))

lemma mem_box_of_unbox_prf {p : form σ} {w : wrld σ} (H : w ∈ domain σ) :
  (unbox w ⊢ₛ₅ p) → (◻p) ∈ w :=
begin
  generalize eq : unbox w = Γ',
  intro h, induction h; subst eq,
    { assumption },
    repeat { apply ctx.mem_max_of_prf H,
      apply prf.nec,
      apply prf.pl1 <|> apply prf.pl2 <|> apply prf.pl3 },
    { apply ctx.mem_max_of_prf H,
      refine prf.mp (prf.ax _) (prf.ax (h_ih_hp rfl)),
      exact (ctx.mem_max_of_prf H) (prf.mp prf.k (prf.ax (h_ih_hpq rfl))) },
    { apply ctx.mem_max_of_prf H,
      exact prf.nec prf.k },
    { apply ctx.mem_max_of_prf H,
      exact prf.nec prf.t },
    { apply ctx.mem_max_of_prf H,
      exact prf.nec prf.s4 },
    { apply ctx.mem_max_of_prf H,
      exact prf.nec prf.b },
    { apply ctx.mem_max_of_prf H,
      apply prf.nec (prf.nec h_h) }
end

lemma not_unbox_prf_of_not_box_mem {p : form σ} {w : wrld σ} (hw : w ∈ domain σ) :
  (~◻p) ∈ w → (unbox w ⊬ₛ₅ p) :=
by { intros h nhp, apply mem_domain_consist hw, apply prf.mp (prf.ax h) (prf.ax (mem_box_of_unbox_prf hw nhp)) }

lemma consist_unbox_of_not_box_mem {p : form σ} {w : wrld σ} (hw : w ∈ domain σ) :
  (~◻p) ∈ w → is_consist (unbox w ⸴ (~p)) :=
λ hn, consist_not_of_not_prf (not_unbox_prf_of_not_box_mem hw hn)

-- valuation

noncomputable def val : fin σ → wrld σ → bool :=
assume p w, if w ∈ domain σ ∧ (#p) ∈ w then tt else ff

-- reflexivity

lemma access.refl :
  ∀ w ∈ domain σ, access w w = tt :=
begin
  intros w h, unfold access,
  simp, intros p hp, cases mem_domain_max h p,
  { assumption },
  { exfalso, apply mem_domain_consist h,
    apply prf.mp,
    { apply prf.ax h_1 },
    { apply prf.mp,
      { apply prf.t },
      { apply prf.ax,
        apply mem_unbox_iff_mem_box.1,
        assumption } } }
end

-- symmetry

lemma access.symm : ∀ w ∈ domain σ, ∀ v ∈ domain σ, access w v = tt → access v w = tt :=
begin
  intros w hw v hv, unfold access,
  simp, intros sw p hp,
  apply mem_domain_of_prf _ hw,
  apply prf.mp,
    { apply prf.sub_weak, apply prf.contrap_b, simp },
    { have h₁ : ∀ p, p ∉ v → p ∉ unbox w, from
      (λ p, (@not_imp_not _ _ (prop_decidable _)).2 (@sw _ ) ),
      have h₂ : (◻~◻p) ∉ w, from
      begin
        apply h₁,
        intro h, apply mem_domain_consist hv,
        apply prf.mp,
        { apply prf.ax h },
        { apply prf.ax, assumption }
      end,
      cases mem_domain_max hw (◻~◻p),
      { contradiction },
      { apply prf.ax, assumption } }
end

-- transitivity

lemma access.trans : ∀ w ∈ domain σ, ∀ v ∈ domain σ, ∀ u ∈ domain σ,
  access w v = tt → access v u = tt → access w u = tt :=
begin
  intros w hw v hv u hu, unfold access,
  simp, intros sw sv p hp,
  apply sv, apply mem_unbox_iff_mem_box.2,
  apply sw, apply mem_unbox_iff_mem_box.2,
  apply mem_domain_of_prf, assumption,
  apply prf.mp,
  { exact prf.s4 },
  { apply prf.ax,
    apply mem_unbox_iff_mem_box.1,
    assumption }
end

noncomputable def model : @model σ :=
begin
  fapply model.mk,
    apply domain,
    apply access,
    apply val,
    apply access.refl,
    apply access.symm,
    apply access.trans
end

/- truth is membership in the canonical model -/

lemma form_tt_iff_mem_wrld {p : form σ} :
  ∀ (w ∈ domain σ), (w ⊩⦃model⦄ p) = tt ↔ p ∈ w :=
begin
  induction p with v p q hp hq p hp,
  { intros, unfold forces_form model val, simp,
    apply iff.intro,
    { intro h, exact h.right },
    { intro h, split, repeat {assumption} } },

  { unfold forces_form, simp,
    intros w wm h, apply mem_domain_consist wm (prf.ax h) },

  { unfold forces_form, simp, intros v wm,
    apply iff.intro,
    { intro h, cases h,
      { cases mem_domain_max wm p with h₁ h₂,
        { refine ctx.mem_max_of_prf wm _,
          exact (prf.mp prf.pl1 (prf.ax ((hq _ wm).1 h))) },
        { refine ctx.mem_max_of_prf wm _,
          apply prf.mp prf.contrap (prf.mp prf.pl1 (prf.ax h₂)) } },
      { cases mem_domain_max wm q with h₁ h₂,
        { refine ctx.mem_max_of_prf wm _,
          exact prf.mp prf.pl1 (prf.ax h₁) },
        { refine ctx.mem_max_of_prf wm _,
          refine prf.mp prf.contrap (prf.mp prf.pl1 _),
          cases mem_domain_max wm p with hp₁ hp₂,
          { exfalso, apply ff_eq_tt_eq_false,
            transitivity,
            { exact h.symm },
            { exact (hp _ wm).2 hp₁} },
          { apply prf.ax hp₂ } } } },
      { intro h,
        cases mem_domain_max wm q with h₁ h₂,
        { left, exact (hq _ wm).2 h₁ },
        { cases mem_domain_max wm p with hp₁ hp₂,
          { exfalso, apply mem_domain_consist wm,
            exact prf.mp (prf.ax h₂) (prf.mp (prf.ax h) (prf.ax hp₁)) },
          { right, apply eq_ff_of_not_eq_tt,
            intro ptt, apply mem_domain_consist wm,
            exact prf.mp (prf.ax hp₂) (prf.ax ((hp _ wm).1 ptt)) } } } },

  { unfold forces_form,
    simp, intros w wm,
    apply iff.intro,
    { intro h,
      cases mem_domain_max wm (◻p) with h₁ h₂,
      { exact h₁ },
        exfalso, apply ctx.is_consist_max (consist_unbox_of_not_box_mem wm h₂),
        apply prf.mp,
        { apply prf.ax (ctx.subset_max_self (mem_insert _ _)) },
        { apply prf.ax,
          apply (hp _ (mem_domain (consist_unbox_of_not_box_mem wm h₂))).1,
          apply h, apply mem_domain (consist_unbox_of_not_box_mem wm h₂), exact wm,
          apply subset_unbox_iff_access.2,
          intros p pm, apply ctx.subset_max_self,
          apply mem_insert_of_mem _ pm } },

    { intro h,
      intros w v, unfold model access, simp,
      intros wm' rwv,
      exact (hp _ v).2 (rwv (mem_unbox_iff_mem_box.2 h)) } }
end

lemma ctx_tt_of_mem_domain (Γ : ctx σ) (wm : Γ ∈ domain σ) :
  (Γ ⊩⦃model⦄ Γ) = tt :=
mem_tt_to_ctx_tt Γ (λ p pm, (form_tt_iff_mem_wrld _ wm).2 pm)

/- the completeness lemma -/

theorem completeness {Γ : ctx σ} {p : form σ} :
  (Γ ⊨ₛ₅ p) → (Γ ⊢ₛ₅ p) :=
begin
  apply (@not_imp_not (Γ ⊢ₛ₅ p) (Γ ⊨ₛ₅ p) (prop_decidable _)).1,
  intros nhp hp, cases hp,
  have c : is_consist (Γ ⸴ ~p) := consist_not_of_not_prf nhp,
  apply absurd,
  fapply hp,
    { exact model },
    { exact ctx.max (Γ ⸴ ~p) },
    { apply mem_domain c },

    { apply cons_ctx_tt_to_ctx_tt,
      apply ctx_tt_to_subctx_tt,
      apply ctx_tt_of_mem_domain (ctx.max (Γ ⸴ ~p)),
      apply mem_domain c,
      apply ctx.subset_max_self },

    { simp, apply eq_ff_of_not_eq_tt,
      apply neg_tt_iff_ff.1,
      apply and.elim_right,
      apply cons_ctx_tt_iff_and.1,
      apply ctx_tt_to_subctx_tt,
      apply ctx_tt_of_mem_domain (ctx.max (Γ ⸴ ~p)),
      apply mem_domain c,
      apply ctx.subset_max_self },
end

end canonical


import tactic

@[derive fintype] inductive bool2
| ff2 : bool2
| tt2 : bool2

namespace bool2

definition and2 : bool2 → bool2 → bool2
| ff2 P := ff2
| tt2 P := P

definition or2 : bool2 → bool2 → bool2
| tt2 P := tt2
| ff2 P := P

definition not2 : bool2 → bool2
| tt2 := ff2
| ff2 := tt2

definition xor2 (x y : bool2) := and2 (or2 x y) (not2 (and2 x y))

definition going : bool2 → bool
| ff2 := tt
| tt2 := ff

end bool2

open bool2

definition bool.to2 : bool → bool2
| tt := ff2
| ff := tt2

namespace bool2

-- no good -- false and true name clash

-- `bool2.F`, standing for "From `bool` (to `bool2` in this case)".

-- `bool2.T`, standing for "To `bool` (from `bool2` in this case)"
-- So anything we can do in `bool` about `bool2`

-- These functions bijectively identify `bool` and `bool2`.

open bool

definition equiv : bool2 ≃ bool :=
{ to_fun := going,
  inv_fun := to2,
  left_inv := begin
    intro x,
    cases x;
    refl,
  end,
  right_inv := begin
    rintro (ht | hf);
    refl
  end
   }
end bool2

-- every definition involving bool has a corresponding definition
-- in bool2

-- What construction in `bool2` corresponds to `and` in `bool`?

example (x y : bool) : (x && y).to2 = or2 x.to2 y.to2 :=
begin
  cases x;
  cases y;
  refl,
end

example (x y : bool) : (x || y).to2 = and2 x.to2 y.to2 :=
begin
  cases x;
  cases y;
  refl,
end

example (x y : bool) : (bxor x y).to2 = not2 (xor2 x.to2 y.to2) :=
begin
  cases x;
  cases y;
  refl,
--  sorry,sorry,sorry,sorry,
end

#print prefix bool
example (x : bool) : (bnot x).to2 = not2 (x.to2) :=
begin
  cases x;
  refl
end

def bimp : bool → bool → bool
| ff tt := ff
| _  _  := tt

-- corresponds to something awful

-- Computer scientists don't want to reason about bool
-- or prove theorems about it -- they just need it
-- to make data structures, recording yes-no answers
-- to questions about the terms involved.

example (b : bool) : b = ff ∨ b = tt := bool.dichotomy b

-- I can'y do this -- ask Chris?
example : ∀ f : bool → bool → bool,
  (∀ x y : bool, f x y = f y x) →
  (f = bor ∨ f = band ∨ f = bxor ∨ f = λ x y, bnot (band x y)
  ∨ f = λ x y, bnot (bor x y) ∨ f = λ x y, bnot (bxor x y) ∨ f = λ x y, tt ∨ f = λ x y, ff) :=
begin
  intros,
  rw function.funext_iff,
  rw function.funext_iff,
  rw function.funext_iff,
  rw function.funext_iff,
  cases (f tt tt).dichotomy;
  cases (f tt ff).dichotomy;
  cases (f ff tt).dichotomy;
  cases (f ff ff).dichotomy,

  {
    sorry },
  repeat {sorry},

--  exact dec_trivial,
end

-- now let's see forall and exists
variables (Ω : Type) (X Y : set Ω)

example : ¬ (∃ a, X a) ↔ ∀ b, ¬ (X b) :=
begin
  split,
  { intro h,
    intros b hb,
    apply h,
    use b,
    assumption },
  { intro h,
    intro h2,
    cases h2 with a ha,
    apply h a,
    assumption },
end
example : ¬ (∀ a, X a) ↔ ∃ b, ¬ (X b) :=
begin
  split,
  { -- classical
    intro h,
    classical,
    by_contra hnX,
    apply h,
    intro a,
    by_contra hXa,
    apply hnX,
    use a },
  { intro h,
    cases h with b hb,
    intro h,
    apply hb,
    apply h }
end

example : ¬ (∃ a, X a) ↔ ∀ b, ¬ (X b) :=
begin
  split,
  { intro h,
    intros b hb,
    apply h,
    use b,
    assumption },
  { intro h,
    intro h2,
    cases h2 with a ha,
    apply h a,
    assumption },
end


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.polynomial.expand
import linear_algebra.finite_dimensional
import linear_algebra.matrix.charpoly.linear_map
import ring_theory.adjoin.fg
import ring_theory.finite_type
import ring_theory.polynomial.scale_roots
import ring_theory.polynomial.tower
import ring_theory.tensor_product

/-!
# 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_locale classical
open_locale big_operators polynomial
open polynomial submodule

section ring
variables {R S A : Type*}
variables [comm_ring 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 ring_hom.is_integral_elem (f : R →+* A) (x : A) :=
∃ p : R[X], monic p ∧ eval₂ f x p = 0

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

variables [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 is_integral (x : A) : Prop :=
(algebra_map R A).is_integral_elem x

variable (A)

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

variables {R A}

lemma ring_hom.is_integral_map {x : R} : f.is_integral_elem (f x) :=
⟨X - C x, monic_X_sub_C _, by simp⟩

theorem is_integral_algebra_map {x : R} : is_integral R (algebra_map R A x) :=
(algebra_map R A).is_integral_map

theorem is_integral_of_noetherian (H : is_noetherian R A) (x : A) :
  is_integral R x :=
begin
  let leval : (R[X] →ₗ[R] A) := (aeval x).to_linear_map,
  let D : ℕ → submodule R A := λ n, (degree_le R n).map leval,
  let M := well_founded.min (is_noetherian_iff_well_founded.1 H)
    (set.range D) ⟨_, ⟨0, rfl⟩⟩,
  have HM : M ∈ set.range D := well_founded.min_mem _ _ _,
  cases HM with N HN,
  have HM : ¬M < D (N+1) := well_founded.not_lt_min
    (is_noetherian_iff_well_founded.1 H) (set.range D) _ ⟨N+1, rfl⟩,
  rw ← HN at HM,
  have HN2 : D (N+1) ≤ D N := classical.by_contradiction (λ H, HM
    (lt_of_le_not_le (map_mono (degree_le_mono
      (with_bot.coe_le_coe.2 (nat.le_succ N)))) H)),
  have HN3 : leval (X^(N+1)) ∈ D N,
  { exact 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 [linear_map.map_sub, hpe, sub_self]
end

theorem is_integral_of_submodule_noetherian (S : subalgebra R A)
  (H : is_noetherian R S.to_submodule) (x : A) (hx : x ∈ S) :
  is_integral R x :=
begin
  suffices : is_integral R (show S, from ⟨x, hx⟩),
  { 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 (λ n hn, _),
    rw [S.val.map_mul, S.val.map_pow, S.val.commutes, S.val_apply, subtype.coe_mk], },
  refine is_integral_of_noetherian H ⟨x, hx⟩
end

end ring

section
variables {R A B S : Type*}
variables [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring S]
variables [algebra R A] [algebra R B] (f : R →+* S)

lemma map_is_integral {B C F : Type*} [ring B] [ring C] [algebra R B] [algebra A B]
  [algebra R C] [is_scalar_tower R A B] [algebra A C] [is_scalar_tower R A C] {b : B}
  [alg_hom_class F A B C] (f : F) (hb : is_integral R b) : is_integral R (f b) :=
begin
  obtain ⟨P, hP⟩ := hb,
  refine ⟨P, hP.1, _⟩,
  rw [← aeval_def, show (aeval (f b)) P = (aeval (f b)) (P.map (algebra_map R A)), by simp,
    aeval_alg_hom_apply, aeval_map_algebra_map, aeval_def, hP.2, _root_.map_zero]
end

lemma is_integral_map_of_comp_eq_of_is_integral {R S T U : Type*} [comm_ring R] [comm_ring S]
  [comm_ring T] [comm_ring U] [algebra R S] [algebra T U] (φ : R →+* T) (ψ : S →+* U)
  (h : (algebra_map T U).comp φ = ψ.comp (algebra_map R S)) {a : S} (ha : is_integral R a) :
  is_integral T (ψ a) :=
begin
  rw [is_integral, ring_hom.is_integral_elem] 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, ring_hom.map_zero],
end

theorem is_integral_alg_hom_iff {A B : Type*} [ring A] [ring B] [algebra R A] [algebra R B]
  (f : A →ₐ[R] B) (hf : function.injective f) {x : A} : is_integral R (f x) ↔ is_integral R x :=
begin
  refine ⟨_, map_is_integral f⟩,
  rintros ⟨p, hp, hx⟩,
  use [p, hp],
  rwa [← f.comp_algebra_map, ← alg_hom.coe_to_ring_hom, ← polynomial.hom_eval₂,
    alg_hom.coe_to_ring_hom, map_eq_zero_iff f hf] at hx
end

@[simp]
theorem is_integral_alg_equiv {A B : Type*} [ring A] [ring B] [algebra R A] [algebra R B]
  (f : A ≃ₐ[R] B) {x : A} : is_integral R (f x) ↔ is_integral R x :=
⟨λ h, by simpa using map_is_integral f.symm.to_alg_hom h, map_is_integral f.to_alg_hom⟩

theorem is_integral_of_is_scalar_tower [algebra A B] [is_scalar_tower R A B]
  {x : B} (hx : is_integral R x) : is_integral A x :=
let ⟨p, hp, hpx⟩ := hx in
⟨p.map $ algebra_map R A, hp.map _,
  by rw [← aeval_def, aeval_map_algebra_map, aeval_def, hpx]⟩

lemma map_is_integral_int {B C F : Type*} [ring B] [ring C] {b : B}
  [ring_hom_class F B C] (f : F) (hb : is_integral ℤ b) :
  is_integral ℤ (f b) :=
map_is_integral (f : B →+* C).to_int_alg_hom hb

theorem is_integral_of_subring {x : A} (T : subring R)
  (hx : is_integral T x) : is_integral R x :=
is_integral_of_is_scalar_tower hx

lemma is_integral.algebra_map [algebra A B] [is_scalar_tower R A B]
  {x : A} (h : is_integral R x) :
  is_integral R (algebra_map A B x) :=
begin
  rcases h with ⟨f, hf, hx⟩,
  use [f, hf],
  rw [is_scalar_tower.algebra_map_eq R A B, ← hom_eval₂, hx, ring_hom.map_zero]
end

lemma is_integral_algebra_map_iff [algebra A B] [is_scalar_tower R A B]
  {x : A} (hAB : function.injective (algebra_map A B)) :
  is_integral R (algebra_map A B x) ↔ is_integral R x :=
is_integral_alg_hom_iff (is_scalar_tower.to_alg_hom R A B) hAB

theorem is_integral_iff_is_integral_closure_finite {r : A} :
  is_integral R r ↔ ∃ s : set R, s.finite ∧ is_integral (subring.closure s) r :=
begin
  split; intro hr,
  { rcases hr with ⟨p, hmp, hpr⟩,
    refine ⟨_, finset.finite_to_set _, 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 is_integral_of_subring _ hsr
end

theorem fg_adjoin_singleton_of_integral (x : A) (hx : is_integral R x) :
  (algebra.adjoin R ({x} : set A)).to_submodule.fg :=
begin
  rcases hx with ⟨f, hfm, hfx⟩,
  existsi finset.image ((^) x) (finset.range (nat_degree f + 1)),
  apply le_antisymm,
  { rw span_le, intros 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 },
  intros 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 [alg_hom.map_add, alg_hom.map_mul, hfx, zero_mul, add_zero],
  have : degree (p %ₘ f) ≤ degree f := degree_mod_by_monic_le p hfm,
  generalize_hyp : p %ₘ f = q at this ⊢,
  rw [← sum_C_mul_X_pow_eq q, aeval_def, eval₂_sum, sum_def],
  refine sum_mem (λ 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 (λ 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 (with_bot.coe_lt_coe.2 hk)
end

theorem fg_adjoin_of_finite {s : set A} (hfs : s.finite)
  (his : ∀ x ∈ s, is_integral R x) : (algebra.adjoin R s).to_submodule.fg :=
set.finite.induction_on hfs (λ _, ⟨{1}, submodule.ext $ λ x,
  by { erw [algebra.adjoin_empty, finset.coe_singleton, ← one_eq_span, one_eq_range,
            linear_map.mem_range, algebra.mem_bot], refl }⟩)
(λ a s has hs ih his, by rw [← set.union_singleton, algebra.adjoin_union_coe_submodule]; exact
  fg.mul (ih $ λ i hi, his i $ set.mem_insert_of_mem a hi)
    (fg_adjoin_singleton_of_integral _ $ his a $ set.mem_insert a s)) his

lemma is_noetherian_adjoin_finset [is_noetherian_ring R] (s : finset A)
  (hs : ∀ x ∈ s, is_integral R x) :
  is_noetherian R (algebra.adjoin R (↑s : set A)) :=
is_noetherian_of_fg_of_noetherian _ (fg_adjoin_of_finite s.finite_to_set hs)

/-- 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 is_integral_of_mem_of_fg (S : subalgebra R A)
  (HS : S.to_submodule.fg) (x : A) (hx : x ∈ S) : is_integral R x :=
begin
  -- 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,
  { 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 := λ 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 :=
    λ 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 is_integral_of_subring S₀ _,
  letI : comm_ring S₀ := subring_class.to_comm_ring S₀,
  letI : algebra S₀ A := algebra.of_subring 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),
  { rw span_mul_span, refine span_le.2 (λ 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 (λ 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' := λ p q hp hq, this $ mul_mem_mul hp hq,
    zero_mem' := (span S₀ (insert 1 ↑y : set A)).zero_mem,
    add_mem' := λ _ _, (span S₀ (insert 1 ↑y : set A)).add_mem,
    neg_mem' := λ _, (span S₀ (insert 1 ↑y : set A)).neg_mem },
  have : S₁ = subalgebra.to_subring (algebra.adjoin S₀ (↑y : set A)),
  { ext z,
    suffices : z ∈ span ↥S₀ (insert 1 ↑y : set A) ↔
      z ∈ (algebra.adjoin ↥S₀ (y : set A)).to_submodule,
    { simpa },
    split; intro hz,
    { exact (span_le.2
        (set.insert_subset.2 ⟨(algebra.adjoin S₀ ↑y).one_mem, algebra.subset_adjoin⟩)) hz },
    { rw [subalgebra.mem_to_submodule, algebra.mem_adjoin_iff] at hz,
      suffices : subring.closure (set.range ⇑(algebra_map ↥S₀ A) ∪ ↑y) ≤ S₁,
      { exact this hz },
      refine subring.closure_le.2 (set.union_subset _ (λ t ht, subset_span $ or.inr ht)),
      rw set.range_subset_iff,
      intro y,
      rw algebra.algebra_map_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 : is_noetherian_ring ↥S₀ := is_noetherian_subring_closure _ (finset.finite_to_set _),
  refine is_integral_of_submodule_noetherian (algebra.adjoin S₀ ↑y)
    (is_noetherian_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 _ (λ 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) _
end

lemma module.End.is_integral {M : Type*} [add_comm_group M] [module R M] [module.finite R M] :
  algebra.is_integral R (module.End R M) :=
linear_map.exists_monic_and_aeval_eq_zero R

/-- 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. -/
lemma is_integral_of_smul_mem_submodule {M : Type*} [add_comm_group M] [module R M]
  [module A M] [is_scalar_tower R A M] [no_zero_smul_divisors A M]
  (N : submodule R M) (hN : N ≠ ⊥) (hN' : N.fg) (x : A)
    (hx : ∀ n ∈ N, x • n ∈ N) : is_integral R x :=
begin
  let A' : subalgebra R A :=
  { carrier := { x | ∀ n ∈ N, x • n ∈ N },
    mul_mem' := λ a b ha hb n hn, smul_smul a b n ▸ ha _ (hb _ hn),
    one_mem' := λ n hn, (one_smul A n).symm ▸ hn,
    add_mem' := λ a b ha hb n hn, (add_smul a b n).symm ▸ N.add_mem (ha _ hn) (hb _ hn),
    zero_mem' := λ n hn, (zero_smul A n).symm ▸ N.zero_mem,
    algebra_map_mem' := λ r n hn, (algebra_map_smul A r n).symm ▸ N.smul_mem r hn },
  let f : A' →ₐ[R] module.End R N := alg_hom.of_linear_map
    { to_fun := λ x, (distrib_mul_action.to_linear_map R M x).restrict x.prop,
      map_add' := λ x y, linear_map.ext $ λ n, subtype.ext $ add_smul x y n,
      map_smul' := λ r s, linear_map.ext $ λ n, subtype.ext $ smul_assoc r s n }
      (linear_map.ext $ λ n, subtype.ext $ one_smul _ _)
      (λ x y, linear_map.ext $ λ n, subtype.ext $ mul_smul x y n),
  obtain ⟨a, ha₁, ha₂⟩ : ∃ a ∈ N, a ≠ (0 : M),
  { by_contra h', push_neg at h', apply hN, rwa eq_bot_iff },
  have : function.injective f,
  { show function.injective f.to_linear_map,
    rw [← linear_map.ker_eq_bot, eq_bot_iff],
    intros s hs,
    have : s.1 • a = 0 := congr_arg subtype.val (linear_map.congr_fun hs ⟨a, ha₁⟩),
    exact subtype.ext ((eq_zero_or_eq_zero_of_smul_eq_zero this).resolve_right ha₂) },
  show is_integral R (A'.val ⟨x, hx⟩),
  rw [is_integral_alg_hom_iff A'.val subtype.val_injective,
    ← is_integral_alg_hom_iff f this],
  haveI : module.finite R N := by rwa [module.finite_def, submodule.fg_top],
  apply module.End.is_integral,
end

variables {f}

lemma ring_hom.finite.to_is_integral (h : f.finite) : f.is_integral :=
by { letI := f.to_algebra, exact λ x, is_integral_of_mem_of_fg ⊤ h.1 _ trivial }

alias ring_hom.finite.to_is_integral ← ring_hom.is_integral.of_finite

lemma ring_hom.is_integral.to_finite (h : f.is_integral) (h' : f.finite_type) : f.finite :=
begin
  letI := f.to_algebra,
  unfreezingI { obtain ⟨s, hs⟩ := h' },
  constructor,
  change (⊤ : subalgebra R S).to_submodule.fg,
  rw ← hs,
  exact fg_adjoin_of_finite (set.to_finite _) (λ x _, h x)
end

alias ring_hom.is_integral.to_finite ← ring_hom.finite.of_is_integral_of_finite_type

/-- finite = integral + finite type -/
lemma ring_hom.finite_iff_is_integral_and_finite_type :
  f.finite ↔ f.is_integral ∧ f.finite_type :=
⟨λ h, ⟨h.to_is_integral, h.to_finite_type⟩, λ ⟨h, h'⟩, h.to_finite h'⟩

lemma algebra.is_integral.finite (h : algebra.is_integral R A) [h' : algebra.finite_type R A] :
  module.finite R A :=
begin
  have := h.to_finite
    (by { delta ring_hom.finite_type, convert h', ext, exact (algebra.smul_def _ _).symm }),
  delta ring_hom.finite at this, convert this, ext, exact algebra.smul_def _ _,
end

lemma algebra.is_integral.of_finite [h : module.finite R A] : algebra.is_integral R A :=
begin
  apply ring_hom.finite.to_is_integral,
  delta ring_hom.finite, convert h, ext, exact (algebra.smul_def _ _).symm,
end

/-- finite = integral + finite type -/
lemma algebra.finite_iff_is_integral_and_finite_type :
  module.finite R A ↔ algebra.is_integral R A ∧ algebra.finite_type R A :=
⟨λ h, by exactI ⟨algebra.is_integral.of_finite, infer_instance⟩, λ ⟨h, h'⟩, by exactI h.finite⟩

variables (f)

lemma ring_hom.is_integral_of_mem_closure {x y z : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y)
  (hz : z ∈ subring.closure ({x, y} : set S)) :
  f.is_integral_elem z :=
begin
  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 is_integral_of_mem_of_fg (algebra.adjoin R {x, y}) this z
    (algebra.mem_adjoin_iff.2 $ subring.closure_mono (set.subset_union_right _ _) hz),
end

theorem is_integral_of_mem_closure {x y z : A}
  (hx : is_integral R x) (hy : is_integral R y)
  (hz : z ∈ subring.closure ({x, y} : set A)) :
  is_integral R z :=
(algebra_map R A).is_integral_of_mem_closure hx hy hz

lemma ring_hom.is_integral_zero : f.is_integral_elem 0 :=
f.map_zero ▸ f.is_integral_map

theorem is_integral_zero : is_integral R (0:A) :=
(algebra_map R A).is_integral_zero

lemma ring_hom.is_integral_one : f.is_integral_elem 1 :=
f.map_one ▸ f.is_integral_map

theorem is_integral_one : is_integral R (1:A) :=
(algebra_map R A).is_integral_one

lemma ring_hom.is_integral_add {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) :
  f.is_integral_elem (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))

theorem is_integral_add {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) :
  is_integral R (x + y) :=
(algebra_map R A).is_integral_add hx hy

lemma ring_hom.is_integral_neg {x : S}
  (hx : f.is_integral_elem x) : f.is_integral_elem (-x) :=
f.is_integral_of_mem_closure hx hx (subring.neg_mem _ (subring.subset_closure (or.inl rfl)))

theorem is_integral_neg {x : A}
  (hx : is_integral R x) : is_integral R (-x) :=
(algebra_map R A).is_integral_neg hx

lemma ring_hom.is_integral_sub {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) : f.is_integral_elem (x - y) :=
by simpa only [sub_eq_add_neg] using f.is_integral_add hx (f.is_integral_neg hy)

theorem is_integral_sub {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) : is_integral R (x - y) :=
(algebra_map R A).is_integral_sub hx hy

lemma ring_hom.is_integral_mul {x y : S}
  (hx : f.is_integral_elem x) (hy : f.is_integral_elem y) : f.is_integral_elem (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)))

theorem is_integral_mul {x y : A}
  (hx : is_integral R x) (hy : is_integral R y) : is_integral R (x * y) :=
(algebra_map R A).is_integral_mul hx hy

lemma is_integral_smul [algebra S A] [algebra R S] [is_scalar_tower R S A] {x : A} (r : R)
  (hx : is_integral S x) : is_integral S (r • x) :=
begin
  rw [algebra.smul_def, is_scalar_tower.algebra_map_apply R S A],
  exact is_integral_mul is_integral_algebra_map hx,
end

lemma is_integral_of_pow {x : A} {n : ℕ} (hn : 0 < n) (hx : is_integral R $ x ^ n) :
  is_integral R x :=
begin
  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]⟩
end

variables (R A)

/-- The integral closure of R in an R-algebra A. -/
def integral_closure : subalgebra R A :=
{ carrier := { r | is_integral R r },
  zero_mem' := is_integral_zero,
  one_mem' := is_integral_one,
  add_mem' := λ _ _, is_integral_add,
  mul_mem' := λ _ _, is_integral_mul,
  algebra_map_mem' := λ x, is_integral_algebra_map }

theorem mem_integral_closure_iff_mem_fg {r : A} :
  r ∈ integral_closure R A ↔ ∃ M : subalgebra R A, M.to_submodule.fg ∧ r ∈ M :=
⟨λ hr, ⟨algebra.adjoin R {r}, fg_adjoin_singleton_of_integral _ hr, algebra.subset_adjoin rfl⟩,
λ ⟨M, Hf, hrM⟩, is_integral_of_mem_of_fg M Hf _ hrM⟩

variables {R} {A}

lemma adjoin_le_integral_closure {x : A} (hx : is_integral R x) :
  algebra.adjoin R {x} ≤ integral_closure R A :=
begin
  rw [algebra.adjoin_le_iff],
  simp only [set_like.mem_coe, set.singleton_subset_iff],
  exact hx
end

lemma le_integral_closure_iff_is_integral {S : subalgebra R A} :
  S ≤ integral_closure R A ↔ algebra.is_integral R S :=
set_like.forall.symm.trans (forall_congr (λ x, show is_integral R (algebra_map S A x)
  ↔ is_integral R x, from is_integral_algebra_map_iff subtype.coe_injective))

lemma is_integral_sup {S T : subalgebra R A} :
  algebra.is_integral R ↥(S ⊔ T) ↔ algebra.is_integral R S ∧ algebra.is_integral R T :=
by simp only [←le_integral_closure_iff_is_integral, sup_le_iff]

/-- Mapping an integral closure along an `alg_equiv` gives the integral closure. -/
lemma integral_closure_map_alg_equiv (f : A ≃ₐ[R] B) :
  (integral_closure R A).map (f : A →ₐ[R] B) = integral_closure R B :=
begin
  ext y,
  rw subalgebra.mem_map,
  split,
  { rintros ⟨x, hx, rfl⟩,
    exact map_is_integral f hx },
  { intro hy,
    use [f.symm y, map_is_integral (f.symm : B →ₐ[R] A) hy],
    simp }
end

lemma integral_closure.is_integral (x : integral_closure R A) : is_integral R x :=
let ⟨p, hpm, hpx⟩ := x.2 in ⟨p, hpm, subtype.eq $
by rwa [← aeval_def, subtype.val_eq_coe, ← subalgebra.val_apply, aeval_alg_hom_apply] at hpx⟩

lemma ring_hom.is_integral_of_is_integral_mul_unit (x y : S) (r : R) (hr : f r * y = 1)
  (hx : f.is_integral_elem (x * y)) : f.is_integral_elem x :=
begin
  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],
end

theorem is_integral_of_is_integral_mul_unit {x y : A} {r : R} (hr : algebra_map R A r * y = 1)
  (hx : is_integral R (x * y)) : is_integral R x :=
(algebra_map R A).is_integral_of_is_integral_mul_unit x y r hr hx

/-- Generalization of `is_integral_of_mem_closure` bootstrapped up from that lemma -/
lemma is_integral_of_mem_closure' (G : set A) (hG : ∀ x ∈ G, is_integral R x) :
  ∀ x ∈ (subring.closure G), is_integral R x :=
λ x hx, subring.closure_induction hx hG is_integral_zero is_integral_one
  (λ _ _, is_integral_add) (λ _, is_integral_neg) (λ _ _, is_integral_mul)

lemma is_integral_of_mem_closure'' {S : Type*} [comm_ring S] {f : R →+* S} (G : set S)
  (hG : ∀ x ∈ G, f.is_integral_elem x) : ∀ x ∈ (subring.closure G), f.is_integral_elem x :=
λ x hx, @is_integral_of_mem_closure' R S _ _ f.to_algebra G hG x hx

lemma is_integral.pow {x : A} (h : is_integral R x) (n : ℕ) : is_integral R (x ^ n) :=
(integral_closure R A).pow_mem h n

lemma is_integral.nsmul {x : A} (h : is_integral R x) (n : ℕ) : is_integral R (n • x) :=
(integral_closure R A).nsmul_mem h n

lemma is_integral.zsmul {x : A} (h : is_integral R x) (n : ℤ) : is_integral R (n • x) :=
(integral_closure R A).zsmul_mem h n

lemma is_integral.multiset_prod {s : multiset A} (h : ∀ x ∈ s, is_integral R x) :
  is_integral R s.prod :=
(integral_closure R A).multiset_prod_mem h

lemma is_integral.multiset_sum {s : multiset A} (h : ∀ x ∈ s, is_integral R x) :
  is_integral R s.sum :=
(integral_closure R A).multiset_sum_mem h

lemma is_integral.prod {α : Type*} {s : finset α} (f : α → A) (h : ∀ x ∈ s, is_integral R (f x)) :
  is_integral R (∏ x in s, f x) :=
(integral_closure R A).prod_mem h

lemma is_integral.sum {α : Type*} {s : finset α} (f : α → A) (h : ∀ x ∈ s, is_integral R (f x)) :
  is_integral R (∑ x in s, f x) :=
(integral_closure R A).sum_mem h

lemma is_integral.det {n : Type*} [fintype n] [decidable_eq n] {M : matrix n n A}
  (h : ∀ i j, is_integral R (M i j)) :
  is_integral R M.det :=
begin
  rw [matrix.det_apply],
  exact is_integral.sum _ (λ σ hσ, is_integral.zsmul (is_integral.prod _ (λ i hi, h _ _)) _)
end

@[simp] lemma is_integral.pow_iff {x : A} {n : ℕ} (hn : 0 < n) :
  is_integral R (x ^ n) ↔ is_integral R x :=
⟨is_integral_of_pow hn, λ hx, is_integral.pow hx n⟩

open_locale tensor_product

lemma is_integral.tmul (x : A) {y : B} (h : is_integral R y) : is_integral A (x ⊗ₜ[R] y) :=
begin
  obtain ⟨p, hp, hp'⟩ := h,
  refine ⟨(p.map (algebra_map R A)).scale_roots x, _, _⟩,
  { rw polynomial.monic_scale_roots_iff, exact hp.map _ },
  convert @polynomial.scale_roots_eval₂_mul (A ⊗[R] B) A _ _ _
    algebra.tensor_product.include_left.to_ring_hom (1 ⊗ₜ y) x using 2,
  { simp only [alg_hom.to_ring_hom_eq_coe, alg_hom.coe_to_ring_hom, mul_one, one_mul,
      algebra.tensor_product.include_left_apply, algebra.tensor_product.tmul_mul_tmul] },
  convert (mul_zero _).symm,
  rw [polynomial.eval₂_map, algebra.tensor_product.include_left_comp_algebra_map,
    ← 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],
end

section

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

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

lemma normalize_scale_roots_coeff_mul_leading_coeff_pow (i : ℕ) (hp : 1 ≤ nat_degree p) :
  (normalize_scale_roots p).coeff i * p.leading_coeff ^ i =
    p.coeff i * p.leading_coeff ^ (p.nat_degree - 1) :=
begin
  simp only [normalize_scale_roots, finset_sum_coeff, coeff_monomial, finset.sum_ite_eq', one_mul,
    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₂⟩, },
end

lemma leading_coeff_smul_normalize_scale_roots (p : R[X]) :
  p.leading_coeff • normalize_scale_roots p = scale_roots p p.leading_coeff :=
begin
  ext,
  simp only [coeff_scale_roots, normalize_scale_roots, 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₂) },
end

lemma normalize_scale_roots_support :
  (normalize_scale_roots p).support ≤ p.support :=
begin
  intro x,
  contrapose,
  simp only [not_mem_support_iff, normalize_scale_roots, finset_sum_coeff, coeff_monomial,
    finset.sum_ite_eq', mem_support_iff, ne.def, not_not, ite_eq_right_iff],
  intros h₁ h₂,
  exact (h₂ h₁).rec _,
end

lemma normalize_scale_roots_degree :
  (normalize_scale_roots p).degree = p.degree :=
begin
  apply le_antisymm,
  { exact finset.sup_mono (normalize_scale_roots_support p) },
  { rw [← degree_scale_roots, ← leading_coeff_smul_normalize_scale_roots],
    exact degree_smul_le _ _ }
end

lemma normalize_scale_roots_eval₂_leading_coeff_mul (h : 1 ≤ p.nat_degree) (f : R →+* S) (x : S) :
  (normalize_scale_roots p).eval₂ f (f p.leading_coeff * x) =
    f p.leading_coeff ^ (p.nat_degree - 1) * (p.eval₂ f x) :=
begin
  rw [eval₂_eq_sum_range, eval₂_eq_sum_range, finset.mul_sum],
  apply finset.sum_congr,
  { rw nat_degree_eq_of_degree_eq (normalize_scale_roots_degree p) },
  intros n hn,
  rw [mul_pow, ← mul_assoc, ← f.map_pow, ← f.map_mul,
    normalize_scale_roots_coeff_mul_leading_coeff_pow _ _ h, f.map_mul, f.map_pow],
  ring,
end

lemma normalize_scale_roots_monic (h : p ≠ 0) : (normalize_scale_roots p).monic :=
begin
  delta monic leading_coeff,
  rw nat_degree_eq_of_degree_eq (normalize_scale_roots_degree p),
  suffices : p = 0 → (0 : R) = 1,
  { simpa [normalize_scale_roots, coeff_monomial] },
  exact λ h', (h h').rec _,
end

/-- Given a `p : R[X]` and a `x : S` such that `p.eval₂ f x = 0`,
`f p.leading_coeff * x` is integral. -/
lemma ring_hom.is_integral_elem_leading_coeff_mul (h : p.eval₂ f x = 0) :
  f.is_integral_elem (f p.leading_coeff * x) :=
begin
  by_cases h' : 1 ≤ p.nat_degree,
  { use normalize_scale_roots p,
    have : p ≠ 0 := λ h'', by { rw [h'', nat_degree_zero] at h', exact nat.not_succ_le_zero 0 h' },
    use normalize_scale_roots_monic p this,
    rw [normalize_scale_roots_eval₂_leading_coeff_mul p h' f x, h, mul_zero] },
  { by_cases hp : p.map f = 0,
    { apply_fun (λ q, coeff q p.nat_degree) at hp,
      rw [coeff_map, coeff_zero, coeff_nat_degree] at hp,
      rw [hp, zero_mul],
      exact f.is_integral_zero },
    { rw [nat.one_le_iff_ne_zero, not_not] at h',
      rw [eq_C_of_nat_degree_eq_zero h', eval₂_C] at h,
      suffices : p.map f = 0,
      { exact (hp this).rec _ },
      rw [eq_C_of_nat_degree_eq_zero h', map_C, h, C_eq_zero] } }
end

/-- Given a `p : R[X]` and a root `x : S`,
then `p.leading_coeff • x : S` is integral over `R`. -/
lemma is_integral_leading_coeff_smul [algebra R S] (h : aeval x p = 0) :
  is_integral R (p.leading_coeff • x) :=
begin
  rw aeval_def at h,
  rw algebra.smul_def,
  exact (algebra_map R S).is_integral_elem_leading_coeff_mul p x h,
end

end

end

section is_integral_closure

/-- `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 is_integral_closure (A R B : Type*) [comm_ring R] [comm_semiring A] [comm_ring B]
  [algebra R B] [algebra A B] : Prop :=
(algebra_map_injective [] : function.injective (algebra_map A B))
(is_integral_iff : ∀ {x : B}, is_integral R x ↔ ∃ y, algebra_map A B y = x)

instance integral_closure.is_integral_closure (R A : Type*) [comm_ring R] [comm_ring A]
  [algebra R A] : is_integral_closure (integral_closure R A) R A :=
⟨subtype.coe_injective, λ x, ⟨λ h, ⟨⟨x, h⟩, rfl⟩, by { rintro ⟨⟨_, h⟩, rfl⟩, exact h }⟩⟩

namespace is_integral_closure

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

variables (R) {A} (B)
protected theorem is_integral [algebra R A] [is_scalar_tower R A B] (x : A) : is_integral R x :=
(is_integral_algebra_map_iff (algebra_map_injective A R B)).mp $
show is_integral R (algebra_map A B x), from is_integral_iff.mpr ⟨x, rfl⟩

theorem is_integral_algebra [algebra R A] [is_scalar_tower R A B] :
  algebra.is_integral R A :=
λ x, is_integral_closure.is_integral R B x

theorem no_zero_smul_divisors [algebra R A] [is_scalar_tower R A B] [no_zero_smul_divisors R B] :
  no_zero_smul_divisors R A :=
begin
  refine function.injective.no_zero_smul_divisors
      _ (is_integral_closure.algebra_map_injective A R B) (map_zero _) (λ _ _, _),
  simp only [algebra.algebra_map_eq_smul_one, is_scalar_tower.smul_assoc],
 end

variables {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 : is_integral R x) : A :=
classical.some (is_integral_iff.mp hx)

@[simp] lemma algebra_map_mk' (x : B) (hx : is_integral R x) :
  algebra_map A B (mk' A x hx) = x :=
classical.some_spec (is_integral_iff.mp hx)

@[simp] lemma mk'_one (h : is_integral R (1 : B) := is_integral_one) :
  mk' A 1 h = 1 :=
algebra_map_injective A R B $ by rw [algebra_map_mk', ring_hom.map_one]

@[simp] lemma mk'_zero (h : is_integral R (0 : B) := is_integral_zero) :
  mk' A 0 h = 0 :=
algebra_map_injective A R B $ by rw [algebra_map_mk', ring_hom.map_zero]

@[simp]

@[simp] lemma mk'_mul (x y : B) (hx : is_integral R x) (hy : is_integral R y) :
  mk' A (x * y) (is_integral_mul hx hy) = mk' A x hx * mk' A y hy :=
algebra_map_injective A R B $ by simp only [algebra_map_mk', ring_hom.map_mul]

@[simp] lemma mk'_algebra_map [algebra R A] [is_scalar_tower R A B] (x : R)
  (h : is_integral R (algebra_map R B x) := is_integral_algebra_map) :
  is_integral_closure.mk' A (algebra_map R B x) h = algebra_map R A x :=
algebra_map_injective A R B $ by rw [algebra_map_mk', ← is_scalar_tower.algebra_map_apply]

section lift

variables {R} (A B) {S : Type*} [comm_ring S] [algebra R S] [algebra S B] [is_scalar_tower R S B]
variables [algebra R A] [is_scalar_tower R A B] (h : algebra.is_integral 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 :=
{ to_fun := λ x, mk' A (algebra_map S B x) (is_integral.algebra_map (h x)),
  map_one' := by simp only [ring_hom.map_one, mk'_one],
  map_zero' := by simp only [ring_hom.map_zero, mk'_zero],
  map_add' := λ x y, by simp_rw [← mk'_add, ring_hom.map_add],
  map_mul' := λ x y, by simp_rw [← mk'_mul, ring_hom.map_mul],
  commutes' := λ x, by simp_rw [← is_scalar_tower.algebra_map_apply, mk'_algebra_map] }

@[simp] lemma algebra_map_lift (x : S) : algebra_map A B (lift A B h x) = algebra_map S B x :=
algebra_map_mk' _ _ _

end lift

section equiv

variables (R A B) (A' : Type*) [comm_ring A'] [algebra A' B] [is_integral_closure A' R B]
variables [algebra R A] [algebra R A'] [is_scalar_tower R A B] [is_scalar_tower R A' B]

/-- Integral closures are all isomorphic to each other. -/
noncomputable def equiv : A ≃ₐ[R] A' :=
alg_equiv.of_alg_hom (lift _ B (is_integral_algebra R B)) (lift _ B (is_integral_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 })

@[simp] lemma algebra_map_equiv (x : A) : algebra_map A' B (equiv R A B A' x) = algebra_map A B x :=
algebra_map_lift _ _ _ _

end equiv

end is_integral_closure

end is_integral_closure

section algebra
open algebra
variables {R A B S T : Type*}
variables [comm_ring R] [comm_ring A] [comm_ring B] [comm_ring S] [comm_ring T]
variables [algebra A B] [algebra R B] (f : R →+* S) (g : S →+* T)

lemma is_integral_trans_aux (x : B) {p : A[X]} (pmonic : monic p) (hp : aeval x p = 0) :
  is_integral (adjoin R (↑(p.map $ algebra_map A B).frange : set B)) x :=
begin
  generalize hS : (↑(p.map $ algebra_map A B).frange : set B) = S,
  have coeffs_mem : ∀ i, (p.map $ algebra_map A B).coeff i ∈ adjoin R S,
  { intro i, by_cases hi : (p.map $ algebra_map 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 (algebra_map (adjoin R S) B) =
      (p.map $ algebra_map A B),
  { rw ← set.mem_range, exact (polynomial.mem_map_range _).2 (λ i, ⟨⟨_, coeffs_mem i⟩, rfl⟩) },
  use q,
  split,
  { suffices h : (q.map (algebra_map (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; symmetry; apply eval_map },
end

variables [algebra R A] [is_scalar_tower 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.-/
lemma is_integral_trans (A_int : algebra.is_integral R A) (x : B) (hx : is_integral A x) :
  is_integral R x :=
begin
  rcases hx with ⟨p, pmonic, hp⟩,
  let S : set B := ↑(p.map $ algebra_map A B).frange,
  refine is_integral_of_mem_of_fg (adjoin R (S ∪ {x})) _ _ (subset_adjoin $ or.inr rfl),
  refine fg_trans (fg_adjoin_of_finite (finset.finite_to_set _) (λ x hx, _)) _,
  { rw [finset.mem_coe, frange, finset.mem_image] at hx,
    rcases hx with ⟨i, _, rfl⟩,
    rw coeff_map,
    exact map_is_integral (is_scalar_tower.to_alg_hom R A B) (A_int _) },
  { apply fg_adjoin_singleton_of_integral,
    exact is_integral_trans_aux _ pmonic hp }
end

/-- 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.-/
lemma algebra.is_integral_trans (hA : algebra.is_integral R A) (hB : algebra.is_integral A B) :
  algebra.is_integral R B :=
λ x, is_integral_trans hA x (hB x)

lemma ring_hom.is_integral_trans (hf : f.is_integral) (hg : g.is_integral) :
  (g.comp f).is_integral :=
@algebra.is_integral_trans R S T _ _ _ g.to_algebra (g.comp f).to_algebra f.to_algebra
  (@is_scalar_tower.of_algebra_map_eq R S T _ _ _ f.to_algebra g.to_algebra (g.comp f).to_algebra
  (ring_hom.comp_apply g f)) hf hg

lemma ring_hom.is_integral_of_surjective (hf : function.surjective f) : f.is_integral :=
λ x, (hf x).rec_on (λ y hy, (hy ▸ f.is_integral_map : f.is_integral_elem x))

lemma is_integral_of_surjective (h : function.surjective (algebra_map R A)) :
  algebra.is_integral R A := (algebra_map R A).is_integral_of_surjective h

/-- 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` -/
lemma is_integral_tower_bot_of_is_integral (H : function.injective (algebra_map A B))
  {x : A} (h : is_integral R (algebra_map A B x)) : is_integral R x :=
begin
  rcases h with ⟨p, ⟨hp, hp'⟩⟩,
  refine ⟨p, ⟨hp, _⟩⟩,
  rw [is_scalar_tower.algebra_map_eq R A B, ← eval₂_map,
      eval₂_hom, ← ring_hom.map_zero (algebra_map A B)] at hp',
  rw [eval₂_eq_eval_map],
  exact H hp',
end

lemma ring_hom.is_integral_tower_bot_of_is_integral (hg : function.injective g)
  (hfg : (g.comp f).is_integral) : f.is_integral :=
λ x,
  @is_integral_tower_bot_of_is_integral R S T _ _ _ g.to_algebra (g.comp f).to_algebra f.to_algebra
  (@is_scalar_tower.of_algebra_map_eq R S T _ _ _ f.to_algebra g.to_algebra (g.comp f).to_algebra
  (ring_hom.comp_apply g f))  hg x (hfg (g x))

lemma is_integral_tower_bot_of_is_integral_field {R A B : Type*} [comm_ring R] [field A]
  [comm_ring B] [nontrivial B] [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B]
  {x : A} (h : is_integral R (algebra_map A B x)) : is_integral R x :=
is_integral_tower_bot_of_is_integral (algebra_map A B).injective h

lemma ring_hom.is_integral_elem_of_is_integral_elem_comp {x : T}
  (h : (g.comp f).is_integral_elem x) : g.is_integral_elem x :=
let ⟨p, ⟨hp, hp'⟩⟩ := h in ⟨p.map f, hp.map f, by rwa ← eval₂_map at hp'⟩

lemma ring_hom.is_integral_tower_top_of_is_integral (h : (g.comp f).is_integral) : g.is_integral :=
λ x, ring_hom.is_integral_elem_of_is_integral_elem_comp f g (h x)

/-- If `R → A → B` is an algebra tower,
then if the entire tower is an integral extension so is `A → B`. -/
lemma is_integral_tower_top_of_is_integral {x : B} (h : is_integral R x) : is_integral A x :=
begin
  rcases h with ⟨p, ⟨hp, hp'⟩⟩,
  refine ⟨p.map (algebra_map R A), ⟨hp.map (algebra_map R A), _⟩⟩,
  rw [is_scalar_tower.algebra_map_eq R A B, ← eval₂_map] at hp',
  exact hp',
end

lemma ring_hom.is_integral_quotient_of_is_integral {I : ideal S} (hf : f.is_integral) :
  (ideal.quotient_map I f le_rfl).is_integral :=
begin
  rintros ⟨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
end

lemma is_integral_quotient_of_is_integral {I : ideal A} (hRA : algebra.is_integral R A) :
  algebra.is_integral (R ⧸ I.comap (algebra_map R A)) (A ⧸ I) :=
(algebra_map R A).is_integral_quotient_of_is_integral hRA

lemma is_integral_quotient_map_iff {I : ideal S} :
  (ideal.quotient_map I f le_rfl).is_integral ↔
    ((ideal.quotient.mk I).comp f : R →+* S ⧸ I).is_integral :=
begin
  let g := ideal.quotient.mk (I.comap f),
  have := ideal.quotient_map_comp_mk le_rfl,
  refine ⟨λ h, _, λ h, ring_hom.is_integral_tower_top_of_is_integral g _ (this ▸ h)⟩,
  refine this ▸ ring_hom.is_integral_trans g (ideal.quotient_map I f le_rfl) _ h,
  exact ring_hom.is_integral_of_surjective g ideal.quotient.mk_surjective,
end

/-- If the integral extension `R → S` is injective, and `S` is a field, then `R` is also a field. -/
lemma is_field_of_is_integral_of_is_field
  {R S : Type*} [comm_ring R] [nontrivial R] [comm_ring S] [is_domain S]
  [algebra R S] (H : algebra.is_integral R S) (hRS : function.injective (algebra_map R S))
  (hS : is_field S) : is_field R :=
begin
  refine ⟨⟨0, 1, zero_ne_one⟩, mul_comm, λ 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 (λ h, ha (hRS (trans h (ring_hom.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,
  { apply (injective_iff_map_eq_zero (algebra_map 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 [ring_hom.map_sum, finset.sum_mul],
    refine (finset.sum_congr rfl (λ i hi, _)).trans hp,
    rw [ring_hom.map_mul, mul_assoc],
    congr,
    have : a_inv ^ p.nat_degree = a_inv ^ (p.nat_degree - i) * a_inv ^ i,
    { rw [← pow_add a_inv, tsub_add_cancel_of_le (nat.le_of_lt_succ (finset.mem_range.mp hi))] },
    rw [ring_hom.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 (λ 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]
end

lemma is_field_of_is_integral_of_is_field'
  {R S : Type*} [comm_ring R] [comm_ring S] [is_domain S] [algebra R S]
  (H : algebra.is_integral R S) (hR : is_field R) :
  is_field S :=
begin
  letI := hR.to_field,
  refine ⟨⟨0, 1, zero_ne_one⟩, mul_comm, λ x hx, _⟩,
  let A := algebra.adjoin R ({x} : set S),
  haveI : is_noetherian R A :=
  is_noetherian_of_fg_of_noetherian A.to_submodule (fg_adjoin_singleton_of_integral x (H x)),
  haveI : module.finite R A := module.is_noetherian.finite R A,
  obtain ⟨y, hy⟩ := linear_map.surjective_of_injective (@linear_map.mul_left_injective R A _ _ _ _
    ⟨x, subset_adjoin (set.mem_singleton x)⟩ (λ h, hx (subtype.ext_iff.mp h))) 1,
  exact ⟨y, subtype.ext_iff.mp hy⟩,
end

lemma algebra.is_integral.is_field_iff_is_field
  {R S : Type*} [comm_ring R] [nontrivial R] [comm_ring S] [is_domain S] [algebra R S]
  (H : algebra.is_integral R S) (hRS : function.injective (algebra_map R S)) :
  is_field R ↔ is_field S :=
⟨is_field_of_is_integral_of_is_field' H, is_field_of_is_integral_of_is_field H hRS⟩

end algebra

theorem integral_closure_idem {R : Type*} {A : Type*} [comm_ring R] [comm_ring A] [algebra R A] :
  integral_closure (integral_closure R A : set A) A = ⊥ :=
eq_bot_iff.2 $ λ x hx, algebra.mem_bot.2
⟨⟨x, @is_integral_trans _ _ _ _ _ _ _ _ (integral_closure R A).algebra
     _ integral_closure.is_integral x hx⟩, rfl⟩

section is_domain
variables {R S : Type*} [comm_ring R] [comm_ring S] [is_domain S] [algebra R S]

instance : is_domain (integral_closure R S) :=
infer_instance

theorem roots_mem_integral_closure {f : R[X]} (hf : f.monic) {a : S}
  (ha : a ∈ (f.map $ algebra_map R S).roots) : a ∈ integral_closure R S :=
⟨f, hf, (eval₂_eq_eval_map _).trans $ (mem_roots $ (hf.map _).ne_zero).1 ha⟩

end is_domain


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer

! This file was ported from Lean 3 source module algebra.category.Module.filtered_colimits
! leanprover-community/mathlib commit 806bbb0132ba63b93d5edbe4789ea226f8329979
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Group.FilteredColimits
import Mathbin.Algebra.Category.Module.Basic

/-!
# The forgetful functor from `R`-modules preserves filtered colimits.

Forgetful functors from algebraic categories usually don't preserve colimits. However, they tend
to preserve _filtered_ colimits.

In this file, we start with a ring `R`, a small filtered category `J` and a functor
`F : J ⥤ Module R`. We show that the colimit of `F ⋙ forget₂ (Module R) AddCommGroup`
(in `AddCommGroup`) carries the structure of an `R`-module, thereby showing that the forgetful
functor `forget₂ (Module R) AddCommGroup` preserves filtered colimits. In particular, this implies
that `forget (Module R)` preserves filtered colimits.

-/

universe u v

noncomputable section

open Classical

open CategoryTheory

open CategoryTheory.Limits

open CategoryTheory.IsFiltered renaming max → max'

-- avoid name collision with `_root_.max`.
open AddMonCat.FilteredColimits (colimit_zero_eq colimit_add_mk_eq)

namespace ModuleCat.FilteredColimits

section

-- We use parameters here, mainly so we can have the abbreviations `M` and `M.mk` below, without
-- passing around `F` all the time.
parameter {R : Type u}[Ring R]{J : Type v}[SmallCategory J][IsFiltered J]

parameter (F : J ⥤ ModuleCat.{max v u} R)

/-- The colimit of `F ⋙ forget₂ (Module R) AddCommGroup` in the category `AddCommGroup`.
In the following, we will show that this has the structure of an `R`-module.
-/
abbrev m : AddCommGroupCat :=
  AddCommGroupCat.FilteredColimits.colimit (F ⋙ forget₂ (ModuleCat R) AddCommGroupCat.{max v u})
#align Module.filtered_colimits.M ModuleCat.FilteredColimits.m

/-- The canonical projection into the colimit, as a quotient type. -/
abbrev m.mk : (Σj, F.obj j) → M :=
  Quot.mk (Types.Quot.Rel (F ⋙ forget (ModuleCat R)))
#align Module.filtered_colimits.M.mk ModuleCat.FilteredColimits.m.mk

theorem m.mk_eq (x y : Σj, F.obj j)
    (h : ∃ (k : J)(f : x.1 ⟶ k)(g : y.1 ⟶ k), F.map f x.2 = F.map g y.2) : M.mk x = M.mk y :=
  Quot.EqvGen_sound (Types.FilteredColimit.eqvGen_quot_rel_of_rel (F ⋙ forget (ModuleCat R)) x y h)
#align Module.filtered_colimits.M.mk_eq ModuleCat.FilteredColimits.m.mk_eq

/-- The "unlifted" version of scalar multiplication in the colimit. -/
def colimitSmulAux (r : R) (x : Σj, F.obj j) : M :=
  M.mk ⟨x.1, r • x.2⟩
#align Module.filtered_colimits.colimit_smul_aux ModuleCat.FilteredColimits.colimitSmulAux

theorem colimitSmulAux_eq_of_rel (r : R) (x y : Σj, F.obj j)
    (h : Types.FilteredColimit.Rel (F ⋙ forget (ModuleCat R)) x y) :
    colimit_smul_aux r x = colimit_smul_aux r y :=
  by
  apply M.mk_eq
  obtain ⟨k, f, g, hfg⟩ := h
  use k, f, g
  simp only [CategoryTheory.Functor.comp_map, forget_map_eq_coe] at hfg
  rw [LinearMap.map_smul, LinearMap.map_smul, hfg]
#align Module.filtered_colimits.colimit_smul_aux_eq_of_rel ModuleCat.FilteredColimits.colimitSmulAux_eq_of_rel

/-- Scalar multiplication in the colimit. See also `colimit_smul_aux`. -/
instance colimitHasSmul : SMul R M
    where smul r x := by
    refine' Quot.lift (colimit_smul_aux F r) _ x
    intro x y h
    apply colimit_smul_aux_eq_of_rel
    apply types.filtered_colimit.rel_of_quot_rel
    exact h
#align Module.filtered_colimits.colimit_has_smul ModuleCat.FilteredColimits.colimitHasSmul

@[simp]
theorem colimit_smul_mk_eq (r : R) (x : Σj, F.obj j) : r • M.mk x = M.mk ⟨x.1, r • x.2⟩ :=
  rfl
#align Module.filtered_colimits.colimit_smul_mk_eq ModuleCat.FilteredColimits.colimit_smul_mk_eq

instance colimitModule : Module R M
    where
  one_smul x := by
    apply Quot.inductionOn x; clear x; intro x; cases' x with j x
    erw [colimit_smul_mk_eq F 1 ⟨j, x⟩, one_smul]
    rfl
  mul_smul r s x := by
    apply Quot.inductionOn x; clear x; intro x; cases' x with j x
    erw [colimit_smul_mk_eq F (r * s) ⟨j, x⟩, colimit_smul_mk_eq F s ⟨j, x⟩,
      colimit_smul_mk_eq F r ⟨j, _⟩, mul_smul]
  smul_add r x y := by
    apply Quot.induction_on₂ x y; clear x y; intro x y; cases' x with i x; cases' y with j y
    erw [colimit_add_mk_eq _ ⟨i, x⟩ ⟨j, y⟩ (max' i j) (left_to_max i j) (right_to_max i j),
      colimit_smul_mk_eq, smul_add, colimit_smul_mk_eq, colimit_smul_mk_eq,
      colimit_add_mk_eq _ ⟨i, _⟩ ⟨j, _⟩ (max' i j) (left_to_max i j) (right_to_max i j),
      LinearMap.map_smul, LinearMap.map_smul]
    rfl
  smul_zero r :=
    by
    erw [colimit_zero_eq _ (is_filtered.nonempty.some : J), colimit_smul_mk_eq, smul_zero]
    rfl
  zero_smul x := by
    apply Quot.inductionOn x; clear x; intro x; cases' x with j x
    erw [colimit_smul_mk_eq, zero_smul, colimit_zero_eq _ j]
    rfl
  add_smul r s x := by
    apply Quot.inductionOn x; clear x; intro x; cases' x with j x
    erw [colimit_smul_mk_eq, add_smul, colimit_smul_mk_eq, colimit_smul_mk_eq,
      colimit_add_mk_eq _ ⟨j, _⟩ ⟨j, _⟩ j (𝟙 j) (𝟙 j), CategoryTheory.Functor.map_id, id_apply,
      id_apply]
    rfl
#align Module.filtered_colimits.colimit_module ModuleCat.FilteredColimits.colimitModule

/-- The bundled `R`-module giving the filtered colimit of a diagram. -/
def colimit : ModuleCat R :=
  ModuleCat.of R M
#align Module.filtered_colimits.colimit ModuleCat.FilteredColimits.colimit

/-- The linear map from a given `R`-module in the diagram to the colimit module. -/
def coconeMorphism (j : J) : F.obj j ⟶ colimit :=
  {
    (AddCommGroupCat.FilteredColimits.colimitCocone
            (F ⋙ forget₂ (ModuleCat R) AddCommGroupCat.{max v u})).ι.app
      j with
    map_smul' := fun r x => by erw [colimit_smul_mk_eq F r ⟨j, x⟩]; rfl }
#align Module.filtered_colimits.cocone_morphism ModuleCat.FilteredColimits.coconeMorphism

/-- The cocone over the proposed colimit module. -/
def colimitCocone : cocone F where
  pt := colimit
  ι :=
    { app := cocone_morphism
      naturality' := fun j j' f =>
        LinearMap.coe_injective ((Types.colimitCocone (F ⋙ forget (ModuleCat R))).ι.naturality f) }
#align Module.filtered_colimits.colimit_cocone ModuleCat.FilteredColimits.colimitCocone

/-- Given a cocone `t` of `F`, the induced monoid linear map from the colimit to the cocone point.
We already know that this is a morphism between additive groups. The only thing left to see is that
it is a linear map, i.e. preserves scalar multiplication.
-/
def colimitDesc (t : cocone F) : colimit ⟶ t.pt :=
  {
    (AddCommGroupCat.FilteredColimits.colimitCoconeIsColimit
          (F ⋙ forget₂ (ModuleCat R) AddCommGroupCat.{max v u})).desc
      ((forget₂ (ModuleCat R) AddCommGroupCat.{max v u}).mapCocone t) with
    map_smul' := fun r x => by
      apply Quot.inductionOn x; clear x; intro x; cases' x with j x
      erw [colimit_smul_mk_eq]
      exact LinearMap.map_smul (t.ι.app j) r x }
#align Module.filtered_colimits.colimit_desc ModuleCat.FilteredColimits.colimitDesc

/-- The proposed colimit cocone is a colimit in `Module R`. -/
def colimitCoconeIsColimit : IsColimit colimit_cocone
    where
  desc := colimit_desc
  fac t j :=
    LinearMap.coe_injective <|
      (Types.colimitCoconeIsColimit (F ⋙ forget (ModuleCat R))).fac
        ((forget (ModuleCat R)).mapCocone t) j
  uniq t m h :=
    LinearMap.coe_injective <|
      (Types.colimitCoconeIsColimit (F ⋙ forget (ModuleCat R))).uniq
        ((forget (ModuleCat R)).mapCocone t) m fun j => funext fun x => LinearMap.congr_fun (h j) x
#align Module.filtered_colimits.colimit_cocone_is_colimit ModuleCat.FilteredColimits.colimitCoconeIsColimit

instance forget₂AddCommGroupPreservesFilteredColimits :
    PreservesFilteredColimits (forget₂ (ModuleCat R) AddCommGroupCat.{u})
    where PreservesFilteredColimits J _ _ :=
    {
      PreservesColimit := fun F =>
        preserves_colimit_of_preserves_colimit_cocone (colimit_cocone_is_colimit F)
          (AddCommGroupCat.FilteredColimits.colimitCoconeIsColimit
            (F ⋙ forget₂ (ModuleCat.{u} R) AddCommGroupCat.{u})) }
#align Module.filtered_colimits.forget₂_AddCommGroup_preserves_filtered_colimits ModuleCat.FilteredColimits.forget₂AddCommGroupPreservesFilteredColimits

instance forgetPreservesFilteredColimits : PreservesFilteredColimits (forget (ModuleCat.{u} R)) :=
  Limits.compPreservesFilteredColimits (forget₂ (ModuleCat R) AddCommGroupCat)
    (forget AddCommGroupCat)
#align Module.filtered_colimits.forget_preserves_filtered_colimits ModuleCat.FilteredColimits.forgetPreservesFilteredColimits

end

end ModuleCat.FilteredColimits