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


import Days
import Days.Common
import Std
import Lean.Data.Parsec

namespace Days.Day04
open Days
open Common
open Std (RBSet)

/--

Space needs to be cleared before the last supplies can be unloaded from the ships, and so several Elves have been assigned the job of cleaning up sections of the camp. Every section has a unique ID number, and each Elf is assigned a range of section IDs.

However, as some of the Elves compare their section assignments with each other, they've noticed that many of the assignments overlap. To try to quickly find overlaps and reduce duplicated effort, the Elves pair up and make a big list of the section assignments for each pair (your puzzle input).

For example, consider the following list of section assignment pairs:

2-4,6-8
2-3,4-5
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8
For the first few pairs, this list means:

Within the first pair of Elves, the first Elf was assigned sections 2-4 (sections 2, 3, and 4), while the second Elf was assigned sections 6-8 (sections 6, 7, 8).
The Elves in the second pair were each assigned two sections.
The Elves in the third pair were each assigned three sections: one got sections 5, 6, and 7, while the other also got 7, plus 8 and 9.
This example list uses single-digit section IDs to make it easier to draw; your actual list might contain larger numbers. Visually, these pairs of section assignments look like this:

.234.....  2-4
.....678.  6-8

.23......  2-3
...45....  4-5

....567..  5-7
......789  7-9

.2345678.  2-8
..34567..  3-7

.....6...  6-6
...456...  4-6

.23456...  2-6
...45678.  4-8
Some of the pairs have noticed that one of their assignments fully contains the other. For example, 2-8 fully contains 3-7, and 6-6 is fully contained by 4-6. In pairs where one assignment fully contains the other, one Elf in the pair would be exclusively cleaning sections their partner will already be cleaning, so these seem like the most in need of reconsideration. In this example, there are 2 such pairs.

In how many assignment pairs does one range fully contain the other?
-/
structure ElfSection where
  start: Nat
  stop: Nat

def ElfSection.contains (self: ElfSection) (other: Nat) : Bool :=
  if self.start ≤ other ∧ self.stop ≥ other
  then true
  else false

def ElfSection.fullyContains (self other: ElfSection) : Bool :=
  if self.contains other.start ∧ self.contains other.stop
  then true
  else false

def ElfSection.eitherFullyOverlaps (self other: ElfSection) : Bool :=
  self.fullyContains other ∨ other.fullyContains self

def allElfPairs (input: Input) : List $ ElfSection × ElfSection :=
  input.lines
  |>.map (λ line =>
    match line.splitOn "," with
    | [fst, snd] =>
      let parsePair (sec: Input) : Option ElfSection :=
        match sec.text.splitOn "-" |>.map String.toNat! with
        | [start, stop] => some ⟨ start, stop ⟩
        | _ => none

      do
      let fst ← parsePair fst
      let snd ← parsePair snd
      return (fst, snd)
    | _ => none
  )
  |>.filterMap id

def part₁ (input: Input) : Nat :=
  totalOverlaps
  where
    fullyOverlaps := Function.uncurry (ElfSection.eitherFullyOverlaps · ·)
    totalOverlaps :=
      allElfPairs input
      |>.filter fullyOverlaps
      |>.length

/--
It seems like there is still quite a bit of duplicate work planned. Instead, the Elves would like to know the number of pairs that overlap at all.

In the above example, the first two pairs (2-4,6-8 and 2-3,4-5) don't overlap, while the remaining four pairs (5-7,7-9, 2-8,3-7, 6-6,4-6, and 2-6,4-8) do overlap:

5-7,7-9 overlaps in a single section, 7.
2-8,3-7 overlaps all of the sections 3 through 7.
6-6,4-6 overlaps in a single section, 6.
2-6,4-8 overlaps in sections 4, 5, and 6.
So, in this example, the number of overlapping assignment pairs is 4.

In how many assignment pairs do the ranges overlap?
-/
def ElfSection.anyOverlap (self other: ElfSection) : Bool :=
  if self.contains other.start ∨ self.contains other.stop
  then true
  else false

def ElfSection.eitherOverlaps (self other: ElfSection) : Bool :=
  self.anyOverlap other ∨ other.anyOverlap self

def part₂ (input: Input) : Nat :=
   totalOverlaps
  where
    anyOverlaps := Function.uncurry (ElfSection.eitherOverlaps · ·)
    totalOverlaps :=
      allElfPairs input
      |>.filter anyOverlaps
      |>.length

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

def sample := "2-4,6-8
2-3,4-5
5-7,7-9
2-8,3-7
6-6,4-6
2-6,4-8"

#eval testPart₁ solution sample (expect:=2)
#eval testPart₂ solution sample (expect:=4)


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