/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.extend_deriv
import Mathlib.analysis.calculus.iterated_deriv
import Mathlib.analysis.special_functions.exp_log
import Mathlib.topology.algebra.polynomial
import Mathlib.PostPort

namespace Mathlib

/-!
# Smoothness of specific functions

The real function `exp_neg_inv_glue` given by `x ↦ exp (-1/x)` for `x > 0` and `0`
for `x ≤ 0` is a basic building block to construct smooth partitions of unity. We prove that it
is `C^∞` in `exp_neg_inv_glue.smooth`.
-/

/-- `exp_neg_inv_glue` is the real function given by `x ↦ exp (-1/x)` for `x > 0` and `0`
for `x ≤ 0`. is a basic building block to construct smooth partitions of unity. Its main property
is that it vanishes for `x ≤ 0`, it is positive for `x > 0`, and the junction between the two
behaviors is flat enough to retain smoothness. The fact that this function is `C^∞` is proved in
`exp_neg_inv_glue.smooth`. -/
def exp_neg_inv_glue (x : ℝ) : ℝ :=
  ite (x ≤ 0) 0 (real.exp (-(x⁻¹)))

namespace exp_neg_inv_glue

/-- Our goal is to prove that `exp_neg_inv_glue` is `C^∞`. For this, we compute its successive
derivatives for `x > 0`. The `n`-th derivative is of the form `P_aux n (x) exp(-1/x) / x^(2 n)`,
where `P_aux n` is computed inductively. -/
def P_aux : ℕ → polynomial ℝ :=
  sorry

/-- Formula for the `n`-th derivative of `exp_neg_inv_glue`, as an auxiliary function `f_aux`. -/
def f_aux (n : ℕ) (x : ℝ) : ℝ :=
  ite (x ≤ 0) 0 (polynomial.eval x (P_aux n) * real.exp (-(x⁻¹)) / x ^ (bit0 1 * n))

/-- The `0`-th auxiliary function `f_aux 0` coincides with `exp_neg_inv_glue`, by definition. -/
theorem f_aux_zero_eq : f_aux 0 = exp_neg_inv_glue := sorry

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
(given in this statement in unfolded form) is the `n+1`-th auxiliary function, since
the polynomial `P_aux (n+1)` was chosen precisely to ensure this. -/
theorem f_aux_deriv (n : ℕ) (x : ℝ) (hx : x ≠ 0) : has_deriv_at (fun (x : ℝ) => polynomial.eval x (P_aux n) * real.exp (-(x⁻¹)) / x ^ (bit0 1 * n))
  (polynomial.eval x (P_aux (n + 1)) * real.exp (-(x⁻¹)) / x ^ (bit0 1 * (n + 1))) x := sorry

/-- For positive values, the derivative of the `n`-th auxiliary function `f_aux n`
is the `n+1`-th auxiliary function. -/
theorem f_aux_deriv_pos (n : ℕ) (x : ℝ) (hx : 0 < x) : has_deriv_at (f_aux n) (polynomial.eval x (P_aux (n + 1)) * real.exp (-(x⁻¹)) / x ^ (bit0 1 * (n + 1))) x := sorry

/-- To get differentiability at `0` of the auxiliary functions, we need to know that their limit
is `0`, to be able to apply general differentiability extension theorems. This limit is checked in
this lemma. -/
theorem f_aux_limit (n : ℕ) : filter.tendsto (fun (x : ℝ) => polynomial.eval x (P_aux n) * real.exp (-(x⁻¹)) / x ^ (bit0 1 * n))
  (nhds_within 0 (set.Ioi 0)) (nhds 0) := sorry

/-- Deduce from the limiting behavior at `0` of its derivative and general differentiability
extension theorems that the auxiliary function `f_aux n` is differentiable at `0`,
with derivative `0`. -/
theorem f_aux_deriv_zero (n : ℕ) : has_deriv_at (f_aux n) 0 0 := sorry

/-- At every point, the auxiliary function `f_aux n` has a derivative which is
equal to `f_aux (n+1)`. -/
theorem f_aux_has_deriv_at (n : ℕ) (x : ℝ) : has_deriv_at (f_aux n) (f_aux (n + 1) x) x := sorry

/-- The successive derivatives of the auxiliary function `f_aux 0` are the
functions `f_aux n`, by induction. -/
theorem f_aux_iterated_deriv (n : ℕ) : iterated_deriv n (f_aux 0) = f_aux n := sorry

/-- The function `exp_neg_inv_glue` is smooth. -/
theorem smooth : times_cont_diff ℝ ⊤ exp_neg_inv_glue := sorry

/-- The function `exp_neg_inv_glue` vanishes on `(-∞, 0]`. -/
theorem zero_of_nonpos {x : ℝ} (hx : x ≤ 0) : exp_neg_inv_glue x = 0 := sorry

/-- The function `exp_neg_inv_glue` is positive on `(0, +∞)`. -/
theorem pos_of_pos {x : ℝ} (hx : 0 < x) : 0 < exp_neg_inv_glue x := sorry

/-- The function exp_neg_inv_glue` is nonnegative. -/
theorem nonneg (x : ℝ) : 0 ≤ exp_neg_inv_glue x :=
  or.dcases_on (le_or_gt x 0) (fun (h : x ≤ 0) => ge_of_eq (zero_of_nonpos h)) fun (h : x > 0) => le_of_lt (pos_of_pos h)


/-
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
-/
import order.hom.basic
import logic.relation

/-!
# Turning a preorder into a partial order

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

This file allows to make a preorder into a partial order by quotienting out the elements `a`, `b`
such that `a ≤ b` and `b ≤ a`.

`antisymmetrization` is a functor from `Preorder` to `PartialOrder`. See `Preorder_to_PartialOrder`.

## Main declarations

* `antisymm_rel`: The antisymmetrization relation. `antisymm_rel r a b` means that `a` and `b` are
  related both ways by `r`.
* `antisymmetrization α r`: The quotient of `α` by `antisymm_rel r`. Even when `r` is just a
  preorder, `antisymmetrization α` is a partial order.
-/

open function order_dual

variables {α β : Type*}

section relation
variables (r : α → α → Prop)

/-- The antisymmetrization relation. -/
def antisymm_rel (a b : α) : Prop := r a b ∧ r b a

lemma antisymm_rel_swap : antisymm_rel (swap r) = antisymm_rel r :=
funext $ λ _, funext $ λ _, propext and.comm

@[refl] lemma antisymm_rel_refl [is_refl α r] (a : α) : antisymm_rel r a a := ⟨refl _, refl _⟩

variables {r}

@[symm] lemma antisymm_rel.symm {a b : α} : antisymm_rel r a b → antisymm_rel r b a := and.symm

@[trans] lemma antisymm_rel.trans [is_trans α r] {a b c : α} (hab : antisymm_rel r a b)
  (hbc : antisymm_rel r b c) :
  antisymm_rel r a c :=
⟨trans hab.1 hbc.1, trans hbc.2 hab.2⟩

instance antisymm_rel.decidable_rel [decidable_rel r] : decidable_rel (antisymm_rel r) :=
λ _ _, and.decidable

@[simp] lemma antisymm_rel_iff_eq [is_refl α r] [is_antisymm α r] {a b : α} :
  antisymm_rel r a b ↔ a = b := antisymm_iff

alias antisymm_rel_iff_eq ↔ antisymm_rel.eq _

end relation

section is_preorder
variables (α) (r : α → α → Prop) [is_preorder α r]

/-- The antisymmetrization relation as an equivalence relation. -/
@[simps] def antisymm_rel.setoid : setoid α :=
⟨antisymm_rel r, antisymm_rel_refl _, λ _ _, antisymm_rel.symm, λ _ _ _, antisymm_rel.trans⟩

/-- The partial order derived from a preorder by making pairwise comparable elements equal. This is
the quotient by `λ a b, a ≤ b ∧ b ≤ a`. -/
def antisymmetrization : Type* := quotient $ antisymm_rel.setoid α r

variables {α}

/-- Turn an element into its antisymmetrization. -/
def to_antisymmetrization : α → antisymmetrization α r := quotient.mk'

/-- Get a representative from the antisymmetrization. -/
noncomputable def of_antisymmetrization : antisymmetrization α r → α := quotient.out'

instance [inhabited α] : inhabited (antisymmetrization α r) := quotient.inhabited _

@[elab_as_eliminator]
protected lemma antisymmetrization.ind {p : antisymmetrization α r → Prop} :
  (∀ a, p $ to_antisymmetrization r a) → ∀ q, p q :=
quot.ind

@[elab_as_eliminator]
protected lemma antisymmetrization.induction_on {p : antisymmetrization α r → Prop}
  (a : antisymmetrization α r) (h : ∀ a, p $ to_antisymmetrization r a) : p a :=
quotient.induction_on' a h

@[simp] lemma to_antisymmetrization_of_antisymmetrization (a : antisymmetrization α r) :
  to_antisymmetrization r (of_antisymmetrization r a) = a := quotient.out_eq' _

end is_preorder

section preorder
variables {α} [preorder α] [preorder β] {a b : α}

lemma antisymm_rel.image {a b : α} (h : antisymm_rel (≤) a b) {f : α → β} (hf : monotone f) :
  antisymm_rel (≤) (f a) (f b) :=
⟨hf h.1, hf h.2⟩

instance : partial_order (antisymmetrization α (≤)) :=
{ le := λ a b, quotient.lift_on₂' a b (≤) $ λ (a₁ a₂ b₁ b₂ : α) h₁ h₂,
    propext ⟨λ h, h₁.2.trans $ h.trans h₂.1, λ h, h₁.1.trans $ h.trans h₂.2⟩,
  lt := λ a b, quotient.lift_on₂' a b (<) $ λ (a₁ a₂ b₁ b₂ : α) h₁ h₂,
    propext ⟨λ h, h₁.2.trans_lt $ h.trans_le h₂.1, λ h, h₁.1.trans_lt $ h.trans_le h₂.2⟩,
  le_refl := λ a, quotient.induction_on' a $ le_refl,
  le_trans := λ a b c, quotient.induction_on₃' a b c $ λ a b c, le_trans,
  lt_iff_le_not_le := λ a b, quotient.induction_on₂' a b $ λ a b, lt_iff_le_not_le,
  le_antisymm := λ a b, quotient.induction_on₂' a b $ λ a b hab hba, quotient.sound' ⟨hab, hba⟩ }

lemma antisymmetrization_fibration :
  relation.fibration (<) (<) (@to_antisymmetrization α (≤) _) :=
by { rintro a ⟨b⟩ h, exact ⟨b, h, rfl⟩ }

lemma acc_antisymmetrization_iff : acc (<) (to_antisymmetrization (≤) a) ↔ acc (<) a :=
acc_lift_on₂'_iff

lemma well_founded_antisymmetrization_iff :
  well_founded (@has_lt.lt (antisymmetrization α (≤)) _) ↔ well_founded (@has_lt.lt α _) :=
well_founded_lift_on₂'_iff

instance [well_founded_lt α] : well_founded_lt (antisymmetrization α (≤)) :=
⟨well_founded_antisymmetrization_iff.2 is_well_founded.wf⟩

instance [@decidable_rel α (≤)] [@decidable_rel α (<)] [is_total α (≤)] :
  linear_order (antisymmetrization α (≤)) :=
{ le_total := λ a b, quotient.induction_on₂' a b $ total_of (≤),
  decidable_eq := @quotient.decidable_eq _ (antisymm_rel.setoid _ (≤)) antisymm_rel.decidable_rel,
  decidable_le := λ _ _, quotient.lift_on₂'.decidable _ _ _ _,
  decidable_lt := λ _ _, quotient.lift_on₂'.decidable _ _ _ _,
  ..antisymmetrization.partial_order }

@[simp] lemma to_antisymmetrization_le_to_antisymmetrization_iff :
  to_antisymmetrization (≤) a ≤ to_antisymmetrization (≤) b ↔ a ≤ b := iff.rfl

@[simp] lemma to_antisymmetrization_lt_to_antisymmetrization_iff :
  to_antisymmetrization (≤) a < to_antisymmetrization (≤) b ↔ a < b := iff.rfl

@[simp] lemma of_antisymmetrization_le_of_antisymmetrization_iff {a b : antisymmetrization α (≤)} :
  of_antisymmetrization (≤) a ≤ of_antisymmetrization (≤) b ↔ a ≤ b :=
rel_embedding.map_rel_iff (quotient.out'_rel_embedding _)

@[simp] lemma of_antisymmetrization_lt_of_antisymmetrization_iff {a b : antisymmetrization α (≤)} :
  of_antisymmetrization (≤) a < of_antisymmetrization (≤) b ↔ a < b :=
(quotient.out'_rel_embedding _).map_rel_iff

@[mono] lemma to_antisymmetrization_mono : monotone (@to_antisymmetrization α (≤) _) := λ a b, id

/-- `to_antisymmetrization` as an order homomorphism. -/
@[simps] def order_hom.to_antisymmetrization : α →o antisymmetrization α (≤) :=
⟨to_antisymmetrization (≤), λ a b, id⟩

private lemma lift_fun_antisymm_rel (f : α →o β) :
  ((antisymm_rel.setoid α (≤)).r ⇒ (antisymm_rel.setoid β (≤)).r) f f :=
λ a b h, ⟨f.mono h.1, f.mono h.2⟩

/-- Turns an order homomorphism from `α` to `β` into one from `antisymmetrization α` to
`antisymmetrization β`. `antisymmetrization` is actually a functor. See `Preorder_to_PartialOrder`.
-/
protected def order_hom.antisymmetrization (f : α →o β) :
  antisymmetrization α (≤) →o antisymmetrization β (≤) :=
⟨quotient.map' f $ lift_fun_antisymm_rel f, λ a b, quotient.induction_on₂' a b $ f.mono⟩

@[simp] lemma order_hom.coe_antisymmetrization (f : α →o β) :
  ⇑f.antisymmetrization = quotient.map' f (lift_fun_antisymm_rel f) := rfl

@[simp] lemma order_hom.antisymmetrization_apply (f : α →o β) (a : antisymmetrization α (≤)) :
  f.antisymmetrization a = quotient.map' f (lift_fun_antisymm_rel f) a := rfl

@[simp] lemma order_hom.antisymmetrization_apply_mk (f : α →o β) (a : α) :
  f.antisymmetrization (to_antisymmetrization _ a) = (to_antisymmetrization _ (f a)) :=
quotient.map'_mk' f (lift_fun_antisymm_rel f) _

variables (α)

/-- `of_antisymmetrization` as an order embedding. -/
@[simps] noncomputable def order_embedding.of_antisymmetrization : antisymmetrization α (≤) ↪o α :=
{ to_fun := of_antisymmetrization _,
  ..quotient.out'_rel_embedding _ }

/-- `antisymmetrization` and `order_dual` commute. -/
def order_iso.dual_antisymmetrization :
  (antisymmetrization α (≤))ᵒᵈ ≃o antisymmetrization αᵒᵈ (≤) :=
{ to_fun := quotient.map' id $ λ _ _, and.symm,
  inv_fun := quotient.map' id $ λ _ _, and.symm,
  left_inv := λ a, quotient.induction_on' a $ λ a, by simp_rw [quotient.map'_mk', id],
  right_inv := λ a, quotient.induction_on' a $ λ a, by simp_rw [quotient.map'_mk', id],
  map_rel_iff' := λ a b, quotient.induction_on₂' a b $ λ a b, iff.rfl }

@[simp] lemma order_iso.dual_antisymmetrization_apply (a : α) :
  order_iso.dual_antisymmetrization _ (to_dual $ to_antisymmetrization _ a) =
    to_antisymmetrization _ (to_dual a) := rfl

@[simp] lemma order_iso.dual_antisymmetrization_symm_apply (a : α) :
  (order_iso.dual_antisymmetrization _).symm (to_antisymmetrization _ $ to_dual a) =
    to_dual (to_antisymmetrization _ a) := rfl

end preorder


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import ring_theory.localization.integral

/-!
# Gauss's Lemma

Gauss's Lemma is one of a few results pertaining to irreducibility of primitive polynomials.

## Main Results
 - `polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map`:
  A primitive polynomial is irreducible iff it is irreducible in a fraction field.
 - `polynomial.is_primitive.int.irreducible_iff_irreducible_map_cast`:
  A primitive polynomial over `ℤ` is irreducible iff it is irreducible over `ℚ`.
 - `polynomial.is_primitive.dvd_iff_fraction_map_dvd_fraction_map`:
  Two primitive polynomials divide each other iff they do in a fraction field.
 - `polynomial.is_primitive.int.dvd_iff_map_cast_dvd_map_cast`:
  Two primitive polynomials over `ℤ` divide each other if they do in `ℚ`.

-/

open_locale non_zero_divisors polynomial

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

namespace polynomial
section normalized_gcd_monoid
variable [normalized_gcd_monoid R]

section
variables {S : Type*} [comm_ring S] [is_domain S] {φ : R →+* S} (hinj : function.injective φ)
variables {f : R[X]} (hf : f.is_primitive)
include hinj hf

lemma is_primitive.is_unit_iff_is_unit_map_of_injective :
  is_unit f ↔ is_unit (map φ f) :=
begin
  refine ⟨(map_ring_hom φ).is_unit_map, λ h, _⟩,
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  have hdeg := degree_C u.ne_zero,
  rw [hu, degree_map_eq_of_injective hinj] at hdeg,
  rw [eq_C_of_degree_eq_zero hdeg, is_primitive_iff_content_eq_one,
      content_C, normalize_eq_one] at hf,
  rwa [eq_C_of_degree_eq_zero hdeg, is_unit_C],
end

lemma is_primitive.irreducible_of_irreducible_map_of_injective (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨λ h, h_irr.not_unit (is_unit.map (map_ring_hom φ) h), _⟩,
  intros a b h,
  rcases h_irr.is_unit_or_is_unit (by rw [h, polynomial.map_mul]) with hu | hu,
  { left,
    rwa (hf.is_primitive_of_dvd (dvd.intro _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj },
  right,
  rwa (hf.is_primitive_of_dvd (dvd.intro_left _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj
end

end

section fraction_map
variables {K : Type*} [field K] [algebra R K] [is_fraction_ring R K]

lemma is_primitive.is_unit_iff_is_unit_map {p : R[X]} (hp : p.is_primitive) :
  is_unit p ↔ is_unit (p.map (algebra_map R K)) :=
hp.is_unit_iff_is_unit_map_of_injective (is_fraction_ring.injective _ _)

open is_localization

lemma is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part
  {p : K[X]} (h0 : p ≠ 0) (h : is_unit (integer_normalization R⁰ p).prim_part) :
  is_unit p :=
begin
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ p,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hc,
  apply is_unit_of_mul_is_unit_right,
  rw [← hc, (integer_normalization R⁰ p).eq_C_content_mul_prim_part, ← hu,
    ← ring_hom.map_mul, is_unit_iff],
  refine ⟨algebra_map R K ((integer_normalization R⁰ p).content * ↑u),
    is_unit_iff_ne_zero.2 (λ con, _), by simp⟩,
  replace con := (injective_iff_map_eq_zero (algebra_map R K)).1
    (is_fraction_ring.injective _ _) _ con,
  rw [mul_eq_zero, content_eq_zero_iff, is_fraction_ring.integer_normalization_eq_zero_iff] at con,
  rcases con with con | con,
  { apply h0 con },
  { apply units.ne_zero _ con },
end

/-- **Gauss's Lemma** states that a primitive polynomial is irreducible iff it is irreducible in the
  fraction field. -/
theorem is_primitive.irreducible_iff_irreducible_map_fraction_map
  {p : R[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (algebra_map R K)) :=
begin
  refine ⟨λ hi, ⟨λ h, hi.not_unit (hp.is_unit_iff_is_unit_map.2 h), λ a b hab, _⟩,
    hp.irreducible_of_irreducible_map_of_injective (is_fraction_ring.injective _ _)⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ a,
  obtain ⟨⟨d, d0⟩, hd⟩ := integer_normalization_map_to_map R⁰ b,
  rw [algebra.smul_def, algebra_map_apply, subtype.coe_mk] at hc hd,
  rw mem_non_zero_divisors_iff_ne_zero at c0 d0,
  have hcd0 : c * d ≠ 0 := mul_ne_zero c0 d0,
  rw [ne.def, ← C_eq_zero] at hcd0,
  have h1 : C c * C d * p = integer_normalization R⁰ a * integer_normalization R⁰ b,
  { apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _,
    rw [polynomial.map_mul, polynomial.map_mul, polynomial.map_mul, hc, hd, map_C, map_C, hab],
    ring },
  obtain ⟨u, hu⟩ : associated (c * d) (content (integer_normalization R⁰ a) *
            content (integer_normalization R⁰ b)),
  { rw [← dvd_dvd_iff_associated, ← normalize_eq_normalize_iff, normalize.map_mul,
        normalize.map_mul, normalize_content, normalize_content,
        ← mul_one (normalize c * normalize d), ← hp.content_eq_one, ← content_C, ← content_C,
        ← content_mul, ← content_mul, ← content_mul, h1] },
  rw [← ring_hom.map_mul, eq_comm,
    (integer_normalization R⁰ a).eq_C_content_mul_prim_part,
    (integer_normalization R⁰ b).eq_C_content_mul_prim_part, mul_assoc,
    mul_comm _ (C _ * _), ← mul_assoc, ← mul_assoc, ← ring_hom.map_mul, ← hu, ring_hom.map_mul,
    mul_assoc, mul_assoc, ← mul_assoc (C ↑u)] at h1,
  have h0 : (a ≠ 0) ∧ (b ≠ 0),
  { classical,
    rw [ne.def, ne.def, ← decidable.not_or_iff_and_not, ← mul_eq_zero, ← hab],
    intro con,
    apply hp.ne_zero (map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _),
    simp [con] },
  rcases hi.is_unit_or_is_unit (mul_left_cancel₀ hcd0 h1).symm with h | h,
  { right,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.2
      (is_unit_of_mul_is_unit_right h) },
  { left,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.1 h },
end

lemma is_primitive.dvd_of_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive)
  (h_dvd : p.map (algebra_map R K) ∣ q.map (algebra_map R K)) : p ∣ q :=
begin
  rcases h_dvd with ⟨r, hr⟩,
  obtain ⟨⟨s, s0⟩, hs⟩ := integer_normalization_map_to_map R⁰ r,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hs,
  have h : p ∣ q * C s,
  { use (integer_normalization R⁰ r),
    apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _),
    rw [polynomial.map_mul, polynomial.map_mul, hs, hr, mul_assoc, mul_comm r],
    simp },
  rw [← hp.dvd_prim_part_iff_dvd, prim_part_mul, hq.prim_part_eq,
      associated.dvd_iff_dvd_right] at h,
  { exact h },
  { symmetry,
    rcases is_unit_prim_part_C s with ⟨u, hu⟩,
    use u,
    rw hu },
  iterate 2 { apply mul_ne_zero hq.ne_zero,
    rw [ne.def, C_eq_zero],
    contrapose! s0,
    simp [s0, mem_non_zero_divisors_iff_ne_zero] }
end

variables (K)

lemma is_primitive.dvd_iff_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (algebra_map R K) ∣ q.map (algebra_map R K)) :=
⟨λ ⟨a,b⟩, ⟨a.map (algebra_map R K), b.symm ▸ polynomial.map_mul (algebra_map R K)⟩,
  λ h, hp.dvd_of_fraction_map_dvd_fraction_map hq h⟩

end fraction_map

/-- **Gauss's Lemma** for `ℤ` states that a primitive integer polynomial is irreducible iff it is
  irreducible over `ℚ`. -/
theorem is_primitive.int.irreducible_iff_irreducible_map_cast
  {p : ℤ[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (int.cast_ring_hom ℚ)) :=
hp.irreducible_iff_irreducible_map_fraction_map

lemma is_primitive.int.dvd_iff_map_cast_dvd_map_cast (p q : ℤ[X])
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (int.cast_ring_hom ℚ) ∣ q.map (int.cast_ring_hom ℚ)) :=
hp.dvd_iff_fraction_map_dvd_fraction_map ℚ hq

end normalized_gcd_monoid
end polynomial


import algebra.group.hom group_theory.subgroup group_theory.quotient_group

structure add_subgroup (G : Type*) [add_group G] :=
(carrier : set G)
(is_add_subgroup : is_add_subgroup carrier)

namespace add_subgroup

variables (G : Type*) [add_group G]

instance foo (H : add_subgroup G) :
  _root_.is_add_subgroup H.carrier := H.is_add_subgroup

instance : has_coe (add_subgroup G) (set G) :=
⟨add_subgroup.carrier⟩

instance : has_mem G (add_subgroup G) :=
⟨λ g H, g ∈ (H : set G)⟩

theorem ext' {G : Type*} [add_group G] {H K : add_subgroup G} (h : (H : set G) = K) : H = K :=
by cases H; cases K; congr'

@[ext] theorem ext_iff {G : Type*} [add_group G] {H K : add_subgroup G} :
  (∀ g : G, g ∈ H ↔ g ∈ K) ↔ H = K :=
begin
  split,
  { intro h,
    apply ext',
    exact set.ext h
  },
  intro h, rw h, intro g, refl,
end

/- Lattice stuff -/

instance : partial_order (add_subgroup G) :=
partial_order.lift (coe : add_subgroup G → set G) (λ a b, ext') (by apply_instance)

open set

universe u

def bot {G : Type u} [add_group G] : add_subgroup G :=
{ carrier := {x| x=0},
  is_add_subgroup := { zero_mem := rfl,
  add_mem := λ a b ha hb, begin
    cases ha, cases hb,
    apply zero_add,
  end,
  neg_mem := λ a ha, begin
    cases ha,
    exact neg_zero,
  end } }

instance : lattice.has_bot (add_subgroup G) := ⟨bot⟩

def top {G : Type u} [add_group G] : add_subgroup G :=
{ carrier := {x | true},
  is_add_subgroup := {
    zero_mem := mem_univ _,
    add_mem := λ _ _ _ _, mem_univ _,
    neg_mem := λ _ _, mem_univ _ }
}

instance : lattice.has_top (add_subgroup G) := ⟨top⟩

instance : has_subset (add_subgroup G) := ⟨has_le.le⟩

variable {G}

variables (H : add_subgroup G)

def zero_mem : (0 : G) ∈ H :=
begin
  exact _root_.is_add_submonoid.zero_mem H.carrier,
end

def neg_mem {g : G} : g ∈ H → -g ∈ H :=
begin
  intro h,
  show -g ∈ H.carrier,
  exact _root_.is_add_subgroup.neg_mem h,
end

def neg_mem_iff {g : G} : -g ∈ H ↔ g ∈ H :=
⟨λ h, by rw ←neg_neg g; exact neg_mem H h, neg_mem H⟩

def add_mem {g h : G} : g ∈ H → h ∈ H → g + h ∈ H :=
begin
  intros H1 H2,
  show g + h ∈ H.carrier,
  exact _root_.is_add_submonoid.add_mem H1 H2,
end

instance : has_coe_to_sort (add_subgroup G) :=
{ S := _,
  coe := λ H, {g : G // g ∈ H.carrier }
}

-- could prove that these are Galois connections and that add_subgroup G
-- is a complete lattice.

instance (H : add_subgroup G) : add_group ↥H :=
{ add := λ h₁ h₂, ⟨h₁.1 + h₂.1, H.add_mem h₁.2 h₂.2⟩,
  add_assoc := λ a b c, subtype.ext.2 $ add_assoc _ _ _,
  zero := ⟨0, H.zero_mem⟩,
  zero_add := λ a, subtype.ext.2 $ zero_add _,
  add_zero := λ a, subtype.ext.2 $ add_zero _,
  neg := λ h, ⟨-h.1, H.neg_mem h.2⟩,
  add_left_neg := λ a, subtype.ext.2 $ add_left_neg _
}

variables {A : Type*} [add_comm_group A]

instance (B : add_subgroup A) : add_comm_group ↥B :=
{ add_comm := λ a b, subtype.ext.2 $ add_comm _ _,
  ..add_subgroup.add_group B}

end add_subgroup


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.polynomial.monic
import data.polynomial.algebra_map
import algebra.group_ring_action
import algebra.group_action_hom

/-!
# Group action on rings applied to polynomials

This file contains instances and definitions relating `mul_semiring_action` to `polynomial`.
-/

variables (M : Type*) [monoid M]

namespace polynomial

variables (R : Type*) [semiring R]

variables {M}

lemma smul_eq_map [mul_semiring_action M R] (m : M) :
  ((•) m) = map (mul_semiring_action.to_ring_hom M R m) :=
begin
  suffices :
    distrib_mul_action.to_add_monoid_hom (polynomial R) m =
      (map_ring_hom (mul_semiring_action.to_ring_hom M R m)).to_add_monoid_hom,
  { ext1 r, exact add_monoid_hom.congr_fun this r, },
  ext n r : 2,
  change m • monomial n r = map (mul_semiring_action.to_ring_hom M R m) (monomial n r),
  simpa only [polynomial.map_monomial, polynomial.smul_monomial],
end

variables (M)

noncomputable instance [mul_semiring_action M R] : mul_semiring_action M (polynomial R) :=
{ smul := (•),
  smul_one := λ m, (smul_eq_map R m).symm ▸ map_one (mul_semiring_action.to_ring_hom M R m),
  smul_mul := λ m p q, (smul_eq_map R m).symm ▸ map_mul (mul_semiring_action.to_ring_hom M R m),
  ..polynomial.distrib_mul_action }

variables {M R}

variables [mul_semiring_action M R]

@[simp] lemma smul_X (m : M) : (m • X : polynomial R) = X :=
(smul_eq_map R m).symm ▸ map_X _

variables (S : Type*) [comm_semiring S] [mul_semiring_action M S]

theorem smul_eval_smul (m : M) (f : polynomial S) (x : S) :
  (m • f).eval (m • x) = m • f.eval x :=
polynomial.induction_on f
  (λ r, by rw [smul_C, eval_C, eval_C])
  (λ f g ihf ihg, by rw [smul_add, eval_add, ihf, ihg, eval_add, smul_add])
  (λ n r ih, by rw [smul_mul', smul_pow', smul_C, smul_X, eval_mul, eval_C, eval_pow, eval_X,
      eval_mul, eval_C, eval_pow, eval_X, smul_mul', smul_pow'])

variables (G : Type*) [group G]

theorem eval_smul' [mul_semiring_action G S] (g : G) (f : polynomial S) (x : S) :
  f.eval (g • x) = g • (g⁻¹ • f).eval x :=
by rw [← smul_eval_smul, smul_inv_smul]

theorem smul_eval [mul_semiring_action G S] (g : G) (f : polynomial S) (x : S) :
  (g • f).eval x = g • f.eval (g⁻¹ • x) :=
by rw [← smul_eval_smul, smul_inv_smul]

end polynomial

section comm_ring

variables (G : Type*) [group G] [fintype G]
variables (R : Type*) [comm_ring R] [mul_semiring_action G R]
open mul_action
open_locale classical

/-- the product of `(X - g • x)` over distinct `g • x`. -/
noncomputable def prod_X_sub_smul (x : R) : polynomial R :=
(finset.univ : finset (G ⧸ mul_action.stabilizer G x)).prod $
λ g, polynomial.X - polynomial.C (of_quotient_stabilizer G x g)

theorem prod_X_sub_smul.monic (x : R) : (prod_X_sub_smul G R x).monic :=
polynomial.monic_prod_of_monic _ _ $ λ g _, polynomial.monic_X_sub_C _

theorem prod_X_sub_smul.eval (x : R) : (prod_X_sub_smul G R x).eval x = 0 :=
(monoid_hom.map_prod
  ((polynomial.aeval x).to_ring_hom.to_monoid_hom : polynomial R →* R) _ _).trans $
  finset.prod_eq_zero (finset.mem_univ $ quotient_group.mk 1) $
  by simp

theorem prod_X_sub_smul.smul (x : R) (g : G) :
  g • prod_X_sub_smul G R x = prod_X_sub_smul G R x :=
finset.smul_prod.trans $ fintype.prod_bijective _ (mul_action.bijective g) _ _
  (λ g', by rw [of_quotient_stabilizer_smul, smul_sub, polynomial.smul_X, polynomial.smul_C])

theorem prod_X_sub_smul.coeff (x : R) (g : G) (n : ℕ) :
  g • (prod_X_sub_smul G R x).coeff n =
  (prod_X_sub_smul G R x).coeff n :=
by rw [← polynomial.coeff_smul, prod_X_sub_smul.smul]

end comm_ring

namespace mul_semiring_action_hom
variables {M}
variables {P : Type*} [comm_semiring P] [mul_semiring_action M P]
variables {Q : Type*} [comm_semiring Q] [mul_semiring_action M Q]
open polynomial

/-- An equivariant map induces an equivariant map on polynomials. -/
protected noncomputable def polynomial (g : P →+*[M] Q) : polynomial P →+*[M] polynomial Q :=
{ to_fun := map g,
  map_smul' := λ m p, polynomial.induction_on p
    (λ b, by rw [smul_C, map_C, coe_fn_coe, g.map_smul, map_C, coe_fn_coe, smul_C])
    (λ p q ihp ihq, by rw [smul_add, polynomial.map_add, ihp, ihq, polynomial.map_add, smul_add])
    (λ n b ih, by rw [smul_mul', smul_C, smul_pow', smul_X, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, coe_fn_coe, g.map_smul, polynomial.map_mul, map_C,
        polynomial.map_pow, map_X, smul_mul', smul_C, smul_pow', smul_X, coe_fn_coe]),
  map_zero' := polynomial.map_zero g,
  map_add' := λ p q, polynomial.map_add g,
  map_one' := polynomial.map_one g,
  map_mul' := λ p q, polynomial.map_mul g }

@[simp] theorem coe_polynomial (g : P →+*[M] Q) :
  (g.polynomial : polynomial P → polynomial Q) = map g :=
rfl

end mul_semiring_action_hom


/-
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, Mario Carneiro

! This file was ported from Lean 3 source module measure_theory.measurable_space_def
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Countable
import Mathlib.Logic.Encodable.Lattice
import Mathlib.Order.Disjointed

/-!
# Measurable spaces and measurable functions

This file defines measurable spaces and measurable functions.

A measurable space is a set equipped with a σ-algebra, a collection of
subsets closed under complementation and countable union. A function
between measurable spaces is measurable if the preimage of each
measurable subset is measurable.

σ-algebras on a fixed set `α` form a complete lattice. Here we order
σ-algebras by writing `m₁ ≤ m₂` if every set which is `m₁`-measurable is
also `m₂`-measurable (that is, `m₁` is a subset of `m₂`). In particular, any
collection of subsets of `α` generates a smallest σ-algebra which
contains all of them.

Do not add measurability lemmas (which could be tagged with
@[measurability]) to this file, since the measurability tactic is downstream
from here. Use `Mathlib.MeasureTheory.MeasurableSpace` instead.

## References

* <https://en.wikipedia.org/wiki/Measurable_space>
* <https://en.wikipedia.org/wiki/Sigma-algebra>
* <https://en.wikipedia.org/wiki/Dynkin_system>

## Tags

measurable space, σ-algebra, measurable function
-/

open Set Encodable Function Equiv

open Classical

variable {α β γ δ δ' : Type _} {ι : Sort _} {s t u : Set α}

/-- A measurable space is a space equipped with a σ-algebra. -/
@[class] structure MeasurableSpace (α : Type _) where
  /-- Predicate saying that a given set is measurable. Use `MeasurableSet` in the root namespace
  instead. -/
  MeasurableSet' : Set α → Prop
  /-- The empty set is a measurable set. Use `MeasurableSet.empty` instead. -/
  measurableSet_empty : MeasurableSet' ∅
  /-- The complement of a measurable set is a measurable set. Use `MeasurableSet.compl` instead. -/
  measurableSet_compl : ∀ s, MeasurableSet' s → MeasurableSet' (sᶜ)
  /-- The union of a sequence of measurable sets is a measurable set. Use a more general
  `MeasurableSet.unionᵢ` instead. -/
  measurableSet_unionᵢ : ∀ f : ℕ → Set α, (∀ i, MeasurableSet' (f i)) → MeasurableSet' (⋃ i, f i)
#align measurable_space MeasurableSpace

instance [h : MeasurableSpace α] : MeasurableSpace αᵒᵈ := h

/-- `MeasurableSet s` means that `s` is measurable (in the ambient measure space on `α`) -/
def MeasurableSet [MeasurableSpace α] (s : Set α) : Prop :=
  ‹MeasurableSpace α›.MeasurableSet' s
#align measurable_set MeasurableSet

-- porting note: todo: `scoped[MeasureTheory]` doesn't work for unknown reason
namespace MeasureTheory
set_option quotPrecheck false in
/-- Notation for `MeasurableSet` with respect to a non-standanrd σ-algebra. -/
scoped notation "MeasurableSet[" m "]" => @MeasurableSet _ m

end MeasureTheory
open MeasureTheory

section

@[simp]
theorem MeasurableSet.empty [MeasurableSpace α] : MeasurableSet (∅ : Set α) :=
  MeasurableSpace.measurableSet_empty _
#align measurable_set.empty MeasurableSet.empty

variable {m : MeasurableSpace α}

protected theorem MeasurableSet.compl : MeasurableSet s → MeasurableSet (sᶜ) :=
  MeasurableSpace.measurableSet_compl _ s
#align measurable_set.compl MeasurableSet.compl

protected theorem MeasurableSet.of_compl (h : MeasurableSet (sᶜ)) : MeasurableSet s :=
  compl_compl s ▸ h.compl
#align measurable_set.of_compl MeasurableSet.of_compl

@[simp]
theorem MeasurableSet.compl_iff : MeasurableSet (sᶜ) ↔ MeasurableSet s :=
  ⟨.of_compl, .compl⟩
#align measurable_set.compl_iff MeasurableSet.compl_iff

@[simp]
protected theorem MeasurableSet.univ : MeasurableSet (univ : Set α) :=
  .of_compl <| by simp
#align measurable_set.univ MeasurableSet.univ

@[nontriviality]
theorem Subsingleton.measurableSet [Subsingleton α] {s : Set α} : MeasurableSet s :=
  Subsingleton.set_cases MeasurableSet.empty MeasurableSet.univ s
#align subsingleton.measurable_set Subsingleton.measurableSet

theorem MeasurableSet.congr {s t : Set α} (hs : MeasurableSet s) (h : s = t) : MeasurableSet t := by
  rwa [← h]
#align measurable_set.congr MeasurableSet.congr

protected theorem MeasurableSet.unionᵢ [Countable ι] ⦃f : ι → Set α⦄
    (h : ∀ b, MeasurableSet (f b)) : MeasurableSet (⋃ b, f b) := by
  cases isEmpty_or_nonempty ι
  · simp
  · rcases exists_surjective_nat ι with ⟨e, he⟩
    rw [← unionᵢ_congr_of_surjective _ he (fun _ => rfl)]
    exact m.measurableSet_unionᵢ _ fun _ => h _
#align measurable_set.Union MeasurableSet.unionᵢ

@[deprecated MeasurableSet.unionᵢ]
theorem MeasurableSet.bunionᵢ_decode₂ [Encodable β] ⦃f : β → Set α⦄ (h : ∀ b, MeasurableSet (f b))
    (n : ℕ) : MeasurableSet (⋃ b ∈ decode₂ β n, f b) :=
  .unionᵢ fun _ => .unionᵢ fun _ => h _
#align measurable_set.bUnion_decode₂ MeasurableSet.bunionᵢ_decode₂

protected theorem MeasurableSet.bunionᵢ {f : β → Set α} {s : Set β} (hs : s.Countable)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋃ b ∈ s, f b) := by
  rw [bunionᵢ_eq_unionᵢ]
  have := hs.to_subtype
  exact MeasurableSet.unionᵢ (by simpa using h)
#align measurable_set.bUnion MeasurableSet.bunionᵢ

theorem Set.Finite.measurableSet_bunionᵢ {f : β → Set α} {s : Set β} (hs : s.Finite)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋃ b ∈ s, f b) :=
  .bunionᵢ hs.countable h
#align set.finite.measurable_set_bUnion Set.Finite.measurableSet_bunionᵢ

theorem Finset.measurableSet_bunionᵢ {f : β → Set α} (s : Finset β)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋃ b ∈ s, f b) :=
  s.finite_toSet.measurableSet_bunionᵢ h
#align finset.measurable_set_bUnion Finset.measurableSet_bunionᵢ

protected theorem MeasurableSet.unionₛ {s : Set (Set α)} (hs : s.Countable)
    (h : ∀ t ∈ s, MeasurableSet t) : MeasurableSet (⋃₀ s) := by
  rw [unionₛ_eq_bunionᵢ]
  exact .bunionᵢ hs h
#align measurable_set.sUnion MeasurableSet.unionₛ

theorem Set.Finite.measurableSet_unionₛ {s : Set (Set α)} (hs : s.Finite)
    (h : ∀ t ∈ s, MeasurableSet t) : MeasurableSet (⋃₀ s) :=
  MeasurableSet.unionₛ hs.countable h
#align set.finite.measurable_set_sUnion Set.Finite.measurableSet_unionₛ

theorem MeasurableSet.interᵢ [Countable ι] {f : ι → Set α} (h : ∀ b, MeasurableSet (f b)) :
    MeasurableSet (⋂ b, f b) :=
  .of_compl <| by rw [compl_interᵢ]; exact .unionᵢ fun b => (h b).compl
#align measurable_set.Inter MeasurableSet.interᵢ

theorem MeasurableSet.binterᵢ {f : β → Set α} {s : Set β} (hs : s.Countable)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋂ b ∈ s, f b) :=
  .of_compl <| by rw [compl_interᵢ₂]; exact .bunionᵢ hs fun b hb => (h b hb).compl
#align measurable_set.bInter MeasurableSet.binterᵢ

theorem Set.Finite.measurableSet_binterᵢ {f : β → Set α} {s : Set β} (hs : s.Finite)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋂ b ∈ s, f b) :=
 .binterᵢ hs.countable h
#align set.finite.measurable_set_bInter Set.Finite.measurableSet_binterᵢ

theorem Finset.measurableSet_binterᵢ {f : β → Set α} (s : Finset β)
    (h : ∀ b ∈ s, MeasurableSet (f b)) : MeasurableSet (⋂ b ∈ s, f b) :=
  s.finite_toSet.measurableSet_binterᵢ h
#align finset.measurable_set_bInter Finset.measurableSet_binterᵢ

theorem MeasurableSet.interₛ {s : Set (Set α)} (hs : s.Countable) (h : ∀ t ∈ s, MeasurableSet t) :
    MeasurableSet (⋂₀ s) := by
  rw [interₛ_eq_binterᵢ]
  exact MeasurableSet.binterᵢ hs h
#align measurable_set.sInter MeasurableSet.interₛ

theorem Set.Finite.measurableSet_interₛ {s : Set (Set α)} (hs : s.Finite)
    (h : ∀ t ∈ s, MeasurableSet t) : MeasurableSet (⋂₀ s) :=
  MeasurableSet.interₛ hs.countable h
#align set.finite.measurable_set_sInter Set.Finite.measurableSet_interₛ

@[simp]
protected theorem MeasurableSet.union {s₁ s₂ : Set α} (h₁ : MeasurableSet s₁)
    (h₂ : MeasurableSet s₂) : MeasurableSet (s₁ ∪ s₂) := by
  rw [union_eq_unionᵢ]
  exact .unionᵢ (Bool.forall_bool.2 ⟨h₂, h₁⟩)
#align measurable_set.union MeasurableSet.union

@[simp]
protected theorem MeasurableSet.inter {s₁ s₂ : Set α} (h₁ : MeasurableSet s₁)
    (h₂ : MeasurableSet s₂) : MeasurableSet (s₁ ∩ s₂) := by
  rw [inter_eq_compl_compl_union_compl]
  exact (h₁.compl.union h₂.compl).compl
#align measurable_set.inter MeasurableSet.inter

@[simp]
protected theorem MeasurableSet.diff {s₁ s₂ : Set α} (h₁ : MeasurableSet s₁)
    (h₂ : MeasurableSet s₂) : MeasurableSet (s₁ \ s₂) :=
  h₁.inter h₂.compl
#align measurable_set.diff MeasurableSet.diff

@[simp]
protected theorem MeasurableSet.symmDiff {s₁ s₂ : Set α} (h₁ : MeasurableSet s₁)
    (h₂ : MeasurableSet s₂) : MeasurableSet (s₁ ∆ s₂) :=
  (h₁.diff h₂).union (h₂.diff h₁)
#align measurable_set.symm_diff MeasurableSet.symmDiff

@[simp]
protected theorem MeasurableSet.ite {t s₁ s₂ : Set α} (ht : MeasurableSet t)
    (h₁ : MeasurableSet s₁) (h₂ : MeasurableSet s₂) : MeasurableSet (t.ite s₁ s₂) :=
  (h₁.inter ht).union (h₂.diff ht)
#align measurable_set.ite MeasurableSet.ite

theorem MeasurableSet.ite' {s t : Set α} {p : Prop} (hs : p → MeasurableSet s)
    (ht : ¬p → MeasurableSet t) : MeasurableSet (ite p s t) := by
  split_ifs with h
  exacts[hs h, ht h]
#align measurable_set.ite' MeasurableSet.ite'

@[simp]
protected theorem MeasurableSet.cond {s₁ s₂ : Set α} (h₁ : MeasurableSet s₁)
    (h₂ : MeasurableSet s₂) {i : Bool} : MeasurableSet (cond i s₁ s₂) := by
  cases i
  exacts[h₂, h₁]
#align measurable_set.cond MeasurableSet.cond

@[simp]
protected theorem MeasurableSet.disjointed {f : ℕ → Set α} (h : ∀ i, MeasurableSet (f i)) (n) :
    MeasurableSet (disjointed f n) :=
  disjointedRec (fun _ _ ht => MeasurableSet.diff ht <| h _) (h n)
#align measurable_set.disjointed MeasurableSet.disjointed

@[simp]
protected theorem MeasurableSet.const (p : Prop) : MeasurableSet { _a : α | p } := by
  by_cases p <;> simp [*]
#align measurable_set.const MeasurableSet.const

/-- Every set has a measurable superset. Declare this as local instance as needed. -/
theorem nonempty_measurable_superset (s : Set α) : Nonempty { t // s ⊆ t ∧ MeasurableSet t } :=
  ⟨⟨univ, subset_univ s, MeasurableSet.univ⟩⟩
#align nonempty_measurable_superset nonempty_measurable_superset

end

theorem MeasurableSpace.measurableSet_injective : Injective (@MeasurableSet α)
  | ⟨_, _, _, _⟩, ⟨_, _, _, _⟩, _ => by congr

@[ext]
theorem MeasurableSpace.ext {m₁ m₂ : MeasurableSpace α}
    (h : ∀ s : Set α, MeasurableSet[m₁] s ↔ MeasurableSet[m₂] s) : m₁ = m₂ :=
  measurableSet_injective <| funext fun s => propext (h s)
#align measurable_space.ext MeasurableSpace.ext

theorem MeasurableSpace.ext_iff {m₁ m₂ : MeasurableSpace α} :
    m₁ = m₂ ↔ ∀ s : Set α, MeasurableSet[m₁] s ↔ MeasurableSet[m₂] s :=
  ⟨fun h _ => h ▸ Iff.rfl, MeasurableSpace.ext⟩
#align measurable_space.ext_iff MeasurableSpace.ext_iff

/-- A typeclass mixin for `MeasurableSpace`s such that each singleton is measurable. -/
class MeasurableSingletonClass (α : Type _) [MeasurableSpace α] : Prop where
  /-- A singleton is a measurable set. -/
  measurableSet_singleton : ∀ x, MeasurableSet ({x} : Set α)
#align measurable_singleton_class MeasurableSingletonClass

export MeasurableSingletonClass (measurableSet_singleton)

@[simp]
lemma MeasurableSet.singleton [MeasurableSpace α] [MeasurableSingletonClass α] (a : α) :
    MeasurableSet {a} :=
  measurableSet_singleton a

section MeasurableSingletonClass

variable [MeasurableSpace α] [MeasurableSingletonClass α]

theorem measurableSet_eq {a : α} : MeasurableSet { x | x = a } := .singleton a
#align measurable_set_eq measurableSet_eq

protected theorem MeasurableSet.insert {s : Set α} (hs : MeasurableSet s) (a : α) :
    MeasurableSet (insert a s) :=
  .union (.singleton a) hs
#align measurable_set.insert MeasurableSet.insert

@[simp]
theorem measurableSet_insert {a : α} {s : Set α} : MeasurableSet (insert a s) ↔ MeasurableSet s :=
  ⟨fun h =>
    if ha : a ∈ s then by rwa [← insert_eq_of_mem ha]
    else insert_diff_self_of_not_mem ha ▸ h.diff (.singleton _),
    fun h => h.insert a⟩
#align measurable_set_insert measurableSet_insert

theorem Set.Subsingleton.measurableSet {s : Set α} (hs : s.Subsingleton) : MeasurableSet s :=
  hs.induction_on .empty .singleton
#align set.subsingleton.measurable_set Set.Subsingleton.measurableSet

theorem Set.Finite.measurableSet {s : Set α} (hs : s.Finite) : MeasurableSet s :=
  Finite.induction_on hs MeasurableSet.empty fun _ _ hsm => hsm.insert _
#align set.finite.measurable_set Set.Finite.measurableSet

protected theorem Finset.measurableSet (s : Finset α) : MeasurableSet (↑s : Set α) :=
  s.finite_toSet.measurableSet
#align finset.measurable_set Finset.measurableSet

theorem Set.Countable.measurableSet {s : Set α} (hs : s.Countable) : MeasurableSet s := by
  rw [← bunionᵢ_of_singleton s]
  exact .bunionᵢ hs fun b _ => .singleton b
#align set.countable.measurable_set Set.Countable.measurableSet

end MeasurableSingletonClass

namespace MeasurableSpace

/-- Copy of a `MeasurableSpace` with a new `MeasurableSet` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (m : MeasurableSpace α) (p : Set α → Prop) (h : ∀ s, p s ↔ MeasurableSet[m] s) :
    MeasurableSpace α where
  MeasurableSet' := p
  measurableSet_empty := by simpa only [h] using m.measurableSet_empty
  measurableSet_compl := by simpa only [h] using m.measurableSet_compl
  measurableSet_unionᵢ := by simpa only [h] using m.measurableSet_unionᵢ

lemma measurableSet_copy {m : MeasurableSpace α} {p : Set α → Prop}
    (h : ∀ s, p s ↔ MeasurableSet[m] s) {s} : MeasurableSet[.copy m p h] s ↔ p s :=
  Iff.rfl

lemma copy_eq {m : MeasurableSpace α} {p : Set α → Prop} (h : ∀ s, p s ↔ MeasurableSet[m] s) :
    m.copy p h = m :=
  ext h

section CompleteLattice

instance : LE (MeasurableSpace α) where le m₁ m₂ := ∀ s, MeasurableSet[m₁] s → MeasurableSet[m₂] s

theorem le_def {α} {a b : MeasurableSpace α} : a ≤ b ↔ a.MeasurableSet' ≤ b.MeasurableSet' :=
  Iff.rfl
#align measurable_space.le_def MeasurableSpace.le_def

instance : PartialOrder (MeasurableSpace α) :=
  { PartialOrder.lift (@MeasurableSet α) measurableSet_injective with
    le := LE.le
    lt := fun m₁ m₂ => m₁ ≤ m₂ ∧ ¬m₂ ≤ m₁ }

/-- The smallest σ-algebra containing a collection `s` of basic sets -/
inductive GenerateMeasurable (s : Set (Set α)) : Set α → Prop
  | protected basic : ∀ u ∈ s, GenerateMeasurable s u
  | protected empty : GenerateMeasurable s ∅
  | protected compl : ∀ t, GenerateMeasurable s t → GenerateMeasurable s (tᶜ)
  | protected unionᵢ : ∀ f : ℕ → Set α, (∀ n, GenerateMeasurable s (f n)) →
      GenerateMeasurable s (⋃ i, f i)
#align measurable_space.generate_measurable MeasurableSpace.GenerateMeasurable

/-- Construct the smallest measure space containing a collection of basic sets -/
def generateFrom (s : Set (Set α)) : MeasurableSpace α where
  MeasurableSet' := GenerateMeasurable s
  measurableSet_empty := .empty
  measurableSet_compl := .compl
  measurableSet_unionᵢ := .unionᵢ
#align measurable_space.generate_from MeasurableSpace.generateFrom

@[elab_as_elim]
theorem generateFrom_induction (p : Set α → Prop) (C : Set (Set α)) (hC : ∀ t ∈ C, p t)
    (h_empty : p ∅) (h_compl : ∀ t, p t → p (tᶜ))
    (h_Union : ∀ f : ℕ → Set α, (∀ n, p (f n)) → p (⋃ i, f i)) {s : Set α}
    (hs : MeasurableSet[generateFrom C] s) : p s := by
  induction hs
  exacts [hC _ ‹_›, h_empty, h_compl _ ‹_›, h_Union ‹_› ‹_›]
#align measurable_space.generate_from_induction MeasurableSpace.generateFrom_induction

theorem generateFrom_le {s : Set (Set α)} {m : MeasurableSpace α}
    (h : ∀ t ∈ s, MeasurableSet[m] t) : generateFrom s ≤ m :=
  fun t (ht : GenerateMeasurable s t) =>
  ht.recOn h .empty (fun _ _ => .compl) fun _ _ hf => .unionᵢ hf
#align measurable_space.generate_from_le MeasurableSpace.generateFrom_le

theorem generateFrom_le_iff {s : Set (Set α)} (m : MeasurableSpace α) :
    generateFrom s ≤ m ↔ s ⊆ { t | MeasurableSet[m] t } :=
  Iff.intro (fun h _ hu => h _ <| measurableSet_generateFrom hu) fun h => generateFrom_le h
#align measurable_space.generate_from_le_iff MeasurableSpace.generateFrom_le_iff

@[simp]
theorem generateFrom_measurableSet [MeasurableSpace α] :
    generateFrom { s : Set α | MeasurableSet s } = ‹_› :=
  le_antisymm (generateFrom_le fun _ => id) fun _ => measurableSet_generateFrom
#align measurable_space.generate_from_measurable_set MeasurableSpace.generateFrom_measurableSet

/-- If `g` is a collection of subsets of `α` such that the `σ`-algebra generated from `g` contains
the same sets as `g`, then `g` was already a `σ`-algebra. -/
protected def mkOfClosure (g : Set (Set α)) (hg : { t | MeasurableSet[generateFrom g] t } = g) :
    MeasurableSpace α :=
  (generateFrom g).copy (· ∈ g) <| Set.ext_iff.1 hg.symm
#align measurable_space.mk_of_closure MeasurableSpace.mkOfClosure

theorem mkOfClosure_sets {s : Set (Set α)} {hs : { t | MeasurableSet[generateFrom s] t } = s} :
    MeasurableSpace.mkOfClosure s hs = generateFrom s :=
  copy_eq _
#align measurable_space.mk_of_closure_sets MeasurableSpace.mkOfClosure_sets

/-- We get a Galois insertion between `σ`-algebras on `α` and `Set (Set α)` by using `generate_from`
  on one side and the collection of measurable sets on the other side. -/
def giGenerateFrom : GaloisInsertion (@generateFrom α) fun m => { t | MeasurableSet[m] t } where
  gc _ := generateFrom_le_iff
  le_l_u _ _ := measurableSet_generateFrom
  choice g hg := MeasurableSpace.mkOfClosure g <| le_antisymm hg <| (generateFrom_le_iff _).1 le_rfl
  choice_eq _ _ := mkOfClosure_sets
#align measurable_space.gi_generate_from MeasurableSpace.giGenerateFrom

instance : CompleteLattice (MeasurableSpace α) :=
  giGenerateFrom.liftCompleteLattice

instance : Inhabited (MeasurableSpace α) := ⟨⊤⟩

@[mono]
theorem generateFrom_mono {s t : Set (Set α)} (h : s ⊆ t) : generateFrom s ≤ generateFrom t :=
  giGenerateFrom.gc.monotone_l h
#align measurable_space.generate_from_mono MeasurableSpace.generateFrom_mono

theorem generateFrom_sup_generateFrom {s t : Set (Set α)} :
    generateFrom s ⊔ generateFrom t = generateFrom (s ∪ t) :=
  (@giGenerateFrom α).gc.l_sup.symm
#align measurable_space.generate_from_sup_generate_from MeasurableSpace.generateFrom_sup_generateFrom

@[simp]
theorem generateFrom_singleton_empty : generateFrom {∅} = (⊥ : MeasurableSpace α) :=
  bot_unique $ generateFrom_le <| by simp [@MeasurableSet.empty α ⊥]
#align measurable_space.generate_from_singleton_empty MeasurableSpace.generateFrom_singleton_empty

@[simp]
theorem generateFrom_singleton_univ : generateFrom {Set.univ} = (⊥ : MeasurableSpace α) :=
  bot_unique $ generateFrom_le <| by simp
#align measurable_space.generate_from_singleton_univ MeasurableSpace.generateFrom_singleton_univ

@[simp]
theorem generateFrom_insert_univ (S : Set (Set α)) :
    generateFrom (insert Set.univ S) = generateFrom S := by
  rw [insert_eq, ← generateFrom_sup_generateFrom, generateFrom_singleton_univ, bot_sup_eq]
#align measurable_space.generate_from_insert_univ MeasurableSpace.generateFrom_insert_univ

@[simp]
theorem generateFrom_insert_empty (S : Set (Set α)) :
    generateFrom (insert ∅ S) = generateFrom S := by
  rw [insert_eq, ← generateFrom_sup_generateFrom, generateFrom_singleton_empty, bot_sup_eq]
#align measurable_space.generate_from_insert_empty MeasurableSpace.generateFrom_insert_empty

theorem measurableSet_bot_iff {s : Set α} : MeasurableSet[⊥] s ↔ s = ∅ ∨ s = univ :=
  let b : MeasurableSpace α :=
    { MeasurableSet' := fun s => s = ∅ ∨ s = univ
      measurableSet_empty := Or.inl rfl
      measurableSet_compl := by simp (config := { contextual := true }) [or_imp]
      measurableSet_unionᵢ := fun f hf => unionₛ_mem_empty_univ (forall_range_iff.2 hf) }
  have : b = ⊥ :=
    bot_unique fun s hs =>
      hs.elim (fun s => s.symm ▸ @measurableSet_empty _ ⊥) fun s =>
        s.symm ▸ @MeasurableSet.univ _ ⊥
  this ▸ Iff.rfl
#align measurable_space.measurable_set_bot_iff MeasurableSpace.measurableSet_bot_iff

@[simp] theorem measurableSet_top {s : Set α} : MeasurableSet[⊤] s := trivial
#align measurable_space.measurable_set_top MeasurableSpace.measurableSet_top

@[simp, nolint simpNF] -- porting note: todo: `simpNF` claims that this lemma doesn't simplify LHS
theorem measurableSet_inf {m₁ m₂ : MeasurableSpace α} {s : Set α} :
    MeasurableSet[m₁ ⊓ m₂] s ↔ MeasurableSet[m₁] s ∧ MeasurableSet[m₂] s :=
  Iff.rfl
#align measurable_space.measurable_set_inf MeasurableSpace.measurableSet_inf

@[simp]
theorem measurableSet_infₛ {ms : Set (MeasurableSpace α)} {s : Set α} :
    MeasurableSet[infₛ ms] s ↔ ∀ m ∈ ms, MeasurableSet[m] s :=
  show s ∈ ⋂₀ _ ↔ _ by simp
#align measurable_space.measurable_set_Inf MeasurableSpace.measurableSet_infₛ

theorem measurableSet_infᵢ {ι} {m : ι → MeasurableSpace α} {s : Set α} :
    MeasurableSet[infᵢ m] s ↔ ∀ i, MeasurableSet[m i] s := by
  rw [infᵢ, measurableSet_infₛ, forall_range_iff]
#align measurable_space.measurable_set_infi MeasurableSpace.measurableSet_infᵢ

theorem measurableSet_sup {m₁ m₂ : MeasurableSpace α} {s : Set α} :
    MeasurableSet[m₁ ⊔ m₂] s ↔ GenerateMeasurable (MeasurableSet[m₁] ∪ MeasurableSet[m₂]) s :=
  Iff.rfl
#align measurable_space.measurable_set_sup MeasurableSpace.measurableSet_sup

theorem measurableSet_supₛ {ms : Set (MeasurableSpace α)} {s : Set α} :
    MeasurableSet[supₛ ms] s ↔
      GenerateMeasurable { s : Set α | ∃ m ∈ ms, MeasurableSet[m] s } s := by
  change GenerateMeasurable (⋃₀ _) _ ↔ _
  simp [← setOf_exists]
#align measurable_space.measurable_set_Sup MeasurableSpace.measurableSet_supₛ

theorem measurableSet_supᵢ {ι} {m : ι → MeasurableSpace α} {s : Set α} :
    MeasurableSet[supᵢ m] s ↔ GenerateMeasurable { s : Set α | ∃ i, MeasurableSet[m i] s } s :=
  by simp only [supᵢ, measurableSet_supₛ, exists_range_iff]
#align measurable_space.measurable_set_supr MeasurableSpace.measurableSet_supᵢ

theorem measurableSpace_supᵢ_eq (m : ι → MeasurableSpace α) :
    (⨆ n, m n) = generateFrom { s | ∃ n, MeasurableSet[m n] s } := by
  ext s
  rw [measurableSet_supᵢ]
  rfl
#align measurable_space.measurable_space_supr_eq MeasurableSpace.measurableSpace_supᵢ_eq

theorem generateFrom_unionᵢ_measurableSet (m : ι → MeasurableSpace α) :
    generateFrom (⋃ n, { t | MeasurableSet[m n] t }) = ⨆ n, m n :=
  (@giGenerateFrom α).l_supᵢ_u m
#align measurable_space.generate_from_Union_measurable_set MeasurableSpace.generateFrom_unionᵢ_measurableSet

end CompleteLattice

end MeasurableSpace

/-- A function `f` between measurable spaces is measurable if the preimage of every
  measurable set is measurable. -/
def Measurable [MeasurableSpace α] [MeasurableSpace β] (f : α → β) : Prop :=
  ∀ ⦃t : Set β⦄, MeasurableSet t → MeasurableSet (f ⁻¹' t)
#align measurable Measurable

namespace MeasureTheory

set_option quotPrecheck false in
/-- Notation for `Measurable` with respect to a non-standanrd σ-algebra in the domain. -/
scoped notation "Measurable[" m "]" => @Measurable _ _ m _

end MeasureTheory

section MeasurableFunctions

theorem measurable_id {_ : MeasurableSpace α} : Measurable (@id α) := fun _ => id
#align measurable_id measurable_id

theorem measurable_id' {_ : MeasurableSpace α} : Measurable fun a : α => a := measurable_id
#align measurable_id' measurable_id'

protected theorem Measurable.comp {_ : MeasurableSpace α} {_ : MeasurableSpace β}
    {_ : MeasurableSpace γ} {g : β → γ} {f : α → β} (hg : Measurable g) (hf : Measurable f) :
    Measurable (g ∘ f) :=
  fun _ h => hf (hg h)
#align measurable.comp Measurable.comp

@[simp]
theorem measurable_const {_ : MeasurableSpace α} {_ : MeasurableSpace β} {a : α} :
    Measurable fun _ : β => a := fun s _ => .const (a ∈ s)
#align measurable_const measurable_const

theorem Measurable.le {α} {m m0 : MeasurableSpace α} {_ : MeasurableSpace β} (hm : m ≤ m0)
    {f : α → β} (hf : Measurable[m] f) : Measurable[m0] f := fun _ hs => hm _ (hf hs)
#align measurable.le Measurable.le

theorem MeasurableSpace.Top.measurable {α β : Type _} [MeasurableSpace β] (f : α → β) :
    Measurable[⊤] f := fun _ _ => MeasurableSpace.measurableSet_top
#align measurable_space.top.measurable MeasurableSpace.Top.measurable

end MeasurableFunctions


lemma iff_trans (P Q R : Prop) : (P ↔ Q) → (Q ↔ R) → (P ↔ R) :=
begin
    intro fpq,
    cases fpq with pq qp,
    intro fqr,
    cases fqr with qr rq,
    split,
    intro p,
    apply qr,
    apply pq,
    exact p,
    intro r,
    apply qp,
    apply rq,
    exact r,
end


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Linear integer arithmetic terms in pre-normalized form.
-/

import tactic.omega.term

namespace omega
namespace int

/-- The shadow syntax for arithmetic terms. All constants are reified to `cst`
(e.g., `-5` is reified to `cst -5`) and all other atomic terms are reified to
`exp` (e.g., `-5 * (gcd 14 -7)` is reified to `exp -5 \`(gcd 14 -7)`).
`exp` accepts a coefficient of type `int` as its first argument because
multiplication by constant is allowed by the omega test. -/
meta inductive exprterm : Type
| cst : int → exprterm
| exp : int → expr → exprterm
| add : exprterm → exprterm → exprterm

/-- Similar to `exprterm`, except that all exprs are now replaced with
de Brujin indices of type `nat`. This is akin to generalizing over
the terms represented by the said exprs. -/
@[derive has_reflect, derive inhabited]
inductive preterm : Type
| cst : int → preterm
| var : int → nat → preterm
| add : preterm → preterm → preterm

localized "notation (name := preterm.cst) `&` k := omega.int.preterm.cst k" in omega.int
localized "infix (name := preterm.var) ` ** `:300 := omega.int.preterm.var" in omega.int
localized "notation (name := preterm.add) t ` +* ` s := omega.int.preterm.add t s" in omega.int

namespace preterm

/-- Preterm evaluation -/
@[simp] def val (v : nat → int) : preterm → int
| (& i) := i
| (i ** n) :=
  if i = 1
  then v n
  else if i = -1
       then -(v n)
       else (v n) * i
| (t1 +* t2) := t1.val + t2.val

/-- Fresh de Brujin index not used by any variable in argument -/
def fresh_index : preterm → nat
| (& _) := 0
| (i ** n) := n + 1
| (t1 +* t2) := max t1.fresh_index t2.fresh_index

@[simp] def add_one (t : preterm) : preterm := t +* (&1)

def repr : preterm → string
| (& i) := i.repr
| (i ** n) := i.repr ++ "*x" ++ n.repr
| (t1 +* t2) := "(" ++ t1.repr ++ " + " ++ t2.repr ++ ")"

end preterm

open_locale list.func -- get notation for list.func.set

/-- Return a term (which is in canonical form by definition)
    that is equivalent to the input preterm -/
@[simp] def canonize : preterm → term
| (& i)      := ⟨i, []⟩
| (i ** n)   := ⟨0, [] {n ↦ i}⟩
| (t1 +* t2) := term.add (canonize t1) (canonize t2)

@[simp] lemma val_canonize {v : nat → int} :
  ∀ {t : preterm}, (canonize t).val v = t.val v
| (& i) :=
  by simp only [preterm.val, add_zero, term.val, canonize, coeffs.val_nil]
| (i ** n)   :=
  begin
    simp only [coeffs.val_set, canonize,
      preterm.val, zero_add, term.val],
    split_ifs with h1 h2,
    { simp only [one_mul, h1] },
    { simp only [neg_mul, one_mul, h2] },
    { rw mul_comm }
  end
| (t +* s) :=
  by simp only [canonize, val_canonize,
     term.val_add, preterm.val]

end int

end omega


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

! This file was ported from Lean 3 source module order.compactly_generated
! leanprover-community/mathlib commit 861a26926586cd46ff80264d121cdb6fa0e35cc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Atoms
import Mathlib.Order.OrderIsoNat
import Mathlib.Order.RelIso.Set
import Mathlib.Order.SupIndep
import Mathlib.Order.Zorn
import Mathlib.Data.Finset.Order
import Mathlib.Data.Set.Intervals.OrderIso
import Mathlib.Data.Finite.Set
import Mathlib.Tactic.TFAE

/-!
# Compactness properties for complete lattices

For complete lattices, there are numerous equivalent ways to express the fact that the relation `>`
is well-founded. In this file we define three especially-useful characterisations and provide
proofs that they are indeed equivalent to well-foundedness.

## Main definitions
 * `CompleteLattice.IsSupClosedCompact`
 * `CompleteLattice.IsSupFiniteCompact`
 * `CompleteLattice.IsCompactElement`
 * `IsCompactlyGenerated`

## Main results
The main result is that the following four conditions are equivalent for a complete lattice:
 * `well_founded (>)`
 * `CompleteLattice.IsSupClosedCompact`
 * `CompleteLattice.IsSupFiniteCompact`
 * `∀ k, CompleteLattice.IsCompactElement k`

This is demonstrated by means of the following four lemmas:
 * `CompleteLattice.WellFounded.isSupFiniteCompact`
 * `CompleteLattice.IsSupFiniteCompact.isSupClosedCompact`
 * `CompleteLattice.IsSupClosedCompact.wellFounded`
 * `CompleteLattice.isSupFiniteCompact_iff_all_elements_compact`

 We also show well-founded lattices are compactly generated
 (`CompleteLattice.isCompactlyGenerated_of_wellFounded`).

## References
- [G. Călugăreanu, *Lattice Concepts of Module Theory*][calugareanu]

## Tags

complete lattice, well-founded, compact
-/

variable {α : Type _} [CompleteLattice α]

namespace CompleteLattice

variable (α)

/-- A compactness property for a complete lattice is that any `sup`-closed non-empty subset
contains its `supₛ`. -/
def IsSupClosedCompact : Prop :=
  ∀ (s : Set α) (_ : s.Nonempty), (∀ (a) (_ : a ∈ s) (b) (_ : b ∈ s), a ⊔ b ∈ s) → supₛ s ∈ s
#align complete_lattice.is_sup_closed_compact CompleteLattice.IsSupClosedCompact

/-- A compactness property for a complete lattice is that any subset has a finite subset with the
same `supₛ`. -/
def IsSupFiniteCompact : Prop :=
  ∀ s : Set α, ∃ t : Finset α, ↑t ⊆ s ∧ supₛ s = t.sup id
#align complete_lattice.is_Sup_finite_compact CompleteLattice.IsSupFiniteCompact

/-- An element `k` of a complete lattice is said to be compact if any set with `supₛ`
above `k` has a finite subset with `supₛ` above `k`.  Such an element is also called
"finite" or "S-compact". -/
def IsCompactElement {α : Type _} [CompleteLattice α] (k : α) :=
  ∀ s : Set α, k ≤ supₛ s → ∃ t : Finset α, ↑t ⊆ s ∧ k ≤ t.sup id
#align complete_lattice.is_compact_element CompleteLattice.IsCompactElement

theorem isCompactElement_iff.{u} {α : Type u} [CompleteLattice α] (k : α) :
    CompleteLattice.IsCompactElement k ↔
      ∀ (ι : Type u) (s : ι → α), k ≤ supᵢ s → ∃ t : Finset ι, k ≤ t.sup s := by
  classical
    constructor
    · intro H ι s hs
      obtain ⟨t, ht, ht'⟩ := H (Set.range s) hs
      have : ∀ x : t, ∃ i, s i = x := fun x => ht x.prop
      choose f hf using this
      refine' ⟨Finset.univ.image f, ht'.trans _⟩
      · rw [Finset.sup_le_iff]
        intro b hb
        rw [← show s (f ⟨b, hb⟩) = id b from hf _]
        exact Finset.le_sup (Finset.mem_image_of_mem f <| Finset.mem_univ (Subtype.mk b hb))
    · intro H s hs
      obtain ⟨t, ht⟩ :=
        H s Subtype.val
          (by
            delta supᵢ
            rwa [Subtype.range_coe])
      refine' ⟨t.image Subtype.val, by simp, ht.trans _⟩
      rw [Finset.sup_le_iff]
      exact fun x hx => @Finset.le_sup _ _ _ _ _ id _ (Finset.mem_image_of_mem Subtype.val hx)
#align complete_lattice.is_compact_element_iff CompleteLattice.isCompactElement_iff

/-- An element `k` is compact if and only if any directed set with `supₛ` above
`k` already got above `k` at some point in the set. -/
theorem isCompactElement_iff_le_of_directed_supₛ_le (k : α) :
    IsCompactElement k ↔
      ∀ s : Set α, s.Nonempty → DirectedOn (· ≤ ·) s → k ≤ supₛ s → ∃ x : α, x ∈ s ∧ k ≤ x := by
  classical
    constructor
    · intro hk s hne hdir hsup
      obtain ⟨t, ht⟩ := hk s hsup
      -- certainly every element of t is below something in s, since ↑t ⊆ s.
      have t_below_s : ∀ x ∈ t, ∃ y ∈ s, x ≤ y := fun x hxt => ⟨x, ht.left hxt, le_rfl⟩
      obtain ⟨x, ⟨hxs, hsupx⟩⟩ := Finset.sup_le_of_le_directed s hne hdir t t_below_s
      exact ⟨x, ⟨hxs, le_trans ht.right hsupx⟩⟩
    · intro hk s hsup
      -- Consider the set of finite joins of elements of the (plain) set s.
      let S : Set α := { x | ∃ t : Finset α, ↑t ⊆ s ∧ x = t.sup id }
      -- S is directed, nonempty, and still has sup above k.
      have dir_US : DirectedOn (· ≤ ·) S :=
        by
        rintro x ⟨c, hc⟩ y ⟨d, hd⟩
        use x ⊔ y
        constructor
        · use c ∪ d
          constructor
          · simp only [hc.left, hd.left, Set.union_subset_iff, Finset.coe_union, and_self_iff]
          · simp only [hc.right, hd.right, Finset.sup_union]
        simp only [and_self_iff, le_sup_left, le_sup_right]
      have sup_S : supₛ s ≤ supₛ S := by
        apply supₛ_le_supₛ
        intro x hx
        use {x}
        simpa only [and_true_iff, id.def, Finset.coe_singleton, eq_self_iff_true,
          Finset.sup_singleton, Set.singleton_subset_iff]
      have Sne : S.Nonempty := by
        suffices : ⊥ ∈ S
        exact Set.nonempty_of_mem this
        use ∅
        simp only [Set.empty_subset, Finset.coe_empty, Finset.sup_empty, eq_self_iff_true,
          and_self_iff]
      -- Now apply the defn of compact and finish.
      obtain ⟨j, ⟨hjS, hjk⟩⟩ := hk S Sne dir_US (le_trans hsup sup_S)
      obtain ⟨t, ⟨htS, htsup⟩⟩ := hjS
      use t
      exact ⟨htS, by rwa [← htsup]⟩
#align complete_lattice.is_compact_element_iff_le_of_directed_Sup_le CompleteLattice.isCompactElement_iff_le_of_directed_supₛ_le

theorem IsCompactElement.exists_finset_of_le_supᵢ {k : α} (hk : IsCompactElement k) {ι : Type _}
    (f : ι → α) (h : k ≤ ⨆ i, f i) : ∃ s : Finset ι, k ≤ ⨆ i ∈ s, f i := by
  classical
    let g : Finset ι → α := fun s => ⨆ i ∈ s, f i
    have h1 : DirectedOn (· ≤ ·) (Set.range g) :=
      by
      rintro - ⟨s, rfl⟩ - ⟨t, rfl⟩
      exact
        ⟨g (s ∪ t), ⟨s ∪ t, rfl⟩, supᵢ_le_supᵢ_of_subset (Finset.subset_union_left s t),
          supᵢ_le_supᵢ_of_subset (Finset.subset_union_right s t)⟩
    have h2 : k ≤ supₛ (Set.range g) :=
      h.trans
        (supᵢ_le fun i =>
          le_supₛ_of_le ⟨{i}, rfl⟩
            (le_supᵢ_of_le i (le_supᵢ_of_le (Finset.mem_singleton_self i) le_rfl)))
    obtain ⟨-, ⟨s, rfl⟩, hs⟩ :=
      (isCompactElement_iff_le_of_directed_supₛ_le α k).mp hk (Set.range g) (Set.range_nonempty g)
        h1 h2
    exact ⟨s, hs⟩
#align complete_lattice.is_compact_element.exists_finset_of_le_supr CompleteLattice.IsCompactElement.exists_finset_of_le_supᵢ

/-- A compact element `k` has the property that any directed set lying strictly below `k` has
its `supₛ` strictly below `k`. -/
theorem IsCompactElement.directed_supₛ_lt_of_lt {α : Type _} [CompleteLattice α] {k : α}
    (hk : IsCompactElement k) {s : Set α} (hemp : s.Nonempty) (hdir : DirectedOn (· ≤ ·) s)
    (hbelow : ∀ x ∈ s, x < k) : supₛ s < k := by
  rw [isCompactElement_iff_le_of_directed_supₛ_le] at hk
  by_contra h
  have sSup : supₛ s ≤ k := supₛ_le s k fun s hs => (hbelow s hs).le
  replace sSup : supₛ s = k := eq_iff_le_not_lt.mpr ⟨sSup, h⟩
  obtain ⟨x, hxs, hkx⟩ := hk s hemp hdir sSup.symm.le
  obtain hxk := hbelow x hxs
  exact hxk.ne (hxk.le.antisymm hkx)
#align complete_lattice.is_compact_element.directed_Sup_lt_of_lt CompleteLattice.IsCompactElement.directed_supₛ_lt_of_lt

theorem finset_sup_compact_of_compact {α β : Type _} [CompleteLattice α] {f : β → α} (s : Finset β)
    (h : ∀ x ∈ s, IsCompactElement (f x)) : IsCompactElement (s.sup f) := by
  classical
    rw [isCompactElement_iff_le_of_directed_supₛ_le]
    intro d hemp hdir hsup
    rw [← Function.comp.left_id f]
    rw [← Finset.sup_finset_image]
    apply Finset.sup_le_of_le_directed d hemp hdir
    rintro x hx
    obtain ⟨p, ⟨hps, rfl⟩⟩ := Finset.mem_image.mp hx
    specialize h p hps
    rw [isCompactElement_iff_le_of_directed_supₛ_le] at h
    specialize h d hemp hdir (le_trans (Finset.le_sup hps) hsup)
    simpa only [exists_prop]
#align complete_lattice.finset_sup_compact_of_compact CompleteLattice.finset_sup_compact_of_compact

theorem WellFounded.isSupFiniteCompact (h : WellFounded ((· > ·) : α → α → Prop)) :
    IsSupFiniteCompact α := by
  intro s
  let p : Set α := { x | ∃ t : Finset α, ↑t ⊆ s ∧ t.sup id = x }
  have hp : p.Nonempty := by
    use ⊥, ∅
    simp
  obtain ⟨m, ⟨t, ⟨ht₁, ht₂⟩⟩, hm⟩ := WellFounded.wellFounded_iff_has_max'.mp h p hp
  use t
  simp only [ht₁, ht₂, true_and_iff]
  apply le_antisymm
  · apply supₛ_le
    intro y hy
    classical
      have hy' : (insert y t).sup id ∈ p := by
        use insert y t
        simp
        rw [Set.insert_subset]
        exact ⟨hy, ht₁⟩
      have hm' : m ≤ (insert y t).sup id := by
        rw [← ht₂]
        exact Finset.sup_mono (t.subset_insert y)
      rw [← hm _ hy' hm']
      simp
  · rw [← ht₂, Finset.sup_id_eq_supₛ]
    exact supₛ_le_supₛ ht₁
#align complete_lattice.well_founded.is_Sup_finite_compact CompleteLattice.WellFounded.isSupFiniteCompact

theorem IsSupFiniteCompact.isSupClosedCompact (h : IsSupFiniteCompact α) : IsSupClosedCompact α :=
  by
  intro s hne hsc; obtain ⟨t, ht₁, ht₂⟩ := h s; clear h
  cases' t.eq_empty_or_nonempty with h h
  · subst h
    rw [Finset.sup_empty] at ht₂
    rw [ht₂]
    simp [eq_singleton_bot_of_supₛ_eq_bot_of_nonempty ht₂ hne]
  · rw [ht₂]
    exact t.sup_closed_of_sup_closed h ht₁ hsc
#align complete_lattice.is_Sup_finite_compact.is_sup_closed_compact CompleteLattice.IsSupFiniteCompact.isSupClosedCompact

theorem IsSupClosedCompact.wellFounded (h : IsSupClosedCompact α) :
    WellFounded ((· > ·) : α → α → Prop) := by
  refine' RelEmbedding.wellFounded_iff_no_descending_seq.mpr ⟨fun a => _⟩
  suffices supₛ (Set.range a) ∈ Set.range a
    by
    obtain ⟨n, hn⟩ := Set.mem_range.mp this
    have h' : supₛ (Set.range a) < a (n + 1) :=
      by
      change _ > _
      simp [← hn, a.map_rel_iff]
    apply lt_irrefl (a (n + 1))
    apply lt_of_le_of_lt _ h'
    apply le_supₛ
    apply Set.mem_range_self
  apply h (Set.range a)
  · use a 37
    apply Set.mem_range_self
  · rintro x ⟨m, hm⟩ y ⟨n, hn⟩
    use m ⊔ n
    rw [← hm, ← hn]
    apply RelHomClass.map_sup a
#align complete_lattice.is_sup_closed_compact.well_founded CompleteLattice.IsSupClosedCompact.wellFounded

theorem isSupFiniteCompact_iff_all_elements_compact :
    IsSupFiniteCompact α ↔ ∀ k : α, IsCompactElement k := by
  refine' ⟨fun h k s hs => _, fun h s => _⟩
  · obtain ⟨t, ⟨hts, htsup⟩⟩ := h s
    use t, hts
    rwa [← htsup]
  · obtain ⟨t, ⟨hts, htsup⟩⟩ := h (supₛ s) s (by rfl)
    have : supₛ s = t.sup id :=
      by
      suffices t.sup id ≤ supₛ s by apply le_antisymm <;> assumption
      simp only [id.def, Finset.sup_le_iff]
      intro x hx
      exact le_supₛ _ _ (hts hx)
    exact ⟨t, hts, this⟩
#align complete_lattice.is_Sup_finite_compact_iff_all_elements_compact CompleteLattice.isSupFiniteCompact_iff_all_elements_compact

open List in
theorem wellFounded_characterisations : List.TFAE
    [WellFounded (( · > · ) : α → α → Prop),
      IsSupFiniteCompact α, IsSupClosedCompact α, ∀ k : α, IsCompactElement k] := by
  tfae_have 1 → 2
  · exact WellFounded.isSupFiniteCompact α
  tfae_have 2 → 3
  · exact IsSupFiniteCompact.isSupClosedCompact α
  tfae_have 3 → 1
  · exact IsSupClosedCompact.wellFounded α
  tfae_have 2 ↔ 4
  · exact isSupFiniteCompact_iff_all_elements_compact α
  tfae_finish
#align complete_lattice.well_founded_characterisations CompleteLattice.wellFounded_characterisations

theorem wellFounded_iff_isSupFiniteCompact :
    WellFounded ((· > ·) : α → α → Prop) ↔ IsSupFiniteCompact α :=
  (wellFounded_characterisations α).out 0 1
#align complete_lattice.well_founded_iff_is_Sup_finite_compact CompleteLattice.wellFounded_iff_isSupFiniteCompact

theorem isSupFiniteCompact_iff_isSupClosedCompact : IsSupFiniteCompact α ↔ IsSupClosedCompact α :=
  (wellFounded_characterisations α).out 1 2
#align complete_lattice.is_Sup_finite_compact_iff_is_sup_closed_compact CompleteLattice.isSupFiniteCompact_iff_isSupClosedCompact

theorem isSupClosedCompact_iff_wellFounded :
    IsSupClosedCompact α ↔ WellFounded ((· > ·) : α → α → Prop) :=
  (wellFounded_characterisations α).out 2 0
#align complete_lattice.is_sup_closed_compact_iff_well_founded CompleteLattice.isSupClosedCompact_iff_wellFounded

alias wellFounded_iff_isSupFiniteCompact ↔ _ IsSupFiniteCompact.wellFounded
#align complete_lattice.is_Sup_finite_compact.well_founded CompleteLattice.IsSupFiniteCompact.wellFounded

alias isSupFiniteCompact_iff_isSupClosedCompact ↔ _ IsSupClosedCompact.isSupFiniteCompact
#align complete_lattice.is_sup_closed_compact.is_Sup_finite_compact CompleteLattice.IsSupClosedCompact.isSupFiniteCompact

alias isSupClosedCompact_iff_wellFounded ↔ _ _root_.WellFounded.isSupClosedCompact
#align well_founded.is_sup_closed_compact WellFounded.isSupClosedCompact

variable {α}

theorem WellFounded.finite_of_setIndependent (h : WellFounded ((· > ·) : α → α → Prop)) {s : Set α}
    (hs : SetIndependent s) : s.Finite := by
  classical
    refine' Set.not_infinite.mp fun contra => _
    obtain ⟨t, ht₁, ht₂⟩ := WellFounded.isSupFiniteCompact α h s
    replace contra : ∃ x : α, x ∈ s ∧ x ≠ ⊥ ∧ x ∉ t
    · have : (s \ (insert ⊥ t : Finset α)).Infinite := contra.diff (Finset.finite_toSet _)
      obtain ⟨x, hx₁, hx₂⟩ := this.nonempty
      exact ⟨x, hx₁, by simpa [not_or] using hx₂⟩
    obtain ⟨x, hx₀, hx₁, hx₂⟩ := contra
    replace hs : x ⊓ supₛ s = ⊥
    · have := hs.mono (by simp [ht₁, hx₀, -Set.union_singleton] : ↑t ∪ {x} ≤ s) (by simp : x ∈ _)
      simpa [Disjoint, hx₂, ← t.sup_id_eq_supₛ, ← ht₂] using this.eq_bot
    apply hx₁
    rw [← hs, eq_comm, inf_eq_left]
    exact le_supₛ _ _ hx₀
#align complete_lattice.well_founded.finite_of_set_independent CompleteLattice.WellFounded.finite_of_setIndependent

theorem WellFounded.finite_of_independent (hwf : WellFounded ((· > ·) : α → α → Prop)) {ι : Type _}
    {t : ι → α} (ht : Independent t) (h_ne_bot : ∀ i, t i ≠ ⊥) : Finite ι :=
  haveI := (WellFounded.finite_of_setIndependent hwf ht.setIndependent_range).to_subtype
  Finite.of_injective_finite_range (ht.injective h_ne_bot)
#align complete_lattice.well_founded.finite_of_independent CompleteLattice.WellFounded.finite_of_independent

end CompleteLattice

/-- A complete lattice is said to be compactly generated if any
element is the `supₛ` of compact elements. -/
class IsCompactlyGenerated (α : Type _) [CompleteLattice α] : Prop where
  /-- In a compactly generated complete lattice,
    every element is the `supₛ` of some set of compact elements. -/
  exists_supₛ_eq : ∀ x : α, ∃ s : Set α, (∀ x ∈ s, CompleteLattice.IsCompactElement x) ∧ supₛ s = x
#align is_compactly_generated IsCompactlyGenerated

section

variable [CompleteLattice α] [IsCompactlyGenerated α] {a b : α} {s : Set α}

@[simp]
theorem supₛ_compact_le_eq (b) : supₛ { c : α | CompleteLattice.IsCompactElement c ∧ c ≤ b } = b :=
  by
  rcases IsCompactlyGenerated.exists_supₛ_eq b with ⟨s, hs, rfl⟩
  exact le_antisymm (supₛ_le fun c hc => hc.2) (supₛ_le_supₛ fun c cs => ⟨hs c cs, le_supₛ cs⟩)
#align Sup_compact_le_eq supₛ_compact_le_eq

@[simp]
theorem supₛ_compact_eq_top : supₛ { a : α | CompleteLattice.IsCompactElement a } = ⊤ := by
  refine' Eq.trans (congr rfl (Set.ext fun x => _)) (supₛ_compact_le_eq ⊤)
  exact (and_iff_left le_top).symm
#align Sup_compact_eq_top supₛ_compact_eq_top

theorem le_iff_compact_le_imp {a b : α} :
    a ≤ b ↔ ∀ c : α, CompleteLattice.IsCompactElement c → c ≤ a → c ≤ b :=
  ⟨fun ab c _ ca => le_trans ca ab, fun h =>
    by
    rw [← supₛ_compact_le_eq a, ← supₛ_compact_le_eq b]
    exact supₛ_le_supₛ fun c hc => ⟨hc.1, h c hc.1 hc.2⟩⟩
#align le_iff_compact_le_imp le_iff_compact_le_imp

/-- This property is sometimes referred to as `α` being upper continuous. -/
theorem inf_supₛ_eq_of_directedOn (h : DirectedOn (· ≤ ·) s) : a ⊓ supₛ s = ⨆ b ∈ s, a ⊓ b :=
  le_antisymm
    (by
      rw [le_iff_compact_le_imp]
      by_cases hs : s.Nonempty
      · intro c hc hcinf
        rw [le_inf_iff] at hcinf
        rw [CompleteLattice.isCompactElement_iff_le_of_directed_supₛ_le] at hc
        rcases hc s hs h hcinf.2 with ⟨d, ds, cd⟩
        refine' (le_inf hcinf.1 cd).trans (le_trans _ (le_supᵢ₂ d ds))
        rfl
      · rw [Set.not_nonempty_iff_eq_empty] at hs
        simp [hs])
    supᵢ_inf_le_inf_supₛ
#align inf_Sup_eq_of_directed_on inf_supₛ_eq_of_directedOn

/-- This property is equivalent to `α` being upper continuous. -/
theorem inf_supₛ_eq_supᵢ_inf_sup_finset :
    a ⊓ supₛ s = ⨆ (t : Finset α) (_H : ↑t ⊆ s), a ⊓ t.sup id :=
  le_antisymm
    (by
      rw [le_iff_compact_le_imp]
      intro c hc hcinf
      rw [le_inf_iff] at hcinf
      rcases hc s hcinf.2 with ⟨t, ht1, ht2⟩
      refine' (le_inf hcinf.1 ht2).trans (le_trans _ (le_supᵢ₂ t ht1))
      rfl)
    (supᵢ_le fun t =>
      supᵢ_le fun h => inf_le_inf_left _ ((Finset.sup_id_eq_supₛ t).symm ▸ supₛ_le_supₛ h))
#align inf_Sup_eq_supr_inf_sup_finset inf_supₛ_eq_supᵢ_inf_sup_finset

theorem CompleteLattice.setIndependent_iff_finite {s : Set α} :
    CompleteLattice.SetIndependent s ↔
      ∀ t : Finset α, ↑t ⊆ s → CompleteLattice.SetIndependent (↑t : Set α) :=
  ⟨fun hs t ht => hs.mono ht, fun h a ha => by
    rw [disjoint_iff, inf_supₛ_eq_supᵢ_inf_sup_finset, supᵢ_eq_bot]
    intro t
    rw [supᵢ_eq_bot, Finset.sup_id_eq_supₛ]
    intro ht
    classical
      have h' := (h (insert a t) ?_ (t.mem_insert_self a)).eq_bot
      · rwa [Finset.coe_insert, Set.insert_diff_self_of_not_mem] at h'
        exact fun con => ((Set.mem_diff a).1 (ht con)).2 (Set.mem_singleton a)
      · rw [Finset.coe_insert, Set.insert_subset]
        exact ⟨ha, Set.Subset.trans ht (Set.diff_subset _ _)⟩⟩
#align complete_lattice.set_independent_iff_finite CompleteLattice.setIndependent_iff_finite

theorem CompleteLattice.setIndependent_unionᵢ_of_directed {η : Type _} {s : η → Set α}
    (hs : Directed (· ⊆ ·) s) (h : ∀ i, CompleteLattice.SetIndependent (s i)) :
    CompleteLattice.SetIndependent (⋃ i, s i) := by
  by_cases hη : Nonempty η
  · rw [CompleteLattice.setIndependent_iff_finite]
    intro t ht
    obtain ⟨I, fi, hI⟩ := Set.finite_subset_unionᵢ t.finite_toSet ht
    obtain ⟨i, hi⟩ := hs.finset_le fi.toFinset
    exact (h i).mono
        (Set.Subset.trans hI <| Set.unionᵢ₂_subset fun j hj => hi j (fi.mem_toFinset.2 hj))
  · rintro a ⟨_, ⟨i, _⟩, _⟩
    exfalso
    exact hη ⟨i⟩
#align complete_lattice.set_independent_Union_of_directed CompleteLattice.setIndependent_unionᵢ_of_directed

theorem CompleteLattice.independent_unionₛ_of_directed {s : Set (Set α)} (hs : DirectedOn (· ⊆ ·) s)
    (h : ∀ a ∈ s, CompleteLattice.SetIndependent a) : CompleteLattice.SetIndependent (⋃₀ s) := by
  rw [Set.unionₛ_eq_unionᵢ]
  exact CompleteLattice.setIndependent_unionᵢ_of_directed hs.directed_val (by simpa using h)
#align complete_lattice.independent_sUnion_of_directed CompleteLattice.independent_unionₛ_of_directed

end

namespace CompleteLattice

theorem isCompactlyGenerated_of_wellFounded (h : WellFounded ((· > ·) : α → α → Prop)) :
    IsCompactlyGenerated α := by
  rw [wellFounded_iff_isSupFiniteCompact, isSupFiniteCompact_iff_all_elements_compact] at h
  -- x is the join of the set of compact elements {x}
  exact ⟨fun x => ⟨{x}, ⟨fun x _ => h x, supₛ_singleton⟩⟩⟩
#align complete_lattice.compactly_generated_of_well_founded CompleteLattice.isCompactlyGenerated_of_wellFounded

/-- A compact element `k` has the property that any `b < k` lies below a "maximal element below
`k`", which is to say `[⊥, k]` is coatomic. -/
theorem Iic_coatomic_of_compact_element {k : α} (h : IsCompactElement k) :
    IsCoatomic (Set.Iic k) := by
  constructor
  rintro ⟨b, hbk⟩
  obtain rfl | H := eq_or_ne b k
  · left; ext; simp only [Set.Iic.coe_top, Subtype.coe_mk]
  right
  have ih : ?_ := ?_ -- Porting note: this is an ugly hack, but `?ih` on the next line fails
  obtain ⟨a, a₀, ba, h⟩ := zorn_nonempty_partialOrder₀ (Set.Iio k) ih b (lt_of_le_of_ne hbk H)
  · refine' ⟨⟨a, le_of_lt a₀⟩, ⟨ne_of_lt a₀, fun c hck => by_contradiction fun c₀ => _⟩, ba⟩
    cases h c.1 (lt_of_le_of_ne c.2 fun con => c₀ (Subtype.ext con)) hck.le
    exact lt_irrefl _ hck
  · intro S SC cC I _
    by_cases hS : S.Nonempty
    · refine' ⟨supₛ S, h.directed_supₛ_lt_of_lt hS cC.directedOn SC, _⟩
      intro; apply le_supₛ
    exact
      ⟨b, lt_of_le_of_ne hbk H, by
        simp only [Set.not_nonempty_iff_eq_empty.mp hS, Set.mem_empty_iff_false, forall_const,
          forall_prop_of_false, not_false_iff]⟩
#align complete_lattice.Iic_coatomic_of_compact_element CompleteLattice.Iic_coatomic_of_compact_element

theorem coatomic_of_top_compact (h : IsCompactElement (⊤ : α)) : IsCoatomic α :=
  (@OrderIso.IicTop α _ _).isCoatomic_iff.mp (Iic_coatomic_of_compact_element h)
#align complete_lattice.coatomic_of_top_compact CompleteLattice.coatomic_of_top_compact

end CompleteLattice

section

variable [IsModularLattice α] [IsCompactlyGenerated α]

instance (priority := 100) isAtomic_of_complementedLattice [ComplementedLattice α] : IsAtomic α :=
  ⟨fun b => by
    by_cases h : { c : α | CompleteLattice.IsCompactElement c ∧ c ≤ b } ⊆ {⊥}
    · left
      rw [← supₛ_compact_le_eq b, supₛ_eq_bot]
      exact h
    · rcases Set.not_subset.1 h with ⟨c, ⟨hc, hcb⟩, hcbot⟩
      right
      have hc' := CompleteLattice.Iic_coatomic_of_compact_element hc
      rw [← isAtomic_iff_isCoatomic] at hc'
      haveI := hc'
      obtain con | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le (⟨c, le_refl c⟩ : Set.Iic c)
      · exfalso
        apply hcbot
        simp only [Subtype.ext_iff, Set.Iic.coe_bot, Subtype.coe_mk] at con
        exact con
      rw [← Subtype.coe_le_coe, Subtype.coe_mk] at hac
      exact ⟨a, ha.of_isAtom_coe_Iic, hac.trans hcb⟩⟩
#align is_atomic_of_complemented_lattice isAtomic_of_complementedLattice

/-- See Lemma 5.1, Călugăreanu -/
instance (priority := 100) isAtomistic_of_complementedLattice [ComplementedLattice α] :
    IsAtomistic α :=
  ⟨fun b =>
    ⟨{ a | IsAtom a ∧ a ≤ b }, by
      symm
      have hle : supₛ { a : α | IsAtom a ∧ a ≤ b } ≤ b := supₛ_le fun _ => And.right
      apply (lt_or_eq_of_le hle).resolve_left _
      intro con
      obtain ⟨c, hc⟩ := exists_isCompl (⟨supₛ { a : α | IsAtom a ∧ a ≤ b }, hle⟩ : Set.Iic b)
      obtain rfl | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le c
      · exact ne_of_lt con (Subtype.ext_iff.1 (eq_top_of_isCompl_bot hc))
      · apply ha.1
        rw [eq_bot_iff]
        apply le_trans (le_inf _ hac) hc.Disjoint.le_bot
        rw [← Subtype.coe_le_coe, Subtype.coe_mk]
        exact le_supₛ ⟨ha.of_isAtom_coe_Iic, a.2⟩, fun _ => And.left⟩⟩
#align is_atomistic_of_complemented_lattice isAtomistic_of_complementedLattice

/-- See Theorem 6.6, Călugăreanu -/
theorem complementedLattice_of_supₛ_atoms_eq_top (h : supₛ { a : α | IsAtom a } = ⊤) :
    ComplementedLattice α :=
  ⟨fun b => by
    have H : ?_ := ?_ -- Porting note: this is an ugly hack, but `?H` on the next line fails
    obtain ⟨s, ⟨s_ind, b_inf_Sup_s, s_atoms⟩, s_max⟩ :=
      zorn_subset
        { s : Set α | CompleteLattice.SetIndependent s ∧ b ⊓ supₛ s = ⊥ ∧ ∀ a ∈ s, IsAtom a } H
    · refine'
        ⟨supₛ s, disjoint_iff.mpr b_inf_Sup_s,
          codisjoint_iff_le_sup.mpr <| h.symm.trans_le <| supₛ_le_iff.2 fun a ha => _⟩
      rw [← inf_eq_left]
      refine' (ha.le_iff.mp inf_le_left).resolve_left fun con => ha.1 _
      rw [eq_bot_iff, ← con]
      refine' le_inf (le_refl a) ((le_supₛ _).trans le_sup_right)
      rw [← disjoint_iff] at *
      have a_dis_Sup_s : Disjoint a (supₛ s) := con.mono_right le_sup_right
      rw [← s_max (s ∪ {a}) ⟨_, ⟨_, _⟩⟩ (Set.subset_union_left _ _)]
      · exact Set.mem_union_right _ (Set.mem_singleton _)
      · intro x hx
        rw [Set.mem_union, Set.mem_singleton_iff] at hx
        by_cases xa : x = a
        · simp only [xa, Set.mem_singleton, Set.insert_diff_of_mem, Set.union_singleton]
          exact con.mono_right (le_trans (supₛ_le_supₛ (Set.diff_subset s {a})) le_sup_right)
        · have h : (s ∪ {a}) \ {x} = s \ {x} ∪ {a} :=
            by
            simp only [Set.union_singleton]
            rw [Set.insert_diff_of_not_mem]
            rw [Set.mem_singleton_iff]
            exact Ne.symm xa
          rw [h, supₛ_union, supₛ_singleton]
          apply
            (s_ind (hx.resolve_right xa)).disjoint_sup_right_of_disjoint_sup_left
              (a_dis_Sup_s.mono_right _).symm
          rw [← supₛ_insert, Set.insert_diff_singleton, Set.insert_eq_of_mem (hx.resolve_right xa)]
      · rw [supₛ_union, supₛ_singleton, ← disjoint_iff]
        exact b_inf_Sup_s.disjoint_sup_right_of_disjoint_sup_left con.symm
      · intro x hx
        rw [Set.mem_union, Set.mem_singleton_iff] at hx
        cases' hx with hx hx
        · exact s_atoms x hx
        · rw [hx]
          exact ha
    · intro c hc1 hc2
      refine'
        ⟨⋃₀ c,
          ⟨CompleteLattice.independent_unionₛ_of_directed hc2.directedOn fun s hs => (hc1 hs).1, _,
            fun a ha => _⟩,
          fun _ => Set.subset_unionₛ_of_mem⟩
      · rw [supₛ_unionₛ, ← supₛ_image, inf_supₛ_eq_of_directedOn, supᵢ_eq_bot]
        · intro i
          rw [supᵢ_eq_bot]
          intro hi
          obtain ⟨x, xc, rfl⟩ := (Set.mem_image _ _ _).1 hi
          exact (hc1 xc).2.1
        · rw [directedOn_image]
          refine' hc2.directedOn.mono _
          intro s t
          apply supₛ_le_supₛ
      · rcases Set.mem_unionₛ.1 ha with ⟨s, sc, as⟩
        exact (hc1 sc).2.2 a as⟩
#align complemented_lattice_of_Sup_atoms_eq_top complementedLattice_of_supₛ_atoms_eq_top

/-- See Theorem 6.6, Călugăreanu -/
theorem complementedLattice_of_isAtomistic [IsAtomistic α] : ComplementedLattice α :=
  complementedLattice_of_supₛ_atoms_eq_top supₛ_atoms_eq_top
#align complemented_lattice_of_is_atomistic complementedLattice_of_isAtomistic

theorem complementedLattice_iff_isAtomistic : ComplementedLattice α ↔ IsAtomistic α := by
  constructor <;> intros
  · exact isAtomistic_of_complementedLattice
  · exact complementedLattice_of_isAtomistic
#align complemented_lattice_iff_is_atomistic complementedLattice_iff_isAtomistic

end


/-
Copyright (c) 2023 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen
-/

import algebra.big_operators.fin
import algebra.big_operators.order
import algebra.order.ring.abs
import data.multiset.sort

open_locale big_operators

section

open finset

section defs

variables {α : Type*}
  [linear_ordered_add_comm_monoid α]
  [decidable_rel ((≤) : α → α → Prop)]
  {ι : Type*} [fintype ι]

def weakly_majorize (l₁ l₂ : ι → α) :=
  ∀ n,
    (((univ.val.map l₁).sort (≥)).take n).sum ≤
    (((univ.val.map l₂).sort (≥)).take n).sum

/-- Majorization. Note that `majorize p q` means `q` majorizes `p` -/
def majorize (l₁ l₂ : ι → α) := weakly_majorize l₁ l₂ ∧ ∑ i, l₁ i = ∑ i, l₂ i

lemma majorize_def (l₁ l₂ : ι → α) :
  majorize l₁ l₂ ↔
  (∀ n,
    (((univ.val.map l₁).sort (≥)).take n).sum ≤
    (((univ.val.map l₂).sort (≥)).take n).sum) ∧ ∑ i, l₁ i = ∑ i, l₂ i := iff.rfl

infix ` ≺w `:45 := weakly_majorize
infix ` ≺ `:45 := majorize

lemma weakly_majorize_def' (l₁ l₂ : ι → α) :
  l₁ ≺w l₂ ↔
  ∀ n ≤ fintype.card ι,
    (((univ.val.map l₁).sort (≥)).take n).sum ≤
    (((univ.val.map l₂).sort (≥)).take n).sum :=
begin
  split,
  { intros h n hn,
    apply h },
  { intros h n,
    cases le_total n (fintype.card ι) with hn' hn',
    { exact h n hn' },
    { have := h _ le_rfl,
      rwa [list.take_all_of_le, list.take_all_of_le] at this ⊢,
      all_goals { rwa [multiset.length_sort, multiset.card_map]; refl } } }
end

instance : decidable_rel (≺w) := λ (l₁ l₂ : ι → α),
by { rw weakly_majorize_def', exact nat.decidable_ball_le _ _ }

instance : decidable_rel (≺) := λ (l₁ l₂ : ι → α), and.decidable

instance majorize.preorder : preorder (ι → α) :=
{ le := (≺),
  le_refl := λ l, ⟨λ _, rfl.le, rfl⟩,
  le_trans := λ l₁ l₂ l₃ h₁ h₂,
    ⟨λ h, (h₁.1 h).trans (h₂.1 h), h₁.2.trans h₂.2⟩ }

end defs

variables {α : Type*}

lemma exists_lt_eq_gt
  [linear_ordered_cancel_add_comm_monoid α]
  [decidable_rel ((<) : α → α → Prop)]
  {n} {a b : fin n → α} (hab : a ≠ b) (h₁ : ∑ i, a i = ∑ i, b i)
  (h₂ : ∀ i, ((list.of_fn a).take i).sum ≤ ((list.of_fn b).take i).sum) :
  ∃ (k l : fin n), k < l ∧ a k < b k ∧ b l < a l ∧ (∀ i, k < i → i < l → a i = b i):=
begin
  have h_k : ∃ k, a k ≠ b k,
  { by_contra' h,
    apply hab,
    ext,
    apply h },
  let k := option.get (fin.is_some_find_iff.2 h_k),
  have hk : k ∈ fin.find (λ i, a i ≠ b i) := option.get_mem _,
  have hk₂ : ∀ i < k, a i = b i := λ i hi, not_not.1 (fin.find_min hk hi),
  have hkab : list.take k (list.of_fn a) = list.take k (list.of_fn b),
  { apply list.ext_le,
    { iterate 2 { rw [list.length_take, list.length_of_fn] } },
    intros i hi _,
    iterate 2 { rw [list.nth_le_take', list.nth_le_of_fn'] },
    rw [list.length_take, list.length_of_fn, min_eq_left fin.is_le'] at hi,
    apply hk₂,
    exact hi  },
  have ha_len : ↑k < (list.of_fn a).length := (list.length_of_fn a).symm ▸ k.is_lt,
  have hb_len : ↑k < (list.of_fn b).length := (list.length_of_fn b).symm ▸ k.is_lt,
  specialize h₂ (k + 1),
  rw [list.sum_take_succ _ _ ha_len, list.sum_take_succ _ _ hb_len,
    list.nth_le_of_fn, list.nth_le_of_fn, hkab, add_le_add_iff_left] at h₂,
  have hk₁ := lt_of_le_of_ne h₂ (fin.find_spec _ hk),
  have h_l : ∃ l, b l < a l,
  { by_contra' h,
    refine ne_of_lt _ h₁,
    exact sum_lt_sum (λ _ _, h _) ⟨k, mem_univ _, hk₁⟩ },
  let l := option.get (fin.is_some_find_iff.2 h_l),
  have hl : l ∈ fin.find (λ i, b i < a i) := option.get_mem _,
  have hl₁ : b l < a l := fin.find_spec _ hl,
  have hkl : k < l,
  { by_contra' h,
    cases eq_or_lt_of_le h with h' h',
    { rw h' at hl₁,
      exact hl₁.not_le h₂ },
    { rw hk₂ _ h' at hl₁,
      exact lt_irrefl _ hl₁ } },
  let s := univ.filter (λ k' : fin l,
    a (fin.cast_le fin.is_le' k') < b (fin.cast_le fin.is_le' k')),
  have hs : s.nonempty,
  { use [k, fin.lt_iff_coe_lt_coe.1 hkl],
    rw mem_filter,
    refine ⟨mem_univ _, _⟩,
    rwa [fin.cast_le_mk, fin.eta] },
  let k' := fin.cast_le fin.is_le' (max' s hs),
  use [k', l, fin.is_lt _, (mem_filter.1 (max'_mem s hs)).2, hl₁],
  intros i hk'i hil,
  refine eq_of_le_of_not_lt (le_of_not_lt (fin.find_min hl hil)) _,
  intros hi,
  refine lt_irrefl _ ((max'_lt_iff _ _).1
    (show s.max' hs < ⟨i, hil⟩, from hk'i) _ _),
  rw mem_filter,
  refine ⟨mem_univ _, _⟩,
  rwa [fin.cast_le_mk, fin.eta]
end

end


/- Zariski topology, by Kenny Lau.

-/

import analysis.topology.topological_space Kenny_comm_alg.temp
noncomputable theory

local attribute [instance] classical.prop_decidable

universe u

section is_prime_ideal

theorem is_prime_ideal.one_not_mem {α : Type u} [comm_ring α] (S : set α) [is_prime_ideal S] :
  (1:α) ∉ S :=
λ h, is_proper_ideal.ne_univ S $ set.ext $ λ z,
⟨λ hz, trivial,
 λ hz, calc z = z * 1 : by simp
          ... ∈ S : is_submodule.smul z h⟩

end is_prime_ideal

def topological_space.of_closed {α : Type u} (T : set (set α))
  (H1 : ∅ ∈ T)
  (H2 : ∀ A ⊆ T, ⋂₀ A ∈ T)
  (H3 : ∀ A B ∈ T, A ∪ B ∈ T) :
  topological_space α :=
{ is_open := λ X, -X ∈ T,
  is_open_univ := by simp [H1],
  is_open_inter := λ s t hs ht, by simpa [set.compl_inter] using H3 (-s) (-t) hs ht,
  is_open_sUnion := λ s hs, by rw set.compl_sUnion; exact H2 (set.compl '' s) (λ z ⟨y, hy, hz⟩, by simpa [hz.symm] using hs y hy) }

section generate

variables {α : Type u} [comm_ring α] (S : set α)

def generate : set α :=
{ x | ∀ (T : set α) [is_submodule T], S ⊆ T → x ∈ T }

instance generate.is_ideal : is_submodule (generate S) :=
{ zero_ := λ T ht hst, @is_submodule.zero _ _ _ _ T ht,
  add_  := λ x y hx hy T ht hst, @@is_submodule.add _ _ ht (@hx T ht hst) (@hy T ht hst),
  smul  := λ x y hy T ht hst, @@is_submodule.smul _ _ ht _ (@hy T ht hst) }

theorem subset_generate : S ⊆ generate S :=
λ x hx T ht hst, hst hx

end generate

class t0_space (α : Type u) [topological_space α] :=
(t0 : ∀ x y, x ≠ y → ∃ U:set α, is_open U ∧ (xor (x ∈ U) (y ∈ U)))

section Zariski

parameters (α : Type u) [comm_ring α]

def X := {P : set α // is_prime_ideal P}

parameter {α}

def Spec.V : set α → set X :=
λ E, {P | E ⊆ P.val}

def Spec.V' : α → set X :=
λ f, {P | f ∈ P.val}

def Spec.D : set α → set X := λ E, -Spec.V(E)

def Spec.D' : α → set X := λ f, -Spec.V'(f)

parameter (α)

open Spec

theorem V_set_eq_V_generate (S : set α) : V S = V (generate S) :=
set.ext $ λ P,
⟨λ hp z hz, @hz P.val P.property.to_is_submodule hp,
 λ hp z hz, hp $ subset_generate S hz⟩

instance Zariski : topological_space X :=
topological_space.of_closed {A | ∃ E, V E = A}
  ⟨{(1:α)}, set.ext $ λ ⟨P, hp⟩,
     ⟨λ h, @@is_prime_ideal.one_not_mem _ P hp $ by simpa [V] using h,
      λ h, false.elim h⟩⟩
(λ T ht, ⟨⋃₀ {E | ∃ A ∈ T, V E = A}, set.ext $ λ ⟨P, hp⟩,
   ⟨λ hpv A hat,
      begin
        cases ht hat with E he,
        rw ← he,
        intros z hz,
        apply hpv,
        existsi E,
        existsi (⟨A, hat, he⟩ : ∃ A ∈ T, V E = A),
        exact hz
      end,
    λ hz x ⟨E, ⟨A, H, hvea⟩, hxe⟩,
      begin
        have h1 := hz A H,
        rw ← hvea at h1,
        exact h1 hxe,
      end⟩⟩)
(λ A B ⟨Ea, ha⟩ ⟨Eb, hb⟩,
   ⟨generate Ea ∩ generate Eb,
    set.ext $ λ ⟨P, hp⟩,
    ⟨λ hz, or_iff_not_and_not.2 $ λ ⟨hpa, hpb⟩,
       begin
         rw ← ha at hpa,
         rw ← hb at hpb,
         cases not_forall.1 hpa with wa hwa,
         cases not_forall.1 hpb with wb hwb,
         cases not_imp.1 hwa with hwa1 hwa2,
         cases not_imp.1 hwb with hwb1 hwb2,
         have : wa * wb ∈ generate Ea ∩ generate Eb,
         { split,
           { rw mul_comm,
             apply is_submodule.smul _ (subset_generate Ea hwa1) },
           { apply is_submodule.smul _ (subset_generate Eb hwb1) } },
         cases @@is_prime_ideal.mem_or_mem_of_mul_mem _ hp (hz this) with hwap hwbp,
         exact hwa (λ h, hwap),
         exact hwb (λ h, hwbp),
       end,
     λ hz y ⟨hy1, hy2⟩, or.cases_on hz
       (λ hpa, begin
          rw ← ha at hpa,
          rw V_set_eq_V_generate at hpa,
          exact hpa hy1
        end)
       (λ hpb, begin
          rw ← hb at hpb,
          rw V_set_eq_V_generate at hpb,
          exact hpb hy2
        end)⟩⟩)

lemma Zariski.is_open (U : set X) (E : set α) (H : U = - V E) :
  topological_space.is_open (Zariski) U :=
⟨E, by rw H; rw set.compl_compl⟩

instance Zariski.t0 : @t0_space X Zariski :=
begin
  constructor,
  intros x y hxy,
  cases x with x hx,
  cases y with y hy,
  have h1 : ¬ x = y,
  { intro h,
    apply hxy,
    exact subtype.eq h },
  rw set.ext_iff at h1,
  rw not_forall at h1,
  cases h1 with z hz,
  existsi -(V {z}),
  split,
  { existsi {z},
    rw set.compl_compl },
  rw iff_def at hz,
  rw not_and_distrib at hz,
  cases hz;
  rw not_imp at hz,
  { cases hz with hzx hzy,
    right,
    split,
    { intro h,
      apply hzy,
      apply h,
      exact set.mem_singleton z },
    { intro h,
      apply h,
      intros m hm,
      rw set.mem_singleton_iff at hm,
      rw hm,
      exact hzx } },
  { cases hz with hzy hzx,
    left,
    split,
    { intro h,
      apply hzx,
      apply h,
      exact set.mem_singleton z },
    { intro h,
      apply h,
      intros m hm,
      rw set.mem_singleton_iff at hm,
      rw hm,
      exact hzy } }
end

end Zariski