import tactic -- import the tactics
import data.set.basic -- import the sets
import data.set.lattice -- infinite unions and intersections

/-

# Sets

## Introduction

In contrast to group theory, where we made our own definition
of a group and developed our own API (i.e. the lemmas we need
to prove basic results in group theory), here we will use Lean's API.

The first thing to learn is that this is not some development
of set theory, or ZFC, or whatever "set theory" brings to mind.
This is all about the theory of _subsets_ of a set, or, more
precisely, subsets of a type.

Just like `subgroup G` was the type of subgroups of `G`,
`set X` is the type of subsets of `X`. Don't ask me why it's
not called `subset X`. I guess the idea is that if `S : set X`
then `S` is a set of elements of `X` or, more precisely,
a set of terms of `X`.

And, also like `subgroup G`, if `S : set X` then `S` is a term,
not a type. This is a bit weird because in type theory our
model is that types are sets, and terms are their elements,
and `a : X` means that `a` is an element of `X`.

The way subsets work is like this. If `S : set X` and if `a : X`
then there's a predicate `a ∈ S`, which means that `a` is in
the subset `S` of `X`. Note that the _type_ of `a` is still `X`,
it's just that `a` happens to be in `S` as well. This is why we
can't have `S` as a type: then we would want to write `a : S`
and `a : X`, but terms in type theory can only have one type.

## Implementation

You don't need to know about implentation -- that's the point of the API.
Any new definition, like `set X`, should be accessed and reasoned with
using its API, the collection of lemmas that comes with it. But here's
what's actually going on.

Under the hood, if `S : set X` then `S` is a function from `X` to `Prop`.
The idea is that a subset of `X` is represented internally as a function
to `{true, false}` which sends all the elements of `S` to `true` and
all the other elements to `false`. In fact `set X := X → Prop` is
the internal definition of `set`. Internally, the statement `a ∈ S`
is just encoded as the proposition `S a`.

## Notation

There is a lot of it.

Say `(X Y : Type)`

The empty set is `∅ : set X`. Hover over the symbol to find out
how to write it in Lean.

The set corresponding to all of `X` is `set.univ : set X`, or
just `univ : set X` if you have written `open set` earlier in the file.

If `S : set X` then its complement is `Sᶜ : set X`.

Now say `f : X → Y`.

If `S : set X` then `f '' S : set Y` is the image of `S`.

If `T : set Y` then `f ⁻¹' T : set X` is the preimage of `T`.

The range of `f` could be written `f '' univ`, however there
is also `range f`.

Finally remember `subset_def : S ⊆ T ↔ ∀ x, x ∈ S → x ∈ T`

-/

variables (X Y Z : Type) (f : X → Y) (g : Y → Z) (S : set X) (y : Y)

open set

/-!

## image

`y ∈ f '' S` is definitionally equal to `∃ x : X, x ∈ S ∧ f x = y`,
but if you want to rewrite to change one to the other,
we have

`mem_image f S y : y ∈ f '' S ↔ ∃ (x : X), x ∈ S ∧ f x = y`

-/

-- here are four proofs of image_id, each taking more short cuts
-- than the last. In practice I might write the first proof
-- and then "golf" it down so it becomes closer to the fourth one.
-- Go through the first proof and then take a look at some
-- of the shortcuts I introduce.

lemma image_id (S : set X) : id '' S = S :=
begin
  ext x,
  split,
  { intro h,
    rw mem_image at h,
    cases h with y hy,
    cases hy with hyS hid,
    rw id.def at hid,
    rw ← hid,
    exact hyS },
  { intro hxS,
    rw mem_image,
    use x,
    split,
    { exact hxS },
    { rw id.def } }
end

example : id '' S = S :=
begin
  ext x,
  split,
  { intro h,
    -- don't need to `rw mem_image` because it's definitional
    -- rcases can do multiple `cases` at once. Note that ⟨a, b, c⟩ = ⟨a, ⟨b, c⟩⟩
    rcases h with ⟨y, hyS, hid⟩,
    -- don't need to `rw id.def` because it's definitional
    rw ← hid,
    exact hyS },
  { intro hxS,
    use x,
    -- if the goal is `⊢ P ∧ Q` and you have a proof of `P`, you can `use` it
    use hxS,
    -- `⊢ id x = x` is true by definition
    refl }
end

example : id '' S = S :=
begin
  ext x,
  split,
  { -- the `rintro` tactic will do `intro, cases`
    -- and will even do both `cases` at once!
    rintro ⟨y, hyS, hid⟩,
    rw ← hid,
    exact hyS },
  { intro hxS,
    -- two `use`s can go together
    use [x, hxS],
    refl }
end

-- this is the shortest explicit tactic proof I know which doesn't
-- cheat and use the corresponding lemma in Lean's maths library:
example : id '' S = S :=
begin
  ext x,
  split,
  { -- `hid` says `(something) = y` so why not just _define_ y to be this!
    rintro ⟨y, hyS, rfl⟩, -- rfl deletes `y` from the context and subs in `id x`
    exact hyS },
  { intro hxS,
  -- we can just build this term
    exact ⟨x, hxS, rfl⟩ },
end

-- Other proofs which won't teach you as much:

example : id '' S = S :=
begin
  -- it's in the library already
  apply image_id',
end

example : id '' S = S :=
begin
  simp -- `image_id'` is tagged `@[simp]` so `simp` finds it.
end

-- This tactic also finds `image_id'` in the library
example : id '' S = S :=
begin
  finish,
end

-- So does this one.
example : id '' S = S :=
begin
  tidy
end

-- The disadvantages of these last few proofs : (a) `finish` and `tidy` are
-- slow (b) they won't teach you much and (c) if the theorems are not
-- already in Lean's maths library then the tactics might not be of much use.

-- Let's see what you make of these lemmas about sets.

lemma image_comp (S : set X) : (g ∘ f) '' S = g '' (f '' S) :=
begin
  sorry
end

open function

-- don't forget you can use `dsimp` to tidy up evaluated lambdas
lemma image_injective : injective f → injective (λ S, f '' S) :=
begin
  sorry
end

/-!

## preimage

The notation : `f ⁻¹' T`. The useful lemma:

`mem_preimage : x ∈ f ⁻¹' T ↔ f x ∈ T`

but in fact both sides are equal by definition.

-/

example (S : set X) : S = id ⁻¹' S :=
begin
  sorry
end

-- Do take a look at the model solutions to this one (which I'll upload
-- after the workshop )
example (T : set Z) : (g ∘ f) ⁻¹' T = f ⁻¹' (g ⁻¹' T) :=
begin
  sorry
end

lemma preimage_injective (hf : surjective f) : injective (λ T, f ⁻¹' T) :=
begin
  sorry
end

lemma image_surjective (hf : surjective f) : surjective (λ S, f '' S) :=
begin
  sorry
end

lemma preimage_surjective (hf : injective f) : surjective (λ S, f ⁻¹' S) :=
begin
  sorry
end

/-!

## Union

If `(ι : Type)` and `(F : ι → set X)` then the `F i` for `i : ι`
are a family of subsets of `X`, so we can take their union.
This is `Union F` (note the capital U -- small u means union of two things,
capital means union of arbitrary number of things).
But the notation used in the lemmas is `⋃ (i : ι), F i`.

The key lemma you need to prove everything is that something is
an element of the union iff it's an element of one of the sets.

`mem_Union : (x ∈ ⋃ (i : ι), F i) ↔ ∃ j : ι, x ∈ F j`

-/

variables (ι : Type) (F : ι → set X) (x : X)

lemma image_Union (F : ι → set X) (f : X → Y) :
  f '' (⋃ (i : ι), F i) = ⋃ (i : ι), f '' (F i) :=
begin
  sorry
end

/-!

## bUnion

If as well as `F : ι → set X` you have `Z : set ι` then you might
just want to take the union over `F i` as `i` runs through `Z`.
This is called a "bounded union" or `bUnion`, and
the notation is `⋃ (i ∈ Z), F i`.

The lemma for elements of a bounded union is:

`mem_bUnion_iff : (x ∈ ⋃ (i ∈ J), F i) ↔ ∃ (j ∈ J), x ∈ F j`

-/

lemma preimage_bUnion (F : ι → set Y) (Z : set ι) :
  f ⁻¹' (⋃ (i ∈ Z), F i) = ⋃ (i ∈ Z), f ⁻¹' (F i) :=
begin
  sorry
end


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

/-!
# 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 -/
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)

theorem is_integral_alg_hom (f : A →ₐ[R] B) {x : A} (hx : is_integral R x) : is_integral R (f x) :=
let ⟨p, hp, hpx⟩ :=
hx in ⟨p, hp, by rw [← aeval_def, aeval_alg_hom_apply, aeval_def, hpx, f.map_zero]⟩

@[simp]
theorem is_integral_alg_equiv (f : A ≃ₐ[R] B) {x : A} : is_integral R (f x) ↔ is_integral R x :=
⟨λ h, by simpa using is_integral_alg_hom f.symm.to_alg_hom h, is_integral_alg_hom 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, ← is_scalar_tower.aeval_apply, aeval_def, hpx]⟩

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 x 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 :=
begin
  refine ⟨_, λ h, h.algebra_map⟩,
  rintros ⟨f, hf, hx⟩,
  use [f, hf],
  exact is_scalar_tower.aeval_eq_zero_of_aeval_algebra_map_eq_zero R A B hAB hx,
end

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 ⟨_, set.finite_mem_finset _, p.restriction, monic_restriction.2 hmp, _⟩,
    erw [← aeval_def, is_scalar_tower.aeval_apply _ R, 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_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.product 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₁ = (algebra.adjoin S₀ (↑y : set A)).to_subring,
  { 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 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

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 is_integral_alg_hom f hx },
  { intro hy,
    use [f.symm y, is_integral_alg_hom (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

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

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] lemma mk'_add (x y : B) (hx : is_integral R x) (hy : is_integral R y) :
  mk' A (x + y) (is_integral_add 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_add]

@[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 : 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 is_integral_alg_hom (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 : is_integral R A) (hB : is_integral A B) : 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)) : 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 : is_integral R A) :
  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 : 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 (@lmul_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 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

end is_domain


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

import algebra.algebra.basic

/-!
# Trivial Square-Zero Extension

Given a module `M` over a ring `R`, the trivial square-zero extension of `M` over `R` is defined
to be the `R`-algebra `R ⊕ M` with multiplication given by
`(r₁ + m₁) * (r₂ + m₂) = r₁ r₂ + r₁ m₂ + r₂ m₁`.

It is a square-zero extension because `M^2 = 0`.
-/

universes u v w

/--
"Trivial Square-Zero Extension".

Given a module `M` over a ring `R`, the trivial square-zero extension of `M` over `R` is defined
to be the `R`-algebra `R × M` with multiplication given by
`(r₁ + m₁) * (r₂ + m₂) = r₁ r₂ + r₁ m₂ + r₂ m₁`.

It is a square-zero extension because `M^2 = 0`.
-/
@[nolint has_inhabited_instance] def triv_sq_zero_ext (R : Type u) (M : Type v) :=
R × M

local notation `tsze` := triv_sq_zero_ext

namespace triv_sq_zero_ext

section basic
variables {R : Type u} {M : Type v}

/-- The canonical inclusion `R → triv_sq_zero_ext R M`. -/
def inl [has_zero M] (r : R) : tsze R M :=
(r, 0)

/-- The canonical inclusion `M → triv_sq_zero_ext R M`. -/
def inr [has_zero R] (m : M) : tsze R M :=
(0, m)

/-- The canonical projection `triv_sq_zero_ext R M → R`. -/
def fst (x : tsze R M) : R :=
x.1

/-- The canonical projection `triv_sq_zero_ext R M → M`. -/
def snd (x : tsze R M) : M :=
x.2

@[ext] lemma ext {x y : tsze R M} (h1 : x.fst = y.fst) (h2 : x.snd = y.snd) : x = y :=
prod.ext h1 h2

@[simp] lemma fst_inl [has_zero M] (r : R) : (inl r : tsze R M).fst = r := rfl
@[simp] lemma snd_inl [has_zero M] (r : R) : (inl r : tsze R M).snd = 0 := rfl
@[simp] lemma fst_inr [has_zero R] (m : M) : (inr m : tsze R M).fst = 0 := rfl
@[simp]

lemma inl_injective [has_zero M] : function.injective (inl : R → tsze R M) :=
function.left_inverse.injective fst_inl

lemma inr_injective [has_zero R] : function.injective (inr : M → tsze R M) :=
function.left_inverse.injective snd_inr

end basic

section add
variables (R : Type u) (M : Type v)

instance [has_zero R] [has_zero M] : has_zero (tsze R M) :=
prod.has_zero

@[simp] lemma fst_zero [has_zero R] [has_zero M] : (0 : tsze R M).fst = 0 := rfl
@[simp] lemma snd_zero [has_zero R] [has_zero M] : (0 : tsze R M).snd = 0 := rfl
@[simp] lemma inl_zero [has_zero R] [has_zero M] : (inl 0 : tsze R M) = 0 := rfl
@[simp] lemma inr_zero [has_zero R] [has_zero M] : (inr 0 : tsze R M) = 0 := rfl

instance [has_add R] [has_add M] : has_add (tsze R M) :=
prod.has_add

@[simp] lemma fst_add [has_add R] [has_add M] (x₁ x₂ : tsze R M) :
  (x₁ + x₂).fst = x₁.fst + x₂.fst := rfl
@[simp] lemma snd_add [has_add R] [has_add M] (x₁ x₂ : tsze R M) :
  (x₁ + x₂).snd = x₁.snd + x₂.snd := rfl

instance [has_neg R] [has_neg M] : has_neg (tsze R M) :=
prod.has_neg

@[simp] lemma fst_neg [has_neg R] [has_neg M] (x : tsze R M) : (-x).fst = -x.fst := rfl
@[simp] lemma snd_neg [has_neg R] [has_neg M] (x : tsze R M) : (-x).snd = -x.snd := rfl

instance [add_semigroup R] [add_semigroup M] : add_semigroup (tsze R M) :=
prod.add_semigroup

instance [add_monoid R] [add_monoid M] : add_monoid (tsze R M) :=
prod.add_monoid

@[simp] lemma inl_add [has_add R] [add_monoid M] (r₁ r₂ : R) :
  (inl (r₁ + r₂) : tsze R M) = inl r₁ + inl r₂ :=
ext rfl (add_zero 0).symm

@[simp] lemma inr_add [add_monoid R] [has_add M] (m₁ m₂ : M) :
  (inr (m₁ + m₂) : tsze R M) = inr m₁ + inr m₂ :=
ext (add_zero 0).symm rfl

lemma inl_fst_add_inr_snd_eq [add_monoid R] [add_monoid M] (x : tsze R M) :
  inl x.fst + inr x.snd = x :=
ext (add_zero x.1) (zero_add x.2)

instance [add_group R] [add_group M] : add_group (tsze R M) :=
prod.add_group

@[simp] lemma inl_neg [has_neg R] [add_group M] (r : R) :
  (inl (-r) : tsze R M) = -inl r :=
ext rfl neg_zero.symm

@[simp] lemma inr_neg [add_group R] [has_neg M] (m : M) :
  (inr (-m) : tsze R M) = -inr m :=
ext neg_zero.symm rfl

instance [add_comm_semigroup R] [add_comm_semigroup M] : add_comm_semigroup (tsze R M) :=
prod.add_comm_semigroup

instance [add_comm_monoid R] [add_comm_monoid M] : add_comm_monoid (tsze R M) :=
prod.add_comm_monoid

instance [add_comm_group R] [add_comm_group M] : add_comm_group (tsze R M) :=
prod.add_comm_group

end add

section smul
variables (R : Type u) (M : Type v)

instance [has_mul R] [has_scalar R M] : has_scalar R (tsze R M) :=
⟨λ r x, (r * x.1, r • x.2)⟩

@[simp] lemma fst_smul [has_mul R] [has_scalar R M] (r : R) (x : tsze R M) :
  (r • x).fst = r * x.fst := rfl
@[simp] lemma snd_smul [has_mul R] [has_scalar R M] (r : R) (x : tsze R M) :
  (r • x).snd = r • x.snd := rfl

@[simp] lemma inr_smul [mul_zero_class R] [has_scalar R M] (r : R) (m : M) :
  (inr (r • m) : tsze R M) = r • inr m :=
ext (mul_zero _).symm rfl

instance [monoid R] [mul_action R M] : mul_action R (tsze R M) :=
{ one_smul := λ x, ext (one_mul x.1) (one_smul R x.2) ,
  mul_smul := λ r₁ r₂ x, ext (mul_assoc r₁ r₂ x.1) (mul_smul r₁ r₂ x.2) }

instance [semiring R] [add_monoid M] [distrib_mul_action R M] : distrib_mul_action R (tsze R M) :=
{ smul_add := λ r x₁ x₂, ext (mul_add r x₁.1 x₂.1) (smul_add r x₁.2 x₂.2),
  smul_zero := λ r, ext (mul_zero r) (smul_zero r) }

instance [semiring R] [add_comm_monoid M] [module R M] : module R (tsze R M) :=
{ add_smul := λ r₁ r₂ x, ext (add_mul r₁ r₂ x.1) (add_smul r₁ r₂ x.2),
  zero_smul := λ x, ext (zero_mul x.1) (zero_smul R x.2) }

/-- The canonical `R`-linear inclusion `M → triv_sq_zero_ext R M`. -/
@[simps apply]
def inr_hom [semiring R] [add_comm_monoid M] [module R M] : M →ₗ[R] tsze R M :=
{ to_fun := inr,
  map_add' := inr_add R M,
  map_smul' := inr_smul R M }

end smul

section mul
variables (R : Type u) (M : Type v)

instance [has_one R] [has_zero M] : has_one (tsze R M) :=
⟨(1, 0)⟩

@[simp] lemma fst_one [has_one R] [has_zero M] : (1 : tsze R M).fst = 1 := rfl
@[simp] lemma snd_one [has_one R] [has_zero M] : (1 : tsze R M).snd = 0 := rfl
@[simp] lemma inl_one [has_one R] [has_zero M] : (inl 1 : tsze R M) = 1 := rfl

instance [has_mul R] [has_add M] [has_scalar R M] : has_mul (tsze R M) :=
⟨λ x y, (x.1 * y.1, x.1 • y.2 + y.1 • x.2)⟩

@[simp] lemma fst_mul [has_mul R] [has_add M] [has_scalar R M] (x₁ x₂ : tsze R M) :
  (x₁ * x₂).fst = x₁.fst * x₂.fst := rfl
@[simp] lemma snd_mul [has_mul R] [has_add M] [has_scalar R M] (x₁ x₂ : tsze R M) :
  (x₁ * x₂).snd = x₁.fst • x₂.snd + x₂.fst • x₁.snd := rfl

@[simp] lemma inl_mul [monoid R] [add_monoid M] [distrib_mul_action R M] (r₁ r₂ : R) :
  (inl (r₁ * r₂) : tsze R M) = inl r₁ * inl r₂ :=
ext rfl $ show (0 : M) = r₁ • 0 + r₂ • 0, by rw [smul_zero, zero_add, smul_zero]

lemma inl_mul_inl [monoid R] [add_monoid M] [distrib_mul_action R M] (r₁ r₂ : R) :
  (inl r₁ * inl r₂ : tsze R M) = inl (r₁ * r₂) :=
(inl_mul R M r₁ r₂).symm

lemma inl_mul_inr [semiring R] [add_comm_monoid M] [module R M] (r : R) (m : M) :
  (inl r * inr m : tsze R M) = inr (r • m) :=
ext (mul_zero r) $ show r • m + (0 : R) • 0 = r • m, by rw [smul_zero, add_zero]

lemma inr_mul_inl [semiring R] [add_comm_monoid M] [module R M] (r : R) (m : M) :
  (inr m * inl r : tsze R M) = inr (r • m) :=
ext (zero_mul r) $ show (0 : R) • 0 + r • m = r • m, by rw [smul_zero, zero_add]

@[simp] lemma inr_mul_inr [semiring R] [add_comm_monoid M] [module R M] (m₁ m₂ : M) :
  (inr m₁ * inr m₂ : tsze R M) = 0 :=
ext (mul_zero _) $ show (0 : R) • m₂ + (0 : R) • m₁ = 0, by rw [zero_smul, zero_add, zero_smul]

instance [comm_monoid R] [add_monoid M] [distrib_mul_action R M] : monoid (tsze R M) :=
{ mul_assoc := λ x y z, ext (mul_assoc x.1 y.1 z.1) $
    show (x.1 * y.1) • z.2 + z.1 • (x.1 • y.2 + y.1 • x.2) =
      x.1 • (y.1 • z.2 + z.1 • y.2) + (y.1 * z.1) • x.2,
    by simp_rw [smul_add, ← mul_smul, add_assoc, mul_comm],
  one_mul := λ x, ext (one_mul x.1) $ show (1 : R) • x.2 + x.1 • 0 = x.2,
    by rw [one_smul, smul_zero, add_zero],
  mul_one := λ x, ext (mul_one x.1) $ show (x.1 • 0 : M) + (1 : R) • x.2 = x.2,
    by rw [smul_zero, zero_add, one_smul],
  .. triv_sq_zero_ext.has_one R M,
  .. triv_sq_zero_ext.has_mul R M }

instance [comm_semiring R] [add_comm_monoid M] [module R M] : comm_semiring (tsze R M) :=
{ mul_comm := λ x₁ x₂, ext (mul_comm x₁.1 x₂.1) $
    show x₁.1 • x₂.2 + x₂.1 • x₁.2 = x₂.1 • x₁.2 + x₁.1 • x₂.2, from add_comm _ _,
  zero_mul := λ x, ext (zero_mul x.1) $ show (0 : R) • x.2 + x.1 • 0 = 0,
    by rw [zero_smul, zero_add, smul_zero],
  mul_zero := λ x, ext (mul_zero x.1) $ show (x.1 • 0 : M) + (0 : R) • x.2 = 0,
    by rw [smul_zero, zero_add, zero_smul],
  left_distrib := λ x₁ x₂ x₃, ext (mul_add x₁.1 x₂.1 x₃.1) $
    show x₁.1 • (x₂.2 + x₃.2) + (x₂.1 + x₃.1) • x₁.2 =
      x₁.1 • x₂.2 + x₂.1 • x₁.2 + (x₁.1 • x₃.2 + x₃.1 • x₁.2),
    by simp_rw [smul_add, add_smul, add_add_add_comm],
  right_distrib := λ x₁ x₂ x₃, ext (add_mul x₁.1 x₂.1 x₃.1) $
    show (x₁.1 + x₂.1) • x₃.2 + x₃.1 • (x₁.2 + x₂.2) =
      x₁.1 • x₃.2 + x₃.1 • x₁.2 + (x₂.1 • x₃.2 + x₃.1 • x₂.2),
    by simp_rw [add_smul, smul_add, add_add_add_comm],
  .. triv_sq_zero_ext.monoid R M,
  .. triv_sq_zero_ext.add_comm_monoid R M }

/-- The canonical inclusion of rings `R → triv_sq_zero_ext R M`. -/
@[simps apply]
def inl_hom [comm_semiring R] [add_comm_monoid M] [module R M] : R →+* tsze R M :=
{ to_fun := inl,
  map_one' := inl_one R M,
  map_mul' := inl_mul R M,
  map_zero' := inl_zero R M,
  map_add' := inl_add R M }

end mul

section algebra
variables (R : Type u) (M : Type v)

instance [comm_semiring R] [add_comm_monoid M] [module R M] : algebra R (tsze R M) :=
{ commutes' := λ r x, mul_comm _ _,
  smul_def' := λ r x, ext rfl $ show r • x.2 = r • x.2 + x.1 • 0, by rw [smul_zero, add_zero],
  .. triv_sq_zero_ext.module R M,
  .. triv_sq_zero_ext.inl_hom R M }

/-- The canonical `R`-algebra projection `triv_sq_zero_ext R M → R`. -/
def fst_hom [comm_semiring R] [add_comm_monoid M] [module R M] : tsze R M →ₐ[R] R :=
{ to_fun := fst,
  map_one' := fst_one R M,
  map_mul' := fst_mul R M,
  map_zero' := fst_zero R M,
  map_add' := fst_add R M,
  commutes' := fst_inl }

/-- The canonical `R`-module projection `triv_sq_zero_ext R M → M`. -/
@[simps apply]
def snd_hom [semiring R] [add_comm_monoid M] [module R M] : tsze R M →ₗ[R] M :=
{ to_fun := snd,
  map_add' := snd_add R M,
  map_smul' := snd_smul R M}

end algebra

end triv_sq_zero_ext


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

import data.list.basic
import data.list.infix

/-!

# Dropping or taking from lists on the right

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

Taking or removing element from the tail end of a list

## Main defintions

- `rdrop n`: drop `n : ℕ` elements from the tail
- `rtake n`: take `n : ℕ` elements from the tail
- `drop_while p`: remove all the elements that satisfy a decidable `p : α → Prop` from the tail of
  a list until hitting the first non-satisfying element
- `take_while p`: take all the elements that satisfy a decidable `p : α → Prop` from the tail of
  a list until hitting the first non-satisfying element

## Implementation detail

The two predicate-based methods operate by performing the regular "from-left" operation on
`list.reverse`, followed by another `list.reverse`, so they are not the most performant.
The other two rely on `list.length l` so they still traverse the list twice. One could construct
another function that takes a `L : ℕ` and use `L - n`. Under a proof condition that
`L = l.length`, the function would do the right thing.

-/

variables {α : Type*} (p : α → Prop) [decidable_pred p] (l : list α) (n : ℕ)

namespace list

/-- Drop `n` elements from the tail end of a list. -/
def rdrop : list α := l.take (l.length - n)

@[simp] lemma rdrop_nil : rdrop ([] : list α) n = [] := by simp [rdrop]
@[simp] lemma rdrop_zero : rdrop l 0 = l := by simp [rdrop]

lemma rdrop_eq_reverse_drop_reverse : l.rdrop n = reverse (l.reverse.drop n) :=
begin
  rw rdrop,
  induction l using list.reverse_rec_on with xs x IH generalizing n,
  { simp },
  { cases n,
    { simp [take_append] },
    { simp [take_append_eq_append_take, IH] } }
end

@[simp] lemma rdrop_concat_succ (x : α) : rdrop (l ++ [x]) (n + 1) = rdrop l n :=
by simp [rdrop_eq_reverse_drop_reverse]

/-- Take `n` elements from the tail end of a list. -/
def rtake : list α := l.drop (l.length - n)

@[simp] lemma rtake_nil : rtake ([] : list α) n = [] := by simp [rtake]
@[simp] lemma rtake_zero : rtake l 0 = [] := by simp [rtake]

lemma rtake_eq_reverse_take_reverse : l.rtake n = reverse (l.reverse.take n) :=
begin
  rw rtake,
  induction l using list.reverse_rec_on with xs x IH generalizing n,
  { simp },
  { cases n,
    { simp },
    { simp [drop_append_eq_append_drop, IH] } }
end

@[simp] lemma rtake_concat_succ (x : α) : rtake (l ++ [x]) (n + 1) = rtake l n ++ [x] :=
by simp [rtake_eq_reverse_take_reverse]

/-- Drop elements from the tail end of a list that satisfy `p : α → Prop`.
Implemented naively via `list.reverse` -/
def rdrop_while : list α := reverse (l.reverse.drop_while p)

@[simp] lemma rdrop_while_nil : rdrop_while p ([] : list α) = [] :=
by simp [rdrop_while, drop_while]
lemma rdrop_while_concat (x : α) :
  rdrop_while p (l ++ [x]) = if p x then rdrop_while p l else l ++ [x] :=
begin
  simp only [rdrop_while, drop_while, reverse_append, reverse_singleton, singleton_append],
  split_ifs with h h;
  simp [h]
end
@[simp] lemma rdrop_while_concat_pos (x : α) (h : p x) :
  rdrop_while p (l ++ [x]) = rdrop_while p l :=
by rw [rdrop_while_concat, if_pos h]
@[simp] lemma rdrop_while_concat_neg (x : α) (h : ¬ p x) :
  rdrop_while p (l ++ [x]) = l ++ [x] :=
by rw [rdrop_while_concat, if_neg h]

lemma rdrop_while_singleton (x : α) :
  rdrop_while p [x] = if p x then [] else [x] :=
by rw [←nil_append [x], rdrop_while_concat, rdrop_while_nil]

lemma rdrop_while_last_not (hl : (l.rdrop_while p) ≠ []):
  ¬ p ((rdrop_while p l).last hl) :=
begin
  simp_rw rdrop_while,
  rw last_reverse,
  exact drop_while_nth_le_zero_not _ _ _
end

lemma rdrop_while_prefix : l.rdrop_while p <+: l :=
begin
  rw [←reverse_suffix, rdrop_while, reverse_reverse],
  exact drop_while_suffix _
end

variables {p} {l}

@[simp] lemma rdrop_while_eq_nil_iff : rdrop_while p l = [] ↔ ∀ x ∈ l, p x :=
by simp [rdrop_while]

-- it is in this file because it requires `list.infix`
@[simp] lemma drop_while_eq_self_iff :
  drop_while p l = l ↔ ∀ (hl : 0 < l.length), ¬ p (l.nth_le 0 hl) :=
begin
  induction l with hd tl IH,
  { simp },
  { rw drop_while,
    split_ifs,
    { simp only [h, length, nth_le, nat.succ_pos', not_true, forall_true_left, iff_false],
      intro H,
      refine (cons_ne_self hd tl) (sublist.antisymm _ (sublist_cons _ _)),
      rw ←H,
      exact (drop_while_suffix _).sublist },
    { simp [h] } }
end

@[simp] lemma rdrop_while_eq_self_iff : rdrop_while p l = l ↔ ∀ (hl : l ≠ []), ¬ p (l.last hl) :=
begin
  simp only [rdrop_while, reverse_eq_iff, length_reverse, ne.def, drop_while_eq_self_iff,
             last_eq_nth_le, ←length_eq_zero, pos_iff_ne_zero],
  refine forall_congr _,
  intro h,
  rw [nth_le_reverse'],
  { simp },
  { rw [←ne.def, ←pos_iff_ne_zero] at h,
    simp [tsub_lt_iff_right (nat.succ_le_of_lt h)] }
end

variables (p) (l)

lemma drop_while_idempotent : drop_while p (drop_while p l) = drop_while p l :=
drop_while_eq_self_iff.mpr (drop_while_nth_le_zero_not _ _)

lemma rdrop_while_idempotent : rdrop_while p (rdrop_while p l) = rdrop_while p l :=
rdrop_while_eq_self_iff.mpr (rdrop_while_last_not _ _)

/-- Take elements from the tail end of a list that satisfy `p : α → Prop`.
Implemented naively via `list.reverse` -/
def rtake_while : list α := reverse (l.reverse.take_while p)

@[simp] lemma rtake_while_nil : rtake_while p ([] : list α) = [] :=
by simp [rtake_while, take_while]
lemma rtake_while_concat (x : α) :
  rtake_while p (l ++ [x]) = if p x then rtake_while p l ++ [x] else [] :=
begin
  simp only [rtake_while, take_while, reverse_append, reverse_singleton, singleton_append],
  split_ifs with h h;
  simp [h]
end
@[simp]

lemma rtake_while_suffix : l.rtake_while p <:+ l :=
begin
  rw [←reverse_prefix, rtake_while, reverse_reverse],
  exact take_while_prefix _
end

variables {p} {l}

@[simp] lemma rtake_while_eq_self_iff : rtake_while p l = l ↔ ∀ x ∈ l, p x :=
by simp [rtake_while, reverse_eq_iff]

@[simp] lemma rtake_while_eq_nil_iff : rtake_while p l = [] ↔ ∀ (hl : l ≠ []), ¬ p (l.last hl) :=
begin
  induction l using list.reverse_rec_on;
  simp [rtake_while]
end

lemma mem_rtake_while_imp {x : α} (hx : x ∈ rtake_while p l) : p x :=
begin
  suffices : x ∈ take_while p l.reverse,
  { exact mem_take_while_imp this },
  rwa [←mem_reverse, ←rtake_while]
end

variables (p) (l)

lemma rtake_while_idempotent : rtake_while p (rtake_while p l) = rtake_while p l :=
rtake_while_eq_self_iff.mpr (λ _, mem_rtake_while_imp)

end list


import Mathlib
import Lean
import Mathlib.Data.Finset.Basic

universe u v w

def Finset.next_elem (s:Finset Nat) : Nat :=
  match Finset.max s with
  | some x => Nat.succ x
  | none => 0

theorem Finset.next_elem_not_in_self (s:Finset Nat) : next_elem s ∉ s :=
by
  intro h1
  simp only [next_elem] at h1
  generalize h2 : Finset.max s = x
  rw [h2] at h1
  cases x with
  | none =>
    have := Finset.max_eq_bot.1 h2
    simp only [this, not_mem_empty] at *
  | some x =>
    simp only at *
    have := Finset.le_max h1
    rw [h2] at this
    simp only [LE.le, Option.mem_def, Option.some.injEq, Nat.lt_eq, exists_eq_left'] at this
    have := this (.succ x) (by trivial)
    simp_arith at this

structure Heap.Cell where
  type: Type 0
  val: type

structure Heap where
  domain : Finset Nat
  val : {x // x ∈ domain} → Heap.Cell

instance : Inhabited Heap where
  default := ⟨∅, fun x => by
    apply False.elim
    cases x.property
  ⟩

instance : Singleton (Nat × Heap.Cell) Heap where
  singleton pair :=
    let (ref, cell) := pair
    ⟨{ref}, fun _ => cell⟩

instance : EmptyCollection Heap where
  emptyCollection := default

def Heap.eval (m:Heap) (x:Nat) : Option Cell :=
  dite (x ∈ m.domain) (fun h => some <| m.val ⟨x, h⟩) (fun _ => none)

theorem Heap.eval_eq_thm : ∀ m₁ m₂ : Heap,
  (∀ x, eval m₁ x = eval m₂ x) → m₁ = m₂ :=
by
  intro ⟨d1, v1⟩ ⟨d2, v2⟩ h1
  have : ∀ x, x ∈ d1 ↔ x ∈ d2 := by
    intro x
    constructor <;> intro h2
    <;> apply by_contradiction
    <;> intro h3
    <;> have := h1 x
    <;> simp only [eval, h2, h3, dite_true, dite_false] at this

  have : d1 = d2 := Finset.ext_iff.2 this
  induction this
  simp only [mk.injEq, heq_eq_eq, true_and]

  apply funext
  intro x
  have := h1 x
  simp only [eval, Finset.coe_mem, Subtype.coe_eta, dite_eq_ite, ite_true, Option.some.injEq] at this
  assumption

#check Disjoint
#check Finset.disjUnion
def Heap.disjoint (m₁ m₂: Heap) : Prop := Disjoint m₁.domain m₂.domain

theorem Heap.disjoint_thm (m₁ m₂: Heap) : disjoint m₁ m₂ = (m₁.domain ∩ m₂.domain = ∅) := by
  simp only [disjoint, Finset.disjoint_iff_ne, ne_eq, eq_iff_iff]
  constructor
  . intros h1
    rw [Finset.ext_iff]
    simp only [Finset.mem_inter, Finset.not_mem_empty, iff_false, not_and]
    intro a h2 h3
    apply h1 a h2 a h3 rfl
  . intros h1 a h2 b h3 h4
    simp only [Finset.ext_iff, Finset.mem_inter, Finset.not_mem_empty, iff_false, not_and] at h1
    induction h4
    apply h1 a
    <;> assumption

infixl:62 " /// " => Heap.disjoint

instance : Union Heap := ⟨fun m₁ m₂ => ⟨
  m₁.domain ∪ m₂.domain,
  fun x => dite (x.1 ∈ m₁.domain) (fun h => m₁.val ⟨x.val, h⟩)
  (fun h1 => dite (x.1 ∈ m₂.domain) (fun h => m₂.val ⟨x.val, h⟩) (by
    intro h2
    apply False.elim
    have := x.property
    simp only [Finset.mem_union] at this
    apply Or.elim this
    <;> intro h
    . exact h1 h
    . exact h2 h
  ))
⟩⟩

@[simp] instance : Membership Nat Heap := ⟨fun x m => x ∈ m.domain⟩

instance {x:Nat} {m:Heap} : Decidable (x ∈ m) := inferInstanceAs (Decidable (x ∈ m.domain))

@[simp] def Heap.join := @Union.union Heap _

@[simp] theorem Heap.eval_join_thm : ∀ m₁ m₂ x,
  eval (m₁ ∪ m₂) x = match eval m₁ x with
    | none => eval m₂ x
    | some x => some x
:= by
  intro m₁ m₂ x
  apply @Classical.byCases (x ∈ m₁.domain) <;>
  apply @Classical.byCases (x ∈ m₂.domain) <;>
  intro h1 h2 <;> simp only [
    eval, h1, h2, Union.union, Finset.mem_mk,
    Multiset.mem_ndunion, Finset.mem_val,
    or_self, or_true, or_false, dite_true, dite_false]

#print Associative

theorem Heap.join_is_Associative : ∀ m₁ m₂ m₃:Heap, m₁ ∪ (m₂ ∪ m₃) = (m₁ ∪ m₂) ∪ m₃ := by
  intro m1 m2 m3
  apply Heap.eval_eq_thm
  intro x
  simp only [eval_join_thm]
  cases eval m1 x <;>
  cases eval m2 x <;>
  simp only

instance : Associative Heap.join := by
  simp only [Associative]
  intros
  apply Eq.symm
  apply Heap.join_is_Associative

theorem Heap.disjoint_is_symmetric : ∀ m₁ m₂, m₁ /// m₂ → m₂ /// m₁ :=
by
  simp only [Symmetric, disjoint_thm]
  intro m₁ m₂ h
  have h := Finset.ext_iff.1 h
  apply Finset.ext_iff.2
  simp only [Finset.mem_inter, Finset.not_mem_empty, iff_false, not_and] at *
  intro x h1 h2
  apply h x h2 h1

theorem Heap.disjoint_symm : ∀ m₁ m₂, m₁ /// m₂ ↔ m₂ /// m₁ :=
by
  intros
  constructor
  <;> apply Heap.disjoint_is_symmetric

theorem Heap.join_symm : ∀ m₁ m₂, m₁ /// m₂ → m₁ ∪ m₂ = m₂ ∪ m₁ :=
by
  intro m₁ m₂ h1
  apply eval_eq_thm
  intro x
  simp only [eval_join_thm]
  apply @Classical.byCases (x ∈ m₁.domain) <;>
  apply @Classical.byCases (x ∈ m₂.domain) <;>
  intro h2 h3 <;> simp only [eval, h2, h3, dite_true, dite_false]
  apply False.elim
  simp only [disjoint_thm] at h1
  have := Finset.ext_iff.1 h1 x
  simp only [Finset.mem_inter, Finset.not_mem_empty, iff_false, not_and] at this
  apply this
  <;> assumption

@[simp] theorem Heap.eval_empty :
  ∀ x, eval ∅ x = none :=
by
  intro x
  simp only [eval, EmptyCollection.emptyCollection]
  simp only [default, dite_false, Finset.not_mem_empty]

@[simp] theorem Heap.disjoint_empty_left :
  ∀ m:Heap, disjoint m ∅ :=
by
  simp only [disjoint, EmptyCollection.emptyCollection]
  simp only [default, Finset.disjoint_empty_right, forall_const]

@[simp] theorem Heap.disjoint_empty_right :
  ∀ m:Heap, disjoint ∅ m :=
by
  simp only [disjoint, EmptyCollection.emptyCollection]
  simp only [default, Finset.disjoint_empty_left, forall_const]

@[simp] theorem Heap.join_empty_right :
  ∀ m:Heap, ∅ ∪ m = m :=
by
  intro m
  apply eval_eq_thm
  intro x
  simp only [eval_join_thm, eval_empty]

@[simp] theorem Heap.join_empty_left :
  ∀ m:Heap, m ∪ ∅ = m :=
by
  intro m
  apply eval_eq_thm
  intro x
  simp only [eval_empty, eval_join_thm]
  cases eval m x
  <;> simp only

@[simp] theorem Heap.join_domain :
  ∀ m₁ m₂ : Heap, (m₁ ∪ m₂).domain = m₁.domain ∪ m₂.domain :=
by
  intro m₁ m₂
  simp only [Union.union]

@[simp] theorem Heap.disjoint_join_comp1 :
  ∀ m₁ m₂ m₃, m₁ /// m₂ ∪ m₃ ↔ (m₁ /// m₂ ∧ m₁ /// m₃) :=
by
  intro m₁ m₂ m₃
  constructor
  <;> intro h
  <;> simp only [disjoint_thm, join_domain] at *
  . have h1 := Finset.ext_iff.1 h
    constructor <;> apply Finset.ext_iff.2
    <;> simp only [Finset.mem_union, Finset.mem_inter, Finset.not_mem_empty, iff_false, not_and] at *
    . intro x h2 h3
      apply h1 x
      assumption
      apply Or.inl
      assumption
    . intro x h2 h3
      apply h1 x
      assumption
      apply Or.inr
      assumption
  . apply Finset.ext_iff.2
    have h1 := Finset.ext_iff.1 h.1
    have h2 := Finset.ext_iff.1 h.2
    simp only [Finset.mem_inter, Finset.mem_union, Finset.not_mem_empty, iff_false, not_and] at *
    intro x h3 h4
    cases h4
    . apply h1 x <;> assumption
    . apply h2 x <;> assumption

@[simp] theorem Heap.disjoint_join_comp2 :
  ∀ m₁ m₂ m₃, m₁ ∪ m₂ /// m₃ ↔ (m₁ /// m₃ ∧ m₂ /// m₃) :=
by
  intro m₁ m₂ m₃
  simp only [disjoint_symm, disjoint_join_comp1]

instance : Symmetric Heap.disjoint := Heap.disjoint_is_symmetric

def Heap.context_stability (p:Heap → Prop) := ∀ m₁ m₂, m₁ /// m₂ → p m₁ → p (m₁ ∪ m₂)

def Heap.prop := { p:Heap → Prop // context_stability p }

@[simp] def Heap.pure_prop_definition (p:Prop) : Heap → Prop := fun _ => p

def Heap.pure_prop_stability (p:Prop) : context_stability (pure_prop_definition p) :=
  by simp [context_stability, pure_prop_definition]

@[simp] def Heap.pure_prop (p:Prop) : Heap.prop :=
  ⟨pure_prop_definition p, pure_prop_stability p⟩

@[simp] def Heap.star_prop_definition (P Q:Heap.prop) : Heap → Prop :=
  fun m => ∃ m₁ m₂,
    m = m₁ ∪ m₂ ∧ m₁ /// m₂ ∧ P.val m₁ ∧ Q.val m₂

def Heap.star_prop_stability (P Q:Heap.prop) : context_stability (star_prop_definition P Q) :=
by
  intro m m' h1 h2
  apply Exists.elim h2
  intro m₁ h2
  apply Exists.elim h2
  intro m₂ h2
  -- use m₁ and m₂ ∪ m'
  apply Exists.intro m₁
  apply Exists.intro (m₂ ∪ m')
  constructor
  . simp only [h2.1]
    have := Heap.join_is_Associative
    simp only [Associative] at this
    rw [this]
  . constructor
    . simp only [disjoint_join_comp1]
      simp only [h2.1, disjoint_join_comp2] at h1
      constructor
      . apply h2.2.1
      . exact h1.1
    . constructor
      . exact h2.2.2.1
      . apply Q.property
        . simp only [h2.1, disjoint_join_comp2] at h1
          exact h1.2
        . exact h2.2.2.2

@[simp] def Heap.star_prop (P Q:Heap.prop) : Heap.prop :=
  ⟨star_prop_definition P Q, star_prop_stability P Q⟩

@[simp] def Heap.magic_prop_definitoin (P Q:Heap.prop) : Heap → Prop :=
  fun m : Heap =>
    ∀ m':Heap, m /// m' → P.val m' → Q.val (m ∪ m')

def Heap.magic_prop_stability (P Q:Heap.prop) : context_stability (magic_prop_definitoin P Q) :=
by
  intro m₁ m₂ h1 h2 m' h3 h4
  have h2 := h2 (m₂ ∪ m')
  rw [join_is_Associative] at h2
  apply h2
  simp only [disjoint_join_comp1, disjoint_join_comp2] at *
  constructor
  . apply h1
  . apply h3.1
  . rw [join_symm] <;>
    simp only [disjoint_join_comp2] at h3
    apply P.property
    rw [disjoint_symm]
    exact h3.2
    assumption
    exact h3.2

@[simp] def Heap.magic_prop (P Q:Heap.prop) : Heap.prop :=
  ⟨Heap.magic_prop_definitoin P Q, Heap.magic_prop_stability P Q⟩

@[simp] def Heap.exists_prop_definition {α:Sort u} (prop:α → Heap.prop) : Heap → Prop :=
  λ m: Heap => ∃ x:α, (prop x).val m

def Heap.exists_prop_stability {α: Sort u} (prop: α → Heap.prop) :
  context_stability (@exists_prop_definition α prop) :=
by
  simp only [context_stability, exists_prop_definition, forall_exists_index]
  intro m₁ m₂ h1 x h2
  apply Exists.intro x
  apply (prop x).property
  <;> assumption

@[simp] def Heap.exists_prop {α:Sort u} (prop:α → Heap.prop) : Heap.prop :=
  ⟨exists_prop_definition prop, exists_prop_stability prop⟩

@[simp] def Heap.forall_prop_definition {α:Sort u} (prop:α → Heap.prop) : Heap → Prop :=
  λ m:Heap => ∀ x:α, (prop x).val m

theorem Heap.forall_prop_stability {α:Sort u} (prop:α → Heap.prop) : context_stability (forall_prop_definition prop) :=
by
  simp only [context_stability]
  intro m₁ m₂ h1 h2 x
  apply (prop x).property
  assumption
  apply h2

@[simp] def Heap.forall_prop {α:Sort u} (prop:α → Heap.prop) : Heap.prop :=
  ⟨forall_prop_definition prop, forall_prop_stability prop⟩

@[simp] def Heap.and_prop_definition (P Q:Heap.prop) : Heap → Prop :=
  λ m:Heap => P.val m ∧ Q.val m

theorem Heap.and_prop_stability (P Q:Heap.prop) : context_stability (and_prop_definition P Q) :=
by
  simp only [context_stability, and_prop_definition, and_imp]
  intro m₁ m₂ h1 h2 h3
  constructor
  . apply P.property
    <;> assumption
  . apply Q.property
    <;> assumption

@[simp] def Heap.and_prop (P Q:Heap.prop) : Heap.prop :=
  ⟨and_prop_definition P Q, and_prop_stability P Q⟩

@[simp] def Heap.or_prop_definition (P Q:Heap.prop) : Heap → Prop :=
  λ m:Heap => P.val m ∨ Q.val m

def Heap.or_prop_stability (P Q:Heap.prop) : context_stability (or_prop_definition P Q) :=
by
  simp only [context_stability]
  intro m₁ m₂ h1 h2
  cases h2
  . apply Or.inl
    apply P.property
    <;> assumption
  . apply Or.inr
    apply Q.property
    <;> assumption

@[simp] def Heap.or_prop (P Q:Heap.prop) : Heap.prop :=
  ⟨or_prop_definition P Q, or_prop_stability P Q⟩

syntax " ⌜ " term " ⌝ " : term -- type as `ulcorner` and `urcorner`
syntax " ⌜ " " ⌝ " : term
macro_rules
| `(⌜ $p:term ⌝) => `( Heap.pure_prop $p )
| `( ⌜⌝ ) => `( Heap.pure_prop True )

infixr:67 " ⋆ " => Heap.star_prop -- type as `star`

infixr:65 " -⋆ " => Heap.magic_prop

infixr:35 " ∧ᴴ " => Heap.and_prop

infixr:30 " ∨ᴴ " => Heap.or_prop

#print Exists

@[simp] def Heap.as_prop_definition (p:Heap→Prop) : Heap → Prop := fun m => ∀ m', m /// m' → p (m ∪ m')

theorem Heap.as_prop_stability (p:Heap→Prop) : context_stability (as_prop_definition p) :=
by
  simp only [context_stability]
  intro m₁ m₂ h1 h2 m' h3
  simp only [disjoint_join_comp2] at h3
  rw [<-join_is_Associative]
  apply h2
  simp only [disjoint_join_comp1]
  constructor
  . apply h1
  . apply h3.1

@[simp] def Heap.as_prop (p:Heap→Prop) : Heap.prop :=
  ⟨as_prop_definition p, as_prop_stability p⟩

open Lean in
open TSyntax.Compat in
macro "∃ᴴ " xs:explicitBinders ", " b:term : term => expandExplicitBinders ``Heap.exists_prop xs b

open Lean in
open TSyntax.Compat in
macro "∀ᴴ " xs:explicitBinders ", " b:term : term => expandExplicitBinders ``Heap.forall_prop xs b

#check (∃ᴴ x, ⌜ x ⌝) ⋆ ∀ᴴ y, ⌜ y ⌝

abbrev Heap.Pointer := Nat

@[simp] def Heap.assign_prop_definition (ref:Nat) (cell:Cell) : Heap → Prop :=
  fun m => eval m ref = some cell

def Heap.assign_prop_stability (ref:Nat) (cell:Cell) : context_stability (assign_prop_definition ref cell) :=
by
  simp only [context_stability, assign_prop_definition, eval_join_thm]
  intro m₁ m₂ _ h2
  generalize h3 : eval m₁ ref = x₁
  generalize h4 : eval m₂ ref = x₂
  cases x₁ <;> cases x₂ <;> simp only [Option.some.injEq]
  case none.none =>
    rw [h3] at h2
    cases h2
  case none.some x =>
    rw [h3] at h2
    cases h2
  case some.none x =>
    rw [h3] at h2
    cases h2
    rfl
  case some.some x y =>
    rw [h3] at h2
    cases h2
    rfl

@[simp] def Heap.assign_prop (ref:Nat) (cell:Cell) : Heap.prop :=
  ⟨
    assign_prop_definition ref cell,
    assign_prop_stability ref cell
  ⟩

infixl:70 " ↦ " => Heap.assign_prop -- type as `mapsto`

@[simp] theorem Heap.star_magic_reduction (P Q:Heap.prop) : ∀ m, (P ⋆ (P -⋆ Q)).val m → Q.val m :=
by
  intro m1
  simp only [star_prop, star_prop_definition, magic_prop, magic_prop_definitoin, forall_exists_index, and_imp]
  intro m2 m3 h1 h2 h3 h4
  have := h4 m2
  simp only at *
  rw [join_symm, disjoint_symm, <-h1] at this
  apply this
  <;> assumption
  rw [disjoint_symm]
  assumption

def Heap.models (P Q:Heap.prop) : Prop :=
  ∀ m, P.1 m → Q.1 m

infix:25  " ⊧ " => Heap.models -- type as vdash

theorem Heap.star_is_symmetric (P Q:Heap.prop) : P ⋆ Q ⊧ Q ⋆ P :=
by
  intro m
  simp only [star_prop, star_prop_definition]
  intro h1
  apply Exists.elim h1
  intro m1 h1
  apply Exists.elim h1
  intro m2 h1
  rw [join_symm, disjoint_symm] at h1
  apply Exists.intro m2
  apply Exists.intro m1
  constructor
  . apply h1.1
  . constructor
    . apply h1.2.1
    . constructor
      . apply h1.2.2.2
      . apply h1.2.2.1
  apply h1.2.1


import data.real.basic
import data.int.order
import order.well_founded_set
import data.int.parity
import tactic
import init.data.int.order
import combinatorics.simple_graph.basic
import data.fintype.card
import data.nat.basic

--Types and helper functions for points in d dimensional space
def point (d : ℕ) : Type := vector ℝ d
def int_point (d : ℕ) : Type := vector ℤ d
def int_point_to_point {d : ℕ} (p : int_point d) : point d :=
  let fn : fin d → ℝ := λ x : fin d, ↑(vector.nth p x) in
  vector.of_fn fn

--Misc helper functions
lemma lt_of_le_add_neg {a : ℝ} {b : ℝ} {c : ℝ} (h : c < 0) : a ≤ b + c → a < b :=
  by {intro h', linarith}

lemma floor_mono_eq {a : ℝ} {b : ℝ} (h : a = b) : int.floor(a) = int.floor(b) :=
begin
  have a_le_b : a ≤ b := le_of_eq h,
  symmetry' at h,
  have b_le_a : b ≤ a := le_of_eq h,
  have floor_a_le_floor_b : int.floor(a) ≤ int.floor(b) := int.floor_mono a_le_b,
  have floor_b_le_floor_a : int.floor(b) ≤ int.floor(a) := int.floor_mono b_le_a,
  linarith,
end

lemma ceil_mono_eq {a : ℝ} {b : ℝ} (h : a = b) : int.ceil(a) = int.ceil(b) :=
begin
  have a_le_b : a ≤ b := le_of_eq h,
  symmetry' at h,
  have b_le_a : b ≤ a := le_of_eq h,
  have ceil_a_le_ceil_b := int.ceil_mono a_le_b,
  have ceil_b_le_ceil_a := int.ceil_mono b_le_a,
  linarith,
end

lemma coe_nat_abs_ge_zero (z : ℤ) : (z.nat_abs : ℤ) ≥ 0 :=
begin
  have h : z.nat_abs ≥ 0,
  by_cases z = 0,
  rw h,
  rw int.nat_abs_zero,
  linarith,
  have h' := int.nat_abs_pos_of_ne_zero h,
  linarith,
  assumption_mod_cast,
end

lemma eq_of_le_and_ge {a : ℤ} {b : ℤ} (a_le_b : a ≤ b) (b_le_a : b ≤ a) : a = b :=
begin
  replace a_le_b := eq_or_lt_of_le a_le_b,
  replace b_le_a := eq_or_lt_of_le b_le_a,
  cases a_le_b,
  assumption,
  cases b_le_a,
  symmetry,
  assumption,
  linarith,
end

lemma eq_or_lt_or_gt (a : ℤ) (b : ℤ) : a = b ∨ a < b ∨ a > b :=
begin
  by_cases a_le_b : a ≤ b,
  by_cases a_eq_b : a = b, left, exact a_eq_b,
  right, left, exact lt_of_le_of_ne a_le_b a_eq_b,
  right, right, linarith,
end

lemma real_eq_or_lt_or_gt (a : ℝ) (b : ℝ) : a = b ∨ a < b ∨ a > b :=
begin
  by_cases a_le_b : a ≤ b,
  by_cases a_eq_b : a = b, left, exact a_eq_b,
  right, left, exact lt_of_le_of_ne a_le_b a_eq_b,
  right, right, linarith,
end

lemma nat_eq_or_lt_or_gt (a : ℕ) (b : ℕ) : a = b ∨ a < b ∨ a > b :=
begin
  by_cases a_le_b : a ≤ b,
by_cases a_eq_b : a = b, left, exact a_eq_b,
right, left, exact lt_of_le_of_ne a_le_b a_eq_b,
right, right, linarith,
end

lemma floor_val {x : ℝ} {a : ℤ} (h : ↑a ≤ x) (h2 : x < ↑a + 1) : int.floor(x) = a :=
begin
  have floor_mono_h := int.floor_mono h,
  have floor_a_eq_a : int.floor(a : ℝ) = a := int.floor_coe a,
  rw floor_a_eq_a at floor_mono_h,
  have floor_x_le_x := int.floor_le x,
  have floor_x_lt_a_add_one : ((int.floor(x)) : ℝ) < ↑a + 1 := by linarith,
  replace floor_x_lt_a_add_one : ⌊x⌋ < a + 1 := by assumption_mod_cast,
  linarith,
end

lemma ceil_val {x : ℝ} {a : ℤ} (h : ↑a - 1 < x) (h2 : x ≤ ↑a) : int.ceil(x) = a :=
begin
  have ceil_mono_h2 := int.ceil_mono h2,
  have ceil_a_eq_a : int.ceil(a : ℝ) = a := int.ceil_coe a,
  rw ceil_a_eq_a at ceil_mono_h2,
  have x_le_ceil_x := int.le_ceil x,
  have coe_a_lt_ceil_x_add_one : ↑a < ↑(int.ceil x) + (1 : ℝ) := by linarith,
  have a_lt_ceil_x_add_one : a < (int.ceil x) + 1 := by assumption_mod_cast,
  have a_le_ceil_x := int.le_of_lt_add_one a_lt_ceil_x_add_one,
  linarith,
end

lemma ceil_one : int.ceil((1 : ℝ)) = 1 :=
begin
  have one_sub_one_lt_one : 1 - 1 < 1 := by linarith,
  have coe_one_sub_one_lt_one : ↑(1 : ℤ) - 1 < (1 : ℝ) := by assumption_mod_cast,
  have one_le_one : 1 ≤ 1 := by refl,
  have coe_one_le_one : (1 : ℝ) ≤ ↑(1 : ℤ) := by assumption_mod_cast,
  exact ceil_val coe_one_sub_one_lt_one coe_one_le_one,
end

lemma mul_div_two_of_even {a : ℤ} (a_is_even : even a) : 2 * (a / 2) = a :=
begin
  rw even_iff_two_dvd at a_is_even,
  have two_ne_zero : (2 : ℤ) ≠ 0 := by linarith,
  have two_times_a_eq_a_times_two : 2 * a = a * 2 := by rw mul_comm,
  symmetry,
  have almost_goal := int.eq_mul_div_of_mul_eq_mul_of_dvd_left two_ne_zero a_is_even two_times_a_eq_a_times_two,
  linarith,
end

lemma mul_div_of_ne_zero {b : ℝ} (a : ℝ) (b_ne_zero : b ≠ 0) : b * (a / b) = a :=
begin
  have h : b = 0 → a = 0 := by {intro b_eq_zero, exfalso, exact b_ne_zero b_eq_zero},
  exact mul_div_cancel_of_imp' h,
end

lemma lt_le_trans {a : ℝ} {b : ℝ} {c : ℝ} (h : a < b) (h' : b ≤ c) : a < c := by linarith
lemma le_lt_trans {a : ℝ} {b : ℝ} {c : ℝ} (h : a ≤ b) (h' : b < c) : a < c := by linarith

lemma nat_le_of_lt_add_one {a : ℕ} {b : ℕ} (h : a < b + 1) : a ≤ b := by linarith

--Vector helper functions
def zero_vector {d : ℕ} : point d := vector.of_fn (λ j, 0)
def int_zero_vector {d : ℕ} : int_point d := vector.of_fn (λ j, 0)
def unit_basis_vector {d : ℕ} (i : fin d) : point d := vector.of_fn (λ j, if(i = j) then 1 else 0)
def neg_unit_basis_vector {d : ℕ} (i : fin d) : point d := vector.of_fn (λ j, if(i=j) then -1 else 0)
def int_unit_basis_vector {d : ℕ} (i : fin d) : int_point d := vector.of_fn (λ j, if(i = j) then 1 else 0)
def int_neg_unit_basis_vector {d : ℕ} (i : fin d) : int_point d := vector.of_fn (λ j, if(i=j) then -1 else 0)

def add_vectors {d : ℕ} (v1 : point d) (v2 : point d) := vector.of_fn(λ j, v1.nth j + v2.nth j)
def add_int_vectors {d : ℕ} (v1 : int_point d) (v2 : int_point d) := vector.of_fn(λ j, v1.nth j + v2.nth j)

lemma add_same_vector {d : ℕ} {v1 : point d} {v2 : point d} (v3 : point d) (h : v1 = v2) : add_vectors v1 v3 = add_vectors v2 v3 :=
begin
  rw [add_vectors, add_vectors],
  apply vector.ext,
  intro i,
  simp,
  rw h,
end

lemma add_vectors_comm {d : ℕ} (v1 : point d) (v2 : point d) : add_vectors v1 v2 = add_vectors v2 v1 :=
begin
  rw [add_vectors, add_vectors],
  apply vector.ext,
  intro i,
  simp only [vector.nth_of_fn],
  rw add_comm,
end

lemma add_int_vectors_comm {d : ℕ} (v1 : int_point d) (v2 : int_point d) : add_int_vectors v1 v2 = add_int_vectors v2 v1 :=
begin
  rw [add_int_vectors, add_int_vectors],
  apply vector.ext,
  intro i,
  simp only [vector.nth_of_fn],
  rw add_comm,
end

lemma add_vectors_assoc {d : ℕ} (v1 : point d) (v2 : point d) (v3 : point d) :
  add_vectors (add_vectors v1 v2) v3 = add_vectors v1 (add_vectors v2 v3) :=
begin
  rw [add_vectors, add_vectors, add_vectors, add_vectors],
  apply vector.ext,
  intro i,
  simp only [vector.nth_of_fn],
  rw add_assoc,
end

lemma add_int_vectors_assoc {d : ℕ} (v1 : int_point d) (v2 : int_point d) (v3 : int_point d) :
  add_int_vectors (add_int_vectors v1 v2) v3 = add_int_vectors v1 (add_int_vectors v2 v3) :=
begin
  rw [add_int_vectors, add_int_vectors, add_int_vectors, add_int_vectors],
  apply vector.ext,
  intro i,
  simp only [vector.nth_of_fn],
  rw add_assoc,
end

lemma remove_same_vector {d : ℕ} {v1 : point d} {v2 : point d} {v3 : point d} (h : add_vectors v1 v3 = add_vectors v2 v3) : v1 = v2 :=
begin
  apply vector.ext,
  intro i,
  have h' : (add_vectors v1 v3).nth i = (add_vectors v2 v3).nth i := by rw h,
  rw [add_vectors, add_vectors] at h',
  simp only [vector.nth_of_fn] at h',
  linarith,
end

lemma unit_basis_vector_add_neg_unit_basis_vector_eq_zero {d : ℕ} (i : fin d) :
  add_vectors (unit_basis_vector i) (neg_unit_basis_vector i) = zero_vector :=
begin
  apply vector.ext,
  intro j,
  rw [neg_unit_basis_vector, unit_basis_vector, add_vectors, zero_vector],
  simp only [vector.nth_of_fn],
  by_cases i_eq_j : i = j, {rw i_eq_j, simp only [if_true, eq_self_iff_true, add_right_neg],},
  rw if_neg i_eq_j,
  simp only [ite_eq_right_iff, zero_add, neg_eq_zero, one_ne_zero],
  exact i_eq_j,
end

lemma add_zero_vector {d : ℕ} (v : point d) : add_vectors v zero_vector = v :=
begin
  rw [zero_vector, add_vectors],
  simp only [add_zero, vector.of_fn_nth, vector.nth_of_fn],
end

lemma zero_vector_add {d : ℕ} (v : point d) : add_vectors zero_vector v = v :=
begin
  rw [zero_vector, add_vectors],
  simp only [zero_add, vector.of_fn_nth, vector.nth_of_fn],
end

def scaled_basis_vector {d : ℕ} (scalar : ℝ) (i : fin d) : point d := vector.of_fn (λ j, if(i = j) then scalar else 0)
def int_scaled_basis_vector {d : ℕ} (scalar : ℤ) (i : fin d) : int_point d := vector.of_fn (λ j, if(i = j) then scalar else 0)
def double_int_vector {d : ℕ} (x : int_point d) : int_point d := vector.of_fn (λ j : fin d, 2 * (x.nth j))

--Mod one helper functions

/-
Note: There's no point in trying to build a computational version of eq_mod_one because it would require real equality which
isn't computable
-/
def eq_mod_one (a : ℝ) (b : ℝ) : Prop := ∃ a_floor : ℤ, ∃ b_floor : ℤ, ∃ y : ℝ, 0 ≤ y ∧ y < 1 ∧ a = a_floor + y ∧ b = b_floor + y
def ne_mod_one (a : ℝ) (b : ℝ) : Prop := ¬(eq_mod_one a b)

lemma eq_mod_one_reflexive (a : ℝ) : eq_mod_one a a :=
begin
  rw eq_mod_one,
  have floor_le_fact := int.floor_le a,
  have lt_floor_add_one_fact := int.lt_floor_add_one a,
  use [int.floor(a), int.floor(a), a - ↑(int.floor(a))],
  exact ⟨by linarith, by linarith, by linarith, by linarith⟩,
end

lemma eq_mod_one_symmetric {a : ℝ} {b : ℝ} (h : eq_mod_one a b) : eq_mod_one b a :=
begin
  rw eq_mod_one,
  rw eq_mod_one at h,
  rcases h with ⟨a_floor, b_floor, y, zero_le_y, y_lt_one, a_eq_y_mod_one, b_eq_y_mod_one⟩,
  use [b_floor, a_floor, y],
  exact ⟨zero_le_y, y_lt_one, b_eq_y_mod_one, a_eq_y_mod_one⟩,
end

lemma eq_mod_one_transitive {a : ℝ} {b : ℝ} {c : ℝ} (h1 : eq_mod_one a b) (h2 : eq_mod_one b c) : eq_mod_one a c :=
begin
  rw eq_mod_one at h1,
  rcases h1 with ⟨a_floor, b_floor, y, zero_le_y, y_lt_one, a_eq_y_mod_one, b_eq_y_mod_one⟩,
  rcases h2 with ⟨b_floor', c_floor, y', zero_le_y', y'_lt_one, b_eq_y', c_eq_y_mod_one⟩,
  have b_floor_eq_b_floor' : b_floor = b_floor' :=
    begin
      have b_floor_add_y_eq_b_floor'_add_y' : y + ↑b_floor = y' + ↑b_floor' := by linarith,
      have floor_mono_fact := floor_mono_eq b_floor_add_y_eq_b_floor'_add_y',
      have floor_add_int_fact1 := int.floor_add_int y b_floor,
      have floor_add_int_fact2 := int.floor_add_int y' b_floor',
      rw [floor_add_int_fact1, floor_add_int_fact2] at floor_mono_fact,

      replace zero_le_y : ↑(0 : ℤ) ≤ y := by assumption_mod_cast,
      replace y_lt_one : y < ↑(0 : ℤ) + 1 :=
        begin
          have coe_goal : y < 0 + 1 := by linarith,
          assumption_mod_cast,
        end,
      have floor_y_eq_zero := floor_val zero_le_y y_lt_one,

      replace zero_le_y' : ↑(0 : ℤ) ≤ y' := by assumption_mod_cast,
      replace y'_lt_one : y' < ↑(0 : ℤ) + 1 :=
        begin
          have coe_goal : y' < 0 + 1 := by linarith,
          assumption_mod_cast,
        end,
      have floor_y'_eq_zero := floor_val zero_le_y' y'_lt_one,

      rw [floor_y_eq_zero, floor_y'_eq_zero] at floor_mono_fact,
      simp at floor_mono_fact,
      exact floor_mono_fact,
    end,
  have y_eq_y' : y = y' :=
    begin
      have b_defs : ↑b_floor + y = ↑b_floor' + y' := by linarith,
      rw b_floor_eq_b_floor' at b_defs,
      linarith,
    end,
  rw ← y_eq_y' at c_eq_y_mod_one,
  rw eq_mod_one,
  use [a_floor, c_floor, y],
  exact ⟨zero_le_y, y_lt_one, a_eq_y_mod_one, c_eq_y_mod_one⟩,
end

lemma add_mod_eq_add_mod_right {a : ℝ} {b : ℝ} {c : ℝ} (h1 : eq_mod_one a b) : eq_mod_one (a + c) (b + c) :=
begin
  rw eq_mod_one at h1,
  rcases h1 with ⟨a_floor, b_floor, y, zero_le_y, y_lt_one, a_val, b_val⟩,
  rw eq_mod_one,
  have floor_le_fact := int.floor_le (y + c),
  have lt_floor_add_one_fact := int.lt_floor_add_one (y + c),
  have floor_c_le_c := int.floor_le c,
  have c_lt_floor_c_add_one := int.lt_floor_add_one c,
  by_cases y_add_c_remainder_lt_one : y + c - ↑(int.floor c) < 1,
  { use [a_floor + int.floor(c), b_floor + int.floor(c), y + c - ↑(int.floor c)],
    exact ⟨by linarith, by linarith, by {simp, linarith,}, by {simp, linarith,}⟩,
  },
  use [a_floor + int.floor(c) + 1, b_floor + int.floor(c) + 1, y + c - ↑(int.floor c) - 1],
  exact ⟨by linarith, by linarith, by {simp, linarith}, by {simp, linarith,}⟩,
end

lemma subst_summand_eq_mod_one {a : ℝ} {b : ℝ} {c : ℝ} {d : ℝ} : eq_mod_one a d → eq_mod_one (a + b) c → eq_mod_one (d + b) c :=
begin
  intros a_eq_d_mod_one,
  rcases a_eq_d_mod_one with ⟨a_floor, d_floor, y, zero_le_y, y_lt_one, a_def, d_def⟩,
  rintro ⟨a_add_b_floor, c_floor, y', zero_le_y', y'_lt_one, a_add_b_def, c_def⟩,
  rw eq_mod_one,
  use [a_add_b_floor - a_floor + d_floor, c_floor, y', zero_le_y', y'_lt_one, by {simp only [int.cast_add, int.cast_sub], linarith}, c_def],
end

lemma eq_mod_one_int_add {a : ℝ} {b : ℤ} {c : ℝ} : eq_mod_one a c → eq_mod_one (a + ↑b) c :=
begin
  rw [eq_mod_one, eq_mod_one],
  rintro ⟨a_floor, c_floor, y, zero_le_y, y_lt_one, a_eq_a_floor_add_y, c_eq_c_floor_add_y⟩,
  use [a_floor + b, c_floor, y, zero_le_y, y_lt_one],
  split,
  { rw a_eq_a_floor_add_y,
    finish,
  },
  exact c_eq_c_floor_add_y,
end

lemma eq_mod_one_int_sub {a : ℝ} {b : ℤ} {c : ℝ} : eq_mod_one a c → eq_mod_one (a - ↑b) c :=
begin
  have b_id : -↑b = (↑(-b) : ℝ) := by finish,
  rw [sub_eq_add_neg a ↑b, b_id],
  exact eq_mod_one_int_add,
end

--Helpers for finsets
lemma sorted_list_to_finset_lemma :
  ∀ l : list ℝ, list.sorted (≤) l → l.nodup → finset.sort (≤) l.to_finset = l :=
begin
  intros l l_sorted l_nodup,
  cases l with l_hd l_tl,
  { simp only [list.to_finset_nil],
    have emptyset_to_list_eq_nil : finset.to_list ∅ = (list.nil : list ℝ) := finset.to_list_empty,
    have emptyset_sort_perm_emptyset_to_list := finset.sort_perm_to_list has_le.le (∅ : finset ℝ),
    rw finset.to_list_empty at emptyset_sort_perm_emptyset_to_list,
    exact list.perm.eq_nil emptyset_sort_perm_emptyset_to_list,
  },
  have finset_sort_output_nodup : (finset.sort (≤) (l_hd :: l_tl).to_finset).nodup :=
    finset.sort_nodup (≤) (l_hd :: l_tl).to_finset,
  have perm_goal : finset.sort (≤) (l_hd :: l_tl).to_finset ~ l_hd :: l_tl :=
    begin
      rw list.perm_ext finset_sort_output_nodup l_nodup,
      intro a,
      rw [← list.to_finset_eq l_nodup],
      simp only [finset.mem_sort, multiset.mem_coe, finset.mem_mk],
    end,
  have finset_to_list_ordered_output_sorted := finset.sort_sorted has_le.le ((l_hd :: l_tl).to_finset),
  exact list.eq_of_perm_of_sorted perm_goal finset_to_list_ordered_output_sorted l_sorted,
end