/-
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 measure_theory.covering.differentiation
import measure_theory.covering.vitali_family
import measure_theory.integral.lebesgue
import measure_theory.measure.regular
import set_theory.ordinal.arithmetic
import topology.metric_space.basic

/-!
# Besicovitch covering theorems

The topological Besicovitch covering theorem ensures that, in a nice metric space, there exists a
number `N` such that, from any family of balls with bounded radii, one can extract `N` families,
each made of disjoint balls, covering together all the centers of the initial family.

By "nice metric space", we mean a technical property stated as follows: there exists no satellite
configuration of `N + 1` points (with a given parameter `τ > 1`). Such a configuration is a family
of `N + 1` balls, where the first `N` balls all intersect the last one, but none of them contains
the center of another one and their radii are controlled. This property is for instance
satisfied by finite-dimensional real vector spaces.

In this file, we prove the topological Besicovitch covering theorem,
in `besicovitch.exist_disjoint_covering_families`.

The measurable Besicovitch theorem ensures that, in the same class of metric spaces, if at every
point one considers a class of balls of arbitrarily small radii, called admissible balls, then
one can cover almost all the space by a family of disjoint admissible balls.
It is deduced from the topological Besicovitch theorem, and proved
in `besicovitch.exists_disjoint_closed_ball_covering_ae`.

This implies that balls of small radius form a Vitali family in such spaces. Therefore, theorems
on differentiation of measures hold as a consequence of general results. We restate them in this
context to make them more easily usable.

## Main definitions and results

* `satellite_config α N τ` is the type of all satellite configurations of `N + 1` points
  in the metric space `α`, with parameter `τ`.
* `has_besicovitch_covering` is a class recording that there exist `N` and `τ > 1` such that
  there is no satellite configuration of `N + 1` points with parameter `τ`.
* `exist_disjoint_covering_families` is the topological Besicovitch covering theorem: from any
  family of balls one can extract finitely many disjoint subfamilies covering the same set.
* `exists_disjoint_closed_ball_covering` is the measurable Besicovitch covering theorem: from any
  family of balls with arbitrarily small radii at every point, one can extract countably many
  disjoint balls covering almost all the space. While the value of `N` is relevant for the precise
  statement of the topological Besicovitch theorem, it becomes irrelevant for the measurable one.
  Therefore, this statement is expressed using the `Prop`-valued
  typeclass `has_besicovitch_covering`.

We also restate the following specialized versions of general theorems on differentiation of
measures:
* `besicovitch.ae_tendsto_rn_deriv` ensures that `ρ (closed_ball x r) / μ (closed_ball x r)` tends
  almost surely to the Radon-Nikodym derivative of `ρ` with respect to `μ` at `x`.
* `besicovitch.ae_tendsto_measure_inter_div` states that almost every point in an arbitrary set `s`
  is a Lebesgue density point, i.e., `μ (s ∩ closed_ball x r) / μ (closed_ball x r)` tends to `1` as
  `r` tends to `0`. A stronger version for measurable sets is given in
  `besicovitch.ae_tendsto_measure_inter_div_of_measurable_set`.

## Implementation

#### Sketch of proof of the topological Besicovitch theorem:

We choose balls in a greedy way. First choose a ball with maximal radius (or rather, since there
is no guarantee the maximal radius is realized, a ball with radius within a factor `τ` of the
supremum). Then, remove all balls whose center is covered by the first ball, and choose among the
remaining ones a ball with radius close to maximum. Go on forever until there is no available
center (this is a transfinite induction in general).

Then define inductively a coloring of the balls. A ball will be of color `i` if it intersects
already chosen balls of color `0`, ..., `i - 1`, but none of color `i`. In this way, balls of the
same color form a disjoint family, and the space is covered by the families of the different colors.

The nontrivial part is to show that at most `N` colors are used. If one needs `N + 1` colors,
consider the first time this happens. Then the corresponding ball intersects `N` balls of the
different colors. Moreover, the inductive construction ensures that the radii of all the balls are
controlled: they form a satellite configuration with `N + 1` balls (essentially by definition of
satellite configurations). Since we assume that there are no such configurations, this is a
contradiction.

#### Sketch of proof of the measurable Besicovitch theorem:

From the topological Besicovitch theorem, one can find a disjoint countable family of balls
covering a proportion `> 1 / (N + 1)` of the space. Taking a large enough finite subset of these
balls, one gets the same property for finitely many balls. Their union is closed. Therefore, any
point in the complement has around it an admissible ball not intersecting these finitely many balls.
Applying again the topological Besicovitch theorem, one extracts from these a disjoint countable
subfamily covering a proportion `> 1 / (N + 1)` of the remaining points, and then even a disjoint
finite subfamily. Then one goes on again and again, covering at each step a positive proportion of
the remaining points, while remaining disjoint from the already chosen balls. The union of all these
balls is the desired almost everywhere covering.
-/

noncomputable theory

universe u

open metric set filter fin measure_theory topological_space
open_locale topology classical big_operators ennreal measure_theory nnreal

/-!
### Satellite configurations
-/

/-- A satellite configuration is a configuration of `N+1` points that shows up in the inductive
construction for the Besicovitch covering theorem. It depends on some parameter `τ ≥ 1`.

This is a family of balls (indexed by `i : fin N.succ`, with center `c i` and radius `r i`) such
that the last ball intersects all the other balls (condition `inter`),
and given any two balls there is an order between them, ensuring that the first ball does not
contain the center of the other one, and the radius of the second ball can not be larger than
the radius of the first ball (up to a factor `τ`). This order corresponds to the order of choice
in the inductive construction: otherwise, the second ball would have been chosen before.
This is the condition `h`.

Finally, the last ball is chosen after all the other ones, meaning that `h` can be strengthened
by keeping only one side of the alternative in `hlast`.
-/
structure besicovitch.satellite_config (α : Type*) [metric_space α] (N : ℕ) (τ : ℝ) :=
(c : fin N.succ → α)
(r : fin N.succ → ℝ)
(rpos : ∀ i, 0 < r i)
(h : ∀ i j, i ≠ j → (r i ≤ dist (c i) (c j) ∧ r j ≤ τ * r i) ∨
                    (r j ≤ dist (c j) (c i) ∧ r i ≤ τ * r j))
(hlast : ∀ i < last N, r i ≤ dist (c i) (c (last N)) ∧ r (last N) ≤ τ * r i)
(inter : ∀ i < last N, dist (c i) (c (last N)) ≤ r i + r (last N))

/-- A metric space has the Besicovitch covering property if there exist `N` and `τ > 1` such that
there are no satellite configuration of parameter `τ` with `N+1` points. This is the condition that
guarantees that the measurable Besicovitch covering theorem holds. It is satified by
finite-dimensional real vector spaces. -/
class has_besicovitch_covering (α : Type*) [metric_space α] : Prop :=
(no_satellite_config [] : ∃ (N : ℕ) (τ : ℝ), 1 < τ ∧ is_empty (besicovitch.satellite_config α N τ))

/-- There is always a satellite configuration with a single point. -/
instance {α : Type*} {τ : ℝ} [inhabited α] [metric_space α] :
  inhabited (besicovitch.satellite_config α 0 τ) :=
⟨{ c := default,
  r := λ i, 1,
  rpos := λ i, zero_lt_one,
  h := λ i j hij, (hij (subsingleton.elim i j)).elim,
  hlast := λ i hi, by { rw subsingleton.elim i (last 0) at hi, exact (lt_irrefl _ hi).elim },
  inter := λ i hi, by { rw subsingleton.elim i (last 0) at hi, exact (lt_irrefl _ hi).elim } }⟩

namespace besicovitch

namespace satellite_config
variables {α : Type*} [metric_space α] {N : ℕ} {τ : ℝ} (a : satellite_config α N τ)

lemma inter' (i : fin N.succ) : dist (a.c i) (a.c (last N)) ≤ a.r i + a.r (last N) :=
begin
  rcases lt_or_le i (last N) with H|H,
  { exact a.inter i H },
  { have I : i = last N := top_le_iff.1 H,
    have := (a.rpos (last N)).le,
    simp only [I, add_nonneg this this, dist_self] }
end

lemma hlast' (i : fin N.succ) (h : 1 ≤ τ) : a.r (last N) ≤ τ * a.r i :=
begin
  rcases lt_or_le i (last N) with H|H,
  { exact (a.hlast i H).2 },
  { have : i = last N := top_le_iff.1 H,
    rw this,
    exact le_mul_of_one_le_left (a.rpos _).le h }
end

end satellite_config

/-! ### Extracting disjoint subfamilies from a ball covering -/

/-- A ball package is a family of balls in a metric space with positive bounded radii. -/
structure ball_package (β : Type*) (α : Type*) :=
(c : β → α)
(r : β → ℝ)
(rpos : ∀ b, 0 < r b)
(r_bound : ℝ)
(r_le : ∀ b, r b ≤ r_bound)

/-- The ball package made of unit balls. -/
def unit_ball_package (α : Type*) : ball_package α α :=
{ c := id,
  r := λ _, 1,
  rpos := λ _, zero_lt_one,
  r_bound := 1,
  r_le := λ _, le_rfl }

instance (α : Type*) : inhabited (ball_package α α) :=
⟨unit_ball_package α⟩

/-- A Besicovitch tau-package is a family of balls in a metric space with positive bounded radii,
together with enough data to proceed with the Besicovitch greedy algorithm. We register this in
a single structure to make sure that all our constructions in this algorithm only depend on
one variable. -/
structure tau_package (β : Type*) (α : Type*) extends ball_package β α :=
(τ : ℝ)
(one_lt_tau : 1 < τ)

instance (α : Type*) : inhabited (tau_package α α) :=
⟨{ τ := 2,
  one_lt_tau := one_lt_two,
  .. unit_ball_package α }⟩

variables {α : Type*} [metric_space α] {β : Type u}

namespace tau_package

variables [nonempty β] (p : tau_package β α)
include p

/-- Choose inductively large balls with centers that are not contained in the union of already
chosen balls. This is a transfinite induction. -/
noncomputable def index : ordinal.{u} → β
| i :=
    -- `Z` is the set of points that are covered by already constructed balls
    let Z := ⋃ (j : {j // j < i}), ball (p.c (index j)) (p.r (index j)),
    -- `R` is the supremum of the radii of balls with centers not in `Z`
    R := supr (λ b : {b : β // p.c b ∉ Z}, p.r b) in
    -- return an index `b` for which the center `c b` is not in `Z`, and the radius is at
    -- least `R / τ`, if such an index exists (and garbage otherwise).
    classical.epsilon (λ b : β, p.c b ∉ Z ∧ R ≤ p.τ * p.r b)
using_well_founded {dec_tac := `[exact j.2]}

/-- The set of points that are covered by the union of balls selected at steps `< i`. -/
def Union_up_to (i : ordinal.{u}) : set α :=
⋃ (j : {j // j < i}), ball (p.c (p.index j)) (p.r (p.index j))

lemma monotone_Union_up_to : monotone p.Union_up_to :=
begin
  assume i j hij,
  simp only [Union_up_to],
  exact Union_mono' (λ r, ⟨⟨r, r.2.trans_le hij⟩, subset.rfl⟩),
end

/-- Supremum of the radii of balls whose centers are not yet covered at step `i`. -/
def R (i : ordinal.{u}) : ℝ :=
supr (λ b : {b : β // p.c b ∉ p.Union_up_to i}, p.r b)

/-- Group the balls into disjoint families, by assigning to a ball the smallest color for which
it does not intersect any already chosen ball of this color. -/
noncomputable def color : ordinal.{u} → ℕ
| i := let A : set ℕ := ⋃ (j : {j // j < i})
          (hj : (closed_ball (p.c (p.index j)) (p.r (p.index j))
            ∩ closed_ball (p.c (p.index i)) (p.r (p.index i))).nonempty), {color j} in
       Inf (univ \ A)
using_well_founded {dec_tac := `[exact j.2]}

/-- `p.last_step` is the first ordinal where the construction stops making sense, i.e., `f` returns
garbage since there is no point left to be chosen. We will only use ordinals before this step. -/
def last_step : ordinal.{u} :=
Inf {i | ¬ ∃ (b : β), p.c b ∉ p.Union_up_to i ∧ p.R i ≤ p.τ * p.r b}

lemma last_step_nonempty :
  {i | ¬ ∃ (b : β), p.c b ∉ p.Union_up_to i ∧ p.R i ≤ p.τ * p.r b}.nonempty :=
begin
  by_contra,
  suffices H : function.injective p.index, from not_injective_of_ordinal p.index H,
  assume x y hxy,
  wlog x_le_y : x ≤ y generalizing x y,
  { exact (this hxy.symm (le_of_not_le x_le_y)).symm },
  rcases eq_or_lt_of_le x_le_y with rfl|H, { refl },
  simp only [nonempty_def, not_exists, exists_prop, not_and, not_lt, not_le, mem_set_of_eq,
    not_forall] at h,
  specialize h y,
  have A : p.c (p.index y) ∉ p.Union_up_to y,
  { have : p.index y = classical.epsilon (λ b : β, p.c b ∉ p.Union_up_to y ∧ p.R y ≤ p.τ * p.r b),
      by { rw [tau_package.index], refl },
    rw this,
    exact (classical.epsilon_spec h).1 },
  simp only [Union_up_to, not_exists, exists_prop, mem_Union, mem_closed_ball, not_and, not_le,
              subtype.exists, subtype.coe_mk] at A,
  specialize A x H,
  simp [hxy] at A,
  exact (lt_irrefl _ ((p.rpos (p.index y)).trans_le A)).elim
end

/-- Every point is covered by chosen balls, before `p.last_step`. -/
lemma mem_Union_up_to_last_step (x : β) : p.c x ∈ p.Union_up_to p.last_step :=
begin
  have A : ∀ (z : β), p.c z ∈ p.Union_up_to p.last_step ∨ p.τ * p.r z < p.R p.last_step,
  { have : p.last_step ∈ {i | ¬ ∃ (b : β), p.c b ∉ p.Union_up_to i ∧ p.R i ≤ p.τ * p.r b} :=
      Inf_mem p.last_step_nonempty,
    simpa only [not_exists, mem_set_of_eq, not_and_distrib, not_le, not_not_mem] },
  by_contra,
  rcases A x with H|H, { exact h H },
  have Rpos : 0 < p.R p.last_step,
  { apply lt_trans (mul_pos (_root_.zero_lt_one.trans p.one_lt_tau) (p.rpos _)) H },
  have B : p.τ⁻¹ * p.R p.last_step < p.R p.last_step,
  { conv_rhs { rw ← one_mul (p.R p.last_step) },
    exact mul_lt_mul (inv_lt_one p.one_lt_tau) le_rfl Rpos zero_le_one },
  obtain ⟨y, hy1, hy2⟩ : ∃ (y : β),
    p.c y ∉ p.Union_up_to p.last_step ∧ (p.τ)⁻¹ * p.R p.last_step < p.r y,
  { simpa only [exists_prop, mem_range, exists_exists_and_eq_and, subtype.exists, subtype.coe_mk]
      using exists_lt_of_lt_cSup _ B,
    rw [← image_univ, nonempty_image_iff],
    exact ⟨⟨_, h⟩, mem_univ _⟩ },
  rcases A y with Hy|Hy,
  { exact hy1 Hy },
  { rw ← div_eq_inv_mul at hy2,
    have := (div_le_iff' (_root_.zero_lt_one.trans p.one_lt_tau)).1 hy2.le,
    exact lt_irrefl _ (Hy.trans_le this) }
end

/-- If there are no configurations of satellites with `N+1` points, one never uses more than `N`
distinct families in the Besicovitch inductive construction. -/
lemma color_lt {i : ordinal.{u}} (hi : i < p.last_step)
  {N : ℕ} (hN : is_empty (satellite_config α N p.τ)) :
  p.color i < N :=
begin
  /- By contradiction, consider the first ordinal `i` for which one would have `p.color i = N`.
  Choose for each `k < N` a ball with color `k` that intersects the ball at color `i`
  (there is such a ball, otherwise one would have used the color `k` and not `N`).
  Then this family of `N+1` balls forms a satellite configuration, which is forbidden by
  the assumption `hN`. -/
  induction i using ordinal.induction with i IH,
  let A : set ℕ := ⋃ (j : {j // j < i})
         (hj : (closed_ball (p.c (p.index j)) (p.r (p.index j))
            ∩ closed_ball (p.c (p.index i)) (p.r (p.index i))).nonempty), {p.color j},
  have color_i : p.color i = Inf (univ \ A), by rw [color],
  rw color_i,
  have N_mem : N ∈ univ \ A,
  { simp only [not_exists, true_and, exists_prop, mem_Union, mem_singleton_iff, mem_closed_ball,
      not_and, mem_univ, mem_diff, subtype.exists, subtype.coe_mk],
    assume j ji hj,
    exact (IH j ji (ji.trans hi)).ne' },
  suffices : Inf (univ \ A) ≠ N,
  { rcases (cInf_le (order_bot.bdd_below (univ \ A)) N_mem).lt_or_eq with H|H,
    { exact H },
    { exact (this H).elim } },
  assume Inf_eq_N,
  have : ∀ k, k < N → ∃ j, j < i
    ∧ (closed_ball (p.c (p.index j)) (p.r (p.index j))
        ∩ closed_ball (p.c (p.index i)) (p.r (p.index i))).nonempty
    ∧ k = p.color j,
  { assume k hk,
    rw ← Inf_eq_N at hk,
    have : k ∈ A,
      by simpa only [true_and, mem_univ, not_not, mem_diff] using nat.not_mem_of_lt_Inf hk,
    simp at this,
    simpa only [exists_prop, mem_Union, mem_singleton_iff, mem_closed_ball, subtype.exists,
      subtype.coe_mk] },
  choose! g hg using this,
  -- Choose for each `k < N` an ordinal `G k < i`  giving a ball of color `k` intersecting
  -- the last ball.
  let G : ℕ → ordinal := λ n, if n = N then i else g n,
  have color_G : ∀ n, n ≤ N → p.color (G n) = n,
  { assume n hn,
    unfreezingI { rcases hn.eq_or_lt with rfl|H },
    { simp only [G], simp only [color_i, Inf_eq_N, if_true, eq_self_iff_true] },
    { simp only [G], simp only [H.ne, (hg n H).right.right.symm, if_false] } },
  have G_lt_last : ∀ n, n ≤ N → G n < p.last_step,
  { assume n hn,
    unfreezingI { rcases hn.eq_or_lt with rfl|H },
    { simp only [G], simp only [hi, if_true, eq_self_iff_true], },
    { simp only [G], simp only [H.ne, (hg n H).left.trans hi, if_false] } },
  have fGn : ∀ n, n ≤ N →
    p.c (p.index (G n)) ∉ p.Union_up_to (G n) ∧ p.R (G n) ≤ p.τ * p.r (p.index (G n)),
  { assume n hn,
    have: p.index (G n) = classical.epsilon
      (λ t, p.c t ∉ p.Union_up_to (G n) ∧ p.R (G n) ≤ p.τ * p.r t), by { rw index, refl },
    rw this,
    have : ∃ t, p.c t ∉ p.Union_up_to (G n) ∧ p.R (G n) ≤ p.τ * p.r t,
      by simpa only [not_exists, exists_prop, not_and, not_lt, not_le, mem_set_of_eq,
        not_forall] using not_mem_of_lt_cInf (G_lt_last n hn) (order_bot.bdd_below _),
    exact classical.epsilon_spec this },
  -- the balls with indices `G k` satisfy the characteristic property of satellite configurations.
  have Gab : ∀ (a b : fin (nat.succ N)), G a < G b →
    p.r (p.index (G a)) ≤ dist (p.c (p.index (G a))) (p.c (p.index (G b)))
      ∧ p.r (p.index (G b)) ≤ p.τ * p.r (p.index (G a)),
  { assume a b G_lt,
    have ha : (a : ℕ) ≤ N := nat.lt_succ_iff.1 a.2,
    have hb : (b : ℕ) ≤ N := nat.lt_succ_iff.1 b.2,
    split,
    { have := (fGn b hb).1,
      simp only [Union_up_to, not_exists, exists_prop, mem_Union, mem_closed_ball, not_and,
        not_le, subtype.exists, subtype.coe_mk] at this,
      simpa only [dist_comm, mem_ball, not_lt] using this (G a) G_lt },
    { apply le_trans _ (fGn a ha).2,
      have B : p.c (p.index (G b)) ∉ p.Union_up_to (G a),
      { assume H, exact (fGn b hb).1 (p.monotone_Union_up_to G_lt.le H) },
      let b' : {t // p.c t ∉ p.Union_up_to (G a)} := ⟨p.index (G b), B⟩,
      apply @le_csupr _ _ _ (λ t : {t // p.c t ∉ p.Union_up_to (G a)}, p.r t) _ b',
      refine ⟨p.r_bound, λ t ht, _⟩,
      simp only [exists_prop, mem_range, subtype.exists, subtype.coe_mk] at ht,
      rcases ht with ⟨u, hu⟩,
      rw ← hu.2,
      exact p.r_le _ } },
  -- therefore, one may use them to construct a satellite configuration with `N+1` points
  let sc : satellite_config α N p.τ :=
  { c := λ k, p.c (p.index (G k)),
    r := λ k, p.r (p.index (G k)),
    rpos := λ k, p.rpos (p.index (G k)),
    h := begin
      assume a b a_ne_b,
      wlog G_le : G a ≤ G b generalizing a b,
      { exact (this b a a_ne_b.symm (le_of_not_le G_le)).symm },
      have G_lt : G a < G b,
      { rcases G_le.lt_or_eq with H|H, { exact H },
        have A : (a : ℕ) ≠ b := fin.coe_injective.ne a_ne_b,
        rw [← color_G a (nat.lt_succ_iff.1 a.2), ← color_G b (nat.lt_succ_iff.1 b.2), H] at A,
        exact (A rfl).elim },
      exact or.inl (Gab a b G_lt),
    end,
    hlast := begin
      assume a ha,
      have I : (a : ℕ) < N := ha,
      have : G a < G (fin.last N), by { dsimp [G], simp [I.ne, (hg a I).1] },
      exact Gab _ _ this,
    end,
    inter := begin
      assume a ha,
      have I : (a : ℕ) < N := ha,
      have J : G (fin.last N) = i, by { dsimp [G], simp only [if_true, eq_self_iff_true], },
      have K : G a = g a, { dsimp [G], simp [I.ne, (hg a I).1] },
      convert dist_le_add_of_nonempty_closed_ball_inter_closed_ball (hg _ I).2.1,
    end },
  -- this is a contradiction
  exact (hN.false : _) sc
end

end tau_package

open tau_package

/-- The topological Besicovitch covering theorem: there exist finitely many families of disjoint
balls covering all the centers in a package. More specifically, one can use `N` families if there
are no satellite configurations with `N+1` points. -/
theorem exist_disjoint_covering_families {N : ℕ} {τ : ℝ}
  (hτ : 1 < τ) (hN : is_empty (satellite_config α N τ)) (q : ball_package β α) :
  ∃ s : fin N → set β,
    (∀ (i : fin N), (s i).pairwise_disjoint (λ j, closed_ball (q.c j) (q.r j))) ∧
      (range q.c ⊆ ⋃ (i : fin N), ⋃ (j ∈ s i), ball (q.c j) (q.r j)) :=
begin
  -- first exclude the trivial case where `β` is empty (we need non-emptiness for the transfinite
  -- induction, to be able to choose garbage when there is no point left).
  casesI is_empty_or_nonempty β,
  { refine ⟨λ i, ∅, λ i, pairwise_disjoint_empty, _⟩,
    rw [← image_univ, eq_empty_of_is_empty (univ : set β)],
    simp },
  -- Now, assume `β` is nonempty.
  let p : tau_package β α := { τ := τ, one_lt_tau := hτ, .. q },
  -- we use for `s i` the balls of color `i`.
  let s := λ (i : fin N),
    ⋃ (k : ordinal.{u}) (hk : k < p.last_step) (h'k : p.color k = i), ({p.index k} : set β),
  refine ⟨s, λ i, _, _⟩,
  { -- show that balls of the same color are disjoint
    assume x hx y hy x_ne_y,
    obtain ⟨jx, jx_lt, jxi, rfl⟩ :
      ∃ (jx : ordinal), jx < p.last_step ∧ p.color jx = i ∧ x = p.index jx,
        by simpa only [exists_prop, mem_Union, mem_singleton_iff] using hx,
    obtain ⟨jy, jy_lt, jyi, rfl⟩ :
      ∃ (jy : ordinal), jy < p.last_step ∧ p.color jy = i ∧ y = p.index jy,
        by simpa only [exists_prop, mem_Union, mem_singleton_iff] using hy,
    wlog jxy : jx ≤ jy generalizing jx jy,
    { exact (this jy jy_lt jyi hy jx jx_lt jxi hx x_ne_y.symm (le_of_not_le jxy)).symm },
    replace jxy : jx < jy,
      by { rcases lt_or_eq_of_le jxy with H|rfl, { exact H }, { exact (x_ne_y rfl).elim } },
    let A : set ℕ := ⋃ (j : {j // j < jy})
         (hj : (closed_ball (p.c (p.index j)) (p.r (p.index j))
            ∩ closed_ball (p.c (p.index jy)) (p.r (p.index jy))).nonempty), {p.color j},
    have color_j : p.color jy = Inf (univ \ A), by rw [tau_package.color],
    have : p.color jy ∈ univ \ A,
    { rw color_j,
      apply Inf_mem,
      refine ⟨N, _⟩,
      simp only [not_exists, true_and, exists_prop, mem_Union, mem_singleton_iff, not_and, mem_univ,
        mem_diff, subtype.exists, subtype.coe_mk],
      assume k hk H,
      exact (p.color_lt (hk.trans jy_lt) hN).ne' },
    simp only [not_exists, true_and, exists_prop, mem_Union, mem_singleton_iff, not_and, mem_univ,
      mem_diff, subtype.exists, subtype.coe_mk] at this,
    specialize this jx jxy,
    contrapose! this,
    simpa only [jxi, jyi, and_true, eq_self_iff_true, ← not_disjoint_iff_nonempty_inter] },
  { -- show that the balls of color at most `N` cover every center.
    refine range_subset_iff.2 (λ b, _),
    obtain ⟨a, ha⟩ :
      ∃ (a : ordinal), a < p.last_step ∧ dist (p.c b) (p.c (p.index a)) < p.r (p.index a),
      by simpa only [Union_up_to, exists_prop, mem_Union, mem_ball, subtype.exists, subtype.coe_mk]
        using p.mem_Union_up_to_last_step b,
    simp only [exists_prop, mem_Union, mem_ball, mem_singleton_iff, bUnion_and', exists_eq_left,
      Union_exists, exists_and_distrib_left],
    exact ⟨⟨p.color a, p.color_lt ha.1 hN⟩, a, rfl, ha⟩ }
end

/-!
### The measurable Besicovitch covering theorem
-/

open_locale nnreal
variables [second_countable_topology α] [measurable_space α] [opens_measurable_space α]

/-- Consider, for each `x` in a set `s`, a radius `r x ∈ (0, 1]`. Then one can find finitely
many disjoint balls of the form `closed_ball x (r x)` covering a proportion `1/(N+1)` of `s`, if
there are no satellite configurations with `N+1` points.
-/
lemma exist_finset_disjoint_balls_large_measure
  (μ : measure α) [is_finite_measure μ] {N : ℕ} {τ : ℝ}
  (hτ : 1 < τ) (hN : is_empty (satellite_config α N τ)) (s : set α)
  (r : α → ℝ) (rpos : ∀ x ∈ s, 0 < r x) (rle : ∀ x ∈ s, r x ≤ 1) :
  ∃ (t : finset α), (↑t ⊆ s) ∧ μ (s \ (⋃ (x ∈ t), closed_ball x (r x))) ≤ N/(N+1) * μ s
    ∧ (t : set α).pairwise_disjoint (λ x, closed_ball x (r x)) :=
begin
  -- exclude the trivial case where `μ s = 0`.
  rcases le_or_lt (μ s) 0 with hμs|hμs,
  { have : μ s = 0 := le_bot_iff.1 hμs,
    refine ⟨∅, by simp only [finset.coe_empty, empty_subset], _, _⟩,
    { simp only [this, diff_empty, Union_false, Union_empty, nonpos_iff_eq_zero, mul_zero] },
    { simp only [finset.coe_empty, pairwise_disjoint_empty], } },
  casesI is_empty_or_nonempty α,
  { simp only [eq_empty_of_is_empty s, measure_empty] at hμs,
    exact (lt_irrefl _ hμs).elim },
  have Npos : N ≠ 0,
  { unfreezingI { rintros rfl },
    inhabit α,
    exact (not_is_empty_of_nonempty _) hN },
  -- introduce a measurable superset `o` with the same measure, for measure computations
  obtain ⟨o, so, omeas, μo⟩ : ∃ (o : set α), s ⊆ o ∧ measurable_set o ∧ μ o = μ s :=
    exists_measurable_superset μ s,
  /- We will apply the topological Besicovitch theorem, giving `N` disjoint subfamilies of balls
  covering `s`. Among these, one of them covers a proportion at least `1/N` of `s`. A large
  enough finite subfamily will then cover a proportion at least `1/(N+1)`. -/
  let a : ball_package s α :=
  { c := λ x, x,
    r := λ x, r x,
    rpos := λ x, rpos x x.2,
    r_bound := 1,
    r_le := λ x, rle x x.2 },
  rcases exist_disjoint_covering_families hτ hN a with ⟨u, hu, hu'⟩,
  have u_count : ∀ i, (u i).countable,
  { assume i,
    refine (hu i).countable_of_nonempty_interior (λ j hj, _),
    have : (ball (j : α) (r j)).nonempty := nonempty_ball.2 (a.rpos _),
    exact this.mono ball_subset_interior_closed_ball },
  let v : fin N → set α := λ i, ⋃ (x : s) (hx : x ∈ u i), closed_ball x (r x),
  have : ∀ i, measurable_set (v i) :=
    λ i, measurable_set.bUnion (u_count i) (λ b hb, measurable_set_closed_ball),
  have A : s = ⋃ (i : fin N), s ∩ v i,
  { refine subset.antisymm _ (Union_subset (λ i, inter_subset_left _ _)),
    assume x hx,
    obtain ⟨i, y, hxy, h'⟩ : ∃ (i : fin N) (i_1 : ↥s) (i : i_1 ∈ u i), x ∈ ball ↑i_1 (r ↑i_1),
    { have : x ∈ range a.c, by simpa only [subtype.range_coe_subtype, set_of_mem_eq],
      simpa only [mem_Union] using hu' this },
    refine mem_Union.2 ⟨i, ⟨hx, _⟩⟩,
    simp only [v, exists_prop, mem_Union, set_coe.exists, exists_and_distrib_right, subtype.coe_mk],
    exact ⟨y, ⟨y.2, by simpa only [subtype.coe_eta]⟩, ball_subset_closed_ball h'⟩ },
  have S : ∑ (i : fin N), μ s / N ≤ ∑ i, μ (s ∩ v i) := calc
    ∑ (i : fin N), μ s / N = μ s : begin
      simp only [finset.card_fin, finset.sum_const, nsmul_eq_mul],
      rw ennreal.mul_div_cancel',
      { simp only [Npos, ne.def, nat.cast_eq_zero, not_false_iff] },
      { exact (ennreal.nat_ne_top _) }
    end
    ... ≤ ∑ i, μ (s ∩ v i) : by { conv_lhs { rw A }, apply measure_Union_fintype_le },
  -- choose an index `i` of a subfamily covering at least a proportion `1/N` of `s`.
  obtain ⟨i, -, hi⟩ : ∃ (i : fin N) (hi : i ∈ finset.univ), μ s / N ≤ μ (s ∩ v i),
  { apply ennreal.exists_le_of_sum_le _ S,
    exact ⟨⟨0, bot_lt_iff_ne_bot.2 Npos⟩, finset.mem_univ _⟩ },
  replace hi : μ s / (N + 1) < μ (s ∩ v i),
  { apply lt_of_lt_of_le _ hi,
    apply (ennreal.mul_lt_mul_left hμs.ne' (measure_lt_top μ s).ne).2,
    rw ennreal.inv_lt_inv,
    conv_lhs {rw ← add_zero (N : ℝ≥0∞) },
    exact ennreal.add_lt_add_left (ennreal.nat_ne_top N) zero_lt_one },
  have B : μ (o ∩ v i) = ∑' (x : u i), μ (o ∩ closed_ball x (r x)),
  { have : o ∩ v i = ⋃ (x : s) (hx : x ∈ u i), o ∩ closed_ball x (r x), by simp only [inter_Union],
    rw [this, measure_bUnion (u_count i)],
    { refl },
    { exact (hu i).mono (λ k, inter_subset_right _ _) },
    { exact λ b hb, omeas.inter measurable_set_closed_ball } },
  -- A large enough finite subfamily of `u i` will also cover a proportion `> 1/(N+1)` of `s`.
  -- Since `s` might not be measurable, we express this in terms of the measurable superset `o`.
  obtain ⟨w, hw⟩ : ∃ (w : finset (u i)),
    μ s / (N + 1) < ∑ (x : u i) in w, μ (o ∩ closed_ball (x : α) (r (x : α))),
  { have C : has_sum (λ (x : u i), μ (o ∩ closed_ball x (r x))) (μ (o ∩ v i)),
      by { rw B, exact ennreal.summable.has_sum },
    have : μ s / (N+1) < μ (o ∩ v i) :=
      hi.trans_le (measure_mono (inter_subset_inter_left _ so)),
    exact ((tendsto_order.1 C).1 _ this).exists },
  -- Bring back the finset `w i` of `↑(u i)` to a finset of `α`, and check that it works by design.
  refine ⟨finset.image (λ (x : u i), x) w, _, _, _⟩,
  -- show that the finset is included in `s`.
  { simp only [image_subset_iff, coe_coe, finset.coe_image],
    assume y hy,
    simp only [subtype.coe_prop, mem_preimage] },
  -- show that it covers a large enough proportion of `s`. For measure computations, we do not
  -- use `s` (which might not be measurable), but its measurable superset `o`. Since their measures
  -- are the same, this does not spoil the estimates
  { suffices H : μ (o \ ⋃ x ∈ w, closed_ball ↑x (r ↑x)) ≤ N/(N+1) * μ s,
      { rw [finset.set_bUnion_finset_image],
        exact le_trans (measure_mono (diff_subset_diff so (subset.refl _))) H },
    rw [← diff_inter_self_eq_diff,
      measure_diff_le_iff_le_add _ (inter_subset_right _ _) ((measure_lt_top μ _).ne)], swap,
    { apply measurable_set.inter _ omeas,
      haveI : encodable (u i) := (u_count i).to_encodable,
      exact measurable_set.Union
        (λ b, measurable_set.Union (λ hb, measurable_set_closed_ball)) },
    calc
    μ o = 1/(N+1) * μ s + N/(N+1) * μ s :
      by { rw [μo, ← add_mul, ennreal.div_add_div_same, add_comm, ennreal.div_self, one_mul]; simp }
    ... ≤ μ ((⋃ (x ∈ w), closed_ball ↑x (r ↑x)) ∩ o) + N/(N+1) * μ s : begin
      refine add_le_add _ le_rfl,
      rw [div_eq_mul_inv, one_mul, mul_comm, ← div_eq_mul_inv],
      apply hw.le.trans (le_of_eq _),
      rw [← finset.set_bUnion_coe, inter_comm _ o, inter_Union₂, finset.set_bUnion_coe,
          measure_bUnion_finset],
      { have : (w : set (u i)).pairwise_disjoint (λ (b : u i), closed_ball (b : α) (r (b : α))),
          by { assume k hk l hl hkl, exact hu i k.2 l.2 (subtype.coe_injective.ne hkl) },
        exact this.mono (λ k, inter_subset_right _ _) },
      { assume b hb,
        apply omeas.inter measurable_set_closed_ball }
    end },
  -- show that the balls are disjoint
  { assume k hk l hl hkl,
    obtain ⟨k', k'w, rfl⟩ : ∃ (k' : u i), k' ∈ w ∧ ↑↑k' = k,
      by simpa only [mem_image, finset.mem_coe, coe_coe, finset.coe_image] using hk,
    obtain ⟨l', l'w, rfl⟩ : ∃ (l' : u i), l' ∈ w ∧ ↑↑l' = l,
      by simpa only [mem_image, finset.mem_coe, coe_coe, finset.coe_image] using hl,
    have k'nel' : (k' : s) ≠ l',
      by { assume h, rw h at hkl, exact hkl rfl },
    exact hu i k'.2 l'.2 k'nel' }
end

variable [has_besicovitch_covering α]

/-- The measurable Besicovitch covering theorem. Assume that, for any `x` in a set `s`,
one is given a set of admissible closed balls centered at `x`, with arbitrarily small radii.
Then there exists a disjoint covering of almost all `s` by admissible closed balls centered at some
points of `s`.
This version requires that the underlying measure is finite, and that the space has the Besicovitch
covering property (which is satisfied for instance by normed real vector spaces). It expresses the
conclusion in a slightly awkward form (with a subset of `α × ℝ`) coming from the proof technique.
For a version assuming that the measure is sigma-finite,
see `exists_disjoint_closed_ball_covering_ae_aux`.
For a version giving the conclusion in a nicer form, see `exists_disjoint_closed_ball_covering_ae`.
-/
theorem exists_disjoint_closed_ball_covering_ae_of_finite_measure_aux
  (μ : measure α) [is_finite_measure μ]
  (f : α → set ℝ) (s : set α) (hf : ∀ x ∈ s, ∀ δ > 0, (f x ∩ Ioo 0 δ).nonempty) :
  ∃ (t : set (α × ℝ)), t.countable
    ∧ (∀ (p : α × ℝ), p ∈ t → p.1 ∈ s) ∧ (∀ (p : α × ℝ), p ∈ t → p.2 ∈ f p.1)
    ∧ μ (s \ (⋃ (p : α × ℝ) (hp : p ∈ t), closed_ball p.1 p.2)) = 0
    ∧ t.pairwise_disjoint (λ p, closed_ball p.1 p.2) :=
begin
  rcases has_besicovitch_covering.no_satellite_config α with ⟨N, τ, hτ, hN⟩,
  /- Introduce a property `P` on finsets saying that we have a nice disjoint covering of a
    subset of `s` by admissible balls. -/
  let P : finset (α × ℝ) → Prop := λ t,
    (t : set (α × ℝ)).pairwise_disjoint (λ p, closed_ball p.1 p.2) ∧
    (∀ (p : α × ℝ), p ∈ t → p.1 ∈ s) ∧ (∀ (p : α × ℝ), p ∈ t → p.2 ∈ f p.1),
  /- Given a finite good covering of a subset `s`, one can find a larger finite good covering,
  covering additionally a proportion at least `1/(N+1)` of leftover points. This follows from
  `exist_finset_disjoint_balls_large_measure` applied to balls not intersecting the initial
  covering. -/
  have : ∀ (t : finset (α × ℝ)), P t → ∃ (u : finset (α × ℝ)), t ⊆ u ∧ P u ∧
    μ (s \ (⋃ (p : α × ℝ) (hp : p ∈ u), closed_ball p.1 p.2)) ≤
      N/(N+1) * μ (s \ (⋃ (p : α × ℝ) (hp : p ∈ t), closed_ball p.1 p.2)),
  { assume t ht,
    set B := ⋃ (p : α × ℝ) (hp : p ∈ t), closed_ball p.1 p.2 with hB,
    have B_closed : is_closed B :=
      is_closed_bUnion (finset.finite_to_set _) (λ i hi, is_closed_ball),
    set s' := s \ B with hs',
    have : ∀ x ∈ s', ∃ r ∈ f x ∩ Ioo 0 1, disjoint B (closed_ball x r),
    { assume x hx,
      have xs : x ∈ s := ((mem_diff x).1 hx).1,
      rcases eq_empty_or_nonempty B with hB|hB,
      { have : (0 : ℝ) < 1 := zero_lt_one,
        rcases hf x xs 1 zero_lt_one with ⟨r, hr, h'r⟩,
        exact ⟨r, ⟨hr, h'r⟩, by simp only [hB, empty_disjoint]⟩ },
      { let R := inf_dist x B,
        have : 0 < min R 1 :=
          lt_min ((B_closed.not_mem_iff_inf_dist_pos hB).1 ((mem_diff x).1 hx).2) zero_lt_one,
        rcases hf x xs _ this with ⟨r, hr, h'r⟩,
        refine ⟨r, ⟨hr, ⟨h'r.1, h'r.2.trans_le (min_le_right _ _)⟩⟩, _⟩,
        rw disjoint.comm,
        exact disjoint_closed_ball_of_lt_inf_dist (h'r.2.trans_le (min_le_left _ _)) } },
    choose! r hr using this,
    obtain ⟨v, vs', hμv, hv⟩ : ∃ (v : finset α), ↑v ⊆ s'
      ∧ μ (s' \ ⋃ (x ∈ v), closed_ball x (r x)) ≤ N/(N+1) * μ s'
      ∧ (v : set α).pairwise_disjoint (λ (x : α), closed_ball x (r x)),
    { have rI : ∀ x ∈ s', r x ∈ Ioo (0 : ℝ) 1 := λ x hx, (hr x hx).1.2,
      exact exist_finset_disjoint_balls_large_measure μ hτ hN s' r (λ x hx, (rI x hx).1)
        (λ x hx, (rI x hx).2.le) },
    refine ⟨t ∪ (finset.image (λ x, (x, r x)) v), finset.subset_union_left _ _, ⟨_, _, _⟩, _⟩,
    { simp only [finset.coe_union, pairwise_disjoint_union, ht.1, true_and, finset.coe_image],
      split,
      { assume p hp q hq hpq,
        rcases (mem_image _ _ _).1 hp with ⟨p', p'v, rfl⟩,
        rcases (mem_image _ _ _).1 hq with ⟨q', q'v, rfl⟩,
        refine hv p'v q'v (λ hp'q', _),
        rw [hp'q'] at hpq,
        exact hpq rfl },
      { assume p hp q hq hpq,
        rcases (mem_image _ _ _).1 hq with ⟨q', q'v, rfl⟩,
        apply disjoint_of_subset_left _ (hr q' (vs' q'v)).2,
        rw [hB, ← finset.set_bUnion_coe],
        exact subset_bUnion_of_mem hp } },
    { assume p hp,
      rcases finset.mem_union.1 hp with h'p|h'p,
      { exact ht.2.1 p h'p },
      { rcases finset.mem_image.1 h'p with ⟨p', p'v, rfl⟩,
        exact ((mem_diff _).1 (vs' (finset.mem_coe.2 p'v))).1 } },
    { assume p hp,
      rcases finset.mem_union.1 hp with h'p|h'p,
      { exact ht.2.2 p h'p },
      { rcases finset.mem_image.1 h'p with ⟨p', p'v, rfl⟩,
        exact (hr p' (vs' p'v)).1.1 } },
    { convert hμv using 2,
      rw [finset.set_bUnion_union, ← diff_diff, finset.set_bUnion_finset_image] } },
  /- Define `F` associating to a finite good covering the above enlarged good covering, covering
  a proportion `1/(N+1)` of leftover points. Iterating `F`, one will get larger and larger good
  coverings, missing in the end only a measure-zero set. -/
  choose! F hF using this,
  let u := λ n, F^[n] ∅,
  have u_succ : ∀ (n : ℕ), u n.succ = F (u n) :=
    λ n, by simp only [u, function.comp_app, function.iterate_succ'],
  have Pu : ∀ n, P (u n),
  { assume n,
    induction n with n IH,
    { simp only [u, P, prod.forall, id.def, function.iterate_zero],
      simp only [finset.not_mem_empty, is_empty.forall_iff, finset.coe_empty, forall_2_true_iff,
        and_self, pairwise_disjoint_empty] },
    { rw u_succ,
      exact (hF (u n) IH).2.1 } },
  refine ⟨⋃ n, u n, countable_Union (λ n, (u n).countable_to_set), _, _, _, _⟩,
  { assume p hp,
    rcases mem_Union.1 hp with ⟨n, hn⟩,
    exact (Pu n).2.1 p (finset.mem_coe.1 hn) },
  { assume p hp,
    rcases mem_Union.1 hp with ⟨n, hn⟩,
    exact (Pu n).2.2 p (finset.mem_coe.1 hn) },
  { have A : ∀ n, μ (s \ ⋃ (p : α × ℝ) (hp : p ∈ ⋃ (n : ℕ), (u n : set (α × ℝ))),
                     closed_ball p.fst p.snd)
                ≤ μ (s \ ⋃ (p : α × ℝ) (hp : p ∈ u n), closed_ball p.fst p.snd),
    { assume n,
      apply measure_mono,
      apply diff_subset_diff (subset.refl _),
      exact bUnion_subset_bUnion_left (subset_Union (λ i, (u i : set (α × ℝ))) n) },
    have B : ∀ n, μ (s \ ⋃ (p : α × ℝ) (hp : p ∈ u n), closed_ball p.fst p.snd)
      ≤ (N/(N+1))^n * μ s,
    { assume n,
      induction n with n IH,
      { simp only [le_refl, diff_empty, one_mul, Union_false, Union_empty, pow_zero] },
      calc
        μ (s \ ⋃ (p : α × ℝ) (hp : p ∈ u n.succ), closed_ball p.fst p.snd)
            ≤ (N/(N+1)) * μ (s \ ⋃ (p : α × ℝ) (hp : p ∈ u n), closed_ball p.fst p.snd) :
              by { rw u_succ, exact (hF (u n) (Pu n)).2.2 }
        ... ≤ (N/(N+1))^n.succ * μ s :
          by { rw [pow_succ, mul_assoc], exact mul_le_mul_left' IH _ } },
    have C : tendsto (λ (n : ℕ), ((N : ℝ≥0∞)/(N+1))^n * μ s) at_top (𝓝 (0 * μ s)),
    { apply ennreal.tendsto.mul_const _ (or.inr (measure_lt_top μ s).ne),
      apply ennreal.tendsto_pow_at_top_nhds_0_of_lt_1,
      rw [ennreal.div_lt_iff, one_mul],
      { conv_lhs {rw ← add_zero (N : ℝ≥0∞) },
        exact ennreal.add_lt_add_left (ennreal.nat_ne_top N) zero_lt_one },
      { simp only [true_or, add_eq_zero_iff, ne.def, not_false_iff, one_ne_zero, and_false] },
      { simp only [ennreal.nat_ne_top, ne.def, not_false_iff, or_true] } },
    rw zero_mul at C,
    apply le_bot_iff.1,
    exact le_of_tendsto_of_tendsto' tendsto_const_nhds C (λ n, (A n).trans (B n)) },
  { refine (pairwise_disjoint_Union _).2 (λ n, (Pu n).1),
    apply (monotone_nat_of_le_succ (λ n, _)).directed_le,
    rw u_succ,
    exact (hF (u n) (Pu n)).1 }
end

/-- The measurable Besicovitch covering theorem. Assume that, for any `x` in a set `s`,
one is given a set of admissible closed balls centered at `x`, with arbitrarily small radii.
Then there exists a disjoint covering of almost all `s` by admissible closed balls centered at some
points of `s`.
This version requires that the underlying measure is sigma-finite, and that the space has the
Besicovitch covering property (which is satisfied for instance by normed real vector spaces).
It expresses the conclusion in a slightly awkward form (with a subset of `α × ℝ`) coming from the
proof technique.
For a version giving the conclusion in a nicer form, see `exists_disjoint_closed_ball_covering_ae`.
-/
theorem exists_disjoint_closed_ball_covering_ae_aux (μ : measure α) [sigma_finite μ]
  (f : α → set ℝ) (s : set α) (hf : ∀ x ∈ s, ∀ δ > 0, (f x ∩ Ioo 0 δ).nonempty) :
  ∃ (t : set (α × ℝ)), t.countable
    ∧ (∀ (p : α × ℝ), p ∈ t → p.1 ∈ s) ∧ (∀ (p : α × ℝ), p ∈ t → p.2 ∈ f p.1)
    ∧ μ (s \ (⋃ (p : α × ℝ) (hp : p ∈ t), closed_ball p.1 p.2)) = 0
    ∧ t.pairwise_disjoint (λ p, closed_ball p.1 p.2) :=
begin
  /- This is deduced from the finite measure case, by using a finite measure with respect to which
  the initial sigma-finite measure is absolutely continuous. -/
  unfreezingI { rcases exists_absolutely_continuous_is_finite_measure μ with ⟨ν, hν, hμν⟩ },
  rcases exists_disjoint_closed_ball_covering_ae_of_finite_measure_aux ν f s hf
    with ⟨t, t_count, ts, tr, tν, tdisj⟩,
  exact ⟨t, t_count, ts, tr, hμν tν, tdisj⟩,
end

/-- The measurable Besicovitch covering theorem. Assume that, for any `x` in a set `s`,
one is given a set of admissible closed balls centered at `x`, with arbitrarily small radii.
Then there exists a disjoint covering of almost all `s` by admissible closed balls centered at some
points of `s`. We can even require that the radius at `x` is bounded by a given function `R x`.
(Take `R = 1` if you don't need this additional feature).
This version requires that the underlying measure is sigma-finite, and that the space has the
Besicovitch covering property (which is satisfied for instance by normed real vector spaces).
-/
theorem exists_disjoint_closed_ball_covering_ae (μ : measure α) [sigma_finite μ]
  (f : α → set ℝ) (s : set α) (hf : ∀ x ∈ s, ∀ δ > 0, (f x ∩ Ioo 0 δ).nonempty)
  (R : α → ℝ) (hR : ∀ x ∈ s, 0 < R x):
  ∃ (t : set α) (r : α → ℝ), t.countable ∧ t ⊆ s ∧ (∀ x ∈ t, r x ∈ f x ∩ Ioo 0 (R x))
    ∧ μ (s \ (⋃ (x ∈ t), closed_ball x (r x))) = 0
    ∧ t.pairwise_disjoint (λ x, closed_ball x (r x)) :=
begin
  let g := λ x, f x ∩ Ioo 0 (R x),
  have hg : ∀ x ∈ s, ∀ δ > 0, (g x ∩ Ioo 0 δ).nonempty,
  { assume x hx δ δpos,
    rcases hf x hx (min δ (R x)) (lt_min δpos (hR x hx)) with ⟨r, hr⟩,
    exact ⟨r, ⟨⟨hr.1, hr.2.1, hr.2.2.trans_le (min_le_right _ _)⟩,
      ⟨hr.2.1, hr.2.2.trans_le (min_le_left _ _)⟩⟩⟩ },
  rcases exists_disjoint_closed_ball_covering_ae_aux μ g s hg
    with ⟨v, v_count, vs, vg, μv, v_disj⟩,
  let t := prod.fst '' v,
  have : ∀ x ∈ t, ∃ (r : ℝ), (x, r) ∈ v,
  { assume x hx,
    rcases (mem_image _ _ _).1 hx with ⟨⟨p, q⟩, hp, rfl⟩,
    exact ⟨q, hp⟩ },
  choose! r hr using this,
  have im_t : (λ x, (x, r x)) '' t = v,
  { have I : ∀ (p : α × ℝ), p ∈ v → 0 ≤ p.2 :=
      λ p hp, (vg p hp).2.1.le,
    apply subset.antisymm,
    { simp only [image_subset_iff],
      rintros ⟨x, p⟩ hxp,
      simp only [mem_preimage],
      exact hr _ (mem_image_of_mem _ hxp) },
    { rintros ⟨x, p⟩ hxp,
      have hxrx : (x, r x) ∈ v := hr _ (mem_image_of_mem _ hxp),
      have : p = r x,
      { by_contra,
        have A : (x, p) ≠ (x, r x),
          by simpa only [true_and, prod.mk.inj_iff, eq_self_iff_true, ne.def] using h,
        have H := v_disj hxp hxrx A,
        contrapose H,
        rw not_disjoint_iff_nonempty_inter,
        refine ⟨x, by simp [I _ hxp, I _ hxrx]⟩ },
      rw this,
      apply mem_image_of_mem,
      exact mem_image_of_mem _ hxp } },
  refine ⟨t, r, v_count.image _, _, _, _, _⟩,
  { assume x hx,
    rcases (mem_image _ _ _).1 hx with ⟨⟨p, q⟩, hp, rfl⟩,
    exact vs _ hp },
  { assume x hx,
    rcases (mem_image _ _ _).1 hx with ⟨⟨p, q⟩, hp, rfl⟩,
    exact vg _ (hr _ hx) },
  { have : (⋃ (x : α) (H : x ∈ t), closed_ball x (r x)) =
      (⋃ (p : α × ℝ) (H : p ∈ (λ x, (x, r x)) '' t), closed_ball p.1 p.2),
        by conv_rhs { rw bUnion_image },
    rw [this, im_t],
    exact μv },
  { have A : inj_on (λ x : α, (x, r x)) t,
      by simp only [inj_on, prod.mk.inj_iff, implies_true_iff, eq_self_iff_true] {contextual := tt},
    rwa [← im_t, A.pairwise_disjoint_image] at v_disj }
end

/-- In a space with the Besicovitch property, any set `s` can be covered with balls whose measures
add up to at most `μ s + ε`, for any positive `ε`. This works even if one restricts the set of
allowed radii around a point `x` to a set `f x` which accumulates at `0`. -/
theorem exists_closed_ball_covering_tsum_measure_le
  (μ : measure α) [sigma_finite μ] [measure.outer_regular μ]
  {ε : ℝ≥0∞} (hε : ε ≠ 0) (f : α → set ℝ) (s : set α)
  (hf : ∀ x ∈ s, ∀ δ > 0, (f x ∩ Ioo 0 δ).nonempty) :
  ∃ (t : set α) (r : α → ℝ), t.countable ∧ t ⊆ s ∧ (∀ x ∈ t, r x ∈ f x)
    ∧ s ⊆ (⋃ (x ∈ t), closed_ball x (r x))
    ∧ ∑' (x : t), μ (closed_ball x (r x)) ≤ μ s + ε  :=
begin
  /- For the proof, first cover almost all `s` with disjoint balls thanks to the usual Besicovitch
  theorem. Taking the balls included in a well-chosen open neighborhood `u` of `s`, one may
  ensure that their measures add at most to `μ s + ε / 2`. Let `s'` be the remaining set, of measure
  `0`. Applying the other version of Besicovitch, one may cover it with at most `N` disjoint
  subfamilies. Making sure that they are all included in a neighborhood `v` of `s'` of measure at
  most `ε / (2 N)`, the sum of their measures is at most `ε / 2`, completing the proof. -/
  obtain ⟨u, su, u_open, μu⟩ : ∃ U ⊇ s, is_open U ∧ μ U ≤ μ s + ε / 2 :=
    set.exists_is_open_le_add _ _ (by simpa only [or_false, ne.def, ennreal.div_zero_iff,
      ennreal.one_ne_top, ennreal.bit0_eq_top_iff] using hε),
  have : ∀ x ∈ s, ∃ R > 0, ball x R ⊆ u :=
    λ x hx, metric.mem_nhds_iff.1 (u_open.mem_nhds (su hx)),
  choose! R hR using this,
  obtain ⟨t0, r0, t0_count, t0s, hr0, μt0, t0_disj⟩ :
    ∃ (t0 : set α) (r0 : α → ℝ), t0.countable ∧ t0 ⊆ s ∧ (∀ x ∈ t0, r0 x ∈ f x ∩ Ioo 0 (R x))
      ∧ μ (s \ (⋃ (x ∈ t0), closed_ball x (r0 x))) = 0
      ∧ t0.pairwise_disjoint (λ x, closed_ball x (r0 x)) :=
        exists_disjoint_closed_ball_covering_ae μ f s hf R (λ x hx, (hR x hx).1),
  -- we have constructed an almost everywhere covering of `s` by disjoint balls. Let `s'` be the
  -- remaining set.
  let s' := s \ (⋃ (x ∈ t0), closed_ball x (r0 x)),
  have s's : s' ⊆ s := diff_subset _ _,
  obtain ⟨N, τ, hτ, H⟩ : ∃ N τ, 1 < τ ∧ is_empty (besicovitch.satellite_config α N τ) :=
    has_besicovitch_covering.no_satellite_config α,
  obtain ⟨v, s'v, v_open, μv⟩ : ∃ v ⊇ s', is_open v ∧ μ v ≤ μ s' + (ε / 2) / N :=
    set.exists_is_open_le_add _ _
      (by simp only [hε, ennreal.nat_ne_top, with_top.mul_eq_top_iff, ne.def, ennreal.div_zero_iff,
        ennreal.one_ne_top, not_false_iff, and_false, false_and, or_self, ennreal.bit0_eq_top_iff]),
  have : ∀ x ∈ s', ∃ r1 ∈ (f x ∩ Ioo (0 : ℝ) 1), closed_ball x r1 ⊆ v,
  { assume x hx,
    rcases metric.mem_nhds_iff.1 (v_open.mem_nhds (s'v hx)) with ⟨r, rpos, hr⟩,
    rcases hf x (s's hx) (min r 1) (lt_min rpos zero_lt_one) with ⟨R', hR'⟩,
    exact ⟨R', ⟨hR'.1, hR'.2.1, hR'.2.2.trans_le (min_le_right _ _)⟩,
      subset.trans (closed_ball_subset_ball (hR'.2.2.trans_le (min_le_left _ _))) hr⟩, },
  choose! r1 hr1 using this,
  let q : ball_package s' α :=
  { c := λ x, x,
    r := λ x, r1 x,
    rpos := λ x, (hr1 x.1 x.2).1.2.1,
    r_bound := 1,
    r_le := λ x, (hr1 x.1 x.2).1.2.2.le },
  -- by Besicovitch, we cover `s'` with at most `N` families of disjoint balls, all included in
  -- a suitable neighborhood `v` of `s'`.
  obtain ⟨S, S_disj, hS⟩ : ∃ S : fin N → set s',
    (∀ (i : fin N), (S i).pairwise_disjoint (λ j, closed_ball (q.c j) (q.r j))) ∧
      (range q.c ⊆ ⋃ (i : fin N), ⋃ (j ∈ S i), ball (q.c j) (q.r j)) :=
    exist_disjoint_covering_families hτ H q,
  have S_count : ∀ i, (S i).countable,
  { assume i,
    apply (S_disj i).countable_of_nonempty_interior (λ j hj, _),
    have : (ball (j : α) (r1 j)).nonempty := nonempty_ball.2 (q.rpos _),
    exact this.mono ball_subset_interior_closed_ball },
  let r := λ x, if x ∈ s' then r1 x else r0 x,
  have r_t0 : ∀ x ∈ t0, r x = r0 x,
  { assume x hx,
    have : ¬ (x ∈ s'),
    { simp only [not_exists, exists_prop, mem_Union, mem_closed_ball, not_and, not_lt,
                  not_le, mem_diff, not_forall],
      assume h'x,
      refine ⟨x, hx, _⟩,
      rw dist_self,
      exact (hr0 x hx).2.1.le },
    simp only [r, if_neg this] },
  -- the desired covering set is given by the union of the families constructed in the first and
  -- second steps.
  refine ⟨t0 ∪ (⋃ (i : fin N), (coe : s' → α) '' (S i)), r, _, _, _, _, _⟩,
  -- it remains to check that they have the desired properties
  { exact t0_count.union (countable_Union (λ i, (S_count i).image _)) },
  { simp only [t0s, true_and, union_subset_iff, image_subset_iff, Union_subset_iff],
    assume i x hx,
    exact s's x.2 },
  { assume x hx,
    cases hx,
    { rw r_t0 x hx,
      exact (hr0 _ hx).1 },
    { have h'x : x ∈ s',
      { simp only [mem_Union, mem_image] at hx,
        rcases hx with ⟨i, y, ySi, rfl⟩,
        exact y.2 },
      simp only [r, if_pos h'x, (hr1 x h'x).1.1] } },
  { assume x hx,
    by_cases h'x : x ∈ s',
    { obtain ⟨i, y, ySi, xy⟩ : ∃ (i : fin N) (y : ↥s') (ySi : y ∈ S i), x ∈ ball (y : α) (r1 y),
      { have A : x ∈ range q.c, by simpa only [not_exists, exists_prop, mem_Union, mem_closed_ball,
          not_and, not_le, mem_set_of_eq, subtype.range_coe_subtype, mem_diff] using h'x,
        simpa only [mem_Union, mem_image] using hS A },
      refine mem_Union₂.2 ⟨y, or.inr _, _⟩,
      { simp only [mem_Union, mem_image],
        exact ⟨i, y, ySi, rfl⟩ },
      { have : (y : α) ∈ s' := y.2,
        simp only [r, if_pos this],
        exact ball_subset_closed_ball xy } },
    { obtain ⟨y, yt0, hxy⟩ : ∃ (y : α), y ∈ t0 ∧ x ∈ closed_ball y (r0 y),
        by simpa [hx, -mem_closed_ball] using h'x,
      refine mem_Union₂.2 ⟨y, or.inl yt0, _⟩,
      rwa r_t0 _ yt0 } },
  -- the only nontrivial property is the measure control, which we check now
  { -- the sets in the first step have measure at most `μ s + ε / 2`
    have A : ∑' (x : t0), μ (closed_ball x (r x)) ≤ μ s + ε / 2 := calc
      ∑' (x : t0), μ (closed_ball x (r x))
      = ∑' (x : t0), μ (closed_ball x (r0 x)) :
        by { congr' 1, ext x, rw r_t0 x x.2 }
      ... = μ (⋃ (x : t0), closed_ball x (r0 x)) :
        begin
          haveI : encodable t0 := t0_count.to_encodable,
          rw measure_Union,
          { exact (pairwise_subtype_iff_pairwise_set _ _).2 t0_disj },
          { exact λ i, measurable_set_closed_ball }
        end
      ... ≤ μ u :
        begin
          apply measure_mono,
          simp only [set_coe.forall, subtype.coe_mk, Union_subset_iff],
          assume x hx,
          apply subset.trans (closed_ball_subset_ball (hr0 x hx).2.2) (hR x (t0s hx)).2,
        end
      ... ≤ μ s + ε / 2 : μu,
    -- each subfamily in the second step has measure at most `ε / (2 N)`.
    have B : ∀ (i : fin N),
      ∑' (x : (coe : s' → α) '' (S i)), μ (closed_ball x (r x)) ≤ (ε / 2) / N := λ i, calc
      ∑' (x : (coe : s' → α) '' (S i)), μ (closed_ball x (r x)) =
            ∑' (x : S i), μ (closed_ball x (r x)) :
        begin
          have : inj_on (coe : s' → α) (S i) := subtype.coe_injective.inj_on _,
          let F : S i ≃ (coe : s' → α) '' (S i) := this.bij_on_image.equiv _,
          exact (F.tsum_eq (λ x, μ (closed_ball x (r x)))).symm,
        end
      ... = ∑' (x : S i), μ (closed_ball x (r1 x)) :
        by { congr' 1, ext x, have : (x : α) ∈ s' := x.1.2, simp only [r, if_pos this] }
      ... = μ (⋃ (x : S i), closed_ball x (r1 x)) :
        begin
          haveI : encodable (S i) := (S_count i).to_encodable,
          rw measure_Union,
          { exact (pairwise_subtype_iff_pairwise_set _ _).2 (S_disj i) },
          { exact λ i, measurable_set_closed_ball }
        end
      ... ≤ μ v :
        begin
          apply measure_mono,
          simp only [set_coe.forall, subtype.coe_mk, Union_subset_iff],
          assume x xs' xSi,
          exact (hr1 x xs').2,
        end
      ... ≤ (ε / 2) / N : by { have : μ s' = 0 := μt0, rwa [this, zero_add] at μv },
    -- add up all these to prove the desired estimate
    calc ∑' (x : (t0 ∪ ⋃ (i : fin N), (coe : s' → α) '' S i)), μ (closed_ball x (r x))
        ≤ ∑' (x : t0), μ (closed_ball x (r x))
          + ∑' (x : ⋃ (i : fin N), (coe : s' → α) '' S i), μ (closed_ball x (r x)) :
            ennreal.tsum_union_le (λ x, μ (closed_ball x (r x))) _ _
    ... ≤ ∑' (x : t0), μ (closed_ball x (r x))
          + ∑ (i : fin N), ∑' (x : (coe : s' → α) '' S i), μ (closed_ball x (r x)) :
            add_le_add le_rfl (ennreal.tsum_Union_le (λ x, μ (closed_ball x (r x))) _)
    ... ≤ (μ s + ε / 2) + ∑ (i : fin N), (ε / 2) / N :
      begin
        refine add_le_add A _,
        refine finset.sum_le_sum _,
        assume i hi,
        exact B i
      end
    ... ≤ (μ s + ε / 2) + ε / 2 :
      begin
        refine add_le_add le_rfl _,
        simp only [finset.card_fin, finset.sum_const, nsmul_eq_mul, ennreal.mul_div_le],
      end
    ... = μ s + ε : by rw [add_assoc, ennreal.add_halves] }
end

/-! ### Consequences on differentiation of measures -/

/-- In a space with the Besicovitch covering property, the set of closed balls with positive radius
forms a Vitali family. This is essentially a restatement of the measurable Besicovitch theorem. -/
protected def vitali_family (μ : measure α) [sigma_finite μ] :
  vitali_family μ :=
{ sets_at := λ x, (λ (r : ℝ), closed_ball x r) '' (Ioi (0 : ℝ)),
  measurable_set' := begin
    assume x y hy,
    obtain ⟨r, rpos, rfl⟩ : ∃ (r : ℝ), 0 < r ∧ closed_ball x r = y,
      by simpa only [mem_image, mem_Ioi] using hy,
    exact is_closed_ball.measurable_set
  end,
  nonempty_interior := begin
    assume x y hy,
    obtain ⟨r, rpos, rfl⟩ : ∃ (r : ℝ), 0 < r ∧ closed_ball x r = y,
      by simpa only [mem_image, mem_Ioi] using hy,
    simp only [nonempty.mono ball_subset_interior_closed_ball, rpos, nonempty_ball],
  end,
  nontrivial := λ x ε εpos, ⟨closed_ball x ε, mem_image_of_mem _ εpos, subset.refl _⟩,
  covering := begin
    assume s f fsubset ffine,
    let g : α → set ℝ := λ x, {r | 0 < r ∧ closed_ball x r ∈ f x},
    have A : ∀ x ∈ s, ∀ δ > 0, (g x ∩ Ioo 0 δ).nonempty,
    { assume x xs δ δpos,
      obtain ⟨t, tf, ht⟩ : ∃ (t : set α) (H : t ∈ f x), t ⊆ closed_ball x (δ/2) :=
        ffine x xs (δ/2) (half_pos δpos),
      obtain ⟨r, rpos, rfl⟩ : ∃ (r : ℝ), 0 < r ∧ closed_ball x r = t,
        by simpa using fsubset x xs tf,
      rcases le_total r (δ/2) with H|H,
      { exact ⟨r, ⟨rpos, tf⟩, ⟨rpos, H.trans_lt (half_lt_self δpos)⟩⟩ },
      { have : closed_ball x r = closed_ball x (δ/2) :=
          subset.antisymm ht (closed_ball_subset_closed_ball H),
        rw this at tf,
        refine ⟨δ/2, ⟨half_pos δpos, tf⟩, ⟨half_pos δpos, half_lt_self δpos⟩⟩ } },
    obtain ⟨t, r, t_count, ts, tg, μt, tdisj⟩ : ∃ (t : set α) (r : α → ℝ), t.countable
      ∧ t ⊆ s ∧ (∀ x ∈ t, r x ∈ g x ∩ Ioo 0 1)
      ∧ μ (s \ (⋃ (x ∈ t), closed_ball x (r x))) = 0
      ∧ t.pairwise_disjoint (λ x, closed_ball x (r x)) :=
        exists_disjoint_closed_ball_covering_ae μ g s A (λ _, 1) (λ _ _, zero_lt_one),
    let F : α → α × set α := λ x, (x, closed_ball x (r x)),
    refine ⟨F '' t, _, _, _, _⟩,
    { rintros - ⟨x, hx, rfl⟩, exact ts hx },
    { rintros p ⟨x, hx, rfl⟩ q ⟨y, hy, rfl⟩ hxy,
      exact tdisj hx hy (ne_of_apply_ne F hxy) },
    { rintros - ⟨x, hx, rfl⟩, exact (tg x hx).1.2 },
    { rwa bUnion_image }
  end }

/-- The main feature of the Besicovitch Vitali family is that its filter at a point `x` corresponds
to convergence along closed balls. We record one of the two implications here, which will enable us
to deduce specific statements on differentiation of measures in this context from the general
versions. -/
lemma tendsto_filter_at (μ : measure α) [sigma_finite μ] (x : α) :
  tendsto (λ r, closed_ball x r) (𝓝[>] 0) ((besicovitch.vitali_family μ).filter_at x) :=
begin
  assume s hs,
  simp only [mem_map],
  obtain ⟨ε, εpos, hε⟩ : ∃ (ε : ℝ) (H : ε > 0), ∀ (a : set α),
    a ∈ (besicovitch.vitali_family μ).sets_at x → a ⊆ closed_ball x ε → a ∈ s :=
      (vitali_family.mem_filter_at_iff _).1 hs,
  have : Ioc (0 : ℝ) ε ∈ 𝓝[>] (0 : ℝ) := Ioc_mem_nhds_within_Ioi ⟨le_rfl, εpos⟩,
  filter_upwards [this] with _ hr,
  apply hε,
  { exact mem_image_of_mem _ hr.1 },
  { exact closed_ball_subset_closed_ball hr.2 }
end

variables [metric_space β] [measurable_space β] [borel_space β] [second_countable_topology β]
  [has_besicovitch_covering β]

/-- In a space with the Besicovitch covering property, the ratio of the measure of balls converges
almost surely to to the Radon-Nikodym derivative. -/
lemma ae_tendsto_rn_deriv
  (ρ μ : measure β) [is_locally_finite_measure μ] [is_locally_finite_measure ρ] :
  ∀ᵐ x ∂μ, tendsto (λ r, ρ (closed_ball x r) / μ (closed_ball x r))
    (𝓝[>] 0) (𝓝 (ρ.rn_deriv μ x)) :=
begin
  filter_upwards [vitali_family.ae_tendsto_rn_deriv (besicovitch.vitali_family μ) ρ] with x hx,
  exact hx.comp (tendsto_filter_at μ x)
end

/-- Given a measurable set `s`, then `μ (s ∩ closed_ball x r) / μ (closed_ball x r)` converges when
`r` tends to `0`, for almost every `x`. The limit is `1` for `x ∈ s` and `0` for `x ∉ s`.
This shows that almost every point of `s` is a Lebesgue density point for `s`.
A version for non-measurable sets holds, but it only gives the first conclusion,
see `ae_tendsto_measure_inter_div`. -/
lemma ae_tendsto_measure_inter_div_of_measurable_set
  (μ : measure β) [is_locally_finite_measure μ] {s : set β} (hs : measurable_set s) :
  ∀ᵐ x ∂μ, tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r))
    (𝓝[>] 0) (𝓝 (s.indicator 1 x)) :=
begin
  filter_upwards [vitali_family.ae_tendsto_measure_inter_div_of_measurable_set
    (besicovitch.vitali_family μ) hs],
  assume x hx,
  exact hx.comp (tendsto_filter_at μ x)
end

/-- Given an arbitrary set `s`, then `μ (s ∩ closed_ball x r) / μ (closed_ball x r)` converges
to `1` when `r` tends to `0`, for almost every `x` in `s`.
This shows that almost every point of `s` is a Lebesgue density point for `s`.
A stronger version holds for measurable sets, see `ae_tendsto_measure_inter_div_of_measurable_set`.

See also `is_doubling_measure.ae_tendsto_measure_inter_div`. -/
lemma ae_tendsto_measure_inter_div (μ : measure β) [is_locally_finite_measure μ] (s : set β) :
  ∀ᵐ x ∂(μ.restrict s), tendsto (λ r, μ (s ∩ (closed_ball x r)) / μ (closed_ball x r))
    (𝓝[>] 0) (𝓝 1) :=
by filter_upwards [vitali_family.ae_tendsto_measure_inter_div (besicovitch.vitali_family μ)]
    with x hx using hx.comp (tendsto_filter_at μ x)

end besicovitch


import Runtime.Utilities.Extensions

/-- An event type is a type which has an identifier and an associated time stamp. -/
class EventType (α : Type _) where
  Id : Type
  id : α → Id
  time : α → Time
  [decEqId : DecidableEq Id]

attribute [instance] EventType.decEqId

-- TODO: Use `List.Sorted` once it arrives in Mathlib.
inductive Queue.Sorted [inst : EventType ε] : List ε → Prop
  | nil : Sorted []
  | singleton : Sorted [e]
  | cons : (inst.time fst ≤ inst.time snd) → Sorted (snd :: tl) → Sorted (hd :: snd :: tl)

/--
A queue is a sorted list of events where each event has a time stamp greater or equal to a given
lower `bound`.
-/
structure Queue (ε : Type) [inst : EventType ε] (bound : Time) where
  events : Array ε
  sorted : Queue.Sorted events.data
  bounded : ∀ {event}, (events[0]? = some event) → bound ≤ inst.time event
  -- TODO: Add the property:
  -- ∀ {event₁ event₂}, (event₁ ∈ events) → (event₂ ∈ events) → (time event₁ > bound) →
  --                    (time event₁ ≠ time event₂) ∨ (id event₁ ≠ id event₂)

namespace Queue
open EventType

variable [EventType ε]

@[reducible]
instance : Membership ε (Queue ε bound) where
  mem e q := e ∈ q.events.data

-- TODO: What's the story for theorems about `Array`s in Lean 4?
theorem all_events_bounded {queue : Queue ε bound} :
  ∀ {event}, event ∈ queue.events.data → bound ≤ time event := by
  sorry

/-- A queue is empty if its underlying list of events is empty. -/
def isEmpty (q : Queue ε bound) : Bool := q.events.isEmpty

/-- The size of a queue is the number of its events. -/
def size (q : Queue ε bound) : Nat := q.events.size

instance : GetElem (Queue ε bound) Nat { e : ε // bound ≤ time e } (fun q i => i < q.size) where
  getElem queue i _ := {
    val := queue.events[i]
    property := sorry
  }

@[simp]
theorem getElem?_some_events_getElem?_some {queue : Queue ε bound} {i : Nat} :
  (queue[i]? = some event) → (queue.events[i]? = event.val) := by
  intro h
  sorry

@[simp]
theorem getElem?_none_events_getElem?_none {queue : Queue ε bound} {i : Nat} :
  (queue[i]? = none) → (queue.events[i]? = none) := by
  intro h
  sorry

/-- Creates an empty queue. -/
def nil : Queue ε bound where
  events := #[]
  sorted := .nil
  bounded := by simp

notation "°[]" => Queue.nil

instance : Inhabited (Queue ε bound) where
  default := °[]

/-- Creates a queue with a single event. -/
def singleton (event : ε) (h : bound ≤ time event) : Queue ε bound where
  events := #[event]
  sorted := .singleton
  bounded := by intros; simp_all

notation "°[" e "]' " h => Queue.singleton e h

/--
Creates a queue from an array of events by sorting its elements. The time bound fulfilled trivially
by choosing it to be 0.
-/
def sorting (events : Array ε) : Queue ε 0 where
  events := events.insertionSort (time · ≤ time ·)
  sorted := sorry
  bounded := by intros; simp

/--
The "next time" of a queue is the time of its next event (if it exists).

*Note:* The next event is considered to be the one at index 0.
-/
def nextTime (queue : Queue ε bound) : Option (Time.From bound) :=
  match queue[0]? with
  | none => none
  | some nextEvent => some {
      val := time nextEvent.val
      property := by have := nextEvent.property; simp_all [EventType.time]
    }

theorem nextTime_some {queue : Queue ε bound} :
  (queue.nextTime = some next) →
  (∃ event, queue[0]? = some event ∧ (time event.val) ≥ next.val) := by
  intro h
  unfold nextTime at h
  split at h <;> simp at h
  case _ event h' =>
    exists event
    apply And.intro h'
    simp [←h]

theorem nextTime_isSome_iff_not_isEmpty {queue : Queue ε bound} :
  queue.nextTime.isSome ↔ ¬queue.isEmpty := by
  rw [Queue.isEmpty, ←Array.getElem?_zero_isSome_iff_not_isEmpty]
  simp [nextTime]
  constructor <;> split <;> simp_all [Option.isSome]
  · simp [Queue.getElem?_some_events_getElem?_some ‹_›]

/--
Splits a queue into a list of "next events" and "remaining events".
* "Next events" are those which have a time stamp matching the `nextTime` and are the first among
  all events with the same id.
* "Remaining events" are those which have a time stamp greater than the `nextTime` or have an event
  in with the same id earlier in the queue.

For example, let's assume each event has the form `(time, id, value)`. Then the queue:
```
(10, a, 0) (10, a, 1) (10, b, 2) (11, a, 3)
```
... would be split into:
* next events `(10, a, 0) (10, b, 2)`, and
* remaining events `(10, a, 1) (11, a, 3)`.
-/
def split
  (queue : Queue ε bound) (anchor : Time) (h : ∀ next, queue.nextTime = some next → anchor ≤ next) :
  Array ε × Queue ε anchor :=
  let ⟨candidates, later⟩ := queue.events.split (time · = anchor)
  let ⟨next, postponed⟩ := candidates.unique (EventType.id ·)
  {
    fst := next
    snd := {
      events := postponed ++ later
      sorted := sorry
      bounded := sorry
    }
  }

-- *Note*: For adherence to the LF scheduling semantics, this operation overrides events of equal id
--         and time, except those whose time is `bound`.
--
-- *Note:* It is important that this merge is stable. That is, it should be the same as would be
-- produced by a stable sorting algorithm on input `queue₁ ++ queue₂`.
-- TODO: Implement all of this properly once something like `Array.merge` arrives in Std.
def merge [inst : EventType ε] (queue₁ queue₂ : Queue ε bound) : Queue ε bound :=
  if queue₁.isEmpty      then queue₂
  else if queue₂.isEmpty then queue₁
  else
  -- Note, using `split` is inefficient as it traverses the entire array.
  let ⟨immediate₁, future₁⟩ := queue₁.events.split (time · = bound)
  let ⟨immediate₂, future₂⟩ := queue₂.events.split (time · = bound)
  {
    events := (mergeImmediate immediate₁ immediate₂) ++ (mergeFuture future₁ future₂)
    sorted := sorry
    bounded := sorry
  }
where
  mergeImmediate (is₁ is₂ : Array ε) : Array ε :=
    (is₁ ++ is₂).insertionSort (time · ≤ time ·)
  mergeFuture (fs₁ fs₂ : Array ε) : Array ε :=
    let fs₁' := fs₁.filter fun event₁ =>
      ¬ fs₂.any fun event₂ =>
        (inst.time event₁ = inst.time event₂) ∧
        (inst.id event₁ = inst.id event₂)
    (fs₁' ++ fs₂).insertionSort (time · ≤ time ·)

theorem merge_mem₂ {queue₁ queue₂ : Queue ε bound} :
  (event ∈ queue₂) → (event ∈ queue₁.merge queue₂) := by
  intro h
  simp [merge]
  split <;> try split
  case inl => exact h
  case inr.inl he =>
    rw [isEmpty, Array.isEmpty_iff_data_eq_nil] at he
    simp [Membership.mem, he] at h
    contradiction
  case inr.inr =>
    by_cases time event = bound
    case inl ht =>
      -- `event` is in `immediate₂` and thus retained as part of `mergeImmediate`
      sorry
    case inr ht =>
      -- `event` is in `future₂` and thus retained as part of `mergeFuture`
      sorry

/--
Maps a queue of event type `ε` to a queue of event type `δ`. To ensure that the resulting queue is
still sorted and bounded, the map must preserve time stamps.
-/
def map [EventType δ] (queue : Queue ε bound) (f : ε → δ) (h : ∀ e : ε, time e = time (f e)) :
  Queue δ bound where
  events := queue.events.map f
  sorted := sorry
  bounded := sorry

namespace Queue


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.structured_arrow
import category_theory.groupoid
import category_theory.punit

/-!
# The category of elements

This file defines the category of elements, also known as (a special case of) the Grothendieck
construction.

Given a functor `F : C ⥤ Type`, an object of `F.elements` is a pair `(X : C, x : F.obj X)`.
A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.

## Implementation notes

This construction is equivalent to a special case of a comma construction, so this is mostly just a
more convenient API. We prove the equivalence in
`category_theory.category_of_elements.structured_arrow_equivalence`.

## References
* [Emily Riehl, *Category Theory in Context*, Section 2.4][riehl2017]
* <https://en.wikipedia.org/wiki/Category_of_elements>
* <https://ncatlab.org/nlab/show/category+of+elements>

## Tags
category of elements, Grothendieck construction, comma category
-/

namespace category_theory

universes w v u
variables {C : Type u} [category.{v} C]

/--
The type of objects for the category of elements of a functor `F : C ⥤ Type`
is a pair `(X : C, x : F.obj X)`.
-/
@[nolint has_inhabited_instance]
def functor.elements (F : C ⥤ Type w) := (Σ c : C, F.obj c)

/-- The category structure on `F.elements`, for `F : C ⥤ Type`.
    A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.
 -/
instance category_of_elements (F : C ⥤ Type w) : category.{v} F.elements :=
{ hom := λ p q, { f : p.1 ⟶ q.1 // (F.map f) p.2 = q.2 },
  id := λ p, ⟨𝟙 p.1, by obviously⟩,
  comp := λ p q r f g, ⟨f.val ≫ g.val, by obviously⟩ }

namespace category_of_elements

@[ext]
lemma ext (F : C ⥤ Type w) {x y : F.elements} (f g : x ⟶ y) (w : f.val = g.val) : f = g :=
subtype.ext_val w

@[simp] lemma comp_val {F : C ⥤ Type w} {p q r : F.elements} {f : p ⟶ q} {g : q ⟶ r} :
  (f ≫ g).val = f.val ≫ g.val := rfl

@[simp] lemma id_val {F : C ⥤ Type w} {p : F.elements} : (𝟙 p : p ⟶ p).val = 𝟙 p.1 := rfl

end category_of_elements

noncomputable
instance groupoid_of_elements {G : Type u} [groupoid.{v} G] (F : G ⥤ Type w) :
  groupoid F.elements :=
{ inv := λ p q f, ⟨inv f.val,
      calc F.map (inv f.val) q.2 = F.map (inv f.val) (F.map f.val p.2) : by rw f.2
                             ... = (F.map f.val ≫ F.map (inv f.val)) p.2 : by simp
                             ... = p.2 : by {rw ←functor.map_comp, simp}⟩, }

namespace category_of_elements
variable (F : C ⥤ Type w)

/-- The functor out of the category of elements which forgets the element. -/
@[simps]
def π : F.elements ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.val }

/--
A natural transformation between functors induces a functor between the categories of elements.
-/
@[simps]
def map {F₁ F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : F₁.elements ⥤ F₂.elements :=
{ obj := λ t, ⟨t.1, α.app t.1 t.2⟩,
  map := λ t₁ t₂ k, ⟨k.1, by simpa [←k.2] using (functor_to_types.naturality _ _ α k.1 t₁.2).symm⟩ }

@[simp] lemma map_π {F₁ F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : map α ⋙ π F₂ = π F₁ := rfl

/-- The forward direction of the equivalence `F.elements ≅ (*, F)`. -/
def to_structured_arrow : F.elements ⥤ structured_arrow punit F :=
{ obj := λ X, structured_arrow.mk (λ _, X.2),
  map := λ X Y f, structured_arrow.hom_mk f.val (by tidy) }

@[simp] lemma to_structured_arrow_obj (X) :
  (to_structured_arrow F).obj X = { left := punit.star, right := X.1, hom := λ _, X.2 } := rfl
@[simp] lemma to_comma_map_right {X Y} (f : X ⟶ Y) :
  ((to_structured_arrow F).map f).right = f.val := rfl

/-- The reverse direction of the equivalence `F.elements ≅ (*, F)`. -/
def from_structured_arrow : structured_arrow punit F ⥤ F.elements :=
{ obj := λ X, ⟨X.right, X.hom (punit.star)⟩,
  map := λ X Y f, ⟨f.right, congr_fun f.w'.symm punit.star⟩ }

@[simp] lemma from_structured_arrow_obj (X) :
  (from_structured_arrow F).obj X = ⟨X.right, X.hom (punit.star)⟩ := rfl
@[simp] lemma from_structured_arrow_map {X Y} (f : X ⟶ Y) :
  (from_structured_arrow F).map f = ⟨f.right, congr_fun f.w'.symm punit.star⟩ := rfl

/-- The equivalence between the category of elements `F.elements`
    and the comma category `(*, F)`. -/
@[simps]
def structured_arrow_equivalence : F.elements ≌ structured_arrow punit F :=
equivalence.mk (to_structured_arrow F) (from_structured_arrow F)
  (nat_iso.of_components (λ X, eq_to_iso (by tidy)) (by tidy))
  (nat_iso.of_components
    (λ X, { hom := { right := 𝟙 _ }, inv := { right := 𝟙 _ } })
    (by tidy))

end category_of_elements
end category_theory


import category_theory.category
import o_minimal.structure
import o_minimal.coordinates

universe u

namespace o_minimal

open set

-- Carrier for the (o-minimal) structure.
variables {R : Type u}

-- A structure on `R`.
variables (S : struc R)

/--
A type with coordinates valued in R is *definable* with respect to a given structure S on R
if the corresponding subset of Rⁿ is definable according to S.
-/
class is_definable (X : Type*) [has_coordinates R X] : Prop :=
(is_definable [] : S.definable (coordinate_image R X))

instance is_definable.self : is_definable S R :=
begin
  constructor,
  convert S.definable_univ 1,
  ext,
  simp [coordinate_image],
  use (x 0),
  ext i,
  have : i = 0 := by cc,
  subst i
end

-- TODO: Generalize to [is_definable S X] : is_definable S (finvec n X)
instance is_definable.rn {n : ℕ} : is_definable S (finvec n R) :=
begin
  constructor,
  convert S.definable_univ n,
  ext,
  simp [coordinate_image]
end

variables {X : Type*} [has_coordinates R X] [is_definable S X]
variables {Y : Type*} [has_coordinates R Y] [is_definable S Y]
variables {Z : Type*} [has_coordinates R Z] [is_definable S Z]
variables {W : Type*} [has_coordinates R W] [is_definable S W]

instance is_definable.prod : is_definable S (X × Y) :=
begin
  constructor,
  rw coordinate_image_prod,
  exact S.definable_external_prod (is_definable.is_definable S X) (is_definable.is_definable S Y)
end

-- TODO: instances matching the rest of has_coordinates

section definable_set
/-
We first discuss what it means for
a subset `s : set X` to be definable
when `X` is a definable type. -/

def def_set (s : set X) : Prop := S.definable (coords R '' s)

variables {S}

/-- The subtype of a definable type determined by a definable set is definable.
Unfortunately, this can't be a global instance because of the hypothesis `hs`. -/
def is_definable.subtype {s : set X} (hs : def_set S s) : is_definable S s :=
{ is_definable := begin
    unfold def_set at hs,
    convert hs,
    ext x,
    simp [coordinate_image]
  end }

variables (X)

lemma def_set_empty : def_set S (∅ : set X) :=
begin
  convert S.definable_empty _,
  simp [def_set]
end

lemma def_set_univ : def_set S (set.univ : set X) :=
by simpa [def_set] using is_definable.is_definable S X

variable {X}

lemma def_set.inter {s t : set X} (hs : def_set S s) (ht : def_set S t) :
  def_set S (s ∩ t) :=
begin
  convert S.definable_inter hs ht,
  simp [def_set, image_inter (injective_coords X)]
end

lemma def_set.union {s t : set X} (hs : def_set S s) (ht : def_set S t) :
  def_set S (s ∪ t) :=
begin
  convert S.definable_union hs ht,
  simp [def_set, image_union]
end

lemma def_set.diff {s t : set X} (hs : def_set S s) (ht : def_set S t) :
  def_set S (s \ t) :=
begin
  convert S.definable_diff hs ht,
  simp [def_set, image_diff (injective_coords X)],
end

lemma def_set.compl {s : set X} (hs : def_set S s) : def_set S (sᶜ) :=
by { rw compl_eq_univ_diff, exact (def_set_univ _).diff hs }

lemma def_set.compl' {s : set X} (hs : def_set S sᶜ) : def_set S s :=
by { rw ←compl_compl s, exact hs.compl }

lemma def_set.iff {s t : set X} (hs : def_set S s) (ht : def_set S t) :
  def_set S {x : X | x ∈ s ↔ x ∈ t} :=
begin
  simp only [iff_iff_and_or_not_and_not],
  exact (hs.inter ht).union (hs.compl.inter ht.compl)
end

lemma def_set_Inter {ι : Type*} [fintype ι] {t : ι → set X}
  (ht : ∀ i, def_set S (t i)) : def_set S (⋂ i, t i) :=
suffices ∀ {s : set ι}, set.finite s → def_set S (⋂ i ∈ s, t i),
by { convert this finite_univ, simp },
λ s hs, finite.induction_on hs
  (by { convert def_set_univ _, simp, apply_instance }) -- why is apply_instance needed here?
  (λ i s _ _ IH, by { convert (ht i).inter IH, simp })

lemma def_set_Union {ι : Type*} [fintype ι] {t : ι → set X}
  (ht : ∀ i, def_set S (t i)) : def_set S (⋃ i, t i) :=
begin
  apply def_set.compl',
  rw compl_Union,
  exact def_set_Inter (λ i, (ht i).compl)
end

lemma def_set.or {s t : X → Prop} (hs : def_set S {x : X | s x}) (ht : def_set S {x : X | t x}) :
  def_set S {x | s x ∨ t x} :=
hs.union ht

lemma def_set.and {s t : X → Prop} (hs : def_set S {x : X | s x}) (ht : def_set S {x : X | t x}) :
  def_set S {x | s x ∧ t x} :=
hs.inter ht

lemma def_set.not {s : X → Prop} (hs : def_set S {x : X | s x}) :
  def_set S {x | ¬ s x} :=
hs.compl

lemma def_set.imp {s t : X → Prop} (hs : def_set S {x : X | s x}) (ht : def_set S {x : X | t x}) :
  def_set S {x | s x → t x} :=
begin
  simp [imp_iff_not_or], -- classical!
  exact hs.not.or ht
end

lemma def_set.forall_fintype {ι : Type*} [fintype ι] {t : ι → set X}
  (ht : ∀ i, def_set S (t i)) : def_set S {x | ∀ i, x ∈ t i} :=
begin
  convert def_set_Inter ht using 1,
  ext x,
  simp
end

lemma def_set.exists_fintype {ι : Type*} [fintype ι] {t : ι → set X}
  (ht : ∀ i, def_set S (t i)) : def_set S {x | ∃ i, x ∈ t i} :=
begin
  convert def_set_Union ht using 1,
  ext x,
  simp
end

lemma def_set.proj {s : set (X × Y)} (hs : def_set S s) : def_set S (prod.fst '' s) :=
begin
  unfold def_set,
  convert S.definable_proj hs using 1,
  ext z,
  rw [image_image, image_image],
  simp only [has_coordinates.prod_coords, finvec.left_append]
end

-- Is it better to use `{p : Y × X | s p.2 p.1}`?
-- After all, Lean prefers to form `Z × Y × X = Z × (Y × X)`
lemma def_set.exists {s : X → Y → Prop} (hs : def_set S {p : X × Y | s p.1 p.2}) :
  def_set S {x | ∃ y, s x y} :=
begin
  convert def_set.proj hs,
  ext, simp
end

lemma def_set.forall {s : X → Y → Prop} (hs : def_set S {p : X × Y | s p.1 p.2}) :
  def_set S {x | ∀ y, s x y} :=
begin
  -- classical!!
  have : ∀ (s : X → Y → Prop) (hs : def_set S {p : X × Y | s p.1 p.2}),
    def_set S {x | ∀ y, ¬ s x y},
  { intros t ht, simpa using ht.exists.not },
  simpa using this (λ x y, ¬ s x y) hs.not,
end

lemma def_set.reindex {f : X → Y} (hf : is_reindexing R f)
  {s : set Y} (hs : def_set S s) : def_set S (f ⁻¹' s) :=
begin
  cases hf with fσ hf,
  unfold def_set,
  -- The preimage f ⁻¹' s, as a subset of the Rⁿ in which X lives,
  -- is the intersection of X with the preimage of s under the reindexing.
  convert S.definable_inter (is_definable.is_definable S X) (S.definable_reindex fσ hs),
  ext z,
  suffices : (∃ (x : X), f x ∈ s ∧ coords R x = z) ↔
    z ∈ range (coords R) ∧ ∃ (y : Y), y ∈ s ∧ coords R y = z ∘ fσ,
  { simpa },
  -- TODO: funext'd version of `is_reindexing.hf`
  replace hf : ∀ (x : X), coords R x ∘ fσ = coords R (f x) := λ x, funext (λ i, (hf x i)),
  split,
  { rintro ⟨x, hfx, rfl⟩,
    refine ⟨mem_range_self _, f x, hfx, (hf x).symm⟩ },
  { rintro ⟨⟨x, rfl⟩, y, hy, H⟩,
    rw hf x at H,
    replace hf := injective_coords _ H,
    subst y,
    exact ⟨x, hy, rfl⟩ }
end

lemma def_set_diag : def_set S {p : X × X | p.1 = p.2} :=
begin
  unfold def_set,
  -- The image of the diagonal of X in Rⁿ × Rⁿ
  -- is the diagonal of Rⁿ intersected with X × X.
  convert S.definable_inter
    (S.definable_external_prod (is_definable.is_definable S X) (is_definable.is_definable S X))
    S.definable_diag_rn,
  ext z,
  rw [mem_inter_iff, finvec.mem_prod_iff],
  change _ ↔ _ ∧ finvec.left z = finvec.right z,
  split,
  { rintro ⟨⟨x, y⟩, h, rfl⟩,
    change x = y at h,
    simp [coordinate_image, h] },
  { rintro ⟨⟨hz₁, _⟩, hz₂⟩,
    rcases hz₁ with ⟨x, hx⟩,
    refine ⟨⟨x, x⟩, rfl, _⟩,
    convert finvec.left_append_right _,
    refine finvec.append.inj_iff.mpr _,
    simp [hx, hz₂] }
end

lemma def_set.prod_univ {s : set X} (hs : def_set S s) :
  def_set S {p : X × Y | p.1 ∈ s} :=
def_set.reindex is_reindexing.fst hs

lemma def_set.univ_prod {t : set Y} (ht : def_set S t) :
  def_set S {p : X × Y | p.2 ∈ t} :=
def_set.reindex is_reindexing.snd ht

lemma def_set.prod {s : set X} (hs : def_set S s) {t : set Y} (ht : def_set S t) :
  def_set S (s.prod t) :=
hs.prod_univ.inter ht.univ_prod

end definable_set

section definable_fun
-- Now we introduce definable functions between definable types.
-- They are the functions whose graphs are definable sets.

/-- A function f : X → Y is definable if its graph is a definable set. -/
def def_fun (f : X → Y) : Prop := def_set S {p : X × Y | f p.1 = p.2}

variables {S}

lemma def_fun.id : def_fun S (id : X → X) :=
def_set_diag

lemma def_fun.comp {g : Y → Z} (hg : def_fun S g) {f : X → Y} (hf : def_fun S f) :
  def_fun S (g ∘ f) :=
begin
  suffices : def_set S {p : X × Z | ∃ y, f p.1 = y ∧ g y = p.2},
  { unfold def_fun,
    convert this,
    ext ⟨x, z⟩,
    simp },
  apply def_set.exists,
  apply def_set.and,
  { have : is_reindexing R (λ p : (X × Z) × Y, (p.1.1, p.2)),
    { apply_rules [is_reindexing.prod, is_reindexing.fst, is_reindexing.snd, is_reindexing.comp] },
    exact def_set.reindex this hf },
  { have : is_reindexing R (λ p : (X × Z) × Y, (p.2, p.1.2)),
    { apply_rules [is_reindexing.prod, is_reindexing.fst, is_reindexing.snd, is_reindexing.comp] },
    exact def_set.reindex this hg }
end

lemma is_reindexing.def_fun {f : X → Y} (hf : is_reindexing R f) :
  def_fun S f :=
begin
  cases hf with fσ hf,
  unfold def_fun,
  unfold def_set,
  convert S.definable_inter
    (S.definable_prod_rn (is_definable.is_definable S X))
    (S.definable_reindex_aux fσ (def_set_univ Y)),
  ext z,
  split,
  { rintro ⟨⟨x, y⟩, h, rfl⟩,
    change f x = y at h, subst y,
    show _ ∧ _ ∧ _,
    simp only [mem_range_self, and_true, image_univ, has_coordinates.prod_coords, finvec.left_append, finvec.right_append, finvec.append_mem_prod_univ_iff],
    refine ⟨⟨x, _⟩, _⟩,
    { simp },
    { ext i,
      apply hf, }, },
  { rintro ⟨⟨x, hx⟩, ⟨hz, ⟨y, ⟨⟩, hy⟩⟩⟩,
    simp only [mem_image, mem_set_of_eq],
    use [(x,y)],
    split,
    { apply @injective_coords R,
      ext i,
      show coords R (f x) i = coords R y i,
      rw ← hf,
      rw [← hx, ← hy] at hz,
      exact congr_fun hz i },
    { simp [hx, hy] } }
end

lemma def_fun.preimage {f : X → Y} (hf : def_fun S f) {s : set Y} (hs : def_set S s) :
  def_set S (f ⁻¹' s) :=
begin
  -- f ⁻¹' s = {x | ∃ (p : X × Y), p.1 = x ∧ p ∈ Γ(f)}
  convert def_set.proj (hf.inter ((def_set_univ _).prod hs)) using 1,
  ext, simp
end

lemma def_fun.coords : def_fun S (λ x : X, coords R x) :=
is_reindexing.def_fun is_reindexing.coords

lemma def_fun.coord (i : fin (has_coordinates.ambdim R X)) : def_fun S (λ x : X, coords R x i) :=
is_reindexing.def_fun (is_reindexing.coord i)

lemma def_fun.coord_rn {n : ℕ} (i : fin n) : def_fun S (λ x : finvec n R, x i) :=
def_fun.coord i

lemma def_fun.fst : def_fun S (prod.fst : X × Y → X) :=
is_reindexing.def_fun is_reindexing.fst

lemma def_fun.snd : def_fun S (prod.snd : X × Y → Y) :=
is_reindexing.def_fun is_reindexing.snd

lemma def_fun.prod' {f : X → Y} {g : X → Z} (hf : def_fun S f) (hg : def_fun S g) :
  def_fun S (λ x, (f x, g x)) :=
begin
  unfold def_fun,
  let p1 : X × (Y × Z) → X × Y := λ p, (p.1, p.2.1),
  have hp1 : def_fun S p1,
  { apply is_reindexing.def_fun,
    apply is_reindexing.fst.prod (is_reindexing.fst.comp is_reindexing.snd) },
  let p2 : X × (Y × Z) → X × Z := λ p, (p.1, p.2.2),
  have hp2 : def_fun S p2,
  { apply is_reindexing.def_fun,
    apply is_reindexing.fst.prod (is_reindexing.snd.comp is_reindexing.snd) },
  convert (hp1.preimage hf).inter (hp2.preimage hg),
  ext ⟨x,y,z⟩,
  show (f x, g x) = (y,z) ↔ _,
  simp only [mem_inter_eq, prod.mk.inj_iff, mem_set_of_eq, preimage_set_of_eq],
end

lemma def_fun.prod {f : X → Z} {g : Y → W} (hf : def_fun S f) (hg : def_fun S g) :
  def_fun S (prod.map f g) :=
(hf.comp def_fun.fst).prod' (hg.comp def_fun.snd)

lemma def_fun_subtype_val {s : set X} {hs : def_set S s} :
  by haveI := is_definable.subtype hs; exact
  def_fun S (subtype.val : s → X) :=
by haveI := is_definable.subtype hs; exact
is_reindexing.subtype.val.def_fun

lemma def_fun.finvec.left {n m : ℕ} : def_fun S (λ x : finvec (n+m) R, x.left) :=
is_reindexing.finvec.left.def_fun

lemma def_fun.finvec.right {n m : ℕ} : def_fun S (λ x : finvec (n+m) R, x.right) :=
is_reindexing.finvec.right.def_fun

lemma def_fun.finvec.init {n : ℕ} : def_fun S (λ x : finvec (n+1) R, x.init) :=
is_reindexing.finvec.init.def_fun

lemma def_fun.finvec.snoc' {n : ℕ} : def_fun S (λ p : finvec n R × R, p.1.snoc p.2) :=
is_reindexing.finvec.snoc.def_fun

lemma def_fun.finvec.snoc {n : ℕ} {f : X → finvec n R} (hf : def_fun S f) {g : X → R} (hg : def_fun S g) :
  def_fun S (λ x, (f x).snoc (g x)) :=
def_fun.finvec.snoc'.comp (hf.prod' hg)

lemma def_set_eq {f g : X → Y} (hf : def_fun S f) (hg : def_fun S g) :
  def_set S {x | f x = g x} :=
(hf.prod' hg).preimage def_set_diag

lemma def_fun.cancel {g : Y → Z} (dg : def_fun S g) (hg : function.injective g)
  {f : X → Y} (h : def_fun S (g ∘ f)) : def_fun S f :=
begin
  unfold def_fun,
  suffices : def_set S {p : X × Y | (g ∘ f) p.fst = g p.snd},
  { convert ←this,
    ext,
    apply hg.eq_iff },
  apply def_set_eq,
  { exact h.comp def_fun.fst },
  { exact dg.comp def_fun.snd }
end

lemma def_fun_subtype_mk {s : set X} {hs : def_set S s}
  {f : Y → X} (df : def_fun S f) (h : ∀ y, f y ∈ s) :
  by haveI := is_definable.subtype hs; exact
  def_fun S (λ y, (⟨f y, h y⟩ : s)) :=
by haveI := is_definable.subtype hs; exact
def_fun.cancel def_fun_subtype_val subtype.val_injective df

lemma def_fun_subtype_iff {s : set X} {ds : def_set S s} {f : Y → s} :
  by haveI := is_definable.subtype ds; exact
  def_fun S f ↔ def_fun S (subtype.val ∘ f) :=
by haveI := is_definable.subtype ds; exact
⟨λ h, def_fun_subtype_val.comp h, λ h, def_fun_subtype_val.cancel subtype.val_injective h⟩

lemma def_fun.image {f : X → Y} (hf : def_fun S f) {s : set X} (hs : def_set S s) :
  def_set S (f '' s) :=
show def_set S {y | ∃ x, x ∈ s ∧ f x = y}, from
def_set.exists $
  (def_fun.preimage def_fun.snd hs).and
  (def_set_eq (hf.comp def_fun.snd) (def_fun.fst))

lemma def_fun.range {f : X → Y} (hf : def_fun S f) : def_set S (range f) :=
by { rw ←image_univ, exact hf.image (def_set_univ _) }

end definable_fun

section definable_val
-- Finally, a "value" (element) of X is definable
-- if the corresponding singleton set is definable.
--
-- This notion is mostly used for bootstrapping
-- because in the o-minimal project we're only interested in
-- structures S on R in which every r ∈ R is definable,
-- which forces every value of every definable type to be definable.

/-- A value `x : X` is definable if `{x}` is definable. -/
def def_val (x : X) : Prop := def_set S ({x} : set X)

variables (S)

/-- A structure `S` on `R` has *definable constants*
if every `r : R` is definable. -/
class definable_constants : Prop :=
(definable_val : ∀ (r : R), def_val S r)

variables {S}

-- These primed lemmas take `def_val` arguments
-- and have unprimed variants which use a `definable_constants S` assumption.

lemma def_set_eq_const' {f : X → Y} (hf : def_fun S f) {y : Y} (hy : def_val S y) :
  def_set S {x | f x = y} :=
show def_set S (f ⁻¹' {y}), from
hf.preimage hy

lemma def_set_const_eq' {f : X → Y} (hf : def_fun S f) {y : Y} (hy : def_val S y) :
  def_set S {x | y = f x} :=
by { convert def_set_eq_const' hf hy, simp_rw [eq_comm] }

lemma def_fun_const' {y : Y} (hy : def_val S y) : def_fun S (λ (x : X), y) :=
def_set_const_eq' def_fun.snd hy

lemma def_val_const [definable_constants S] {x : X} : def_val S x :=
begin
  unfold def_val,
  have : {x} = ⋂ i, {x' : X | coords R x' i = coords R x i},
  { ext x',
    rw [mem_singleton_iff, mem_Inter],
    exact (@injective_coords R X _).eq_iff.symm.trans function.funext_iff },
  rw this,
  apply def_set_Inter,
  intro i,
  exact def_set_eq_const' (def_fun.coord i) (definable_constants.definable_val _)
end

lemma def_set_eq_const [definable_constants S] {f : X → Y} (hf : def_fun S f) (y : Y) :
  def_set S {x | f x = y} :=
def_set_eq_const' hf def_val_const

lemma def_set_const_eq [definable_constants S] {f : X → Y} (hf : def_fun S f) (y : Y) :
  def_set S {x | y = f x} :=
def_set_const_eq' hf def_val_const

lemma def_fun_const [definable_constants S] {y : Y} : def_fun S (λ (x : X), y) :=
def_fun_const' def_val_const

-- TODO: more lemmas as needed.

end definable_val

end o_minimal