section
  variable (p q r : Prop)

  example : p ∧ q ↔ q ∧ p :=
    Iff.intro
    (fun h => ⟨h.right, h.left⟩)
    (fun h => ⟨h.right, h.left⟩)

  example : p ∨ q ↔ q ∨ p :=
    Iff.intro
    (
      fun h =>
        Or.elim h
        (
          fun hp => Or.inr hp
        )
        (
          fun hq => Or.inl hq
        )
    )
    (
      fun h =>
        Or.elim h
        (
          fun hq => Or.inr hq
        )
        (
          fun hp => Or.inl hp
        )
    )

  example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
    Iff.intro
    (
      fun h =>
        ⟨h.left.left, ⟨h.left.right, h.right⟩⟩
    )
    (
      fun h =>
        ⟨⟨h.left, h.right.left⟩, h.right.right⟩
    )

  example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
    Iff.intro
    (
      fun h =>
        Or.elim h
        (
          fun hpq =>
            Or.elim hpq
            (
              fun hp => Or.inl hp
            )
            (
              fun hq => Or.inr $ Or.inl hq
            )
        )
        (
          fun hr =>
            Or.inr $ Or.inr hr
        )
    )
    (
      fun h =>
        Or.elim h
        (
          fun hp =>
            Or.inl $ Or.inl hp
        )
        (
          fun hqr =>
            Or.elim hqr
            (
              fun hq => Or.inl $ Or.inr hq
            )
            (
              fun hr => Or.inr hr
            )
        )
    )

  example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
    Iff.intro
    (
      fun h =>
        have hp := h.left
        Or.elim h.right
        (
          fun hq =>
            Or.inl $ And.intro hp hq
        )
        (
          fun hr =>
            Or.inr $ And.intro hp hr
        )
    )
    (
      fun h =>
        Or.elim h
        (
          fun hpq =>
            And.intro hpq.left $ Or.inl hpq.right
        )
        (
          fun hpr =>
            have hp := hpr.left
            have hr := hpr.right
            have hqr := Or.inr hr
            And.intro hp hqr
        )
    )

  example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
    Iff.intro
    (
      fun h =>
        Or.elim h
        (
          fun hp =>
            ⟨Or.inl hp, Or.inl hp⟩
        )
        (
          fun hqr =>
            ⟨Or.inr hqr.left, Or.inr hqr.right⟩
        )
    )
    (
      fun h =>
        have hpq := h.left
        have hpr := h.right
        Or.elim hpq
        (
          fun hp =>
            Or.inl hp
        )
        (
          fun hq =>
            Or.elim hpr
            (
              fun hp =>
                Or.inl hp
            )
            (
              fun hr =>
                Or.inr ⟨hq, hr⟩
            )
        )
    )

  example : (p → (q → r)) ↔ (p ∧ q → r) :=
    Iff.intro
    (
      fun hpqr =>
        fun hpq =>
          have hp := hpq.left
          have hq := hpq.right
          hpqr hp hq
    )
    (
      fun h =>
        fun hp =>
          fun hq =>
            have hpq := ⟨hp, hq⟩
            h hpq
    )

  example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
    Iff.intro
    (
      fun h =>
        And.intro
        (
          fun hp : p =>
            have hpq := Or.inl hp
            have hr := h hpq
            hr
        )
        (
          fun hq : q =>
            have hpq := Or.inr hq
            have hr := h hpq
            hr
        )
    )
    (
      fun h =>
        fun hpq : p ∨ q =>
          Or.elim hpq
          (
            fun hp =>
              h.left hp
          )
          (
            fun hq =>
              h.right hq
          )
    )

  example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
    Iff.intro
    (
      fun hnpq : ¬(p ∨ q) =>
        And.intro
        (
          fun hp : p =>
            have hpq : p ∨ q := Or.inl hp
            hnpq hpq
        )
        (
          fun hq : q =>
            have hpq : p ∨ q := Or.inr hq
            hnpq hpq
        )
    )
    (
      fun hnpnq : ¬p ∧ ¬q =>
        fun hpq : p ∨ q =>
          Or.elim hpq
          (
            fun hp =>
              have hnp := hnpnq.left
              hnp hp
          )
          (
            fun hq =>
              hnpnq.right hq
          )

    )

  example : ¬p ∨ ¬q → ¬(p ∧ q) :=
    fun hnpnq : ¬p ∨ ¬q =>
      fun hpq : p ∧ q =>
        Or.elim hnpnq
        (
          fun hnp : ¬p =>
            hnp hpq.left
        )
        (
          fun hnq : ¬q =>
            hnq hpq.right
        )

  example : ¬(p ∧ ¬p) :=
    fun hpnp : p ∧ ¬p =>
      hpnp.right hpnp.left

  example : p ∧ ¬q → ¬(p → q) :=
    fun h =>
      fun hpq =>
        have hq := hpq h.left
        h.right hq

  example : ¬p → (p → q) :=
    fun hnp =>
      fun hp =>
        absurd hp hnp

  example : (¬p ∨ q) → (p → q) :=
    fun hnpq =>
      fun hp =>
        Or.elim hnpq
        (
          fun hnp =>
            absurd hp hnp
        )
        (
          fun hq =>
            hq
        )

  example : p ∨ False ↔ p :=
    Iff.intro
    (
      fun h =>
        Or.elim h
        (
          fun hp => hp
        )
        (
          fun fls => False.elim fls
        )
    )
    (
      fun h =>
        Or.inl h
    )

  example : p ∧ False ↔ False :=
    Iff.intro
    (
      fun h => h.right
    )
    (
      fun fls =>
        have hp := False.elim fls
        And.intro hp fls
    )

  example : (p → q) → (¬q → ¬p) :=
    fun hpq =>
      fun hnq =>
        fun hp =>
          hnq $ hpq hp
end

section
  open Classical

  variable (p q r : Prop)

  example : (p → q ∨ r) → ((p → q) ∨ (p → r)) :=
    fun hpqr : (p → q ∨ r) =>
      Or.elim (em q)
      (
        fun hq =>
          Or.inl $ fun _ => hq
      )
      (
        fun hnq =>
          Or.inr <|
            fun hp =>
              have hqr := hpqr hp
              Or.elim hqr
              (
                fun hq => absurd hq hnq
              )
              (
                fun hr => hr
              )
      )

  example : ¬(p ∧ q) → ¬p ∨ ¬q :=
    fun hnpq =>
      Or.elim (em p)
      (
        fun hp =>
          Or.elim (em q)
          (
            fun hq =>
              absurd ⟨hp, hq⟩ hnpq
          )
          (
            fun hnq => Or.inr hnq
          )
      )
      (
        fun hnp =>
          Or.inl hnp
      )

  example : ¬(p → q) → p ∧ ¬q :=
    fun hnpq : ¬(p → q) =>
      Or.elim (em p)
      (
        fun hp =>
          Or.elim (em q)
          (
            fun hq =>
              have hpq := fun _ => hq
              absurd hpq hnpq
          )
          (
            fun hnq =>
              And.intro hp hnq
          )
      )
      (
        fun hnp =>
          Or.elim (em q)
          (
            fun hq =>
              have hpq := fun _ => hq
              absurd hpq hnpq
          )
          (
            fun _ =>
              have hpq := fun hp => absurd hp hnp
              absurd hpq hnpq
          )
      )

  example : (p → q) → (¬p ∨ q) :=
    fun hpq =>
      Or.elim (em p)
      (
        fun hp =>
          have hq := hpq hp
          Or.inr hq
      )
      (
        fun hnp =>
          Or.inl hnp
      )

  example : (¬q → ¬p) → (p → q) :=
    fun hnqnp =>
      Or.elim (em q)
      (
        fun hq =>
          have hpq := fun _ => hq
          hpq
      )
      (
        fun hnq =>
          have hnp := hnqnp hnq
          fun hp =>
            absurd hp hnp
      )

  example : (p ∨ ¬p) :=
    em p

  example : ((p → q) → p) → p :=
    fun hpqp =>
      Or.elim (em p)
      (
        fun hp : p => hp
      )
      (
        fun hnp : ¬p =>
          have hpq :=
            fun hp => absurd hp hnp
          have hp := hpqp hpq
          absurd hp hnp
      )

end

section
  variable (p : Prop)

  example : ¬(p ↔ ¬p) :=
    fun h : p ↔ ¬p =>
      have hnp : ¬p :=
        fun hp : p =>
          have hnp' := h.mp hp
          absurd hp hnp'
      have hp : p := h.mpr hnp
      absurd hp hnp

end


/-
Copyright (c) 2019 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 topology.uniform_space.completion
import topology.metric_space.isometry
import topology.instances.real

/-!
# The completion of a metric space

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

Completion of uniform spaces are already defined in `topology.uniform_space.completion`. We show
here that the uniform space completion of a metric space inherits a metric space structure,
by extending the distance to the completion and checking that it is indeed a distance, and that
it defines the same uniformity as the already defined uniform structure on the completion
-/

open set filter uniform_space metric
open_locale filter topology uniformity
noncomputable theory

universes u v
variables {α : Type u} {β : Type v} [pseudo_metric_space α]

namespace uniform_space.completion

/-- The distance on the completion is obtained by extending the distance on the original space,
by uniform continuity. -/
instance : has_dist (completion α) :=
⟨completion.extension₂ dist⟩

/-- The new distance is uniformly continuous. -/
protected lemma uniform_continuous_dist :
  uniform_continuous (λp:completion α × completion α, dist p.1 p.2) :=
uniform_continuous_extension₂ dist

/-- The new distance is continuous. -/
protected lemma continuous_dist [topological_space β] {f g : β → completion α} (hf : continuous f)
  (hg : continuous g) :
  continuous (λ x, dist (f x) (g x)) :=
completion.uniform_continuous_dist.continuous.comp (hf.prod_mk hg : _)

/-- The new distance is an extension of the original distance. -/
@[simp] protected lemma dist_eq (x y : α) : dist (x : completion α) y = dist x y :=
completion.extension₂_coe_coe uniform_continuous_dist _ _

/- Let us check that the new distance satisfies the axioms of a distance, by starting from the
properties on α and extending them to `completion α` by continuity. -/
protected lemma dist_self (x : completion α) : dist x x = 0 :=
begin
  apply induction_on x,
  { refine is_closed_eq _ continuous_const,
    exact completion.continuous_dist continuous_id continuous_id },
  { assume a,
    rw [completion.dist_eq, dist_self] }
end

protected lemma dist_comm (x y : completion α) : dist x y = dist y x :=
begin
  apply induction_on₂ x y,
  { exact is_closed_eq (completion.continuous_dist continuous_fst continuous_snd)
      (completion.continuous_dist continuous_snd continuous_fst) },
  { assume a b,
    rw [completion.dist_eq, completion.dist_eq, dist_comm] }
end

protected lemma dist_triangle (x y z : completion α) : dist x z ≤ dist x y + dist y z :=
begin
  apply induction_on₃ x y z,
  { refine is_closed_le _ (continuous.add _ _);
      apply_rules [completion.continuous_dist, continuous.fst, continuous.snd, continuous_id] },
  { assume a b c,
    rw [completion.dist_eq, completion.dist_eq, completion.dist_eq],
    exact dist_triangle a b c }
end

/-- Elements of the uniformity (defined generally for completions) can be characterized in terms
of the distance. -/
protected lemma mem_uniformity_dist (s : set (completion α × completion α)) :
  s ∈ 𝓤 (completion α) ↔ (∃ε>0, ∀{a b}, dist a b < ε → (a, b) ∈ s) :=
begin
  split,
  { /- Start from an entourage `s`. It contains a closed entourage `t`. Its pullback in `α` is an
    entourage, so it contains an `ε`-neighborhood of the diagonal by definition of the entourages
    in metric spaces. Then `t` contains an `ε`-neighborhood of the diagonal in `completion α`, as
    closed properties pass to the completion. -/
    assume hs,
    rcases mem_uniformity_is_closed hs with ⟨t, ht, ⟨tclosed, ts⟩⟩,
    have A : {x : α × α | (coe (x.1), coe (x.2)) ∈ t} ∈ uniformity α :=
      uniform_continuous_def.1 (uniform_continuous_coe α) t ht,
    rcases mem_uniformity_dist.1 A with ⟨ε, εpos, hε⟩,
    refine ⟨ε, εpos, λx y hxy, _⟩,
    have : ε ≤ dist x y ∨ (x, y) ∈ t,
    { apply induction_on₂ x y,
      { have : {x : completion α × completion α | ε ≤ dist (x.fst) (x.snd) ∨ (x.fst, x.snd) ∈ t}
               = {p : completion α × completion α | ε ≤ dist p.1 p.2} ∪ t, by ext; simp,
        rw this,
        apply is_closed.union _ tclosed,
        exact is_closed_le continuous_const completion.uniform_continuous_dist.continuous },
      { assume x y,
        rw completion.dist_eq,
        by_cases h : ε ≤ dist x y,
        { exact or.inl h },
        { have Z := hε (not_le.1 h),
          simp only [set.mem_set_of_eq] at Z,
          exact or.inr Z }}},
    simp only [not_le.mpr hxy, false_or, not_le] at this,
    exact ts this },
  { /- Start from a set `s` containing an ε-neighborhood of the diagonal in `completion α`. To show
    that it is an entourage, we use the fact that `dist` is uniformly continuous on
    `completion α × completion α` (this is a general property of the extension of uniformly
    continuous functions). Therefore, the preimage of the ε-neighborhood of the diagonal in ℝ
    is an entourage in `completion α × completion α`. Massaging this property, it follows that
    the ε-neighborhood of the diagonal is an entourage in `completion α`, and therefore this is
    also the case of `s`. -/
    rintros ⟨ε, εpos, hε⟩,
    let r : set (ℝ × ℝ) := {p | dist p.1 p.2 < ε},
    have : r ∈ uniformity ℝ := metric.dist_mem_uniformity εpos,
    have T := uniform_continuous_def.1 (@completion.uniform_continuous_dist α _) r this,
    simp only [uniformity_prod_eq_prod, mem_prod_iff, exists_prop,
               filter.mem_map, set.mem_set_of_eq] at T,
    rcases T with ⟨t1, ht1, t2, ht2, ht⟩,
    refine mem_of_superset ht1 _,
    have A : ∀a b : completion α, (a, b) ∈ t1 → dist a b < ε,
    { assume a b hab,
      have : ((a, b), (a, a)) ∈ t1 ×ˢ t2 := ⟨hab, refl_mem_uniformity ht2⟩,
      have I := ht this,
      simp [completion.dist_self, real.dist_eq, completion.dist_comm] at I,
      exact lt_of_le_of_lt (le_abs_self _) I },
    show t1 ⊆ s,
    { rintros ⟨a, b⟩ hp,
      have : dist a b < ε := A a b hp,
      exact hε this }}
end

/-- If two points are at distance 0, then they coincide. -/
protected lemma eq_of_dist_eq_zero (x y : completion α) (h : dist x y = 0) : x = y :=
begin
  /- This follows from the separation of `completion α` and from the description of
  entourages in terms of the distance. -/
  have : separated_space (completion α) := by apply_instance,
  refine separated_def.1 this x y (λs hs, _),
  rcases (completion.mem_uniformity_dist s).1 hs with ⟨ε, εpos, hε⟩,
  rw ← h at εpos,
  exact hε εpos
end

/-- Reformulate `completion.mem_uniformity_dist` in terms that are suitable for the definition
of the metric space structure. -/
protected lemma uniformity_dist' :
  𝓤 (completion α) = (⨅ε:{ε : ℝ // 0 < ε}, 𝓟 {p | dist p.1 p.2 < ε.val}) :=
begin
  ext s, rw mem_infi_of_directed,
  { simp [completion.mem_uniformity_dist, subset_def] },
  { rintro ⟨r, hr⟩ ⟨p, hp⟩, use ⟨min r p, lt_min hr hp⟩,
    simp [lt_min_iff, (≥)] {contextual := tt} }
end

protected lemma uniformity_dist :
  𝓤 (completion α) = (⨅ ε>0, 𝓟 {p | dist p.1 p.2 < ε}) :=
by simpa [infi_subtype] using @completion.uniformity_dist' α _

/-- Metric space structure on the completion of a pseudo_metric space. -/
instance : metric_space (completion α) :=
{ dist_self          := completion.dist_self,
  eq_of_dist_eq_zero := completion.eq_of_dist_eq_zero,
  dist_comm          := completion.dist_comm,
  dist_triangle      := completion.dist_triangle,
  dist               := dist,
  to_uniform_space   := by apply_instance,
  uniformity_dist    := completion.uniformity_dist }

/-- The embedding of a metric space in its completion is an isometry. -/
lemma coe_isometry : isometry (coe : α → completion α) :=
isometry.of_dist_eq completion.dist_eq

@[simp] protected lemma edist_eq (x y : α) : edist (x : completion α) y = edist x y :=
coe_isometry x y

end uniform_space.completion


/-
Copyright (c) 2021 Alex Kontorovich and Heather Macbeth and Marc Masdeu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth, Marc Masdeu
-/

import linear_algebra.special_linear_group
import analysis.complex.basic
import group_theory.group_action.defs

/-!
# The upper half plane and its automorphisms

This file defines `upper_half_plane` to be the upper half plane in `ℂ`.

We furthermore equip it with the structure of an `SL(2,ℝ)` action by
fractional linear transformations.

We define the notation `ℍ` for the upper half plane available in the locale
`upper_half_plane` so as not to conflict with the quaternions.
-/

noncomputable theory

open matrix matrix.special_linear_group

open_locale classical big_operators matrix_groups

local attribute [instance] fintype.card_fin_even

/- Disable this instances as it is not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
local attribute [-instance] matrix.special_linear_group.has_coe_to_fun

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _

/-- The open upper half plane -/
@[derive [topological_space, λ α, has_coe α ℂ]]
def upper_half_plane := {point : ℂ // 0 < point.im}

localized "notation `ℍ` := upper_half_plane" in upper_half_plane

namespace upper_half_plane

instance : inhabited ℍ := ⟨⟨complex.I, by simp⟩⟩

/-- Imaginary part -/
def im (z : ℍ) := (z : ℂ).im

/-- Real part -/
def re (z : ℍ) := (z : ℂ).re

@[simp] lemma coe_im (z : ℍ) : (z : ℂ).im = z.im := rfl

@[simp] lemma coe_re (z : ℍ) : (z : ℂ).re = z.re := rfl

lemma im_pos (z : ℍ) : 0 < z.im := z.2

lemma im_ne_zero (z : ℍ) : z.im ≠ 0 := z.im_pos.ne'

lemma ne_zero (z : ℍ) : (z : ℂ) ≠ 0 :=
mt (congr_arg complex.im) z.im_ne_zero

lemma norm_sq_pos (z : ℍ) : 0 < complex.norm_sq (z : ℂ) :=
by { rw complex.norm_sq_pos, exact z.ne_zero }

lemma norm_sq_ne_zero (z : ℍ) : complex.norm_sq (z : ℂ) ≠ 0 := (norm_sq_pos z).ne'

/-- Numerator of the formula for a fractional linear transformation -/
@[simp] def num (g : SL(2, ℝ)) (z : ℍ) : ℂ := (↑ₘg 0 0 : ℝ) * z + (↑ₘg 0 1 : ℝ)

/-- Denominator of the formula for a fractional linear transformation -/
@[simp] def denom (g : SL(2, ℝ)) (z : ℍ) : ℂ := (↑ₘg 1 0 : ℝ) * z + (↑ₘg 1 1 : ℝ)

lemma linear_ne_zero (cd : fin 2 → ℝ) (z : ℍ) (h : cd ≠ 0) : (cd 0 : ℂ) * z + cd 1 ≠ 0 :=
begin
  contrapose! h,
  have : cd 0 = 0, -- we will need this twice
  { apply_fun complex.im at h,
    simpa only [z.im_ne_zero, complex.add_im, add_zero, coe_im, zero_mul, or_false,
      complex.of_real_im, complex.zero_im, complex.mul_im, mul_eq_zero] using h, },
  simp only [this, zero_mul, complex.of_real_zero, zero_add, complex.of_real_eq_zero] at h,
  ext i,
  fin_cases i; assumption,
end

lemma denom_ne_zero (g : SL(2, ℝ)) (z : ℍ) : denom g z ≠ 0 :=
linear_ne_zero (↑ₘg 1) z (g.row_ne_zero 1)

lemma norm_sq_denom_pos (g : SL(2, ℝ)) (z : ℍ) : 0 < complex.norm_sq (denom g z) :=
complex.norm_sq_pos.mpr (denom_ne_zero g z)

lemma norm_sq_denom_ne_zero (g : SL(2, ℝ)) (z : ℍ) : complex.norm_sq (denom g z) ≠ 0 :=
ne_of_gt (norm_sq_denom_pos g z)

/-- Fractional linear transformation -/
def smul_aux' (g : SL(2, ℝ)) (z : ℍ) : ℂ := num g z / denom g z

lemma smul_aux'_im (g : SL(2, ℝ)) (z : ℍ) :
  (smul_aux' g z).im = z.im / (denom g z).norm_sq :=
begin
  rw [smul_aux', complex.div_im],
  set NsqBot := (denom g z).norm_sq,
  have : NsqBot ≠ 0,
  { simp only [denom_ne_zero g z, monoid_with_zero_hom.map_eq_zero, ne.def, not_false_iff], },
  field_simp [smul_aux'],
  convert congr_arg (λ x, x * z.im * NsqBot ^ 2) g.det_coe using 1,
  { rw det_fin_two ↑g,
    ring },
  { ring }
end

/-- Fractional linear transformation -/
def smul_aux (g : SL(2,ℝ)) (z : ℍ) : ℍ :=
⟨smul_aux' g z,
by { rw smul_aux'_im, exact div_pos z.im_pos (complex.norm_sq_pos.mpr (denom_ne_zero g z)) }⟩

lemma denom_cocycle (x y : SL(2,ℝ)) (z : ℍ) :
  denom (x * y) z = denom x (smul_aux y z) * denom y z :=
begin
  change _ = (_ * (_ / _) + _) * _,
  field_simp [denom_ne_zero, -denom, -num],
  simp [matrix.mul, dot_product, fin.sum_univ_succ],
  ring
end

lemma mul_smul' (x y : SL(2, ℝ)) (z : ℍ) :
  smul_aux (x * y) z = smul_aux x (smul_aux y z) :=
begin
  ext1,
  change _ / _ = (_ * (_ / _) + _)  * _,
  rw denom_cocycle,
  field_simp [denom_ne_zero, -denom, -num],
  simp [matrix.mul, dot_product, fin.sum_univ_succ],
  ring
end

/-- The action of `SL(2, ℝ)` on the upper half-plane by fractional linear transformations. -/
instance : mul_action SL(2, ℝ) ℍ :=
{ smul := smul_aux,
  one_smul := λ z, by { ext1, change _ / _ = _, simp },
  mul_smul := mul_smul' }

@[simp] lemma coe_smul (g : SL(2, ℝ)) (z : ℍ) : ↑(g • z) = num g z / denom g z := rfl
@[simp] lemma re_smul (g : SL(2, ℝ)) (z : ℍ) : (g • z).re = (num g z / denom g z).re := rfl

lemma im_smul (g : SL(2, ℝ)) (z : ℍ) : (g • z).im = (num g z / denom g z).im := rfl

lemma im_smul_eq_div_norm_sq (g : SL(2, ℝ)) (z : ℍ) :
  (g • z).im = z.im / (complex.norm_sq (denom g z)) :=
smul_aux'_im g z

@[simp] lemma neg_smul (g : SL(2,ℝ)) (z : ℍ) : -g • z = g • z :=
begin
  ext1,
  change _ / _ = _ / _,
  field_simp [denom_ne_zero, -denom, -num],
  simp,
  ring,
end

end upper_half_plane


/-
Copyright (c) 2021 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 topology.metric_space.basic
import measure_theory.constructions.borel_space
import measure_theory.covering.vitali_family

/-!
# Vitali covering theorems

The topological Vitali covering theorem, in its most classical version, states the following.
Consider a family of balls `(B (x_i, r_i))_{i ∈ I}` in a metric space, with uniformly bounded
radii. Then one can extract a disjoint subfamily indexed by `J ⊆ I`, such that any `B (x_i, r_i)`
is included in a ball `B (x_j, 5 r_j)`.

We prove this theorem in `vitali.exists_disjoint_subfamily_covering_enlargment_closed_ball`.
It is deduced from a more general version, called
`vitali.exists_disjoint_subfamily_covering_enlargment`, which applies to any family of sets
together with a size function `δ` (think "radius" or "diameter").

We deduce the measurable Vitali covering theorem. Assume one is given a family `t` of closed sets
with nonempty interior, such that each `a ∈ t` is included in a ball `B (x, r)` and covers a
definite proportion of the ball `B (x, 6 r)` for a given measure `μ` (think of the situation
where `μ` is a doubling measure and `t` is a family of balls). Consider a set `s` at which the
family is fine, i.e., every point of `s` belongs to arbitrarily small elements of `t`. Then one
can extract from `t` a disjoint subfamily that covers almost all `s`. It is proved in
`vitali.exists_disjoint_covering_ae`.

A way to restate this theorem is to say that the set of closed sets `a` with nonempty interior
covering a fixed proportion `1/C` of the ball `closed_ball x (3 * diam a)` forms a Vitali family.
This version is given in `vitali.vitali_family`.
-/

variables {α ι : Type*}

open set metric measure_theory topological_space filter
open_locale nnreal classical ennreal topology

namespace vitali

/-- Vitali covering theorem: given a set `t` of subsets of a type, one may extract a disjoint
subfamily `u` such that the `τ`-enlargment of this family covers all elements of `t`, where `τ > 1`
is any fixed number.

When `t` is a family of balls, the `τ`-enlargment of `ball x r` is `ball x ((1+2τ) r)`. In general,
it is expressed in terms of a function `δ` (think "radius" or "diameter"), positive and bounded on
all elements of `t`. The condition is that every element `a` of `t` should intersect an
element `b` of `u` of size larger than that of `a` up to `τ`, i.e., `δ b ≥ δ a / τ`.

We state the lemma slightly more generally, with an indexed family of sets `B a` for `a ∈ t`, for
wider applicability.
-/
theorem exists_disjoint_subfamily_covering_enlargment
  (B : ι → set α) (t : set ι) (δ : ι → ℝ) (τ : ℝ) (hτ : 1 < τ) (δnonneg : ∀ a ∈ t, 0 ≤ δ a)
  (R : ℝ) (δle : ∀ a ∈ t, δ a ≤ R) (hne : ∀ a ∈ t, (B a).nonempty) :
  ∃ u ⊆ t, u.pairwise_disjoint B ∧
    ∀ a ∈ t, ∃ b ∈ u, (B a ∩ B b).nonempty ∧ δ a ≤ τ * δ b :=
begin
  /- The proof could be formulated as a transfinite induction. First pick an element of `t` with `δ`
  as large as possible (up to a factor of `τ`). Then among the remaining elements not intersecting
  the already chosen one, pick another element with large `δ`. Go on forever (transfinitely) until
  there is nothing left.

  Instead, we give a direct Zorn-based argument. Consider a maximal family `u` of disjoint sets
  with the following property: if an element `a` of `t` intersects some element `b` of `u`, then it
  intersects some `b' ∈ u` with `δ b' ≥ δ a / τ`. Such a maximal family exists by Zorn. If this
  family did not intersect some element `a ∈ t`, then take an element `a' ∈ t` which does not
  intersect any element of `u`, with `δ a'` almost as large as possible. One checks easily
  that `u ∪ {a'}` still has this property, contradicting the maximality. Therefore, `u`
  intersects all elements of `t`, and by definition it satisfies all the desired properties.
  -/
  let T : set (set ι) := {u | u ⊆ t ∧ u.pairwise_disjoint B
    ∧ ∀ a ∈ t, ∀ b ∈ u, (B a ∩ B b).nonempty → ∃ c ∈ u, (B a ∩ B c).nonempty ∧ δ a ≤ τ * δ c},
  -- By Zorn, choose a maximal family in the good set `T` of disjoint families.
  obtain ⟨u, uT, hu⟩ : ∃ u ∈ T, ∀ v ∈ T, u ⊆ v → v = u,
  { refine zorn_subset _ (λ U UT hU, _),
    refine ⟨⋃₀ U, _, λ s hs, subset_sUnion_of_mem hs⟩,
    simp only [set.sUnion_subset_iff, and_imp, exists_prop, forall_exists_index, mem_sUnion,
                set.mem_set_of_eq],
    refine ⟨λ u hu, (UT hu).1, (pairwise_disjoint_sUnion hU.directed_on).2 (λ u hu, (UT hu).2.1),
      λ a hat b u uU hbu hab, _⟩,
    obtain ⟨c, cu, ac, hc⟩ : ∃ (c : ι) (H : c ∈ u), (B a ∩ B c).nonempty ∧ δ a ≤ τ * δ c :=
      (UT uU).2.2 a hat b hbu hab,
    exact ⟨c, ⟨u, uU, cu⟩, ac, hc⟩ },
  -- the only nontrivial bit is to check that every `a ∈ t` intersects an element `b ∈ u` with
  -- comparatively large `δ b`. Assume this is not the case, then we will contradict the maximality.
  refine ⟨u, uT.1, uT.2.1, λ a hat, _⟩,
  contrapose! hu,
  have a_disj : ∀ c ∈ u, disjoint (B a) (B c),
  { assume c hc,
    by_contra,
    rw not_disjoint_iff_nonempty_inter at h,
    obtain ⟨d, du, ad, hd⟩ : ∃ (d : ι) (H : d ∈ u), (B a ∩ B d).nonempty ∧ δ a ≤ τ * δ d :=
      uT.2.2 a hat c hc h,
    exact lt_irrefl _ ((hu d du ad).trans_le hd) },
  -- Let `A` be all the elements of `t` which do not intersect the family `u`. It is nonempty as it
  -- contains `a`. We will pick an element `a'` of `A` with `δ a'` almost as large as possible.
  let A := {a' | a' ∈ t ∧ ∀ c ∈ u, disjoint (B a') (B c)},
  have Anonempty : A.nonempty := ⟨a, hat, a_disj⟩,
  let m := Sup (δ '' A),
  have bddA : bdd_above (δ '' A),
  { refine ⟨R, λ x xA, _⟩,
    rcases (mem_image _ _ _).1 xA with ⟨a', ha', rfl⟩,
    exact δle a' ha'.1 },
  obtain ⟨a', a'A, ha'⟩ : ∃ a' ∈ A, m / τ ≤ δ a',
  { have : 0 ≤ m := (δnonneg a hat).trans (le_cSup bddA (mem_image_of_mem _ ⟨hat, a_disj⟩)),
    rcases eq_or_lt_of_le this with mzero|mpos,
    { refine ⟨a, ⟨hat, a_disj⟩, _⟩,
      simpa only [← mzero, zero_div] using δnonneg a hat },
    { have I : m / τ < m,
      { rw div_lt_iff (zero_lt_one.trans hτ),
        conv_lhs { rw ← mul_one m },
        exact (mul_lt_mul_left mpos).2 hτ },
      rcases exists_lt_of_lt_cSup (nonempty_image_iff.2 Anonempty) I with ⟨x, xA, hx⟩,
      rcases (mem_image _ _ _).1 xA with ⟨a', ha', rfl⟩,
      exact ⟨a', ha', hx.le⟩, } },
  clear hat hu a_disj a,
  have a'_ne_u : a' ∉ u := λ H, (hne _ a'A.1).ne_empty (disjoint_self.1 (a'A.2 _ H)),
  -- we claim that `u ∪ {a'}` still belongs to `T`, contradicting the maximality of `u`.
  refine ⟨insert a' u, ⟨_, _, _⟩, subset_insert _ _, (ne_insert_of_not_mem _ a'_ne_u).symm⟩,
  -- check that `u ∪ {a'}` is made of elements of `t`.
  { rw insert_subset,
    exact ⟨a'A.1, uT.1⟩ },
  -- check that `u ∪ {a'}` is a disjoint family. This follows from the fact that `a'` does not
  -- intersect `u`.
  { exact uT.2.1.insert (λ b bu ba', a'A.2 b bu) },
  -- check that every element `c` of `t` intersecting `u ∪ {a'}` intersects an element of this
  -- family with large `δ`.
  { assume c ct b ba'u hcb,
    -- if `c` already intersects an element of `u`, then it intersects an element of `u` with
    -- large `δ` by the assumption on `u`, and there is nothing left to do.
    by_cases H : ∃ d ∈ u, (B c ∩ B d).nonempty,
    { rcases H with ⟨d, du, hd⟩,
      rcases uT.2.2 c ct d du hd with ⟨d', d'u, hd'⟩,
      exact ⟨d', mem_insert_of_mem _ d'u, hd'⟩ },
    -- otherwise, `c` belongs to `A`. The element of `u ∪ {a'}` that it intersects has to be `a'`.
    -- moreover, `δ c` is smaller than the maximum `m` of `δ` over `A`, which is `≤ δ a' / τ`
    -- thanks to the good choice of `a'`. This is the desired inequality.
    { push_neg at H,
      simp only [← not_disjoint_iff_nonempty_inter, not_not] at H,
      rcases mem_insert_iff.1 ba'u with rfl|H',
      { refine ⟨b, mem_insert _ _, hcb, _⟩,
        calc δ c ≤ m : le_cSup bddA (mem_image_of_mem _ ⟨ct, H⟩)
        ... = τ * (m / τ) : by { field_simp [(zero_lt_one.trans hτ).ne'], ring }
        ... ≤ τ * δ b : mul_le_mul_of_nonneg_left ha' (zero_le_one.trans hτ.le) },
      { rw ← not_disjoint_iff_nonempty_inter at hcb,
        exact (hcb (H _ H')).elim } } }
end

/-- Vitali covering theorem, closed balls version: given a family `t` of closed balls, one can
extract a disjoint subfamily `u ⊆ t` so that all balls in `t` are covered by the 5-times
dilations of balls in `u`. -/
theorem exists_disjoint_subfamily_covering_enlargment_closed_ball [metric_space α]
  (t : set ι) (x : ι → α) (r : ι → ℝ) (R : ℝ) (hr : ∀ a ∈ t, r a ≤ R) :
  ∃ u ⊆ t, u.pairwise_disjoint (λ a, closed_ball (x a) (r a)) ∧
    ∀ a ∈ t, ∃ b ∈ u, closed_ball (x a) (r a) ⊆ closed_ball (x b) (5 * r b) :=
begin
  rcases eq_empty_or_nonempty t with rfl|tnonempty,
  { exact ⟨∅, subset.refl _, pairwise_disjoint_empty, by simp⟩ },
  by_cases ht : ∀ a ∈ t, r a < 0,
  { exact ⟨t, subset.rfl, λ a ha b hb hab,
      by simp only [function.on_fun, closed_ball_eq_empty.2 (ht a ha), empty_disjoint],
      λ a ha, ⟨a, ha, by simp only [closed_ball_eq_empty.2 (ht a ha), empty_subset]⟩⟩ },
  push_neg at ht,
  let t' := {a ∈ t | 0 ≤ r a},
  rcases exists_disjoint_subfamily_covering_enlargment (λ a, closed_ball (x a) (r a)) t' r
    2 one_lt_two (λ a ha, ha.2) R (λ a ha, hr a ha.1) (λ a ha, ⟨x a, mem_closed_ball_self ha.2⟩)
    with ⟨u, ut', u_disj, hu⟩,
  have A : ∀ a ∈ t', ∃ b ∈ u, closed_ball (x a) (r a) ⊆ closed_ball (x b) (5 * r b),
  { assume a ha,
    rcases hu a ha with ⟨b, bu, hb, rb⟩,
    refine ⟨b, bu, _⟩,
    have : dist (x a) (x b) ≤ r a + r b :=
      dist_le_add_of_nonempty_closed_ball_inter_closed_ball hb,
    apply closed_ball_subset_closed_ball',
    linarith },
  refine ⟨u, ut'.trans (λ a ha, ha.1), u_disj, λ a ha, _⟩,
  rcases le_or_lt 0 (r a) with h'a|h'a,
  { exact A a ⟨ha, h'a⟩ },
  { rcases ht with ⟨b, rb⟩,
    rcases A b ⟨rb.1, rb.2⟩ with ⟨c, cu, hc⟩,
    refine ⟨c, cu, by simp only [closed_ball_eq_empty.2 h'a, empty_subset]⟩ },
end

/-- The measurable Vitali covering theorem. Assume one is given a family `t` of closed sets with
nonempty interior, such that each `a ∈ t` is included in a ball `B (x, r)` and covers a definite
proportion of the ball `B (x, 3 r)` for a given measure `μ` (think of the situation where `μ` is
a doubling measure and `t` is a family of balls). Consider a (possibly non-measurable) set `s`
at which the family is fine, i.e., every point of `s` belongs to arbitrarily small elements of `t`.
Then one can extract from `t` a disjoint subfamily that covers almost all `s`.

For more flexibility, we give a statement with a parameterized family of sets.
-/
theorem exists_disjoint_covering_ae [metric_space α] [measurable_space α] [opens_measurable_space α]
  [second_countable_topology α]
  (μ : measure α) [is_locally_finite_measure μ] (s : set α)
  (t : set ι) (C : ℝ≥0) (r : ι → ℝ) (c : ι → α) (B : ι → set α)
  (hB : ∀ a ∈ t, B a ⊆ closed_ball (c a) (r a))
  (μB : ∀ a ∈ t, μ (closed_ball (c a) (3 * r a)) ≤ C * μ (B a))
  (ht : ∀ a ∈ t, (interior (B a)).nonempty) (h't : ∀ a ∈ t, is_closed (B a))
  (hf : ∀ x ∈ s, ∀ (ε > (0 : ℝ)), ∃ a ∈ t, r a ≤ ε ∧ c a = x) :
  ∃ u ⊆ t, u.countable ∧ u.pairwise_disjoint B ∧ μ (s \ ⋃ a ∈ u, B a) = 0 :=
begin
  /- The idea of the proof is the following. Assume for simplicity that `μ` is finite. Applying the
  abstract Vitali covering theorem with `δ = r` given by `hf`, one obtains a disjoint subfamily `u`,
  such that any element of `t` intersects an element of `u` with comparable radius. Fix `ε > 0`.
  Since the elements of `u` have summable measure, one can remove finitely elements `w_1, ..., w_n`.
  so that the measure of the remaining elements is `< ε`. Consider now a point `z` not
  in the `w_i`. There is a small ball around `z` not intersecting the `w_i` (as they are closed),
  an element `a ∈ t` contained in this small ball (as the family `t` is fine at `z`) and an element
  `b ∈ u` intersecting `a`, with comparable radius (by definition of `u`). Then `z` belongs to the
  enlargement of `b`. This shows that `s \ (w_1 ∪ ... ∪ w_n)` is contained in
  `⋃ (b ∈ u \ {w_1, ... w_n}) (enlargement of b)`. The measure of the latter set is bounded by
  `∑ (b ∈ u \ {w_1, ... w_n}) C * μ b` (by the doubling property of the measure), which is at most
  `C ε`. Letting `ε` tend to `0` shows that `s` is almost everywhere covered by the family `u`.

  For the real argument, the measure is only locally finite. Therefore, we implement the same
  strategy, but locally restricted to balls on which the measure is finite. For this, we do not
  use the whole family `t`, but a subfamily `t'` supported on small balls (which is possible since
  the family is assumed to be fine at every point of `s`).
  -/
  -- choose around each `x` a small ball on which the measure is finite
  have : ∀ x, ∃ R, 0 < R ∧ R ≤ 1 ∧ μ (closed_ball x (20 * R)) < ∞,
  { assume x,
    obtain ⟨R, Rpos, μR⟩ : ∃ (R : ℝ) (hR : 0 < R), μ (closed_ball x R) < ∞ :=
      (μ.finite_at_nhds x).exists_mem_basis nhds_basis_closed_ball,
    refine ⟨min 1 (R/20), _, min_le_left _ _, _⟩,
    { simp only [true_and, lt_min_iff, zero_lt_one],
      linarith },
    { apply lt_of_le_of_lt (measure_mono _) μR,
      apply closed_ball_subset_closed_ball,
      calc 20 * min 1 (R / 20) ≤ 20 * (R/20) :
        mul_le_mul_of_nonneg_left (min_le_right _ _) (by norm_num)
      ... = R : by ring } },
  choose R hR0 hR1 hRμ,
  -- we restrict to a subfamily `t'` of `t`, made of elements small enough to ensure that
  -- they only see a finite part of the measure, and with a doubling property
  let t' := {a ∈ t | r a ≤ R (c a)},
  -- extract a disjoint subfamily `u` of `t'` thanks to the abstract Vitali covering theorem.
  obtain ⟨u, ut', u_disj, hu⟩ : ∃ u ⊆ t', u.pairwise_disjoint B ∧
    ∀ a ∈ t', ∃ b ∈ u, (B a ∩ B b).nonempty ∧ r a ≤ 2 * r b,
  { have A : ∀ a ∈ t', r a ≤ 1,
    { assume a ha,
      apply ha.2.trans (hR1 (c a)), },
    have A' : ∀ a ∈ t', (B a).nonempty :=
      λ a hat', set.nonempty.mono interior_subset (ht a hat'.1),
    refine exists_disjoint_subfamily_covering_enlargment B t' r 2 one_lt_two
      (λ a ha, _) 1 A A',
    exact nonempty_closed_ball.1 ((A' a ha).mono (hB a ha.1)) },
  have ut : u ⊆ t := λ a hau, (ut' hau).1,
  -- As the space is second countable, the family is countable since all its sets have nonempty
  -- interior.
  have u_count : u.countable := u_disj.countable_of_nonempty_interior (λ a ha, ht a (ut ha)),
  -- the family `u` will be the desired family
  refine ⟨u, λ a hat', (ut' hat').1, u_count, u_disj, _⟩,
  -- it suffices to show that it covers almost all `s` locally around each point `x`.
  refine null_of_locally_null _ (λ x hx, _),
  -- let `v` be the subfamily of `u` made of those sets intersecting the small ball `ball x (r x)`
  let v := {a ∈ u | (B a ∩ ball x (R x)).nonempty },
  have vu : v ⊆ u := λ a ha, ha.1,
  -- they are all contained in a fixed ball of finite measure, thanks to our choice of `t'`
  obtain ⟨K, μK, hK⟩ : ∃ K, μ (closed_ball x K) < ∞ ∧
                          ∀ a ∈ u, (B a ∩ ball x (R x)).nonempty → B a ⊆ closed_ball x K,
  { have Idist_v : ∀ a ∈ v, dist (c a) x ≤ r a + R x,
    { assume a hav,
      apply dist_le_add_of_nonempty_closed_ball_inter_closed_ball,
      refine hav.2.mono _,
      apply inter_subset_inter _ ball_subset_closed_ball,
      exact hB a (ut (vu hav)) },
    set R0 := Sup (r '' v) with R0_def,
    have R0_bdd : bdd_above (r '' v),
    { refine ⟨1, λ r' hr', _⟩,
      rcases (mem_image _ _ _).1 hr' with ⟨b, hb, rfl⟩,
      exact le_trans (ut' (vu hb)).2 (hR1 (c b)) },
    rcases le_total R0 (R x) with H|H,
    { refine ⟨20 * R x, hRμ x, λ a au hax, _⟩,
      refine (hB a (ut au)).trans _,
      apply closed_ball_subset_closed_ball',
      have : r a ≤ R0 := le_cSup R0_bdd (mem_image_of_mem _ ⟨au, hax⟩),
      linarith [Idist_v a ⟨au, hax⟩, hR0 x] },
    { have R0pos : 0 < R0 := (hR0 x).trans_le H,
      have vnonempty : v.nonempty,
      { by_contra,
        rw [nonempty_iff_ne_empty, not_not] at h,
        simp only [h, real.Sup_empty, image_empty] at R0_def,
        exact lt_irrefl _ (R0pos.trans_le (le_of_eq R0_def)) },
      obtain ⟨a, hav, R0a⟩ : ∃ a ∈ v, R0/2 < r a,
      { obtain ⟨r', r'mem, hr'⟩ : ∃ r' ∈ r '' v, R0 / 2 < r' :=
          exists_lt_of_lt_cSup (nonempty_image_iff.2 vnonempty) (half_lt_self R0pos),
        rcases (mem_image _ _ _).1 r'mem with ⟨a, hav, rfl⟩,
        exact ⟨a, hav, hr'⟩ },
      refine ⟨8 * R0, _, _⟩,
      { apply lt_of_le_of_lt (measure_mono _) (hRμ (c a)),
        apply closed_ball_subset_closed_ball',
        rw dist_comm,
        linarith [Idist_v a hav, (ut' (vu hav)).2] },
      { assume b bu hbx,
        refine (hB b (ut bu)).trans _,
        apply closed_ball_subset_closed_ball',
        have : r b ≤ R0 := le_cSup R0_bdd (mem_image_of_mem _ ⟨bu, hbx⟩),
        linarith [Idist_v b ⟨bu, hbx⟩] } } },
  -- we will show that, in `ball x (R x)`, almost all `s` is covered by the family `u`.
  refine ⟨_ ∩ ball x (R x), inter_mem_nhds_within _ (ball_mem_nhds _ (hR0 _)),
    nonpos_iff_eq_zero.mp (le_of_forall_le_of_dense (λ ε εpos, _))⟩,
  -- the elements of `v` are disjoint and all contained in a finite volume ball, hence the sum
  -- of their measures is finite.
  have I : ∑' (a : v), μ (B a) < ∞,
  { calc ∑' (a : v), μ (B a) = μ (⋃ (a ∈ v), B a) : begin
      rw measure_bUnion (u_count.mono vu) _ (λ a ha, (h't _ (vu.trans ut ha)).measurable_set),
      exact u_disj.subset vu
    end
    ... ≤ μ (closed_ball x K) : measure_mono (Union₂_subset (λ a ha, hK a (vu ha) ha.2))
    ... < ∞ : μK },
  -- we can obtain a finite subfamily of `v`, such that the measures of the remaining elements
  -- add up to an arbitrarily small number, say `ε / C`.
  obtain ⟨w, hw⟩ : ∃ (w : finset ↥v), ∑' (a : {a // a ∉ w}), μ (B a) < ε / C,
  { have : 0 < ε / C, by simp only [ennreal.div_pos_iff, εpos.ne', ennreal.coe_ne_top, ne.def,
                                    not_false_iff, and_self],
    exact ((tendsto_order.1 (ennreal.tendsto_tsum_compl_at_top_zero I.ne)).2 _ this).exists },
  -- main property: the points `z` of `s` which are not covered by `u` are contained in the
  -- enlargements of the elements not in `w`.
  have M : (s \ ⋃ a ∈ u, B a) ∩ ball x (R x)
    ⊆ ⋃ (a : {a // a ∉ w}), closed_ball (c a) (3 * r a),
  { assume z hz,
    set k := ⋃ (a : v) (ha : a ∈ w), B a with hk,
    have k_closed : is_closed k :=
      is_closed_bUnion w.finite_to_set (λ i hi, h't _ (ut (vu i.2))),
    have z_notmem_k : z ∉ k,
    { simp only [not_exists, exists_prop, mem_Union, mem_sep_iff, forall_exists_index,
        set_coe.exists, not_and, exists_and_distrib_right, subtype.coe_mk],
      assume b hbv h'b h'z,
      have : z ∈ (s \ ⋃ a ∈ u, B a) ∩ (⋃ a ∈ u, B a) :=
        mem_inter (mem_of_mem_inter_left hz) (mem_bUnion (vu hbv) h'z),
      simpa only [diff_inter_self] },
    -- since the elements of `w` are closed and finitely many, one can find a small ball around `z`
    -- not intersecting them
    have : ball x (R x) \ k ∈ 𝓝 z,
    { apply is_open.mem_nhds (is_open_ball.sdiff k_closed) _,
      exact (mem_diff _).2 ⟨mem_of_mem_inter_right hz, z_notmem_k⟩ },
    obtain ⟨d, dpos, hd⟩ : ∃ (d : ℝ) (dpos : 0 < d), closed_ball z d ⊆ ball x (R x) \ k :=
      nhds_basis_closed_ball.mem_iff.1 this,
    -- choose an element `a` of the family `t` contained in this small ball
    obtain ⟨a, hat, ad, rfl⟩ : ∃ a ∈ t, r a ≤ min d (R z) ∧ c a = z,
      from hf z ((mem_diff _).1 (mem_of_mem_inter_left hz)).1 (min d (R z)) (lt_min dpos (hR0 z)),
    have ax : B a ⊆ ball x (R x),
    { refine (hB a hat).trans _,
      refine subset.trans _ (hd.trans (diff_subset (ball x (R x)) k)),
      exact closed_ball_subset_closed_ball (ad.trans (min_le_left _ _)), },
    -- it intersects an element `b` of `u` with comparable diameter, by definition of `u`
    obtain ⟨b, bu, ab, bdiam⟩ : ∃ b ∈ u, (B a ∩ B b).nonempty ∧ r a ≤ 2 * r b,
      from hu a ⟨hat, ad.trans (min_le_right _ _)⟩,
    have bv : b ∈ v,
    { refine ⟨bu, ab.mono _⟩,
      rw inter_comm,
      exact inter_subset_inter_right _ ax },
    let b' : v := ⟨b, bv⟩,
    -- `b` can not belong to `w`, as the elements of `w` do not intersect `closed_ball z d`,
    -- contrary to `b`
    have b'_notmem_w : b' ∉ w,
    { assume b'w,
      have b'k : B b' ⊆ k, from @finset.subset_set_bUnion_of_mem _ _ _ (λ (y : v), B y) _ b'w,
      have : ((ball x (R x) \ k) ∩ k).nonempty,
      { apply ab.mono (inter_subset_inter _ b'k),
        refine ((hB _ hat).trans _).trans hd,
        exact (closed_ball_subset_closed_ball (ad.trans (min_le_left _ _))) },
      simpa only [diff_inter_self, not_nonempty_empty] },
    let b'' : {a // a ∉ w} := ⟨b', b'_notmem_w⟩,
    -- since `a` and `b` have comparable diameters, it follows that `z` belongs to the
    -- enlargement of `b`
    have zb : c a ∈ closed_ball (c b) (3 * r b),
    { rcases ab with ⟨e, ⟨ea, eb⟩⟩,
      have A : dist (c a) e ≤ r a, from mem_closed_ball'.1 (hB a hat ea),
      have B : dist e (c b) ≤ r b, from mem_closed_ball.1 (hB b (ut bu) eb),
      simp only [mem_closed_ball],
      linarith [dist_triangle (c a) e (c b)] },
    suffices H : closed_ball (c b'') (3 * r b'')
      ⊆ ⋃ (a : {a // a ∉ w}), closed_ball (c a) (3 * r a), from H zb,
    exact subset_Union (λ (a : {a // a ∉ w}), closed_ball (c a) (3 * r a)) b'' },
  -- now that we have proved our main inclusion, we can use it to estimate the measure of the points
  -- in `ball x (r x)` not covered by `u`.
  haveI : encodable v := (u_count.mono vu).to_encodable,
  calc μ ((s \ ⋃ a ∈ u, B a) ∩ ball x (R x))
      ≤ μ (⋃ (a : {a // a ∉ w}), closed_ball (c a) (3 * r a)) : measure_mono M
  ... ≤ ∑' (a : {a // a ∉ w}), μ (closed_ball (c a) (3 * r a)) :
    measure_Union_le _
  ... ≤ ∑' (a : {a // a ∉ w}), C * μ (B a) : ennreal.tsum_le_tsum (λ a, μB a (ut (vu a.1.2)))
  ... = C * ∑' (a : {a // a ∉ w}), μ (B a) : ennreal.tsum_mul_left
  ... ≤ C * (ε / C) : mul_le_mul_left' hw.le _
  ... ≤ ε : ennreal.mul_div_le
end

/-- Assume that around every point there are arbitrarily small scales at which the measure is
doubling. Then the set of closed sets `a` with nonempty interior contained in `closed_ball x r` and
covering a fixed proportion `1/C` of the ball `closed_ball x (3 * r)` forms a Vitali family.
This is essentially a restatement of the measurable Vitali theorem. -/
protected def vitali_family [metric_space α] [measurable_space α] [opens_measurable_space α]
  [second_countable_topology α] (μ : measure α) [is_locally_finite_measure μ] (C : ℝ≥0)
  (h : ∀ x, ∃ᶠ r in 𝓝[>] 0, μ (closed_ball x (3 * r)) ≤ C * μ (closed_ball x r)) :
  vitali_family μ :=
{ sets_at := λ x, {a | is_closed a ∧ (interior a).nonempty ∧ ∃ r, (a ⊆ closed_ball x r ∧
                      μ (closed_ball x (3 * r)) ≤ C * μ a)},
  measurable_set' := λ x a ha, ha.1.measurable_set,
  nonempty_interior := λ x a ha, ha.2.1,
  nontrivial := λ x ε εpos, begin
    obtain ⟨r, μr, rpos, rε⟩ : ∃ r,
      μ (closed_ball x (3 * r)) ≤ C * μ (closed_ball x r) ∧ r ∈ Ioc (0 : ℝ) ε :=
      ((h x).and_eventually (Ioc_mem_nhds_within_Ioi ⟨le_rfl, εpos⟩)).exists,
    refine ⟨closed_ball x r, ⟨is_closed_ball, _, ⟨r, subset.rfl, μr⟩⟩,
      closed_ball_subset_closed_ball rε⟩,
    exact (nonempty_ball.2 rpos).mono (ball_subset_interior_closed_ball)
  end,
  covering := begin
    assume s f fsubset ffine,
    let t : set (ℝ × α × set α) :=
      {p | p.2.2 ⊆ closed_ball p.2.1 p.1 ∧ μ (closed_ball p.2.1 (3 * p.1)) ≤ C * μ p.2.2
      ∧ (interior p.2.2).nonempty ∧ is_closed p.2.2 ∧ p.2.2 ∈ f p.2.1 ∧ p.2.1 ∈ s},
    have A : ∀ x ∈ s, ∀ (ε : ℝ), ε > 0 → (∃ (p : ℝ × α × set α) (Hp : p ∈ t), p.1 ≤ ε ∧ p.2.1 = x),
    { assume x xs ε εpos,
      rcases ffine x xs ε εpos with ⟨a, ha, h'a⟩,
      rcases fsubset x xs ha with ⟨a_closed, a_int, ⟨r, ar, μr⟩⟩,
      refine ⟨⟨min r ε, x, a⟩, ⟨_, _, a_int, a_closed, ha, xs⟩, min_le_right _ _, rfl⟩,
      { rcases min_cases r ε with h'|h'; rwa h'.1 },
      { apply le_trans (measure_mono (closed_ball_subset_closed_ball _)) μr,
        exact mul_le_mul_of_nonneg_left (min_le_left _ _) zero_le_three } },
    rcases exists_disjoint_covering_ae μ s t C (λ p, p.1) (λ p, p.2.1) (λ p, p.2.2) (λ p hp, hp.1)
      (λ p hp, hp.2.1) (λ p hp, hp.2.2.1) (λ p hp, hp.2.2.2.1) A
      with ⟨t', t't, t'_count, t'_disj, μt'⟩,
    refine ⟨(λ (p : ℝ × α × set α), p.2) '' t', _, _, _, _⟩,
    { rintros - ⟨q, hq, rfl⟩,
      exact (t't hq).2.2.2.2.2 },
    { rintros p ⟨q, hq, rfl⟩ p' ⟨q', hq', rfl⟩ hqq',
      exact t'_disj hq hq' (ne_of_apply_ne _ hqq') },
    { rintros - ⟨q, hq, rfl⟩,
      exact (t't hq).2.2.2.2.1 },
    { convert μt' using 3,
      rw bUnion_image }
  end }

end vitali


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

! This file was ported from Lean 3 source module field_theory.separable
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Squarefree
import Mathbin.Data.Polynomial.Expand
import Mathbin.Data.Polynomial.Splits
import Mathbin.FieldTheory.Minpoly.Field
import Mathbin.RingTheory.PowerBasis

/-!

# Separable polynomials

We define a polynomial to be separable if it is coprime with its derivative. We prove basic
properties about separable polynomials here.

## Main definitions

* `polynomial.separable f`: a polynomial `f` is separable iff it is coprime with its derivative.

-/

universe u v w

open Classical BigOperators Polynomial

open Finset

namespace Polynomial

section CommSemiring

variable {R : Type u} [CommSemiring R] {S : Type v} [CommSemiring S]

/-- A polynomial is separable iff it is coprime with its derivative. -/
def Separable (f : R[X]) : Prop :=
  IsCoprime f f.derivative
#align polynomial.separable Polynomial.Separable

theorem separable_def (f : R[X]) : f.Separable ↔ IsCoprime f f.derivative :=
  Iff.rfl
#align polynomial.separable_def Polynomial.separable_def

theorem separable_def' (f : R[X]) : f.Separable ↔ ∃ a b : R[X], a * f + b * f.derivative = 1 :=
  Iff.rfl
#align polynomial.separable_def' Polynomial.separable_def'

theorem not_separable_zero [Nontrivial R] : ¬Separable (0 : R[X]) :=
  by
  rintro ⟨x, y, h⟩
  simpa only [derivative_zero, MulZeroClass.mul_zero, add_zero, zero_ne_one] using h
#align polynomial.not_separable_zero Polynomial.not_separable_zero

theorem separable_one : (1 : R[X]).Separable :=
  isCoprime_one_left
#align polynomial.separable_one Polynomial.separable_one

@[nontriviality]
theorem separable_of_subsingleton [Subsingleton R] (f : R[X]) : f.Separable := by simp [separable]
#align polynomial.separable_of_subsingleton Polynomial.separable_of_subsingleton

theorem separable_x_add_c (a : R) : (X + C a).Separable :=
  by
  rw [separable_def, derivative_add, derivative_X, derivative_C, add_zero]
  exact isCoprime_one_right
#align polynomial.separable_X_add_C Polynomial.separable_x_add_c

theorem separable_x : (X : R[X]).Separable :=
  by
  rw [separable_def, derivative_X]
  exact isCoprime_one_right
#align polynomial.separable_X Polynomial.separable_x

theorem separable_c (r : R) : (C r).Separable ↔ IsUnit r := by
  rw [separable_def, derivative_C, isCoprime_zero_right, is_unit_C]
#align polynomial.separable_C Polynomial.separable_c

theorem Separable.of_mul_left {f g : R[X]} (h : (f * g).Separable) : f.Separable :=
  by
  have := h.of_mul_left_left; rw [derivative_mul] at this
  exact IsCoprime.of_mul_right_left (IsCoprime.of_add_mul_left_right this)
#align polynomial.separable.of_mul_left Polynomial.Separable.of_mul_left

theorem Separable.of_mul_right {f g : R[X]} (h : (f * g).Separable) : g.Separable :=
  by
  rw [mul_comm] at h
  exact h.of_mul_left
#align polynomial.separable.of_mul_right Polynomial.Separable.of_mul_right

theorem Separable.of_dvd {f g : R[X]} (hf : f.Separable) (hfg : g ∣ f) : g.Separable :=
  by
  rcases hfg with ⟨f', rfl⟩
  exact separable.of_mul_left hf
#align polynomial.separable.of_dvd Polynomial.Separable.of_dvd

theorem separable_gcd_left {F : Type _} [Field F] {f : F[X]} (hf : f.Separable) (g : F[X]) :
    (EuclideanDomain.gcd f g).Separable :=
  Separable.of_dvd hf (EuclideanDomain.gcd_dvd_left f g)
#align polynomial.separable_gcd_left Polynomial.separable_gcd_left

theorem separable_gcd_right {F : Type _} [Field F] {g : F[X]} (f : F[X]) (hg : g.Separable) :
    (EuclideanDomain.gcd f g).Separable :=
  Separable.of_dvd hg (EuclideanDomain.gcd_dvd_right f g)
#align polynomial.separable_gcd_right Polynomial.separable_gcd_right

theorem Separable.isCoprime {f g : R[X]} (h : (f * g).Separable) : IsCoprime f g :=
  by
  have := h.of_mul_left_left; rw [derivative_mul] at this
  exact IsCoprime.of_mul_right_right (IsCoprime.of_add_mul_left_right this)
#align polynomial.separable.is_coprime Polynomial.Separable.isCoprime

theorem Separable.of_pow' {f : R[X]} :
    ∀ {n : ℕ} (h : (f ^ n).Separable), IsUnit f ∨ f.Separable ∧ n = 1 ∨ n = 0
  | 0 => fun h => Or.inr <| Or.inr rfl
  | 1 => fun h => Or.inr <| Or.inl ⟨pow_one f ▸ h, rfl⟩
  | n + 2 => fun h => by
    rw [pow_succ, pow_succ] at h
    exact Or.inl (isCoprime_self.1 h.is_coprime.of_mul_right_left)
#align polynomial.separable.of_pow' Polynomial.Separable.of_pow'

theorem Separable.of_pow {f : R[X]} (hf : ¬IsUnit f) {n : ℕ} (hn : n ≠ 0)
    (hfs : (f ^ n).Separable) : f.Separable ∧ n = 1 :=
  (hfs.of_pow'.resolve_left hf).resolve_right hn
#align polynomial.separable.of_pow Polynomial.Separable.of_pow

theorem Separable.map {p : R[X]} (h : p.Separable) {f : R →+* S} : (p.map f).Separable :=
  let ⟨a, b, H⟩ := h
  ⟨a.map f, b.map f, by
    rw [derivative_map, ← Polynomial.map_mul, ← Polynomial.map_mul, ← Polynomial.map_add, H,
      Polynomial.map_one]⟩
#align polynomial.separable.map Polynomial.Separable.map

variable (p q : ℕ)

theorem isUnit_of_self_mul_dvd_separable {p q : R[X]} (hp : p.Separable) (hq : q * q ∣ p) :
    IsUnit q := by
  obtain ⟨p, rfl⟩ := hq
  apply is_coprime_self.mp
  have : IsCoprime (q * (q * p)) (q * (q.derivative * p + q.derivative * p + q * p.derivative)) :=
    by
    simp only [← mul_assoc, mul_add]
    convert hp
    rw [derivative_mul, derivative_mul]
    ring
  exact IsCoprime.of_mul_right_left (IsCoprime.of_mul_left_left this)
#align polynomial.is_unit_of_self_mul_dvd_separable Polynomial.isUnit_of_self_mul_dvd_separable

theorem multiplicity_le_one_of_separable {p q : R[X]} (hq : ¬IsUnit q) (hsep : Separable p) :
    multiplicity q p ≤ 1 := by
  contrapose! hq
  apply is_unit_of_self_mul_dvd_separable hsep
  rw [← sq]
  apply multiplicity.pow_dvd_of_le_multiplicity
  simpa only [Nat.cast_one, Nat.cast_bit0] using PartENat.add_one_le_of_lt hq
#align polynomial.multiplicity_le_one_of_separable Polynomial.multiplicity_le_one_of_separable

theorem Separable.squarefree {p : R[X]} (hsep : Separable p) : Squarefree p :=
  by
  rw [multiplicity.squarefree_iff_multiplicity_le_one p]
  intro f
  by_cases hunit : IsUnit f
  · exact Or.inr hunit
  exact Or.inl (multiplicity_le_one_of_separable hunit hsep)
#align polynomial.separable.squarefree Polynomial.Separable.squarefree

end CommSemiring

section CommRing

variable {R : Type u} [CommRing R]

theorem separable_x_sub_c {x : R} : Separable (X - C x) := by
  simpa only [sub_eq_add_neg, C_neg] using separable_X_add_C (-x)
#align polynomial.separable_X_sub_C Polynomial.separable_x_sub_c

theorem Separable.mul {f g : R[X]} (hf : f.Separable) (hg : g.Separable) (h : IsCoprime f g) :
    (f * g).Separable := by
  rw [separable_def, derivative_mul]
  exact
    ((hf.mul_right h).add_mul_left_right _).mul_left ((h.symm.mul_right hg).mul_add_right_right _)
#align polynomial.separable.mul Polynomial.Separable.mul

theorem separable_prod' {ι : Sort _} {f : ι → R[X]} {s : Finset ι} :
    (∀ x ∈ s, ∀ y ∈ s, x ≠ y → IsCoprime (f x) (f y)) →
      (∀ x ∈ s, (f x).Separable) → (∏ x in s, f x).Separable :=
  Finset.induction_on s (fun _ _ => separable_one) fun a s has ih h1 h2 =>
    by
    simp_rw [Finset.forall_mem_insert, forall_and] at h1 h2; rw [prod_insert has]
    exact
      h2.1.mul (ih h1.2.2 h2.2)
        (IsCoprime.prod_right fun i his => h1.1.2 i his <| Ne.symm <| ne_of_mem_of_not_mem his has)
#align polynomial.separable_prod' Polynomial.separable_prod'

theorem separable_prod {ι : Sort _} [Fintype ι] {f : ι → R[X]} (h1 : Pairwise (IsCoprime on f))
    (h2 : ∀ x, (f x).Separable) : (∏ x, f x).Separable :=
  separable_prod' (fun x hx y hy hxy => h1 hxy) fun x hx => h2 x
#align polynomial.separable_prod Polynomial.separable_prod

theorem Separable.inj_of_prod_x_sub_c [Nontrivial R] {ι : Sort _} {f : ι → R} {s : Finset ι}
    (hfs : (∏ i in s, X - C (f i)).Separable) {x y : ι} (hx : x ∈ s) (hy : y ∈ s)
    (hfxy : f x = f y) : x = y := by
  by_contra hxy
  rw [← insert_erase hx, prod_insert (not_mem_erase _ _), ←
    insert_erase (mem_erase_of_ne_of_mem (Ne.symm hxy) hy), prod_insert (not_mem_erase _ _), ←
    mul_assoc, hfxy, ← sq] at hfs
  cases (hfs.of_mul_left.of_pow (not_is_unit_X_sub_C _) two_ne_zero).2
#align polynomial.separable.inj_of_prod_X_sub_C Polynomial.Separable.inj_of_prod_x_sub_c

theorem Separable.injective_of_prod_x_sub_c [Nontrivial R] {ι : Sort _} [Fintype ι] {f : ι → R}
    (hfs : (∏ i, X - C (f i)).Separable) : Function.Injective f := fun x y hfxy =>
  hfs.inj_of_prod_x_sub_c (mem_univ _) (mem_univ _) hfxy
#align polynomial.separable.injective_of_prod_X_sub_C Polynomial.Separable.injective_of_prod_x_sub_c

theorem nodup_of_separable_prod [Nontrivial R] {s : Multiset R}
    (hs : Separable (Multiset.map (fun a => X - C a) s).Prod) : s.Nodup :=
  by
  rw [Multiset.nodup_iff_ne_cons_cons]
  rintro a t rfl
  refine' not_is_unit_X_sub_C a (is_unit_of_self_mul_dvd_separable hs _)
  simpa only [Multiset.map_cons, Multiset.prod_cons] using mul_dvd_mul_left _ (dvd_mul_right _ _)
#align polynomial.nodup_of_separable_prod Polynomial.nodup_of_separable_prod

/-- If `is_unit n` in a `comm_ring R`, then `X ^ n - u` is separable for any unit `u`. -/
theorem separable_x_pow_sub_c_unit {n : ℕ} (u : Rˣ) (hn : IsUnit (n : R)) :
    Separable (X ^ n - C (u : R)) := by
  nontriviality R
  rcases n.eq_zero_or_pos with (rfl | hpos)
  · simpa using hn
  apply (separable_def' (X ^ n - C (u : R))).2
  obtain ⟨n', hn'⟩ := hn.exists_left_inv
  refine' ⟨-C ↑u⁻¹, C ↑u⁻¹ * C n' * X, _⟩
  rw [derivative_sub, derivative_C, sub_zero, derivative_pow X n, derivative_X, mul_one]
  calc
    -C ↑u⁻¹ * (X ^ n - C ↑u) + C ↑u⁻¹ * C n' * X * (↑n * X ^ (n - 1)) =
        C (↑u⁻¹ * ↑u) - C ↑u⁻¹ * X ^ n + C ↑u⁻¹ * C (n' * ↑n) * (X * X ^ (n - 1)) :=
      by
      simp only [C.map_mul, C_eq_nat_cast]
      ring
    _ = 1 := by
      simp only [Units.inv_mul, hn', C.map_one, mul_one, ← pow_succ,
        Nat.sub_add_cancel (show 1 ≤ n from hpos), sub_add_cancel]

#align polynomial.separable_X_pow_sub_C_unit Polynomial.separable_x_pow_sub_c_unit

theorem rootMultiplicity_le_one_of_separable [Nontrivial R] {p : R[X]} (hsep : Separable p)
    (x : R) : rootMultiplicity x p ≤ 1 :=
  by
  by_cases hp : p = 0
  · simp [hp]
  rw [root_multiplicity_eq_multiplicity, dif_neg hp, ← PartENat.coe_le_coe, PartENat.natCast_get,
    Nat.cast_one]
  exact multiplicity_le_one_of_separable (not_is_unit_X_sub_C _) hsep
#align polynomial.root_multiplicity_le_one_of_separable Polynomial.rootMultiplicity_le_one_of_separable

end CommRing

section IsDomain

variable {R : Type u} [CommRing R] [IsDomain R]

theorem count_roots_le_one {p : R[X]} (hsep : Separable p) (x : R) : p.roots.count x ≤ 1 :=
  by
  rw [count_roots p]
  exact root_multiplicity_le_one_of_separable hsep x
#align polynomial.count_roots_le_one Polynomial.count_roots_le_one

theorem nodup_roots {p : R[X]} (hsep : Separable p) : p.roots.Nodup :=
  Multiset.nodup_iff_count_le_one.mpr (count_roots_le_one hsep)
#align polynomial.nodup_roots Polynomial.nodup_roots

end IsDomain

section Field

variable {F : Type u} [Field F] {K : Type v} [Field K]

theorem separable_iff_derivative_ne_zero {f : F[X]} (hf : Irreducible f) :
    f.Separable ↔ f.derivative ≠ 0 :=
  ⟨fun h1 h2 => hf.not_unit <| isCoprime_zero_right.1 <| h2 ▸ h1, fun h =>
    EuclideanDomain.isCoprime_of_dvd (mt And.right h) fun g hg1 hg2 ⟨p, hg3⟩ hg4 =>
      let ⟨u, hu⟩ := (hf.isUnit_or_isUnit hg3).resolve_left hg1
      have : f ∣ f.derivative := by
        conv_lhs => rw [hg3, ← hu]
        rwa [Units.mul_right_dvd]
      not_lt_of_le (natDegree_le_of_dvd this h) <|
        natDegree_derivative_lt <| mt derivative_of_natDegree_zero h⟩
#align polynomial.separable_iff_derivative_ne_zero Polynomial.separable_iff_derivative_ne_zero

theorem separable_map (f : F →+* K) {p : F[X]} : (p.map f).Separable ↔ p.Separable := by
  simp_rw [separable_def, derivative_map, is_coprime_map]
#align polynomial.separable_map Polynomial.separable_map

theorem separable_prod_x_sub_c_iff' {ι : Sort _} {f : ι → F} {s : Finset ι} :
    (∏ i in s, X - C (f i)).Separable ↔ ∀ x ∈ s, ∀ y ∈ s, f x = f y → x = y :=
  ⟨fun hfs x hx y hy hfxy => hfs.inj_of_prod_x_sub_c hx hy hfxy, fun H =>
    by
    rw [← prod_attach]
    exact
      separable_prod'
        (fun x hx y hy hxy =>
          @pairwise_coprime_X_sub_C _ _ { x // x ∈ s } (fun x => f x)
            (fun x y hxy => Subtype.eq <| H x.1 x.2 y.1 y.2 hxy) _ _ hxy)
        fun _ _ => separable_X_sub_C⟩
#align polynomial.separable_prod_X_sub_C_iff' Polynomial.separable_prod_x_sub_c_iff'

theorem separable_prod_x_sub_c_iff {ι : Sort _} [Fintype ι] {f : ι → F} :
    (∏ i, X - C (f i)).Separable ↔ Function.Injective f :=
  separable_prod_x_sub_c_iff'.trans <| by simp_rw [mem_univ, true_imp_iff, Function.Injective]
#align polynomial.separable_prod_X_sub_C_iff Polynomial.separable_prod_x_sub_c_iff

section CharP

variable (p : ℕ) [HF : CharP F p]

include HF

theorem separable_or {f : F[X]} (hf : Irreducible f) :
    f.Separable ∨ ¬f.Separable ∧ ∃ g : F[X], Irreducible g ∧ expand F p g = f :=
  if H : f.derivative = 0 then by
    rcases p.eq_zero_or_pos with (rfl | hp)
    · haveI := CharP.charP_to_charZero F
      have := nat_degree_eq_zero_of_derivative_eq_zero H
      have := (nat_degree_pos_iff_degree_pos.mpr <| degree_pos_of_irreducible hf).ne'
      contradiction
    haveI := is_local_ring_hom_expand F hp
    exact
      Or.inr
        ⟨by rw [separable_iff_derivative_ne_zero hf, Classical.not_not, H], contract p f,
          of_irreducible_map (↑(expand F p)) (by rwa [← expand_contract p H hp.ne'] at hf),
          expand_contract p H hp.ne'⟩
  else Or.inl <| (separable_iff_derivative_ne_zero hf).2 H
#align polynomial.separable_or Polynomial.separable_or

theorem exists_separable_of_irreducible {f : F[X]} (hf : Irreducible f) (hp : p ≠ 0) :
    ∃ (n : ℕ)(g : F[X]), g.Separable ∧ expand F (p ^ n) g = f :=
  by
  replace hp : p.prime := (CharP.char_is_prime_or_zero F p).resolve_right hp
  induction' hn : f.nat_degree using Nat.strong_induction_on with N ih generalizing f
  rcases separable_or p hf with (h | ⟨h1, g, hg, hgf⟩)
  · refine' ⟨0, f, h, _⟩
    rw [pow_zero, expand_one]
  · cases' N with N
    · rw [nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff] at hn
      rw [hn, separable_C, isUnit_iff_ne_zero, Classical.not_not] at h1
      have hf0 : f ≠ 0 := hf.ne_zero
      rw [h1, C_0] at hn
      exact absurd hn hf0
    have hg1 : g.nat_degree * p = N.succ := by rwa [← nat_degree_expand, hgf]
    have hg2 : g.nat_degree ≠ 0 := by
      intro this
      rw [this, MulZeroClass.zero_mul] at hg1
      cases hg1
    have hg3 : g.nat_degree < N.succ :=
      by
      rw [← mul_one g.nat_degree, ← hg1]
      exact Nat.mul_lt_mul_of_pos_left hp.one_lt hg2.bot_lt
    rcases ih _ hg3 hg rfl with ⟨n, g, hg4, rfl⟩
    refine' ⟨n + 1, g, hg4, _⟩
    rw [← hgf, expand_expand, pow_succ]
#align polynomial.exists_separable_of_irreducible Polynomial.exists_separable_of_irreducible

theorem isUnit_or_eq_zero_of_separable_expand {f : F[X]} (n : ℕ) (hp : 0 < p)
    (hf : (expand F (p ^ n) f).Separable) : IsUnit f ∨ n = 0 :=
  by
  rw [or_iff_not_imp_right]
  rintro hn : n ≠ 0
  have hf2 : (expand F (p ^ n) f).derivative = 0 := by
    rw [derivative_expand, Nat.cast_pow, CharP.cast_eq_zero, zero_pow hn.bot_lt,
      MulZeroClass.zero_mul, MulZeroClass.mul_zero]
  rw [separable_def, hf2, isCoprime_zero_right, is_unit_iff] at hf
  rcases hf with ⟨r, hr, hrf⟩
  rw [eq_comm, expand_eq_C (pow_pos hp _)] at hrf
  rwa [hrf, is_unit_C]
#align polynomial.is_unit_or_eq_zero_of_separable_expand Polynomial.isUnit_or_eq_zero_of_separable_expand

theorem unique_separable_of_irreducible {f : F[X]} (hf : Irreducible f) (hp : 0 < p) (n₁ : ℕ)
    (g₁ : F[X]) (hg₁ : g₁.Separable) (hgf₁ : expand F (p ^ n₁) g₁ = f) (n₂ : ℕ) (g₂ : F[X])
    (hg₂ : g₂.Separable) (hgf₂ : expand F (p ^ n₂) g₂ = f) : n₁ = n₂ ∧ g₁ = g₂ :=
  by
  revert g₁ g₂
  wlog hn : n₁ ≤ n₂
  · intro g₁ g₂ hg₁ Hg₁ hg₂ Hg₂
    simpa only [eq_comm] using this hf hp n₂ n₁ (le_of_not_le hn) g₂ g₁ hg₂ Hg₂ hg₁ Hg₁
  have hf0 : f ≠ 0 := hf.ne_zero
  intros
  rw [le_iff_exists_add] at hn
  rcases hn with ⟨k, rfl⟩
  rw [← hgf₁, pow_add, expand_mul, expand_inj (pow_pos hp n₁)] at hgf₂
  subst hgf₂
  subst hgf₁
  rcases is_unit_or_eq_zero_of_separable_expand p k hp hg₁ with (h | rfl)
  · rw [is_unit_iff] at h
    rcases h with ⟨r, hr, rfl⟩
    simp_rw [expand_C] at hf
    exact absurd (is_unit_C.2 hr) hf.1
  · rw [add_zero, pow_zero, expand_one]
    constructor <;> rfl
#align polynomial.unique_separable_of_irreducible Polynomial.unique_separable_of_irreducible

end CharP

/-- If `n ≠ 0` in `F`, then ` X ^ n - a` is separable for any `a ≠ 0`. -/
theorem separable_x_pow_sub_c {n : ℕ} (a : F) (hn : (n : F) ≠ 0) (ha : a ≠ 0) :
    Separable (X ^ n - C a) :=
  separable_x_pow_sub_c_unit (Units.mk0 a ha) (IsUnit.mk0 n hn)
#align polynomial.separable_X_pow_sub_C Polynomial.separable_x_pow_sub_c

-- this can possibly be strengthened to making `separable_X_pow_sub_C_unit` a
-- bi-implication, but it is nontrivial!
/-- In a field `F`, `X ^ n - 1` is separable iff `↑n ≠ 0`. -/
theorem x_pow_sub_one_separable_iff {n : ℕ} : (X ^ n - 1 : F[X]).Separable ↔ (n : F) ≠ 0 :=
  by
  refine' ⟨_, fun h => separable_X_pow_sub_C_unit 1 (IsUnit.mk0 (↑n) h)⟩
  rw [separable_def', derivative_sub, derivative_X_pow, derivative_one, sub_zero]
  -- Suppose `(n : F) = 0`, then the derivative is `0`, so `X ^ n - 1` is a unit, contradiction.
  rintro (h : IsCoprime _ _) hn'
  rw [hn', C_0, MulZeroClass.zero_mul, isCoprime_zero_right] at h
  exact not_is_unit_X_pow_sub_one F n h
#align polynomial.X_pow_sub_one_separable_iff Polynomial.x_pow_sub_one_separable_iff

section Splits

theorem card_rootSet_eq_natDegree [Algebra F K] {p : F[X]} (hsep : p.Separable)
    (hsplit : Splits (algebraMap F K) p) : Fintype.card (p.rootSet K) = p.natDegree :=
  by
  simp_rw [root_set_def, Finset.coe_sort_coe, Fintype.card_coe]
  rw [Multiset.toFinset_card_of_nodup, ← nat_degree_eq_card_roots hsplit]
  exact nodup_roots hsep.map
#align polynomial.card_root_set_eq_nat_degree Polynomial.card_rootSet_eq_natDegree

variable {i : F →+* K}

theorem eq_x_sub_c_of_separable_of_root_eq {x : F} {h : F[X]} (h_sep : h.Separable)
    (h_root : h.eval x = 0) (h_splits : Splits i h) (h_roots : ∀ y ∈ (h.map i).roots, y = i x) :
    h = C (leadingCoeff h) * (X - C x) :=
  by
  have h_ne_zero : h ≠ 0 := by
    rintro rfl
    exact not_separable_zero h_sep
  apply Polynomial.eq_X_sub_C_of_splits_of_single_root i h_splits
  apply Finset.mk.inj
  · change _ = {i x}
    rw [Finset.eq_singleton_iff_unique_mem]
    constructor
    · apply finset.mem_mk.mpr
      rw [mem_roots (show h.map i ≠ 0 from map_ne_zero h_ne_zero)]
      rw [is_root.def, ← eval₂_eq_eval_map, eval₂_hom, h_root]
      exact RingHom.map_zero i
    · exact h_roots
  · exact nodup_roots (separable.map h_sep)
#align polynomial.eq_X_sub_C_of_separable_of_root_eq Polynomial.eq_x_sub_c_of_separable_of_root_eq

theorem exists_finset_of_splits (i : F →+* K) {f : F[X]} (sep : Separable f) (sp : Splits i f) :
    ∃ s : Finset K, f.map i = C (i f.leadingCoeff) * s.Prod fun a : K => X - C a :=
  by
  obtain ⟨s, h⟩ := (splits_iff_exists_multiset _).1 sp
  use s.to_finset
  rw [h, Finset.prod_eq_multiset_prod, ← Multiset.toFinset_eq]
  apply nodup_of_separable_prod
  apply separable.of_mul_right
  rw [← h]
  exact sep.map
#align polynomial.exists_finset_of_splits Polynomial.exists_finset_of_splits

end Splits

theorem Irreducible.separable [CharZero F] {f : F[X]} (hf : Irreducible f) : f.Separable :=
  by
  rw [separable_iff_derivative_ne_zero hf, Ne, ← degree_eq_bot, degree_derivative_eq]
  · rintro ⟨⟩
  rw [pos_iff_ne_zero, Ne, nat_degree_eq_zero_iff_degree_le_zero, degree_le_zero_iff]
  refine' fun hf1 => hf.not_unit _
  rw [hf1, is_unit_C, isUnit_iff_ne_zero]
  intro hf2
  rw [hf2, C_0] at hf1
  exact absurd hf1 hf.ne_zero
#align irreducible.separable Irreducible.separable

end Field

end Polynomial

open Polynomial

section CommRing

variable (F K : Type _) [CommRing F] [Ring K] [Algebra F K]

-- TODO: refactor to allow transcendental extensions?
-- See: https://en.wikipedia.org/wiki/Separable_extension#Separability_of_transcendental_extensions
-- Note that right now a Galois extension (class `is_galois`) is defined to be an extension which
-- is separable and normal, so if the definition of separable changes here at some point
-- to allow non-algebraic extensions, then the definition of `is_galois` must also be changed.
/-- Typeclass for separable field extension: `K` is a separable field extension of `F` iff
the minimal polynomial of every `x : K` is separable.

We define this for general (commutative) rings and only assume `F` and `K` are fields if this
is needed for a proof.
-/
class IsSeparable : Prop where
  is_integral' (x : K) : IsIntegral F x
  separable' (x : K) : (minpoly F x).Separable
#align is_separable IsSeparable

variable (F) {K}

theorem IsSeparable.isIntegral [IsSeparable F K] : ∀ x : K, IsIntegral F x :=
  IsSeparable.is_integral'
#align is_separable.is_integral IsSeparable.isIntegral

theorem IsSeparable.separable [IsSeparable F K] : ∀ x : K, (minpoly F x).Separable :=
  IsSeparable.separable'
#align is_separable.separable IsSeparable.separable

variable {F K}

theorem isSeparable_iff : IsSeparable F K ↔ ∀ x : K, IsIntegral F x ∧ (minpoly F x).Separable :=
  ⟨fun h x => ⟨@IsSeparable.isIntegral F _ _ _ h x, @IsSeparable.separable F _ _ _ h x⟩, fun h =>
    ⟨fun x => (h x).1, fun x => (h x).2⟩⟩
#align is_separable_iff isSeparable_iff

end CommRing

instance isSeparable_self (F : Type _) [Field F] : IsSeparable F F :=
  ⟨fun x => isIntegral_algebraMap, fun x =>
    by
    rw [minpoly.eq_x_sub_C']
    exact separable_X_sub_C⟩
#align is_separable_self isSeparable_self

-- See note [lower instance priority]
/-- A finite field extension in characteristic 0 is separable. -/
instance (priority := 100) IsSeparable.of_finite (F K : Type _) [Field F] [Field K] [Algebra F K]
    [FiniteDimensional F K] [CharZero F] : IsSeparable F K :=
  have : ∀ x : K, IsIntegral F x := fun x => Algebra.isIntegral_of_finite _ _ _
  ⟨this, fun x => (minpoly.irreducible (this x)).Separable⟩
#align is_separable.of_finite IsSeparable.of_finite

section IsSeparableTower

variable (F K E : Type _) [Field F] [Field K] [Field E] [Algebra F K] [Algebra F E] [Algebra K E]
  [IsScalarTower F K E]

theorem isSeparable_tower_top_of_isSeparable [IsSeparable F E] : IsSeparable K E :=
  ⟨fun x => isIntegral_of_isScalarTower (IsSeparable.isIntegral F x), fun x =>
    (IsSeparable.separable F x).map.of_dvd (minpoly.dvd_map_of_isScalarTower _ _ _)⟩
#align is_separable_tower_top_of_is_separable isSeparable_tower_top_of_isSeparable

theorem isSeparable_tower_bot_of_isSeparable [h : IsSeparable F E] : IsSeparable F K :=
  isSeparable_iff.2 fun x =>
    by
    refine'
      (isSeparable_iff.1 h (algebraMap K E x)).imp isIntegral_tower_bot_of_isIntegral_field
        fun hs => _
    obtain ⟨q, hq⟩ :=
      minpoly.dvd F x
        ((aeval_algebra_map_eq_zero_iff _ _ _).mp (minpoly.aeval F ((algebraMap K E) x)))
    rw [hq] at hs
    exact hs.of_mul_left
#align is_separable_tower_bot_of_is_separable isSeparable_tower_bot_of_isSeparable

variable {E}

theorem IsSeparable.of_algHom (E' : Type _) [Field E'] [Algebra F E'] (f : E →ₐ[F] E')
    [IsSeparable F E'] : IsSeparable F E :=
  by
  letI : Algebra E E' := RingHom.toAlgebra f.to_ring_hom
  haveI : IsScalarTower F E E' := IsScalarTower.of_algebraMap_eq fun x => (f.commutes x).symm
  exact isSeparable_tower_bot_of_isSeparable F E E'
#align is_separable.of_alg_hom IsSeparable.of_algHom

end IsSeparableTower

section CardAlgHom

variable {R S T : Type _} [CommRing S]

variable {K L F : Type _} [Field K] [Field L] [Field F]

variable [Algebra K S] [Algebra K L]

theorem AlgHom.card_of_powerBasis (pb : PowerBasis K S) (h_sep : (minpoly K pb.gen).Separable)
    (h_splits : (minpoly K pb.gen).Splits (algebraMap K L)) :
    @Fintype.card (S →ₐ[K] L) (PowerBasis.AlgHom.fintype pb) = pb.dim :=
  by
  let s := ((minpoly K pb.gen).map (algebraMap K L)).roots.toFinset
  have H := fun x => Multiset.mem_toFinset
  rw [Fintype.card_congr pb.lift_equiv', Fintype.card_of_subtype s H, ← pb.nat_degree_minpoly,
    nat_degree_eq_card_roots h_splits, Multiset.toFinset_card_of_nodup]
  exact nodup_roots ((separable_map (algebraMap K L)).mpr h_sep)
#align alg_hom.card_of_power_basis AlgHom.card_of_powerBasis

end CardAlgHom


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import order.rel_iso
import order.lattice_intervals
import order.galois_connection

/-!
# Modular Lattices
This file defines Modular Lattices, a kind of lattice useful in algebra.
For examples, look to the subobject lattices of abelian groups, submodules, and ideals, or consider
any distributive lattice.

## Main Definitions
- `is_modular_lattice` defines a modular lattice to be one such that
  `x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ (y ⊓ z)`
- `inf_Icc_order_iso_Icc_sup` gives an order isomorphism between the intervals
  `[a ⊓ b, a]` and `[b, a ⊔ b]`.
  This corresponds to the diamond (or second) isomorphism theorems of algebra.

## Main Results
- `is_modular_lattice_iff_inf_sup_inf_assoc`:
  Modularity is equivalent to the `inf_sup_inf_assoc`: `(x ⊓ z) ⊔ (y ⊓ z) = ((x ⊓ z) ⊔ y) ⊓ z`
- `distrib_lattice.is_modular_lattice`: Distributive lattices are modular.

## To do
- Relate atoms and coatoms in modular lattices

-/

variable {α : Type*}

/-- A modular lattice is one with a limited associativity between `⊓` and `⊔`. -/
class is_modular_lattice α [lattice α] : Prop :=
(sup_inf_le_assoc_of_le : ∀ {x : α} (y : α) {z : α}, x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ (y ⊓ z))

section is_modular_lattice
variables [lattice α] [is_modular_lattice α]

theorem sup_inf_assoc_of_le {x : α} (y : α) {z : α} (h : x ≤ z) :
  (x ⊔ y) ⊓ z = x ⊔ (y ⊓ z) :=
le_antisymm (is_modular_lattice.sup_inf_le_assoc_of_le y h)
  (le_inf (sup_le_sup_left inf_le_left _) (sup_le h inf_le_right))

theorem is_modular_lattice.inf_sup_inf_assoc {x y z : α} :
  (x ⊓ z) ⊔ (y ⊓ z) = ((x ⊓ z) ⊔ y) ⊓ z :=
(sup_inf_assoc_of_le y inf_le_right).symm

lemma inf_sup_assoc_of_le {x : α} (y : α) {z : α} (h : z ≤ x) :
  (x ⊓ y) ⊔ z = x ⊓ (y ⊔ z) :=
by rw [inf_comm, sup_comm, ← sup_inf_assoc_of_le y h, inf_comm, sup_comm]

instance : is_modular_lattice (order_dual α) :=
⟨λ x y z xz, le_of_eq (by { rw [inf_comm, sup_comm, eq_comm, inf_comm, sup_comm],
  convert sup_inf_assoc_of_le (order_dual.of_dual y) (order_dual.dual_le.2 xz) })⟩

variables {x y z : α}

theorem is_modular_lattice.sup_inf_sup_assoc :
  (x ⊔ z) ⊓ (y ⊔ z) = ((x ⊔ z) ⊓ y) ⊔ z :=
@is_modular_lattice.inf_sup_inf_assoc (order_dual α) _ _ _ _ _

theorem eq_of_le_of_inf_le_of_sup_le (hxy : x ≤ y) (hinf : y ⊓ z ≤ x ⊓ z) (hsup : y ⊔ z ≤ x ⊔ z) :
  x = y :=
le_antisymm hxy $
  have h : y ≤ x ⊔ z,
    from calc y ≤ y ⊔ z : le_sup_left
      ... ≤ x ⊔ z : hsup,
  calc y ≤ (x ⊔ z) ⊓ y : le_inf h (le_refl _)
    ... = x ⊔ (z ⊓ y) : sup_inf_assoc_of_le _ hxy
    ... ≤ x ⊔ (z ⊓ x) : sup_le_sup_left
      (by rw [inf_comm, @inf_comm _ _ z]; exact hinf) _
    ... ≤ x : sup_le (le_refl _) inf_le_right

theorem sup_lt_sup_of_lt_of_inf_le_inf (hxy : x < y) (hinf : y ⊓ z ≤ x ⊓ z) : x ⊔ z < y ⊔ z :=
lt_of_le_of_ne
  (sup_le_sup_right (le_of_lt hxy) _)
  (λ hsup, ne_of_lt hxy $ eq_of_le_of_inf_le_of_sup_le (le_of_lt hxy) hinf
    (le_of_eq hsup.symm))

theorem inf_lt_inf_of_lt_of_sup_le_sup (hxy : x < y) (hinf : y ⊔ z ≤ x ⊔ z) : x ⊓ z < y ⊓ z :=
@sup_lt_sup_of_lt_of_inf_le_inf (order_dual α) _ _ _ _ _ hxy hinf

/-- A generalization of the theorem that if `N` is a submodule of `M` and
  `N` and `M / N` are both Artinian, then `M` is Artinian. -/
theorem well_founded_lt_exact_sequence
  {β γ : Type*} [partial_order β] [partial_order γ]
  (h₁ : well_founded ((<) : β → β → Prop))
  (h₂ : well_founded ((<) : γ → γ → Prop))
  (K : α) (f₁ : β → α) (f₂ : α → β) (g₁ : γ → α) (g₂ : α → γ)
  (gci : galois_coinsertion f₁ f₂)
  (gi : galois_insertion g₂ g₁)
  (hf : ∀ a, f₁ (f₂ a) = a ⊓ K)
  (hg : ∀ a, g₁ (g₂ a) = a ⊔ K) :
  well_founded ((<) : α → α → Prop) :=
subrelation.wf
  (λ A B hAB, show prod.lex (<) (<) (f₂ A, g₂ A) (f₂ B, g₂ B),
    begin
      simp only [prod.lex_def, lt_iff_le_not_le, ← gci.l_le_l_iff,
        ← gi.u_le_u_iff, hf, hg, le_antisymm_iff],
      simp only [gci.l_le_l_iff, gi.u_le_u_iff, ← lt_iff_le_not_le, ← le_antisymm_iff],
      cases lt_or_eq_of_le (inf_le_inf_right K (le_of_lt hAB)) with h h,
      { exact or.inl h },
      { exact or.inr ⟨h, sup_lt_sup_of_lt_of_inf_le_inf hAB (le_of_eq h.symm)⟩ }
    end)
  (inv_image.wf _ (prod.lex_wf h₁ h₂))

/-- A generalization of the theorem that if `N` is a submodule of `M` and
  `N` and `M / N` are both Noetherian, then `M` is Noetherian.  -/
theorem well_founded_gt_exact_sequence
  {β γ : Type*} [partial_order β] [partial_order γ]
  (h₁ : well_founded ((>) : β → β → Prop))
  (h₂ : well_founded ((>) : γ → γ → Prop))
  (K : α) (f₁ : β → α) (f₂ : α → β) (g₁ : γ → α) (g₂ : α → γ)
  (gci : galois_coinsertion f₁ f₂)
  (gi : galois_insertion g₂ g₁)
  (hf : ∀ a, f₁ (f₂ a) = a ⊓ K)
  (hg : ∀ a, g₁ (g₂ a) = a ⊔ K) :
  well_founded ((>) : α → α → Prop) :=
@well_founded_lt_exact_sequence
  (order_dual α) _ _ (order_dual γ) (order_dual β) _ _
  h₂ h₁ K g₁ g₂ f₁ f₂ gi.dual gci.dual hg hf

/-- The diamond isomorphism between the intervals `[a ⊓ b, a]` and `[b, a ⊔ b]` -/
def inf_Icc_order_iso_Icc_sup (a b : α) : set.Icc (a ⊓ b) a ≃o set.Icc b (a ⊔ b) :=
{ to_fun := λ x, ⟨x ⊔ b, ⟨le_sup_right, sup_le_sup_right x.prop.2 b⟩⟩,
  inv_fun := λ x, ⟨a ⊓ x, ⟨inf_le_inf_left a x.prop.1, inf_le_left⟩⟩,
  left_inv := λ x, subtype.ext (by { change a ⊓ (↑x ⊔ b) = ↑x,
    rw [sup_comm, ← inf_sup_assoc_of_le _ x.prop.2, sup_eq_right.2 x.prop.1] }),
  right_inv := λ x, subtype.ext (by { change a ⊓ ↑x ⊔ b = ↑x,
    rw [inf_comm, inf_sup_assoc_of_le _ x.prop.1, inf_eq_left.2 x.prop.2] }),
  map_rel_iff' := λ x y, begin
    simp only [subtype.mk_le_mk, equiv.coe_fn_mk, and_true, le_sup_right],
    rw [← subtype.coe_le_coe],
    refine ⟨λ h, _, λ h, sup_le_sup_right h _⟩,
    rw [← sup_eq_right.2 x.prop.1, inf_sup_assoc_of_le _ x.prop.2, sup_comm,
      ← sup_eq_right.2 y.prop.1, inf_sup_assoc_of_le _ y.prop.2, @sup_comm _ _ b],
    exact inf_le_inf_left _ h
  end }
end is_modular_lattice

namespace is_compl
variables [lattice α] [bounded_order α] [is_modular_lattice α]

/-- The diamond isomorphism between the intervals `set.Iic a` and `set.Ici b`. -/
def Iic_order_iso_Ici {a b : α} (h : is_compl a b) : set.Iic a ≃o set.Ici b :=
(order_iso.set_congr (set.Iic a) (set.Icc (a ⊓ b) a) (h.inf_eq_bot.symm ▸ set.Icc_bot.symm)).trans $
  (inf_Icc_order_iso_Icc_sup a b).trans
  (order_iso.set_congr (set.Icc b (a ⊔ b)) (set.Ici b) (h.sup_eq_top.symm ▸ set.Icc_top))

end is_compl

theorem is_modular_lattice_iff_inf_sup_inf_assoc [lattice α] :
  is_modular_lattice α ↔ ∀ (x y z : α), (x ⊓ z) ⊔ (y ⊓ z) = ((x ⊓ z) ⊔ y) ⊓ z :=
⟨λ h, @is_modular_lattice.inf_sup_inf_assoc _ _ h, λ h, ⟨λ x y z xz, by rw [← inf_eq_left.2 xz, h]⟩⟩

namespace distrib_lattice

@[priority 100]
instance [distrib_lattice α] : is_modular_lattice α :=
⟨λ x y z xz, by rw [inf_sup_right, inf_eq_left.2 xz]⟩

end distrib_lattice

theorem disjoint.disjoint_sup_right_of_disjoint_sup_left
  [lattice α] [bounded_order α] [is_modular_lattice α] {a b c : α}
  (h : disjoint a b) (hsup : disjoint (a ⊔ b) c) :
  disjoint a (b ⊔ c) :=
begin
  rw [disjoint, ← h.eq_bot, sup_comm],
  apply le_inf inf_le_left,
  apply (inf_le_inf_right (c ⊔ b) le_sup_right).trans,
  rw [sup_comm, is_modular_lattice.sup_inf_sup_assoc, hsup.eq_bot, bot_sup_eq]
end

theorem disjoint.disjoint_sup_left_of_disjoint_sup_right
  [lattice α] [bounded_order α] [is_modular_lattice α] {a b c : α}
  (h : disjoint b c) (hsup : disjoint a (b ⊔ c)) :
  disjoint (a ⊔ b) c :=
begin
  rw [disjoint.comm, sup_comm],
  apply disjoint.disjoint_sup_right_of_disjoint_sup_left h.symm,
  rwa [sup_comm, disjoint.comm] at hsup,
end

namespace is_modular_lattice

variables [lattice α] [is_modular_lattice α] {a : α}

instance is_modular_lattice_Iic : is_modular_lattice (set.Iic a) :=
⟨λ x y z xz, (sup_inf_le_assoc_of_le (y : α) xz : (↑x ⊔ ↑y) ⊓ ↑z ≤ ↑x ⊔ ↑y ⊓ ↑z)⟩

instance is_modular_lattice_Ici : is_modular_lattice (set.Ici a) :=
⟨λ x y z xz, (sup_inf_le_assoc_of_le (y : α) xz : (↑x ⊔ ↑y) ⊓ ↑z ≤ ↑x ⊔ ↑y ⊓ ↑z)⟩

section is_complemented
variables [bounded_order α] [is_complemented α]

instance is_complemented_Iic : is_complemented (set.Iic a) :=
⟨λ ⟨x, hx⟩, let ⟨y, hy⟩ := exists_is_compl x in
  ⟨⟨y ⊓ a, set.mem_Iic.2 inf_le_right⟩, begin
    split,
    { change x ⊓ (y ⊓ a) ≤ ⊥, -- improve lattice subtype API
      rw ← inf_assoc,
      exact le_trans inf_le_left hy.1 },
    { change a ≤ x ⊔ (y ⊓ a), -- improve lattice subtype API
      rw [← sup_inf_assoc_of_le _ (set.mem_Iic.1 hx), top_le_iff.1 hy.2, top_inf_eq] }
  end⟩⟩

instance is_complemented_Ici : is_complemented (set.Ici a) :=
⟨λ ⟨x, hx⟩, let ⟨y, hy⟩ := exists_is_compl x in
  ⟨⟨y ⊔ a, set.mem_Ici.2 le_sup_right⟩, begin
    split,
    { change x ⊓ (y ⊔ a) ≤ a, -- improve lattice subtype API
      rw [← inf_sup_assoc_of_le _ (set.mem_Ici.1 hx),  le_bot_iff.1 hy.1, bot_sup_eq] },
    { change ⊤ ≤ x ⊔ (y ⊔ a), -- improve lattice subtype API
      rw ← sup_assoc,
      exact le_trans hy.2 le_sup_left }
  end⟩⟩

end is_complemented

end is_modular_lattice


import data.nat.prime
import tactic.norm_num
import data.list.basic
open nat
open list

theorem prime_prod: ∀x:ℕ,1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧prod L=x:=begin
    have Hstrong:∀ y x:ℕ,x≤y→1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧prod L=x:=begin
        intro,induction y with y1 Hiy,
        intros,rw eq_zero_of_le_zero a at a_1,revert a_1,norm_num,intros,
        cases x with x1,revert a_1,norm_num,
        cases x1 with x2,existsi nil,norm_num,
        cases classical.em (prime (succ(succ x2))) with A A,
        existsi ([succ (succ x2)]),norm_num,exact A,
        have H:=exists_dvd_of_not_prime2 (dec_trivial:2≤succ(succ x2)) A,
        cases H with b Hb,cases Hb with Hbd Hb,cases Hb with Hb2 Hbx,
        have H:=exists_eq_mul_right_of_dvd Hbd,cases H with c Hbc,rw eq_comm at Hbc,
        have H3:=succ_ne_zero (succ x2),rw ←Hbc at H3,
        have H2:= iff.elim_right pos_iff_ne_zero (ne_zero_of_mul_ne_zero_left H3),
        have H1:=iff.elim_right (lt_mul_iff_one_lt_left (iff.elim_right pos_iff_ne_zero (ne_zero_of_mul_ne_zero_left H3))) (lt_of_lt_of_le (dec_trivial:1<2) Hb2),rw Hbc at H1,
        cases Hiy b (le_of_succ_le_succ (le_trans (succ_le_of_lt Hbx) a)) (le_trans (dec_trivial:1≤2) Hb2) with B HB,
        cases Hiy c (le_of_succ_le_succ (le_trans (succ_le_of_lt H1) a)) (succ_le_of_lt H2) with C HC,existsi B++C,norm_num,intros,apply and.intro,
        rwa [and.right HB,and.right HC],intros,cases a_2,exact and.left HB p a_2,exact and.left HC p a_2,
    end,exact λ x,Hstrong x x (le_refl x),
end
theorem bezout: ∀ b c:ℕ,∃x y:ℤ, ↑b*x+↑c*y = ↑(gcd b c):=begin
    assume b c,apply gcd.induction b c,
    simp [gcd],intro,existsi (1:ℤ),simp,
    assume m n Hm,assume Hmn,cases Hmn with x1 Hx,cases Hx with y1 Hxy,
    cases m with m,simp [lt_irrefl] at Hm,revert Hm,trivial,
    unfold gcd,rw ←Hxy,existsi -↑(n/succ m)*x1+y1,existsi x1,
    have H: n%succ m=n-(succ m)*(n/(succ m)):=begin rw [eq_comm,nat.sub_eq_iff_eq_add,mod_add_div n (succ m)],rw mul_comm,exact div_mul_le_self n (succ m) end,rw H,
    rw [int.coe_nat_sub,mul_add,add_assoc,add_comm (↑(succ m) * y1) (↑n * x1),←add_assoc,add_right_cancel_iff,mul_sub_right_distrib,int.coe_nat_mul],norm_num,
    rw mul_comm,exact div_mul_le_self n (succ m),
end
theorem euclid: ∀b c p:ℕ, prime p → p ∣ (b*c) → p ∣ b ∨ p ∣ c:=begin
    assume b c p Hp Hpbc,unfold prime at Hp,
    cases(and.right Hp (gcd c p) (and.right (gcd_dvd c p))) with A A,
    cases (bezout c p)with x H,cases H with y H,rw A at H,
    have H1:↑(b*c)*x+↑(p*b)*y=↑b:=by{have H:↑b*↑c*x+↑b*↑p*y=↑b*↑1:=by{rw[←H,mul_add],norm_num},simp at H,rw←H,norm_num},left,
    have H2:=dvd_mul_of_dvd_left (iff.elim_right int.coe_nat_dvd Hpbc) x,
    have H3:=dvd_mul_of_dvd_left (iff.elim_right int.coe_nat_dvd (dvd_mul_of_dvd_left (dvd_refl p) b)) y,
    have H4:=dvd_add H2 H3,rw H1 at H4,rwa ←int.coe_nat_dvd,right,rw ←A,
    exact and.left (gcd_dvd c p),
end
theorem prod_dvd: ∀ (p:ℕ) (L:list ℕ),p∈L→ p ∣ prod L:=begin
    assume p L,revert p,
    induction L with p1 L1 HiL,
        norm_num,
        exact λ p2 Hp, dvd_mul_of_dvd_right (HiL p2 Hp) p1,
end
theorem list_reorder: ∀ (B:list ℕ) (p:ℕ),p∈ B→ (∀x:ℕ,x∈B→prime x)→ ∃ B2:list ℕ,(prod B=prod (p::B2)∧(∀x:ℕ,x∈ B2→ prime x)∧(∀ x:ℕ,count x B = count x (p::B2))):=begin
    assume B1,induction B1 with p1 B3 Hi,
    simp,assume p2 Hp,
    have H:p2 = p1 ∨ p2 ∈ B3:=by{revert Hp,norm_num},
    cases H with A A,
    assume H2,existsi B3,rw A,
    apply and.intro,trivial,
    revert H2,norm_num,

    assume H6 H7, cases (Hi p2 A H7) with C HC,
    existsi (p1::C:list ℕ),
    rw prod_cons at HC,simp [prod_cons],rw and.left HC,
    apply and.intro,assumption,

    apply and.intro,exact and.left (and.right HC),
    apply and.intro,simp,
    assume x,
    have listcount1:∀ B:list ℕ,∀ x y1 y2:ℕ, count x (y1::y2::B) = count x (y2::y1::B):=begin
        assume B x y1 y2,
        unfold count countp,
        cases classical.em (x=y1) with H H,
        cases classical.em (x=y2) with H1 H1,
        simp [H,H1],rw H at H1,simp [H1], simp [H,H1],
        cases classical.em (x=y2) with H1 H1,simp[H1,H],simp[H,H1],
    end,rw listcount1 C x p2 p1,
    cases classical.em (x=p1) with A A,
    rw [A,count_cons_self,count_cons_self],
    rw and.right (and.right HC) p1,
    rw [count_cons_of_ne A,count_cons_of_ne A],
    rw and.right (and.right HC) x,
end
theorem prime_prod_dvd: ∀ (B:list ℕ)(p:ℕ),prime p→(∀pB, pB ∈ B → prime pB)→p ∣ prod B → p ∈ B:=begin
    assume B,
    induction B with p1 B1 Hi,
    rw prod_nil,assume p Hp H H2,exfalso,revert H2,
    exact prime.not_dvd_one Hp,
    assume p2 Hp2 H H1,
    norm_num,
    rw prod_cons at H1,
    have H2:=euclid p1 (prod B1) p2 Hp2 H1,
    cases H2 with A A,
    left,
    have H3:=H p1,
    revert H3,norm_num,assume H4,
    unfold prime at H4,
    have H5:=and.right H4 p2 A,
    have H6:¬p2=1:=begin unfold prime at Hp2,intro,rw a at Hp2,simp at Hp2,revert Hp2,exact dec_trivial,end,
    simp [H6] at H5,assumption,
    right,
    have H3:(∀ (pB : ℕ), pB ∈ B1 → prime pB):=begin revert H, norm_num,end,have H2:= Hi p2 Hp2 H3 A,assumption,
end
theorem  unique_prime_factorization: ∀ A B:list ℕ,prod A=prod B→(∀p:ℕ, p∈A→prime p)→(∀ p:ℕ,p∈ B→ prime p)→∀ p:ℕ,count p A=count p B:=begin
    assume A,
    induction A with pA A Hi,
    rw prod_nil,norm_num,
    assume B HP HA p,
    have H:p∈ B→ ¬p∈ B:=begin intro HpB,
        have H1:=prod_dvd p B HpB,
        rw ←HP at H1,exfalso,
        exact prime.not_dvd_one (HA p HpB) H1,
    end,
    cases classical.em(count p B>0) with A A,have H09: 0<count p B:=begin revert A,norm_num,end,
    rw count_pos at H09,exfalso, exact H H09 H09,
    cases (eq_zero_or_pos (count p B)),rw a, exfalso, exact A a,

    assume B HP HA HB,
    rw prod_cons at HP,
    have H8:pA ∣ prod B:=begin
        have H1:=dvd_mul_of_dvd_left (dvd_refl pA) (prod A),
        rwa HP at H1,
    end,
    have HppA: prime pA:=begin apply HA,norm_num,  end,
    have H9:=prime_prod_dvd B pA HppA HB H8,
    have H10:=list_reorder B pA H9 HB,intros,
    cases H10 with C HC,
    rw prod_cons at HC,rw ←HP at HC,
    have HpA0:pA>0:=gt_of_ge_of_gt (and.left HppA) (dec_trivial:2>0),
    have H2:=iff.elim_left (nat.mul_left_inj HpA0) (and.left HC),
    have H3:=λ p Hp,and.left (and.right HC) p Hp,
    have H4:=λ p,and.right (and.right HC) p,
    have H6:∀ (p : ℕ), p ∈ A → prime p:=begin revert HA,norm_num, end,
    have Hi2:= Hi C H2 H6 H3,rw H4 p,
    cases classical.em (p=pA) with D D,rw D,
    rw[count_cons_self,count_cons_self, Hi2 pA],
    rw[count_cons_of_ne D,count_cons_of_ne D, Hi2 p],
end
theorem fundamental_theorem_of_arithmetic: ∀n:ℕ,1≤n→∃L:list ℕ,(∀p:ℕ,p∈L→prime p)∧prod L=n∧∀M:list ℕ,((∀p:ℕ,p∈M→prime p)→prod M=n→(∀p:ℕ,count p L=count p M)):=begin
    assume n Hn,
    cases (prime_prod n Hn) with L HL,
    existsi L,
    apply and.intro (and.left HL),
    apply and.intro (and.right HL),
    intros M H1 H2 p,
    rw[eq_comm,←and.right HL] at H2,
    exact (unique_prime_factorization L) M H2 (and.left HL) H1 p,
end
#print axioms fundamental_theorem_of_arithmetic
#print prod_eq_of_perm