/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison
-/
import algebraic_geometry.prime_spectrum.basic
import algebra.category.CommRing.colimits
import algebra.category.CommRing.limits
import topology.sheaves.local_predicate
import ring_theory.localization.at_prime
import ring_theory.subring.basic

/-!
# The structure sheaf on `prime_spectrum R`.

We define the structure sheaf on `Top.of (prime_spectrum R)`, for a commutative ring `R` and prove
basic properties about it. We define this as a subsheaf of the sheaf of dependent functions into the
localizations, cut out by the condition that the function must be locally equal to a ratio of
elements of `R`.

Because the condition "is equal to a fraction" passes to smaller open subsets,
the subset of functions satisfying this condition is automatically a subpresheaf.
Because the condition "is locally equal to a fraction" is local,
it is also a subsheaf.

(It may be helpful to refer back to `topology.sheaves.sheaf_of_functions`,
where we show that dependent functions into any type family form a sheaf,
and also `topology.sheaves.local_predicate`, where we characterise the predicates
which pick out sub-presheaves and sub-sheaves of these sheaves.)

We also set up the ring structure, obtaining
`structure_sheaf R : sheaf CommRing (Top.of (prime_spectrum R))`.

We then construct two basic isomorphisms, relating the structure sheaf to the underlying ring `R`.
First, `structure_sheaf.stalk_iso` gives an isomorphism between the stalk of the structure sheaf
at a point `p` and the localization of `R` at the prime ideal `p`. Second,
`structure_sheaf.basic_open_iso` gives an isomorphism between the structure sheaf on `basic_open f`
and the localization of `R` at the submonoid of powers of `f`.

## References

* [Robin Hartshorne, *Algebraic Geometry*][Har77]

-/

universe u

noncomputable theory

variables (R : Type u) [comm_ring R]

open Top
open topological_space
open category_theory
open opposite

namespace algebraic_geometry

/--
The prime spectrum, just as a topological space.
-/
def prime_spectrum.Top : Top := Top.of (prime_spectrum R)

namespace structure_sheaf

/--
The type family over `prime_spectrum R` consisting of the localization over each point.
-/
@[derive [comm_ring, local_ring]]
def localizations (P : prime_spectrum.Top R) : Type u := localization.at_prime P.as_ideal

instance (P : prime_spectrum.Top R) : inhabited (localizations R P) :=
⟨1⟩

instance (U : opens (prime_spectrum.Top R)) (x : U) :
  algebra R (localizations R x) :=
localization.algebra

instance (U : opens (prime_spectrum.Top R)) (x : U) :
  is_localization.at_prime (localizations R x) (x : prime_spectrum.Top R).as_ideal :=
localization.is_localization

variables {R}

/--
The predicate saying that a dependent function on an open `U` is realised as a fixed fraction
`r / s` in each of the stalks (which are localizations at various prime ideals).
-/
def is_fraction {U : opens (prime_spectrum.Top R)} (f : Π x : U, localizations R x) : Prop :=
∃ (r s : R), ∀ x : U,
  ¬ (s ∈ x.1.as_ideal) ∧ f x * algebra_map _ _ s = algebra_map _ _ r

lemma is_fraction.eq_mk' {U : opens (prime_spectrum.Top R)} {f : Π x : U, localizations R x}
  (hf : is_fraction f) :
  ∃ (r s : R) , ∀ x : U, ∃ (hs : s ∉ x.1.as_ideal), f x =
    is_localization.mk' (localization.at_prime _) r
      (⟨s, hs⟩ : (x : prime_spectrum.Top R).as_ideal.prime_compl) :=
begin
  rcases hf with ⟨r, s, h⟩,
  refine ⟨r, s, λ x, ⟨(h x).1, (is_localization.mk'_eq_iff_eq_mul.mpr _).symm⟩⟩,
  exact (h x).2.symm,
end

variables (R)

/--
The predicate `is_fraction` is "prelocal",
in the sense that if it holds on `U` it holds on any open subset `V` of `U`.
-/
def is_fraction_prelocal : prelocal_predicate (localizations R) :=
{ pred := λ U f, is_fraction f,
  res := by { rintro V U i f ⟨r, s, w⟩, exact ⟨r, s, λ x, w (i x)⟩ } }

/--
We will define the structure sheaf as
the subsheaf of all dependent functions in `Π x : U, localizations R x`
consisting of those functions which can locally be expressed as a ratio of
(the images in the localization of) elements of `R`.

Quoting Hartshorne:

For an open set $U ⊆ Spec A$, we define $𝒪(U)$ to be the set of functions
$s : U → ⨆_{𝔭 ∈ U} A_𝔭$, such that $s(𝔭) ∈ A_𝔭$ for each $𝔭$,
and such that $s$ is locally a quotient of elements of $A$:
to be precise, we require that for each $𝔭 ∈ U$, there is a neighborhood $V$ of $𝔭$,
contained in $U$, and elements $a, f ∈ A$, such that for each $𝔮 ∈ V, f ∉ 𝔮$,
and $s(𝔮) = a/f$ in $A_𝔮$.

Now Hartshorne had the disadvantage of not knowing about dependent functions,
so we replace his circumlocution about functions into a disjoint union with
`Π x : U, localizations x`.
-/
def is_locally_fraction : local_predicate (localizations R) :=
(is_fraction_prelocal R).sheafify

@[simp]
lemma is_locally_fraction_pred
  {U : opens (prime_spectrum.Top R)} (f : Π x : U, localizations R x) :
  (is_locally_fraction R).pred f =
  ∀ x : U, ∃ (V) (m : x.1 ∈ V) (i : V ⟶ U),
  ∃ (r s : R), ∀ y : V,
  ¬ (s ∈ y.1.as_ideal) ∧
    f (i y : U) * algebra_map _ _ s = algebra_map _ _ r :=
rfl

/--
The functions satisfying `is_locally_fraction` form a subring.
-/
def sections_subring (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  subring (Π x : unop U, localizations R x) :=
{ carrier := { f | (is_locally_fraction R).pred f },
  zero_mem' :=
  begin
    refine λ x, ⟨unop U, x.2, 𝟙 _, 0, 1, λ y, ⟨_, _⟩⟩,
    { rw ←ideal.ne_top_iff_one, exact y.1.is_prime.1, },
    { simp, },
  end,
  one_mem' :=
  begin
    refine λ x, ⟨unop U, x.2, 𝟙 _, 1, 1, λ y, ⟨_, _⟩⟩,
    { rw ←ideal.ne_top_iff_one, exact y.1.is_prime.1, },
    { simp, },
  end,
  add_mem' :=
  begin
    intros a b ha hb x,
    rcases ha x with ⟨Va, ma, ia, ra, sa, wa⟩,
    rcases hb x with ⟨Vb, mb, ib, rb, sb, wb⟩,
    refine ⟨Va ⊓ Vb, ⟨ma, mb⟩, opens.inf_le_left _ _ ≫ ia, ra * sb + rb * sa, sa * sb, _⟩,
    intro y,
    rcases wa (opens.inf_le_left _ _ y) with ⟨nma, wa⟩,
    rcases wb (opens.inf_le_right _ _ y) with ⟨nmb, wb⟩,
    fsplit,
    { intro H, cases y.1.is_prime.mem_or_mem H; contradiction, },
    { simp only [add_mul, ring_hom.map_add, pi.add_apply, ring_hom.map_mul],
      erw [←wa, ←wb],
      simp only [mul_assoc],
      congr' 2,
      rw [mul_comm], refl, }
  end,
  neg_mem' :=
  begin
    intros a ha x,
    rcases ha x with ⟨V, m, i, r, s, w⟩,
    refine ⟨V, m, i, -r, s, _⟩,
    intro y,
    rcases w y with ⟨nm, w⟩,
    fsplit,
    { exact nm, },
    { simp only [ring_hom.map_neg, pi.neg_apply],
      erw [←w],
      simp only [neg_mul], }
  end,
  mul_mem' :=
  begin
    intros a b ha hb x,
    rcases ha x with ⟨Va, ma, ia, ra, sa, wa⟩,
    rcases hb x with ⟨Vb, mb, ib, rb, sb, wb⟩,
    refine ⟨Va ⊓ Vb, ⟨ma, mb⟩, opens.inf_le_left _ _ ≫ ia, ra * rb, sa * sb, _⟩,
    intro y,
    rcases wa (opens.inf_le_left _ _ y) with ⟨nma, wa⟩,
    rcases wb (opens.inf_le_right _ _ y) with ⟨nmb, wb⟩,
    fsplit,
    { intro H, cases y.1.is_prime.mem_or_mem H; contradiction, },
    { simp only [pi.mul_apply, ring_hom.map_mul],
      erw [←wa, ←wb],
      simp only [mul_left_comm, mul_assoc, mul_comm],
      refl, }
  end, }

end structure_sheaf

open structure_sheaf

/--
The structure sheaf (valued in `Type`, not yet `CommRing`) is the subsheaf consisting of
functions satisfying `is_locally_fraction`.
-/
def structure_sheaf_in_Type : sheaf (Type u) (prime_spectrum.Top R):=
subsheaf_to_Types (is_locally_fraction R)

instance comm_ring_structure_sheaf_in_Type_obj (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  comm_ring ((structure_sheaf_in_Type R).1.obj U) :=
(sections_subring R U).to_comm_ring

open _root_.prime_spectrum

/--
The structure presheaf, valued in `CommRing`, constructed by dressing up the `Type` valued
structure presheaf.
-/
@[simps]
def structure_presheaf_in_CommRing : presheaf CommRing (prime_spectrum.Top R) :=
{ obj := λ U, CommRing.of ((structure_sheaf_in_Type R).1.obj U),
  map := λ U V i,
  { to_fun := ((structure_sheaf_in_Type R).1.map i),
    map_zero' := rfl,
    map_add' := λ x y, rfl,
    map_one' := rfl,
    map_mul' := λ x y, rfl, }, }

/--
Some glue, verifying that that structure presheaf valued in `CommRing` agrees
with the `Type` valued structure presheaf.
-/
def structure_presheaf_comp_forget :
  structure_presheaf_in_CommRing R ⋙ (forget CommRing) ≅ (structure_sheaf_in_Type R).1 :=
nat_iso.of_components
  (λ U, iso.refl _)
  (by tidy)

open Top.presheaf

/--
The structure sheaf on $Spec R$, valued in `CommRing`.

This is provided as a bundled `SheafedSpace` as `Spec.SheafedSpace R` later.
-/
def Spec.structure_sheaf : sheaf CommRing (prime_spectrum.Top R) :=
⟨structure_presheaf_in_CommRing R,
  -- We check the sheaf condition under `forget CommRing`.
  (is_sheaf_iff_is_sheaf_comp _ _).mpr
    (is_sheaf_of_iso (structure_presheaf_comp_forget R).symm
      (structure_sheaf_in_Type R).property)⟩

open Spec (structure_sheaf)

namespace structure_sheaf

@[simp] lemma res_apply (U V : opens (prime_spectrum.Top R)) (i : V ⟶ U)
  (s : (structure_sheaf R).1.obj (op U)) (x : V) :
  ((structure_sheaf R).1.map i.op s).1 x = (s.1 (i x) : _) :=
rfl

/-

Notation in this comment

X = Spec R
OX = structure sheaf

In the following we construct an isomorphism between OX_p and R_p given any point p corresponding
to a prime ideal in R.

We do this via 8 steps:

1. def const (f g : R) (V) (hv : V ≤ D_g) : OX(V) [for api]
2. def to_open (U) : R ⟶ OX(U)
3. [2] def to_stalk (p : Spec R) : R ⟶ OX_p
4. [2] def to_basic_open (f : R) : R_f ⟶ OX(D_f)
5. [3] def localization_to_stalk (p : Spec R) : R_p ⟶ OX_p
6. def open_to_localization (U) (p) (hp : p ∈ U) : OX(U) ⟶ R_p
7. [6] def stalk_to_fiber_ring_hom (p : Spec R) : OX_p ⟶ R_p
8. [5,7] def stalk_iso (p : Spec R) : OX_p ≅ R_p

In the square brackets we list the dependencies of a construction on the previous steps.

-/

/-- The section of `structure_sheaf R` on an open `U` sending each `x ∈ U` to the element
`f/g` in the localization of `R` at `x`. -/
def const (f g : R) (U : opens (prime_spectrum.Top R))
  (hu : ∀ x ∈ U, g ∈ (x : prime_spectrum.Top R).as_ideal.prime_compl) :
  (structure_sheaf R).1.obj (op U) :=
⟨λ x, is_localization.mk' _ f ⟨g, hu x x.2⟩,
 λ x, ⟨U, x.2, 𝟙 _, f, g, λ y, ⟨hu y y.2, is_localization.mk'_spec _ _ _⟩⟩⟩

@[simp] lemma const_apply (f g : R) (U : opens (prime_spectrum.Top R))
  (hu : ∀ x ∈ U, g ∈ (x : prime_spectrum.Top R).as_ideal.prime_compl) (x : U) :
  (const R f g U hu).1 x = is_localization.mk' _ f ⟨g, hu x x.2⟩ :=
rfl

lemma const_apply' (f g : R) (U : opens (prime_spectrum.Top R))
  (hu : ∀ x ∈ U, g ∈ (x : prime_spectrum.Top R).as_ideal.prime_compl) (x : U)
  (hx : g ∈ (as_ideal (x : prime_spectrum.Top R)).prime_compl) :
  (const R f g U hu).1 x = is_localization.mk' _ f ⟨g, hx⟩ :=
rfl

lemma exists_const (U) (s : (structure_sheaf R).1.obj (op U)) (x : prime_spectrum.Top R)
  (hx : x ∈ U) :
  ∃ (V : opens (prime_spectrum.Top R)) (hxV : x ∈ V) (i : V ⟶ U) (f g : R) hg,
  const R f g V hg = (structure_sheaf R).1.map i.op s :=
let ⟨V, hxV, iVU, f, g, hfg⟩ := s.2 ⟨x, hx⟩ in
⟨V, hxV, iVU, f, g, λ y hyV, (hfg ⟨y, hyV⟩).1, subtype.eq $ funext $ λ y,
is_localization.mk'_eq_iff_eq_mul.2 $ eq.symm $ (hfg y).2⟩

@[simp] lemma res_const (f g : R) (U hu V hv i) :
  (structure_sheaf R).1.map i (const R f g U hu) = const R f g V hv :=
rfl

lemma res_const' (f g : R) (V hv) :
  (structure_sheaf R).1.map (hom_of_le hv).op (const R f g (basic_open g) (λ _, id)) =
    const R f g V hv :=
rfl

lemma const_zero (f : R) (U hu) : const R 0 f U hu = 0 :=
subtype.eq $ funext $ λ x, is_localization.mk'_eq_iff_eq_mul.2 $
by erw [ring_hom.map_zero, subtype.val_eq_coe, subring.coe_zero, pi.zero_apply, zero_mul]

lemma const_self (f : R) (U hu) : const R f f U hu = 1 :=
subtype.eq $ funext $ λ x, is_localization.mk'_self _ _

lemma const_one (U) : const R 1 1 U (λ p _, submonoid.one_mem _) = 1 :=
const_self R 1 U _

lemma const_add (f₁ f₂ g₁ g₂ : R) (U hu₁ hu₂) :
  const R f₁ g₁ U hu₁ + const R f₂ g₂ U hu₂ =
  const R (f₁ * g₂ + f₂ * g₁) (g₁ * g₂) U (λ x hx, submonoid.mul_mem _ (hu₁ x hx) (hu₂ x hx)) :=
subtype.eq $ funext $ λ x, eq.symm $
by convert is_localization.mk'_add f₁ f₂ ⟨g₁, hu₁ x x.2⟩ ⟨g₂, hu₂ x x.2⟩

lemma const_mul (f₁ f₂ g₁ g₂ : R) (U hu₁ hu₂) :
  const R f₁ g₁ U hu₁ * const R f₂ g₂ U hu₂ =
  const R (f₁ * f₂) (g₁ * g₂) U (λ x hx, submonoid.mul_mem _ (hu₁ x hx) (hu₂ x hx)) :=
subtype.eq $ funext $ λ x, eq.symm $
by convert is_localization.mk'_mul _ f₁ f₂ ⟨g₁, hu₁ x x.2⟩ ⟨g₂, hu₂ x x.2⟩

lemma const_ext {f₁ f₂ g₁ g₂ : R} {U hu₁ hu₂} (h : f₁ * g₂ = f₂ * g₁) :
  const R f₁ g₁ U hu₁ = const R f₂ g₂ U hu₂ :=
subtype.eq $ funext $ λ x, is_localization.mk'_eq_of_eq h.symm

lemma const_congr {f₁ f₂ g₁ g₂ : R} {U hu} (hf : f₁ = f₂) (hg : g₁ = g₂) :
  const R f₁ g₁ U hu = const R f₂ g₂ U (hg ▸ hu) :=
by substs hf hg

lemma const_mul_rev (f g : R) (U hu₁ hu₂) :
  const R f g U hu₁ * const R g f U hu₂ = 1 :=
by rw [const_mul, const_congr R rfl (mul_comm g f), const_self]

lemma const_mul_cancel (f g₁ g₂ : R) (U hu₁ hu₂) :
  const R f g₁ U hu₁ * const R g₁ g₂ U hu₂ = const R f g₂ U hu₂ :=
by { rw [const_mul, const_ext], rw mul_assoc }

lemma const_mul_cancel' (f g₁ g₂ : R) (U hu₁ hu₂) :
  const R g₁ g₂ U hu₂ * const R f g₁ U hu₁ = const R f g₂ U hu₂ :=
by rw [mul_comm, const_mul_cancel]

/-- The canonical ring homomorphism interpreting an element of `R` as
a section of the structure sheaf. -/
def to_open (U : opens (prime_spectrum.Top R)) :
  CommRing.of R ⟶ (structure_sheaf R).1.obj (op U) :=
{ to_fun := λ f, ⟨λ x, algebra_map R _ f,
    λ x, ⟨U, x.2, 𝟙 _, f, 1, λ y, ⟨(ideal.ne_top_iff_one _).1 y.1.2.1,
      by { rw [ring_hom.map_one, mul_one], refl } ⟩⟩⟩,
  map_one' := subtype.eq $ funext $ λ x, ring_hom.map_one _,
  map_mul' := λ f g, subtype.eq $ funext $ λ x, ring_hom.map_mul _ _ _,
  map_zero' := subtype.eq $ funext $ λ x, ring_hom.map_zero _,
  map_add' := λ f g, subtype.eq $ funext $ λ x, ring_hom.map_add _ _ _ }

@[simp] lemma to_open_res (U V : opens (prime_spectrum.Top R)) (i : V ⟶ U) :
  to_open R U ≫ (structure_sheaf R).1.map i.op = to_open R V :=
rfl

@[simp] lemma to_open_apply (U : opens (prime_spectrum.Top R)) (f : R) (x : U) :
  (to_open R U f).1 x = algebra_map _ _ f :=
rfl

lemma to_open_eq_const (U : opens (prime_spectrum.Top R)) (f : R) : to_open R U f =
  const R f 1 U (λ x _, (ideal.ne_top_iff_one _).1 x.2.1) :=
subtype.eq $ funext $ λ x, eq.symm $ is_localization.mk'_one _ f

/-- The canonical ring homomorphism interpreting an element of `R` as an element of
the stalk of `structure_sheaf R` at `x`. -/
def to_stalk (x : prime_spectrum.Top R) : CommRing.of R ⟶ (structure_sheaf R).1.stalk x :=
(to_open R ⊤ ≫ (structure_sheaf R).1.germ ⟨x, ⟨⟩⟩ : _)

@[simp] lemma to_open_germ (U : opens (prime_spectrum.Top R)) (x : U) :
  to_open R U ≫ (structure_sheaf R).1.germ x =
  to_stalk R x :=
by { rw [← to_open_res R ⊤ U (hom_of_le le_top : U ⟶ ⊤), category.assoc, presheaf.germ_res], refl }

@[simp] lemma germ_to_open (U : opens (prime_spectrum.Top R)) (x : U) (f : R) :
  (structure_sheaf R).1.germ x (to_open R U f) = to_stalk R x f :=
by { rw ← to_open_germ, refl }

lemma germ_to_top (x : prime_spectrum.Top R) (f : R) :
  (structure_sheaf R).1.germ (⟨x, trivial⟩ : (⊤ : opens (prime_spectrum.Top R)))
    (to_open R ⊤ f) =
    to_stalk R x f :=
rfl

lemma is_unit_to_basic_open_self (f : R) : is_unit (to_open R (basic_open f) f) :=
is_unit_of_mul_eq_one _ (const R 1 f (basic_open f) (λ _, id)) $
by rw [to_open_eq_const, const_mul_rev]

lemma is_unit_to_stalk (x : prime_spectrum.Top R) (f : x.as_ideal.prime_compl) :
  is_unit (to_stalk R x (f : R)) :=
by { erw ← germ_to_open R (basic_open (f : R)) ⟨x, f.2⟩ (f : R),
    exact ring_hom.is_unit_map _ (is_unit_to_basic_open_self R f) }

/-- The canonical ring homomorphism from the localization of `R` at `p` to the stalk
of the structure sheaf at the point `p`. -/
def localization_to_stalk (x : prime_spectrum.Top R) :
  CommRing.of (localization.at_prime x.as_ideal) ⟶ (structure_sheaf R).1.stalk x :=
show localization.at_prime x.as_ideal →+* _, from
is_localization.lift (is_unit_to_stalk R x)

@[simp] lemma localization_to_stalk_of (x : prime_spectrum.Top R) (f : R) :
  localization_to_stalk R x (algebra_map _ (localization _) f) = to_stalk R x f :=
is_localization.lift_eq _ f

@[simp] lemma localization_to_stalk_mk' (x : prime_spectrum.Top R) (f : R)
  (s : (as_ideal x).prime_compl) :
  localization_to_stalk R x (is_localization.mk' _ f s : localization _) =
  (structure_sheaf R).1.germ (⟨x, s.2⟩ : basic_open (s : R))
    (const R f s (basic_open s) (λ _, id)) :=
(is_localization.lift_mk'_spec _ _ _ _).2 $
by erw [← germ_to_open R (basic_open s) ⟨x, s.2⟩, ← germ_to_open R (basic_open s) ⟨x, s.2⟩,
    ← ring_hom.map_mul, to_open_eq_const, to_open_eq_const, const_mul_cancel']

/-- The ring homomorphism that takes a section of the structure sheaf of `R` on the open set `U`,
implemented as a subtype of dependent functions to localizations at prime ideals, and evaluates
the section on the point corresponding to a given prime ideal. -/
def open_to_localization (U : opens (prime_spectrum.Top R)) (x : prime_spectrum.Top R)
  (hx : x ∈ U) :
  (structure_sheaf R).1.obj (op U) ⟶ CommRing.of (localization.at_prime x.as_ideal) :=
{ to_fun := λ s, (s.1 ⟨x, hx⟩ : _),
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

@[simp] lemma coe_open_to_localization (U : opens (prime_spectrum.Top R)) (x : prime_spectrum.Top R)
  (hx : x ∈ U) :
  (open_to_localization R U x hx :
    (structure_sheaf R).1.obj (op U) → localization.at_prime x.as_ideal) =
  (λ s, (s.1 ⟨x, hx⟩ : _)) :=
rfl

lemma open_to_localization_apply (U : opens (prime_spectrum.Top R)) (x : prime_spectrum.Top R)
  (hx : x ∈ U)
  (s : (structure_sheaf R).1.obj (op U)) :
  open_to_localization R U x hx s = (s.1 ⟨x, hx⟩ : _) :=
rfl

/-- The ring homomorphism from the stalk of the structure sheaf of `R` at a point corresponding to
a prime ideal `p` to the localization of `R` at `p`,
formed by gluing the `open_to_localization` maps. -/
def stalk_to_fiber_ring_hom (x : prime_spectrum.Top R) :
  (structure_sheaf R).1.stalk x ⟶ CommRing.of (localization.at_prime x.as_ideal) :=
limits.colimit.desc (((open_nhds.inclusion x).op) ⋙ (structure_sheaf R).1)
  { X := _,
    ι :=
    { app := λ U, open_to_localization R ((open_nhds.inclusion _).obj (unop U)) x (unop U).2, } }

@[simp] lemma germ_comp_stalk_to_fiber_ring_hom (U : opens (prime_spectrum.Top R)) (x : U) :
  (structure_sheaf R).1.germ x ≫ stalk_to_fiber_ring_hom R x =
  open_to_localization R U x x.2 :=
limits.colimit.ι_desc _ _

@[simp] lemma stalk_to_fiber_ring_hom_germ' (U : opens (prime_spectrum.Top R))
  (x : prime_spectrum.Top R) (hx : x ∈ U) (s : (structure_sheaf R).1.obj (op U)) :
  stalk_to_fiber_ring_hom R x ((structure_sheaf R).1.germ ⟨x, hx⟩ s) = (s.1 ⟨x, hx⟩ : _) :=
ring_hom.ext_iff.1 (germ_comp_stalk_to_fiber_ring_hom R U ⟨x, hx⟩ : _) s

@[simp] lemma stalk_to_fiber_ring_hom_germ (U : opens (prime_spectrum.Top R)) (x : U)
  (s : (structure_sheaf R).1.obj (op U)) :
  stalk_to_fiber_ring_hom R x ((structure_sheaf R).1.germ x s) = s.1 x :=
by { cases x, exact stalk_to_fiber_ring_hom_germ' R U _ _ _ }

@[simp] lemma to_stalk_comp_stalk_to_fiber_ring_hom (x : prime_spectrum.Top R) :
  to_stalk R x ≫ stalk_to_fiber_ring_hom R x = (algebra_map _ _ : R →+* localization _) :=
by { erw [to_stalk, category.assoc, germ_comp_stalk_to_fiber_ring_hom], refl }

@[simp] lemma stalk_to_fiber_ring_hom_to_stalk (x : prime_spectrum.Top R) (f : R) :
  stalk_to_fiber_ring_hom R x (to_stalk R x f) = algebra_map _ (localization _) f :=
ring_hom.ext_iff.1 (to_stalk_comp_stalk_to_fiber_ring_hom R x) _

/-- The ring isomorphism between the stalk of the structure sheaf of `R` at a point `p`
corresponding to a prime ideal in `R` and the localization of `R` at `p`. -/
@[simps] def stalk_iso (x : prime_spectrum.Top R) :
  (structure_sheaf R).1.stalk x ≅ CommRing.of (localization.at_prime x.as_ideal) :=
{ hom := stalk_to_fiber_ring_hom R x,
  inv := localization_to_stalk R x,
  hom_inv_id' := (structure_sheaf R).1.stalk_hom_ext $ λ U hxU,
  begin
    ext s, simp only [comp_apply], rw [id_apply, stalk_to_fiber_ring_hom_germ'],
    obtain ⟨V, hxV, iVU, f, g, hg, hs⟩ := exists_const _ _ s x hxU,
    erw [← res_apply R U V iVU s ⟨x, hxV⟩, ← hs, const_apply, localization_to_stalk_mk'],
    refine (structure_sheaf R).1.germ_ext V hxV (hom_of_le hg) iVU _,
    erw [← hs, res_const']
  end,
  inv_hom_id' := @is_localization.ring_hom_ext R _ x.as_ideal.prime_compl
      (localization.at_prime x.as_ideal) _ _ (localization.at_prime x.as_ideal) _ _
      (ring_hom.comp (stalk_to_fiber_ring_hom R x) (localization_to_stalk R x))
      (ring_hom.id (localization.at_prime _)) $
    by { ext f, simp only [ring_hom.comp_apply, ring_hom.id_apply, localization_to_stalk_of,
                           stalk_to_fiber_ring_hom_to_stalk] } }

instance (x : prime_spectrum R) : is_iso (stalk_to_fiber_ring_hom R x) :=
is_iso.of_iso (stalk_iso R x)

instance (x : prime_spectrum R) : is_iso (localization_to_stalk R x) :=
is_iso.of_iso (stalk_iso R x).symm

@[simp, reassoc] lemma stalk_to_fiber_ring_hom_localization_to_stalk (x : prime_spectrum.Top R) :
  stalk_to_fiber_ring_hom R x ≫ localization_to_stalk R x = 𝟙 _ :=
(stalk_iso R x).hom_inv_id

@[simp, reassoc] lemma localization_to_stalk_stalk_to_fiber_ring_hom (x : prime_spectrum.Top R) :
  localization_to_stalk R x ≫ stalk_to_fiber_ring_hom R x = 𝟙 _ :=
(stalk_iso R x).inv_hom_id

/-- The canonical ring homomorphism interpreting `s ∈ R_f` as a section of the structure sheaf
on the basic open defined by `f ∈ R`. -/
def to_basic_open (f : R) : localization.away f →+*
  (structure_sheaf R).1.obj (op $ basic_open f) :=
is_localization.away.lift f (is_unit_to_basic_open_self R f)

@[simp] lemma to_basic_open_mk' (s f : R) (g : submonoid.powers s) :
  to_basic_open R s (is_localization.mk' (localization.away s) f g) =
  const R f g (basic_open s) (λ x hx, submonoid.powers_subset hx g.2) :=
(is_localization.lift_mk'_spec _ _ _ _).2 $
by rw [to_open_eq_const, to_open_eq_const, const_mul_cancel']

@[simp] lemma localization_to_basic_open (f : R) :
  ring_hom.comp (to_basic_open R f) (algebra_map R (localization.away f)) =
    to_open R (basic_open f) :=
ring_hom.ext $ λ g,
by rw [to_basic_open, is_localization.away.lift, ring_hom.comp_apply, is_localization.lift_eq]

@[simp] lemma to_basic_open_to_map (s f : R) :
  to_basic_open R s (algebra_map R (localization.away s) f) =
    const R f 1 (basic_open s) (λ _ _, submonoid.one_mem _) :=
(is_localization.lift_eq _ _).trans $ to_open_eq_const _ _ _

-- The proof here follows the argument in Hartshorne's Algebraic Geometry, Proposition II.2.2.
lemma to_basic_open_injective (f : R) : function.injective (to_basic_open R f) :=
begin
  intros s t h_eq,
  obtain ⟨a, ⟨b, hb⟩, rfl⟩ := is_localization.mk'_surjective (submonoid.powers f) s,
  obtain ⟨c, ⟨d, hd⟩, rfl⟩ := is_localization.mk'_surjective (submonoid.powers f) t,
  simp only [to_basic_open_mk'] at h_eq,
  rw is_localization.eq,
  -- We know that the fractions `a/b` and `c/d` are equal as sections of the structure sheaf on
  -- `basic_open f`. We need to show that they agree as elements in the localization of `R` at `f`.
  -- This amounts showing that `a * d * r = c * b * r`, for some power `r = f ^ n` of `f`.
  -- We define `I` as the ideal of *all* elements `r` satisfying the above equation.
  let I : ideal R :=
  { carrier := {r : R | a * d * r = c * b * r},
    zero_mem' := by simp only [set.mem_set_of_eq, mul_zero],
    add_mem' := λ r₁ r₂ hr₁ hr₂, by { dsimp at hr₁ hr₂ ⊢, simp only [mul_add, hr₁, hr₂] },
    smul_mem' := λ r₁ r₂ hr₂, by { dsimp at hr₂ ⊢, simp only [mul_comm r₁ r₂, ← mul_assoc, hr₂] }},
  -- Our claim now reduces to showing that `f` is contained in the radical of `I`
  suffices : f ∈ I.radical,
  { cases this with n hn,
    exact ⟨⟨f ^ n, n, rfl⟩, hn⟩ },
  rw [← vanishing_ideal_zero_locus_eq_radical, mem_vanishing_ideal],
  intros p hfp,
  contrapose hfp,
  rw [mem_zero_locus, set.not_subset],
  have := congr_fun (congr_arg subtype.val h_eq) ⟨p,hfp⟩,
  rw [const_apply, const_apply, is_localization.eq] at this,
  cases this with r hr,
  exact ⟨r.1, hr, r.2⟩
end

/-
Auxiliary lemma for surjectivity of `to_basic_open`.
Every section can locally be represented on basic opens `basic_opens g` as a fraction `f/g`
-/
lemma locally_const_basic_open (U : opens (prime_spectrum.Top R))
  (s : (structure_sheaf R).1.obj (op U)) (x : U) :
  ∃ (f g : R) (i : basic_open g ⟶ U), x.1 ∈ basic_open g ∧
    const R f g (basic_open g) (λ y hy, hy) = (structure_sheaf R).1.map i.op s :=
begin
  -- First, any section `s` can be represented as a fraction `f/g` on some open neighborhood of `x`
  -- and we may pass to a `basic_open h`, since these form a basis
  obtain ⟨V, (hxV : x.1 ∈ V.1), iVU, f, g, (hVDg : V ⊆ basic_open g), s_eq⟩ :=
    exists_const R U s x.1 x.2,
  obtain ⟨_, ⟨h, rfl⟩, hxDh, (hDhV : basic_open h ⊆ V)⟩ :=
    is_topological_basis_basic_opens.exists_subset_of_mem_open hxV V.2,
  -- The problem is of course, that `g` and `h` don't need to coincide.
  -- But, since `basic_open h ≤ basic_open g`, some power of `h` must be a multiple of `g`
  cases (basic_open_le_basic_open_iff h g).mp (set.subset.trans hDhV hVDg) with n hn,
  -- Actually, we will need a *nonzero* power of `h`.
  -- This is because we will need the equality `basic_open (h ^ n) = basic_open h`, which only
  -- holds for a nonzero power `n`. We therefore artificially increase `n` by one.
  replace hn := ideal.mul_mem_left (ideal.span {g}) h hn,
  rw [← pow_succ, ideal.mem_span_singleton'] at hn,
  cases hn with c hc,
  have basic_opens_eq := basic_open_pow h (n+1) (by linarith),
  have i_basic_open := eq_to_hom basic_opens_eq ≫ hom_of_le hDhV,
  -- We claim that `(f * c) / h ^ (n+1)` is our desired representation
  use [f * c, h ^ (n+1), i_basic_open ≫ iVU, (basic_opens_eq.symm.le : _) hxDh],
  rw [op_comp, functor.map_comp, comp_apply, ← s_eq, res_const],
  -- Note that the last rewrite here generated an additional goal, which was a parameter
  -- of `res_const`. We prove this goal first
  swap,
  { intros y hy,
    rw basic_opens_eq at hy,
    exact (set.subset.trans hDhV hVDg : _) hy },
  -- All that is left is a simple calculation
  apply const_ext,
  rw [mul_assoc f c g, hc],
end

/-
Auxiliary lemma for surjectivity of `to_basic_open`.
A local representation of a section `s` as fractions `a i / h i` on finitely many basic opens
`basic_open (h i)` can be "normalized" in such a way that `a i * h j = h i * a j` for all `i, j`
-/
lemma normalize_finite_fraction_representation (U : opens (prime_spectrum.Top R))
  (s : (structure_sheaf R).1.obj (op U)) {ι : Type*} (t : finset ι) (a h : ι → R)
  (iDh : Π i : ι, basic_open (h i) ⟶ U)  (h_cover : U.1 ⊆ ⋃ i ∈ t, (basic_open (h i)).1)
  (hs : ∀ i : ι, const R (a i) (h i) (basic_open (h i)) (λ y hy, hy) =
    (structure_sheaf R).1.map (iDh i).op s) :
  ∃ (a' h' : ι → R) (iDh' : Π i : ι, (basic_open (h' i)) ⟶ U),
    (U.1 ⊆ ⋃ i ∈ t, (basic_open (h' i)).1) ∧
    (∀ i j ∈ t, a' i * h' j = h' i * a' j) ∧
    (∀ i ∈ t, (structure_sheaf R).1.map (iDh' i).op s =
      const R (a' i) (h' i) (basic_open (h' i)) (λ y hy, hy)) :=
begin
  -- First we show that the fractions `(a i * h j) / (h i * h j)` and `(h i * a j) / (h i * h j)`
  -- coincide in the localization of `R` at `h i * h j`
  have fractions_eq : ∀ (i j : ι),
    is_localization.mk' (localization.away _) (a i * h j) ⟨h i * h j, submonoid.mem_powers _⟩ =
    is_localization.mk' _ (h i * a j) ⟨h i * h j, submonoid.mem_powers _⟩,
  { intros i j,
    let D := basic_open (h i * h j),
    let iDi : D ⟶ basic_open (h i) := hom_of_le (basic_open_mul_le_left _ _),
    let iDj : D ⟶ basic_open (h j) := hom_of_le (basic_open_mul_le_right _ _),
    -- Crucially, we need injectivity of `to_basic_open`
    apply to_basic_open_injective R (h i * h j),
    rw [to_basic_open_mk', to_basic_open_mk'],
    simp only [set_like.coe_mk],
    -- Here, both sides of the equation are equal to a restriction of `s`
    transitivity,
    convert congr_arg ((structure_sheaf R).1.map iDj.op) (hs j).symm using 1,
    convert congr_arg ((structure_sheaf R).1.map iDi.op) (hs i) using 1, swap,
    all_goals { rw res_const, apply const_ext, ring },
    -- The remaining two goals were generated during the rewrite of `res_const`
    -- These can be solved immediately
    exacts [basic_open_mul_le_right _ _, basic_open_mul_le_left _ _] },

  -- From the equality in the localization, we obtain for each `(i,j)` some power `(h i * h j) ^ n`
  -- which equalizes `a i * h j` and `h i * a j`
  have exists_power : ∀ (i j : ι), ∃ n : ℕ,
    a i * h j * (h i * h j) ^ n = h i * a j * (h i * h j) ^ n,
  { intros i j,
    obtain ⟨⟨c, n, rfl⟩, hc⟩ := is_localization.eq.mp (fractions_eq i j),
    use (n+1),
    rw pow_succ,
    dsimp at hc,
    convert hc using 1 ; ring },
  let n := λ (p : ι × ι), (exists_power p.1 p.2).some,
  have n_spec := λ (p : ι × ι), (exists_power p.fst p.snd).some_spec,
  -- We need one power `(h i * h j) ^ N` that works for *all* pairs `(i,j)`
  -- Since there are only finitely many indices involved, we can pick the supremum.
  let N := (t.product t).sup n,
  have basic_opens_eq : ∀ i : ι, basic_open ((h i) ^ (N+1)) = basic_open (h i) :=
    λ i, basic_open_pow _ _ (by linarith),
  -- Expanding the fraction `a i / h i` by the power `(h i) ^ N` gives the desired normalization
  refine ⟨(λ i, a i * (h i) ^ N), (λ i, (h i) ^ (N + 1)),
    (λ i, eq_to_hom (basic_opens_eq i) ≫ iDh i), _, _, _⟩,
  { simpa only [basic_opens_eq] using h_cover },
  { intros i hi j hj,
    -- Here we need to show that our new fractions `a i / h i` satisfy the normalization condition
    -- Of course, the power `N` we used to expand the fractions might be bigger than the power
    -- `n (i, j)` which was originally chosen. We denote their difference by `k`
    have n_le_N : n (i, j) ≤ N := finset.le_sup (finset.mem_product.mpr ⟨hi, hj⟩),
    cases nat.le.dest n_le_N with k hk,
    simp only [← hk, pow_add, pow_one],
    -- To accommodate for the difference `k`, we multiply both sides of the equation `n_spec (i, j)`
    -- by `(h i * h j) ^ k`
    convert congr_arg (λ z, z * (h i * h j) ^ k) (n_spec (i, j)) using 1 ;
    { simp only [n, mul_pow], ring } },

  -- Lastly, we need to show that the new fractions still represent our original `s`
  intros i hi,
  rw [op_comp, functor.map_comp, comp_apply, ← hs, res_const],
  -- additional goal spit out by `res_const`
  swap, exact (basic_opens_eq i).le,
  apply const_ext,
  rw pow_succ,
  ring
end

open_locale classical
open_locale big_operators

-- The proof here follows the argument in Hartshorne's Algebraic Geometry, Proposition II.2.2.
lemma to_basic_open_surjective (f : R) : function.surjective (to_basic_open R f) :=
begin
  intro s,
  -- In this proof, `basic_open f` will play two distinct roles: Firstly, it is an open set in the
  -- prime spectrum. Secondly, it is used as an indexing type for various families of objects
  -- (open sets, ring elements, ...). In order to make the distinction clear, we introduce a type
  -- alias `ι` that is used whenever we want think of it as an indexing type.
  let ι : Type u := basic_open f,

  -- First, we pick some cover of basic opens, on which we can represent `s` as a fraction
  choose a' h' iDh' hxDh' s_eq' using locally_const_basic_open R (basic_open f) s,
  -- Since basic opens are compact, we can pass to a finite subcover
  obtain ⟨t, ht_cover'⟩ := (is_compact_basic_open f).elim_finite_subcover
   (λ (i : ι), (basic_open (h' i)).1) (λ i, is_open_basic_open) (λ x hx, _),
  swap,
  { -- Here, we need to show that our basic opens actually form a cover of `basic_open f`
    rw set.mem_Union,
    exact ⟨⟨x,hx⟩, hxDh' ⟨x, hx⟩⟩ },
  -- We use the normalization lemma from above to obtain the relation `a i * h j = h i * a j`
  obtain ⟨a, h, iDh, ht_cover, ah_ha, s_eq⟩ := normalize_finite_fraction_representation R
    (basic_open f) s t a' h' iDh' ht_cover' s_eq',
  clear s_eq' iDh' hxDh' ht_cover' a' h',
  -- Next we show that some power of `f` is a linear combination of the `h i`
  obtain ⟨n, hn⟩ : f ∈ (ideal.span (h '' ↑t)).radical,
  { rw [← vanishing_ideal_zero_locus_eq_radical, zero_locus_span],
    simp_rw [subtype.val_eq_coe, basic_open_eq_zero_locus_compl] at ht_cover,
    rw set.compl_subset_comm at ht_cover, -- Why doesn't `simp_rw` do this?
    simp_rw [set.compl_Union, compl_compl, ← zero_locus_Union, ← finset.set_bUnion_coe,
             ← set.image_eq_Union ] at ht_cover,
    apply vanishing_ideal_anti_mono ht_cover,
    exact subset_vanishing_ideal_zero_locus {f} (set.mem_singleton f) },

  replace hn := ideal.mul_mem_left _ f hn,
  erw [←pow_succ, finsupp.mem_span_image_iff_total] at hn,
  rcases hn with ⟨b, b_supp, hb⟩,
  rw finsupp.total_apply_of_mem_supported R b_supp at hb,
  dsimp at hb,

  -- Finally, we have all the ingredients.
  -- We claim that our preimage is given by `(∑ (i : ι) in t, b i * a i) / f ^ (n+1)`
  use is_localization.mk' (localization.away f) (∑ (i : ι) in t, b i * a i)
    (⟨f ^ (n+1), n+1, rfl⟩ : submonoid.powers _),
  rw to_basic_open_mk',

  -- Since the structure sheaf is a sheaf, we can show the desired equality locally.
  -- Annoyingly, `sheaf.eq_of_locally_eq` requires an open cover indexed by a *type*, so we need to
  -- coerce our finset `t` to a type first.
  let tt := ((t : set (basic_open f)) : Type u),
  apply (structure_sheaf R).eq_of_locally_eq'
    (λ i : tt, basic_open (h i)) (basic_open f) (λ i : tt, iDh i),
  { -- This feels a little redundant, since already have `ht_cover` as a hypothesis
    -- Unfortunately, `ht_cover` uses a bounded union over the set `t`, while here we have the
    -- Union indexed by the type `tt`, so we need some boilerplate to translate one to the other
    intros x hx,
    erw topological_space.opens.mem_supr,
    have := ht_cover hx,
    rw [← finset.set_bUnion_coe, set.mem_Union₂] at this,
    rcases this with ⟨i, i_mem, x_mem⟩,
    use [i, i_mem] },

  rintro ⟨i, hi⟩,
  dsimp,
  change (structure_sheaf R).1.map _ _ = (structure_sheaf R).1.map _ _,
  rw [s_eq i hi, res_const],
  -- Again, `res_const` spits out an additional goal
  swap,
  { intros y hy,
    change y ∈ basic_open (f ^ (n+1)),
    rw basic_open_pow f (n+1) (by linarith),
    exact (le_of_hom (iDh i) : _) hy },
  -- The rest of the proof is just computation
  apply const_ext,
  rw [← hb, finset.sum_mul, finset.mul_sum],
  apply finset.sum_congr rfl,
  intros j hj,
  rw [mul_assoc, ah_ha j hj i hi],
  ring
end

instance is_iso_to_basic_open (f : R) : is_iso (show CommRing.of _ ⟶ _, from to_basic_open R f) :=
begin
  haveI : is_iso ((forget CommRing).map (show CommRing.of _ ⟶ _, from to_basic_open R f)) :=
    (is_iso_iff_bijective _).mpr ⟨to_basic_open_injective R f, to_basic_open_surjective R f⟩,
  exact is_iso_of_reflects_iso _ (forget CommRing),
end

/-- The ring isomorphism between the structure sheaf on `basic_open f` and the localization of `R`
at the submonoid of powers of `f`. -/
def basic_open_iso (f : R) : (structure_sheaf R).1.obj (op (basic_open f)) ≅
  CommRing.of (localization.away f) :=
(as_iso (show CommRing.of _ ⟶ _, from to_basic_open R f)).symm

instance stalk_algebra (p : prime_spectrum R) : algebra R ((structure_sheaf R).val.stalk p) :=
(to_stalk R p).to_algebra

@[simp] lemma stalk_algebra_map (p : prime_spectrum R) (r : R) :
  algebra_map R ((structure_sheaf R).val.stalk p) r = to_stalk R p r := rfl

/-- Stalk of the structure sheaf at a prime p as localization of R -/
instance is_localization.to_stalk (p : prime_spectrum R) :
  is_localization.at_prime ((structure_sheaf R).val.stalk p) p.as_ideal :=
begin
  convert (is_localization.is_localization_iff_of_ring_equiv _ (stalk_iso R p).symm
    .CommRing_iso_to_ring_equiv).mp localization.is_localization,
  apply algebra.algebra_ext,
  intro _,
  rw stalk_algebra_map,
  congr' 1,
  erw iso.eq_comp_inv,
  exact to_stalk_comp_stalk_to_fiber_ring_hom R p,
end

instance open_algebra (U : (opens (prime_spectrum R))ᵒᵖ) :
  algebra R ((structure_sheaf R).val.obj U) :=
(to_open R (unop U)).to_algebra

@[simp] lemma open_algebra_map (U : (opens (prime_spectrum R))ᵒᵖ) (r : R) :
  algebra_map R ((structure_sheaf R).val.obj U) r = to_open R (unop U) r := rfl

/-- Sections of the structure sheaf of Spec R on a basic open as localization of R -/
instance is_localization.to_basic_open (r : R) :
  is_localization.away r ((structure_sheaf R).val.obj (op $ basic_open r)) :=
begin
  convert (is_localization.is_localization_iff_of_ring_equiv _ (basic_open_iso R r).symm
    .CommRing_iso_to_ring_equiv).mp localization.is_localization,
  apply algebra.algebra_ext,
  intro x,
  congr' 1,
  exact (localization_to_basic_open R r).symm
end

instance to_basic_open_epi (r : R) : epi (to_open R (basic_open r)) :=
⟨λ S f g h, by { refine is_localization.ring_hom_ext _ _,
  swap 5, exact is_localization.to_basic_open R r, exact h }⟩

@[elementwise] lemma to_global_factors : to_open R ⊤ =
  (CommRing.of_hom (algebra_map R (localization.away (1 : R)))) ≫ (to_basic_open R (1 : R)) ≫
  (structure_sheaf R).1.map (eq_to_hom (basic_open_one.symm)).op :=
begin
  change to_open R ⊤ = (to_basic_open R 1).comp _ ≫ _,
  unfold CommRing.of_hom,
  rw [localization_to_basic_open R, to_open_res],
end

instance is_iso_to_global : is_iso (to_open R ⊤) :=
begin
  let hom := CommRing.of_hom (algebra_map R (localization.away (1 : R))),
  haveI : is_iso hom := is_iso.of_iso
    ((is_localization.at_one R (localization.away (1 : R))).to_ring_equiv.to_CommRing_iso),
  rw to_global_factors R,
  apply_instance
end

/-- The ring isomorphism between the ring `R` and the global sections `Γ(X, 𝒪ₓ)`. -/
@[simps] def global_sections_iso : CommRing.of R ≅ (structure_sheaf R).1.obj (op ⊤) :=
as_iso (to_open R ⊤)

@[simp] lemma global_sections_iso_hom (R : CommRing) :
  (global_sections_iso R).hom = to_open R ⊤ := rfl

@[simp, reassoc, elementwise]
lemma to_stalk_stalk_specializes {R : Type*} [comm_ring R]
  {x y : prime_spectrum R} (h : x ⤳ y) :
  to_stalk R y ≫ (structure_sheaf R).val.stalk_specializes h = to_stalk R x :=
by { dsimp [ to_stalk], simpa }

@[simp, reassoc, elementwise]
lemma localization_to_stalk_stalk_specializes {R : Type*} [comm_ring R]
  {x y : prime_spectrum R} (h : x ⤳ y) :
  structure_sheaf.localization_to_stalk R y ≫ (structure_sheaf R).val.stalk_specializes h =
    CommRing.of_hom (prime_spectrum.localization_map_of_specializes h) ≫
      structure_sheaf.localization_to_stalk R x :=
begin
  apply is_localization.ring_hom_ext y.as_ideal.prime_compl,
  any_goals { dsimp, apply_instance },
  erw ring_hom.comp_assoc,
  conv_rhs { erw ring_hom.comp_assoc },
  dsimp [CommRing.of_hom, localization_to_stalk, prime_spectrum.localization_map_of_specializes],
  rw [is_localization.lift_comp, is_localization.lift_comp, is_localization.lift_comp],
  exact to_stalk_stalk_specializes h
end

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_to_fiber {R : Type*} [comm_ring R]
  {x y : prime_spectrum R} (h : x ⤳ y) :
  (structure_sheaf R).val.stalk_specializes h ≫ structure_sheaf.stalk_to_fiber_ring_hom R x =
    structure_sheaf.stalk_to_fiber_ring_hom R y ≫
      prime_spectrum.localization_map_of_specializes h :=
begin
  change _ ≫ (structure_sheaf.stalk_iso R x).hom = (structure_sheaf.stalk_iso R y).hom ≫ _,
  rw [← iso.eq_comp_inv, category.assoc, ← iso.inv_comp_eq],
  exact localization_to_stalk_stalk_specializes h,
end

section comap

variables {R} {S : Type u} [comm_ring S] {P : Type u} [comm_ring P]

/--
Given a ring homomorphism `f : R →+* S`, an open set `U` of the prime spectrum of `R` and an open
set `V` of the prime spectrum of `S`, such that `V ⊆ (comap f) ⁻¹' U`, we can push a section `s`
on `U` to a section on `V`, by composing with `localization.local_ring_hom _ _ f` from the left and
`comap f` from the right. Explicitly, if `s` evaluates on `comap f p` to `a / b`, its image on `V`
evaluates on `p` to `f(a) / f(b)`.

At the moment, we work with arbitrary dependent functions `s : Π x : U, localizations R x`. Below,
we prove the predicate `is_locally_fraction` is preserved by this map, hence it can be extended to
a morphism between the structure sheaves of `R` and `S`.
-/
def comap_fun (f : R →+* S) (U : opens (prime_spectrum.Top R))
  (V : opens (prime_spectrum.Top S)) (hUV : V.1 ⊆ (prime_spectrum.comap f) ⁻¹' U.1)
  (s : Π x : U, localizations R x) (y : V) : localizations S y :=
localization.local_ring_hom (prime_spectrum.comap f y.1).as_ideal _ f rfl
  (s ⟨(prime_spectrum.comap f y.1), hUV y.2⟩ : _)

lemma comap_fun_is_locally_fraction (f : R →+* S)
  (U : opens (prime_spectrum.Top R)) (V : opens (prime_spectrum.Top S))
  (hUV : V.1 ⊆ (prime_spectrum.comap f) ⁻¹' U.1) (s : Π x : U, localizations R x)
  (hs : (is_locally_fraction R).to_prelocal_predicate.pred s) :
  (is_locally_fraction S).to_prelocal_predicate.pred (comap_fun f U V hUV s) :=
begin
  rintro ⟨p, hpV⟩,
  -- Since `s` is locally fraction, we can find a neighborhood `W` of `prime_spectrum.comap f p`
  -- in `U`, such that `s = a / b` on `W`, for some ring elements `a, b : R`.
  rcases hs ⟨prime_spectrum.comap f p, hUV hpV⟩ with ⟨W, m, iWU, a, b, h_frac⟩,
  -- We claim that we can write our new section as the fraction `f a / f b` on the neighborhood
  -- `(comap f) ⁻¹ W ⊓ V` of `p`.
  refine ⟨opens.comap (comap f) W ⊓ V, ⟨m, hpV⟩, opens.inf_le_right _ _, f a, f b, _⟩,
  rintro ⟨q, ⟨hqW, hqV⟩⟩,
  specialize h_frac ⟨prime_spectrum.comap f q, hqW⟩,
  refine ⟨h_frac.1, _⟩,
  dsimp only [comap_fun],
  erw [← localization.local_ring_hom_to_map ((prime_spectrum.comap f q).as_ideal),
    ← ring_hom.map_mul, h_frac.2, localization.local_ring_hom_to_map],
  refl,
end

/--
For a ring homomorphism `f : R →+* S` and open sets `U` and `V` of the prime spectra of `R` and
`S` such that `V ⊆ (comap f) ⁻¹ U`, the induced ring homomorphism from the structure sheaf of `R`
at `U` to the structure sheaf of `S` at `V`.

Explicitly, this map is given as follows: For a point `p : V`, if the section `s` evaluates on `p`
to the fraction `a / b`, its image on `V` evaluates on `p` to the fraction `f(a) / f(b)`.
-/
def comap (f : R →+* S) (U : opens (prime_spectrum.Top R))
  (V : opens (prime_spectrum.Top S)) (hUV : V.1 ⊆ (prime_spectrum.comap f) ⁻¹' U.1) :
  (structure_sheaf R).1.obj (op U) →+* (structure_sheaf S).1.obj (op V) :=
{ to_fun := λ s, ⟨comap_fun f U V hUV s.1, comap_fun_is_locally_fraction f U V hUV s.1 s.2⟩,
  map_one' := subtype.ext $ funext $ λ p, by
    { rw [subtype.coe_mk, subtype.val_eq_coe, comap_fun, (sections_subring R (op U)).coe_one,
      pi.one_apply, ring_hom.map_one], refl },
  map_zero' := subtype.ext $ funext $ λ p, by
    { rw [subtype.coe_mk, subtype.val_eq_coe, comap_fun, (sections_subring R (op U)).coe_zero,
      pi.zero_apply, ring_hom.map_zero], refl },
  map_add' := λ s t, subtype.ext $ funext $ λ p, by
    { rw [subtype.coe_mk, subtype.val_eq_coe, comap_fun, (sections_subring R (op U)).coe_add,
      pi.add_apply, ring_hom.map_add], refl },
  map_mul' := λ s t, subtype.ext $ funext $ λ p, by
    { rw [subtype.coe_mk, subtype.val_eq_coe, comap_fun, (sections_subring R (op U)).coe_mul,
      pi.mul_apply, ring_hom.map_mul], refl } }

@[simp]
lemma comap_apply (f : R →+* S) (U : opens (prime_spectrum.Top R))
  (V : opens (prime_spectrum.Top S)) (hUV : V.1 ⊆ (prime_spectrum.comap f) ⁻¹' U.1)
  (s : (structure_sheaf R).1.obj (op U)) (p : V) :
  (comap f U V hUV s).1 p =
  localization.local_ring_hom (prime_spectrum.comap f p.1).as_ideal _ f rfl
    (s.1 ⟨(prime_spectrum.comap f p.1), hUV p.2⟩ : _) :=
rfl

lemma comap_const (f : R →+* S) (U : opens (prime_spectrum.Top R))
  (V : opens (prime_spectrum.Top S)) (hUV : V.1 ⊆ (prime_spectrum.comap f) ⁻¹' U.1)
  (a b : R) (hb : ∀ x : prime_spectrum R, x ∈ U → b ∈ x.as_ideal.prime_compl) :
  comap f U V hUV (const R a b U hb) =
  const S (f a) (f b) V (λ p hpV, hb (prime_spectrum.comap f p) (hUV hpV)) :=
subtype.eq $ funext $ λ p,
begin
  rw [comap_apply, const_apply, const_apply],
  erw localization.local_ring_hom_mk',
  refl,
end

/--
For an inclusion `i : V ⟶ U` between open sets of the prime spectrum of `R`, the comap of the
identity from OO_X(U) to OO_X(V) equals as the restriction map of the structure sheaf.

This is a generalization of the fact that, for fixed `U`, the comap of the identity from OO_X(U)
to OO_X(U) is the identity.
-/
lemma comap_id_eq_map (U V : opens (prime_spectrum.Top R)) (iVU : V ⟶ U) :
  comap (ring_hom.id R) U V
    (λ p hpV, le_of_hom iVU $ by rwa prime_spectrum.comap_id) =
  (structure_sheaf R).1.map iVU.op :=
ring_hom.ext $ λ s, subtype.eq $ funext $ λ p,
begin
  rw comap_apply,
  -- Unfortunately, we cannot use `localization.local_ring_hom_id` here, because
  -- `prime_spectrum.comap (ring_hom.id R) p` is not *definitionally* equal to `p`. Instead, we use
  -- that we can write `s` as a fraction `a/b` in a small neighborhood around `p`. Since
  -- `prime_spectrum.comap (ring_hom.id R) p` equals `p`, it is also contained in the same
  -- neighborhood, hence `s` equals `a/b` there too.
  obtain ⟨W, hpW, iWU, h⟩ := s.2 (iVU p),
  obtain ⟨a, b, h'⟩ := h.eq_mk',
  obtain ⟨hb₁, s_eq₁⟩ := h' ⟨p, hpW⟩,
  obtain ⟨hb₂, s_eq₂⟩ := h' ⟨prime_spectrum.comap (ring_hom.id _) p.1,
    by rwa prime_spectrum.comap_id⟩,
  dsimp only at s_eq₁ s_eq₂,
  erw [s_eq₂, localization.local_ring_hom_mk', ← s_eq₁, ← res_apply],
end

/--
The comap of the identity is the identity. In this variant of the lemma, two open subsets `U` and
`V` are given as arguments, together with a proof that `U = V`. This is be useful when `U` and `V`
are not definitionally equal.
-/
lemma comap_id (U V : opens (prime_spectrum.Top R)) (hUV : U = V) :
  comap (ring_hom.id R) U V (λ p hpV, by rwa [hUV, prime_spectrum.comap_id]) =
  eq_to_hom (show (structure_sheaf R).1.obj (op U) = _, by rw hUV) :=
by erw [comap_id_eq_map U V (eq_to_hom hUV.symm), eq_to_hom_op, eq_to_hom_map]

@[simp] lemma comap_id' (U : opens (prime_spectrum.Top R)) :
  comap (ring_hom.id R) U U (λ p hpU, by rwa prime_spectrum.comap_id) =
  ring_hom.id _ :=
by { rw comap_id U U rfl, refl }

lemma comap_comp (f : R →+* S) (g : S →+* P) (U : opens (prime_spectrum.Top R))
  (V : opens (prime_spectrum.Top S)) (W : opens (prime_spectrum.Top P))
  (hUV : ∀ p ∈ V, prime_spectrum.comap f p ∈ U) (hVW : ∀ p ∈ W, prime_spectrum.comap g p ∈ V) :
  comap (g.comp f) U W (λ p hpW, hUV (prime_spectrum.comap g p) (hVW p hpW)) =
    (comap g V W hVW).comp (comap f U V hUV) :=
ring_hom.ext $ λ s, subtype.eq $ funext $ λ p,
begin
  rw comap_apply,
  erw localization.local_ring_hom_comp _ (prime_spectrum.comap g p.1).as_ideal,
  -- refl works here, because `prime_spectrum.comap (g.comp f) p` is defeq to
  -- `prime_spectrum.comap f (prime_spectrum.comap g p)`
  refl,
end

@[elementwise, reassoc] lemma to_open_comp_comap (f : R →+* S)
  (U : opens (prime_spectrum.Top R)) :
  to_open R U ≫ comap f U (opens.comap (prime_spectrum.comap f) U) (λ _, id) =
  CommRing.of_hom f ≫ to_open S _ :=
ring_hom.ext $ λ s, subtype.eq $ funext $ λ p,
begin
  simp_rw [comp_apply, comap_apply, subtype.val_eq_coe],
  erw localization.local_ring_hom_to_map,
  refl,
end

end comap

end structure_sheaf

end algebraic_geometry


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.nilpotent
import algebra.lie.centralizer

/-!
# Engel's theorem

This file contains a proof of Engel's theorem providing necessary and sufficient conditions for Lie
algebras and Lie modules to be nilpotent.

The key result `lie_module.is_nilpotent_iff_forall` says that if `M` is a Lie module of a
Noetherian Lie algebra `L`, then `M` is nilpotent iff the image of `L → End(M)` consists of
nilpotent elements. In the special case that we have the adjoint representation `M = L`, this says
that a Lie algebra is nilpotent iff `ad x : End(L)` is nilpotent for all `x : L`.

Engel's theorem is true for any coefficients (i.e., it is really a theorem about Lie rings) and so
we work with coefficients in any commutative ring `R` throughout.

On the other hand, Engel's theorem is not true for infinite-dimensional Lie algebras and so a
finite-dimensionality assumption is required. We prove the theorem subject to the the assumption
that the Lie algebra is Noetherian as an `R`-module, though actually we only need the slightly
weaker property that the relation `>` is well-founded on the complete lattice of Lie subalgebras.

## Remarks about the proof

Engel's theorem is usually proved in the special case that the coefficients are a field, and uses
an inductive argument on the dimension of the Lie algebra. One begins by choosing either a maximal
proper Lie subalgebra (in some proofs) or a maximal nilpotent Lie subalgebra (in other proofs, at
the cost of obtaining a weaker end result).

Since we work with general coefficients, we cannot induct on dimension and an alternate approach
must be taken. The key ingredient is the concept of nilpotency, not just for Lie algebras, but for
Lie modules. Using this concept, we define an _Engelian Lie algebra_ `lie_algebra.is_engelian` to
be one for which a Lie module is nilpotent whenever the action consists of nilpotent endomorphisms.
The argument then proceeds by selecting a maximal Engelian Lie subalgebra and showing that it cannot
be proper.

The first part of the traditional statement of Engel's theorem consists of the statement that if `M`
is a non-trivial `R`-module and `L ⊆ End(M)` is a finite-dimensional Lie subalgebra of nilpotent
elements, then there exists a non-zero element `m : M` that is annihilated by every element of `L`.
This follows trivially from the result established here `lie_module.is_nilpotent_iff_forall`, that
`M` is a nilpotent Lie module over `L`, since the last non-zero term in the lower central series
will consist of such elements `m` (see: `lie_module.nontrivial_max_triv_of_is_nilpotent`). It seems
that this result has not previously been established at this level of generality.

The second part of the traditional statement of Engel's theorem concerns nilpotency of the Lie
algebra and a proof of this for general coefficients appeared in the literature as long ago
[as 1937](zorn1937). This also follows trivially from `lie_module.is_nilpotent_iff_forall` simply by
taking `M = L`.

It is pleasing that the two parts of the traditional statements of Engel's theorem are thus unified
into a single statement about nilpotency of Lie modules. This is not usually emphasised.

## Main definitions

  * `lie_algebra.is_engelian`
  * `lie_algebra.is_engelian_of_is_noetherian`
  * `lie_module.is_nilpotent_iff_forall`
  * `lie_algebra.is_nilpotent_iff_forall`

-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} {L : Type u₂} {L₂ : Type u₃} {M : Type u₄}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L₂] [lie_algebra R L₂]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]

include R L

namespace lie_submodule

open lie_module

variables {I : lie_ideal R L} {x : L} (hxI : (R ∙ x) ⊔ I = ⊤)

include hxI

lemma exists_smul_add_of_span_sup_eq_top (y : L) : ∃ (t : R) (z ∈ I), y = t • x + z :=
begin
  have hy : y ∈ (⊤ : submodule R L) := submodule.mem_top,
  simp only [← hxI, submodule.mem_sup, submodule.mem_span_singleton] at hy,
  obtain ⟨-, ⟨t, rfl⟩, z, hz, rfl⟩ := hy,
  exact ⟨t, z, hz, rfl⟩,
end

lemma lie_top_eq_of_span_sup_eq_top (N : lie_submodule R L M) :
  (↑⁅(⊤ : lie_ideal R L), N⁆ : submodule R M) =
  (N : submodule R M).map (to_endomorphism R L M x) ⊔ (↑⁅I, N⁆ : submodule R M) :=
begin
  simp only [lie_ideal_oper_eq_linear_span', submodule.sup_span, mem_top, exists_prop,
    exists_true_left, submodule.map_coe, to_endomorphism_apply_apply],
  refine le_antisymm (submodule.span_le.mpr _) (submodule.span_mono (λ z hz, _)),
  { rintros z ⟨y, n, hn : n ∈ N, rfl⟩,
    obtain ⟨t, z, hz, rfl⟩ := exists_smul_add_of_span_sup_eq_top hxI y,
    simp only [set_like.mem_coe, submodule.span_union, submodule.mem_sup],
    exact ⟨t • ⁅x, n⁆, submodule.subset_span ⟨t • n, N.smul_mem' t hn, lie_smul t x n⟩,
      ⁅z, n⁆, submodule.subset_span ⟨z, hz, n, hn, rfl⟩, by simp⟩, },
  { rcases hz with ⟨m, hm, rfl⟩ | ⟨y, hy, m, hm, rfl⟩,
    exacts [⟨x, m, hm, rfl⟩, ⟨y, m, hm, rfl⟩], },
end

lemma lcs_le_lcs_of_is_nilpotent_span_sup_eq_top {n i j : ℕ} (hxn : (to_endomorphism R L M x)^n = 0)
  (hIM : lower_central_series R L M i ≤ I.lcs M j) :
  lower_central_series R L M (i + n) ≤ I.lcs M (j + 1) :=
begin
  suffices : ∀ l, ((⊤ : lie_ideal R L).lcs M (i + l) : submodule R M) ≤
    (I.lcs M j : submodule R M).map
    ((to_endomorphism R L M x)^l) ⊔ (I.lcs M (j + 1) : submodule R M),
  { simpa only [bot_sup_eq, lie_ideal.incl_coe, submodule.map_zero, hxn] using this n, },
  intros l,
  induction l with l ih,
  { simp only [add_zero, lie_ideal.lcs_succ, pow_zero, linear_map.one_eq_id, submodule.map_id],
    exact le_sup_of_le_left hIM, },
  { simp only [lie_ideal.lcs_succ, i.add_succ l, lie_top_eq_of_span_sup_eq_top hxI, sup_le_iff],
    refine ⟨(submodule.map_mono ih).trans _, le_sup_of_le_right _⟩,
    { rw [submodule.map_sup, ← submodule.map_comp, ← linear_map.mul_eq_comp, ← pow_succ,
        ← I.lcs_succ],
      exact sup_le_sup_left coe_map_to_endomorphism_le _, },
    { refine le_trans (mono_lie_right _ _ I _) (mono_lie_right _ _ I hIM),
      exact antitone_lower_central_series R L M le_self_add, }, },
end

lemma is_nilpotent_of_is_nilpotent_span_sup_eq_top
  (hnp : is_nilpotent $ to_endomorphism R L M x) (hIM : is_nilpotent R I M) :
  is_nilpotent R L M :=
begin
  obtain ⟨n, hn⟩ := hnp,
  unfreezingI { obtain ⟨k, hk⟩ := hIM, },
  have hk' : I.lcs M k = ⊥,
  { simp only [← coe_to_submodule_eq_iff, I.coe_lcs_eq, hk, bot_coe_submodule], },
  suffices : ∀ l, lower_central_series R L M (l * n) ≤ I.lcs M l,
  { use k * n,
    simpa [hk'] using this k, },
  intros l,
  induction l with l ih,
  { simp, },
  { exact (l.succ_mul n).symm ▸ lcs_le_lcs_of_is_nilpotent_span_sup_eq_top hxI hn ih, },
end

end lie_submodule

section lie_algebra

open lie_module (hiding is_nilpotent)

variables (R L)

/-- A Lie algebra `L` is said to be Engelian if a sufficient condition for any `L`-Lie module `M` to
be nilpotent is that the image of the map `L → End(M)` consists of nilpotent elements.

Engel's theorem `lie_algebra.is_engelian_of_is_noetherian` states that any Noetherian Lie algebra is
Engelian. -/
def lie_algebra.is_engelian : Prop :=
  ∀ (M : Type u₄) [add_comm_group M], by exactI ∀ [module R M] [lie_ring_module L M], by exactI ∀
    [lie_module R L M], by exactI ∀ (h : ∀ (x : L), is_nilpotent (to_endomorphism R L M x)),
    lie_module.is_nilpotent R L M

variables {R L}

lemma lie_algebra.is_engelian_of_subsingleton [subsingleton L] : lie_algebra.is_engelian R L :=
begin
  intros M _i1 _i2 _i3 _i4 h,
  use 1,
  suffices : (⊤ : lie_ideal R L) = ⊥, { simp [this], },
  haveI := (lie_submodule.subsingleton_iff R L L).mpr infer_instance,
  apply subsingleton.elim,
end

lemma function.surjective.is_engelian
  {f : L →ₗ⁅R⁆ L₂} (hf : function.surjective f) (h : lie_algebra.is_engelian.{u₁ u₂ u₄} R L) :
  lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
begin
  introsI M _i1 _i2 _i3 _i4 h',
  letI : lie_ring_module L M := lie_ring_module.comp_lie_hom M f,
  letI : lie_module R L M := comp_lie_hom M f,
  have hnp : ∀ x, is_nilpotent (to_endomorphism R L M x) := λ x, h' (f x),
  have surj_id : function.surjective (linear_map.id : M →ₗ[R] M) := function.surjective_id,
  haveI : lie_module.is_nilpotent R L M := h M hnp,
  apply hf.lie_module_is_nilpotent surj_id,
  simp,
end

lemma lie_equiv.is_engelian_iff (e : L ≃ₗ⁅R⁆ L₂) :
  lie_algebra.is_engelian.{u₁ u₂ u₄} R L ↔ lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
⟨e.surjective.is_engelian, e.symm.surjective.is_engelian⟩

lemma lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer
  {K : lie_subalgebra R L} (hK₁ : lie_algebra.is_engelian.{u₁ u₂ u₄} R K) (hK₂ : K < K.normalizer) :
  ∃ (K' : lie_subalgebra R L) (hK' : lie_algebra.is_engelian.{u₁ u₂ u₄} R K'), K < K' :=
begin
  obtain ⟨x, hx₁, hx₂⟩ := set_like.exists_of_lt hK₂,
  let K' : lie_subalgebra R L :=
  { lie_mem' := λ y z, lie_subalgebra.lie_mem_sup_of_mem_normalizer hx₁,
    .. (R ∙ x) ⊔ (K : submodule R L) },
  have hxK' : x ∈ K' := submodule.mem_sup_left (submodule.subset_span (set.mem_singleton _)),
  have hKK' : K ≤ K' := (lie_subalgebra.coe_submodule_le_coe_submodule K K').mp le_sup_right,
  have hK' : K' ≤ K.normalizer,
  { rw ← lie_subalgebra.coe_submodule_le_coe_submodule,
    exact sup_le ((submodule.span_singleton_le_iff_mem _ _).mpr hx₁) hK₂.le, },
  refine ⟨K', _, lt_iff_le_and_ne.mpr ⟨hKK', λ contra, hx₂ (contra.symm ▸ hxK')⟩⟩,
  introsI M _i1 _i2 _i3 _i4 h,
  obtain ⟨I, hI₁ : (I : lie_subalgebra R K') = lie_subalgebra.of_le hKK'⟩ :=
    lie_subalgebra.exists_nested_lie_ideal_of_le_normalizer hKK' hK',
  have hI₂ : (R ∙ (⟨x, hxK'⟩ : K')) ⊔ I = ⊤,
  { rw [← lie_ideal.coe_to_lie_subalgebra_to_submodule R K' I, hI₁],
    apply submodule.map_injective_of_injective (K' : submodule R L).injective_subtype,
    simpa, },
  have e : K ≃ₗ⁅R⁆ I := (lie_subalgebra.equiv_of_le hKK').trans
    (lie_equiv.of_eq _ _ ((lie_subalgebra.coe_set_eq _ _).mpr hI₁.symm)),
  have hI₃ : lie_algebra.is_engelian R I := e.is_engelian_iff.mp hK₁,
  exact lie_submodule.is_nilpotent_of_is_nilpotent_span_sup_eq_top hI₂ (h _) (hI₃ _ (λ x, h x)),
end

local attribute [instance] lie_subalgebra.subsingleton_bot

variables [is_noetherian R L]

/-- *Engel's theorem*.

Note that this implies all traditional forms of Engel's theorem via
`lie_module.nontrivial_max_triv_of_is_nilpotent`, `lie_module.is_nilpotent_iff_forall`,
`lie_algebra.is_nilpotent_iff_forall`. -/
lemma lie_algebra.is_engelian_of_is_noetherian : lie_algebra.is_engelian R L :=
begin
  introsI M _i1 _i2 _i3 _i4 h,
  rw ← is_nilpotent_range_to_endomorphism_iff,
  let L' := (to_endomorphism R L M).range,
  replace h : ∀ (y : L'), is_nilpotent (y : module.End R M),
  { rintros ⟨-, ⟨y, rfl⟩⟩,
    simp [h], },
  change lie_module.is_nilpotent R L' M,
  let s := { K : lie_subalgebra R L' | lie_algebra.is_engelian R K },
  have hs : s.nonempty := ⟨⊥, lie_algebra.is_engelian_of_subsingleton⟩,
  suffices : ⊤ ∈ s,
  { rw ← is_nilpotent_of_top_iff,
    apply this M,
    simp [lie_subalgebra.to_endomorphism_eq, h], },
  have : ∀ (K ∈ s), K ≠ ⊤ → ∃ (K' ∈ s), K < K',
  { rintros K (hK₁ : lie_algebra.is_engelian R K) hK₂,
    apply lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer hK₁,
    apply lt_of_le_of_ne K.le_normalizer,
    rw [ne.def, eq_comm, K.normalizer_eq_self_iff, ← ne.def,
      ← lie_submodule.nontrivial_iff_ne_bot R K],
    haveI : nontrivial (L' ⧸ K.to_lie_submodule),
    { replace hK₂ : K.to_lie_submodule ≠ ⊤ :=
        by rwa [ne.def, ← lie_submodule.coe_to_submodule_eq_iff, K.coe_to_lie_submodule,
          lie_submodule.top_coe_submodule, ← lie_subalgebra.top_coe_submodule,
          K.coe_to_submodule_eq_iff],
      exact submodule.quotient.nontrivial_of_lt_top _ hK₂.lt_top, },
    haveI : lie_module.is_nilpotent R K (L' ⧸ K.to_lie_submodule),
    { refine hK₁ _ (λ x, _),
      have hx := lie_algebra.is_nilpotent_ad_of_is_nilpotent (h x),
      exact module.End.is_nilpotent.mapq _ hx, },
    exact nontrivial_max_triv_of_is_nilpotent R K (L' ⧸ K.to_lie_submodule), },
  haveI _i5 : is_noetherian R L' :=
    is_noetherian_of_surjective L _ (linear_map.range_range_restrict (to_endomorphism R L M)),
  obtain ⟨K, hK₁, hK₂⟩ :=
    well_founded.well_founded_iff_has_max'.mp (lie_subalgebra.well_founded_of_noetherian R L') s hs,
  have hK₃ : K = ⊤,
  { by_contra contra,
    obtain ⟨K', hK'₁, hK'₂⟩ := this K hK₁ contra,
    specialize hK₂ K' hK'₁ (le_of_lt hK'₂),
    replace hK'₂ := (ne_of_lt hK'₂).symm,
    contradiction, },
  exact hK₃ ▸ hK₁,
end

/-- Engel's theorem. -/
lemma lie_module.is_nilpotent_iff_forall :
  lie_module.is_nilpotent R L M ↔ ∀ x, is_nilpotent $ to_endomorphism R L M x :=
⟨begin
  introsI h,
  obtain ⟨k, hk⟩ := nilpotent_endo_of_nilpotent_module R L M,
  exact λ x, ⟨k, hk x⟩,
end,
λ h, lie_algebra.is_engelian_of_is_noetherian M h⟩

/-- Engel's theorem. -/
lemma lie_algebra.is_nilpotent_iff_forall :
  lie_algebra.is_nilpotent R L ↔ ∀ x, is_nilpotent $ lie_algebra.ad R L x :=
lie_module.is_nilpotent_iff_forall

end lie_algebra


variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : α → ((∀ x : α, r) ↔ r) := by
  intro x
  constructor
  . intro har
    apply har
    assumption
  . intro hr
    intro y
    assumption

open Classical

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r := by
  constructor
  . intro h
    match em r with
    | Or.inl hr => apply Or.inr; assumption
    | Or.inr hl =>
      apply Or.inl
      intro y
      match h y with
      | Or.inl hp => assumption
      | Or.inr hr => contradiction
  . intro h
    intro y
    match h with
    | Or.inl h' => apply Or.inl; exact h' y
    | Or.inr hr => apply Or.inr; assumption

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) := by
  constructor
  . intro h
    intro hr
    intro y
    apply h y
    assumption
  . intro h
    intro y
    intro hr
    exact (h hr) y


import misc.rationals.basic
import misc.rationals.alg_props

open classical

namespace rational

def pre_abs : ℤ × ℕ⁺ → ℚ
| (int.of_nat n,m) := ⟦(int.of_nat n,m)⟧
| (-[1+n],m)       := ⟦(nat.succ n,m)⟧

def abs : ℚ → ℚ :=
begin
  apply quotient.lift pre_abs,
  intros p₁ p₂ h,
  cases p₁ with z₁ m₁,
  cases z₁ with n₁ n₁,
  cases p₂ with z₂ m₂,
  cases z₂ with n₂ n₂,
  simp[pre_abs],
  exact quotient.sound h,
  simp[pre_abs],
  simp[strong_pos_nat_nat_coor, ← int.of_nat_mul] at h,
  have trv : -[1+ n₂] * int.of_nat (pos_nat_to_nat m₁)
    = int.neg_of_nat (nat.succ n₂ * (pos_nat_to_nat m₁)) := rfl,
  rw [trv,nat.succ_mul] at h,
  cases m₁,
  simp [nat.add_succ,pos_nat_to_nat,int.neg_of_nat] at h,
  cases h,
  simp [nat.add_succ,pos_nat_to_nat,int.neg_of_nat] at h,
  cases h,
  cases p₂ with z₂ m₂,
  cases z₂ with n₂ n₂,
  have trv : -[1+ n₁] * int.of_nat (pos_nat_to_nat m₂)
    = int.neg_of_nat (nat.succ n₁ * (pos_nat_to_nat m₂)) := rfl,
  simp[trv,strong_pos_nat_nat_coor, ← int.of_nat_mul] at h,
  cases m₂,
  simp [nat.add_succ,nat.mul_one,pos_nat_to_nat,int.neg_of_nat] at h,
  cases h,
  simp [nat.add_succ,nat.mul_one,pos_nat_to_nat,int.neg_of_nat] at h,
  cases h,
  simp[pre_abs],
  apply quotient.sound,
  simp at h,
  have trv₁ : -[1+ n₂] * int.of_nat (pos_nat_to_nat m₁)
    = int.neg_of_nat (nat.succ n₂ * (pos_nat_to_nat m₁)) := rfl,
  have trv₂ : -[1+ n₁] * int.of_nat (pos_nat_to_nat m₂)
    = int.neg_of_nat (nat.succ n₁ * (pos_nat_to_nat m₂)) := rfl,
  simp[trv₁,trv₂,strong_pos_nat_nat_coor] at h,
  have h₁ : -int.neg_of_nat (n₁.succ * pos_nat_to_nat m₂) =
    -int.neg_of_nat (n₂.succ * pos_nat_to_nat m₁),
    rw h,
  have trv₃ : ∀ n : ℕ, -(int.of_nat n) = int.neg_of_nat n,
    intro,
    refl,
  have trv₄ : ∀ n : ℕ, ↑n = int.of_nat n := λ _, rfl,
  simp [← trv₃,comm_ring.minus_minus] at h₁,
  simp,
  simp [trv₄,strong_pos_nat_nat_coor,← int.of_nat_mul],
  assumption,
end

theorem abs_zero : abs 0 = 0 := rfl

theorem abs_nat : ∀ (n : ℕ) (m : ℕ⁺), abs ⟦(int.of_nat n,m)⟧ = ⟦(int.of_nat n, m)⟧ := λ _ _,rfl

theorem abs_neg : ∀ (n : ℕ) (m : ℕ⁺), abs ⟦(-[1+n],m)⟧ = ⟦(nat.succ n,m)⟧ := λ _ _, rfl

def rational_le (x y: ℚ) : Prop := ∃ (n : ℕ) (m : ℕ⁺), y - x = ⟦(int.of_nat n, m)⟧

instance rationals_ordered : has_le ℚ := ⟨rational_le⟩
instance rationals_lt      : has_lt ℚ := ⟨λ x y : ℚ, x ≤ y ∧ x ≠ y⟩

@[simp]
theorem rational_le_defn : ∀ x y : ℚ, x ≤ y ↔ ∃ (n : ℕ) (m : ℕ⁺), y - x = ⟦(int.of_nat n, m)⟧ :=
begin
  intros x y,
  refl,
end

theorem le_refl : ∀ x : ℚ, x ≤ x :=
begin
  intro x,
  simp,
  existsi [0,(1: ℕ⁺)],
  rw minus_inverse,
  refl,
end

theorem le_trans : ∀ x y z : ℚ, x ≤ y → y ≤ z → x ≤ z :=
begin
  simp,
  intros x y z hxy hyz,
  cases hxy with nxy hxy,
  cases hxy with mxy hxy,
  cases hyz with nyz hyz,
  cases hyz with myz hyz,
  existsi[nxy * (pos_nat_to_nat myz) + nyz * (pos_nat_to_nat mxy), mxy * myz],
  simp [int.of_nat_add,int.of_nat_mul,← strong_pos_nat_nat_coor],
  rw [← rational_add_concrete_char,← hxy,← hyz],
  rw [add_comm y,add_comm z,add_comm z, comm_ring.add_assoc₄,minus_inverse,add_zero],
end

lemma minus_of_nat_eq : ∀ {n m : ℕ}, -int.of_nat n = int.of_nat m → n = 0 :=
begin
  intros n m eq,
  induction n with n hn,
  refl,
  rw int.neg_of_nat_of_succ at eq,
  cases eq,
end

theorem le_antisymm : ∀ x y : ℚ, x ≤ y → y ≤ x → x = y :=
begin
  intros x y hxy hyx,
  cases hxy with nxy hxy,
  cases hxy with mxy hxy,
  cases hyx with nyx hyx,
  cases hyx with myx hyx,
  rw sub_antisymm at hyx,
  rw [hxy,rational_minus_concrete_char] at hyx,
  have arg := quotient.exact hyx,
  simp[strong_pos_nat_nat_coor,← int.of_nat_mul,← comm_ring.minus_mul] at arg,
  have arg₁ : nxy * pos_nat_to_nat myx = 0,
    apply minus_of_nat_eq,
    assumption,
  have arg₂ : nxy = 0,
    apply int.of_nat.inj,
    apply pos_nat_mul_right_cancel myx,
    simp[strong_pos_nat_nat_coor,←int.of_nat_mul,nat.zero_mul],
    assumption,
  simp[arg₂] at hxy,
  symmetry,
  apply comm_ring.zero_diff_equal,
  rw hxy,
  simp[int.of_nat_zero],
end

theorem le_total : ∀ x y : ℚ , x ≤ y ∨ y ≤ x :=
begin
  intros x y,
  cases quotient.exists_rep (y - x : ℚ) with p hp,
  cases p with z m,
  cases z with n n,
  simp,
  left,
  existsi [n,m],
  symmetry,
  assumption,
  right,
  existsi [n.succ,m],
  apply comm_ring.minus_inj,
  rw [sub_antisymm,comm_ring.minus_minus,rational_minus_concrete_char],
  rw int.neg_of_nat_of_succ,
  symmetry,
  assumption,
end

theorem ge_zero_abs : ∀ {x : ℚ}, x ≥ 0 → abs x = x :=
begin
  intros x hx,
  cases hx with n hx,
  cases hx with m hx,
  simp[comm_ring.minus_zero_zero, add_zero] at hx,
  simp[hx,abs_nat],
end

theorem lt_zero_abs : ∀ {x : ℚ}, x < 0 → abs x = -x :=
begin
  intros x hx,
  cases hx with hxless0 nx0,
  cases hxless0 with n hn,
  cases hn with m hxint,
  have hx : x = -⟦(int.of_nat n, m)⟧,
    apply comm_ring.minus_inj,
    rw comm_ring.minus_minus,
    simp[zero_add] at hxint,
    assumption,
  simp[rational_minus_concrete_char] at hx,
  cases n,
  simp[int.of_nat_zero,comm_ring.minus_zero_zero] at hx,
  apply false.elim,
  exact nx0 hx,
  simp [hx,int.neg_of_nat_of_succ,abs_neg,rational_minus_concrete_char],
  simp[← int.neg_of_nat_of_succ,comm_ring.minus_minus],
  refl,
end

lemma ge_or_lt_zero : ∀ x : ℚ, x < 0 ∨ x ≥ 0 :=
begin
  intro x,
  cases le_total x 0,
  cases quotient.exists_rep x with p hp,
  cases p with z m,
  cases z with n n,
  right,
  existsi [n,m],
  simp[hp,comm_ring.minus_zero_zero,add_zero],
  left,
  split,
  existsi [nat.succ n,m],
  simp[← hp,rational_minus_concrete_char,← int.neg_of_nat_of_succ],
  simp[comm_ring.minus_minus,zero_add],
  intro ab,
  rw ab at hp,
  have h₁ := quotient.exact hp,
  simp[int.mul_one,int.zero_mul] at h₁,
  cases h₁,
  right,
  assumption,
end

theorem abs_ge_zero : ∀ x : ℚ, 0 ≤ abs x :=
begin
  intro x,
  cases ge_or_lt_zero x,
  rw lt_zero_abs h,
  cases h,
  cases h_left with n h,
  cases h with m h,
  existsi [n,m],
  simp[comm_ring.minus_zero_zero,add_zero],
  simp[zero_add] at h,
  assumption,
  rw ge_zero_abs h,
  assumption,
end

theorem le_add_weak : ∀ (b : ℚ) {a₁ a₂ : ℚ}, a₁ ≤ a₂ → a₁ + b ≤ a₂ + b :=
begin
  intros b a₁ a₂ h,
  cases h with n h,
  cases h with m h,
  existsi [n,m],
  simp[add_comm a₁, comm_ring.minus_dis, comm_ring.add_assoc₄, minus_inverse,add_zero],
  assumption,
end

theorem le_add_weak_iff : ∀ (b : ℚ) {a₁ a₂ : ℚ}, a₁ ≤ a₂ ↔ a₁ + b ≤ a₂ + b :=
begin
  intros b a₁ a₂,
  split,
  apply le_add_weak,
  intro h,
  rw [← add_zero a₁, ← add_zero a₂],
  rw [← minus_inverse b,add_assoc,add_assoc],
  apply le_add_weak (-b),
  assumption,
end

theorem le_add {a₁ a₂ b₁ b₂ : ℚ} : a₁ ≤ a₂ → b₁ ≤ b₂ → a₁ + b₁ ≤ a₂ + b₂ :=
begin
  intros ha hb,
  have int₁ : a₁ + b₁ ≤ a₂ + b₁ := le_add_weak b₁ ha,
  have int₂ : a₂ + b₁ ≤ a₂ + b₂,
    rw add_comm a₂,
    rw add_comm a₂,
    exact le_add_weak a₂ hb,
  apply le_trans,
  assumption,
  assumption,
end

theorem abs_upper_bound : ∀ x : ℚ, x ≤ abs x ∧ -x ≤ abs x :=
begin
  intro x,
  cases ge_or_lt_zero x,
  split,
  cases h,
  apply le_trans,
  assumption,
  apply abs_ge_zero,
  rw lt_zero_abs h,
  apply le_refl,
  split,
  rw ge_zero_abs h,
  apply le_refl,
  apply le_trans,
  have int : -x ≤ 0,
    cases h with n h,
    cases h with m h,
    existsi [n, m],
    simp[comm_ring.minus_minus,zero_add],
    simp[comm_ring.minus_zero_zero,add_zero] at h,
    assumption,
  assumption,
  apply abs_ge_zero,
end

theorem abs_minus : ∀ x : ℚ, abs (-x) = abs x :=
begin
  intro,
  cases quotient.exists_rep x with p hp,
  cases p with z n,
  simp[← hp,rational_minus_concrete_char],
  cases z with m m,
  cases m,
  simp[comm_ring.minus_zero_zero,int.of_nat_zero],
  simp[int.neg_of_nat_of_succ,abs_neg,abs_nat],
  refl,
  simp[← int.neg_of_nat_of_succ,abs_neg,abs_nat,comm_ring.minus_minus],
  simp[int.neg_of_nat_of_succ,abs_neg],
  refl,
end

theorem triangle_inequality : ∀ x y : ℚ, abs (x + y) ≤ abs x + abs y :=
begin
  intros x y,
  cases ge_or_lt_zero (x + y),
  rw [lt_zero_abs h, comm_ring.minus_dis],
  apply le_add,
  exact (abs_upper_bound x).2,
  exact (abs_upper_bound y).2,
  rw ge_zero_abs h,
  apply le_add,
  exact (abs_upper_bound x).1,
  exact (abs_upper_bound y).1,
end

theorem scale_pos_rat {ε : ℚ} {n : ℕ} {m : ℕ⁺} (k : ℕ⁺) : (0 ≠ ε) → (ε = ⟦(int.of_nat n,m)⟧)
  → let ε' : ℚ := ⟦(int.of_nat n,m*k)⟧ in ε' > 0 :=
begin
  intros nε hε,
  simp,
  split,
  existsi [n, m*k],
  simp[add_zero, comm_ring.minus_zero_zero],
  intro ab,
  have hcon := quotient.exact ab,
  simp[int.zero_mul,int.mul_one] at hcon,
  rw ← hcon at hε,
  simp at hε,
  apply nε,
  symmetry,
  assumption,
end

theorem lt_not_ge : ∀ x y : ℚ , x < y ↔ ¬(x ≥ y) :=
begin
  intros x y,
  split,
  intros hxy hyx,
  cases hxy with hxy nxy,
  apply nxy,
  apply le_antisymm,
  assumption,
  assumption,
  intro h,
  cases le_total x y with h₁,
  split,
  assumption,
  intro ab,
  rw ab at h,
  apply h,
  apply le_refl,
  apply false.elim,
  apply h,
  assumption,
end

theorem lt_trans : ∀ {x y z : ℚ} , x < y → y < z → x < z :=
begin
  intros x y z h₁ h₂,
  rw lt_not_ge,
  intro ab,
  cases h₁ with lxy exy,
  cases h₂ with lyz eyz,
  apply exy,
  apply le_antisymm,
  assumption,
  apply le_trans,
  apply le_trans,
  assumption,
  assumption,
  apply le_refl,
end

theorem lt_add_weak : ∀ (b : ℚ) {a₁ a₂ : ℚ}, a₁ < a₂ → a₁ + b < a₂ + b :=
begin
  intros b a₁ a₂ h12,
  cases h12 with l12 e12,
  rw lt_not_ge,
  intro ab,
  apply e12,
  apply le_antisymm,
  assumption,
  rw le_add_weak_iff,
  assumption,
end

theorem lt_add {a₁ a₂ b₁ b₂ : ℚ} : a₁ < a₂ → b₁ < b₂ → a₁ + b₁ < a₂ + b₂ :=
begin
  intros ha hb,
  have int₁ : a₁ + b₁ < a₂ + b₁ := lt_add_weak b₁ ha,
  have int₂ : a₂ + b₁ < a₂ + b₂,
    rw add_comm a₂,
    rw add_comm a₂,
    exact lt_add_weak a₂ hb,
  apply lt_trans,
  assumption,
  assumption,
end

theorem le_then_lt_lt {a₁ a₂ a₃ : ℚ} : a₁ ≤ a₂ → a₂ < a₃ → a₁ < a₃ :=
begin
  intros l12 h23,
  cases h23 with l23 n23,
  rw lt_not_ge,
  intro l31,
  apply n23,
  apply le_antisymm,
  assumption,
  apply le_trans,
  assumption,
  assumption,
end

end rational


open classical
variables p q r s : Prop

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p :=
  iff.intro
    (assume H : p ∧ q,
      show q ∧ p, from and.intro (and.elim_right H) (and.elim_left H))
    (assume H : q ∧ p,
      show p ∧ q, from and.intro (and.elim_right H) (and.elim_left H))

example : p ∨ q ↔ q ∨ p :=
  iff.intro
    (assume H : p ∨ q, show q ∨ p, from
        or.elim H
          (assume H : p, show q ∨ p, from or.intro_right q H)
          (assume H : q, show q ∨ p, from or.intro_left p H))
    (assume H : q ∨ p, show p ∨ q, from
        or.elim H
          (assume H : q, show p ∨ q, from or.intro_right p H)
          (assume H : p, show p ∨ q, from or.intro_left q H))

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
  iff.intro
    (assume H : (p ∧ q) ∧ r, show p ∧ (q ∧ r), from
      and.intro
        (and.elim_left (and.elim_left H))
        (and.intro (and.elim_right (and.elim_left H)) (and.elim_right H)))
    (assume H : p ∧ (q ∧ r), show (p ∧ q) ∧ r, from
      and.intro
        (and.intro (and.elim_left H) (and.elim_left (and.elim_right H)))
        (and.elim_right (and.elim_right H)))

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
  iff.intro
    (assume H : (p ∨ q) ∨ r, show p ∨ (q ∨ r), from
      or.elim H
        (assume H : p ∨ q, show p ∨ (q ∨ r), from
          or.elim H
          (assume H : p, show p ∨ (q ∨ r), from
            or.intro_left (q ∨ r) H)
          (assume H : q, show p ∨ (q ∨ r), from
            or.intro_right p (or.intro_left r H)))
        (assume H : r, show p ∨ (q ∨ r), from
          or.intro_right p (or.intro_right q H)))
    (assume H : p ∨ (q ∨ r), show (p ∨ q) ∨ r, from
      or.elim H
        (assume H : p, show (p ∨ q) ∨ r, from
          or.intro_left r (or.intro_left q H))
        (assume H : q ∨ r, show (p ∨ q) ∨ r, from
          or.elim H
          (assume H : q, show (p ∨ q) ∨ r, from
            or.intro_left r (or.intro_right p H))
          (assume H : r, show (p ∨ q) ∨ r, from
            or.intro_right (p ∨ q) H)))

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
  iff.intro
    (assume H : p ∧ (q ∨ r), show (p ∧ q) ∨ (p ∧ r), from
      have Hp : p, from and.elim_left H,
      or.elim (and.elim_right H)
        (assume Hq : q, show (p ∧ q) ∨ (p ∧ r), from
          or.intro_left (p ∧ r) (and.intro Hp Hq))
        (assume Hr : r, show (p ∧ q) ∨ (p ∧ r), from
          or.intro_right (p ∧ q) (and.intro Hp Hr)))
    (assume H : (p ∧ q) ∨ (p ∧ r), show p ∧ (q ∨ r), from
      or.elim H
        (assume H : p ∧ q, show p ∧ (q ∨ r), from
          and.intro (and.elim_left H)
                    (or.intro_left r (and.elim_right H)))
        (assume H : p ∧ r, show p ∧ (q ∨ r), from
          and.intro (and.elim_left H)
                    (or.intro_right q (and.elim_right H))))

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
  iff.intro
    (assume H : p ∨ (q ∧ r), show (p ∨ q) ∧ (p ∨ r), from
      or.elim H
        (assume Hp : p, show (p ∨ q) ∧ (p ∨ r), from
          and.intro (or.intro_left q Hp) (or.intro_left r Hp))
        (assume Hqr : q ∧ r, show (p ∨ q) ∧ (p ∨ r), from
          and.intro (or.intro_right p (and.elim_left Hqr))
                    (or.intro_right p (and.elim_right Hqr))))
    (assume H : (p ∨ q) ∧ (p ∨ r), show p ∨ (q ∧ r), from
      (λ Hpq : p ∨ q,
        or.elim Hpq
          (λ Hp : p,
            λ Hpr : p ∨ r, or.inl Hp)
          (λ Hq : q,
            (λ Hpr : p ∨ r,
              or.elim Hpr
                (λ Hp : p, or.inl Hp)
                (λ Hr : r, or.inr (and.intro Hq Hr)))))
      (and.elim_left H)
      (and.elim_right H))

-- other properties

example : (p → (q → r)) ↔ (p ∧ q → r) :=
  iff.intro
    (assume H : p → (q → r), show (p ∧ q → r), from
      (assume Hpq : p ∧ q, show r, from
        (H (and.elim_left Hpq)) (and.elim_right Hpq)))
    (assume H : p ∧ q → r, show  p → (q → r), from
      (assume Hp : p, show q → r, from
        (assume Hq : q, show r, from
          H (and.intro Hp Hq))))

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
  iff.intro
    (λ H : (p ∨ q) → r,
      and.intro (λ Hp : p, H (or.inl Hp)) (λ Hq : q, H (or.inr Hq)))
    (λ H : (p → r) ∧ (q → r),
      (λ Hpq : p ∨ q,
        or.elim Hpq
          (λ Hp : p, (and.elim_left H) Hp)
          (λ Hq : q, (and.elim_right H) Hq)))

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
  iff.intro
    (λ H : ¬(p ∨ q), and.intro
      (λ Hp : p, H (or.inl Hp))
      (λ Hq : q, H (or.inr Hq)))
    (λ H : ¬p ∧ ¬q,
      (λ Hpq : p ∨ q, or.elim Hpq
        (λ Hp : p, (and.elim_left H) Hp)
        (λ Hq : q, (and.elim_right H) Hq)))

example : ¬p ∨ ¬q → ¬(p ∧ q) :=
  (λ H : ¬p ∨ ¬q, or.elim H
    (λ Hp : ¬p,
      (λ Hpq : p ∧ q, Hp (and.elim_left Hpq)))
    (λ Hq : ¬q,
      (λ Hpq : p ∧ q, Hq (and.elim_right Hpq))))

example : ¬(p ∧ ¬ p) :=
  (λ H : p ∧ ¬ p, (and.elim_right H) (and.elim_left H))

example : p ∧ ¬q → ¬(p → q) :=
  (λ H : p ∧ ¬q,
    (λ H1 : p → q,
      (and.elim_right H) (H1 (and.elim_left H))))

example : ¬p → (p → q) :=
  (λ Hnp : ¬p,
    (λ Hp : p, false.elim (Hnp Hp)))

example : (¬p ∨ q) → (p → q) :=
  (λ H : ¬p ∨ q, or.elim H
    (λ Hnp : ¬p, (λ Hp : p, false.elim (Hnp Hp)))
    (λ Hq : q, (λ Hp : p, Hq)))

example : p ∨ false ↔ p :=
  iff.intro
    (λ H : p ∨ false, or.elim H
      (λ Hp : p, Hp)
      (λ H : false, false.elim H))
    (λ Hp : p, or.inl Hp)

example : p ∧ false ↔ false :=
  iff.intro
    (λ H : p ∧ false, and.elim_right H)
    (λ H : false, false.elim H)

example : ¬(p ↔ ¬p) := iff.elim
  (λ H1 : p → ¬p,
    (λ H2 : ¬p → p,
      let Hnp := (λ Hp : p, (H1 Hp) Hp) in
      let Hp := H2 Hnp in
        Hnp Hp))

example : (p → q) → (¬q → ¬p) :=
  (λ H : p → q,
    (λ Hnq : ¬q,
      (λ Hp : p, Hnq (H Hp))))

-- these require classical reasoning
example : (p → r ∨ s) → ((p → r) ∨ (p → s)) :=
  let or_help (Hnr : ¬r) (H : r ∨ s) :=
    or.elim H
        (λ Hr : r, false.elim (Hnr Hr))
        (λ Hs : s, Hs)
  in
  (λ H : p → r ∨ s,
    let mr := em r in
      or.elim mr
        (λ Hr : r, or.inl (λ Hp : p, Hr))
        (λ Hnr : ¬r, or.inr (λ Hp : p, or_help Hnr (H Hp))))

example : ¬(p ∧ q) → ¬p ∨ ¬q :=
  (λ H : ¬(p ∧ q),
    or.elim (em p)
      (λ Hp : p,
        or.elim (em q)
          (λ Hq : q, false.elim (H (and.intro Hp Hq)))
          (λ Hnq : ¬q, or.inr Hnq))
      (λ Hnp : ¬p, or.inl Hnp))

example : ¬(p → q) → p ∧ ¬q :=
  (λ H : ¬(p → q),
    let Hnq := (λ Hq : q, H (λ Hp : p, Hq)) in
    let Hp := or.elim (em p)
      (λ Hp : p, Hp)
      (λ Hnp : ¬p, false.elim (H (λ Hp : p, false.elim (Hnp Hp))))
    in
    and.intro Hp Hnq)

example : (p → q) → (¬p ∨ q) :=
  (λ H : p → q,
    or.elim (em p)
      (λ Hp : p, or.inr (H Hp))
      (λ Hnp : ¬p, or.inl Hnp))

example : (¬q → ¬p) → (p → q) :=
  (λ H : ¬q → ¬p,
    (λ Hp : p, or.elim (em q)
      (λ Hq : q, Hq)
      (λ Hnq : ¬q, false.elim ((H Hnq) Hp))))

example : p ∨ ¬p := em p

example : (((p → q) → p) → p) :=
  (λ H : (p → q) → p,
    or.elim (em p)
      (λ Hp : p, Hp)
      (λ Hnp : ¬p, H
        (λ Hp : p, false.elim (Hnp Hp))))


-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    abs a = abs (a - b + b)
-- ----------------------------------------------------------------------

import data.real.basic

-- 1ª demostración
-- ===============

example
  (a b : ℝ)
  : abs a = abs (a - b + b) :=
begin
  congr,
  ring,
end

-- Prueba
-- ======

/-
a b : ℝ
⊢ abs a = abs (a - b + b)
  >> congr,
⊢ a = a - b + b
  >> ring,
no goals
-/

-- Comentario: La táctica cong sustituye una conclusión de la forma
-- A = B por las igualdades de sus subtérminos que no no iguales por
-- definición. Por ejemplo, sustituye la conclusión (x * f y = g w * f z)
-- por las conclusiones (x = g w) y (y = z).

-- 2ª demostración
-- ===============

example
  (a b : ℝ)
  : abs a = abs (a - b + b) :=
by { congr, ring }

-- 3ª demostración
-- ===============

example
  (a b : ℝ)
  : abs a = abs (a - b + b) :=
by ring


import algebra.category.Module.basic
import linear_algebra.finite_dimensional

/-!
Every monomorphism in fdVec splits.

This is not-so-secretly an exercise in using the linear algebra library
-/

variables (𝕜 : Type) [field 𝕜]

open category_theory

abbreviation Vec := Module 𝕜

@[derive category]
def fdVec := full_subcategory (λ V : Vec 𝕜, finite_dimensional 𝕜 V)

/--
We set up a `has_coe_to_sort` for `fdVec 𝕜`, sending an object directly to the underlying type.
-/
instance : has_coe_to_sort (fdVec 𝕜) (Type*) :=
{ coe := λ V, V.obj }

/--
Lean can already work out that this underlying type has the `module 𝕜` typeclass.
-/
example (V : fdVec 𝕜) : module 𝕜 V := by apply_instance

/--
But we need to tell it about the availability of the `finite_dimensional 𝕜` typeclass.
-/
instance fdVec_finite_dimensional (V : fdVec 𝕜) : finite_dimensional 𝕜 V := V.property

def exercise {X Y : fdVec 𝕜} (f : X ⟶ Y) [mono f] : split_mono f :=
-- We want to
-- * pick a basis of `X`, using `exists_is_basis`
-- * see that its image under `f` is linearly independent in `Y`, using `linear_independent.image_subtype`
-- * extend that set to a basis of `Y` using `exists_subset_is_basis`
-- * define a map back using `is_basis.constr`
-- * check it has the right property, using `is_basis.ext`
sorry

/-!
In practice, one should just prove this theorem directly in the linear algebra library,
without reference to `fdVec`. The statement will be more verbose!
The proof of the "categorical" statement should just be one line.
-/


import data.finsupp.basic
-- import data.finsupp.lattice
import data.finset.basic
import data.finsupp.antidiagonal
-- import ..vars

section

open finsupp

parameter {S : Type}
parameter [decidable_eq S]

-- TODO rephrase lemma with nat_antidiagonal

/-- A general lemma about the anitdiagonal of a finsupp.single. -/
lemma single_antidiagonal (s : S) (n : ℕ) :
  (single s n).antidiagonal
  = (finset.range (n+1)).image (λ i, (finsupp.single s (n-i), finsupp.single s (i)))
:=
begin
  rw finset.ext_iff,
  intro a,
  rw finsupp.mem_antidiagonal,
  rw finset.mem_image,
  split,
  intro h,
  use a.snd s,
  split,
  rw finsupp.ext_iff at h,
  have h1 := h s,
  simp at h1,
  rw finset.mem_range,
  rw ←h1,
  apply @nat.lt_of_lt_of_le (a.snd s) (a.snd s + 1) _,
  exact lt_add_one ((a.snd) s),
  rw add_assoc,
  exact ((a.snd) s + 1).le_add_left ((a.fst) s),
  rw prod.ext_iff,
  simp,
  split,
  rw finsupp.ext_iff,
  intro a_1,
  rw finsupp.nat_sub_apply,
  rw finsupp.single_apply,
  rw finsupp.single_apply,
  by_cases h2 : a_1 = s,
   rw h2,
   simp,
   have h3 : (a.fst + a.snd) s = (finsupp.single s n) s,
   rw h,
   rw finsupp.add_apply at h3,
   rw finsupp.single_apply at h3,
   simp at h3,
   rw ←h3,
   simp,
   rw if_neg,
   rw if_neg,
   have h3 : (a.fst + a.snd) a_1 = (finsupp.single s n) a_1,
   rw h,
   rw finsupp.add_apply at h3,
   rw finsupp.single_apply at h3,
   simp at h3,
   rw if_neg at h3,
   simp at h3,
  --  rw nat.sub_zero,
  --  rw add_eq_zero_iff at h3,
   rw h3.left,
   finish,
   finish,
   finish,
  rw finsupp.ext_iff,
  intro a_1,
  rw finsupp.single_apply,
  by_cases h2 : a_1 = s,
    rw h2,
    simp,
    rw if_neg,
    have h3 : (a.fst + a.snd) a_1 = (finsupp.single s n) a_1,
    rw h,
    rw finsupp.add_apply at h3,
    rw finsupp.single_apply at h3,
    simp at h3,
    rw if_neg at h3,
    -- rw add_eq_zero_iff at h3,
    simp at h3,

    rw h3.right,
    finish,
    finish,
  intro h,
  cases h,
  cases h_h,
  let h1 := prod.ext_iff.1 h_h_h,
  rw [←h1.left, ←h1.right],
  simp,
  rw [←finsupp.single_nat_sub, ←finsupp.single_add],
  rw finset.mem_range at h_h_w,
  have h4 : n - h_w + h_w = n,
    rw nat.lt_succ_iff at h_h_w,
    exact nat.sub_add_cancel h_h_w,
  rw h4,
end

lemma finsupp.sub_le_right_of_le_add (a b c : S →₀ ℕ) (h : a ≤ b + c) : a - c ≤ b :=
begin
  intro,
  have z := h s,
  rw nat_sub_apply,
  rw add_apply at z,
  -- rw z,
  exact nat.sub_le_right_of_le_add z,
end

-- TODO generalize and add to mathlib
lemma nat.add_inf (a b c : ℕ) : a + (b ⊓ c) = (a + b) ⊓ (a + c) :=
begin
  by_cases b ≤ c,
  simp [inf_eq_left.2 h],
  exact h,
  have h' : c ≤ b,
    exact le_of_not_ge h,
  simp [inf_eq_right.2 h'],
  exact h',
end

lemma finsupp.nat_add_inf (a b c : S →₀ ℕ) : a + (b ⊓ c) = (a + b) ⊓ (a + c) :=
begin
  ext,
  simp only [add_apply, finsupp.inf_apply],
  apply nat.add_inf,
end

-- -- TODO generalize and add to mathlib
-- lemma nat.add_lemma (a b c : ℕ) (h : b ≤ a) : a - b + c = a + c - b :=
-- begin
--   exact nat.sub_add_eq_add_sub h,
-- end

-- TODO generalize and add to mathlib
lemma nat.add_lemma2 (a b c : ℕ) : c = a + b -> c - a = b :=
begin
  exact nat.sub_eq_of_eq_add
end

lemma helper (a b c d : ℕ) (h : b + d = a + c) : a - b ⊓ a + (c - (b - b ⊓ a)) = d :=
begin
  by_cases h1 : b ≤ a,
  simp [inf_eq_left.2 h1],
  rw nat.sub_add_eq_add_sub,
  rw <-h,
  exact norm_num.sub_nat_pos (b + d) b d rfl,
  exact h1,
  have h' : a ≤ b,
    exact le_of_not_ge h1,
  simp [inf_eq_right.2 h'],
  apply nat.sub_eq_of_eq_add,
  rw nat.sub_add_eq_add_sub,
  rw h,
  simp only [nat.add_sub_cancel_left],
  exact h'
end

-- TODO: Put in mathlib
lemma add_antidiagonal (f g : S →₀ ℕ) : (f + g).antidiagonal = (finset.product (f.antidiagonal) (g.antidiagonal)).image (λ x, ((x.fst.fst + x.snd.fst), (x.fst.snd + x.snd.snd))) :=
begin
  rw finset.ext_iff,
  intro a,
  rw mem_antidiagonal,
  rw finset.mem_image,
  split,
  {
    intro h,
    use ((a.fst ⊓ f, f - (a.fst ⊓ f)), (a.fst - (a.fst ⊓ f), g - (a.fst - (a.fst ⊓ f)))),
    split,
    -- TODO abstract lemma about a+b, a+c, b+d, c+d
    rw finset.mem_product,
    split,
    simp only [mem_antidiagonal],
    apply finsupp.nat_add_sub_of_le,
    exact inf_le_right,
    simp only [mem_antidiagonal],
    apply finsupp.nat_add_sub_of_le,
    apply finsupp.sub_le_right_of_le_add,
    rw finsupp.nat_add_inf,
    simp,
    rw add_comm,
    rw ←h,
    simp,
    -- simp only,
    have tmp : a = (a.fst, a.snd),
    simp,
    rw tmp,
    simp only,
    apply congr_arg2,
    apply finsupp.nat_add_sub_of_le,
    exact inf_le_left,

    -- TODO probably the best way to finish is
    ext,
    simp only [add_apply, nat_sub_apply, finsupp.inf_apply],
    apply helper,
    have h1 := finsupp.ext_iff.1 h,
    exact h1 a_1,

    -- then by_cases on the ⊓ which is greater.
  },
  { intro h,
    cases h with a1 h2,
    cases h2 with H h3,
    rw finset.mem_product at H,
    rw finsupp.mem_antidiagonal at H,
    rw finsupp.mem_antidiagonal at H,
    rw [←H.left, ←H.right],
    rw prod.ext_iff at h3,
    rw [←h3.left, ←h3.right],
    finish,
    }
  -- hint,
  -- ext,
  -- simp only,
  -- use
end

/-- A copy of the square_antidiagonal lemma, which relies on the more general single_antidiagonal rather than being self contained. -/
lemma single_2_antidiagonal (s : S) : (finsupp.single s 2).antidiagonal =
{
  (finsupp.single s 0, finsupp.single s 2),
  (finsupp.single s 1, finsupp.single s 1),
  (finsupp.single s 2, finsupp.single s 0),
}
:=
begin
  rw single_antidiagonal,
  rw finset.range,
  rw finset.image,
  simp [-finsupp.single_nat_sub],
end

lemma single_1_antidiagonal (s : S) : (finsupp.single s 1).antidiagonal =
{
  (finsupp.single s 0, finsupp.single s 1),
  (finsupp.single s 1, finsupp.single s 0),
}
:=
begin
  rw single_antidiagonal,
  rw finset.range,
  rw finset.image,
  simp [-finsupp.single_nat_sub],
end

end


/- Coercion pullback example from the paper "Hints in Unification" -/

universes u

structure Monoid where
  α    : Type u
  op   : α → α → α
  unit : α

structure Group where
  α    : Type u
  op   : α → α → α
  unit : α
  inv : α → α

structure Ring where
  α    : Type u
  mul  : α → α → α
  add  : α → α → α
  neg  : α → α
  one  : α
  zero : α

def Group.ofRing (r : Ring) : Group where
  α    := r.α
  op   := r.add
  inv  := r.neg
  unit := r.zero

def Monoid.ofRing (r : Ring) : Monoid where
  α    := r.α
  op   := r.mul
  unit := r.one

instance : CoeSort Ring (Type u) where
  coe s := s.α

instance : CoeSort Monoid (Type u) where
  coe s := s.α

instance : CoeSort Group (Type u) where
  coe s := s.α

def gop {s : Group} (a b : s) : s :=
  s.op a b

def mop {s : Monoid} (a b : s) : s :=
  s.op a b

infix:70 (priority := high) "*" => mop
infix:65 (priority := high) "+" => gop

unif_hint (r : Ring) (g : Group) where
  g =?= Group.ofRing r
  |-
  r.α =?= g.α

unif_hint (r : Ring) (m : Monoid) where
  m =?= Monoid.ofRing r
  |-
  r.α =?= m.α

def distrib {r : Ring} (a b c : r) := a * (b + c) = a * b + a * c

theorem ex1 {r : Ring} (a b c : r) : distrib a b c = (a * (b + c) = a * b + a * c) :=
  rfl

theorem ex2 {r : Ring} (a b c : r) : distrib a b c = (mop a (gop b c) = gop (mop a b) (mop a c)) :=
  rfl


import analysis.real
import algebra.archimedean
import tactic.norm_num

variables {β : Type} [floor_ring β]

namespace decimal

section
parameters {α : Type} [floor_ring α]
-- ⌊(real.sqrt 2 : ℝ)⌋

definition chomp (r : α) : ℕ → α
| 0 := (r - floor r) * 10
| (n + 1) := (chomp n - floor (chomp n)) * 10

-- tell Mario I'll put the promise in the name
definition expansion_nonneg (r : α) : ℕ → ℕ
| 0 := int.to_nat (floor r)
| (n + 1) := int.to_nat (floor (chomp r n))

-- mario said
--local instance decidable_prop

lemma chomp_is_zero (n : ℕ) (r : α) : chomp r n = 0 → ∀ m, chomp r (n + m) = 0 :=
begin
intros H m,induction m with d Hd,assumption,
show chomp r (nat.succ (n + d)) = 0,
unfold chomp,rw Hd,simp,
end

--set_option pp.notation false
lemma int.succ_le_of_lt (a b : ℤ) : a < b → int.succ a ≤ b := id

--begin
--intro H,
--exact H,
--end

@[simp] theorem rat.cast_floor
  {α} [linear_ordered_field α] [archimedean α] (x : ℚ) :
  by haveI := archimedean.floor_ring α; exact ⌊(x:α)⌋ = ⌊x⌋ :=
begin
  haveI := archimedean.floor_ring α,
  apply le_antisymm,
  { rw [le_floor, ← @rat.cast_le α, rat.cast_coe_int],
    apply floor_le },
  { rw [le_floor, ← rat.cast_coe_int, rat.cast_le],
    apply floor_le }
end

lemma floor_of_bounds (r : α) (z : ℤ) :
  ↑z ≤ r ∧ r < (z + 1) ↔ ⌊ r ⌋ = z :=
by rw [← le_floor, ← int.cast_one, ← int.cast_add, ← floor_lt,
  int.lt_add_one_iff, le_antisymm_iff, and.comm]

end

noncomputable definition s : ℝ := (71/100 : ℝ)

theorem sQ : s = ((71/100:ℚ):ℝ) := by unfold s;norm_num

--set_option pp.all true
theorem floor_s : floor s = 0 :=
by rw [← floor_of_bounds, s, int.cast_zero]; norm_num

theorem floor_10s : floor (71/10 : ℝ) = 7 :=
begin
rw [← floor_of_bounds],
split,
norm_num,
end

lemma chomping_s : chomp s 2 = 0 :=
begin
unfold chomp,
rw floor_s,
unfold s,
norm_num,
rw floor_10s,
norm_num,
end

theorem chomped (n : ℕ) : chomp s (n + 2) = 0 :=
begin
induction n with d Hd,exact chomping_s,
rw chomp.equations._eqn_2,
rw Hd,
simp,
end
-- recall s = 71/100
theorem no_eights_in_0_point_71 (n : ℕ) : decimal.expansion_nonneg s n ≠ 8 :=
begin
cases n,unfold expansion_nonneg,rw floor_s,show 0 ≠ 8,by cc,
cases n,unfold expansion_nonneg chomp,rw floor_s,unfold s,
  rw int.cast_zero,
  have this : ((71 / 100 : ℝ) - 0) * 10 = 71 / 10 := by norm_num,
  rw this,rw floor_10s,show 7 ≠ 8,by cc,
cases n,unfold expansion_nonneg chomp,rw floor_s,unfold s,
  rw int.cast_zero,
  norm_num,
  rw floor_10s,
  norm_num,
  show 1 ≠ 8,
  by cc,
unfold expansion_nonneg,
rw [chomped,floor_zero],
show 0 ≠ 8,
by cc,
end

end decimal