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

! This file was ported from Lean 3 source module analysis.complex.upper_half_plane.metric
! leanprover-community/mathlib commit f06058e64b7e8397234455038f3f8aec83aaba5a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Complex.UpperHalfPlane.Topology
import Mathbin.Analysis.SpecialFunctions.Arsinh
import Mathbin.Geometry.Euclidean.Inversion

/-!
# Metric on the upper half-plane

In this file we define a `metric_space` structure on the `upper_half_plane`. We use hyperbolic
(Poincaré) distance given by
`dist z w = 2 * arsinh (dist (z : ℂ) w / (2 * real.sqrt (z.im * w.im)))` instead of the induced
Euclidean distance because the hyperbolic distance is invariant under holomorphic automorphisms of
the upper half-plane. However, we ensure that the projection to `topological_space` is
definitionally equal to the induced topological space structure.

We also prove that a metric ball/closed ball/sphere in Poincaré metric is a Euclidean ball/closed
ball/sphere with another center and radius.

-/

noncomputable section

open UpperHalfPlane ComplexConjugate NNReal Topology MatrixGroups

open Set Metric Filter Real

variable {z w : ℍ} {r R : ℝ}

namespace UpperHalfPlane

instance : Dist ℍ :=
  ⟨fun z w => 2 * arsinh (dist (z : ℂ) w / (2 * sqrt (z.im * w.im)))⟩

theorem dist_eq (z w : ℍ) : dist z w = 2 * arsinh (dist (z : ℂ) w / (2 * sqrt (z.im * w.im))) :=
  rfl
#align upper_half_plane.dist_eq UpperHalfPlane.dist_eq

theorem sinh_half_dist (z w : ℍ) :
    sinh (dist z w / 2) = dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) := by
  rw [dist_eq, mul_div_cancel_left (arsinh _) two_ne_zero, sinh_arsinh]
#align upper_half_plane.sinh_half_dist UpperHalfPlane.sinh_half_dist

theorem cosh_half_dist (z w : ℍ) :
    cosh (dist z w / 2) = dist (z : ℂ) (conj (w : ℂ)) / (2 * sqrt (z.im * w.im)) :=
  by
  have H₁ : (2 ^ 2 : ℝ) = 4 := by norm_num1
  have H₂ : 0 < z.im * w.im := mul_pos z.im_pos w.im_pos
  have H₃ : 0 < 2 * sqrt (z.im * w.im) := mul_pos two_pos (sqrt_pos.2 H₂)
  rw [← sq_eq_sq (cosh_pos _).le (div_nonneg dist_nonneg H₃.le), cosh_sq', sinh_half_dist, div_pow,
    div_pow, one_add_div (pow_ne_zero 2 H₃.ne'), mul_pow, sq_sqrt H₂.le, H₁]
  congr 1
  simp only [Complex.dist_eq, Complex.sq_abs, Complex.normSq_sub, Complex.normSq_conj,
    Complex.conj_conj, Complex.mul_re, Complex.conj_re, Complex.conj_im, coe_im]
  ring
#align upper_half_plane.cosh_half_dist UpperHalfPlane.cosh_half_dist

theorem tanh_half_dist (z w : ℍ) : tanh (dist z w / 2) = dist (z : ℂ) w / dist (z : ℂ) (conj ↑w) :=
  by
  rw [tanh_eq_sinh_div_cosh, sinh_half_dist, cosh_half_dist, div_div_div_comm, div_self, div_one]
  exact (mul_pos (zero_lt_two' ℝ) (sqrt_pos.2 <| mul_pos z.im_pos w.im_pos)).ne'
#align upper_half_plane.tanh_half_dist UpperHalfPlane.tanh_half_dist

theorem exp_half_dist (z w : ℍ) :
    exp (dist z w / 2) = (dist (z : ℂ) w + dist (z : ℂ) (conj ↑w)) / (2 * sqrt (z.im * w.im)) := by
  rw [← sinh_add_cosh, sinh_half_dist, cosh_half_dist, add_div]
#align upper_half_plane.exp_half_dist UpperHalfPlane.exp_half_dist

theorem cosh_dist (z w : ℍ) : cosh (dist z w) = 1 + dist (z : ℂ) w ^ 2 / (2 * z.im * w.im) := by
  rw [dist_eq, cosh_two_mul, cosh_sq', add_assoc, ← two_mul, sinh_arsinh, div_pow, mul_pow,
    sq_sqrt (mul_pos z.im_pos w.im_pos).le, sq (2 : ℝ), mul_assoc, ← mul_div_assoc, mul_assoc,
    mul_div_mul_left _ _ (two_ne_zero' ℝ)]
#align upper_half_plane.cosh_dist UpperHalfPlane.cosh_dist

theorem sinh_half_dist_add_dist (a b c : ℍ) :
    sinh ((dist a b + dist b c) / 2) =
      (dist (a : ℂ) b * dist (c : ℂ) (conj ↑b) + dist (b : ℂ) c * dist (a : ℂ) (conj ↑b)) /
        (2 * sqrt (a.im * c.im) * dist (b : ℂ) (conj ↑b)) :=
  by
  simp only [add_div _ _ (2 : ℝ), sinh_add, sinh_half_dist, cosh_half_dist, div_mul_div_comm]
  rw [← add_div, Complex.dist_self_conj, coe_im, abs_of_pos b.im_pos, mul_comm (dist ↑b _),
    dist_comm (b : ℂ), Complex.dist_conj_comm, mul_mul_mul_comm, mul_mul_mul_comm _ _ _ b.im]
  congr 2
  rw [sqrt_mul, sqrt_mul, sqrt_mul, mul_comm (sqrt a.im), mul_mul_mul_comm, mul_self_sqrt,
      mul_comm] <;>
    exact (im_pos _).le
#align upper_half_plane.sinh_half_dist_add_dist UpperHalfPlane.sinh_half_dist_add_dist

protected theorem dist_comm (z w : ℍ) : dist z w = dist w z := by
  simp only [dist_eq, dist_comm (z : ℂ), mul_comm]
#align upper_half_plane.dist_comm UpperHalfPlane.dist_comm

theorem dist_le_iff_le_sinh :
    dist z w ≤ r ↔ dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) ≤ sinh (r / 2) := by
  rw [← div_le_div_right (zero_lt_two' ℝ), ← sinh_le_sinh, sinh_half_dist]
#align upper_half_plane.dist_le_iff_le_sinh UpperHalfPlane.dist_le_iff_le_sinh

theorem dist_eq_iff_eq_sinh :
    dist z w = r ↔ dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) = sinh (r / 2) := by
  rw [← div_left_inj' (two_ne_zero' ℝ), ← sinh_inj, sinh_half_dist]
#align upper_half_plane.dist_eq_iff_eq_sinh UpperHalfPlane.dist_eq_iff_eq_sinh

theorem dist_eq_iff_eq_sq_sinh (hr : 0 ≤ r) :
    dist z w = r ↔ dist (z : ℂ) w ^ 2 / (4 * z.im * w.im) = sinh (r / 2) ^ 2 :=
  by
  rw [dist_eq_iff_eq_sinh, ← sq_eq_sq, div_pow, mul_pow, sq_sqrt, mul_assoc]
  · norm_num
  · exact (mul_pos z.im_pos w.im_pos).le
  · exact div_nonneg dist_nonneg (mul_nonneg zero_le_two <| sqrt_nonneg _)
  · exact sinh_nonneg_iff.2 (div_nonneg hr zero_le_two)
#align upper_half_plane.dist_eq_iff_eq_sq_sinh UpperHalfPlane.dist_eq_iff_eq_sq_sinh

protected theorem dist_triangle (a b c : ℍ) : dist a c ≤ dist a b + dist b c :=
  by
  rw [dist_le_iff_le_sinh, sinh_half_dist_add_dist, div_mul_eq_div_div _ _ (dist _ _), le_div_iff,
    div_mul_eq_mul_div]
  ·
    exact
      div_le_div_of_le (mul_nonneg zero_le_two (sqrt_nonneg _))
        (EuclideanGeometry.mul_dist_le_mul_dist_add_mul_dist (a : ℂ) b c (conj ↑b))
  · rw [dist_comm, dist_pos, Ne.def, Complex.eq_conj_iff_im]
    exact b.im_ne_zero
#align upper_half_plane.dist_triangle UpperHalfPlane.dist_triangle

theorem dist_le_dist_coe_div_sqrt (z w : ℍ) : dist z w ≤ dist (z : ℂ) w / sqrt (z.im * w.im) :=
  by
  rw [dist_le_iff_le_sinh, ← div_mul_eq_div_div_swap, self_le_sinh_iff]
  exact div_nonneg dist_nonneg (mul_nonneg zero_le_two (sqrt_nonneg _))
#align upper_half_plane.dist_le_dist_coe_div_sqrt UpperHalfPlane.dist_le_dist_coe_div_sqrt

/-- An auxiliary `metric_space` instance on the upper half-plane. This instance has bad projection
to `topological_space`. We replace it later. -/
def metricSpaceAux : MetricSpace ℍ where
  dist := dist
  dist_self z := by rw [dist_eq, dist_self, zero_div, arsinh_zero, MulZeroClass.mul_zero]
  dist_comm := UpperHalfPlane.dist_comm
  dist_triangle := UpperHalfPlane.dist_triangle
  eq_of_dist_eq_zero z w h := by
    simpa [dist_eq, Real.sqrt_eq_zero', (mul_pos z.im_pos w.im_pos).not_le, Subtype.coe_inj] using h
#align upper_half_plane.metric_space_aux UpperHalfPlane.metricSpaceAux

open Complex

theorem cosh_dist' (z w : ℍ) :
    Real.cosh (dist z w) = ((z.re - w.re) ^ 2 + z.im ^ 2 + w.im ^ 2) / (2 * z.im * w.im) :=
  by
  have H : 0 < 2 * z.im * w.im := mul_pos (mul_pos two_pos z.im_pos) w.im_pos
  field_simp [cosh_dist, Complex.dist_eq, Complex.sq_abs, norm_sq_apply, H, H.ne']
  ring
#align upper_half_plane.cosh_dist' UpperHalfPlane.cosh_dist'

/-- Euclidean center of the circle with center `z` and radius `r` in the hyperbolic metric. -/
def center (z : ℍ) (r : ℝ) : ℍ :=
  ⟨⟨z.re, z.im * cosh r⟩, mul_pos z.im_pos (cosh_pos _)⟩
#align upper_half_plane.center UpperHalfPlane.center

@[simp]
theorem center_re (z r) : (center z r).re = z.re :=
  rfl
#align upper_half_plane.center_re UpperHalfPlane.center_re

@[simp]
theorem center_im (z r) : (center z r).im = z.im * cosh r :=
  rfl
#align upper_half_plane.center_im UpperHalfPlane.center_im

@[simp]
theorem center_zero (z : ℍ) : center z 0 = z :=
  Subtype.ext <| ext rfl <| by rw [coe_im, coe_im, center_im, Real.cosh_zero, mul_one]
#align upper_half_plane.center_zero UpperHalfPlane.center_zero

theorem dist_coe_center_sq (z w : ℍ) (r : ℝ) :
    dist (z : ℂ) (w.center r) ^ 2 =
      2 * z.im * w.im * (cosh (dist z w) - cosh r) + (w.im * sinh r) ^ 2 :=
  by
  have H : 2 * z.im * w.im ≠ 0 := by apply_rules [mul_ne_zero, two_ne_zero, im_ne_zero]
  simp only [Complex.dist_eq, Complex.sq_abs, norm_sq_apply, coe_re, coe_im, center_re, center_im,
    cosh_dist', mul_div_cancel' _ H, sub_sq z.im, mul_pow, Real.cosh_sq, sub_re, sub_im, mul_sub, ←
    sq]
  ring
#align upper_half_plane.dist_coe_center_sq UpperHalfPlane.dist_coe_center_sq

theorem dist_coe_center (z w : ℍ) (r : ℝ) :
    dist (z : ℂ) (w.center r) =
      sqrt (2 * z.im * w.im * (cosh (dist z w) - cosh r) + (w.im * sinh r) ^ 2) :=
  by rw [← sqrt_sq dist_nonneg, dist_coe_center_sq]
#align upper_half_plane.dist_coe_center UpperHalfPlane.dist_coe_center

theorem cmp_dist_eq_cmp_dist_coe_center (z w : ℍ) (r : ℝ) :
    cmp (dist z w) r = cmp (dist (z : ℂ) (w.center r)) (w.im * sinh r) :=
  by
  letI := metric_space_aux
  cases' lt_or_le r 0 with hr₀ hr₀
  · trans Ordering.gt
    exacts[(hr₀.trans_le dist_nonneg).cmp_eq_gt,
      ((mul_neg_of_pos_of_neg w.im_pos (sinh_neg_iff.2 hr₀)).trans_le dist_nonneg).cmp_eq_gt.symm]
  have hr₀' : 0 ≤ w.im * sinh r := mul_nonneg w.im_pos.le (sinh_nonneg_iff.2 hr₀)
  have hzw₀ : 0 < 2 * z.im * w.im := mul_pos (mul_pos two_pos z.im_pos) w.im_pos
  simp only [← cosh_strict_mono_on.cmp_map_eq dist_nonneg hr₀, ←
    (@strictMonoOn_pow ℝ _ _ two_pos).cmp_map_eq dist_nonneg hr₀', dist_coe_center_sq]
  rw [← cmp_mul_pos_left hzw₀, ← cmp_sub_zero, ← mul_sub, ← cmp_add_right, zero_add]
#align upper_half_plane.cmp_dist_eq_cmp_dist_coe_center UpperHalfPlane.cmp_dist_eq_cmp_dist_coe_center

theorem dist_eq_iff_dist_coe_center_eq : dist z w = r ↔ dist (z : ℂ) (w.center r) = w.im * sinh r :=
  eq_iff_eq_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)
#align upper_half_plane.dist_eq_iff_dist_coe_center_eq UpperHalfPlane.dist_eq_iff_dist_coe_center_eq

@[simp]
theorem dist_self_center (z : ℍ) (r : ℝ) : dist (z : ℂ) (z.center r) = z.im * (cosh r - 1) :=
  by
  rw [dist_of_re_eq (z.center_re r).symm, dist_comm, Real.dist_eq, mul_sub, mul_one]
  exact abs_of_nonneg (sub_nonneg.2 <| le_mul_of_one_le_right z.im_pos.le (one_le_cosh _))
#align upper_half_plane.dist_self_center UpperHalfPlane.dist_self_center

@[simp]
theorem dist_center_dist (z w : ℍ) : dist (z : ℂ) (w.center (dist z w)) = w.im * sinh (dist z w) :=
  dist_eq_iff_dist_coe_center_eq.1 rfl
#align upper_half_plane.dist_center_dist UpperHalfPlane.dist_center_dist

theorem dist_lt_iff_dist_coe_center_lt : dist z w < r ↔ dist (z : ℂ) (w.center r) < w.im * sinh r :=
  lt_iff_lt_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)
#align upper_half_plane.dist_lt_iff_dist_coe_center_lt UpperHalfPlane.dist_lt_iff_dist_coe_center_lt

theorem lt_dist_iff_lt_dist_coe_center : r < dist z w ↔ w.im * sinh r < dist (z : ℂ) (w.center r) :=
  lt_iff_lt_of_cmp_eq_cmp (cmp_eq_cmp_symm.1 <| cmp_dist_eq_cmp_dist_coe_center z w r)
#align upper_half_plane.lt_dist_iff_lt_dist_coe_center UpperHalfPlane.lt_dist_iff_lt_dist_coe_center

theorem dist_le_iff_dist_coe_center_le : dist z w ≤ r ↔ dist (z : ℂ) (w.center r) ≤ w.im * sinh r :=
  le_iff_le_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)
#align upper_half_plane.dist_le_iff_dist_coe_center_le UpperHalfPlane.dist_le_iff_dist_coe_center_le

theorem le_dist_iff_le_dist_coe_center : r < dist z w ↔ w.im * sinh r < dist (z : ℂ) (w.center r) :=
  lt_iff_lt_of_cmp_eq_cmp (cmp_eq_cmp_symm.1 <| cmp_dist_eq_cmp_dist_coe_center z w r)
#align upper_half_plane.le_dist_iff_le_dist_coe_center UpperHalfPlane.le_dist_iff_le_dist_coe_center

/-- For two points on the same vertical line, the distance is equal to the distance between the
logarithms of their imaginary parts. -/
theorem dist_of_re_eq (h : z.re = w.re) : dist z w = dist (log z.im) (log w.im) :=
  by
  have h₀ : 0 < z.im / w.im := div_pos z.im_pos w.im_pos
  rw [dist_eq_iff_dist_coe_center_eq, Real.dist_eq, ← abs_sinh, ← log_div z.im_ne_zero w.im_ne_zero,
      sinh_log h₀, dist_of_re_eq, coe_im, coe_im, center_im, cosh_abs, cosh_log h₀, inv_div] <;>
    [skip, exact h]
  nth_rw 4 [← abs_of_pos w.im_pos]
  simp only [← _root_.abs_mul, coe_im, Real.dist_eq]
  congr 1
  field_simp [z.im_pos, w.im_pos, z.im_ne_zero, w.im_ne_zero]
  ring
#align upper_half_plane.dist_of_re_eq UpperHalfPlane.dist_of_re_eq

/-- Hyperbolic distance between two points is greater than or equal to the distance between the
logarithms of their imaginary parts. -/
theorem dist_log_im_le (z w : ℍ) : dist (log z.im) (log w.im) ≤ dist z w :=
  calc
    dist (log z.im) (log w.im) = @dist ℍ _ ⟨⟨0, z.im⟩, z.im_pos⟩ ⟨⟨0, w.im⟩, w.im_pos⟩ :=
      Eq.symm <| @dist_of_re_eq ⟨⟨0, z.im⟩, z.im_pos⟩ ⟨⟨0, w.im⟩, w.im_pos⟩ rfl
    _ ≤ dist z w :=
      mul_le_mul_of_nonneg_left
        (arsinh_le_arsinh.2 <|
          div_le_div_of_le (mul_nonneg zero_le_two (sqrt_nonneg _)) <| by
            simpa [sqrt_sq_eq_abs] using Complex.abs_im_le_abs (z - w))
        zero_le_two

#align upper_half_plane.dist_log_im_le UpperHalfPlane.dist_log_im_le

theorem im_le_im_mul_exp_dist (z w : ℍ) : z.im ≤ w.im * exp (dist z w) :=
  by
  rw [← div_le_iff' w.im_pos, ← exp_log z.im_pos, ← exp_log w.im_pos, ← Real.exp_sub, exp_le_exp]
  exact (le_abs_self _).trans (dist_log_im_le z w)
#align upper_half_plane.im_le_im_mul_exp_dist UpperHalfPlane.im_le_im_mul_exp_dist

theorem im_div_exp_dist_le (z w : ℍ) : z.im / exp (dist z w) ≤ w.im :=
  (div_le_iff (exp_pos _)).2 (im_le_im_mul_exp_dist z w)
#align upper_half_plane.im_div_exp_dist_le UpperHalfPlane.im_div_exp_dist_le

/-- An upper estimate on the complex distance between two points in terms of the hyperbolic distance
and the imaginary part of one of the points. -/
theorem dist_coe_le (z w : ℍ) : dist (z : ℂ) w ≤ w.im * (exp (dist z w) - 1) :=
  calc
    dist (z : ℂ) w ≤ dist (z : ℂ) (w.center (dist z w)) + dist (w : ℂ) (w.center (dist z w)) :=
      dist_triangle_right _ _ _
    _ = w.im * (exp (dist z w) - 1) := by
      rw [dist_center_dist, dist_self_center, ← mul_add, ← add_sub_assoc, Real.sinh_add_cosh]

#align upper_half_plane.dist_coe_le UpperHalfPlane.dist_coe_le

/-- An upper estimate on the complex distance between two points in terms of the hyperbolic distance
and the imaginary part of one of the points. -/
theorem le_dist_coe (z w : ℍ) : w.im * (1 - exp (-dist z w)) ≤ dist (z : ℂ) w :=
  calc
    w.im * (1 - exp (-dist z w)) =
        dist (z : ℂ) (w.center (dist z w)) - dist (w : ℂ) (w.center (dist z w)) :=
      by
      rw [dist_center_dist, dist_self_center, ← Real.cosh_sub_sinh]
      ring
    _ ≤ dist (z : ℂ) w := sub_le_iff_le_add.2 <| dist_triangle _ _ _

#align upper_half_plane.le_dist_coe UpperHalfPlane.le_dist_coe

/-- The hyperbolic metric on the upper half plane. We ensure that the projection to
`topological_space` is definitionally equal to the subtype topology. -/
instance : MetricSpace ℍ :=
  metricSpaceAux.replaceTopology <|
    by
    refine' le_antisymm (continuous_id_iff_le.1 _) _
    · refine' (@continuous_iff_continuous_dist _ _ metric_space_aux.to_pseudo_metric_space _ _).2 _
      have : ∀ x : ℍ × ℍ, 2 * Real.sqrt (x.1.im * x.2.im) ≠ 0 := fun x =>
        mul_ne_zero two_ne_zero (Real.sqrt_pos.2 <| mul_pos x.1.im_pos x.2.im_pos).ne'
      -- `continuity` fails to apply `continuous.div`
      apply_rules [Continuous.div, Continuous.mul, continuous_const, Continuous.arsinh,
        Continuous.dist, continuous_coe.comp, continuous_fst, continuous_snd,
        real.continuous_sqrt.comp, continuous_im.comp]
    · letI : MetricSpace ℍ := metric_space_aux
      refine' le_of_nhds_le_nhds fun z => _
      rw [nhds_induced]
      refine' (nhds_basis_ball.le_basis_iff (nhds_basis_ball.comap _)).2 fun R hR => _
      have h₁ : 1 < R / im z + 1 := lt_add_of_pos_left _ (div_pos hR z.im_pos)
      have h₀ : 0 < R / im z + 1 := one_pos.trans h₁
      refine' ⟨log (R / im z + 1), Real.log_pos h₁, _⟩
      refine' fun w hw => (dist_coe_le w z).trans_lt _
      rwa [← lt_div_iff' z.im_pos, sub_lt_iff_lt_add, ← Real.lt_log_iff_exp_lt h₀]

theorem im_pos_of_dist_center_le {z : ℍ} {r : ℝ} {w : ℂ} (h : dist w (center z r) ≤ z.im * sinh r) :
    0 < w.im :=
  calc
    0 < z.im * (cosh r - sinh r) := mul_pos z.im_pos (sub_pos.2 <| sinh_lt_cosh _)
    _ = (z.center r).im - z.im * sinh r := (mul_sub _ _ _)
    _ ≤ (z.center r).im - dist (z.center r : ℂ) w := (sub_le_sub_left (by rwa [dist_comm]) _)
    _ ≤ w.im := sub_le_comm.1 <| (le_abs_self _).trans (abs_im_le_abs <| z.center r - w)

#align upper_half_plane.im_pos_of_dist_center_le UpperHalfPlane.im_pos_of_dist_center_le

theorem image_coe_closedBall (z : ℍ) (r : ℝ) :
    (coe : ℍ → ℂ) '' closedBall z r = closedBall (z.center r) (z.im * sinh r) :=
  by
  ext w; constructor
  · rintro ⟨w, hw, rfl⟩
    exact dist_le_iff_dist_coe_center_le.1 hw
  · intro hw
    lift w to ℍ using im_pos_of_dist_center_le hw
    exact mem_image_of_mem _ (dist_le_iff_dist_coe_center_le.2 hw)
#align upper_half_plane.image_coe_closed_ball UpperHalfPlane.image_coe_closedBall

theorem image_coe_ball (z : ℍ) (r : ℝ) :
    (coe : ℍ → ℂ) '' ball z r = ball (z.center r) (z.im * sinh r) :=
  by
  ext w; constructor
  · rintro ⟨w, hw, rfl⟩
    exact dist_lt_iff_dist_coe_center_lt.1 hw
  · intro hw
    lift w to ℍ using im_pos_of_dist_center_le (ball_subset_closed_ball hw)
    exact mem_image_of_mem _ (dist_lt_iff_dist_coe_center_lt.2 hw)
#align upper_half_plane.image_coe_ball UpperHalfPlane.image_coe_ball

theorem image_coe_sphere (z : ℍ) (r : ℝ) :
    (coe : ℍ → ℂ) '' sphere z r = sphere (z.center r) (z.im * sinh r) :=
  by
  ext w; constructor
  · rintro ⟨w, hw, rfl⟩
    exact dist_eq_iff_dist_coe_center_eq.1 hw
  · intro hw
    lift w to ℍ using im_pos_of_dist_center_le (sphere_subset_closed_ball hw)
    exact mem_image_of_mem _ (dist_eq_iff_dist_coe_center_eq.2 hw)
#align upper_half_plane.image_coe_sphere UpperHalfPlane.image_coe_sphere

instance : ProperSpace ℍ := by
  refine' ⟨fun z r => _⟩
  rw [← inducing_coe.is_compact_iff, image_coe_closed_ball]
  apply is_compact_closed_ball

theorem isometry_vertical_line (a : ℝ) : Isometry fun y => mk ⟨a, exp y⟩ (exp_pos y) :=
  by
  refine' Isometry.of_dist_eq fun y₁ y₂ => _
  rw [dist_of_re_eq]
  exacts[congr_arg₂ _ (log_exp _) (log_exp _), rfl]
#align upper_half_plane.isometry_vertical_line UpperHalfPlane.isometry_vertical_line

theorem isometry_real_vadd (a : ℝ) : Isometry ((· +ᵥ ·) a : ℍ → ℍ) :=
  Isometry.of_dist_eq fun y₁ y₂ => by simp only [dist_eq, coe_vadd, vadd_im, dist_add_left]
#align upper_half_plane.isometry_real_vadd UpperHalfPlane.isometry_real_vadd

theorem isometry_pos_mul (a : { x : ℝ // 0 < x }) : Isometry ((· • ·) a : ℍ → ℍ) :=
  by
  refine' Isometry.of_dist_eq fun y₁ y₂ => _
  simp only [dist_eq, coe_pos_real_smul, pos_real_im]; congr 2
  rw [dist_smul₀, mul_mul_mul_comm, Real.sqrt_mul (mul_self_nonneg _), Real.sqrt_mul_self_eq_abs,
    Real.norm_eq_abs, mul_left_comm]
  exact mul_div_mul_left _ _ (mt _root_.abs_eq_zero.1 a.2.ne')
#align upper_half_plane.isometry_pos_mul UpperHalfPlane.isometry_pos_mul

/-- `SL(2, ℝ)` acts on the upper half plane as an isometry.-/
instance : IsometricSMul SL(2, ℝ) ℍ :=
  ⟨fun g =>
    by
    have h₀ : Isometry (fun z => ModularGroup.s • z : ℍ → ℍ) :=
      Isometry.of_dist_eq fun y₁ y₂ =>
        by
        have h₁ : 0 ≤ im y₁ * im y₂ := mul_nonneg y₁.property.le y₂.property.le
        have h₂ : Complex.abs (y₁ * y₂) ≠ 0 := by simp [y₁.ne_zero, y₂.ne_zero]
        simp only [dist_eq, modular_S_smul, inv_neg, neg_div, div_mul_div_comm, coe_mk, mk_im,
          div_one, Complex.inv_im, Complex.neg_im, coe_im, neg_neg, Complex.normSq_neg,
          mul_eq_mul_left_iff, Real.arsinh_inj, bit0_eq_zero, one_ne_zero, or_false_iff,
          dist_neg_neg, mul_neg, neg_mul, dist_inv_inv₀ y₁.ne_zero y₂.ne_zero, ← map_mul, ←
          Complex.normSq_mul, Real.sqrt_div h₁, ← Complex.abs_apply, mul_div (2 : ℝ),
          div_div_div_comm, div_self h₂, Complex.norm_eq_abs]
    by_cases hc : g 1 0 = 0
    · obtain ⟨u, v, h⟩ := exists_SL2_smul_eq_of_apply_zero_one_eq_zero g hc
      rw [h]
      exact (isometry_real_vadd v).comp (isometry_pos_mul u)
    · obtain ⟨u, v, w, h⟩ := exists_SL2_smul_eq_of_apply_zero_one_ne_zero g hc
      rw [h]
      exact
        (isometry_real_vadd w).comp (h₀.comp <| (isometry_real_vadd v).comp <| isometry_pos_mul u)⟩

end UpperHalfPlane


/-
Copyright (c) 2022 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez
-/
import algebra.big_operators.order
import data.fintype.big_operators
import data.int.lemmas
import tactic.derive_fintype

/-!
# Sign function

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

This file defines the sign function for types with zero and a decidable less-than relation, and
proves some basic theorems about it.
-/

/-- The type of signs. -/
@[derive [decidable_eq, inhabited, fintype]]
inductive sign_type
| zero | neg | pos

namespace sign_type

instance : has_zero sign_type := ⟨zero⟩
instance : has_one  sign_type := ⟨pos⟩

instance : has_neg sign_type :=
⟨λ s, match s with
| neg  := pos
| zero := zero
| pos  := neg
end⟩

@[simp] lemma zero_eq_zero   : zero = 0 := rfl
@[simp] lemma neg_eq_neg_one : neg = -1 := rfl
@[simp] lemma pos_eq_one     : pos = 1  := rfl

instance : has_mul sign_type :=
⟨λ x y, match x with
| neg  := -y
| zero := zero
| pos  := y
end⟩

/-- The less-than relation on signs. -/
inductive le : sign_type → sign_type → Prop
| of_neg (a) : le neg a
| zero       : le zero zero
| of_pos (a) : le a pos

instance : has_le sign_type := ⟨le⟩

instance : decidable_rel le :=
λ a b, by cases a; cases b; exact is_false (by rintro ⟨⟩) <|> exact is_true (by constructor)

/- We can define a `field` instance on `sign_type`, but it's not mathematically sensible,
so we only define the `comm_group_with_zero`. -/
instance : comm_group_with_zero sign_type :=
{ zero            := 0,
  one             := 1,
  mul             := (*),
  inv             := id,
  mul_zero        := λ a, by cases a; refl,
  zero_mul        := λ a, by cases a; refl,
  mul_one         := λ a, by cases a; refl,
  one_mul         := λ a, by cases a; refl,
  mul_inv_cancel  := λ a ha,  by cases a; trivial,
  mul_comm        := λ a b,   by casesm* _; refl,
  mul_assoc       := λ a b c, by casesm* _; refl,
  exists_pair_ne  := ⟨0, 1,   by rintro ⟨⟩⟩,
  inv_zero        := rfl }

instance : linear_order sign_type :=
{ le           := (≤),
  le_refl      := λ a, by cases a; constructor,
  le_total     := λ a b, by casesm* _; dec_trivial,
  le_antisymm  := λ a b ha hb, by casesm* _; refl,
  le_trans     := λ a b c hab hbc, by casesm* _; constructor,
  decidable_le := le.decidable_rel }

instance : bounded_order sign_type :=
{ top := 1,
  le_top := le.of_pos,
  bot := -1,
  bot_le := le.of_neg }

instance : has_distrib_neg sign_type :=
{ neg_neg := λ x, by cases x; refl,
  neg_mul := λ x y, by casesm* _; refl,
  mul_neg := λ x y, by casesm* _; refl,
..sign_type.has_neg }

/-- `sign_type` is equivalent to `fin 3`. -/
def fin3_equiv : sign_type ≃* fin 3 :=
{ to_fun :=  λ a, a.rec_on 0 (-1) 1,
  inv_fun := λ a, match a with
    | ⟨0, h⟩   := 0
    | ⟨1, h⟩   := 1
    | ⟨2, h⟩   := -1
    | ⟨n+3, h⟩ := (h.not_le le_add_self).elim
  end,
  left_inv :=  λ a, by cases a; refl,
  right_inv := λ a, match a with
    | ⟨0, h⟩   := rfl
    | ⟨1, h⟩   := rfl
    | ⟨2, h⟩   := rfl
    | ⟨n+3, h⟩ := (h.not_le le_add_self).elim
  end,
  map_mul' := λ x y, by casesm* _; refl }

section case_bashing

lemma nonneg_iff {a : sign_type} : 0 ≤ a ↔ a = 0 ∨ a = 1 := by dec_trivial!

lemma nonneg_iff_ne_neg_one {a : sign_type} : 0 ≤ a ↔ a ≠ -1 := by dec_trivial!

lemma neg_one_lt_iff {a : sign_type} : -1 < a ↔ 0 ≤ a := by dec_trivial!

lemma nonpos_iff {a : sign_type} : a ≤ 0 ↔ a = -1 ∨ a = 0 := by dec_trivial!

lemma nonpos_iff_ne_one {a : sign_type} : a ≤ 0 ↔ a ≠ 1 := by dec_trivial!

lemma lt_one_iff {a : sign_type} : a < 1 ↔ a ≤ 0 := by dec_trivial!

@[simp] lemma neg_iff {a : sign_type} : a < 0 ↔ a = -1 := by dec_trivial!

@[simp] lemma le_neg_one_iff {a : sign_type} : a ≤ -1 ↔ a = -1 := le_bot_iff

@[simp] lemma pos_iff {a : sign_type} : 0 < a ↔ a = 1 := by dec_trivial!

@[simp] lemma one_le_iff {a : sign_type} : 1 ≤ a ↔ a = 1 := top_le_iff

@[simp] lemma neg_one_le (a : sign_type) : -1 ≤ a := bot_le

@[simp] lemma le_one (a : sign_type) : a ≤ 1 := le_top

@[simp] lemma not_lt_neg_one (a : sign_type) : ¬ a < -1 := not_lt_bot

@[simp] lemma not_one_lt (a : sign_type) : ¬ 1 < a := not_top_lt

@[simp] lemma self_eq_neg_iff (a : sign_type) : a = -a ↔ a = 0 := by dec_trivial!

@[simp]

@[simp] lemma neg_one_lt_one : (-1 : sign_type) < 1 := bot_lt_top

end case_bashing

section cast

variables {α : Type*} [has_zero α] [has_one α] [has_neg α]

/-- Turn a `sign_type` into zero, one, or minus one. This is a coercion instance, but note it is
only a `has_coe_t` instance: see note [use has_coe_t]. -/
def cast : sign_type → α
| zero :=  0
| pos  :=  1
| neg  := -1

instance : has_coe_t sign_type α := ⟨cast⟩

@[simp] lemma cast_eq_coe (a : sign_type) : (cast a : α) = a := rfl

@[simp] lemma coe_zero : ↑(0 : sign_type) = (0 : α) := rfl
@[simp] lemma coe_one  : ↑(1 : sign_type) = (1 : α) := rfl
@[simp] lemma coe_neg_one : ↑(-1 : sign_type) = (-1 : α) := rfl

end cast

/-- `sign_type.cast` as a `mul_with_zero_hom`. -/
@[simps] def cast_hom {α} [mul_zero_one_class α] [has_distrib_neg α] : sign_type →*₀ α :=
{ to_fun    := cast,
  map_zero' := rfl,
  map_one'  := rfl,
  map_mul'  := λ x y, by cases x; cases y; simp }

lemma range_eq {α} (f : sign_type → α) : set.range f = {f zero, f neg, f pos} :=
begin
  classical,
  simpa only [← finset.coe_singleton, ← finset.image_singleton,
    ← fintype.coe_image_univ, finset.coe_image, ← set.image_insert_eq],
end

end sign_type

variables {α : Type*}

open sign_type

section preorder

variables [has_zero α] [preorder α] [decidable_rel ((<) : α → α → Prop)] {a : α}

/-- The sign of an element is 1 if it's positive, -1 if negative, 0 otherwise. -/
def sign : α →o sign_type :=
⟨λ a, if 0 < a then 1 else if a < 0 then -1 else 0,
 λ a b h, begin
  dsimp,
  split_ifs with h₁ h₂ h₃ h₄ _ _ h₂ h₃; try {constructor},
  { cases lt_irrefl 0 (h₁.trans $ h.trans_lt h₃) },
  { cases h₂ (h₁.trans_le h) },
  { cases h₄ (h.trans_lt h₃) }
  end⟩

lemma sign_apply : sign a = ite (0 < a) 1 (ite (a < 0) (-1) 0) := rfl

@[simp] lemma sign_zero : sign (0 : α) = 0 := by simp [sign_apply]
@[simp] lemma sign_pos (ha : 0 < a) : sign a = 1 := by rwa [sign_apply, if_pos]
@[simp] lemma sign_neg (ha : a < 0) : sign a = -1 := by rwa [sign_apply, if_neg $ asymm ha, if_pos]

lemma sign_eq_one_iff : sign a = 1 ↔ 0 < a :=
begin
  refine ⟨λ h, _, λ h, sign_pos h⟩,
  by_contra hn,
  rw [sign_apply, if_neg hn] at h,
  split_ifs at h;
    simpa using h
end

lemma sign_eq_neg_one_iff : sign a = -1 ↔ a < 0 :=
begin
  refine ⟨λ h, _, λ h, sign_neg h⟩,
  rw sign_apply at h,
  split_ifs at h,
  { simpa using h },
  { exact h_2 },
  { simpa using h }
end

end preorder

section linear_order

variables [has_zero α] [linear_order α] {a : α}

@[simp] lemma sign_eq_zero_iff : sign a = 0 ↔ a = 0 :=
begin
  refine ⟨λ h, _, λ h, h.symm ▸ sign_zero⟩,
  rw [sign_apply] at h,
  split_ifs at h; cases h,
  exact (le_of_not_lt h_1).eq_of_not_lt h_2
end

lemma sign_ne_zero : sign a ≠ 0 ↔ a ≠ 0 :=
sign_eq_zero_iff.not

@[simp] lemma sign_nonneg_iff : 0 ≤ sign a ↔ 0 ≤ a :=
begin
  rcases lt_trichotomy 0 a with (h|rfl|h),
  { simp [h, h.le] },
  { simp },
  { simpa [h, h.not_le] }
end

@[simp] lemma sign_nonpos_iff : sign a ≤ 0 ↔ a ≤ 0 :=
begin
  rcases lt_trichotomy 0 a with (h|rfl|h),
  { simp [h, h.not_le] },
  { simp },
  { simp [h, h.le] }
end

end linear_order

section ordered_semiring

variables [ordered_semiring α] [decidable_rel ((<) : α → α → Prop)] [nontrivial α]

@[simp] lemma sign_one : sign (1 : α) = 1 :=
sign_pos zero_lt_one

end ordered_semiring

section linear_ordered_ring

variables [linear_ordered_ring α] {a b : α}

/- I'm not sure why this is necessary, see https://leanprover.zulipchat.com/#narrow/stream/
113488-general/topic/type.20class.20inference.20issues/near/276937942 -/
local attribute [instance] linear_ordered_ring.decidable_lt

lemma sign_mul (x y : α) : sign (x * y) = sign x * sign y :=
begin
  rcases lt_trichotomy x 0 with hx | hx | hx; rcases lt_trichotomy y 0 with hy | hy | hy;
    simp only [sign_zero, mul_zero, zero_mul, sign_pos, sign_neg, hx, hy, mul_one, neg_one_mul,
               neg_neg, one_mul, mul_pos_of_neg_of_neg, mul_neg_of_neg_of_pos, neg_zero,
               mul_neg_of_pos_of_neg, mul_pos]
end

/-- `sign` as a `monoid_with_zero_hom` for a nontrivial ordered semiring. Note that linearity
is required; consider ℂ with the order `z ≤ w` iff they have the same imaginary part and
`z - w ≤ 0` in the reals; then `1 + i` and `1 - i` are incomparable to zero, and thus we have:
`0 * 0 = sign (1 + i) * sign (1 - i) ≠ sign 2 = 1`. (`complex.ordered_comm_ring`) -/
def sign_hom : α →*₀ sign_type :=
{ to_fun := sign,
  map_zero' := sign_zero,
  map_one' := sign_one,
  map_mul' := sign_mul }

lemma sign_pow (x : α) (n : ℕ) : sign (x ^ n) = (sign x) ^ n :=
begin
  change sign_hom (x ^ n) = (sign_hom x) ^ n,
  exact map_pow _ _ _
end

end linear_ordered_ring

section add_group

variables [add_group α] [preorder α] [decidable_rel ((<) : α → α → Prop)]

lemma left.sign_neg [covariant_class α α (+) (<)] (a : α) : sign (-a) = - sign a :=
begin
  simp_rw [sign_apply, left.neg_pos_iff, left.neg_neg_iff],
  split_ifs with h h',
  { exact false.elim (lt_asymm h h') },
  { simp },
  { simp },
  { simp }
end

lemma right.sign_neg [covariant_class α α (function.swap (+)) (<)] (a : α) : sign (-a) = - sign a :=
begin
  simp_rw [sign_apply, right.neg_pos_iff, right.neg_neg_iff],
  split_ifs with h h',
  { exact false.elim (lt_asymm h h') },
  { simp },
  { simp },
  { simp }
end

end add_group

section linear_ordered_add_comm_group

open_locale big_operators

variables [linear_ordered_add_comm_group α]

/- I'm not sure why this is necessary, see
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Decidable.20vs.20decidable_rel -/
local attribute [instance] linear_ordered_add_comm_group.decidable_lt

lemma sign_sum {ι : Type*} {s : finset ι} {f : ι → α} (hs : s.nonempty) (t : sign_type)
  (h : ∀ i ∈ s, sign (f i) = t) : sign (∑ i in s, f i) = t :=
begin
  cases t,
  { simp_rw [zero_eq_zero, sign_eq_zero_iff] at ⊢ h,
    exact finset.sum_eq_zero h },
  { simp_rw [neg_eq_neg_one, sign_eq_neg_one_iff] at ⊢ h,
    exact finset.sum_neg h hs },
  { simp_rw [pos_eq_one, sign_eq_one_iff] at ⊢ h,
    exact finset.sum_pos h hs }
end

end linear_ordered_add_comm_group

namespace int

lemma sign_eq_sign (n : ℤ) : n.sign = _root_.sign n :=
begin
  obtain ((_ | _) | _) := n,
  { exact congr_arg coe sign_zero.symm },
  { exact congr_arg coe (sign_pos $ int.succ_coe_nat_pos _).symm },
  { exact congr_arg coe (_root_.sign_neg $ neg_succ_lt_zero _).symm }
end
end int

open finset nat
open_locale big_operators

private lemma exists_signed_sum_aux [decidable_eq α] (s : finset α) (f : α → ℤ) :
  ∃ (β : Type u_1) (t : finset β) (sgn : β → sign_type) (g : β → α), (∀ b, g b ∈ s) ∧
    t.card = ∑ a in s, (f a).nat_abs ∧
    ∀ a ∈ s, (∑ b in t, if g b = a then (sgn b : ℤ) else 0) = f a :=
begin
  refine ⟨Σ a : {x // x ∈ s}, ℕ, finset.univ.sigma (λ a, range (f a).nat_abs), λ a, sign (f a.1),
    λ a, a.1, λ a, a.1.prop, _, _⟩,
  { simp [@sum_attach _ _ _ _ (λ a, (f a).nat_abs)] },
  { intros x hx,
    simp [sum_sigma, hx, ← int.sign_eq_sign, int.sign_mul_abs, mul_comm (|f _|),
      @sum_attach _ _ _ _ (λ a, ∑ j in range (f a).nat_abs, if a = x then (f a).sign else 0)] }
end

/-- We can decompose a sum of absolute value `n` into a sum of `n` signs. -/
lemma exists_signed_sum [decidable_eq α] (s : finset α) (f : α → ℤ) :
  ∃ (β : Type u_1) (_ : fintype β) (sgn : β → sign_type) (g : β → α), by exactI (∀ b, g b ∈ s) ∧
    fintype.card β = ∑ a in s, (f a).nat_abs ∧
    ∀ a ∈ s, (∑ b, if g b = a then (sgn b : ℤ) else 0) = f a :=
let ⟨β, t, sgn, g, hg, ht, hf⟩ := exists_signed_sum_aux s f in
  ⟨t, infer_instance, λ b, sgn b, λ b, g b, λ b, hg b, by simp [ht], λ a ha,
    (@sum_attach _ _ t _ (λ b, ite (g b = a) (sgn b : ℤ) 0)).trans $ hf _ ha⟩

/-- We can decompose a sum of absolute value less than `n` into a sum of at most `n` signs. -/
lemma exists_signed_sum' [nonempty α] [decidable_eq α] (s : finset α) (f : α → ℤ) (n : ℕ)
  (h : ∑ i in s, (f i).nat_abs ≤ n) :
  ∃ (β : Type u_1) (_ : fintype β) (sgn : β → sign_type) (g : β → α), by exactI
    (∀ b, g b ∉ s → sgn b = 0) ∧ fintype.card β = n ∧
    ∀ a ∈ s, (∑ i, if g i = a then (sgn i : ℤ) else 0) = f a :=
begin
  obtain ⟨β, _, sgn, g, hg, hβ, hf⟩ := exists_signed_sum s f,
  resetI,
  refine ⟨β ⊕ fin (n - ∑ i in s, (f i).nat_abs), infer_instance, sum.elim sgn 0,
    sum.elim g $ classical.arbitrary _, _, by simp [hβ, h], λ a ha, by simp [hf _ ha]⟩,
  rintro (b | b) hb,
  { cases hb (hg _) },
  { refl }
end


import tactic

variables {α : Type} {A B : set α}

-- Problem 2.1. Prove that there is at most one empty set, i.e., show that if A
-- and B are sets without members, then A = B.
lemma problem_2_1 (ha : ∀ x, x ∉ A) (hb : ∀ x, x ∉ B) : A = B :=
begin
  ext,
  specialize ha x,
  specialize hb x,
  split,
  { intro h,
    exfalso,
    apply ha,
    assumption },
  { intro h,
    exfalso,
    apply hb,
    assumption }
end

#check @finset.induction_on
#print finset

lemma insert_card_eq_succ [decidable_eq α] {x : α} {A : finset α} (h : x ∉ A) :
  (insert x A).card = A.card.succ :=
begin
  change (⟨_, multiset.nodup_ndinsert x A.2⟩ : finset α).1.card = _,
  simp [multiset.ndinsert_of_not_mem h],
  refl
end

lemma insert_powerset_card_eq_two_mul [decidable_eq α] {x : α} {A : finset α} (h : x ∉ A) :
  (insert x A).powerset.card = 2 * A.powerset.card :=
begin
  sorry
end

-- Problem 2.3. Show that if A has n members, then ℘(A) has 2^n members.
lemma problem_2_3 [decidable_eq α] (A : finset α) : A.powerset.card = 2 ^ A.card :=
begin
  apply @finset.induction_on _ (λ R, R.powerset.card = 2 ^ R.card),
  { rw [finset.card_empty, finset.powerset_empty, finset.card_singleton, pow_zero] },
  { clear A,
    intro x,
    intro A,
    intro hx,
    intro ih,
    rw [insert_card_eq_succ hx, insert_powerset_card_eq_two_mul hx],
    change _ = 2 * 2 ^ A.card,
    rw ih }
end

-- Problem 2.4. Prove that if A ⊆ B, then A ∪ B = B.
lemma problem_2_4 (h : A ⊆ B) : A ∪ B = B :=
begin
  ext,
  change ∀ x, x ∈ A → x ∈ B at h,
  split,
  { intro hx,
    cases hx,
    { specialize h x,
      specialize h hx,
      assumption },
    { assumption } },
  { intro hx,
    right,
    assumption }
end

-- Problem 2.5. Prove rigorously that if A ⊆ B, then A ∩ B = A.
lemma problem_2_5 (h : A ⊆ B) : A ∩ B = A :=
begin
  ext,
  change ∀ x, x ∈ A → x ∈ B at h,
  split,
  { intro hx,
    cases hx with hxa hxb,
    assumption },
  { intro hx,
    specialize h x,
    specialize h hx,
    split; assumption }
end

-- Problem 2.6. Show that if A is a set and A ∈ B, then A ⊆ ⋃ B.
lemma problem_2_6 (B : set (set α)) (h : A ∈ B) : A ⊆ ⋃₀ B :=
begin
  change ∀ x, x ∈ A → x ∈ ⋃₀ B,
  intro x,
  intro hx,
  simp only [exists_prop, set.mem_set_of_eq],
  use A,
  split; assumption
end

#check @not_and_distrib
#check @not_not
#check @congr_fun

-- Problem 2.7. Prove that if A ⊊ B, then B \ A ≠ ∅
lemma problem_2_7 (h : A ⊂ B) : B \ A ≠ ∅ :=
begin
  change A ⊆ B ∧ ¬ B ⊆ A at h,
  cases h with h₁ h₂,
  intro h,
  unfold has_sdiff.sdiff at h,
  unfold set.diff at h,
  apply h₂,
  clear h₂,
  change ∀ x, x ∈ B → x ∈ A,
  intro x,
  intro hx,
  specialize @h₁ x,
  change (λ x, _) = (λ x, _) at h,
  simp at h,
  have : x ∉ B ∨ x ∈ A,
  { rw [←@not_not (x ∈ A), ←not_and_distrib],
    rintro ⟨h₁, h₂⟩,
    apply h₂,
    clear h₂,
    have := congr_fun h x,
    tidy },
  cases this,
  { tidy },
  { assumption }
end

-- Definition 2.23 (Ordered pair). ⟨a, b⟩ = {{a}, {a, b}}.
def pair (a b : α) : set (set α) := {{a}, {a, b}}

variables {a₁ a₂ b₁ b₂ : α}

-- Problem 2.8. Using Definition 2.23, prove that ⟨a, b⟩ = ⟨c, d⟩ iff both
-- a = c and b = d .
lemma problem_2_8 : pair a₁ b₁ = pair a₂ b₂ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
begin
  sorry
end

-- Problem 2.10. Show, by induction on k, that for all k ≥ 1, if A has n
-- members, then Ak has n^k members.
lemma problem_2_10 : sorry := sorry


-- Filtros

-- ---------------------------------------------------------------------
-- Ejercicio. Importar la teoría de filtros.
-- ---------------------------------------------------------------------

import order.filter.basic

-- =====================================================================
-- § Introducción                                                     --
-- =====================================================================

-- Un espacio topológico sobre un tipo `α` es una colección de
-- subconjuntos de `α` (los conjuntos abiertos) que satisfacen algunos
-- axiomas. Un filtro es un tipo similar: es una colección de
-- subconjuntos de `α` que satisfacen otros axiomas.
--
-- Antes de ver la definición formal, empecemos por la idea. Un filtro
-- en `α` es una generalización muy potente del concepto de subconjunto
-- de `α`. Si `S : set α` es un subconjunto, entonces existe un filtro
-- `𝓟 S` correspondiente a `S` que es la colección de todos los
-- subconjuntos de `α` que contienen a `S`. Sin embargo, puede haber
-- otros filtros en `α` correspondientes a cosas que son un poco más
-- generales que los subconjuntos. Por ejemplo si `α` es un espacio
-- topológico y `x : α` entonces hay un filtro `𝓝 x` correspondiente a
-- "un entorno infinitesimal de `x`" tal que no hay ningún conjunto
-- abierto más pequeño que contenga a `x`. Como otro ejemplo, si `α`
-- está ordenado entonces hay un filtro de "entornos del infinito" en
-- `α` aunque aunque no haya ningún `∞` en `α`.
--
-- Si `F` es un filtro, entonces se puede pensar en `F` como un tipo
-- generalizado de subconjunto `F` de `α`, y debes pensar que `S ∈ F`
-- significa `F ⊆ S`. Tener esto en cuenta te ayudará a motivar los
-- axiomas que vienen a continuación.

-- =====================================================================
-- § Definición de filtro                                             --
-- =====================================================================

-- Esta es la definición formal. Un filtro sobre `α` es una colección
-- `F` de subconjuntos de `α` que satisface los tres axiomas siguientes:
-- 1. `α ∈ F` (en Lean se escribe `univ ∈ F` porque se distingue
--    entre el tipo `α` y el término `univ : set α` correspondiente a `α`)
-- 2. Si `S ∈ F` y `S ⊆ T` entonces `T ∈ F`; es decir, `F` es "cerrado
--    hacia arriba".
-- 3. Si `A ∈ F` y `B ∈ F` entonces `A ∩ B ∈ F`; es decir, `F` es
--    cerrado bajo intersecciones binarias.
--
-- Obsérvese que (1) y (3) implican conjuntamente (y son de hecho equivalentes a
-- la afirmación de que `F` es cerrado bajo todas las intersecciones finitas;
-- es decir, la intersección de un número finito de elementos de `F` está en `F`.
--
-- Esta es la definición de Lean:
--    structure filter (α : Type*) :=
--    (sets                   : set (set α))
--    (univ_sets              : set.univ ∈ sets)
--    (sets_of_superset {x y} : x ∈ sets → x ⊆ y → y ∈ sets)
--    (inter_sets {x y}       : x ∈ sets → y ∈ sets → x ∩ y ∈ sets)
--
-- En palabras, `filter α` es el tipo de filtros sobre `α`, por lo que
-- dar un filtro en `α` es dar un término `F : filter α` de tipo `filter
-- α`. Para obtener un término de tipo `filter α` hay que dar una
-- colección `conjuntos` de subconjuntos de `α` y luego tres pruebas de
-- los tres axiomas.
--
-- Un ejemplo bastante simple de un filtro es el filtro de *todos* los
-- subconjuntos de `α`. Aquellos que hayan visto definiciones de
-- filtros en otros lugares (por ejemplo en Bourbaki) habrán visto un
-- axioma adicional en la definición de un filtro que dice que un filtro
-- no puede ser la colección de todos los subconjuntos de subconjuntos
-- de `α`. Esto resulta ser un axioma poco natural, es como es como
-- exigir en la teoría de los ideales que si `R` es un anillo entonces
-- `R` no puede ser un ideal de `R`. Una ventaja de esta definición de
-- ideal sería que un ideal maximal de `R` sería literalmente un
-- elemento maximal de los ideales de `R`, pero esta ventaja se ve
-- compensada por la desventaja de que la definición se vuelve mucho
-- menos functorial (por ejemplo, la imagen de un ideal a lo largo de
-- un homomorfismo de anillo podría no ser un ideal, no se puede en
-- general sumar dos ideales, etc.). Para preservar la funtorialidad de
-- los filtros, mathlib no tiene este axioma de Bourbaki como un axioma
-- para los filtros. En consecuencia, hay dos filtros "extremos" en `α`,
-- a saber, el que sólo contiene `univ` (nótese que esto es forzado por
-- `univ_sets`), y luego el que mencionamos antes, que contiene todos
-- los subconjuntos de `α`. Estos dos filtros se llaman `⊥` y `⊤`,
-- ¡aunque te sorprenderá saber cuál es cada uno!  El filtro formado por
-- todos los subconjuntos de `α` es el que corresponde al conjunto vacío,
-- por lo que es `⊥`, y el que consta sólo de `univ` es el es el
-- correspondiente al conjunto de `α`, por lo que es `⊤`.

-- =====================================================================
-- § Notación, tácticas útiles y teoremas útiles                      --
-- =====================================================================

-- No vamos a construir filtros desde los primeros principios, en su
-- lugar usaremos la API de Lean para los filtros.
--
-- Sean `α : Type`, `F : filter α` y `S : set α`. La notación
-- `S ∈ F` se se define como `S ∈ F.sets`.
--
-- La táctica `ext` puede utilizarse para reducir un objetivo `F = G` a
-- un objetivo de la forma `∀ S, S ∈ F ↔ S ∈ G`.
--
-- Los campos de la estructura mencionan cosas como `S ∈ F.sets`, por lo
-- que los axiomas se repiten con otros nombres, pero utilizando la
-- notación `S ∈ F`. Los lemas correspondientes a las definiciones son:
--    `univ_mem_sets : univ ∈ F`
--    `mem_sets_of_superset : S ∈ F → S ⊆ T → T ∈ F`
--    `inter_mem_sets : S ∈ F → T ∈ F → S ∩ T ∈ F`
--
-- Estos lemas están en el espacio de nombres `filter`; es decir, sus
-- nombres completos son `filter.univ_mem_sets`, etc. Pero usaremos
-- "open filter", lo que significa que no se necesita escribir el
-- prefijo `filter.` delante de cada lema que necesites sobre
-- filtros. De hecho, también usaremos un montón de cosas sobre
-- conjuntos, como `set.inter_subset_left`, así que también usaremos
-- `open set`.

-- ---------------------------------------------------------------------
-- Ejercicio. Abrir los espacios de nombre de los filtros y de los
-- conjuntos.
-- ---------------------------------------------------------------------

open filter set

-- ---------------------------------------------------------------------
-- Ejercicio. Declara las variables
-- + α sobre tipos
-- + F sobre filtros sobre α
-- + S y T sobre conjunros de elementos de tipo α.
-- ---------------------------------------------------------------------

variable  (α : Type)
variable  (F : filter α)
variables (S T : set α)

-- He aquí un lema sobre los filtros: Dos conjuntos `S` y `T` están
-- ambos en un filtro `F` si su intersección lo está. Para demostrarlo,
-- es útil conocer los siguientes resultados (del espacio de nombres de
-- los conjuntos)
-- + `inter_subset_left S T : S ∩ T ⊆ S`
-- + `inter_subset_right S T : S ∩ T ⊆ S`

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    S ∩ T ∈ F ↔ S ∈ F ∧ T ∈ F
-- ---------------------------------------------------------------------

-- Demostración (por doble implicación):
-- (⟹) Supongamos que S ∩ T ∈ F. Entonces, S ∩ T ⊆ S y, por el axioma
-- mem_sets_of_superset, se tiene que S ∈ F. Análogamente se demuestra
-- que T ∈ F.
--
-- (⟸) S ∈ F ∧ T ∈ F. Entonces, S ∩ T ∈ F por el axioma inter_mem_sets.

example : S ∩ T ∈ F ↔ S ∈ F ∧ T ∈ F :=
begin
  split,
  { intro hST,
    split,
    { apply mem_sets_of_superset hST,
      exact inter_subset_left S T },
    { apply mem_sets_of_superset hST,
      exact inter_subset_right S T } },
  { rintros ⟨hS, hT⟩,
    exact inter_mem_sets hS hT }
end

-- El filtro principal `𝓟 X` generado por `X : set α` es el conjunto de
-- los subconjuntos de `α` que contienen a `X`. Se demostrará que es un
-- filtro. Para ello, son útiles los siguientes lemas:
--    `mem_univ s : s ∈ univ`
--    `subset.trans : A ⊆ B → B ⊆ C → A ⊆ C`
--    `subset_inter : X ⊆ S → X ⊆ T → X ⊆ S ∩ T`
-- (nótese que probablemente podrías demostrar estas dos últimas cosas
-- directamente, pero también podemos usar la interfaz para conjuntos
-- dado que existe)
--    `mem_set_of_eq : x ∈ {a : α | p a} = p x`
-- (este es por definición, así que podrías usar `change` en su lugar, o
-- simplemente no reescribirlo en absoluto)

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que el filtro principal `𝓟 X` generado por `X`
-- es un filtro.
-- ---------------------------------------------------------------------

-- Demostración: Se define una estructura (que en mathlib se llama
-- `𝓟 X`) formada por los subconjuntos de α que contienen a X y se
-- prueba que cumple los axiomas de filtro. Concretamente, la definición
-- es
--    𝓟 X = {S : set α | X ⊆ S}
-- y las demostraciones de los axiomas son:
--
-- (1º axioma) univ ∈ 𝓟 X ya que X ⊆ univ.
--
-- (2º axioma): Sean S ∈ 𝓟 X y S ⊆ T. Entonces, X ⊆ S y, por la
-- transitiva, X ⊆ T. Por tanto, T ∈ 𝓟 X.
--
-- (3º axioma): Sean S, T ∈ 𝓟 X. Entonces, X ⊆ S y X ⊆ T. Por tanto,
-- X ⊆ S ∩ T. Luego, S ∩ T ∈ 𝓟 X.

example (X : set α) : filter α :=
{ sets := {S : set α | X ⊆ S},
  univ_sets :=
  begin
    intros S hS,
    exact mem_univ _,
  end,
  sets_of_superset :=
  begin
    intros S T hS hT,
    change X ⊆ T,
    change X ⊆ S at hS,
    exact subset.trans hS hT,
  end,
  inter_sets :=
  begin
    intros S T hS hT,
    rw mem_set_of_eq at *,
    exact subset_inter hS hT,
  end }

-- ---------------------------------------------------------------------
-- Ejercicio. Abrir localmente el entorno filter para poder usar la
-- notación `𝓟 X` para el filtro principal generado por `X`.
-- ---------------------------------------------------------------------

open_locale filter

-- =====================================================================
-- § El orden (≤) sobre filtros                                       --
-- =====================================================================

-- Lo siguiente no es sorprendente: la colección de todos los filtros
-- sobre `α` está parcialmente ordenada. Tal vez sea más sorprendente:
-- el orden es al revés de lo que se esperaría. Si `F` y `G` son filtros
-- en `α`, entonces `F ≤ G` se define como `G.sets ⊆ F.sets`; es decir,
-- cada conjunto en el filtro `G` está también en el filtro `F`. ¿A qué
-- se debe esto? Pues bien, piensa en los filtros principales. Si `S ⊆
-- T` son dos subconjuntos, entonces `X ∈ 𝓟 T` implica `T ⊆ X`, luego `S
-- ⊆ X` y `X ∈ 𝓟 S`. Cuanto más pequeño sea el conjunto, mayor será la
-- colección de conjuntos en su filtro principal.
--
-- Formalicemos esto. Demostremos que 𝓟 S ≤ 𝓟 T ↔ S ⊆ T.
-- Nótese que esto es el lema `principal_mono` en mathlib pero
-- no hay inconveniente en demostrarlo por uno mismo.
--
-- Algunos lemas útiles para su demostración son:
-- + `le_def : F ≤ G ↔ ∀ (S : set α), S ∈ G → S ∈ F`
-- + `mem_principal_sets : T ∈ 𝓟 S ↔ S ⊆ T`
-- + `mem_principal_self S : S ∈ 𝓟 S`

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    𝓟 S ≤ 𝓟 T ↔ S ⊆ T
-- ---------------------------------------------------------------------

-- Demostración (por doble implicación)
-- (⟹) Supongamos que 𝓟 S ≤ 𝓟 T.
--       T ⊆ T ⟹ T ∈ 𝓟 T    [por definición de 𝓟 T]
--             ⟹ T ∈ 𝓟 S    [por definición de 𝓟 S ≤ 𝓟 T]
--             ⟹ S ⊆ T      [por definición de 𝓟 S]
-- (⟸) Supongamos que S ⊆ T. Para probar que 𝓟 S ≤ 𝓟 T, sea X ∈ 𝓟 T.
-- Entonces,
--       X ∈ 𝓟 T ⟹ T ⊆ X    [por definición de 𝓟 T]
--               ⟹ S ⊆ X    [porque S ⊆ T]
--               ⟹ X ∈ 𝓟 S  [por definición de 𝓟 S]

-- 1ª demostración
example : 𝓟 S ≤ 𝓟 T ↔ S ⊆ T :=
begin
  split,
  { intro h,
    rw le_def at h,
    have hT : T ∈ 𝓟 T := mem_principal_self T,
    specialize h T hT,
    rwa mem_principal_sets at h },
  { intro hST,
    rw le_def,
    intros X hX,
    rw mem_principal_sets at *,
    exact subset.trans hST hX }
end

-- 2ª demostración
example : 𝓟 S ≤ 𝓟 T ↔ S ⊆ T :=
-- by library_search
principal_mono

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que
--    F ≤ 𝓟 S ↔ S ∈ F
-- ---------------------------------------------------------------------

-- Demostración (por doble implicación)
-- (⟹) Supongamos que F ≤ 𝓟 S. Se tiene,
--    S ⊆ S ⟹ S ∈ 𝓟 S   [por def. de 𝓟 S]
--          ⟹ S ∈ F     [por def. de F ≤ 𝓟 S]
-- (⟸) Supongamos que S ∈ F. Para probar que F ≤ 𝓟 S, sea X ∈ 𝓟 S. Se
-- tiene,
--     X ∈ 𝓟 S ⟹ S ⊆ X   [por def. de 𝓟 S]
--             ⟹ X ∈ F   [porque F es un filtro y S ∈ F]

-- 1ª demostración
example : F ≤ 𝓟 S ↔ S ∈ F :=
begin
  split,
  { intro h,
    rw le_def at h,
    apply h,
    exact mem_principal_self S,},
  { rw le_def,
    intros hSF X hX,
    rw mem_principal_sets at hX,
    exact mem_sets_of_superset hSF hX },
end

-- 2ª demostración
example : F ≤ 𝓟 S ↔ S ∈ F :=
-- by library_search
le_principal_iff

-- =====================================================================
-- § Los filtros son retículos completos                              --
-- =====================================================================

-- Al igual que es posible hablar del espacio topológico generado por
-- una colección de subconjuntos de `α` (es la topología más pequeña
-- para la que los subconjuntos dados son todos abiertos) también es
-- posible hablar del filtro generado por una colección de subconjuntos
-- de `α`. Se puede definir como la intersección de todos los filtros
-- que contienen a la colección dada de subconjuntos.
--
-- En la teoría del orden, dado un orden parcial (como el orden parcial
-- de los filtros) se puede empezar a preguntar si existen ínfimos y
-- supremos. Los filtros son un ejemplo donde todas estas cosas existen
-- (ínfimos y supremos finitos e infinitos) y satisfacen una colección
-- natural de axiomas, convirtiéndolos en lo que se llama un *retículo
-- completo*. Se puede demostrar esto mostrando que "filtro generado por
-- estos conjuntos" y "conjuntos subyacentes de un filtro" son funtores
-- adjuntos y luego utilizando la teoría de las inserciones de
-- Galois. Ya hablé un poco de esto al estudiar los subgrupos, y no
-- hablaré de ello de nuevo.

-- =====================================================================
-- § Otros ejemplos de filtros                                        --
-- =====================================================================

-- =====================================================================
-- §§ Filtro de los grandes en conjuntos totalmente ordenados         --
-- =====================================================================

-- Sea `L` un conjunto totalmente ordenado no vacío. Digamos que un
-- subconjunto `X` de `L` es "grande" si existe `x : L` tal que para
-- todo `y ≥ x`, `y ∈ X`. En mathlib, se denota pot `at_top L`.
--
-- Probaremos que los subconjuntos grandes son un filtro. La idea
-- matemática es que los "grandes subconjuntos" son las entornos de `∞`,
-- por lo que el correspondiente filtro es alguna representación de un
-- entorno infinitesimal de `∞`.
--
-- Notas de implementación: `linear_order L` es el tipo de órdenes
-- lineales sobre `L`.  Además, `e : L` es una forma sencilla de decir
-- que `L` no es vacío.
--
-- Recordemos que `max x y` es el máximo de x e y en un `orden lineal`, y
-- `le_max_left a b : a ≤ max a b` y análogamente `le_max_right`.

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que si L es un orden lineal no vacío, el
-- conjunto de sus conjuntos grandes es un filtro sobre L.
-- ---------------------------------------------------------------------

-- Demostración. El conjunto de los conjuntos grandes de L es
--    F = {X : set L | ∃ x : L, ∀ y, x ≤ y → y ∈ X}
-- Tenemos que demostrar que F es un filtro probando los tres axiomas de
-- filtro.
--
-- (1ª axioma) Para demostrar que univ ∈ F, sea e cualquier elemento de
-- L (existe por ser L no vacío). Por la definición de univ, se tiene
--    ∀ y, e ≤ y → y ∈ univ
-- Por tanto, univ ∈ F.
--
-- (2º axioma) Sea X ∈ F e X ⊆ Y. De X ∈ F se deduce que existe un x ∈ L
-- tal que
--    ∀ y, x ≤ y → y ∈ X
-- y, puesto que X ⊆ Y, se tiene que
--    ∀ y, x ≤ y → y ∈ X
-- Por tanto, Y ∈ F.
--
-- (3º axioma) Sean X, Y ∈ F. Por la definición de F, existen x, y ∈ L
-- tales que
--    ∀ z, x ≤ z → z ∈ X
--    ∀ z, y ≤ z → z ∈ Y
-- Luego,
--    ∀ z, máx(x,y) ≤ z → z ∈ X ∩ Y
-- Por tanto, X ∩ Y ∈ F.

def at_top
  (L : Type)
  [linear_order L]
  (e : L)
  : filter L :=
{ sets := {X : set L | ∃ x : L, ∀ y, x ≤ y → y ∈ X},
  univ_sets :=
  begin
    use e,
    intros y hy,
    exact mem_univ y,
  end,
  sets_of_superset :=
  begin
    rintros X Y ⟨x, hX⟩ hXY,
    rw mem_set_of_eq,
    use x,
    intros y hxy,
    rw subset_def at hXY,
    apply hXY,
    exact hX _ hxy,
  end,
  inter_sets :=
  begin
    rintros X Y ⟨x, hX⟩ ⟨y, hY⟩,
    use max x y,
    intros z hz,
    split,
    { apply hX,
      apply le_trans _ hz,
      exact le_max_left x y },
    { apply hY,
      apply le_trans _ hz,
      exact le_max_right x y, },
  end }

-- =====================================================================
-- §§ El filtro cofinito                                              --
-- =====================================================================

-- El *filtro cofinito* sobre un tipo `α` tiene como conjuntos los
-- subconjuntos `S : set α` con la propiedad de que `Sᶜ`, el complemento
-- de `S`, es finito. Demostremos que es un filtro.
--
-- Lemas que pueden ser útiles en su demostración:
--    `compl_univ : univᶜ = ∅`
--    `finite_empty : finite ∅`
--    `compl_subset_compl : Xᶜ ⊆ Yᶜ ↔ Y ⊆ X`
--    `finite.subset : S.finite → ∀ {T : set α}, T ⊆ S → T.finite`
--    `compl_inter S T : (S ∩ T)ᶜ = Sᶜ ∪ Tᶜ`
--    `finite.union : S.finite → T.finite → (S ∪ T).finite`
--
-- Nota. Si estás pensando "Nunca podría usar Lean por mí mismo, no
-- conozco los nombres de todos los lemas, así que tengo que confiar en
-- que el enunciado me los diga". Se pueden encontrar los lemas
-- presionando Mayúscula-espacio y las reglas para formar sus nombres.

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que el conjunto de los subconjuntos de α cuyo
-- complementario es finito es un filtro sobre α.
-- ---------------------------------------------------------------------

-- Demostración. Sea
--    F = {S : set α | Sᶜ es finito}
-- Tenemos que demostrar que F es un filtro probando los tres axiomas de
-- filtro.
--
-- (1ª axioma). Puesto que univᶜ = ∅, que es finito, se tiene que
-- univ ∈ F.
--
-- (2º axioma). Sean S ∈ F y S ⊆ T. Entonces, Sᶜ es finito y
-- Tᶜ ⊆ Sᶜ. Por tanto, Tᶜ es finito y T ∈ F.
--
-- (3ª axioma). Sean S, T ∈ F. Entonces, Sᶜ y Tᶜ son finitos y, puesto
-- que
--    (S ∩ T)ᶜ = Sᶜ ∪ Tᶜ
-- también (S ∩ T)ᶜ es finito. Por tanto, S ∩ T ∈ F.

def cofinite (α : Type) : filter α :=
{ sets := {S : set α | (Sᶜ).finite},
  univ_sets :=
  begin
    rw mem_set_of_eq,
    rw compl_univ,
    exact finite_empty,
  end,
  sets_of_superset :=
  begin
    intros S T hS hST,
    rw mem_set_of_eq at *,
    rw ← compl_subset_compl at hST,
    exact finite.subset hS hST,
  end,
  inter_sets :=
  begin
    intros S T hS hT,
    rw mem_set_of_eq at *,
    rw compl_inter,
    exact finite.union hS hT,
  end }

-- =====================================================================
-- § Ejercicios                                                       --
-- =====================================================================

-- No es necesario que sepas hacer los siguientes ejercicios para pasar
-- a la parte de topología del tema. Los ejercicios son
-- 1. Demostrar que el filtro cofinito en un tipo finito es el filtro
--    del conjunto de potencias entero.
-- 2. Demostrar que el filtro cofinito sobre `ℕ` es igual al filtro
--    de los subconjuntos grandes (i.e., `at_top`).
-- 3. Demostrar que el filtro cofinito sobre `ℤ` no es igual al filtro
--    de los subconjuntos grandes (i.e., `at_top`).
-- 4. Demostrar que el filtro cofinito sobre `ℕ` no es principal.
--
-- Puedes probarlos en Lean pero tendrás que dominar los conceptos de la
-- finitud. Aquí, por ejemplo, están algunas de las ideas que
-- necesitarás para hacer (4) en Lean. La prueba utiliza varios lemas de
-- la API de conjuntos, como los siguientes:
-- + filter.ext_iff {α : Type u} {f g : filter α} :
--      f = g ↔ ∀ (s : set α), s ∈ f ↔ s ∈ g
-- + diff_eq_compl_inter {α : Type u} {s t : set α} :
--      s \ t = tᶜ ∩ s
-- + compl_inter {α : Type u} (s t : set α) :
--      (s ∩ t)ᶜ = sᶜ ∪ tᶜ
-- + compl_compl {α : Type u} [boolean_algebra α] (x : α) :
--      xᶜᶜ = x
-- + set.finite_singleton {α : Type u} (a : α) :
--      {a}.finite
-- + mem_diff_singleton {α : Type u} {x y : α} {s : set α} :
--      x ∈ s \ {y} ↔ x ∈ s ∧ x ≠ y
--
-- También se necesitan los dos lemas siguientes que no están en mathlib:

lemma infinite_of_finite_compl
  {α : Type}
  [infinite α]
  {s : set α}
  (hs : sᶜ.finite)
  : s.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)

lemma set.infinite.nonempty
  {α}
  {s : set α}
  (h : s.infinite)
  : ∃ a : α, a ∈ s :=
let a := set.infinite.nat_embedding s h 37 in ⟨a.1, a.2⟩

lemma mem_cofinite
  {S : set ℕ}
  : S ∈ cofinite ℕ ↔ Sᶜ.finite :=
begin
  refl
end

-- ---------------------------------------------------------------------
-- Ejercicio. Demostrar que el filtro cofinito sobre `ℕ` no es
-- principal.
-- ---------------------------------------------------------------------

-- Demostración. Basta demostrar que para cualquier S ⊆ ℕ, el filtro
-- principal de S no es el filtro cofinito. Lo haremos por reducción al
-- absurdo. Para ello, supongamos que existe un S ⊆ ℕ cuyo filtro
-- principal es el filtro cofinito; es decir,
--    {X : set ℕ | S ⊆ X} = {X : set ℕ | Xᶜ es finito}               (1)
-- Luego, Sᶜ es finito (ya que S ⊆ S) y, por tanto, S es infinito lo que
-- significa que existe un a ∈ S. Sea T = S \ {a}. Entonces,
--    Tᶜ = (S \ {a})ᶜ = Sᶜ ∪ {a}
-- lo que implica que Tᶜ es finito y, por (1), S ⊆ T; es decir,
-- S ⊆ S \ {a} con a ∈ S lo que es una contradicción.

theorem cofinite_not_principal :
  ∀ S : set ℕ, cofinite ℕ ≠ 𝓟 S :=
begin
  intros S h,
  rw filter.ext_iff at h,
  have hS := h S,
  rw mem_cofinite at hS,
  have hS2 : Sᶜ.finite,
  { rw hS,
    apply mem_principal_self },
  { clear hS,
    have hS3 := infinite_of_finite_compl hS2,
    have hS4 : ∃ s : ℕ, s ∈ S := set.infinite.nonempty hS3,
    cases hS4 with a ha,
    set T := S \ {a} with hTdef,
    specialize h T,
    have hT : T ∈ cofinite ℕ,
    { rw [mem_cofinite, hTdef, diff_eq_compl_inter, compl_inter, compl_compl],
      apply finite.union _ hS2,
      apply finite_singleton },
    rw h at hT,
    rw mem_principal_sets at hT,
    specialize hT ha,
    rw [hTdef, mem_diff_singleton] at hT,
    cases hT with _ hcontra,
    apply hcontra,
    refl, },
end


-- La_paradoja_del_barbero.lean
-- La paradoja del barbero.
-- José A. Alonso Jiménez
-- Sevilla, 26 de julio de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar la paradoja del barbero https://bit.ly/3eWyvVw es decir,
-- que no existe un hombre que afeite a todos los que no se afeitan a sí
-- mismo y sólo a los que no se afeitan a sí mismo.
-- ---------------------------------------------------------------------

import tactic

variable (Hombre : Type)
variable (afeita : Hombre → Hombre → Prop)

-- 1ª demostración
example :
  ¬(∃ x : Hombre, ∀ y : Hombre, afeita x y ↔ ¬ afeita y y) :=
begin
  intro h,
  cases h with b hb,
  specialize hb b,
  by_cases (afeita b b),
  { apply absurd h,
    exact hb.mp h, },
  { apply h,
    exact hb.mpr h, },
end

-- 2ª demostración
example :
  ¬(∃ x : Hombre, ∀ y : Hombre, afeita x y ↔ ¬ afeita y y) :=
begin
  intro h,
  cases h with b hb,
  specialize hb b,
  by_cases (afeita b b),
  { exact (hb.mp h) h, },
  { exact h (hb.mpr h), },
end

-- 3ª demostración
example :
  ¬(∃ x : Hombre, ∀ y : Hombre, afeita x y ↔ ¬ afeita y y) :=
begin
  intro h,
  cases h with b hb,
  specialize hb b,
  by itauto,
end

-- 4ª demostración
example :
  ¬ (∃ x : Hombre,  ∀ y : Hombre, afeita x y ↔ ¬ afeita y y ) :=
begin
  rintro ⟨b, hb⟩,
  exact (iff_not_self (afeita b b)).mp (hb b),
end

-- 5ª demostración
example :
  ¬ (∃ x : Hombre,  ∀ y : Hombre, afeita x y ↔ ¬ afeita y y ) :=
λ ⟨b, hb⟩, (iff_not_self (afeita b b)).mp (hb b)


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

! This file was ported from Lean 3 source module measure_theory.covering.vitali
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.MetricSpace.Basic
import Mathbin.MeasureTheory.Constructions.BorelSpace
import Mathbin.MeasureTheory.Covering.VitaliFamily

/-!
# 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`.
-/

variable {α ι : Type _}

open Set Metric MeasureTheory TopologicalSpace Filter

open NNReal Classical ENNReal Topology

namespace Vitali

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (u «expr ⊆ » t) -/
/-- 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 : _)(_ : u ⊆ t),
      u.PairwiseDisjoint B ∧ ∀ a ∈ t, ∃ b ∈ u, (B a ∩ B b).Nonempty ∧ δ a ≤ τ * δ b :=
  by
  /- 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.PairwiseDisjoint 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 :=
    by
    refine' zorn_subset _ fun U UT hU => _
    refine' ⟨⋃₀ U, _, fun s hs => subset_sUnion_of_mem hs⟩
    simp only [Set.unionₛ_subset_iff, and_imp, exists_prop, forall_exists_index, mem_sUnion,
      Set.mem_setOf_eq]
    refine'
      ⟨fun u hu => (UT hu).1, (pairwise_disjoint_sUnion hU.directed_on).2 fun u hu => (UT hu).2.1,
        fun 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, fun a hat => _⟩
  contrapose! hu
  have a_disj : ∀ c ∈ u, Disjoint (B a) (B c) :=
    by
    intro 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 : BddAbove (δ '' A) := by
    refine' ⟨R, fun 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' :=
    by
    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 := by
        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 := fun 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 fun 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 `δ`.
  · intro 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, Classical.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
#align vitali.exists_disjoint_subfamily_covering_enlargment Vitali.exists_disjoint_subfamily_covering_enlargment

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (u «expr ⊆ » t) -/
/-- 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_closedBall [MetricSpace α] (t : Set ι)
    (x : ι → α) (r : ι → ℝ) (R : ℝ) (hr : ∀ a ∈ t, r a ≤ R) :
    ∃ (u : _)(_ : u ⊆ t),
      (u.PairwiseDisjoint fun a => closedBall (x a) (r a)) ∧
        ∀ a ∈ t, ∃ b ∈ u, closedBall (x a) (r a) ⊆ closedBall (x b) (5 * r b) :=
  by
  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, fun a ha b hb hab => by
        simp only [Function.onFun, closed_ball_eq_empty.2 (ht a ha), empty_disjoint], fun 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 (fun a => closed_ball (x a) (r a)) t' r 2
      one_lt_two (fun a ha => ha.2) R (fun a ha => hr a ha.1) fun 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) :=
    by
    intro 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 fun a ha => ha.1, u_disj, fun 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]⟩
#align vitali.exists_disjoint_subfamily_covering_enlargment_closed_ball Vitali.exists_disjoint_subfamily_covering_enlargment_closedBall

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (u «expr ⊆ » t') -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (u «expr ⊆ » t) -/
/-- 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 [MetricSpace α] [MeasurableSpace α] [OpensMeasurableSpace α]
    [SecondCountableTopology α] (μ : Measure α) [IsLocallyFiniteMeasure μ] (s : Set α) (t : Set ι)
    (C : ℝ≥0) (r : ι → ℝ) (c : ι → α) (B : ι → Set α) (hB : ∀ a ∈ t, B a ⊆ closedBall (c a) (r a))
    (μB : ∀ a ∈ t, μ (closedBall (c a) (3 * r a)) ≤ C * μ (B a))
    (ht : ∀ a ∈ t, (interior (B a)).Nonempty) (h't : ∀ a ∈ t, IsClosed (B a))
    (hf : ∀ x ∈ s, ∀ ε > (0 : ℝ), ∃ a ∈ t, r a ≤ ε ∧ c a = x) :
    ∃ (u : _)(_ : u ⊆ t), u.Countable ∧ u.PairwiseDisjoint B ∧ μ (s \ ⋃ a ∈ u, B a) = 0 :=
  by
  /- 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)) < ∞ :=
    by
    intro 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_iff, 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 : _)(_ : u ⊆ t'),
      u.PairwiseDisjoint B ∧ ∀ a ∈ t', ∃ b ∈ u, (B a ∩ B b).Nonempty ∧ r a ≤ 2 * r b :=
    by
    have A : ∀ a ∈ t', r a ≤ 1 := by
      intro a ha
      apply ha.2.trans (hR1 (c a))
    have A' : ∀ a ∈ t', (B a).Nonempty := fun a hat' =>
      Set.Nonempty.mono interior_subset (ht a hat'.1)
    refine' exists_disjoint_subfamily_covering_enlargment B t' r 2 one_lt_two (fun a ha => _) 1 A A'
    exact nonempty_closed_ball.1 ((A' a ha).mono (hB a ha.1))
  have ut : u ⊆ t := fun 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 fun a ha => ht a (ut ha)
  -- the family `u` will be the desired family
  refine' ⟨u, fun 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 _ fun 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 := fun 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 :=
    by
    have Idist_v : ∀ a ∈ v, dist (c a) x ≤ r a + R x :=
      by
      intro 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 : BddAbove (r '' v) :=
      by
      refine' ⟨1, fun 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, fun 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
        by_contra
        rw [nonempty_iff_ne_empty, Classical.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 :=
        by
        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]
      · intro 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_nhdsWithin _ (ball_mem_nhds _ (hR0 _)),
      nonpos_iff_eq_zero.mp (le_of_forall_le_of_dense fun ε ε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)) < ∞ := by
    calc
      (∑' a : v, μ (B a)) = μ (⋃ a ∈ v, B a) :=
        by
        rw [measure_bUnion (u_count.mono vu) _ fun a ha => (h't _ (vu.trans ut ha)).MeasurableSet]
        exact u_disj.subset vu
      _ ≤ μ (closed_ball x K) := (measure_mono (Union₂_subset fun 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 :=
    haveI : 0 < ε / C := by
      simp only [ENNReal.div_pos_iff, εpos.ne', ENNReal.coe_ne_top, Ne.def, not_false_iff,
        and_self_iff]
    ((tendsto_order.1 (ENNReal.tendsto_tsum_compl_atTop_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) :=
    by
    intro z hz
    set k := ⋃ (a : v) (ha : a ∈ w), B a with hk
    have k_closed : IsClosed k := isClosed_bunionᵢ w.finite_to_set fun i hi => h't _ (ut (vu i.2))
    have z_notmem_k : z ∉ k :=
      by
      simp only [not_exists, exists_prop, mem_Union, mem_sep_iff, forall_exists_index,
        SetCoe.exists, not_and, exists_and_right, Subtype.coe_mk]
      intro 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 :=
      by
      apply IsOpen.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
    exact 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) := by
      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
    exact hu a ⟨hat, ad.trans (min_le_right _ _)⟩
    have bv : b ∈ v := by
      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 := by
      intro b'w
      have b'k : B b' ⊆ k := @Finset.subset_set_bunionᵢ_of_mem _ _ _ (fun y : v => B y) _ b'w
      have : (ball x (R x) \ k ∩ k).Nonempty :=
        by
        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) :=
      by
      rcases ab with ⟨e, ⟨ea, eb⟩⟩
      have A : dist (c a) e ≤ r a := mem_closed_ball'.1 (hB a hat ea)
      have B : dist e (c b) ≤ r b := 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)
    exact H zb
    exact subset_Union (fun 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).toEncodable
  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 fun 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

#align vitali.exists_disjoint_covering_ae Vitali.exists_disjoint_covering_ae

/-- 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 vitaliFamily [MetricSpace α] [MeasurableSpace α] [OpensMeasurableSpace α]
    [SecondCountableTopology α] (μ : Measure α) [IsLocallyFiniteMeasure μ] (C : ℝ≥0)
    (h : ∀ x, ∃ᶠ r in 𝓝[>] 0, μ (closedBall x (3 * r)) ≤ C * μ (closedBall x r)) : VitaliFamily μ
    where
  setsAt x :=
    { a |
      IsClosed a ∧
        (interior a).Nonempty ∧ ∃ r, a ⊆ closedBall x r ∧ μ (closedBall x (3 * r)) ≤ C * μ a }
  MeasurableSet' x a ha := ha.1.MeasurableSet
  nonempty_interior x a ha := ha.2.1
  Nontrivial x ε εpos :=
    by
    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_nhdsWithin_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
  covering := by
    intro 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 ∧ IsClosed 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 :=
      by
      intro 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 (fun p => p.1) (fun p => p.2.1) (fun p => p.2.2)
        (fun p hp => hp.1) (fun p hp => hp.2.1) (fun p hp => hp.2.2.1) (fun p hp => hp.2.2.2.1)
        A with
      ⟨t', t't, t'_count, t'_disj, μt'⟩
    refine' ⟨(fun p : ℝ × α × Set α => p.2) '' t', _, _, _, _⟩
    · rintro - ⟨q, hq, rfl⟩
      exact (t't hq).2.2.2.2.2
    · rintro p ⟨q, hq, rfl⟩ p' ⟨q', hq', rfl⟩ hqq'
      exact t'_disj hq hq' (ne_of_apply_ne _ hqq')
    · rintro - ⟨q, hq, rfl⟩
      exact (t't hq).2.2.2.2.1
    · convert μt' using 3
      rw [bUnion_image]
#align vitali.vitali_family Vitali.vitaliFamily

end Vitali


theorem le_succ (a b : mynat) : a ≤ b → a ≤ (succ b) :=
begin
intro h,
cases h with c hc,
use (succ c),
rw hc,
refl,
end