import data.fin
import data.equiv.fin

namespace fin

@[simp] lemma fin_sum_fin_equiv_symm_apply_cast_add {m n : ℕ} (i : fin m) :
  fin_sum_fin_equiv.symm (cast_add n i) = sum.inl i :=
begin
  rw [fin_sum_fin_equiv_symm_apply_left _ (cast_add_lt _ _)],
  simp
end

@[simp] lemma fin_sum_fin_equiv_symm_apply_cast_add_right {m n : ℕ} (i : fin m) :
  fin_sum_fin_equiv.symm (cast_add_right n i) = sum.inr i :=
begin
  rw [fin_sum_fin_equiv_symm_apply_right _ (le_cast_add_right _ _)],
  simp
end

@[simp] lemma fin_sum_fin_equiv_apply_left' {m : ℕ} (n : ℕ) (i : fin m) :
  (fin_sum_fin_equiv (sum.inl i) : fin (m + n)) = fin.cast_add n i := rfl

@[simp] lemma fin_sum_fin_equiv_apply_right' (m : ℕ) {n : ℕ} (i : fin n) :
  (fin_sum_fin_equiv (sum.inr i) : fin (m + n)) = fin.cast_add_right m i := rfl

end fin


import algebraic_geometry.AffineScheme
import sheaves_of_modules.defs
import algebra.category.Module.limits
import algebra.module.localized_module

/-

# Sheaf of modules associated to a module over a ring

This was *practice* for the 2nd alg geom lecture
-/

--open Module.category_theory -- puzzle

variables {R : CommRing.{0}} (M : Module.{0} R)

open algebraic_geometry

open Top

open algebraic_geometry.Scheme

--@[derive [comm_ring, local_ring]]
--def localizations (P : prime_spectrum.Top R) : Type u := localization.at_prime P.as_ideal

-- protected abbreviation localization.at_prime := localization I.prime_compl

variable (P : prime_spectrum.Top R)

-- #check P.as_ideal.prime_compl -- submonoid R

--#check localized_module (P.as_ideal.prime_compl) M

-- works
example : module (localization (P.as_ideal.prime_compl))
  (localized_module (P.as_ideal.prime_compl) M) := infer_instance

namespace Module

@[derive add_comm_group]
def localizations (P : prime_spectrum.Top R) := localized_module (P.as_ideal.prime_compl) M

--instance (P : prime_spectrum.Top R) : module (localization (P.as_ideal.prime_compl))
--  (M.localizations P) := by unfold Module.localizations; apply_instance

/-
/--
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)⟩ } }
-/

--#check structure_sheaf.is_fraction
/-
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
-/

example : module (localization (P.as_ideal.prime_compl))
  (localized_module (P.as_ideal.prime_compl) M) := infer_instance

/--
The predicate saying that a dependent function on an open `U` valued in localisations of
a module `M` is realised as a fixed fraction `m / s` in each of the stalks (which are
localizations at various prime ideals).
-/
def is_fraction {U : topological_space.opens ↥(prime_spectrum.Top R)}
  (f : Π (x : ↥U), M.localizations ↑x) : Prop :=
∃ (m : M) (s : R), ∀ x : U, ¬ (s ∈ x.1.as_ideal) ∧
  (algebra_map _ (localization (x.1.as_ideal.prime_compl)) s) •
  (id (f x) : localized_module (x.1.as_ideal.prime_compl) M) =
  localized_module.mk_linear_map (x.1.as_ideal.prime_compl) M m

/--
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 (M.localizations) :=
{ pred := λ U f, M.is_fraction f,
  res := by { rintro V U i f ⟨r, s, w⟩, exact ⟨r, s, λ x, w (i x)⟩ } }

def is_locally_fraction : local_predicate (M.localizations) :=
(M.is_fraction_prelocal).sheafify

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

/-
/--
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 (x : prime_spectrum.Top R) : add_comm_group (M.localizations x) := infer_instance

def sheaf_in_Type : sheaf (Type) (prime_spectrum.Top R):=
subsheaf_to_Types (M.is_locally_fraction)

open topological_space opposite

--#check structure_presheaf_in_CommRing
def sections_add_subgroup (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  add_subgroup (Π x : unop U, M.localizations x) :=
{ carrier := { f | (M.is_locally_fraction).pred f },
  zero_mem' := begin
    rintro ⟨x, hx⟩,
    use [unop U, hx, 𝟙 _, 0, 1],
    intro y,
    refine ⟨_, _⟩,
    { rw ←ideal.ne_top_iff_one, exact y.1.is_prime.1, },
    { simp only [pi.zero_apply, id.def, smul_zero, localized_module.mk_linear_map_apply,
        localized_module.zero_mk]},
  end,
  neg_mem' := begin
    intros f hf x,
    obtain ⟨V, hV, i, m, s, hmfs⟩ := hf x,
    refine ⟨V, hV, i, -m, s, λ y, _⟩,
    obtain ⟨h1, h2⟩ := hmfs y,
    refine ⟨h1, _⟩,
    simp only [id.def, pi.neg_apply, algebra_map_smul, smul_neg,
      localized_module.mk_linear_map_apply] at h2 ⊢,
    rw h2,
    refl,
  end,
  add_mem' := begin
    intros a b ha hb x,
    obtain ⟨V, hV, i, m, s, hms⟩ := ha x,
    obtain ⟨W, hW, j, n, t, hnt⟩ := hb x,
    use V ⊓ W,
    refine ⟨⟨hV,hW⟩, opens.inf_le_left _ _ ≫ i, t • m + s • n, s * t, λ y, _⟩,
    obtain ⟨hs, hsa⟩ := hms ⟨y.1, y.2.1⟩,
    obtain ⟨ht, htb⟩ := hnt ⟨y.1, y.2.2⟩,
    split,
    { intro H, cases y.1.is_prime.mem_or_mem H; contradiction, },
    { simp only [pi.add_apply, id.def, smul_add, algebra_map_smul],
      rw [mul_smul _ _ (b _), mul_comm, mul_smul, linear_map.map_add, linear_map.map_smul,
        linear_map.map_smul],
      congr', },
  end,
}

instance (U) : add_comm_group ((M.sheaf_in_Type).1.obj U) :=
(M.sections_add_subgroup U).to_add_comm_group

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

-/

def presheaf_in_Ab : presheaf Ab.{0} (prime_spectrum.Top R):=
{ obj := λ U, AddCommGroup.of ((M.sheaf_in_Type).1.obj U),
  map := λ U V i,
  { to_fun := (M.sheaf_in_Type).1.map i,
    map_zero' := rfl,
    map_add' := λ x y, rfl, }, }

open _root_.category_theory

def presheaf_comp_forget :
  M.presheaf_in_Ab ⋙ (forget Ab) ≅ (M.sheaf_in_Type).1 :=
nat_iso.of_components
  (λ U, iso.refl _)
  (by tidy)

/--
The abelian sheaf on $Spec R$ associated to an R-module M, valued in `Ab`.
-/
def ab_sheaf : sheaf Ab (prime_spectrum.Top R) :=
⟨M.presheaf_in_Ab, (presheaf.is_sheaf_iff_is_sheaf_comp _ _).mpr
    (presheaf.is_sheaf_of_iso (M.presheaf_comp_forget).symm
      (M.sheaf_in_Type).cond)⟩

def ab_sheaf.global_section_map : M →+ M.ab_sheaf.1.obj (opposite.op ⊤) :=
{ to_fun := λ m, ⟨λ x, localized_module.mk_linear_map _ _ m, begin
    intro x,
    use [⊤, by simp only [subtype.val_eq_coe, localized_module.mk_linear_map_apply, exists_prop]],
    use 𝟙 _,
    use m,
    use 1,
    intro y,
    split,
    { rw ←ideal.ne_top_iff_one, exact y.1.is_prime.1, },
    { simp only [map_one, localized_module.mk_linear_map_apply, id.def, one_smul], },
  end⟩,
  map_zero' := rfl,
  map_add' :=λ a b, begin
    ext,
    simp only [localized_module.mk_linear_map_apply, subtype.coe_mk],
    congr';
    simp,
  end }

#exit
def sheaf_of_modules: SHEAF_OF_MODULES (Spec.obj (opposite.op R)).to_LocallyRingedSpace.to_RingedSpace :=
{ ab_sheaf := M.ab_sheaf,
  module_structure := λ U,
  { smul := λ r m, ⟨λ y, begin
      let foo := r.1 y,
      delta Module.localizations,
      delta structure_sheaf.localizations at foo,
      exact foo • (m.1 y),
    end, begin
--      simp only [subtype.val_eq_coe, id.def],
      intro y,
      obtain ⟨W ,hmW, iW, rW, sW, hW⟩ := r.2 y,
      obtain ⟨X ,hmX, iX, mX, rX, hX⟩ := m.2 y,
      use W ⊓ X,
      refine ⟨⟨hmW, hmX⟩, _⟩,
      use opens.inf_le_left _ _ ≫ iW,
      refine ⟨rW • mX, _⟩,
      use sW * rX,
      rintro ⟨y, hWy, hXy⟩,
      obtain ⟨hsW1, hsW2⟩ := hW ⟨y, hWy⟩,
      obtain ⟨hrX1, hrX2⟩ := hX ⟨y, hXy⟩,
      split,
      { intro H, cases y.is_prime.mem_or_mem H; contradiction },
      simp at hsW2 hrX2 ⊢,
      --swap, simp,
      --simp at hW,
      /-
      Exists s ∈ R such that s non-vanishing on W ∩ X
      and ∀ x ∈ W ∩ X, s • r(x) • m(x) = ?m_1 ∈ M
      know hsW2: r(x)*sW=rW
      and hrX2 : rX•m(x)=mX ∈ M
      let's try sW*rX?
      rW*mX
      -/
      sorry,
    end⟩,
    one_smul := sorry,
    mul_smul := sorry,
    smul_zero := sorry,
    smul_add := sorry,
    add_smul := sorry,
    zero_smul := sorry },
  compatibility_bit := sorry }

end Module


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/

import algebra.big_operators.basic
import algebra.module.basic
import data.nat.interval
import tactic.linarith
import tactic.abel

/-!
# Results about big operators over intervals

We prove results about big operators over intervals (mostly the `ℕ`-valued `Ico m n`).
-/

universes u v w

open_locale big_operators nat

namespace finset

section generic

variables {α : Type u} {β : Type v} {γ : Type w} {s₂ s₁ s : finset α} {a : α}
  {g f : α → β}

variables [comm_monoid β]

@[to_additive]
lemma prod_Ico_add' [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α]
  [locally_finite_order α] (f : α → β) (a b c : α) :
  (∏ x in Ico a b, f (x + c)) = (∏ x in Ico (a + c) (b + c), f x) :=
begin
  classical,
  rw [←image_add_right_Ico, prod_image (λ x hx y hy h, add_right_cancel h)],
end

@[to_additive]
lemma prod_Ico_add [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α]
  [locally_finite_order α] (f : α → β) (a b c : α) :
  (∏ x in Ico a b, f (c + x)) = (∏ x in Ico (a + c) (b + c), f x) :=
begin
  convert prod_Ico_add' f a b c,
  simp_rw add_comm,
end

lemma sum_Ico_succ_top {δ : Type*} [add_comm_monoid δ] {a b : ℕ}
  (hab : a ≤ b) (f : ℕ → δ) : (∑ k in Ico a (b + 1), f k) = (∑ k in Ico a b, f k) + f b :=
by rw [nat.Ico_succ_right_eq_insert_Ico hab, sum_insert right_not_mem_Ico, add_comm]

@[to_additive]
lemma prod_Ico_succ_top {a b : ℕ} (hab : a ≤ b) (f : ℕ → β) :
  (∏ k in Ico a (b + 1), f k) = (∏ k in Ico a b, f k) * f b :=
@sum_Ico_succ_top (additive β) _ _ _ hab _

lemma sum_eq_sum_Ico_succ_bot {δ : Type*} [add_comm_monoid δ] {a b : ℕ}
  (hab : a < b) (f : ℕ → δ) : (∑ k in Ico a b, f k) = f a + (∑ k in Ico (a + 1) b, f k) :=
have ha : a ∉ Ico (a + 1) b, by simp,
by rw [← sum_insert ha, nat.Ico_insert_succ_left hab]

@[to_additive]
lemma prod_eq_prod_Ico_succ_bot {a b : ℕ} (hab : a < b) (f : ℕ → β) :
  (∏ k in Ico a b, f k) = f a * (∏ k in Ico (a + 1) b, f k) :=
@sum_eq_sum_Ico_succ_bot (additive β) _ _ _ hab _

@[to_additive]
lemma prod_Ico_consecutive (f : ℕ → β) {m n k : ℕ} (hmn : m ≤ n) (hnk : n ≤ k) :
  (∏ i in Ico m n, f i) * (∏ i in Ico n k, f i) = (∏ i in Ico m k, f i) :=
Ico_union_Ico_eq_Ico hmn hnk ▸ eq.symm $ prod_union $ Ico_disjoint_Ico_consecutive m n k

@[to_additive]
lemma prod_range_mul_prod_Ico (f : ℕ → β) {m n : ℕ} (h : m ≤ n) :
  (∏ k in range m, f k) * (∏ k in Ico m n, f k) = (∏ k in range n, f k) :=
nat.Ico_zero_eq_range ▸ nat.Ico_zero_eq_range ▸ prod_Ico_consecutive f m.zero_le h

@[to_additive]
lemma prod_Ico_eq_mul_inv {δ : Type*} [comm_group δ] (f : ℕ → δ) {m n : ℕ} (h : m ≤ n) :
  (∏ k in Ico m n, f k) = (∏ k in range n, f k) * (∏ k in range m, f k)⁻¹ :=
eq_mul_inv_iff_mul_eq.2 $ by rw [mul_comm]; exact prod_range_mul_prod_Ico f h

lemma sum_Ico_eq_sub {δ : Type*} [add_comm_group δ] (f : ℕ → δ) {m n : ℕ} (h : m ≤ n) :
  (∑ k in Ico m n, f k) = (∑ k in range n, f k) - (∑ k in range m, f k) :=
by simpa only [sub_eq_add_neg] using sum_Ico_eq_add_neg f h

/-- The two ways of summing over `(i,j)` in the range `a<=i<=j<b` are equal. -/
lemma sum_Ico_Ico_comm {M : Type*} [add_comm_monoid M]
  (a b : ℕ) (f : ℕ → ℕ → M) :
  ∑ i in finset.Ico a b, ∑ j in finset.Ico i b, f i j =
  ∑ j in finset.Ico a b, ∑ i in finset.Ico a (j+1), f i j :=
begin
  rw [finset.sum_sigma', finset.sum_sigma'],
  refine finset.sum_bij'
    (λ (x : Σ (i : ℕ), ℕ) _, (⟨x.2, x.1⟩ : Σ (i : ℕ), ℕ)) _ (λ _ _, rfl)
    (λ (x : Σ (i : ℕ), ℕ) _, (⟨x.2, x.1⟩ : Σ (i : ℕ), ℕ)) _
    (by rintro ⟨⟩ _; refl) (by rintro ⟨⟩ _; refl);
  simp only [finset.mem_Ico, sigma.forall, finset.mem_sigma];
  rintros a b ⟨⟨h₁,h₂⟩, ⟨h₃, h₄⟩⟩; refine ⟨⟨_, _⟩, ⟨_, _⟩⟩; linarith
end

@[to_additive]
lemma prod_Ico_eq_prod_range (f : ℕ → β) (m n : ℕ) :
  (∏ k in Ico m n, f k) = (∏ k in range (n - m), f (m + k)) :=
begin
  by_cases h : m ≤ n,
  { rw [←nat.Ico_zero_eq_range, prod_Ico_add, zero_add, tsub_add_cancel_of_le h] },
  { replace h : n ≤ m :=  le_of_not_ge h,
     rw [Ico_eq_empty_of_le h, tsub_eq_zero_iff_le.mpr h, range_zero, prod_empty, prod_empty] }
end

lemma prod_Ico_reflect (f : ℕ → β) (k : ℕ) {m n : ℕ} (h : m ≤ n + 1) :
  ∏ j in Ico k m, f (n - j) = ∏ j in Ico (n + 1 - m) (n + 1 - k), f j :=
begin
  have : ∀ i < m, i ≤ n,
  { intros i hi,
    exact (add_le_add_iff_right 1).1 (le_trans (nat.lt_iff_add_one_le.1 hi) h) },
  cases lt_or_le k m with hkm hkm,
  { rw [← nat.Ico_image_const_sub_eq_Ico (this _ hkm)],
    refine (prod_image _).symm,
    simp only [mem_Ico],
    rintros i ⟨ki, im⟩ j ⟨kj, jm⟩ Hij,
    rw [← tsub_tsub_cancel_of_le (this _ im), Hij, tsub_tsub_cancel_of_le (this _ jm)] },
  { simp [Ico_eq_empty_of_le, tsub_le_tsub_left, hkm] }
end

lemma sum_Ico_reflect {δ : Type*} [add_comm_monoid δ] (f : ℕ → δ) (k : ℕ) {m n : ℕ}
  (h : m ≤ n + 1) :
  ∑ j in Ico k m, f (n - j) = ∑ j in Ico (n + 1 - m) (n + 1 - k), f j :=
@prod_Ico_reflect (multiplicative δ) _ f k m n h

lemma prod_range_reflect (f : ℕ → β) (n : ℕ) :
  ∏ j in range n, f (n - 1 - j) = ∏ j in range n, f j :=
begin
  cases n,
  { simp },
  { simp only [←nat.Ico_zero_eq_range, nat.succ_sub_succ_eq_sub, tsub_zero],
    rw prod_Ico_reflect _ _ le_rfl,
    simp }
end

lemma sum_range_reflect {δ : Type*} [add_comm_monoid δ] (f : ℕ → δ) (n : ℕ) :
  ∑ j in range n, f (n - 1 - j) = ∑ j in range n, f j :=
@prod_range_reflect (multiplicative δ) _ f n

@[simp] lemma prod_Ico_id_eq_factorial : ∀ n : ℕ, ∏ x in Ico 1 (n + 1), x = n!
| 0 := rfl
| (n+1) := by rw [prod_Ico_succ_top $ nat.succ_le_succ $ zero_le n,
  nat.factorial_succ, prod_Ico_id_eq_factorial n, nat.succ_eq_add_one, mul_comm]

@[simp] lemma prod_range_add_one_eq_factorial : ∀ n : ℕ, ∏ x in range n, (x+1) = n!
| 0 := rfl
| (n+1) := by simp [finset.range_succ, prod_range_add_one_eq_factorial n]

section gauss_sum

/-- Gauss' summation formula -/
lemma sum_range_id_mul_two (n : ℕ) :
  (∑ i in range n, i) * 2 = n * (n - 1) :=
calc (∑ i in range n, i) * 2 = (∑ i in range n, i) + (∑ i in range n, (n - 1 - i)) :
  by rw [sum_range_reflect (λ i, i) n, mul_two]
... = ∑ i in range n, (i + (n - 1 - i)) : sum_add_distrib.symm
... = ∑ i in range n, (n - 1) : sum_congr rfl $ λ i hi, add_tsub_cancel_of_le $
  nat.le_pred_of_lt $ mem_range.1 hi
... = n * (n - 1) : by rw [sum_const, card_range, nat.nsmul_eq_mul]

/-- Gauss' summation formula -/
lemma sum_range_id (n : ℕ) : (∑ i in range n, i) = (n * (n - 1)) / 2 :=
by rw [← sum_range_id_mul_two n, nat.mul_div_cancel]; exact dec_trivial

end gauss_sum

end generic

section nat

variable {β : Type*}
variables (f g : ℕ → β) {m n : ℕ}

section group

variable [comm_group β]

@[to_additive]
lemma prod_range_succ_div_prod : (∏ i in range (n+1), f i) / ∏ i in range n, f i = f n :=
div_eq_iff_eq_mul'.mpr $ prod_range_succ f n

@[to_additive]
lemma prod_range_succ_div_top : (∏ i in range (n+1), f i) / f n = ∏ i in range n, f i :=
div_eq_iff_eq_mul.mpr $ prod_range_succ f n

@[to_additive]
lemma prod_Ico_div_bot (hmn : m < n) : (∏ i in Ico m n, f i) / f m = ∏ i in Ico (m+1) n, f i :=
div_eq_iff_eq_mul'.mpr $ prod_eq_prod_Ico_succ_bot hmn _

@[to_additive]
lemma prod_Ico_succ_div_top (hmn : m ≤ n) : (∏ i in Ico m (n+1), f i) / f n = ∏ i in Ico m n, f i :=
div_eq_iff_eq_mul.mpr $ prod_Ico_succ_top hmn _

end group

end nat

section module

variables {R M : Type*} [ring R] [add_comm_group M] [module R M] (f : ℕ → R) (g : ℕ → M) {m n : ℕ}
open finset
-- The partial sum of `g`, starting from zero
local notation `G` n:80 := ∑ i in range n, g i

/-- **Summation by parts**, also known as **Abel's lemma** or an **Abel transformation** -/
theorem sum_Ico_by_parts (hmn : m < n) :
  ∑ i in Ico m n, f i • g i =
  f (n-1) • G n - f m • G m - ∑ i in Ico m (n-1), (f (i+1) - f i) • G (i+1) :=
begin
  have h₁ : ∑ i in Ico (m+1) n, (f i • G i) = ∑ i in Ico m (n-1), (f (i+1) • G (i+1)),
  { conv in n { rw ←nat.sub_add_cancel (nat.one_le_of_lt hmn) },
    rw ←sum_Ico_add' },
  have h₂ : ∑ i in Ico (m+1) n, (f i • G (i+1))
          = ∑ i in Ico m (n-1), (f i • G (i+1)) + f (n-1) • G n - f m • G (m+1) :=
  by rw [←sum_Ico_sub_bot _ hmn, ←sum_Ico_succ_sub_top _ (nat.le_pred_of_lt hmn),
         nat.sub_add_cancel (pos_of_gt hmn), sub_add_cancel],
  rw sum_eq_sum_Ico_succ_bot hmn,
  conv { for (f _ • g _) [2] { rw ← sum_range_succ_sub_sum g } },
  simp_rw [smul_sub, sum_sub_distrib, h₂, h₁],
  conv_lhs { congr, skip, rw [←add_sub, add_comm, ←add_sub, ←sum_sub_distrib] },
  have : ∀ i, f i • G (i+1) - f (i+1) • G (i+1) = -((f (i+1) - f i) • G (i+1)),
  { intro i,
    rw sub_smul,
    abel },
  simp_rw [this, sum_neg_distrib, sum_range_succ, smul_add],
  abel,
end

/-- **Summation by parts** for ranges -/
lemma sum_range_by_parts (hn : 0 < n) :
  ∑ i in range n, (f i • g i) = f (n-1) • G n - ∑ i in range (n-1), (f (i+1) - f i) • G (i+1) :=
by rw [range_eq_Ico, sum_Ico_by_parts f g hn, sum_range_zero, smul_zero, sub_zero, range_eq_Ico]

end module

end finset


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import data.polynomial.lifts
import group_theory.monoid_localization
import ring_theory.algebraic
import ring_theory.ideal.local_ring
import ring_theory.integral_closure
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.non_zero_divisors
import tactic.ring_exp

/-!
# Integral and algebraic elements of a fraction field

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/
variables {R : Type*} [comm_ring R] (M : submonoid R) {S : Type*} [comm_ring S]
variables [algebra R S] {P : Type*} [comm_ring P]

open_locale big_operators polynomial

namespace is_localization

section integer_normalization

open polynomial

variables (M) {S} [is_localization M S]

open_locale classical

/-- `coeff_integer_normalization p` gives the coefficients of the polynomial
`integer_normalization p` -/
noncomputable def coeff_integer_normalization (p : S[X]) (i : ℕ) : R :=
if hi : i ∈ p.support
then classical.some (classical.some_spec
      (exist_integer_multiples_of_finset M (p.support.image p.coeff))
      (p.coeff i)
      (finset.mem_image.mpr ⟨i, hi, rfl⟩))
else 0

lemma coeff_integer_normalization_of_not_mem_support (p : S[X]) (i : ℕ)
  (h : coeff p i = 0) : coeff_integer_normalization M p i = 0 :=
by simp only [coeff_integer_normalization, h, mem_support_iff, eq_self_iff_true, not_true,
  ne.def, dif_neg, not_false_iff]

lemma coeff_integer_normalization_mem_support (p : S[X]) (i : ℕ)
  (h : coeff_integer_normalization M p i ≠ 0) : i ∈ p.support :=
begin
  contrapose h,
  rw [ne.def, not_not, coeff_integer_normalization, dif_neg h]
end

/-- `integer_normalization g` normalizes `g` to have integer coefficients
by clearing the denominators -/
noncomputable def integer_normalization (p : S[X]) :
  R[X] :=
∑ i in p.support, monomial i (coeff_integer_normalization M p i)

@[simp]
lemma integer_normalization_coeff (p : S[X]) (i : ℕ) :
  (integer_normalization M p).coeff i = coeff_integer_normalization M p i :=
by simp [integer_normalization, coeff_monomial, coeff_integer_normalization_of_not_mem_support]
  {contextual := tt}

lemma integer_normalization_spec (p : S[X]) :
  ∃ (b : M), ∀ i,
    algebra_map R S ((integer_normalization M p).coeff i) = (b : R) • p.coeff i :=
begin
  use classical.some (exist_integer_multiples_of_finset M (p.support.image p.coeff)),
  intro i,
  rw [integer_normalization_coeff, coeff_integer_normalization],
  split_ifs with hi,
  { exact classical.some_spec (classical.some_spec
      (exist_integer_multiples_of_finset M (p.support.image p.coeff))
      (p.coeff i)
      (finset.mem_image.mpr ⟨i, hi, rfl⟩)) },
  { convert (smul_zero _).symm,
    { apply ring_hom.map_zero },
    { exact not_mem_support_iff.mp hi } }
end

lemma integer_normalization_map_to_map (p : S[X]) :
  ∃ (b : M), (integer_normalization M p).map (algebra_map R S) = (b : R) • p :=
let ⟨b, hb⟩ := integer_normalization_spec M p in
⟨b, polynomial.ext (λ i, by { rw [coeff_map, coeff_smul], exact hb i })⟩

variables {R' : Type*} [comm_ring R']

lemma integer_normalization_eval₂_eq_zero (g : S →+* R') (p : S[X])
  {x : R'} (hx : eval₂ g x p = 0) :
  eval₂ (g.comp (algebra_map R S)) x (integer_normalization M p) = 0 :=
let ⟨b, hb⟩ := integer_normalization_map_to_map M p in
trans (eval₂_map (algebra_map R S) g x).symm
  (by rw [hb, ← is_scalar_tower.algebra_map_smul S (b : R) p, eval₂_smul, hx, mul_zero])

lemma integer_normalization_aeval_eq_zero [algebra R R'] [algebra S R'] [is_scalar_tower R S R']
  (p : S[X]) {x : R'} (hx : aeval x p = 0) :
  aeval x (integer_normalization M p) = 0 :=
by rw [aeval_def, is_scalar_tower.algebra_map_eq R S R',
       integer_normalization_eval₂_eq_zero _ _ _ hx]

end integer_normalization
end is_localization

namespace is_fraction_ring

open is_localization

variables {A K C : Type*} [comm_ring A] [is_domain A] [field K] [algebra A K] [is_fraction_ring A K]
variables [comm_ring C]

lemma integer_normalization_eq_zero_iff {p : K[X]} :
  integer_normalization (non_zero_divisors A) p = 0 ↔ p = 0 :=
begin
  refine (polynomial.ext_iff.trans (polynomial.ext_iff.trans _).symm),
  obtain ⟨⟨b, nonzero⟩, hb⟩ := integer_normalization_spec _ p,
  split; intros h i,
  { apply to_map_eq_zero_iff.mp,
    rw [hb i, h i],
    apply smul_zero,
    assumption },
  { have hi := h i,
    rw [polynomial.coeff_zero, ← @to_map_eq_zero_iff A _ K, hb i, algebra.smul_def] at hi,
    apply or.resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero hi),
    intro h,
    apply mem_non_zero_divisors_iff_ne_zero.mp nonzero,
    exact to_map_eq_zero_iff.mp h }
end

variables (A K C)

/-- An element of a ring is algebraic over the ring `A` iff it is algebraic
over the field of fractions of `A`.
-/
lemma is_algebraic_iff [algebra A C] [algebra K C] [is_scalar_tower A K C] {x : C} :
  is_algebraic A x ↔ is_algebraic K x :=
begin
  split; rintros ⟨p, hp, px⟩,
  { refine ⟨p.map (algebra_map A K), λ h, hp (polynomial.ext (λ i, _)), _⟩,
    { have : algebra_map A K (p.coeff i) = 0 := trans (polynomial.coeff_map _ _).symm (by simp [h]),
      exact to_map_eq_zero_iff.mp this },
    { exact (polynomial.aeval_map_algebra_map K _ _).trans px, } },
  { exact ⟨integer_normalization _ p,
           mt integer_normalization_eq_zero_iff.mp hp,
           integer_normalization_aeval_eq_zero _ p px⟩ },
end

variables {A K C}

/-- A ring is algebraic over the ring `A` iff it is algebraic over the field of fractions of `A`.
-/
lemma comap_is_algebraic_iff [algebra A C] [algebra K C] [is_scalar_tower A K C] :
  algebra.is_algebraic A C ↔ algebra.is_algebraic K C :=
⟨λ h x, (is_algebraic_iff A K C).mp (h x), λ h x, (is_algebraic_iff A K C).mpr (h x)⟩

end is_fraction_ring

open is_localization

section is_integral
variables {R S} {Rₘ Sₘ : Type*} [comm_ring Rₘ] [comm_ring Sₘ]
variables [algebra R Rₘ] [is_localization M Rₘ]
variables [algebra S Sₘ] [is_localization (algebra.algebra_map_submonoid S M) Sₘ]

variables {S M}

open polynomial

lemma ring_hom.is_integral_elem_localization_at_leading_coeff
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S)
  (x : S) (p : R[X]) (hf : p.eval₂ f x = 0) (M : submonoid R)
  (hM : p.leading_coeff ∈ M) {Rₘ Sₘ : Type*} [comm_ring Rₘ] [comm_ring Sₘ]
  [algebra R Rₘ] [is_localization M Rₘ]
  [algebra S Sₘ] [is_localization (M.map f : submonoid S) Sₘ] :
  (map Sₘ f M.le_comap_map : Rₘ →+* _).is_integral_elem (algebra_map S Sₘ x) :=
begin
  by_cases triv : (1 : Rₘ) = 0,
  { exact ⟨0, ⟨trans leading_coeff_zero triv.symm, eval₂_zero _ _⟩⟩ },
  haveI : nontrivial Rₘ := nontrivial_of_ne 1 0 triv,
  obtain ⟨b, hb⟩ := is_unit_iff_exists_inv.mp
    (map_units Rₘ ⟨p.leading_coeff, hM⟩),
  refine ⟨(p.map (algebra_map R Rₘ)) * C b, ⟨_, _⟩⟩,
  { refine monic_mul_C_of_leading_coeff_mul_eq_one _,
    rwa leading_coeff_map_of_leading_coeff_ne_zero (algebra_map R Rₘ),
    refine λ hfp, zero_ne_one (trans (zero_mul b).symm (hfp ▸ hb) : (0 : Rₘ) = 1) },
  { refine eval₂_mul_eq_zero_of_left _ _ _ _,
    erw [eval₂_map, is_localization.map_comp, ← hom_eval₂ _ f (algebra_map S Sₘ) x],
    exact trans (congr_arg (algebra_map S Sₘ) hf) (ring_hom.map_zero _) }
end

/-- Given a particular witness to an element being algebraic over an algebra `R → S`,
We can localize to a submonoid containing the leading coefficient to make it integral.
Explicitly, the map between the localizations will be an integral ring morphism -/
theorem is_integral_localization_at_leading_coeff {x : S} (p : R[X])
  (hp : aeval x p = 0) (hM : p.leading_coeff ∈ M) :
  (map Sₘ (algebra_map R S)
      (show _ ≤ (algebra.algebra_map_submonoid S M).comap _, from M.le_comap_map)
    : Rₘ →+* _).is_integral_elem (algebra_map S Sₘ x) :=
(algebra_map R S).is_integral_elem_localization_at_leading_coeff x p hp M hM

/-- If `R → S` is an integral extension, `M` is a submonoid of `R`,
`Rₘ` is the localization of `R` at `M`,
and `Sₘ` is the localization of `S` at the image of `M` under the extension map,
then the induced map `Rₘ → Sₘ` is also an integral extension -/
theorem is_integral_localization (H : algebra.is_integral R S) :
  (map Sₘ (algebra_map R S)
    (show _ ≤ (algebra.algebra_map_submonoid S M).comap _, from M.le_comap_map)
    : Rₘ →+* _).is_integral :=
begin
  intro x,
  obtain ⟨⟨s, ⟨u, hu⟩⟩, hx⟩ := surj (algebra.algebra_map_submonoid S M) x,
  obtain ⟨v, hv⟩ := hu,
  obtain ⟨v', hv'⟩ := is_unit_iff_exists_inv'.1 (map_units Rₘ ⟨v, hv.1⟩),
  refine @is_integral_of_is_integral_mul_unit Rₘ _ _ _
    (localization_algebra M S) x (algebra_map S Sₘ u) v' _ _,
  { replace hv' := congr_arg (@algebra_map Rₘ Sₘ _ _ (localization_algebra M S)) hv',
    rw [ring_hom.map_mul, ring_hom.map_one, ← ring_hom.comp_apply _ (algebra_map R Rₘ)] at hv',
    erw is_localization.map_comp at hv',
    exact hv.2 ▸ hv' },
  { obtain ⟨p, hp⟩ := H s,
    exact hx.symm ▸ is_integral_localization_at_leading_coeff p hp.2 (hp.1.symm ▸ M.one_mem) }
end

lemma is_integral_localization' {R S : Type*} [comm_ring R] [comm_ring S]
  {f : R →+* S} (hf : f.is_integral) (M : submonoid R) :
  (map (localization (M.map (f : R →* S))) f
    (M.le_comap_map : _ ≤ submonoid.comap (f : R →* S) _) : localization M →+* _).is_integral :=
@is_integral_localization R _ M S _ f.to_algebra _ _ _ _ _ _ _ _ hf

variable (M)

lemma is_localization.scale_roots_common_denom_mem_lifts (p : Rₘ[X])
  (hp : p.leading_coeff ∈ (algebra_map R Rₘ).range) :
  p.scale_roots (algebra_map R Rₘ $ is_localization.common_denom M p.support p.coeff) ∈
    polynomial.lifts (algebra_map R Rₘ) :=
begin
  rw polynomial.lifts_iff_coeff_lifts,
  intro n,
  rw [polynomial.coeff_scale_roots],
  by_cases h₁ : n ∈ p.support,
  by_cases h₂ : n = p.nat_degree,
  { rwa [h₂, polynomial.coeff_nat_degree, tsub_self, pow_zero, _root_.mul_one] },
  { have : n + 1 ≤ p.nat_degree := lt_of_le_of_ne (polynomial.le_nat_degree_of_mem_supp _ h₁) h₂,
    rw [← tsub_add_cancel_of_le (le_tsub_of_add_le_left this), pow_add, pow_one, mul_comm,
      _root_.mul_assoc, ← map_pow],
    change _ ∈ (algebra_map R Rₘ).range,
    apply mul_mem,
    { exact ring_hom.mem_range_self _ _ },
    { rw ← algebra.smul_def,
      exact ⟨_, is_localization.map_integer_multiple M p.support p.coeff ⟨n, h₁⟩⟩ } },
  { rw polynomial.not_mem_support_iff at h₁,
    rw [h₁, zero_mul],
    exact zero_mem (algebra_map R Rₘ).range }
end

lemma is_integral.exists_multiple_integral_of_is_localization
  [algebra Rₘ S] [is_scalar_tower R Rₘ S] (x : S) (hx : is_integral Rₘ x) :
    ∃ m : M, is_integral R (m • x) :=
begin
  cases subsingleton_or_nontrivial Rₘ with _ nontriv; resetI,
  { haveI := (algebra_map Rₘ S).codomain_trivial,
    exact ⟨1, polynomial.X, polynomial.monic_X, subsingleton.elim _ _⟩ },
  obtain ⟨p, hp₁, hp₂⟩ := hx,
  obtain ⟨p', hp'₁, -, hp'₂⟩ := lifts_and_nat_degree_eq_and_monic
    (is_localization.scale_roots_common_denom_mem_lifts M p _) _,
  { refine ⟨is_localization.common_denom M p.support p.coeff, p', hp'₂, _⟩,
    rw [is_scalar_tower.algebra_map_eq R Rₘ S, ← polynomial.eval₂_map, hp'₁,
      submonoid.smul_def, algebra.smul_def, is_scalar_tower.algebra_map_apply R Rₘ S],
    exact polynomial.scale_roots_eval₂_eq_zero _ hp₂ },
  { rw hp₁.leading_coeff, exact one_mem _ },
  { rwa polynomial.monic_scale_roots_iff },
end

end is_integral

variables {A K : Type*} [comm_ring A] [is_domain A]

namespace is_integral_closure

variables (A) {L : Type*} [field K] [field L] [algebra A K] [algebra A L] [is_fraction_ring A K]
variables (C : Type*) [comm_ring C] [is_domain C] [algebra C L] [is_integral_closure C A L]
variables [algebra A C] [is_scalar_tower A C L]

open algebra

/-- If the field `L` is an algebraic extension of the integral domain `A`,
the integral closure `C` of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_algebraic (alg : is_algebraic A L)
  (inj : ∀ x, algebra_map A L x = 0 → x = 0) :
  is_fraction_ring C L :=
{ map_units := λ ⟨y, hy⟩,
    is_unit.mk0 _ (show algebra_map C L y ≠ 0, from λ h, mem_non_zero_divisors_iff_ne_zero.mp hy
      ((injective_iff_map_eq_zero (algebra_map C L)).mp (algebra_map_injective C A L) _ h)),
  surj := λ z, let ⟨x, y, hy, hxy⟩ := exists_integral_multiple (alg z) inj in
    ⟨⟨mk' C (x : L) x.2, algebra_map _ _ y,
        mem_non_zero_divisors_iff_ne_zero.mpr (λ h, hy (inj _
          (by rw [is_scalar_tower.algebra_map_apply A C L, h, ring_hom.map_zero])))⟩,
     by rw [set_like.coe_mk, algebra_map_mk', ← is_scalar_tower.algebra_map_apply A C L, hxy]⟩,
  eq_iff_exists := λ x y, ⟨λ h, ⟨1, by simpa using algebra_map_injective C A L h⟩, λ ⟨c, hc⟩,
    congr_arg (algebra_map _ L) (mul_left_cancel₀ (mem_non_zero_divisors_iff_ne_zero.mp c.2) hc)⟩ }

variables (K L)

/-- If the field `L` is a finite extension of the fraction field of the integral domain `A`,
the integral closure `C` of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_finite_extension [algebra K L] [is_scalar_tower A K L]
  [finite_dimensional K L] : is_fraction_ring C L :=
is_fraction_ring_of_algebraic A C
  (is_fraction_ring.comap_is_algebraic_iff.mpr (is_algebraic_of_finite K L))
  (λ x hx, is_fraction_ring.to_map_eq_zero_iff.mp ((map_eq_zero $ algebra_map K L).mp $
    (is_scalar_tower.algebra_map_apply _ _ _ _).symm.trans hx))

end is_integral_closure

namespace integral_closure

variables {L : Type*} [field K] [field L] [algebra A K] [is_fraction_ring A K]

open algebra

/-- If the field `L` is an algebraic extension of the integral domain `A`,
the integral closure of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_algebraic [algebra A L] (alg : is_algebraic A L)
  (inj : ∀ x, algebra_map A L x = 0 → x = 0) :
  is_fraction_ring (integral_closure A L) L :=
is_integral_closure.is_fraction_ring_of_algebraic A (integral_closure A L) alg inj

variables (K L)

/-- If the field `L` is a finite extension of the fraction field of the integral domain `A`,
the integral closure of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_finite_extension [algebra A L] [algebra K L]
  [is_scalar_tower A K L] [finite_dimensional K L] :
  is_fraction_ring (integral_closure A L) L :=
is_integral_closure.is_fraction_ring_of_finite_extension A K L (integral_closure A L)

end integral_closure

namespace is_fraction_ring

variables (R S K)

/-- `S` is algebraic over `R` iff a fraction ring of `S` is algebraic over `R` -/
lemma is_algebraic_iff' [field K] [is_domain R] [is_domain S] [algebra R K] [algebra S K]
  [no_zero_smul_divisors R K] [is_fraction_ring S K] [is_scalar_tower R S K] :
  algebra.is_algebraic R S ↔ algebra.is_algebraic R K :=
begin
  simp only [algebra.is_algebraic],
  split,
  { intros h x,
    rw [is_fraction_ring.is_algebraic_iff R (fraction_ring R) K, is_algebraic_iff_is_integral],
    obtain ⟨(a : S), b, ha, rfl⟩ := @div_surjective S _ _ _ _ _ _ x,
    obtain ⟨f, hf₁, hf₂⟩ := h b,
    rw [div_eq_mul_inv],
    refine is_integral_mul _ _,
    { rw [← is_algebraic_iff_is_integral],
      refine _root_.is_algebraic_of_larger_base_of_injective
        (no_zero_smul_divisors.algebra_map_injective R (fraction_ring R)) _,
      exact is_algebraic_algebra_map_of_is_algebraic (h a) },
    { rw [← is_algebraic_iff_is_integral],
      use (f.map (algebra_map R (fraction_ring R))).reverse,
      split,
      { rwa [ne.def, polynomial.reverse_eq_zero, ← polynomial.degree_eq_bot,
          polynomial.degree_map_eq_of_injective
            (no_zero_smul_divisors.algebra_map_injective R (fraction_ring R)),
          polynomial.degree_eq_bot]},
      { haveI : invertible (algebra_map S K b),
           from is_unit.invertible (is_unit_of_mem_non_zero_divisors
              (mem_non_zero_divisors_iff_ne_zero.2
                (λ h, non_zero_divisors.ne_zero ha
                    ((injective_iff_map_eq_zero (algebra_map S K)).1
                    (no_zero_smul_divisors.algebra_map_injective _ _) b h)))),
        rw [polynomial.aeval_def, ← inv_of_eq_inv, polynomial.eval₂_reverse_eq_zero_iff,
          polynomial.eval₂_map, ← is_scalar_tower.algebra_map_eq, ← polynomial.aeval_def,
          polynomial.aeval_algebra_map_apply, hf₂, ring_hom.map_zero] } } },
  { intros h x,
    obtain ⟨f, hf₁, hf₂⟩ := h (algebra_map S K x),
    use [f, hf₁],
    rw [polynomial.aeval_algebra_map_apply] at hf₂,
    exact (injective_iff_map_eq_zero (algebra_map S K)).1
      (no_zero_smul_divisors.algebra_map_injective _ _) _ hf₂ }
end

open_locale non_zero_divisors

variables (R) {S K}
/-- If the `S`-multiples of `a` are contained in some `R`-span, then `Frac(S)`-multiples of `a`
are contained in the equivalent `Frac(R)`-span. -/
lemma ideal_span_singleton_map_subset {L : Type*}
  [is_domain R] [is_domain S] [field K] [field L]
  [algebra R K] [algebra R L] [algebra S L] [is_integral_closure S R L]
  [is_fraction_ring S L] [algebra K L] [is_scalar_tower R S L] [is_scalar_tower R K L]
  {a : S} {b : set S} (alg : algebra.is_algebraic R L) (inj : function.injective (algebra_map R L))
  (h : (ideal.span ({a} : set S) : set S) ⊆ submodule.span R b) :
  (ideal.span ({algebra_map S L a} : set L) : set L) ⊆ submodule.span K (algebra_map S L '' b) :=
begin
  intros x hx,
  obtain ⟨x', rfl⟩ := ideal.mem_span_singleton.mp hx,
  obtain ⟨y', z', rfl⟩ := is_localization.mk'_surjective (S⁰) x',
  obtain ⟨y, z, hz0, yz_eq⟩ := is_integral_closure.exists_smul_eq_mul alg inj y'
    (non_zero_divisors.coe_ne_zero z'),
  have injRS : function.injective (algebra_map R S),
  { refine function.injective.of_comp
      (show function.injective (algebra_map S L ∘ algebra_map R S), from _),
    rwa [← ring_hom.coe_comp, ← is_scalar_tower.algebra_map_eq] },
  have hz0' : algebra_map R S z ∈ S⁰ := map_mem_non_zero_divisors (algebra_map R S) injRS
    (mem_non_zero_divisors_of_ne_zero hz0),
  have mk_yz_eq : is_localization.mk' L y' z' = is_localization.mk' L y ⟨_, hz0'⟩,
  { rw [algebra.smul_def, mul_comm _ y, mul_comm _ y', ← set_like.coe_mk (algebra_map R S z) hz0']
        at yz_eq,
    exact is_localization.mk'_eq_of_eq (by rw [mul_comm _ y, mul_comm _ y', yz_eq]), },
  suffices hy : algebra_map S L (a * y) ∈ submodule.span K (⇑(algebra_map S L) '' b),
  { rw [mk_yz_eq, is_fraction_ring.mk'_eq_div, set_like.coe_mk,
        ← is_scalar_tower.algebra_map_apply, is_scalar_tower.algebra_map_apply R K L,
        div_eq_mul_inv, ← mul_assoc, mul_comm, ← map_inv₀, ← algebra.smul_def,
        ← _root_.map_mul],
    exact (submodule.span K _).smul_mem _ hy },
  refine submodule.span_subset_span R K _ _,
  rw submodule.span_algebra_map_image_of_tower,
  exact submodule.mem_map_of_mem (h (ideal.mem_span_singleton.mpr ⟨y, rfl⟩))
end
end is_fraction_ring


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

! This file was ported from Lean 3 source module order.hom.complete_lattice
! leanprover-community/mathlib commit 71b36b6f3bbe3b44e6538673819324d3ee9fcc96
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.CompleteLattice
import Mathlib.Order.Hom.Lattice

/-!
# Complete lattice homomorphisms

This file defines frame homorphisms and complete lattice homomorphisms.

We use the `FunLike` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `SupₛHom`: Maps which preserve `⨆`.
* `InfₛHom`: Maps which preserve `⨅`.
* `FrameHom`: Frame homomorphisms. Maps which preserve `⨆`, `⊓` and `⊤`.
* `CompleteLatticeHom`: Complete lattice homomorphisms. Maps which preserve `⨆` and `⨅`.

## Typeclasses

* `SupₛHomClass`
* `InfₛHomClass`
* `FrameHomClass`
* `CompleteLatticeHomClass`

## Concrete homs

* `Completelattice.setPreimage`: `Set.preimage` as a complete lattice homomorphism.

## TODO

Frame homs are Heyting homs.
-/

open Function OrderDual Set

variable {F α β γ δ : Type _} {ι : Sort _} {κ : ι → Sort _}

-- Porting note: mathport made this & InfₛHom into "SupHomCat" and "InfHomCat".
/-- The type of `⨆`-preserving functions from `α` to `β`. -/
structure SupₛHom (α β : Type _) [SupSet α] [SupSet β] where
  /-- The underlying function of a SupₛHom. -/
  toFun : α → β
  /-- The proposition that a `SupₛHom` commutes with arbitrary suprema/joins. -/
  map_supₛ' (s : Set α) : toFun (supₛ s) = supₛ (toFun '' s)
#align Sup_hom SupₛHom

/-- The type of `⨅`-preserving functions from `α` to `β`. -/
structure InfₛHom (α β : Type _) [InfSet α] [InfSet β] where
  /-- The underlying function of an `InfₛHom`. -/
  toFun : α → β
  /-- The proposition that a `InfₛHom` commutes with arbitrary infima/meets -/
  map_infₛ' (s : Set α) : toFun (infₛ s) = infₛ (toFun '' s)
#align Inf_hom InfₛHom

/-- The type of frame homomorphisms from `α` to `β`. They preserve finite meets and arbitrary joins.
-/
structure FrameHom (α β : Type _) [CompleteLattice α] [CompleteLattice β] extends
  InfTopHom α β where
  /-- The proposition that frame homomorphisms commute with arbitrary suprema/joins. -/
  map_supₛ' (s : Set α) : toFun (supₛ s) = supₛ (toFun '' s)
#align frame_hom FrameHom

/-- The type of complete lattice homomorphisms from `α` to `β`. -/
structure CompleteLatticeHom (α β : Type _) [CompleteLattice α] [CompleteLattice β] extends
  InfₛHom α β where
  /-- The proposition that complete lattice homomorphism commutes with arbitrary suprema/joins. -/
  map_supₛ' (s : Set α) : toFun (supₛ s) = supₛ (toFun '' s)
#align complete_lattice_hom CompleteLatticeHom

section

-- Porting note: mathport made this & InfHomClass into "SupHomClassCat" and "InfHomClassCat".
/-- `SupₛHomClass F α β` states that `F` is a type of `⨆`-preserving morphisms.

You should extend this class when you extend `SupₛHom`. -/
class SupₛHomClass (F : Type _) (α β : outParam <| Type _) [SupSet α] [SupSet β] extends
  FunLike F α fun _ => β where
  /-- The proposition that members of `SupₛHomClass`s commute with arbitrary suprema/joins. -/
  map_supₛ (f : F) (s : Set α) : f (supₛ s) = supₛ (f '' s)
#align Sup_hom_class SupₛHomClass

/-- `InfₛHomClass F α β` states that `F` is a type of `⨅`-preserving morphisms.

You should extend this class when you extend `InfₛHom`. -/
class InfₛHomClass (F : Type _) (α β : outParam <| Type _) [InfSet α] [InfSet β] extends
  FunLike F α fun _ => β where
  /-- The proposition that members of `InfₛHomClass`s commute with arbitrary infima/meets. -/
  map_infₛ (f : F) (s : Set α) : f (infₛ s) = infₛ (f '' s)
#align Inf_hom_class InfₛHomClass

/-- `FrameHomClass F α β` states that `F` is a type of frame morphisms. They preserve `⊓` and `⨆`.

You should extend this class when you extend `FrameHom`. -/
class FrameHomClass (F : Type _) (α β : outParam <| Type _) [CompleteLattice α]
  [CompleteLattice β] extends InfTopHomClass F α β where
  /-- The proposition that members of `FrameHomClass` commute with arbitrary suprema/joins. -/
  map_supₛ (f : F) (s : Set α) : f (supₛ s) = supₛ (f '' s)
#align frame_hom_class FrameHomClass

/-- `CompleteLatticeHomClass F α β` states that `F` is a type of complete lattice morphisms.

You should extend this class when you extend `CompleteLatticeHom`. -/
class CompleteLatticeHomClass (F : Type _) (α β : outParam <| Type _) [CompleteLattice α]
  [CompleteLattice β] extends InfₛHomClass F α β where
  /-- The proposition that members of `CompleteLatticeHomClass` commute with arbitrary
  suprema/joins. -/
  map_supₛ (f : F) (s : Set α) : f (supₛ s) = supₛ (f '' s)
#align complete_lattice_hom_class CompleteLatticeHomClass

end

export SupₛHomClass (map_supₛ)

export InfₛHomClass (map_infₛ)

attribute [simp] map_supₛ map_infₛ

theorem map_supᵢ [SupSet α] [SupSet β] [SupₛHomClass F α β] (f : F) (g : ι → α) :
    f (⨆ i, g i) = ⨆ i, f (g i) := by simp [supᵢ, ← Set.range_comp, Function.comp]
#align map_supr map_supᵢ

theorem map_supᵢ₂ [SupSet α] [SupSet β] [SupₛHomClass F α β] (f : F) (g : ∀ i, κ i → α) :
    f (⨆ (i) (j), g i j) = ⨆ (i) (j), f (g i j) := by simp_rw [map_supᵢ]
#align map_supr₂ map_supᵢ₂

theorem map_infᵢ [InfSet α] [InfSet β] [InfₛHomClass F α β] (f : F) (g : ι → α) :
    f (⨅ i, g i) = ⨅ i, f (g i) := by simp [infᵢ, ← Set.range_comp, Function.comp]
#align map_infi map_infᵢ

theorem map_infᵢ₂ [InfSet α] [InfSet β] [InfₛHomClass F α β] (f : F) (g : ∀ i, κ i → α) :
    f (⨅ (i) (j), g i j) = ⨅ (i) (j), f (g i j) := by simp_rw [map_infᵢ]
#align map_infi₂ map_infᵢ

/- Porting note: in the following, [CompleteLattice x] to {_ : CompleteLattice x}
  b/c dangerous instances -/
-- See note [lower instance priority]
instance (priority := 100) SupₛHomClass.toSupBotHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [SupₛHomClass F α β] : SupBotHomClass F α β :=
  {  ‹SupₛHomClass F α β› with
    map_sup := fun f a b => by
      rw [← supₛ_pair, map_supₛ]
      simp only [Set.image_pair, supₛ_insert, supₛ_singleton]
    map_bot := fun f => by
      rw [← supₛ_empty, map_supₛ, Set.image_empty]
      -- Porting note: rw [supₛ_empty] does not work, but exact supₛ_empty does?
      exact supₛ_empty  }
#align Sup_hom_class.to_sup_bot_hom_class SupₛHomClass.toSupBotHomClass

-- See note [lower instance priority]
instance (priority := 100) InfₛHomClass.toInfTopHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [InfₛHomClass F α β] : InfTopHomClass F α β :=
  { ‹InfₛHomClass F α β› with
    map_inf := fun f a b => by
      rw [← infₛ_pair, map_infₛ, Set.image_pair]
      simp only [Set.image_pair, infₛ_insert, infₛ_singleton]
    map_top := fun f => by
      rw [← infₛ_empty, map_infₛ, Set.image_empty]
      -- Porting note: rw [infₛ_empty] does not work, but exact infₛ_empty does?
      exact infₛ_empty  }
#align Inf_hom_class.to_inf_top_hom_class InfₛHomClass.toInfTopHomClass

-- See note [lower instance priority]
instance (priority := 100) FrameHomClass.toSupₛHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [FrameHomClass F α β] : SupₛHomClass F α β :=
  { ‹FrameHomClass F α β› with }
#align frame_hom_class.to_Sup_hom_class FrameHomClass.toSupₛHomClass

-- See note [lower instance priority]
instance (priority := 100) FrameHomClass.toBoundedLatticeHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [FrameHomClass F α β] : BoundedLatticeHomClass F α β :=
  { ‹FrameHomClass F α β›, SupₛHomClass.toSupBotHomClass with }
#align frame_hom_class.to_bounded_lattice_hom_class FrameHomClass.toBoundedLatticeHomClass

-- See note [lower instance priority]
instance (priority := 100) CompleteLatticeHomClass.toFrameHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [CompleteLatticeHomClass F α β] : FrameHomClass F α β :=
  { ‹CompleteLatticeHomClass F α β›, InfₛHomClass.toInfTopHomClass with }
#align complete_lattice_hom_class.to_frame_hom_class CompleteLatticeHomClass.toFrameHomClass

-- See note [lower instance priority]
instance (priority := 100) CompleteLatticeHomClass.toBoundedLatticeHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β}  [CompleteLatticeHomClass F α β] : BoundedLatticeHomClass F α β :=
  { SupₛHomClass.toSupBotHomClass, InfₛHomClass.toInfTopHomClass with }
#align
  complete_lattice_hom_class.to_bounded_lattice_hom_class
  CompleteLatticeHomClass.toBoundedLatticeHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toSupₛHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [OrderIsoClass F α β] : SupₛHomClass F α β :=
  { show OrderHomClass F α β from inferInstance with
    map_supₛ := fun f s =>
      eq_of_forall_ge_iff fun c => by
        simp only [← le_map_inv_iff, supₛ_le_iff, Set.ball_image_iff] }
#align order_iso_class.to_Sup_hom_class OrderIsoClass.toSupₛHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toInfₛHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [OrderIsoClass F α β] : InfₛHomClass F α β :=
  { show OrderHomClass F α β from inferInstance with
    map_infₛ := fun f s =>
      eq_of_forall_le_iff fun c => by
        simp only [← map_inv_le_iff, le_infₛ_iff, Set.ball_image_iff] }
#align order_iso_class.to_Inf_hom_class OrderIsoClass.toInfₛHomClass

-- See note [lower instance priority]
instance (priority := 100) OrderIsoClass.toCompleteLatticeHomClass {_ : CompleteLattice α}
    {_ : CompleteLattice β} [OrderIsoClass F α β] : CompleteLatticeHomClass F α β :=
  -- Porting note: Used to be:
    -- { OrderIsoClass.toSupₛHomClass, OrderIsoClass.toLatticeHomClass,
    -- show InfₛHomClass F α β from inferInstance with }
  { OrderIsoClass.toSupₛHomClass, OrderIsoClass.toInfₛHomClass with }
#align order_iso_class.to_complete_lattice_hom_class OrderIsoClass.toCompleteLatticeHomClass

instance [SupSet α] [SupSet β] [SupₛHomClass F α β] : CoeTC F (SupₛHom α β) :=
  ⟨fun f => ⟨f, map_supₛ f⟩⟩

instance [InfSet α] [InfSet β] [InfₛHomClass F α β] : CoeTC F (InfₛHom α β) :=
  ⟨fun f => ⟨f, map_infₛ f⟩⟩

instance [CompleteLattice α] [CompleteLattice β] [FrameHomClass F α β] : CoeTC F (FrameHom α β) :=
  ⟨fun f => ⟨f, map_supₛ f⟩⟩

instance [CompleteLattice α] [CompleteLattice β] [CompleteLatticeHomClass F α β] :
    CoeTC F (CompleteLatticeHom α β) :=
  ⟨fun f => ⟨f, map_supₛ f⟩⟩

/-! ### Supremum homomorphisms -/

namespace SupₛHom

variable [SupSet α]

section SupSet

variable [SupSet β] [SupSet γ] [SupSet δ]

instance : SupₛHomClass (SupₛHom α β) α β
    where
  coe := SupₛHom.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_supₛ := SupₛHom.map_supₛ'

-- Porting note: We do not want CoeFun for this in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `funLike.has_coe_toFun`
-- directly. -/
-- instance : CoeFun (SupₛHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

-- Porting note: times out
@[simp]
theorem toFun_eq_coe {f : SupₛHom α β} : f.toFun = ⇑f  :=
  rfl
#align Sup_hom.to_fun_eq_coe SupₛHom.toFun_eq_coe

@[ext]
theorem ext {f g : SupₛHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align Sup_hom.ext SupₛHom.ext

/-- Copy of a `SupₛHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : SupₛHom α β) (f' : α → β) (h : f' = f) : SupₛHom α β
    where
  toFun := f'
  map_supₛ' := h.symm ▸ f.map_supₛ'
#align Sup_hom.copy SupₛHom.copy

@[simp]
theorem coe_copy (f : SupₛHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align Sup_hom.coe_copy SupₛHom.coe_copy

theorem copy_eq (f : SupₛHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align Sup_hom.copy_eq SupₛHom.copy_eq

variable (α)

/-- `id` as a `SupₛHom`. -/
protected def id : SupₛHom α α :=
  ⟨id, fun s => by rw [id, Set.image_id]⟩
#align Sup_hom.id SupₛHom.id

instance : Inhabited (SupₛHom α α) :=
  ⟨SupₛHom.id α⟩

@[simp]
theorem coe_id : ⇑(SupₛHom.id α) = id :=
  rfl
#align Sup_hom.coe_id SupₛHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : SupₛHom.id α a = a :=
  rfl
#align Sup_hom.id_apply SupₛHom.id_apply

/-- Composition of `SupₛHom`s as a `SupₛHom`. -/
def comp (f : SupₛHom β γ) (g : SupₛHom α β) : SupₛHom α γ
    where
  toFun := f ∘ g
  map_supₛ' s := by rw [comp_apply, map_supₛ, map_supₛ, Set.image_image]; simp only [Function.comp]
#align Sup_hom.comp SupₛHom.comp

@[simp]
theorem coe_comp (f : SupₛHom β γ) (g : SupₛHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align Sup_hom.coe_comp SupₛHom.coe_comp

@[simp]
theorem comp_apply (f : SupₛHom β γ) (g : SupₛHom α β) (a : α) : (f.comp g) a = f (g a) :=
  rfl
#align Sup_hom.comp_apply SupₛHom.comp_apply

@[simp]

@[simp]
theorem comp_id (f : SupₛHom α β) : f.comp (SupₛHom.id α) = f :=
  ext fun _ => rfl
#align Sup_hom.comp_id SupₛHom.comp_id

@[simp]
theorem id_comp (f : SupₛHom α β) : (SupₛHom.id β).comp f = f :=
  ext fun _ => rfl
#align Sup_hom.id_comp SupₛHom.id_comp

theorem cancel_right {g₁ g₂ : SupₛHom β γ} {f : SupₛHom α β} (hf : Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align Sup_hom.cancel_right SupₛHom.cancel_right

theorem cancel_left {g : SupₛHom β γ} {f₁ f₂ : SupₛHom α β} (hg : Injective g) :
    g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align Sup_hom.cancel_left SupₛHom.cancel_left

end SupSet

variable { _ : CompleteLattice β}

instance : PartialOrder (SupₛHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

instance : Bot (SupₛHom α β) :=
  ⟨⟨fun _ => ⊥, fun s => by
      obtain rfl | hs := s.eq_empty_or_nonempty
      · rw [Set.image_empty, supₛ_empty]
      · rw [hs.image_const, supₛ_singleton]⟩⟩

instance : OrderBot (SupₛHom α β) where
  bot := ⊥
  bot_le := fun _ _ ↦ CompleteLattice.bot_le _

@[simp]
theorem coe_bot : ⇑(⊥ : SupₛHom α β) = ⊥ :=
  rfl
#align Sup_hom.coe_bot SupₛHom.coe_bot

@[simp]
theorem bot_apply (a : α) : (⊥ : SupₛHom α β) a = ⊥ :=
  rfl
#align Sup_hom.bot_apply SupₛHom.bot_apply

end SupₛHom

/-! ### Infimum homomorphisms -/

namespace InfₛHom

variable [InfSet α]

section InfSet

variable [InfSet β] [InfSet γ] [InfSet δ]

instance : InfₛHomClass (InfₛHom α β) α β
    where
  coe := InfₛHom.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_infₛ := InfₛHom.map_infₛ'

-- Porting note: Do not want these CoeFun instances in lean4
-- /-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_toFun`
-- directly. -/
-- instance : CoeFun (InfₛHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

@[simp]
theorem toFun_eq_coe {f : InfₛHom α β} : f.toFun = ⇑f :=
  rfl
#align Inf_hom.to_fun_eq_coe InfₛHom.toFun_eq_coe

@[ext]
theorem ext {f g : InfₛHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align Inf_hom.ext InfₛHom.ext

/-- Copy of a `InfₛHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : InfₛHom α β) (f' : α → β) (h : f' = f) : InfₛHom α β
    where
  toFun := f'
  map_infₛ' := h.symm ▸ f.map_infₛ'
#align Inf_hom.copy InfₛHom.copy

@[simp]
theorem coe_copy (f : InfₛHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align Inf_hom.coe_copy InfₛHom.coe_copy

theorem copy_eq (f : InfₛHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align Inf_hom.copy_eq InfₛHom.copy_eq

variable (α)

/-- `id` as an `InfₛHom`. -/
protected def id : InfₛHom α α :=
  ⟨id, fun s => by rw [id, Set.image_id]⟩
#align Inf_hom.id InfₛHom.id

instance : Inhabited (InfₛHom α α) :=
  ⟨InfₛHom.id α⟩

@[simp]
theorem coe_id : ⇑(InfₛHom.id α) = id :=
  rfl
#align Inf_hom.coe_id InfₛHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : InfₛHom.id α a = a :=
  rfl
#align Inf_hom.id_apply InfₛHom.id_apply

/-- Composition of `InfₛHom`s as a `InfₛHom`. -/
def comp (f : InfₛHom β γ) (g : InfₛHom α β) : InfₛHom α γ
    where
  toFun := f ∘ g
  map_infₛ' s := by rw [comp_apply, map_infₛ, map_infₛ, Set.image_image]; simp only [Function.comp]
#align Inf_hom.comp InfₛHom.comp

@[simp]
theorem coe_comp (f : InfₛHom β γ) (g : InfₛHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align Inf_hom.coe_comp InfₛHom.coe_comp

@[simp]
theorem comp_apply (f : InfₛHom β γ) (g : InfₛHom α β) (a : α) : (f.comp g) a = f (g a) :=
  rfl
#align Inf_hom.comp_apply InfₛHom.comp_apply

@[simp]
theorem comp_assoc (f : InfₛHom γ δ) (g : InfₛHom β γ) (h : InfₛHom α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align Inf_hom.comp_assoc InfₛHom.comp_assoc

@[simp]
theorem comp_id (f : InfₛHom α β) : f.comp (InfₛHom.id α) = f :=
  ext fun _ => rfl
#align Inf_hom.comp_id InfₛHom.comp_id

@[simp]
theorem id_comp (f : InfₛHom α β) : (InfₛHom.id β).comp f = f :=
  ext fun _ => rfl
#align Inf_hom.id_comp InfₛHom.id_comp

theorem cancel_right {g₁ g₂ : InfₛHom β γ} {f : InfₛHom α β} (hf : Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align Inf_hom.cancel_right InfₛHom.cancel_right

theorem cancel_left {g : InfₛHom β γ} {f₁ f₂ : InfₛHom α β} (hg : Injective g) :
    g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align Inf_hom.cancel_left InfₛHom.cancel_left

end InfSet

variable [CompleteLattice β]

instance : PartialOrder (InfₛHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

instance : Top (InfₛHom α β) :=
  ⟨⟨fun _ => ⊤, fun s => by
      obtain rfl | hs := s.eq_empty_or_nonempty
      · rw [Set.image_empty, infₛ_empty]
      · rw [hs.image_const, infₛ_singleton]⟩⟩

instance : OrderTop (InfₛHom α β) where
  top := ⊤
  le_top := fun _ _ => CompleteLattice.le_top _

@[simp]
theorem coe_top : ⇑(⊤ : InfₛHom α β) = ⊤ :=
  rfl
#align Inf_hom.coe_top InfₛHom.coe_top

@[simp]
theorem top_apply (a : α) : (⊤ : InfₛHom α β) a = ⊤ :=
  rfl
#align Inf_hom.top_apply InfₛHom.top_apply

end InfₛHom

/-! ### Frame homomorphisms -/

namespace FrameHom

variable [CompleteLattice α] [CompleteLattice β] [CompleteLattice γ] [CompleteLattice δ]

instance : FrameHomClass (FrameHom α β) α β
    where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f
    obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g
    congr
  map_supₛ f := f.map_supₛ'
  map_inf f := f.map_inf'
  map_top f := f.map_top'

-- Porting note: We do not want CoeFun for this in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_toFun`
-- directly. -/
-- instance : CoeFun (FrameHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

/-- Reinterpret a `FrameHom` as a `LatticeHom`. -/
def toLatticeHom (f : FrameHom α β) : LatticeHom α β :=
  f
#align frame_hom.to_lattice_hom FrameHom.toLatticeHom

/- Porting note: SimpNF linter complains that lhs can be simplified,
added _aux version with [simp] attribute -/
-- @[simp]
theorem toFun_eq_coe {f : FrameHom α β} : f.toFun = ⇑f :=
  rfl
#align frame_hom.to_fun_eq_coe FrameHom.toFun_eq_coe

@[simp]
theorem toFun_eq_coe_aux {f : FrameHom α β} : ↑f.toInfTopHom = ⇑f :=
  rfl

@[ext]
theorem ext {f g : FrameHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align frame_hom.ext FrameHom.ext

/-- Copy of a `FrameHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : FrameHom α β) (f' : α → β) (h : f' = f) : FrameHom α β :=
  { (f : SupₛHom α β).copy f' h with toInfTopHom := f.toInfTopHom.copy f' h }
#align frame_hom.copy FrameHom.copy

@[simp]
theorem coe_copy (f : FrameHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align frame_hom.coe_copy FrameHom.coe_copy

theorem copy_eq (f : FrameHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align frame_hom.copy_eq FrameHom.copy_eq

variable (α)

/-- `id` as a `FrameHom`. -/
protected def id : FrameHom α α :=
  { SupₛHom.id α with toInfTopHom := InfTopHom.id α }
#align frame_hom.id FrameHom.id

instance : Inhabited (FrameHom α α) :=
  ⟨FrameHom.id α⟩

@[simp]
theorem coe_id : ⇑(FrameHom.id α) = id :=
  rfl
#align frame_hom.coe_id FrameHom.coe_id

variable {α}

@[simp]
theorem id_apply (a : α) : FrameHom.id α a = a :=
  rfl
#align frame_hom.id_apply FrameHom.id_apply

/-- Composition of `FrameHom`s as a `FrameHom`. -/
def comp (f : FrameHom β γ) (g : FrameHom α β) : FrameHom α γ :=
  { (f : SupₛHom β γ).comp (g : SupₛHom α β) with
    toInfTopHom := f.toInfTopHom.comp g.toInfTopHom }
#align frame_hom.comp FrameHom.comp

@[simp]
theorem coe_comp (f : FrameHom β γ) (g : FrameHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align frame_hom.coe_comp FrameHom.coe_comp

@[simp]
theorem comp_apply (f : FrameHom β γ) (g : FrameHom α β) (a : α) : (f.comp g) a = f (g a) :=
  rfl
#align frame_hom.comp_apply FrameHom.comp_apply

@[simp]
theorem comp_assoc (f : FrameHom γ δ) (g : FrameHom β γ) (h : FrameHom α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align frame_hom.comp_assoc FrameHom.comp_assoc

@[simp]
theorem comp_id (f : FrameHom α β) : f.comp (FrameHom.id α) = f :=
  ext fun _ => rfl
#align frame_hom.comp_id FrameHom.comp_id

@[simp]
theorem id_comp (f : FrameHom α β) : (FrameHom.id β).comp f = f :=
  ext fun _ => rfl
#align frame_hom.id_comp FrameHom.id_comp

theorem cancel_right {g₁ g₂ : FrameHom β γ} {f : FrameHom α β} (hf : Surjective f) :
    g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align frame_hom.cancel_right FrameHom.cancel_right

theorem cancel_left {g : FrameHom β γ} {f₁ f₂ : FrameHom α β} (hg : Injective g) :
    g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align frame_hom.cancel_left FrameHom.cancel_left

instance : PartialOrder (FrameHom α β) :=
  PartialOrder.lift _ FunLike.coe_injective

end FrameHom

/-! ### Complete lattice homomorphisms -/

namespace CompleteLatticeHom

variable [CompleteLattice α] [CompleteLattice β] [CompleteLattice γ] [CompleteLattice δ]

instance : CompleteLatticeHomClass (CompleteLatticeHom α β) α β
    where
  coe f := f.toFun
  coe_injective' f g h := by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr
  map_supₛ f := f.map_supₛ'
  map_infₛ f := f.map_infₛ'

/-- Reinterpret a `CompleteLatticeHom` as a `SupₛHom`. -/
def toSupₛHom (f : CompleteLatticeHom α β) : SupₛHom α β :=
  f
#align complete_lattice_hom.to_Sup_hom CompleteLatticeHom.toSupₛHom

/-- Reinterpret a `CompleteLatticeHom` as a `BoundedLatticeHom`. -/
def toBoundedLatticeHom (f : CompleteLatticeHom α β) : BoundedLatticeHom α β :=
  f
#align complete_lattice_hom.to_bounded_lattice_hom CompleteLatticeHom.toBoundedLatticeHom

-- Porting note: We do not want CoeFun for this in lean 4
-- /-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_toFun`
-- directly. -/
-- instance : CoeFun (CompleteLatticeHom α β) fun _ => α → β :=
--   FunLike.hasCoeToFun

/- Porting note: SimpNF linter complains that lhs can be simplified,
added _aux version with [simp] attribute -/
-- @[simp]
theorem toFun_eq_coe {f : CompleteLatticeHom α β} : f.toFun = ⇑f :=
  rfl
#align complete_lattice_hom.to_fun_eq_coe CompleteLatticeHom.toFun_eq_coe

@[simp]
theorem toFun_eq_coe_aux {f : CompleteLatticeHom α β} : ↑f.toInfₛHom = ⇑f :=
  rfl

@[ext]
theorem ext {f g : CompleteLatticeHom α β} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext f g h
#align complete_lattice_hom.ext CompleteLatticeHom.ext

/-- Copy of a `CompleteLatticeHom` with a new `toFun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : CompleteLatticeHom α β) (f' : α → β) (h : f' = f) :
    CompleteLatticeHom α β :=
  { f.toSupₛHom.copy f' h with toInfₛHom := f.toInfₛHom.copy f' h }
#align complete_lattice_hom.copy CompleteLatticeHom.copy

@[simp]
theorem coe_copy (f : CompleteLatticeHom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align complete_lattice_hom.coe_copy CompleteLatticeHom.coe_copy

theorem copy_eq (f : CompleteLatticeHom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align complete_lattice_hom.copy_eq CompleteLatticeHom.copy_eq

variable (α)

/-- `id` as a `CompleteLatticeHom`. -/
protected def id : CompleteLatticeHom α α :=
  { SupₛHom.id α, InfₛHom.id α with toFun := id }
#align complete_lattice_hom.id CompleteLatticeHom.id

instance : Inhabited (CompleteLatticeHom α α) :=
  ⟨CompleteLatticeHom.id α⟩

@[simp]
theorem coe_id : ⇑(CompleteLatticeHom.id α) = id :=
  rfl
#align complete_lattice_hom.coe_id CompleteLatticeHom.coe_id

variable {α}
@[simp]
theorem id_apply (a : α) : CompleteLatticeHom.id α a = a :=
  rfl
#align complete_lattice_hom.id_apply CompleteLatticeHom.id_apply

/-- Composition of `CompleteLatticeHom`s as a `CompleteLatticeHom`. -/
def comp (f : CompleteLatticeHom β γ) (g : CompleteLatticeHom α β) : CompleteLatticeHom α γ :=
  { f.toSupₛHom.comp g.toSupₛHom with toInfₛHom := f.toInfₛHom.comp g.toInfₛHom }

#align complete_lattice_hom.comp CompleteLatticeHom.comp

@[simp]
theorem coe_comp (f : CompleteLatticeHom β γ) (g : CompleteLatticeHom α β) : ⇑(f.comp g) = f ∘ g :=
  rfl
#align complete_lattice_hom.coe_comp CompleteLatticeHom.coe_comp

@[simp]
theorem comp_apply (f : CompleteLatticeHom β γ) (g : CompleteLatticeHom α β) (a : α) :
    (f.comp g) a = f (g a) :=
  rfl
#align complete_lattice_hom.comp_apply CompleteLatticeHom.comp_apply

@[simp]
theorem comp_assoc (f : CompleteLatticeHom γ δ) (g : CompleteLatticeHom β γ)
    (h : CompleteLatticeHom α β) : (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align complete_lattice_hom.comp_assoc CompleteLatticeHom.comp_assoc

@[simp]
theorem comp_id (f : CompleteLatticeHom α β) : f.comp (CompleteLatticeHom.id α) = f :=
  ext fun _ => rfl
#align complete_lattice_hom.comp_id CompleteLatticeHom.comp_id

@[simp]
theorem id_comp (f : CompleteLatticeHom α β) : (CompleteLatticeHom.id β).comp f = f :=
  ext fun _ => rfl
#align complete_lattice_hom.id_comp CompleteLatticeHom.id_comp

theorem cancel_right {g₁ g₂ : CompleteLatticeHom β γ} {f : CompleteLatticeHom α β}
    (hf : Surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, congr_arg (fun a ↦ comp a f)⟩
#align complete_lattice_hom.cancel_right CompleteLatticeHom.cancel_right

theorem cancel_left {g : CompleteLatticeHom β γ} {f₁ f₂ : CompleteLatticeHom α β}
    (hg : Injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
  ⟨fun h => ext fun a => hg <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align complete_lattice_hom.cancel_left CompleteLatticeHom.cancel_left

end CompleteLatticeHom

/-! ### Dual homs -/

namespace SupₛHom

variable [SupSet α] [SupSet β] [SupSet γ]

/-- Reinterpret a `⨆`-homomorphism as an `⨅`-homomorphism between the dual orders. -/
@[simps]
protected def dual : SupₛHom α β ≃ InfₛHom αᵒᵈ βᵒᵈ
    where
  toFun f := ⟨toDual ∘ f ∘ ofDual, f.map_supₛ'⟩
  invFun f := ⟨ofDual ∘ f ∘ toDual, f.map_infₛ'⟩
  left_inv _ := SupₛHom.ext fun _ => rfl
  right_inv _ := InfₛHom.ext fun _ => rfl
#align Sup_hom.dual SupₛHom.dual

@[simp]
theorem dual_id : SupₛHom.dual (SupₛHom.id α) = InfₛHom.id _ :=
  rfl
#align Sup_hom.dual_id SupₛHom.dual_id

@[simp]
theorem dual_comp (g : SupₛHom β γ) (f : SupₛHom α β) :
    SupₛHom.dual (g.comp f) = (SupₛHom.dual g).comp (SupₛHom.dual f) :=
  rfl
#align Sup_hom.dual_comp SupₛHom.dual_comp

@[simp]
theorem symm_dual_id : SupₛHom.dual.symm (InfₛHom.id _) = SupₛHom.id α :=
  rfl
#align Sup_hom.symm_dual_id SupₛHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : InfₛHom βᵒᵈ γᵒᵈ) (f : InfₛHom αᵒᵈ βᵒᵈ) :
    SupₛHom.dual.symm (g.comp f) = (SupₛHom.dual.symm g).comp (SupₛHom.dual.symm f) :=
  rfl
#align Sup_hom.symm_dual_comp SupₛHom.symm_dual_comp

end SupₛHom

namespace InfₛHom

variable [InfSet α] [InfSet β] [InfSet γ]

/-- Reinterpret an `⨅`-homomorphism as a `⨆`-homomorphism between the dual orders. -/
@[simps]
protected def dual : InfₛHom α β ≃ SupₛHom αᵒᵈ βᵒᵈ
    where
  toFun f :=
    { toFun := toDual ∘ f ∘ ofDual
      map_supₛ' := fun _ => congr_arg toDual (map_infₛ f _) }
  invFun f :=
    { toFun := ofDual ∘ f ∘ toDual
      map_infₛ' := fun _ => congr_arg ofDual (map_supₛ f _) }
  left_inv _ := InfₛHom.ext fun _ => rfl
  right_inv _ := SupₛHom.ext fun _ => rfl
#align Inf_hom.dual InfₛHom.dual

@[simp]
theorem dual_id : InfₛHom.dual (InfₛHom.id α) = SupₛHom.id _ :=
  rfl
#align Inf_hom.dual_id InfₛHom.dual_id

@[simp]
theorem dual_comp (g : InfₛHom β γ) (f : InfₛHom α β) :
    InfₛHom.dual (g.comp f) = (InfₛHom.dual g).comp (InfₛHom.dual f) :=
  rfl
#align Inf_hom.dual_comp InfₛHom.dual_comp

@[simp]
theorem symm_dual_id : InfₛHom.dual.symm (SupₛHom.id _) = InfₛHom.id α :=
  rfl
#align Inf_hom.symm_dual_id InfₛHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : SupₛHom βᵒᵈ γᵒᵈ) (f : SupₛHom αᵒᵈ βᵒᵈ) :
    InfₛHom.dual.symm (g.comp f) = (InfₛHom.dual.symm g).comp (InfₛHom.dual.symm f) :=
  rfl
#align Inf_hom.symm_dual_comp InfₛHom.symm_dual_comp

end InfₛHom

namespace CompleteLatticeHom

variable [CompleteLattice α] [CompleteLattice β] [CompleteLattice γ]

/-- Reinterpret a complete lattice homomorphism as a complete lattice homomorphism between the dual
lattices. -/
@[simps!]
protected def dual : CompleteLatticeHom α β ≃ CompleteLatticeHom αᵒᵈ βᵒᵈ
    where
  toFun f := ⟨SupₛHom.dual f.toSupₛHom, fun s ↦ f.map_infₛ' s⟩
  invFun f := ⟨SupₛHom.dual f.toSupₛHom, fun s ↦ f.map_infₛ' s⟩
  left_inv _ := ext fun _ => rfl
  right_inv _ := ext fun _ => rfl
#align complete_lattice_hom.dual CompleteLatticeHom.dual

@[simp]
theorem dual_id : CompleteLatticeHom.dual (CompleteLatticeHom.id α) = CompleteLatticeHom.id _ :=
  rfl
#align complete_lattice_hom.dual_id CompleteLatticeHom.dual_id

@[simp]
theorem dual_comp (g : CompleteLatticeHom β γ) (f : CompleteLatticeHom α β) :
    CompleteLatticeHom.dual (g.comp f) =
      (CompleteLatticeHom.dual g).comp (CompleteLatticeHom.dual f) :=
  rfl
#align complete_lattice_hom.dual_comp CompleteLatticeHom.dual_comp

@[simp]
theorem symm_dual_id :
    CompleteLatticeHom.dual.symm (CompleteLatticeHom.id _) = CompleteLatticeHom.id α :=
  rfl
#align complete_lattice_hom.symm_dual_id CompleteLatticeHom.symm_dual_id

@[simp]
theorem symm_dual_comp (g : CompleteLatticeHom βᵒᵈ γᵒᵈ) (f : CompleteLatticeHom αᵒᵈ βᵒᵈ) :
    CompleteLatticeHom.dual.symm (g.comp f) =
      (CompleteLatticeHom.dual.symm g).comp (CompleteLatticeHom.dual.symm f) :=
  rfl
#align complete_lattice_hom.symm_dual_comp CompleteLatticeHom.symm_dual_comp

end CompleteLatticeHom

/-! ### Concrete homs -/

namespace CompleteLatticeHom

/-- `Set.preimage` as a complete lattice homomorphism.

See also `SupₛHom.setImage`. -/
def setPreimage (f : α → β) : CompleteLatticeHom (Set β) (Set α)
    where
  toFun := preimage f
  map_supₛ' s := preimage_unionₛ.trans <| by simp only [Set.supₛ_eq_unionₛ, Set.unionₛ_image]
  map_infₛ' s := preimage_interₛ.trans <| by simp only [Set.infₛ_eq_interₛ, Set.interₛ_image]
#align complete_lattice_hom.set_preimage CompleteLatticeHom.setPreimage

@[simp]
theorem coe_setPreimage (f : α → β) : ⇑(setPreimage f) = preimage f :=
  rfl
#align complete_lattice_hom.coe_set_preimage CompleteLatticeHom.coe_setPreimage

@[simp]
theorem setPreimage_apply (f : α → β) (s : Set β) : setPreimage f s = s.preimage f :=
  rfl
#align complete_lattice_hom.set_preimage_apply CompleteLatticeHom.setPreimage_apply

@[simp]
theorem setPreimage_id : setPreimage (id : α → α) = CompleteLatticeHom.id _ :=
  rfl
#align complete_lattice_hom.set_preimage_id CompleteLatticeHom.setPreimage_id

-- This lemma can't be `simp` because `g ∘ f` matches anything (`id ∘ f = f` synctatically)
theorem setPreimage_comp (g : β → γ) (f : α → β) :
    setPreimage (g ∘ f) = (setPreimage f).comp (setPreimage g) :=
  rfl
#align complete_lattice_hom.set_preimage_comp CompleteLatticeHom.setPreimage_comp

end CompleteLatticeHom

theorem Set.image_supₛ {f : α → β} (s : Set (Set α)) : f '' supₛ s = supₛ (image f '' s) := by
  ext b
  simp only [supₛ_eq_unionₛ, mem_image, mem_unionₛ, exists_prop, unionₛ_image, mem_unionᵢ]
  constructor
  · rintro ⟨a, ⟨t, ht₁, ht₂⟩, rfl⟩
    exact ⟨t, ht₁, a, ht₂, rfl⟩
  · rintro ⟨t, ht₁, a, ht₂, rfl⟩
    exact ⟨a, ⟨t, ht₁, ht₂⟩, rfl⟩
#align set.image_Sup Set.image_supₛ

/-- Using `Set.image`, a function between types yields a `SupₛHom` between their lattices of
subsets.

See also `CompleteLatticeHom.setPreimage`. -/
@[simps]
def SupₛHom.setImage (f : α → β) : SupₛHom (Set α) (Set β)
    where
  toFun := image f
  map_supₛ' := Set.image_supₛ
#align Sup_hom.set_image SupₛHom.setImage

/-- An equivalence of types yields an order isomorphism between their lattices of subsets. -/
@[simps]
def Equiv.toOrderIsoSet (e : α ≃ β) : Set α ≃o Set β
    where
  toFun s := e '' s
  invFun s := e.symm '' s
  left_inv s := by simp only [← image_comp, Equiv.symm_comp_self, id.def, image_id']
  right_inv s := by simp only [← image_comp, Equiv.self_comp_symm, id.def, image_id']
  map_rel_iff' :=
    ⟨fun h => by simpa using @monotone_image _ _ e.symm _ _ h, fun h => monotone_image h⟩
#align equiv.to_order_iso_set Equiv.toOrderIsoSet

variable [CompleteLattice α] (x : α × α)

/-- The map `(a, b) ↦ a ⊔ b` as a `SupₛHom`. -/
def supSupₛHom : SupₛHom (α × α) α where
  toFun x := x.1 ⊔ x.2
  map_supₛ' s := by simp_rw [Prod.fst_supₛ, Prod.snd_supₛ, supₛ_image, supᵢ_sup_eq]
#align sup_Sup_hom supSupₛHom

/-- The map `(a, b) ↦ a ⊓ b` as an `InfₛHom`. -/
def infInfₛHom : InfₛHom (α × α) α where
  toFun x := x.1 ⊓ x.2
  map_infₛ' s := by simp_rw [Prod.fst_infₛ, Prod.snd_infₛ, infₛ_image, infᵢ_inf_eq]
#align inf_Inf_hom infInfₛHom

@[simp, norm_cast]
theorem supSupₛHom_apply : supSupₛHom x = x.1 ⊔ x.2 :=
  rfl
#align sup_Sup_hom_apply supSupₛHom_apply

@[simp, norm_cast]
theorem infInfₛHom_apply : infInfₛHom x = x.1 ⊓ x.2 :=
  rfl
#align inf_Inf_hom_apply infInfₛHom_apply