/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Scott Morrison, Ainsley Pahljina
-/
import data.nat.parity
import data.pnat.interval
import data.zmod.basic
import group_theory.order_of_element
import ring_theory.fintype
import tactic.interval_cases
import tactic.ring_exp

/-!
# The Lucas-Lehmer test for Mersenne primes.

We define `lucas_lehmer_residue : Π p : ℕ, zmod (2^p - 1)`, and
prove `lucas_lehmer_residue p = 0 → prime (mersenne p)`.

We construct a tactic `lucas_lehmer.run_test`, which iteratively certifies the arithmetic
required to calculate the residue, and enables us to prove

```
example : prime (mersenne 127) :=
lucas_lehmer_sufficiency _ (by norm_num) (by lucas_lehmer.run_test)
```

## TODO

- Show reverse implication.
- Speed up the calculations using `n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]`.
- Find some bigger primes!

## History

This development began as a student project by Ainsley Pahljina,
and was then cleaned up for mathlib by Scott Morrison.
The tactic for certified computation of Lucas-Lehmer residues was provided by Mario Carneiro.
-/

/-- The Mersenne numbers, 2^p - 1. -/
def mersenne (p : ℕ) : ℕ := 2^p - 1

lemma mersenne_pos {p : ℕ} (h : 0 < p) : 0 < mersenne p :=
begin
  dsimp [mersenne],
  calc 0 < 2^1 - 1 : by norm_num
     ... ≤ 2^p - 1 : nat.pred_le_pred (nat.pow_le_pow_of_le_right (nat.succ_pos 1) h)
end

@[simp]
lemma succ_mersenne (k : ℕ) : mersenne k + 1 = 2 ^ k :=
begin
  rw [mersenne, tsub_add_cancel_of_le],
  exact one_le_pow_of_one_le (by norm_num) k
end

namespace lucas_lehmer

open nat

/-!
We now define three(!) different versions of the recurrence
`s (i+1) = (s i)^2 - 2`.

These versions take values either in `ℤ`, in `zmod (2^p - 1)`, or
in `ℤ` but applying `% (2^p - 1)` at each step.

They are each useful at different points in the proof,
so we take a moment setting up the lemmas relating them.
-/

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `ℤ`. -/
def s : ℕ → ℤ
| 0 := 4
| (i+1) := (s i)^2 - 2

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `zmod (2^p - 1)`. -/
def s_zmod (p : ℕ) : ℕ → zmod (2^p - 1)
| 0 := 4
| (i+1) := (s_zmod i)^2 - 2

/-- The recurrence `s (i+1) = ((s i)^2 - 2) % (2^p - 1)` in `ℤ`. -/
def s_mod (p : ℕ) : ℕ → ℤ
| 0 := 4 % (2^p - 1)
| (i+1) := ((s_mod i)^2 - 2) % (2^p - 1)

lemma mersenne_int_ne_zero (p : ℕ) (w : 0 < p) : (2^p - 1 : ℤ) ≠ 0 :=
begin
  apply ne_of_gt, simp only [gt_iff_lt, sub_pos],
  exact_mod_cast nat.one_lt_two_pow p w,
end

lemma s_mod_nonneg (p : ℕ) (w : 0 < p) (i : ℕ) : 0 ≤ s_mod p i :=
begin
  cases i; dsimp [s_mod],
  { exact sup_eq_right.mp rfl },
  { apply int.mod_nonneg, exact mersenne_int_ne_zero p w },
end

lemma s_mod_mod (p i : ℕ) : s_mod p i % (2^p - 1) = s_mod p i :=
by cases i; simp [s_mod]

lemma s_mod_lt (p : ℕ) (w : 0 < p) (i : ℕ) : s_mod p i < 2^p - 1 :=
begin
  rw ←s_mod_mod,
  convert int.mod_lt _ _,
  { refine (abs_of_nonneg _).symm,
    simp only [sub_nonneg, ge_iff_le],
    exact_mod_cast nat.one_le_two_pow p, },
  { exact mersenne_int_ne_zero p w, },
end

lemma s_zmod_eq_s (p' : ℕ) (i : ℕ) : s_zmod (p'+2) i = (s i : zmod (2^(p'+2) - 1)):=
begin
  induction i with i ih,
  { dsimp [s, s_zmod], norm_num, },
  { push_cast [s, s_zmod, ih] },
end

-- These next two don't make good `norm_cast` lemmas.
lemma int.coe_nat_pow_pred (b p : ℕ) (w : 0 < b) : ((b^p - 1 : ℕ) : ℤ) = (b^p - 1 : ℤ) :=
begin
  have : 1 ≤ b^p := nat.one_le_pow p b w,
  norm_cast
end

lemma int.coe_nat_two_pow_pred (p : ℕ) : ((2^p - 1 : ℕ) : ℤ) = (2^p - 1 : ℤ) :=
int.coe_nat_pow_pred 2 p dec_trivial

lemma s_zmod_eq_s_mod (p : ℕ) (i : ℕ) : s_zmod p i = (s_mod p i : zmod (2^p - 1)) :=
by induction i; push_cast [←int.coe_nat_two_pow_pred p, s_mod, s_zmod, *]

/-- The Lucas-Lehmer residue is `s p (p-2)` in `zmod (2^p - 1)`. -/
def lucas_lehmer_residue (p : ℕ) : zmod (2^p - 1) := s_zmod p (p-2)

lemma residue_eq_zero_iff_s_mod_eq_zero (p : ℕ) (w : 1 < p) :
  lucas_lehmer_residue p = 0 ↔ s_mod p (p-2) = 0 :=
begin
  dsimp [lucas_lehmer_residue],
  rw s_zmod_eq_s_mod p,
  split,
  { -- We want to use that fact that `0 ≤ s_mod p (p-2) < 2^p - 1`
    -- and `lucas_lehmer_residue p = 0 → 2^p - 1 ∣ s_mod p (p-2)`.
    intro h,
    simp [zmod.int_coe_zmod_eq_zero_iff_dvd] at h,
    apply int.eq_zero_of_dvd_of_nonneg_of_lt _ _ h; clear h,
    apply s_mod_nonneg _ (nat.lt_of_succ_lt w),
    exact s_mod_lt _ (nat.lt_of_succ_lt w) (p-2) },
  { intro h, rw h, simp, },
end

/--
A Mersenne number `2^p-1` is prime if and only if
the Lucas-Lehmer residue `s p (p-2) % (2^p - 1)` is zero.
-/
@[derive decidable_pred]
def lucas_lehmer_test (p : ℕ) : Prop := lucas_lehmer_residue p = 0

/-- `q` is defined as the minimum factor of `mersenne p`, bundled as an `ℕ+`. -/
def q (p : ℕ) : ℕ+ := ⟨nat.min_fac (mersenne p), nat.min_fac_pos (mersenne p)⟩

/-- We construct the ring `X q` as ℤ/qℤ + √3 ℤ/qℤ. -/
-- It would be nice to define this as (ℤ/qℤ)[x] / (x^2 - 3),
-- obtaining the ring structure for free,
-- but that seems to be more trouble than it's worth;
-- if it were easy to make the definition,
-- cardinality calculations would be somewhat more involved, too.
@[derive [add_comm_group, decidable_eq, fintype, inhabited]]
def X (q : ℕ+) : Type := (zmod q) × (zmod q)

namespace X
variable {q : ℕ+}

@[ext]
lemma ext {x y : X q} (h₁ : x.1 = y.1) (h₂ : x.2 = y.2) : x = y :=
begin
  cases x, cases y,
  congr; assumption
end

@[simp] lemma add_fst (x y : X q) : (x + y).1 = x.1 + y.1 := rfl
@[simp]

@[simp] lemma neg_fst (x : X q) : (-x).1 = -x.1 := rfl
@[simp] lemma neg_snd (x : X q) : (-x).2 = -x.2 := rfl

instance : has_mul (X q) :=
{ mul := λ x y, (x.1*y.1 + 3*x.2*y.2, x.1*y.2 + x.2*y.1) }

@[simp] lemma mul_fst (x y : X q) : (x * y).1 = x.1 * y.1 + 3 * x.2 * y.2 := rfl
@[simp] lemma mul_snd (x y : X q) : (x * y).2 = x.1 * y.2 + x.2 * y.1 := rfl

instance : has_one (X q) :=
{ one := ⟨1,0⟩ }

@[simp] lemma one_fst : (1 : X q).1 = 1 := rfl
@[simp] lemma one_snd : (1 : X q).2 = 0 := rfl

@[simp] lemma bit0_fst (x : X q) : (bit0 x).1 = bit0 x.1 := rfl
@[simp] lemma bit0_snd (x : X q) : (bit0 x).2 = bit0 x.2 := rfl
@[simp] lemma bit1_fst (x : X q) : (bit1 x).1 = bit1 x.1 := rfl
@[simp] lemma bit1_snd (x : X q) : (bit1 x).2 = bit0 x.2 := by { dsimp [bit1], simp, }

instance : monoid (X q) :=
{ mul_assoc := λ x y z, by { ext; { dsimp, ring }, },
  one := ⟨1,0⟩,
  one_mul := λ x, by { ext; simp, },
  mul_one := λ x, by { ext; simp, },
  ..(infer_instance : has_mul (X q)) }

instance : add_group_with_one (X q) :=
{ nat_cast := λ n, ⟨n, 0⟩,
  nat_cast_zero := by simp,
  nat_cast_succ := by simp [nat.cast, monoid.one],
  int_cast := λ n, ⟨n, 0⟩,
  int_cast_of_nat := λ n, by simp; refl,
  int_cast_neg_succ_of_nat := λ n, by ext; simp; refl,
  .. X.monoid, .. X.add_comm_group _ }

lemma left_distrib (x y z : X q) : x * (y + z) = x * y + x * z :=
by { ext; { dsimp, ring }, }

lemma right_distrib (x y z : X q) : (x + y) * z = x * z + y * z :=
by { ext; { dsimp, ring }, }

instance : ring (X q) :=
{ left_distrib := left_distrib,
  right_distrib := right_distrib,
  .. X.add_group_with_one,
  ..(infer_instance : add_comm_group (X q)),
  ..(infer_instance : monoid (X q)) }

instance : comm_ring (X q) :=
{ mul_comm := λ x y, by { ext; { dsimp, ring }, },
  ..(infer_instance : ring (X q))}

instance [fact (1 < (q : ℕ))] : nontrivial (X q) :=
⟨⟨0, 1, λ h, by { injection h with h1 _, exact zero_ne_one h1 } ⟩⟩

@[simp] lemma nat_coe_fst (n : ℕ) : (n : X q).fst = (n : zmod q) := rfl
@[simp] lemma nat_coe_snd (n : ℕ) : (n : X q).snd = (0 : zmod q) := rfl

@[simp] lemma int_coe_fst (n : ℤ) : (n : X q).fst = (n : zmod q) := rfl
@[simp] lemma int_coe_snd (n : ℤ) : (n : X q).snd = (0 : zmod q) := rfl

@[norm_cast]
lemma coe_mul (n m : ℤ) : ((n * m : ℤ) : X q) = (n : X q) * (m : X q) :=
by { ext; simp; ring }

@[norm_cast]
lemma coe_nat (n : ℕ) : ((n : ℤ) : X q) = (n : X q) :=
by { ext; simp, }

/-- The cardinality of `X` is `q^2`. -/
lemma X_card : fintype.card (X q) = q^2 :=
begin
  dsimp [X],
  rw [fintype.card_prod, zmod.card q],
  ring,
end

/-- There are strictly fewer than `q^2` units, since `0` is not a unit. -/
lemma units_card (w : 1 < q) : fintype.card ((X q)ˣ) < q^2 :=
begin
  haveI : fact (1 < (q:ℕ)) := ⟨w⟩,
  convert card_units_lt (X q),
  rw X_card,
end

/-- We define `ω = 2 + √3`. -/
def ω : X q := (2, 1)
/-- We define `ωb = 2 - √3`, which is the inverse of `ω`. -/
def ωb : X q := (2, -1)

lemma ω_mul_ωb (q : ℕ+) : (ω : X q) * ωb = 1 :=
begin
  dsimp [ω, ωb],
  ext; simp; ring,
end

lemma ωb_mul_ω (q : ℕ+) : (ωb : X q) * ω = 1 :=
begin
  dsimp [ω, ωb],
  ext; simp; ring,
end

/-- A closed form for the recurrence relation. -/
lemma closed_form (i : ℕ) : (s i : X q) = (ω : X q)^(2^i) + (ωb : X q)^(2^i) :=
begin
  induction i with i ih,
  { dsimp [s, ω, ωb],
    ext; { simp; refl, }, },
  { calc (s (i + 1) : X q) = ((s i)^2 - 2 : ℤ) : rfl
    ... = ((s i : X q)^2 - 2) : by push_cast
    ... = (ω^(2^i) + ωb^(2^i))^2 - 2 : by rw ih
    ... = (ω^(2^i))^2 + (ωb^(2^i))^2 + 2*(ωb^(2^i)*ω^(2^i)) - 2 : by ring
    ... = (ω^(2^i))^2 + (ωb^(2^i))^2 :
            by rw [←mul_pow ωb ω, ωb_mul_ω, one_pow, mul_one, add_sub_cancel]
    ... = ω^(2^(i+1)) + ωb^(2^(i+1)) : by rw [←pow_mul, ←pow_mul, pow_succ'] }
end

end X

open X

/-!
Here and below, we introduce `p' = p - 2`, in order to avoid using subtraction in `ℕ`.
-/

/-- If `1 < p`, then `q p`, the smallest prime factor of `mersenne p`, is more than 2. -/
lemma two_lt_q (p' : ℕ) : 2 < q (p'+2) := begin
  by_contradiction H,
  simp at H,
  interval_cases q (p'+2), clear H,
  { -- If q = 1, we get a contradiction from 2^p = 2
    dsimp [q] at h, injection h with h', clear h,
    simp [mersenne] at h',
    exact lt_irrefl 2
    (calc 2 ≤ p'+2    : nat.le_add_left _ _
      ...  < 2^(p'+2) : nat.lt_two_pow _
      ...  = 2        : nat.pred_inj (nat.one_le_two_pow _) dec_trivial h'), },
  { -- If q = 2, we get a contradiction from 2 ∣ 2^p - 1
    dsimp [q] at h, injection h with h', clear h,
    rw [mersenne, pnat.one_coe, nat.min_fac_eq_two_iff, pow_succ] at h',
    exact nat.two_not_dvd_two_mul_sub_one (nat.one_le_two_pow _) h', }
end

theorem ω_pow_formula (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  ∃ (k : ℤ), (ω : X (q (p'+2)))^(2^(p'+1)) =
    k * (mersenne (p'+2)) * ((ω : X (q (p'+2)))^(2^p')) - 1 :=
begin
  dsimp [lucas_lehmer_residue] at h,
  rw s_zmod_eq_s p' at h,
  simp [zmod.int_coe_zmod_eq_zero_iff_dvd] at h,
  cases h with k h,
  use k,
  replace h := congr_arg (λ (n : ℤ), (n : X (q (p'+2)))) h, -- coercion from ℤ to X q
  dsimp at h,
  rw closed_form at h,
  replace h := congr_arg (λ x, ω^2^p' * x) h,
  dsimp at h,
  have t : 2^p' + 2^p' = 2^(p'+1) := by ring_exp,
  rw [mul_add, ←pow_add ω, t, ←mul_pow ω ωb (2^p'), ω_mul_ωb, one_pow] at h,
  rw [mul_comm, coe_mul] at h,
  rw [mul_comm _ (k : X (q (p'+2)))] at h,
  replace h := eq_sub_of_add_eq h,
  have : 1 ≤ 2 ^ (p' + 2) := nat.one_le_pow _ _ dec_trivial,
  exact_mod_cast h,
end

/-- `q` is the minimum factor of `mersenne p`, so `M p = 0` in `X q`. -/
theorem mersenne_coe_X (p : ℕ) : (mersenne p : X (q p)) = 0 :=
begin
  ext; simp [mersenne, q, zmod.nat_coe_zmod_eq_zero_iff_dvd, -pow_pos],
  apply nat.min_fac_dvd,
end

theorem ω_pow_eq_neg_one (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  (ω : X (q (p'+2)))^(2^(p'+1)) = -1 :=
begin
  cases ω_pow_formula p' h with k w,
  rw [mersenne_coe_X] at w,
  simpa using w,
end

theorem ω_pow_eq_one (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  (ω : X (q (p'+2)))^(2^(p'+2)) = 1 :=
calc (ω : X (q (p'+2)))^2^(p'+2)
        = (ω^(2^(p'+1)))^2 : by rw [←pow_mul, ←pow_succ']
    ... = (-1)^2           : by rw ω_pow_eq_neg_one p' h
    ... = 1                : by simp

/-- `ω` as an element of the group of units. -/
def ω_unit (p : ℕ) : units (X (q p)) :=
{ val := ω,
  inv := ωb,
  val_inv := by simp [ω_mul_ωb],
  inv_val := by simp [ωb_mul_ω], }

@[simp] lemma ω_unit_coe (p : ℕ) : (ω_unit p : X (q p)) = ω := rfl

/-- The order of `ω` in the unit group is exactly `2^p`. -/
theorem order_ω (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  order_of (ω_unit (p'+2)) = 2^(p'+2) :=
begin
  apply nat.eq_prime_pow_of_dvd_least_prime_pow, -- the order of ω divides 2^p
  { exact nat.prime_two, },
  { intro o,
    have ω_pow := order_of_dvd_iff_pow_eq_one.1 o,
    replace ω_pow := congr_arg (units.coe_hom (X (q (p'+2))) :
      units (X (q (p'+2))) → X (q (p'+2))) ω_pow,
    simp at ω_pow,
    have h : (1 : zmod (q (p'+2))) = -1 :=
      congr_arg (prod.fst) ((ω_pow.symm).trans (ω_pow_eq_neg_one p' h)),
    haveI : fact (2 < (q (p'+2) : ℕ)) := ⟨two_lt_q _⟩,
    apply zmod.neg_one_ne_one h.symm, },
  { apply order_of_dvd_iff_pow_eq_one.2,
    apply units.ext,
    push_cast,
    exact ω_pow_eq_one p' h, }
end

lemma order_ineq (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) : 2^(p'+2) < (q (p'+2) : ℕ)^2 :=
calc 2^(p'+2) = order_of (ω_unit (p'+2)) : (order_ω p' h).symm
     ... ≤ fintype.card ((X _)ˣ)    : order_of_le_card_univ
     ... < (q (p'+2) : ℕ)^2              : units_card (nat.lt_of_succ_lt (two_lt_q _))

end lucas_lehmer

export lucas_lehmer (lucas_lehmer_test lucas_lehmer_residue)

open lucas_lehmer

theorem lucas_lehmer_sufficiency (p : ℕ) (w : 1 < p) : lucas_lehmer_test p → (mersenne p).prime :=
begin
  let p' := p - 2,
  have z : p = p' + 2 := (tsub_eq_iff_eq_add_of_le w.nat_succ_le).mp rfl,
  have w : 1 < p' + 2 := (nat.lt_of_sub_eq_succ rfl),
  contrapose,
  intros a t,
  rw z at a,
  rw z at t,
  have h₁ := order_ineq p' t,
  have h₂ := nat.min_fac_sq_le_self (mersenne_pos (nat.lt_of_succ_lt w)) a,
  have h := lt_of_lt_of_le h₁ h₂,
  exact not_lt_of_ge (nat.sub_le _ _) h,
end

-- Here we calculate the residue, very inefficiently, using `dec_trivial`. We can do much better.
example : (mersenne 5).prime := lucas_lehmer_sufficiency 5 (by norm_num) dec_trivial

-- Next we use `norm_num` to calculate each `s p i`.
namespace lucas_lehmer
open tactic

lemma s_mod_succ {p a i b c}
  (h1 : (2^p - 1 : ℤ) = a)
  (h2 : s_mod p i = b)
  (h3 : (b * b - 2) % a = c) :
  s_mod p (i+1) = c :=
by { dsimp [s_mod, mersenne], rw [h1, h2, sq, h3] }

/--
Given a goal of the form `lucas_lehmer_test p`,
attempt to do the calculation using `norm_num` to certify each step.
-/
meta def run_test : tactic unit :=
do `(lucas_lehmer_test %%p) ← target,
   `[dsimp [lucas_lehmer_test]],
   `[rw lucas_lehmer.residue_eq_zero_iff_s_mod_eq_zero, swap, norm_num],
   p ← eval_expr ℕ p,
   -- Calculate the candidate Mersenne prime
   let M : ℤ := 2^p - 1,
   t ← to_expr ``(2^%%`(p) - 1 = %%`(M)),
   v ← to_expr ``(by norm_num : 2^%%`(p) - 1 = %%`(M)),
   w ← assertv `w t v,
   -- base case
   t ← to_expr ``(s_mod %%`(p) 0 = 4),
   v ← to_expr ``(by norm_num [lucas_lehmer.s_mod] : s_mod %%`(p) 0 = 4),
   h ← assertv `h t v,
   -- step case, repeated p-2 times
   iterate_exactly (p-2) `[replace h := lucas_lehmer.s_mod_succ w h (by { norm_num, refl })],
   -- now close the goal
   h ← get_local `h,
   exact h

end lucas_lehmer

/-- We verify that the tactic works to prove `127.prime`. -/
example : (mersenne 7).prime := lucas_lehmer_sufficiency _ (by norm_num) (by lucas_lehmer.run_test).

/-!
This implementation works successfully to prove `(2^127 - 1).prime`,
and all the Mersenne primes up to this point appear in [archive/examples/mersenne_primes.lean].

`(2^127 - 1).prime` takes about 5 minutes to run (depending on your CPU!),
and unfortunately the next Mersenne prime `(2^521 - 1)`,
which was the first "computer era" prime,
is out of reach with the current implementation.

There's still low hanging fruit available to do faster computations
based on the formula
```
n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]
```
and the fact that `% 2^p` and `/ 2^p` can be very efficient on the binary representation.
Someone should do this, too!
-/

lemma modeq_mersenne (n k : ℕ) : k ≡ ((k / 2^n) + (k % 2^n)) [MOD 2^n - 1] :=
-- See https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/help.20finding.20a.20lemma/near/177698446
begin
  conv in k { rw ← nat.div_add_mod k (2^n) },
  refine nat.modeq.add_right _ _,
  conv { congr, skip, skip, rw ← one_mul (k/2^n) },
  exact (nat.modeq_sub $ nat.succ_le_of_lt $ pow_pos zero_lt_two _).mul_right _,
end

-- It's hard to know what the limiting factor for large Mersenne primes would be.
-- In the purely computational world, I think it's the squaring operation in `s`.


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import order.well_founded
import algebra.group.pi
import order.min_max

/-!
# Lexicographic order on Pi types

This file defines the lexicographic relation for Pi types of partial orders and linear orders. We
also provide a `pilex` analog of `pi.ordered_comm_group` (see `algebra.order.pi`).
-/

variables {ι : Type*} {β : ι → Type*} (r : ι → ι → Prop)
  (s : Π {i}, β i → β i → Prop)

/-- The lexicographic relation on `Π i : ι, β i`, where `ι` is ordered by `r`,
  and each `β i` is ordered by `s`. -/
def pi.lex (x y : Π i, β i) : Prop :=
∃ i, (∀ j, r j i → x j = y j) ∧ s (x i) (y i)

/-- The cartesian product of an indexed family, equipped with the lexicographic order. -/
def pilex (α : Type*) (β : α → Type*) : Type* := Π a, β a

instance [has_lt ι] [∀ a, has_lt (β a)] : has_lt (pilex ι β) :=
{ lt := pi.lex (<) (λ _, (<)) }

instance [∀ a, inhabited (β a)] : inhabited (pilex ι β) :=
by unfold pilex; apply_instance

instance pilex.is_strict_order [linear_order ι] [∀ a, partial_order (β a)] :
  is_strict_order (pilex ι β) (<) :=
{ irrefl := λ a ⟨k, hk₁, hk₂⟩, lt_irrefl (a k) hk₂,
  trans :=
    begin
      rintro a b c ⟨N₁, lt_N₁, a_lt_b⟩ ⟨N₂, lt_N₂, b_lt_c⟩,
      rcases lt_trichotomy N₁ N₂ with (H|rfl|H),
      exacts [⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ $ hj.trans H), lt_N₂ _ H ▸ a_lt_b⟩,
        ⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ hj), a_lt_b.trans b_lt_c⟩,
        ⟨N₂, λ j hj, (lt_N₁ _ (hj.trans H)).trans (lt_N₂ _ hj), (lt_N₁ _ H).symm ▸ b_lt_c⟩]
    end }

instance [linear_order ι] [∀ a, partial_order (β a)] : partial_order (pilex ι β) :=
partial_order_of_SO (<)

protected lemma pilex.is_strict_total_order' [linear_order ι]
  (wf : well_founded ((<) : ι → ι → Prop)) [∀ a, linear_order (β a)] :
  is_strict_total_order' (pilex ι β) (<) :=
{ trichotomous := λ a b,
    begin
      by_cases h : ∃ i, a i ≠ b i,
      { let i := wf.min _ h,
        have hlt_i : ∀ j < i, a j = b j,
        { intro j, rw ← not_imp_not,
          exact λ h', wf.not_lt_min _ _ h' },
        have : a i ≠ b i, from wf.min_mem _ h,
        exact this.lt_or_lt.imp (λ h, ⟨i, hlt_i, h⟩)
          (λ h, or.inr ⟨i, λ j hj, (hlt_i j hj).symm, h⟩) },
      { push_neg at h, exact or.inr (or.inl (funext h)) }
    end }

/-- `pilex` is a linear order if the original order is well-founded.
This cannot be an instance, since it depends on the well-foundedness of `<`. -/
protected noncomputable def pilex.linear_order [linear_order ι]
  (wf : well_founded ((<) : ι → ι → Prop)) [∀ a, linear_order (β a)] :
  linear_order (pilex ι β) :=
@linear_order_of_STO' (pilex ι β) (<) (pilex.is_strict_total_order' wf) (classical.dec_rel _)

lemma pilex.le_of_forall_le [linear_order ι]
  (wf : well_founded ((<) : ι → ι → Prop)) [∀ a, linear_order (β a)] {a b : pilex ι β}
  (h : ∀ i, a i ≤ b i) : a ≤ b :=
begin
  letI : linear_order (pilex ι β) := pilex.linear_order wf,
  exact le_of_not_lt (λ ⟨i, hi⟩, (h i).not_lt hi.2)
end

--we might want the analog of `pi.ordered_cancel_comm_monoid` as well in the future
@[to_additive]
instance [linear_order ι] [∀ a, ordered_comm_group (β a)] :
  ordered_comm_group (pilex ι β) :=
{ mul_le_mul_left := λ x y hxy z,
    hxy.elim
      (λ hxyz, hxyz ▸ le_refl _)
      (λ ⟨i, hi⟩,
        or.inr ⟨i, λ j hji, show z j * x j = z j * y j, by rw hi.1 j hji,
          mul_lt_mul_left' hi.2 _⟩),
  ..pilex.partial_order,
  ..pi.comm_group }


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import data.polynomial.algebra_map
import data.nat.choose.cast
import number_theory.bernoulli

/-!
# Bernoulli polynomials

The Bernoulli polynomials (defined here : https://en.wikipedia.org/wiki/Bernoulli_polynomials)
are an important tool obtained from Bernoulli numbers.

## Mathematical overview

The $n$-th Bernoulli polynomial is defined as
$$ B_n(X) = ∑_{k = 0}^n {n \choose k} (-1)^k * B_k * X^{n - k} $$
where $B_k$ is the $k$-th Bernoulli number. The Bernoulli polynomials are generating functions,
$$ t * e^{tX} / (e^t - 1) = ∑_{n = 0}^{\infty} B_n(X) * \frac{t^n}{n!} $$

## Implementation detail

Bernoulli polynomials are defined using `bernoulli`, the Bernoulli numbers.

## Main theorems

- `sum_bernoulli`: The sum of the $k^\mathrm{th}$ Bernoulli polynomial with binomial
  coefficients up to n is `(n + 1) * X^n`.
- `bernoulli_generating_function`: The Bernoulli polynomials act as generating functions
  for the exponential.

## TODO

- `bernoulli_eval_one_neg` : $$ B_n(1 - x) = (-1)^n*B_n(x) $$

-/

noncomputable theory
open_locale big_operators
open_locale nat polynomial

open nat finset

namespace polynomial

/-- The Bernoulli polynomials are defined in terms of the negative Bernoulli numbers. -/
def bernoulli (n : ℕ) : ℚ[X] :=
  ∑ i in range (n + 1), polynomial.monomial (n - i) ((_root_.bernoulli i) * (choose n i))

lemma bernoulli_def (n : ℕ) : bernoulli n =
  ∑ i in range (n + 1), polynomial.monomial i ((_root_.bernoulli (n - i)) * (choose n i)) :=
begin
  rw [←sum_range_reflect, add_succ_sub_one, add_zero, bernoulli],
  apply sum_congr rfl,
  rintros x hx,
  rw mem_range_succ_iff at hx, rw [choose_symm hx, tsub_tsub_cancel_of_le hx],
end

/-
### examples
-/

section examples

@[simp] lemma bernoulli_zero : bernoulli 0 = 1 :=
by simp [bernoulli]

@[simp] lemma bernoulli_eval_zero (n : ℕ) : (bernoulli n).eval 0 = _root_.bernoulli n :=
begin
 rw [bernoulli, polynomial.eval_finset_sum, sum_range_succ],
  have : ∑ (x : ℕ) in range n, _root_.bernoulli x * (n.choose x) * 0 ^ (n - x) = 0,
  { apply sum_eq_zero (λ x hx, _),
    have h : 0 < n - x := tsub_pos_of_lt (mem_range.1 hx),
    simp [h] },
  simp [this],
end

@[simp] lemma bernoulli_eval_one (n : ℕ) : (bernoulli n).eval 1 = _root_.bernoulli' n :=
begin
  simp only [bernoulli, polynomial.eval_finset_sum],
  simp only [←succ_eq_add_one, sum_range_succ, mul_one, cast_one, choose_self,
    (_root_.bernoulli _).mul_comm, sum_bernoulli, one_pow, mul_one, polynomial.eval_C,
    polynomial.eval_monomial],
  by_cases h : n = 1,
  { norm_num [h], },
  { simp [h],
    exact bernoulli_eq_bernoulli'_of_ne_one h, }
end

end examples

@[simp] theorem sum_bernoulli (n : ℕ) :
  ∑ k in range (n + 1), ((n + 1).choose k : ℚ) • bernoulli k =
    polynomial.monomial n (n + 1 : ℚ) :=
begin
 simp_rw [bernoulli_def, finset.smul_sum, finset.range_eq_Ico, ←finset.sum_Ico_Ico_comm,
    finset.sum_Ico_eq_sum_range],
  simp only [cast_succ, add_tsub_cancel_left, tsub_zero, zero_add, linear_map.map_add],
  simp_rw [polynomial.smul_monomial, mul_comm (_root_.bernoulli _) _, smul_eq_mul, ←mul_assoc],
  conv_lhs { apply_congr, skip, conv
    { apply_congr, skip,
      rw [← nat.cast_mul, choose_mul ((le_tsub_iff_left $ mem_range_le H).1
        $ mem_range_le H_1) (le.intro rfl), nat.cast_mul, add_comm x x_1, add_tsub_cancel_right,
        mul_assoc, mul_comm, ←smul_eq_mul, ←polynomial.smul_monomial] },
    rw [←sum_smul], },
  rw [sum_range_succ_comm],
  simp only [add_right_eq_self, cast_succ, mul_one, cast_one, cast_add, add_tsub_cancel_left,
    choose_succ_self_right, one_smul, _root_.bernoulli_zero, sum_singleton, zero_add,
    linear_map.map_add, range_one],
  apply sum_eq_zero (λ x hx, _),
  have f : ∀ x ∈ range n, ¬ n + 1 - x = 1,
  { rintros x H, rw [mem_range] at H,
    rw [eq_comm],
    exact ne_of_lt (nat.lt_of_lt_of_le one_lt_two (le_tsub_of_add_le_left (succ_le_succ H))) },
  rw [sum_bernoulli],
  have g : (ite (n + 1 - x = 1) (1 : ℚ) 0) = 0,
  { simp only [ite_eq_right_iff, one_ne_zero],
    intro h₁,
    exact (f x hx) h₁, },
  rw [g, zero_smul],
end

open power_series
variables {A : Type*} [comm_ring A] [algebra ℚ A]

-- TODO: define exponential generating functions, and use them here
-- This name should probably be updated afterwards

/-- The theorem that `∑ Bₙ(t)X^n/n!)(e^X-1)=Xe^{tX}`  -/
theorem bernoulli_generating_function (t : A) :
  mk (λ n, aeval t ((1 / n! : ℚ) • bernoulli n)) * (exp A - 1) =
    power_series.X * rescale t (exp A) :=
begin
  -- check equality of power series by checking coefficients of X^n
  ext n,
  -- n = 0 case solved by `simp`
  cases n, { simp },
  -- n ≥ 1, the coefficients is a sum to n+2, so use `sum_range_succ` to write as
  -- last term plus sum to n+1
  rw [coeff_succ_X_mul, coeff_rescale, coeff_exp, power_series.coeff_mul,
    nat.sum_antidiagonal_eq_sum_range_succ_mk, sum_range_succ],
  -- last term is zero so kill with `add_zero`
  simp only [ring_hom.map_sub, tsub_self, constant_coeff_one, constant_coeff_exp,
    coeff_zero_eq_constant_coeff, mul_zero, sub_self, add_zero],
  -- Let's multiply both sides by (n+1)! (OK because it's a unit)
  set u : units ℚ := ⟨(n+1)!, (n+1)!⁻¹,
    mul_inv_cancel (by exact_mod_cast factorial_ne_zero (n+1)),
      inv_mul_cancel (by exact_mod_cast factorial_ne_zero (n+1))⟩ with hu,
  rw ←units.mul_right_inj (units.map (algebra_map ℚ A).to_monoid_hom u),
  -- now tidy up unit mess and generally do trivial rearrangements
  -- to make RHS (n+1)*t^n
  rw [units.coe_map, mul_left_comm, ring_hom.to_monoid_hom_eq_coe,
      ring_hom.coe_monoid_hom, ←ring_hom.map_mul, hu, units.coe_mk],
  change _ = t^n * algebra_map ℚ A (((n+1)*n! : ℕ)*(1/n!)),
  rw [cast_mul, mul_assoc, mul_one_div_cancel
    (show (n! : ℚ) ≠ 0, from cast_ne_zero.2 (factorial_ne_zero n)), mul_one, mul_comm (t^n),
    ← polynomial.aeval_monomial, cast_add, cast_one],
  -- But this is the RHS of `sum_bernoulli_poly`
  rw [← sum_bernoulli, finset.mul_sum, alg_hom.map_sum],
  -- and now we have to prove a sum is a sum, but all the terms are equal.
  apply finset.sum_congr rfl,
  -- The rest is just trivialities, hampered by the fact that we're coercing
  -- factorials and binomial coefficients between ℕ and ℚ and A.
  intros i hi,
  -- deal with coefficients of e^X-1
  simp only [nat.cast_choose ℚ (mem_range_le hi), coeff_mk,
    if_neg (mem_range_sub_ne_zero hi), one_div, alg_hom.map_smul, power_series.coeff_one,
    units.coe_mk, coeff_exp, sub_zero, linear_map.map_sub, algebra.smul_mul_assoc, algebra.smul_def,
    mul_right_comm _ ((aeval t) _), ←mul_assoc, ← ring_hom.map_mul, succ_eq_add_one],
  -- finally cancel the Bernoulli polynomial and the algebra_map
  congr',
  apply congr_arg,
  rw [mul_assoc, div_eq_mul_inv, ← mul_inv₀],
end

end polynomial


-- ----------------------------------------------------
-- Ejercicio. Demostrar
--    ⊢ p → (q → p)
-- ----------------------------------------------------

import tactic
variables (p q : Prop)

-- 1ª demostración
example :
  p → (q → p) :=
begin
  intros Hp Hq,
  exact Hp,
end

-- 2ª demostración
example :
  p → (q → p) :=
λ Hp _, Hp

-- 3ª demostración
example :
  p → (q → p) :=
assume Hp : p,
assume Hq : q,
show p,
  from Hp

-- 4ª demostración
example :
  p → (q → p) :=
-- by library_search
imp_intro

-- 5ª demostración
example :
  p → (q → p) :=
-- by hint
by tauto

-- 6ª demostración
example :
  p → (q → p) :=
by finish


variables P Q S T R : Prop.

lemma exA (H1 : (P ∧ Q) ∧ R)
          (H2 : S ∧ T) : Q ∧ S :=
  and.intro -- Q ∧ S
    (and.elim_right --Q
        (and.elim_left H1))
    (and.elim_left H2). -- S

lemma exC (H1 : P)
          (H2 : P →(P → Q)) : Q :=
    show Q,
    from (H2 H1 (show P,
                from (H1))).

lemma exD : (P ∧ Q) → P :=
      assume H : P ∧ Q,
      (and.elim_left H).

lemma exE (H : P) : Q → P ∧ Q :=
      assume H1 : Q,
      and.intro
      H H1.


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Patrick Massot

! This file was ported from Lean 3 source module topology.algebra.order.proj_Icc
! 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.Intervals.ProjIcc
import Mathlib.Topology.Order.Basic

/-!
# Projection onto a closed interval

In this file we prove that the projection `Set.projIcc f a b h` is a quotient map, and use it
to show that `Set.IccExtend h f` is continuous if and only if `f` is continuous.
-/

open Set Filter Topology

variable {α β γ : Type _} [LinearOrder α] [TopologicalSpace γ] {a b c : α} {h : a ≤ b}

-- porting note: new lemma
protected theorem Filter.Tendsto.IccExtend (f : γ → Icc a b → β) {la : Filter α} {lb : Filter β}
    {lc : Filter γ} (hf : Tendsto (↿f) (lc ×ᶠ la.map (projIcc a b h)) lb) :
    Tendsto (↿(IccExtend h ∘ f)) (lc ×ᶠ la) lb :=
  hf.comp <| tendsto_id.prod_map tendsto_map

@[deprecated Filter.Tendsto.IccExtend]
theorem Filter.Tendsto.IccExtend' (f : γ → Icc a b → β) {z : γ} {l : Filter α} {l' : Filter β}
    (hf : Tendsto (↿f) (𝓝 z ×ᶠ l.map (projIcc a b h)) l') :
    Tendsto (↿(IccExtend h ∘ f)) (𝓝 z ×ᶠ l) l' :=
  hf.IccExtend f
#align filter.tendsto.Icc_extend Filter.Tendsto.IccExtend'

variable [TopologicalSpace α] [OrderTopology α] [TopologicalSpace β]

@[continuity]
theorem continuous_projIcc : Continuous (projIcc a b h) :=
  (continuous_const.max <| continuous_const.min continuous_id).subtype_mk _
#align continuous_proj_Icc continuous_projIcc

theorem quotientMap_projIcc : QuotientMap (projIcc a b h) :=
  quotientMap_iff.2 ⟨projIcc_surjective h, fun s =>
    ⟨fun hs => hs.preimage continuous_projIcc, fun hs => ⟨_, hs, by ext; simp⟩⟩⟩
#align quotient_map_proj_Icc quotientMap_projIcc

@[simp]
theorem continuous_IccExtend_iff {f : Icc a b → β} : Continuous (IccExtend h f) ↔ Continuous f :=
  quotientMap_projIcc.continuous_iff.symm
#align continuous_Icc_extend_iff continuous_IccExtend_iff

/-- See Note [continuity lemma statement]. -/
protected theorem Continuous.IccExtend {f : γ → Icc a b → β} {g : γ → α} (hf : Continuous ↿f)
    (hg : Continuous g) : Continuous fun a => IccExtend h (f a) (g a) :=
  show Continuous (↿f ∘ fun x => (x, projIcc a b h (g x)))
  from hf.comp <| continuous_id.prod_mk <| continuous_projIcc.comp hg
#align continuous.Icc_extend Continuous.IccExtend

/-- A useful special case of `continuous.Icc_extend`. -/
@[continuity]
protected theorem Continuous.Icc_extend' {f : Icc a b → β} (hf : Continuous f) :
    Continuous (IccExtend h f) :=
  hf.comp continuous_projIcc
#align continuous.Icc_extend' Continuous.Icc_extend'

theorem ContinuousAt.IccExtend {x : γ} (f : γ → Icc a b → β) {g : γ → α}
    (hf : ContinuousAt (↿f) (x, projIcc a b h (g x))) (hg : ContinuousAt g x) :
    ContinuousAt (fun a => IccExtend h (f a) (g a)) x :=
  show ContinuousAt (↿f ∘ fun x => (x, projIcc a b h (g x))) x from
    ContinuousAt.comp hf <| continuousAt_id.prod <| continuous_projIcc.continuousAt.comp hg
#align continuous_at.Icc_extend ContinuousAt.IccExtend


import normalizer_world.normalizer_is_maximal -- hide

variables {G : Type} [group G] -- hide

/-
## The centralizer

In this world we prove two basic facts about centralizers. Here
is the definition of the centralizer of a subset $A$ of a given group $G$:
-/
@[reducible] -- hide
def centralizer (A : set G) := {g : G | ∀ a, a ∈ A → g*a*g⁻¹ = a }

/-
We can use the following lemma to rewrite using the definition.
-/
lemma centralizer_mem (A : set G) (g : G) :
g ∈ centralizer A ↔ ∀ a, a ∈ A → g * a * g⁻¹ = a
:= iff.rfl -- hide

/- Axiom: centralizer_mem
g ∈ centralizer A ↔ ∀ a, a ∈ A → g * a * g⁻¹ = a
-/

/-
The first goal is to prove that the centralizer of any set
is a subgroup.
-/

/- Lemma: no-side-bar
The centralizer $C_G(A)$ is a subgroup of $G$.
-/
lemma sc1 (A : set G) : subgroup (centralizer A) :=
begin
  rw subgroup,
  split,
  {
    use 1,
    rw centralizer,
    intro a,
    rw (show 1 * a * 1⁻¹ = a, by group),
    tauto,
  },
  {
    intros x y hx hy,
    rw centralizer_mem at hx hy ⊢,
    intros c hc,
    rw show x * y⁻¹ * c * (x * y⁻¹)⁻¹ = x * (y⁻¹ * c * y) * x⁻¹, by group,
    have hk : y⁻¹ * c * y = c,
    {
      specialize hy c hc,
      rw show y⁻¹ * c * y = y⁻¹ * (y * c * y⁻¹) * y, by rw hy,
      group,
    },
    rw hk,
    rw (hx c hc),
  }

end


/-
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 topological_space

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 / τ`.
-/
theorem exists_disjoint_subfamily_covering_enlargment
  (t : set (set α)) (δ : set α → ℝ) (τ : ℝ) (hτ : 1 < τ) (δnonneg : ∀ a ∈ t, 0 ≤ δ a)
  (R : ℝ) (δle : ∀ a ∈ t, δ a ≤ R) (hne : ∀ a ∈ t, set.nonempty a) :
  ∃ u ⊆ t, u.pairwise_disjoint id ∧
    ∀ a ∈ t, ∃ b ∈ u, set.nonempty (a ∩ b) ∧ δ 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 (set α)) := {u | u ⊆ t ∧ u.pairwise_disjoint id
    ∧ ∀ a ∈ t, ∀ b ∈ u, set.nonempty (a ∩ b) → ∃ c ∈ u, (a ∩ 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.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,
                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 : set α) (H : c ∈ u), (a ∩ 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 a c,
  { assume c hc,
    by_contra,
    rw not_disjoint_iff_nonempty_inter at h,
    obtain ⟨d, du, ad, hd⟩ : ∃ (d : set α) (H : d ∈ u), (a ∩ 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 a' 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, set.nonempty (c ∩ d),
    { 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 (set α)) (R : ℝ) (ht : ∀ s ∈ t, ∃ x r, s = closed_ball x r ∧ r ≤ R) :
  ∃ u ⊆ t, u.pairwise_disjoint id ∧
    ∀ a ∈ t, ∃ x r, closed_ball x r ∈ u ∧ a ⊆ closed_ball x (5 * r) :=
begin
  rcases eq_empty_or_nonempty t with rfl|tnonempty,
  { exact ⟨∅, subset.refl _, pairwise_disjoint_empty, by simp⟩ },
  haveI : inhabited α,
  { choose s hst using tnonempty,
    choose x r hxr using ht s hst,
    exact ⟨x⟩ },
  -- Exclude the trivial case where `t` is reduced to the empty set.
  rcases eq_or_ne t {∅} with rfl|t_ne_empty,
  { refine ⟨{∅}, subset.refl _, _⟩,
    simp only [true_and, closed_ball_eq_empty, mem_singleton_iff, and_true, empty_subset, forall_eq,
      pairwise_disjoint_singleton, exists_const],
    exact ⟨-1, by simp only [right.neg_neg_iff, zero_lt_one]⟩ },
  -- The real proof starts now. Since the center or the radius of a ball is not uniquely defined
  -- in a general metric space, we just choose one for definiteness.
  choose! x r hxr using ht,
  have r_nonneg : ∀ (a : set α), a ∈ t → a.nonempty → 0 ≤ r a,
  { assume a hat a_nonempty,
    rw (hxr a hat).1 at a_nonempty,
    simpa only [nonempty_closed_ball] using a_nonempty },
  -- The difference with the generic version is that we are not excluding empty sets in our family
  -- (which would correspond to `r a < 0`). To compensate for this, we apply the generic version
  -- to the subfamily `t'` made of nonempty sets, and we use `δ = r` there. This gives a disjointed
  -- subfamily `u'`.
  let t' := {a ∈ t | 0 ≤ r a},
  obtain ⟨u', u't', u'_disj, hu'⟩ : ∃ u' ⊆ t', u'.pairwise_disjoint id ∧
    ∀ a ∈ t', ∃ b ∈ u', set.nonempty (a ∩ b) ∧ r a ≤ 2 * r b,
  { refine exists_disjoint_subfamily_covering_enlargment t' r 2 one_lt_two
      (λ a ha, ha.2) R (λ a ha, (hxr a ha.1).2) (λ a ha, _),
    rw [(hxr a ha.1).1],
    simp only [ha.2, nonempty_closed_ball] },
  -- this subfamily is nonempty, as we have excluded the situation `t = {∅}`.
  have u'_nonempty : u'.nonempty,
  { have : ∃ a ∈ t, a ≠ ∅,
    { contrapose! t_ne_empty,
      apply subset.antisymm,
      { simpa only using t_ne_empty },
      { rcases tnonempty with ⟨a, hat⟩,
        have := t_ne_empty a hat,
        simpa only [this, singleton_subset_iff] using hat } },
    rcases this with ⟨a, hat, a_nonempty⟩,
    have ranonneg : 0 ≤ r a := r_nonneg a hat (ne_empty_iff_nonempty.1 a_nonempty),
    rcases hu' a ⟨hat, ranonneg⟩ with ⟨b, bu', hb⟩,
    exact ⟨b, bu'⟩ },
  -- check that the family `u'` gives the desired disjoint covering.
  refine ⟨u', λ a ha, (u't' ha).1, u'_disj, λ a hat, _⟩,
  -- it remains to check that any ball in `t` is contained in the 5-dilation of a ball
  -- in `u'`. This depends on whether the ball is empty of not.
  rcases eq_empty_or_nonempty a with rfl|a_nonempty,
  -- if the ball is empty, use any element of `u'` (since we know that `u'` is nonempty).
  { rcases u'_nonempty with ⟨b, hb⟩,
    refine ⟨x b, r b, _, empty_subset _⟩,
    rwa ← (hxr b (u't' hb).1).1 },
  -- if the ball is not empty, it belongs to `t'`. Then it intersects a ball `a'` in `u'` with
  -- controlled radius, by definition of `u'`. It is straightforward to check that this ball
  -- satisfies all the desired properties.
  { have hat' : a ∈ t' := ⟨hat, r_nonneg a hat a_nonempty⟩,
    obtain ⟨a', a'u', aa', raa'⟩ :
      (∃ (a' : set α) (H : a' ∈ u'), (a ∩ a').nonempty ∧ r a ≤ 2 * r a') := hu' a hat',
    refine ⟨x a', r a', _, _⟩,
    { convert a'u',
      exact (hxr a' (u't' a'u').1).1.symm },
    { rw (hxr a hat'.1).1 at aa' ⊢,
      rw (hxr a' (u't' a'u').1).1 at aa',
      have : dist (x a) (x a') ≤ r a + r a' :=
        dist_le_add_of_nonempty_closed_ball_inter_closed_ball aa',
      apply closed_ball_subset_closed_ball',
      linarith } }
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, 6 r)` for a given measure `μ` (think of the situation where `μ` is
a doubling measure and `t` is a family of balls). Consider a (possible 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`. -/
theorem exists_disjoint_covering_ae [metric_space α] [measurable_space α] [opens_measurable_space α]
  [second_countable_topology α]
  (μ : measure α) [is_locally_finite_measure μ] (s : set α)
  (t : set (set α)) (hf : ∀ x ∈ s, ∀ (ε > (0 : ℝ)), ∃ a ∈ t, x ∈ a ∧ a ⊆ closed_ball x ε)
  (ht : ∀ a ∈ t, (interior a).nonempty) (h't : ∀ a ∈ t, is_closed a)
  (C : ℝ≥0) (h : ∀ a ∈ t, ∃ x ∈ a, μ (closed_ball x (3 * diam a)) ≤ C * μ a) :
  ∃ u ⊆ t, countable u ∧ u.pairwise_disjoint id ∧ μ (s \ ⋃ (a ∈ u), a) = 0 :=
begin
  /- The idea of the proof is the following. Assume for simplicity that `μ` is finite. Applying the
  abstract Vitali covering theorem with `δ = diam`, one obtains a disjoint subfamily `u`, such
  that any element of `t` intersects an element of `u` with comparable diameter. 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 diameter (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`).
  -/
  rcases eq_empty_or_nonempty s with rfl|nonempty,
  { refine ⟨∅, empty_subset _, countable_empty, pairwise_disjoint_empty,
      by simp only [measure_empty, Union_false, Union_empty, diff_self]⟩ },
  haveI : inhabited α,
  { choose x hx using nonempty,
    exact ⟨x⟩ },
  -- 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 hr using this,
  -- 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.
  let t' := {a ∈ t | ∃ x, a ⊆ closed_ball x (r x)},
  -- 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 id ∧
    ∀ a ∈ t', ∃ b ∈ u, set.nonempty (a ∩ b) ∧ diam a ≤ 2 * diam b,
  { have A : ∀ (a : set α), a ∈ t' → diam a ≤ 2,
    { rintros a ⟨hat, ⟨x, hax⟩⟩,
      calc diam a ≤ diam (closed_ball x (r x)) : diam_mono hax bounded_closed_ball
      ... ≤ 2 * r x : diam_closed_ball (hr x).1.le
      ... ≤ 2 * 1 : mul_le_mul_of_nonneg_left (hr x).2.1 zero_le_two
      ... = 2 : by norm_num },
    have B : ∀ (a : set α), a ∈ t' → a.nonempty :=
      λ a hat', set.nonempty.mono interior_subset (ht a hat'.1),
    exact exists_disjoint_subfamily_covering_enlargment t' diam 2 one_lt_two
      (λ a ha, diam_nonneg) 2 A B },
  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 : countable u :=
    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 | (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 ⟨R, μR, hR⟩ : ∃ R, μ (closed_ball x R) < ∞ ∧
                          ∀ a ∈ u, (a ∩ ball x (r x)).nonempty → a ⊆ closed_ball x R,
  { have : ∀ a ∈ u, ∃ y, a ⊆ closed_ball y (r y) := λ a hau, (ut' hau).2,
    choose! y hy using this,
    have Idist_v : ∀ a ∈ v, dist (y a) x ≤ r (y a) + r x,
    { assume a hav,
      apply dist_le_add_of_nonempty_closed_ball_inter_closed_ball,
      exact hav.2.mono (inter_subset_inter (hy a hav.1) ball_subset_closed_ball) },
    set R0 := Sup ((λ a, r (y a)) '' v) with hR0,
    have R0_bdd : bdd_above ((λ a, r (y a)) '' v),
    { refine ⟨1, λ r' hr', _⟩,
      rcases (mem_image _ _ _).1 hr' with ⟨b, hb, rfl⟩,
      exact (hr _).2.1 },
    rcases le_total R0 (r x) with H|H,
    { refine ⟨20 * r x, (hr x).2.2, λ a au hax, _⟩,
      refine (hy a au).trans _,
      apply closed_ball_subset_closed_ball',
      have : r (y a) ≤ R0 := le_cSup R0_bdd (mem_image_of_mem _ ⟨au, hax⟩),
      linarith [(hr (y a)).1.le, (hr x).1.le, Idist_v a ⟨au, hax⟩] },
    { have R0pos : 0 < R0 := (hr x).1.trans_le H,
      have vnonempty : v.nonempty,
      { by_contra,
        rw [← ne_empty_iff_nonempty, not_not] at h,
        simp only [h, real.Sup_empty, image_empty] at hR0,
        exact lt_irrefl _ (R0pos.trans_le (le_of_eq hR0)) },
      obtain ⟨a, hav, R0a⟩ : ∃ a ∈ v, R0/2 < r (y a),
      { obtain ⟨r', r'mem, hr'⟩ : ∃ r' ∈ ((λ a, r (y a)) '' 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 (y a)).2.2,
        apply closed_ball_subset_closed_ball',
        rw dist_comm,
        linarith [Idist_v a hav] },
      { assume b bu hbx,
        refine (hy b bu).trans _,
        apply closed_ball_subset_closed_ball',
        have : r (y 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), _, le_antisymm (le_of_forall_le_of_dense (λ ε εpos, _)) bot_le⟩,
  { apply mem_nhds_within_of_mem_nhds (is_open_ball.mem_nhds _),
    simp only [(hr x).left, mem_ball, dist_self] },
  -- 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), μ a < ∞,
  { calc ∑' (a : v), μ a = μ (⋃ (a ∈ v), 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 R) : measure_mono (bUnion_subset (λ a ha, hR a (vu ha) ha.2))
    ... < ∞ : μR },
  -- 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}), μ a < ε / C,
  { haveI : ne_bot (at_top : filter (finset v)) := at_top_ne_bot,
    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 },
  choose! y hy using h,
  -- 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 : set α) (H : a ∈ u), a) ∩ ball x (r x)
    ⊆ ⋃ (a : {a // a ∉ w}), closed_ball (y a) (3 * diam (a : set α)),
  { assume z hz,
    set k := ⋃ (a : v) (ha : a ∈ w), (a : set α) 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_eq, 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 : set α) (H : a ∈ u), a) ∩ (⋃ (a : set α) (H : a ∈ u), 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, za, ad⟩ : ∃ a ∈ t, z ∈ a ∧ a ⊆ closed_ball z d :=
      hf z ((mem_diff _).1 (mem_of_mem_inter_left hz)).1 d dpos,
    have ax : a ⊆ ball x (r x) := ad.trans (hd.trans (diff_subset (ball x (r x)) k)),
    -- it intersects an element `b` of `u` with comparable diameter, by definition of `u`
    obtain ⟨b, bu, ab, bdiam⟩ : ∃ (b : set α) (H : b ∈ u), (a ∩ b).nonempty ∧ diam a ≤ 2 * diam b :=
      hu a ⟨hat, ⟨x, ax.trans ball_subset_closed_ball⟩⟩,
    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' : set α) ⊆ k := finset.subset_set_bUnion_of_mem b'w,
      have : ((ball x (r x) \ k) ∩ k).nonempty := ab.mono (inter_subset_inter (ad.trans hd) b'k),
      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 : z ∈ closed_ball (y b) (3 * diam b),
    { rcases ab with ⟨e, ⟨ea, eb⟩⟩,
      have A : dist z e ≤ diam a := dist_le_diam_of_mem (bounded_closed_ball.mono ad) za ea,
      have B : dist e (y b) ≤ diam b,
      { rcases (ut' bu).2 with ⟨c, hc⟩,
        apply dist_le_diam_of_mem (bounded_closed_ball.mono hc) eb (hy b (ut bu)).1 },
      simp only [mem_closed_ball],
      linarith [dist_triangle z e (y b)] },
    suffices H : closed_ball (y (b'' : set α)) (3 * diam (b'' : set α))
      ⊆ ⋃ (a : {a // a ∉ w}), closed_ball (y (a : set α)) (3 * diam (a : set α)), from H zb,
    exact subset_Union (λ (a : {a // a ∉ w}), closed_ball (y a) (3 * diam (a : set α))) 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 : set α) (H : a ∈ u), a) ∩ ball x (r x))
      ≤ μ (⋃ (a : {a // a ∉ w}), closed_ball (y a) (3 * diam (a : set α))) : measure_mono M
  ... ≤ ∑' (a : {a // a ∉ w}), μ (closed_ball (y a) (3 * diam (a : set α))) : measure_Union_le _
  ... ≤ ∑' (a : {a // a ∉ w}), C * μ a : ennreal.tsum_le_tsum (λ a, (hy a (ut (vu a.1.2))).2)
  ... = C * ∑' (a : {a // a ∉ w}), μ a : ennreal.tsum_mul_left
  ... ≤ C * (ε / C) : ennreal.mul_le_mul le_rfl 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 covering a fixed proportion `1/C`
of the ball `closed_ball x (3 * diam a)` 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 (ε > 0), ∃ r ∈ Ioc (0 : ℝ) ε, μ (closed_ball x (6 * r)) ≤ C * μ (closed_ball x r)) :
  vitali_family μ :=
{ sets_at := λ x, {a | x ∈ a ∧ is_closed a ∧ (interior a).nonempty ∧
                      μ (closed_ball x (3 * diam a)) ≤ C * μ a},
  measurable_set' := λ x a ha, ha.2.1.measurable_set,
  nonempty_interior := λ x a ha, ha.2.2.1,
  nontrivial := λ x ε εpos, begin
    obtain ⟨r, ⟨rpos, rε⟩, μr⟩ : ∃ r ∈ Ioc (0 : ℝ) ε,
      μ (closed_ball x (6 * r)) ≤ C * μ (closed_ball x r) := h x ε εpos,
    refine ⟨closed_ball x r, ⟨_, is_closed_ball, _, _⟩, closed_ball_subset_closed_ball rε⟩,
    { simp only [rpos.le, mem_closed_ball, dist_self] },
    { exact (nonempty_ball.2 rpos).mono (ball_subset_interior_closed_ball) },
    { apply le_trans (measure_mono (closed_ball_subset_closed_ball _)) μr,
      have : diam (closed_ball x r) ≤ 2 * r := diam_closed_ball rpos.le,
      linarith }
  end,
  covering := begin
    assume s f fsubset ffine,
    rcases eq_empty_or_nonempty s with rfl|H,
    { exact ⟨∅, λ _, ∅, by simp, by simp⟩ },
    haveI : inhabited α, { choose x hx using H, exact ⟨x⟩ },
    let t := ⋃ (x ∈ s), f x,
    have A₁ : ∀ x ∈ s, ∀ (ε : ℝ), 0 < ε → (∃ a ∈ t, x ∈ a ∧ a ⊆ closed_ball x ε),
    { assume x xs ε εpos,
      rcases ffine x xs ε εpos with ⟨a, xa, hax⟩,
      exact ⟨a, mem_bUnion xs xa, (fsubset x xs xa).1, hax⟩ },
    have A₂ : ∀ a ∈ t, (interior a).nonempty,
    { rintros a ha,
      rcases mem_bUnion_iff.1 ha with ⟨x, xs, xa⟩,
      exact (fsubset x xs xa).2.2.1 },
    have A₃ : ∀ a ∈ t, is_closed a,
    { rintros a ha,
      rcases mem_bUnion_iff.1 ha with ⟨x, xs, xa⟩,
      exact (fsubset x xs xa).2.1 },
    have A₄ : ∀ a ∈ t, ∃ x ∈ a, μ (closed_ball x (3 * diam a)) ≤ C * μ a,
    { rintros a ha,
      rcases mem_bUnion_iff.1 ha with ⟨x, xs, xa⟩,
      exact ⟨x, (fsubset x xs xa).1, (fsubset x xs xa).2.2.2⟩ },
    obtain ⟨u, ut, u_count, u_disj, μu⟩ :
      ∃ u ⊆ t, u.countable ∧ u.pairwise disjoint ∧ μ (s \ ⋃ a ∈ u, a) = 0 :=
        exists_disjoint_covering_ae μ s t A₁ A₂ A₃ C A₄,
    have : ∀ a ∈ u, ∃ x ∈ s, a ∈ f x := λ a ha, mem_bUnion_iff.1 (ut ha),
    choose! x hx using this,
    have inj_on_x : inj_on x u,
    { assume a ha b hb hab,
      have A : (a ∩ b).nonempty,
      { refine ⟨x a, mem_inter ((fsubset _ (hx a ha).1 (hx a ha).2).1) _⟩,
        rw hab,
        exact (fsubset _ (hx b hb).1 (hx b hb).2).1 },
      contrapose A,
      have : disjoint a b := u_disj a ha b hb A,
      simpa only [← not_disjoint_iff_nonempty_inter] },
    refine ⟨x '' u, function.inv_fun_on x u, _, _, _, _⟩,
    { assume y hy,
      rcases (mem_image _ _ _).1 hy with ⟨a, au, rfl⟩,
      exact (hx a au).1 },
    { rw [inj_on_x.pairwise_disjoint_image],
      assume a ha b hb hab,
      simp only [function.on_fun, function.inv_fun_on_eq' inj_on_x, ha, hb, (∘)],
      exact u_disj a ha b hb hab },
    { assume y hy,
      rcases (mem_image _ _ _).1 hy with ⟨a, ha, rfl⟩,
      rw function.inv_fun_on_eq' inj_on_x ha,
      exact (hx a ha).2 },
    { rw [bUnion_image],
      convert μu using 3,
      exact bUnion_congr (λ a ha, function.inv_fun_on_eq' inj_on_x ha) }
  end }

end vitali


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import ring_theory.integral_closure
import ring_theory.localization.integral

/-!
# Integrally closed rings

An integrally closed domain `R` contains all the elements of `Frac(R)` that are
integral over `R`. A special case of integrally closed domains are the Dedekind domains.

## Main definitions

* `is_integrally_closed R` states `R` contains all integral elements of `Frac(R)`

## Main results

* `is_integrally_closed_iff K`, where `K` is a fraction field of `R`, states `R`
  is integrally closed iff it is the integral closure of `R` in `K`
-/

open_locale non_zero_divisors

/-- `R` is integrally closed if all integral elements of `Frac(R)` are also elements of `R`.

This definition uses `fraction_ring R` to denote `Frac(R)`. See `is_integrally_closed_iff`
if you want to choose another field of fractions for `R`.
-/
class is_integrally_closed (R : Type*) [comm_ring R] [is_domain R] : Prop :=
(algebra_map_eq_of_integral :
  ∀ {x : fraction_ring R}, is_integral R x → ∃ y, algebra_map R (fraction_ring R) y = x)

section iff

variables {R : Type*} [comm_ring R] [is_domain R]
variables (K : Type*) [field K] [algebra R K] [is_fraction_ring R K]

/-- `R` is integrally closed iff all integral elements of its fraction field `K`
are also elements of `R`. -/
theorem is_integrally_closed_iff :
  is_integrally_closed R ↔ ∀ {x : K}, is_integral R x → ∃ y, algebra_map R K y = x :=
begin
  let e : K ≃ₐ[R] fraction_ring R := is_localization.alg_equiv R⁰_ _,
  split,
  { rintros ⟨cl⟩,
    refine λ x hx, _,
    obtain ⟨y, hy⟩ := cl ((is_integral_alg_equiv e).mpr hx),
    exact ⟨y, e.algebra_map_eq_apply.mp hy⟩ },
  { rintros cl,
    refine ⟨λ x hx, _⟩,
    obtain ⟨y, hy⟩ := cl ((is_integral_alg_equiv e.symm).mpr hx),
    exact ⟨y, e.symm.algebra_map_eq_apply.mp hy⟩ },
end

/-- `R` is integrally closed iff it is the integral closure of itself in its field of fractions. -/
theorem is_integrally_closed_iff_is_integral_closure :
  is_integrally_closed R ↔ is_integral_closure R R K :=
(is_integrally_closed_iff K).trans $
begin
  let e : K ≃ₐ[R] fraction_ring R := is_localization.alg_equiv R⁰_ _,
  split,
  { intros cl,
    refine ⟨is_fraction_ring.injective _ _, λ x, ⟨cl, _⟩⟩,
    rintros ⟨y, y_eq⟩,
    rw ← y_eq,
    exact is_integral_algebra_map },
  { rintros ⟨-, cl⟩ x hx,
    exact cl.mp hx }
end

end iff

namespace is_integrally_closed

variables {R : Type*} [comm_ring R] [is_domain R] [iic : is_integrally_closed R]
variables {K : Type*} [field K] [algebra R K] [is_fraction_ring R K]

instance : is_integral_closure R R K :=
(is_integrally_closed_iff_is_integral_closure K).mp iic

include iic

lemma is_integral_iff {x : K} : is_integral R x ↔ ∃ y, algebra_map R K y = x :=
is_integral_closure.is_integral_iff

omit iic
variables {R} (K)
lemma integral_closure_eq_bot_iff :
  integral_closure R K = ⊥ ↔ is_integrally_closed R :=
begin
  refine eq_bot_iff.trans _,
  split,
  { rw is_integrally_closed_iff K,
    intros h x hx,
    exact set.mem_range.mp (algebra.mem_bot.mp (h hx)),
    assumption },
  { intros h x hx,
    rw [algebra.mem_bot, set.mem_range],
    exactI is_integral_iff.mp hx },
end

include iic
variables (R K)
@[simp] lemma integral_closure_eq_bot : integral_closure R K = ⊥ :=
(integral_closure_eq_bot_iff K).mpr ‹_›

end is_integrally_closed

namespace integral_closure

open is_integrally_closed

variables {R : Type*} [comm_ring R] [is_domain R] [iic : is_integrally_closed R]
variables (K : Type*) [field K] [algebra R K] [is_fraction_ring R K]
variables {L : Type*} [field L] [algebra K L] [algebra R L] [is_scalar_tower R K L]

-- Can't be an instance because you need to supply `K`.
lemma is_integrally_closed_of_finite_extension [finite_dimensional K L] :
  is_integrally_closed (integral_closure R L) :=
begin
  letI : is_fraction_ring (integral_closure R L) L := is_fraction_ring_of_finite_extension K L,
  exact (integral_closure_eq_bot_iff L).mp integral_closure_idem
end

end integral_closure


import logic.basic

variable {α : Type}

lemma forall_iff_forall {P Q : α → Prop} :
  (∀ a, P a ↔ Q a) → ((∀ a, P a) ↔ (∀ a, Q a)) :=
λ h, iff.intro
  (λ hP a, (h a).elim_left (hP _))
  (λ hQ a, (h a).elim_right (hQ _))

lemma exists_iff_exists {P Q : α → Prop} :
  (∀ a, P a ↔ Q a) → ((∃ a, P a) ↔ (∃ a, Q a)) :=
λ h, iff.intro
  (λ hP, begin cases hP with a ha, existsi a, apply (h a).elim_left ha end)
  (λ hQ, begin cases hQ with a ha, existsi a, apply (h a).elim_right ha end)

lemma or_iff_or {p p' q q' : Prop} :
  (p ↔ p') → (q ↔ q') → ((p ∨ q) ↔ (p' ∨ q')) :=
begin
  intros hp hq, rewrite hp, rewrite hq
end

lemma and_iff_and {p p' q q' : Prop} :
  (p ↔ p') → (q ↔ q') → ((p ∧ q) ↔ (p' ∧ q')) :=
begin intros hp hq, rewrite hp, rewrite hq end

lemma imp_of_imp (p) {q} : (p → q) → (p → q) := id

#exit
lemma not_true.elim : Π {C : Sort u}, ¬ true → C :=
λ _ h, false.elim (h trivial)

lemma not_and.elim :
  ∀ {a b c : Prop}, ¬(a ∧ b) → (¬a → c) → (¬b → c) → c :=
begin
  intros a b c h1 h2 h3,
  cases (@classical.or_not a) with ha ha,
  apply (h3 $ λ hb, h1 ⟨ha,hb⟩), apply h2 ha
end

lemma not_or.elim
  : ∀ {a b c : Prop}, ¬(a ∨ b) → (¬a → ¬b → c) → c :=
begin
  intros a b c h1 h2, rw not_or_distrib at h1,
  cases h1, apply h2; assumption
end

lemma imp.elim :
  ∀ {a b c : Prop}, (a → b) → (¬a → c) → (b → c) → c :=
begin
  intros a b c h1 h2 h3,
  cases (@classical.or_not a) with ha ha,
  apply (h3 $ h1 ha), apply h2 ha
end

lemma not_imp.elim
  : ∀ {a b c : Prop}, ¬(a → b) → (a → ¬b → c) → c :=
begin
  intros a b c h1 h2,
  cases (@classical.or_not b) with hb hb,
  exfalso, apply (h1 $ λ _, hb),
  cases (@classical.or_not a) with ha ha,
  apply (h2 ha hb), exfalso,
  apply (h1 $ λ ha', false.elim $ ha ha'),
end

lemma not_forall.elim :
  ∀ {α : Sort u} {p : α → Prop} {b : Prop},
  (¬ ∀ (x : α), p x) → (∀ (a : α), (¬ p a) → b) → b :=
begin
  intros α p b h1 h2, rw classical.not_forall at h1,
  cases h1 with a ha, apply h2 _ ha
end

variables {p q : Prop}

lemma not_or_not_of_not_and :
  ¬ (p ∧ q) → (¬ p ∨ ¬ q) :=
λ h, @classical.by_cases p (¬ p ∨ ¬ q)
  (λ hp, or.inr (λ hq, h $ and.intro hp hq))
  (λ hnp, or.inl hnp)

lemma not_or_left : ¬ (p ∨ q) → ¬ p :=
λ h, (not_or_distrib.elim_left h).left

lemma not_or_right : ¬ (p ∨ q) → ¬ q :=
λ h, (not_or_distrib.elim_left h).right

lemma not_or_of_imp_cls : (p → q) → ¬p ∨ q :=
@not_or_of_imp p q (classical.dec p)

lemma not_imp_left : ¬ (p → q) → p :=
λ h, ((@not_imp _ _ (classical.dec _)).elim_left h).left

lemma not_imp_right : ¬ (p → q) → ¬ q :=
λ h, ((@not_imp _ _ (classical.dec _)).elim_left h).right

lemma iff_of_left_of_right : p → q → (p ↔ q) :=
λ hp hq, iff.intro (λ _, hq) (λ _, hp)

variables {α : Type}


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.big_operators.basic
import data.sym.sym2

/-!
# Stars and bars

In this file, we prove the case `n = 2` of stars and bars.

## Informal statement

If we have `n` objects to put in `k` boxes, we can do so in exactly `(n + k - 1).choose n` ways.

## Formal statement

We can identify the `k` boxes with the elements of a fintype `α` of card `k`. Then placing `n`
elements in those boxes corresponds to choosing how many of each element of `α` appear in a multiset
of card `n`. `sym α n` being the subtype of `multiset α` of multisets of card `n`, writing stars
and bars using types gives
```lean
-- TODO: this lemma is not yet proven
lemma stars_and_bars {α : Type*} [fintype α] (n : ℕ) :
  card (sym α n) = (card α + n - 1).choose (card α) := sorry
```

## TODO

Prove the general case of stars and bars.

## Tags

stars and bars
-/

open finset fintype

namespace sym2
variables {α : Type*} [decidable_eq α]

/-- The `diag` of `s : finset α` is sent on a finset of `sym2 α` of card `s.card`. -/
lemma card_image_diag (s : finset α) :
  (s.diag.image quotient.mk).card = s.card :=
begin
  rw [card_image_of_inj_on, diag_card],
  rintro ⟨x₀, x₁⟩ hx _ _ h,
  cases quotient.eq.1 h,
  { refl },
  { simp only [mem_coe, mem_diag] at hx,
    rw hx.2 }
end

lemma two_mul_card_image_off_diag (s : finset α) :
  2 * (s.off_diag.image quotient.mk).card = s.off_diag.card :=
begin
  rw [card_eq_sum_card_fiberwise
    (λ x, mem_image_of_mem _ : ∀ x ∈ s.off_diag, quotient.mk x ∈ s.off_diag.image quotient.mk),
    sum_const_nat (quotient.ind _), mul_comm],
  rintro ⟨x, y⟩ hxy,
  simp_rw [mem_image, exists_prop, mem_off_diag, quotient.eq] at hxy,
  obtain ⟨a, ⟨ha₁, ha₂, ha⟩, h⟩ := hxy,
  obtain ⟨hx, hy, hxy⟩ : x ∈ s ∧ y ∈ s ∧ x ≠ y,
  { cases h; have := ha.symm; exact ⟨‹_›, ‹_›, ‹_›⟩ },
  have hxy' : y ≠ x := hxy.symm,
  have : s.off_diag.filter (λ z, ⟦z⟧ = ⟦(x, y)⟧) = ({(x, y), (y, x)} : finset _),
  { ext ⟨x₁, y₁⟩,
    rw [mem_filter, mem_insert, mem_singleton, sym2.eq_iff, prod.mk.inj_iff, prod.mk.inj_iff,
      and_iff_right_iff_imp],
    rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩); rw mem_off_diag; exact ⟨‹_›, ‹_›, ‹_›⟩ }, -- hxy' is used here
  rw [this, card_insert_of_not_mem, card_singleton],
  simp only [not_and, prod.mk.inj_iff, mem_singleton],
  exact λ _, hxy',
end

/-- The `off_diag` of `s : finset α` is sent on a finset of `sym2 α` of card `s.off_diag.card / 2`.
This is because every element `⟦(x, y)⟧` of `sym2 α` not on the diagonal comes from exactly two
pairs: `(x, y)` and `(y, x)`. -/
lemma card_image_off_diag (s : finset α) :
  (s.off_diag.image quotient.mk).card = s.card.choose 2 :=
by rw [nat.choose_two_right, mul_tsub, mul_one, ←off_diag_card,
  nat.div_eq_of_eq_mul_right zero_lt_two (two_mul_card_image_off_diag s).symm]

lemma card_subtype_diag [fintype α] :
  card {a : sym2 α // a.is_diag} = card α :=
begin
  convert card_image_diag (univ : finset α),
  rw [fintype.card_of_subtype, ←filter_image_quotient_mk_is_diag],
  rintro x,
  rw [mem_filter, univ_product_univ, mem_image],
  obtain ⟨a, ha⟩ := quotient.exists_rep x,
  exact and_iff_right ⟨a, mem_univ _, ha⟩,
end

lemma card_subtype_not_diag [fintype α] :
  card {a : sym2 α // ¬a.is_diag} = (card α).choose 2 :=
begin
  convert card_image_off_diag (univ : finset α),
  rw [fintype.card_of_subtype, ←filter_image_quotient_mk_not_is_diag],
  rintro x,
  rw [mem_filter, univ_product_univ, mem_image],
  obtain ⟨a, ha⟩ := quotient.exists_rep x,
  exact and_iff_right ⟨a, mem_univ _, ha⟩,
end

protected lemma card [fintype α] :
  card (sym2 α) = card α * (card α + 1) / 2 :=
by rw [←fintype.card_congr (@equiv.sum_compl _ is_diag (sym2.is_diag.decidable_pred α)),
  fintype.card_sum, card_subtype_diag, card_subtype_not_diag, nat.choose_two_right, add_comm,
  ←nat.triangle_succ, nat.succ_sub_one, mul_comm]

end sym2


-- Sian's work on bundled subgroups

import group_theory.subgroup
import algebra.group.hom
import bundled_group_homs

/- functions banned from this file:

1) is_submonoid
2) is_subgroup
3) is_group_hom
4) is_monoid_hom

-/

-- we want

-- The place for easy lemmas about group homs is in the group_hom namespace
namespace group_hom

variables {G : Type*} {H : Type*} [group G] [group H]

@[extensionality] theorem ext {G : Type*} {H : Type*} [group G] [group H]
  {f f' : G →* H} (H : ∀ (x : G), f x = f' x) : f = f' :=
by cases f; cases f'; congr'; exact funext H

theorem ext_iff {f f' : G →* H} : f = f' ↔ ∀ x, f x = f' x :=
⟨by rintro rfl; simp, ext⟩

variable (f : G →* H)

@[simp] lemma map_mul : ∀ (x y : G), f (x * y) = f x * f y := f.map_mul

@[simp] lemma map_one : f 1 = 1 := f.map_one

end group_hom -- namespace

-- bundled submonoids!
set_option old_structure_cmd true
structure submonoid (M : Type*) [monoid M] :=
(carrier : set M)
(one_mem : (1 : M) ∈ carrier)
(mul_mem {a b} : a ∈ carrier → b ∈ carrier → a * b ∈ carrier)

variables {M : Type*} [monoid M]

instance submonoid.has_coe : has_coe (submonoid M) (set M) := ⟨submonoid.carrier⟩

-- bundled subgroups
structure subgroup (G : Type*) [group G] extends submonoid G :=
(inv_mem {a} : a ∈ carrier → a⁻¹ ∈ carrier)

variables {G : Type*} [group G] {H : Type*} [group H]

instance : has_mem G (subgroup G) := ⟨λ g H, g ∈ H.carrier⟩

namespace subgroup

instance (K : subgroup G) : is_subgroup K.carrier :=
{ one_mem := K.one_mem,
  mul_mem := K.mul_mem,
  inv_mem := K.inv_mem }

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

theorem ext' {G : Type*} [group G] (H K : subgroup G) : H = K ↔ (H : set G) = (K : set G) :=
begin
  cases H;cases K,
  unfold_coes,
  simp,
end

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

definition map (f : G →* H) (G1 : subgroup G) : subgroup H :=
{ carrier := f '' (G1 : set G),
  one_mem := begin
    use 1,
    split,
    {
      exact G1.one_mem,
    },
    {
      exact group_hom.map_one f,
    }
  end,
  mul_mem := begin
    rintro j k ⟨j', hj', rfl⟩ ⟨k', hk', rfl⟩,
    rw [← group_hom.map_mul f j' k'],
    use j'*k',
    split,
      apply G1.mul_mem,
        assumption,
      assumption,
    refl,
  end,
  inv_mem := begin
    rintro j ⟨j', hj', rfl⟩,
    rw [←f.map_inv j'],
    use j'⁻¹,
    split,
      apply subgroup.inv_mem,
      assumption,
    refl,
  end
}

definition comap (f : G →* H) (H1 : subgroup H) : subgroup G :=
{ carrier := f ⁻¹' (H1 : set H),
  one_mem := begin
  unfold set.preimage,
  dsimp,
  rw monoid_hom.map_one f,
  apply subgroup.one_mem,
  end,
  mul_mem := begin
   intros,
  unfold set.preimage,
  dsimp,
  rw monoid_hom.map_mul f,
  apply subgroup.mul_mem,
    assumption,
  assumption,
  end,
  inv_mem := begin
  intros,
  unfold set.preimage,
  dsimp,
  rw f.map_inv,
  apply subgroup.inv_mem,
  assumption,
  end
}

end subgroup

def is_normal_subgroup {G : Type*} [group G] (S : subgroup G) :=
normal_subgroup S.carrier

theorem is_normal_subgroup_def {G : Type*} [group G] (S : subgroup G) :
  is_normal_subgroup S ↔ (∀ n : G, n ∈ S → ∀ g : G, g * n * g⁻¹ ∈ S) :=
begin
  split,
    intro h,
    cases h,
    exact h_normal,
  intro h,
  constructor,
  exact h
end


open classical

variables p q r s : Prop

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p :=
  iff.intro
    (assume h : p ∧ q,
      show q ∧ p, from ⟨h.right, h.left⟩)
    (assume h : q ∧ p,
      show p ∧ q, from ⟨h.right, h.left⟩)
example : p ∨ q ↔ q ∨ p :=
  iff.intro
    (assume h : p ∨ q,
      show q ∨ p, from or.elim h
      (assume hp : p,
        show q ∨ p, from or.inr hp)
      (assume hq : q,
        show q ∨ p, from or.inl hq)
    )
    (assume h : q ∨ p,
      show p ∨ q, from or.elim h
      (assume hq : q,
        show p ∨ q, from or.inr hq)
      (assume hp : p,
        show p ∨ q, from or.inl hp))

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
  iff.intro
    (assume h : (p ∧ q) ∧ r,
      have hp : p, from h.left.left,
      have hq : q, from h.left.right,
      have hr : r, from h.right,
    show p ∧ (q ∧ r), from ⟨ hp, ⟨ hq, hr ⟩ ⟩)
    (assume h : p ∧ (q ∧ r),
      have hp : p, from h.left,
      have hq : q, from h.right.left,
      have hr : r, from h.right.right,
    show (p ∧ q) ∧ r, from ⟨ ⟨ hp, hq ⟩, hr ⟩)
example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
  iff.intro
    (assume h : (p ∨ q) ∨ r,
      show p ∨ (q ∨ r), from or.elim h
      (assume hl : p ∨ q,
        show p ∨ (q ∨ r), from or.elim hl
        (assume hp : p,
        show p ∨ (q ∨ r), from or.intro_left (q ∨ r) hp)
        (assume hq : q,
        show p ∨ (q ∨ r), from or.intro_right p (or.intro_left r hq)
        ))
      (assume hr : r,
        show p ∨ (q ∨ r), from or.intro_right p (or.intro_right q hr)))
    (assume h : p ∨ (q ∨ r),
      show (p ∨ q) ∨ r, from or.elim h
      (assume hr : p,
        show (p ∨ q) ∨ r, from or.intro_left r (or.intro_left q hr))
      (assume hl : q ∨ r,
        show (p ∨ q) ∨ r, from or.elim hl
        (assume hq : q,
          show (p ∨ q) ∨ r, from or.intro_left r (or.intro_right p hq))
        (assume hr : r,
          show (p ∨ q) ∨ r, from or.intro_right (p ∨ q) hr)))

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
  iff.intro
    (assume h : p ∧ (q ∨ r),
      have hp : p, from and.elim_left h,
      have hqr : q ∨ r, from and.elim_right h,
      show (p ∧ q) ∨ (p ∧ r), from or.elim hqr
        (assume hq : q,
          show (p ∧ q) ∨ (p ∧ r), from or.intro_left (p ∧ r) (and.intro hp hq))
        (assume hr : r,
          show (p ∧ q) ∨ (p ∧ r), from or.intro_right (p ∧ q) (and.intro hp hr)))
    (assume h : (p ∧ q) ∨ (p ∧ r),
      or.elim h
      (assume hpq : p ∧ q,
        show p ∧ (q ∨ r), from ⟨ hpq.left, or.inl hpq.right ⟩ )
      (assume hpr : p ∧ r,
        show p ∧ (q ∨ r), from ⟨ hpr.left, or.inr hpr.right ⟩ ))
example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
  iff.intro
    (assume h : p ∨ (q ∧ r),
      or.elim h
        (assume hp : p,
          show (p ∨ q) ∧ (p ∨ r), from ⟨ or.inl hp, or.inl hp ⟩)
        (assume qr : q ∧ r,
          show (p ∨ q) ∧ (p ∨ r), from ⟨ or.inr qr.left, or.inr qr.right ⟩))
    (assume h : (p ∨ q) ∧ (p ∨ r),
      have pq : p ∨ q, from h.left,
      have pr : p ∨ r, from h.right,
      show p ∨ (q ∧ r), from
      pq.elim
        (assume hp : p,
          or.inl hp)
        (assume hq : q,
          pr.elim
            (assume hp : p,
              show p ∨ (q ∧ r), from or.inl hp)
            (assume hr : r,
              show p ∨ (q ∧ r), from or.inr ⟨ hq, hr ⟩)))

-- -- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) :=
  iff.intro
    (assume h : p → (q → r),
      assume hpq : p ∧ q,
      have hp : p, from hpq.left,
      have hq : q, from hpq.right,
      show r, from h hp hq)
    (assume h : p ∧ q → r,
      assume hp : p,
      assume hq : q,
      show r, from h ⟨ hp, hq ⟩)
example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
  iff.intro
    (assume h : (p ∨ q) → r,
      and.intro
        (assume hp : p,
          have hpq : p ∨ q, from or.inl hp,
          show r, from h hpq)
        (assume hq : q,
          have hpq : p ∨ q, from or.inr hq,
          show r, from h hpq))
    (assume h : (p → r) ∧ (q → r),
      assume hpq : p ∨ q,
      hpq.elim
        (assume hp : p,
          show r, from h.left hp)
        (assume hq : q,
          show r, from h.right hq))
example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
  iff.intro
    (assume h : ¬(p ∨ q),
      and.intro
        (assume hp : p,
          have hpq : p ∨ q, from or.inl hp,
          absurd hpq h)
        (assume hq : q,
          have hpq : p ∨ q, from or.inr hq,
          absurd hpq h))
    (assume h : ¬p ∧ ¬q,
      have hnp : ¬p, from h.left,
      have hnq : ¬q, from h.right,
      assume hpq : p ∨ q,
      hpq.elim
        (assume hp : p,
          absurd hp hnp)
        (assume hq : q,
          absurd hq hnq))
example : ¬p ∨ ¬q → ¬(p ∧ q) :=
  assume hnpnq : ¬p ∨ ¬q,
  hnpnq.elim
    (assume hnp : ¬p,
      assume hpq : p ∧ q,
      absurd hpq.left hnp)
    (assume hnq : ¬q,
      assume hpq : p ∧ q,
      absurd hpq.right hnq)
example : ¬(p ∧ ¬p) :=
  assume hpnp : p ∧ ¬p,
  absurd hpnp.left hpnp.right
example : p ∧ ¬q → ¬(p → q) :=
  assume hpnq : p ∧ ¬q,
  assume hpiq : p → q,
  have hp : p, from hpnq.left,
  have hnq : ¬q, from hpnq.right,
  absurd (hpiq hp) hnq
example : ¬p → (p → q) :=
  assume hnp : ¬p,
  assume hp : p,
  show q, from absurd hp hnp
example : (¬p ∨ q) → (p → q) :=
  assume hnpq : ¬p ∨ q,
  assume hp : p,
  hnpq.elim
    (assume hnp : ¬p,
      show q, from absurd hp hnp)
    (assume hq : q,
      show q, from hq)
example : p ∨ false ↔ p :=
  iff.intro
    (assume hpf : p ∨ false,
      hpf.elim
        (assume hp : p,
          hp)
        (assume hf : false,
          hf.elim))
    (assume hp : p,
      show p ∨ false, from or.inl hp)
example : p ∧ false ↔ false :=
  iff.intro
    (assume hpf : p ∧ false,
      show false, from hpf.right)
    (assume hf : false,
      show p ∧ false, from hf.elim)
example : ¬(p ↔ ¬p) :=
  assume h : p ↔ ¬p,
  have hnp : ¬p, from (
    assume hp : p,
    have hnp' : ¬p, from h.elim_left hp,
    absurd hp hnp'
  ),
  have hp : p, from h.elim_right hnp,
  show false, from hnp hp
example : (p → q) → (¬q → ¬p) :=
  assume hpiq : p → q,
  assume hnq : ¬q,
  assume hp : p,
  absurd (hpiq hp) hnq

-- -- these require classical reasoning
example : (p → r ∨ s) → ((p → r) ∨ (p → s)) :=
  assume hpirs : p → r ∨ s,
  by_cases
    (assume hp : p,
      have hrs : r ∨ s, from hpirs hp,
      hrs.elim
        (assume hr : r,
          show (p → r) ∨ (p → s), from or.inl (assume hp : p, hr))
        (assume hs : s,
          show (p → r) ∨ (p → s), from or.inr (assume hp : p, hs)))
    (assume hnp : ¬p,
      or.inl (show p → r, from assume hp : p, absurd hp hnp))
example : ¬(p ∧ q) → ¬p ∨ ¬q :=
  assume hnpq : ¬(p ∧ q),
  show ¬p ∨ ¬q, from (
    by_cases
      (assume hp : p,
        have hnq : ¬q, from (
          assume hq : q,
          absurd (and.intro hp hq) hnpq
        ),
        or.inr hnq)
      (assume hnp : ¬p,
        or.inl hnp)
  )
example : ¬(p → q) → p ∧ ¬q :=
  assume hnpiq : ¬(p → q),
  show p ∧ ¬q, from
  by_cases
    (
      assume hq : q,
      have hpiq : p → q, from (
        assume hp : p,
        show q, from hq),
      absurd hpiq hnpiq
    )(
      assume hnq : ¬q,
      by_cases
        (assume hp : p,
          ⟨ hp, hnq ⟩)
        (assume hnp : ¬p,
          have hpiq : p → q,
          from (assume hp : p, absurd hp hnp),
          absurd hpiq hnpiq)
    )
example : (p → q) → (¬p ∨ q) :=
  assume hpiq : p → q,
  by_cases
    (assume hp : p,
      show ¬p ∨ q, from or.inr (hpiq hp))
    (assume hnp : ¬p,
      show ¬p ∨ q, from or.inl hnp)
example : (¬q → ¬p) → (p → q) :=
  assume hnqinp : ¬q → ¬p,
  by_cases
    (assume hq : q,
      assume hp : p,
      hq)
    (assume hnq : ¬q,
      assume hp : p,
      have hnp : ¬p, from hnqinp hnq,
      absurd hp hnp)
example : p ∨ ¬p :=
  by_cases
    (assume hp : p, or.inl hp)
    (assume hnp : ¬p, or.inr hnp)
example : (((p → q) → p) → p) :=
  assume hpqp : (p → q) → p,
  by_cases
    (assume hp : p,
      show p, from hp)
    (assume hnp : ¬p,
      show p, from hpqp (assume hp : p, show q, from absurd hp hnp))

-- and also in classical logic
example : ¬(p ↔ ¬p) :=
  assume h : p ↔ ¬p,
  by_cases
    (assume hp : p,
      have hnp : ¬p, from h.elim_left hp,
      absurd hp hnp)
    (assume hnp : ¬p,
      have hp : p, from h.elim_right hnp,
      absurd hp hnp)


import data.real.sqrt tactic.fin_cases

/-! # IMO 2020 A3 -/

namespace IMOSL
namespace IMO2020A3

open real

private lemma AM_GM_sqrt {a b : ℝ} (h : 0 ≤ a) (h0 : 0 ≤ b) : 2 * sqrt (a * b) ≤ a + b :=
begin
  have h1 := two_mul_le_add_sq (sqrt a) (sqrt b),
  rwa [sq_sqrt h, sq_sqrt h0, mul_assoc, ← sqrt_mul h] at h1
end

/-- Final solution -/
theorem final_solution :
  is_least
    ((λ x : fin 4 → ℝ, x 0 / x 1 + x 1 / x 2 + x 2 / x 3 + x 3 / x 0) ''
      {x | (∀ i : fin 4, 0 < x i) ∧ (x 0 + x 2) * (x 1 + x 3) = x 0 * x 2 + x 1 * x 3})
    8 :=
begin
  refine ⟨_, λ a h, _⟩,
  { obtain ⟨c, h, h0⟩ : ∃ c : ℝ, 0 < c ∧ c + 1 / c = 4 :=
    begin
      have X : 0 < 2 + sqrt 3 := add_pos_of_pos_of_nonneg two_pos (sqrt_nonneg 3),
      refine ⟨2 + sqrt 3, X, _⟩,
      rw [add_div' _ _ _ (ne_of_gt X), div_eq_iff (ne_of_gt X),
          ← sq, add_sq, sq_sqrt, add_assoc, sq, two_mul],
      change (4 + 4 * sqrt 3 + (2 + 1 + 1) = _),
      rw [add_assoc (2 : ℝ), add_right_comm, ← bit0, ← bit0, ← mul_two, ← mul_add],
      norm_num
    end,
    have h1 : c ≠ 0 := ne_of_gt h,
    refine ⟨![c, 1, c, 1], ⟨λ i, _, _⟩, _⟩,
    fin_cases i; simp; assumption,
    simp; rw [← mul_two, ← bit0, mul_assoc, ← div_left_inj' h1, add_div,
      mul_div_cancel_left _ h1, mul_div_cancel_left _ h1, h0, two_mul, ← bit0],
    simp; rw [inv_eq_one_div, add_assoc, h0, ← bit0] },
  { rcases h with ⟨x, ⟨h, h0⟩, rfl⟩; simp only [],
    rw [add_assoc, add_add_add_comm],
    have Y : ∀ i j, 0 ≤ x i / x j := λ i j, le_of_lt (div_pos (h i) (h j)),
    refine le_trans _ (add_le_add (AM_GM_sqrt (Y 0 1) (Y 2 3)) (AM_GM_sqrt (Y 1 2) (Y 3 0))),
    rw [← mul_add, bit0, ← two_mul, mul_le_mul_left, div_mul_div_comm, div_mul_div_comm],
    replace Y : ∀ i j, 0 ≤ x i * x j := λ i j, le_of_lt (mul_pos (h i) (h j)),
    have Z : ∀ i j, sqrt (x i * x j) ≠ 0 := λ i j, sqrt_ne_zero'.mpr (mul_pos (h i) (h j)),
    rw [sqrt_div (Y 0 2), sqrt_div (Y 1 3), mul_comm (x 2), div_add_div _ _ (Z 1 3) (Z 0 2),
        ← sq, sq_sqrt (Y 0 2), ← sq, sq_sqrt (Y 1 3), ← h0, mul_comm, le_div_iff, bit0,
        ← two_mul, mul_mul_mul_comm],
    clear Y Z; have Y : ∀ i, 0 ≤ x i := λ i, le_of_lt (h i),
    refine mul_le_mul _ _ (mul_nonneg zero_le_two (sqrt_nonneg _)) (add_nonneg (Y _) (Y _));
      exact AM_GM_sqrt (Y _) (Y _),
    apply mul_pos; rw sqrt_pos; apply mul_pos; exact h _,
    exact two_pos }
end

end IMO2020A3
end IMOSL


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

! This file was ported from Lean 3 source module number_theory.zsqrtd.to_real
! leanprover-community/mathlib commit e59154361202a34b26176e0de9267ef8e2dcd446
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Real.Sqrt
import Mathlib.NumberTheory.Zsqrtd.Basic

/-!
# Image of `Zsqrtd` in `ℝ`

This file defines `Zsqrtd.toReal` and related lemmas.
It is in a separate file to avoid pulling in all of `Data.Real` into `Data.Zsqrtd`.
-/

namespace Zsqrtd

/-- The image of `Zsqrtd` in `ℝ`, using `Real.sqrt` which takes the positive root of `d`.

If the negative root is desired, use `toReal h (star a)`. -/
@[simps!]
noncomputable def toReal {d : ℤ} (h : 0 ≤ d) : ℤ√d →+* ℝ :=
  lift ⟨Real.sqrt d, Real.mul_self_sqrt (Int.cast_nonneg.mpr h)⟩
#align zsqrtd.to_real Zsqrtd.toReal

theorem toReal_injective {d : ℤ} (h0d : 0 ≤ d) (hd : ∀ n : ℤ, d ≠ n * n) :
    Function.Injective (toReal h0d) :=
  lift_injective _ hd
#align zsqrtd.to_real_injective Zsqrtd.toReal_injective

end Zsqrtd