/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.basic
import set_theory.cardinal_ordinal
import measure_theory.integral.lebesgue
import measure_theory.covering.vitali_family

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

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

## 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 topological_space 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 := λ i, 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],
  apply Union_subset_Union2,
  assume r,
  exact ⟨⟨r, r.2.trans_le hij⟩, subset.refl _⟩,
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 := le_total x y using [x y, y x],
  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 := le_total (G a) (G b) using [a b, b a] tactic.skip,
      { 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) },
      { assume a_ne_b,
        rw or_comm,
        exact this a_ne_b.symm }
    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 := le_total jx jy using [jx jy, jy jx] tactic.skip,
    swap,
    { assume h1 h2 h3 h4 h5 h6 h7,
      rw [function.on_fun, disjoint.comm],
      exact this h4 h5 h6 h1 h2 h3 h7.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⟩, p.index a, ⟨a, rfl, ha.1, rfl⟩, ha.2⟩ }
end

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

open_locale nnreal

/-- 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
  [second_countable_topology α] [measurable_space α] [opens_measurable_space α]
  (μ : 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, countable (u i),
  { 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.coe_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) ennreal.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 _ omeas (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_Prop (λ 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_bUnion, 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 k.2 l 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' k'.2 l' l'.2 k'nel' }
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 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
  [second_countable_topology α] [hb : has_besicovitch_covering α]
  [measurable_space α] [opens_measurable_space α] (μ : measure α) [is_finite_measure μ]
  (f : α → set ℝ) (s : set α)
  (hf : ∀ x ∈ s, (f x).nonempty) (hf' : ∀ x ∈ s, f x ⊆ Ioi 0) (hf'' : ∀ x ∈ s, Inf (f x) ≤ 0) :
  ∃ (t : set (α × ℝ)), (countable t)
    ∧ (∀ (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 hb.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, r ≤ 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 exists_lt_of_cInf_lt (hf x xs) ((hf'' x xs).trans_lt zero_lt_one) with ⟨r, hr, h'r⟩,
        exact ⟨r, hr, h'r.le, 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 exists_lt_of_cInf_lt (hf x xs) ((hf'' x xs).trans_lt this) with ⟨r, hr, h'r⟩,
        refine ⟨r, hr, h'r.le.trans (min_le_right _ _), _⟩,
        rw disjoint.comm,
        exact disjoint_closed_ball_of_lt_inf_dist (h'r.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 rpos : ∀ x ∈ s', 0 < r x := λ x hx, hf' x ((mem_diff x).1 hx).1 (hr x hx).1,
      have rle : ∀ x ∈ s', r x ≤ 1 := λ x hx, (hr x hx).2.1,
      exact exist_finset_disjoint_balls_large_measure μ hτ hN s' r rpos rle },
    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' p'v q' 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.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⟩,
        dsimp,
        exact (hr p' (vs' p'v)).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, forall_false_left, 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 ennreal.mul_le_mul le_rfl 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) ennreal.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
  [second_countable_topology α] [has_besicovitch_covering α]
  [measurable_space α] [opens_measurable_space α] (μ : measure α) [sigma_finite μ]
  (f : α → set ℝ) (s : set α)
  (hf : ∀ x ∈ s, (f x).nonempty) (hf' : ∀ x ∈ s, f x ⊆ Ioi 0) (hf'' : ∀ x ∈ s, Inf (f x) ≤ 0) :
  ∃ (t : set (α × ℝ)), (countable t)
    ∧ (∀ (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 hf' 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`.
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
  [second_countable_topology α] [hb : has_besicovitch_covering α]
  [measurable_space α] [opens_measurable_space α] (μ : measure α) [sigma_finite μ]
  (f : α → set ℝ) (s : set α)
  (hf : ∀ x ∈ s, (f x).nonempty) (hf' : ∀ x ∈ s, f x ⊆ Ioi 0) (hf'' : ∀ x ∈ s, Inf (f x) ≤ 0) :
  ∃ (t : set α) (r : α → ℝ), countable t ∧ t ⊆ s ∧ (∀ x ∈ t, r x ∈ f x)
    ∧ μ (s \ (⋃ (x ∈ t), closed_ball x (r x))) = 0
    ∧ t.pairwise_disjoint (λ x, closed_ball x (r x)) :=
begin
  rcases exists_disjoint_closed_ball_covering_ae_aux μ f s hf hf' hf''
    with ⟨v, v_count, vs, vf, μ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, le_of_lt (hf' _ (vs _ hp) (vf _ hp)),
    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 (x, p) hxp (x, r x) 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 vf _ (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 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 [second_countable_topology α] [has_besicovitch_covering α]
  [measurable_space α] [opens_measurable_space α] (μ : 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, (g x).nonempty,
    { assume x xs,
      obtain ⟨t, tf, ht⟩ : ∃ (t : set α) (H : t ∈ f x), t ⊆ closed_ball x 1 :=
        ffine x xs 1 zero_lt_one,
      obtain ⟨r, rpos, rfl⟩ : ∃ (r : ℝ), 0 < r ∧ closed_ball x r = t,
        by simpa using fsubset x xs tf,
      exact ⟨r, rpos, tf⟩ },
    have B : ∀ x ∈ s, g x ⊆ Ioi (0 : ℝ),
    { assume x xs r hr,
      replace hr : 0 < r ∧ closed_ball x r ∈ f x, by simpa only using hr,
      exact hr.1 },
    have C : ∀ x ∈ s, Inf (g x) ≤ 0,
    { assume x xs,
      have g_bdd : bdd_below (g x) := ⟨0, λ r hr, hr.1.le⟩,
      refine le_of_forall_le_of_dense (λ ε εpos, _),
      obtain ⟨t, tf, ht⟩ : ∃ (t : set α) (H : t ∈ f x), t ⊆ closed_ball x ε := ffine x xs ε εpos,
      obtain ⟨r, rpos, rfl⟩ : ∃ (r : ℝ), 0 < r ∧ closed_ball x r = t,
        by simpa using fsubset x xs tf,
      rcases le_total r ε with H|H,
      { exact (cInf_le g_bdd ⟨rpos, tf⟩).trans H },
      { have : closed_ball x r = closed_ball x ε :=
          subset.antisymm ht (closed_ball_subset_closed_ball H),
        rw this at tf,
        exact cInf_le g_bdd ⟨εpos, tf⟩ } },
    obtain ⟨t, r, t_count, ts, tg, μt, tdisj⟩ : ∃ (t : set α) (r : α → ℝ), countable t
      ∧ t ⊆ s ∧ (∀ x ∈ t, r x ∈ g x)
      ∧ μ (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 B C,
    exact ⟨t, λ x, closed_ball x (r x), ts, tdisj, λ x xt, (tg x xt).2, μt⟩,
  end }

end besicovitch


-- Lean has first-class functions.
-- they're funcs that are teated like any other variables
  -- can be passsed as args to other funcs, return by another, assigned as value to variable

-- functions: can take in two or more args
-- args: each can also be arbitrary/anonymous functions itself - ie '(f : Nat → Nat)'
def twice (f : Nat → Nat) (a : Nat) :=
  f (f a)

-- `fun` can be used to declare anonymous funcs
-- alternatively, just simply use `.` to denote the input. it is 'syntax sugar'
-- good for defining simply anonymous funcs
#eval twice (fun x => x + 2) 6
#eval twice (. * 5) 5

-- theorems: can prove theorems about the functions
-- if the theorem is not consistent, it will show an error
-- `rfl` is reflexivity - Lean "symbolically" reduces both sides of equality till they're equal
theorem twiceAdd2 (a : Nat) : twice (fun x => x + 3) a = a + 6 := rfl

-- induction: `FILL LATER`
-- enumerated types: special case of inductive types
  -- this creates new type `Weekday`
  -- there's 7 constructors in `Weekday` namespace - monday, tuesday, etc are distinct elements
  -- no other distinguishing properties
inductive Weekday where
  | sunday    : Weekday
  | monday    : Weekday
  | tuesday   : Weekday
  | wednesday : Weekday
  | thursday  : Weekday
  | friday    : Weekday
  | saturday  : Weekday

-- `#check`: prints type of term
#check Weekday.sunday
#check Weekday.monday

-- `open`: opens namespace, making all declarations in it accessible wiithout qualification
open Weekday
#check sunday
#check tuesday

-- `match _ with`: even crazier functions: define by pattern matching
def natOfWeekday (d : Weekday) : Nat :=
  match d with
  | sunday    => 1
  | monday    => 2
  | tuesday   => 3
  | wednesday => 4
  | thursday  => 5
  | friday    => 6
  | saturday  => 7

#eval natOfWeekday monday

-- boolean functions: True and False
  -- `fun` + `match`  is a common idiom.
  -- The following expression is syntax sugar for `fun d => match d with | monday => true | _ => false`
def isMonday : Weekday → Bool :=
  fun
    | monday => true
    | _      => false

#eval isMonday monday
#eval isMonday sunday

-- type classes:
-- polymorphic methods:

-- `toString` (method): converts values to string
#eval toString 10
#eval toString (10, 20)

-- `toString` (method) conevrts values of any type that implements `ToString` (class)
-- `instance ... where`: instance: specific realization of any object
instance : ToString Weekday where
  toString (d : Weekday) : String :=
    match d with
    | sunday    => "Sunday"
    | monday    => "Monday"
    | tuesday   => "Tuesday"
    | wednesday => "Wednesday"
    | thursday  => "Thursday"
    | friday    => "Friday"
    | saturday  => "Saturday"

#eval toString (sunday, 10)

-- more matching example
def Weekday.next (d : Weekday) : Weekday :=
  match d with
  | sunday    => monday
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => saturday
  | saturday  => sunday

#eval Weekday.next Weekday.wednesday
-- or use `open`
#eval next wednesday

-- alternatively, use sugar syntax - no need for `instance`, `match`
def Weekday.previous : Weekday -> Weekday
  | sunday    => saturday
  | monday    => sunday
  | tuesday   => monday
  | wednesday => tuesday
  | thursday  => wednesday
  | friday    => thursday
  | saturday  => friday

#eval next (previous wednesday)

-- associated theorem + more complex matching: prove that for any `Weekday` `d`, `next (previous d) = d`
theorem Weekday.nextOfPrevious (d : Weekday) : next (previous d) = d :=
  match d with
  | sunday    => rfl
  | monday    => rfl
  | tuesday   => rfl
  | wednesday => rfl
  | thursday  => rfl
  | friday    => rfl
  | saturday  => rfl

-- metaprogramming (or "tactics") for theorems, rather than writing everything out
-- `cases`: proof by case distinction
theorem Weekday.nextOfPrevious' (d : Weekday) : next (previous d) = d := by
  cases d       -- A proof by case distinction
  all_goals rfl  -- Each case is solved using `rfl`


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

import set_theory.ordinal.arithmetic

/-!
# Cantor Normal Form

The Cantor normal form of an ordinal is generally defined as its base `ω` expansion, with its
non-zero exponents in decreasing order. Here, we more generally define a base `b` expansion
`ordinal.CNF` in this manner, for any `b ≥ 2`.

# Todo

- Add API for the coefficients of the Cantor normal form.
- Prove the basic results relating the CNF to the arithmetic operations on ordinals.
-/

noncomputable theory

universe u

open order

namespace ordinal

/-- Proving properties of ordinals by induction over their Cantor normal form. -/
@[elab_as_eliminator] noncomputable def CNF_rec {b : ordinal} (b0 : b ≠ 0)
  {C : ordinal → Sort*} (H0 : C 0) (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : ∀ o, C o
| o :=
  if o0 : o = 0 then by rwa o0 else
  have _, from mod_opow_log_lt_self b0 o0,
  H o o0 (CNF_rec (o % b ^ log b o))
using_well_founded {dec_tac := `[assumption]}

@[simp] theorem CNF_rec_zero {b} (b0) {C H0 H} : @CNF_rec b b0 C H0 H 0 = H0 :=
by rw [CNF_rec, dif_pos rfl]; refl

@[simp] theorem CNF_rec_ne_zero {b} (b0) {C H0 H o} (o0) :
  @CNF_rec b b0 C H0 H o = H o o0 (@CNF_rec b b0 C H0 H _) :=
by rw [CNF_rec, dif_neg o0]

/-- The Cantor normal form of an ordinal `o` is the list of coefficients and exponents in the
    base-`b` expansion of `o`.

    `CNF b (b ^ u₁ * v₁ + b ^ u₂ * v₂) = [(u₁, v₁), (u₂, v₂)]` -/
def CNF (b o : ordinal) : list (ordinal × ordinal) :=
if b0 : b = 0 then [] else
CNF_rec b0 [] (λ o o0 IH, (log b o, o / b ^ log b o) :: IH) o

@[simp] theorem zero_CNF (o) : CNF 0 o = [] :=
dif_pos rfl

@[simp] theorem CNF_zero (b) : CNF b 0 = [] :=
if b0 : b = 0 then dif_pos b0 else (dif_neg b0).trans $ CNF_rec_zero _

theorem CNF_ne_zero {b o : ordinal} (b0 : b ≠ 0) (o0 : o ≠ 0) :
  CNF b o = (log b o, o / b ^ log b o) :: CNF b (o % b ^ log b o) :=
by unfold CNF; rw [dif_neg b0, dif_neg b0, CNF_rec_ne_zero b0 o0]

@[simp] theorem one_CNF {o : ordinal} (o0 : o ≠ 0) : CNF 1 o = [(0, o)] :=
by rw [CNF_ne_zero ordinal.one_ne_zero o0, log_of_not_one_lt_left (irrefl _), opow_zero, mod_one,
       CNF_zero, div_one]

theorem CNF_foldr {b : ordinal} (b0 : b ≠ 0) (o) :
  (CNF b o).foldr (λ p r, b ^ p.1 * p.2 + r) 0 = o :=
CNF_rec b0 (by rw CNF_zero; refl)
  (λ o o0 IH, by rw [CNF_ne_zero b0 o0, list.foldr_cons, IH, div_add_mod]) o

/-- This theorem exists to factor out commonalities between the proofs of `ordinal.CNF_pairwise` and
`ordinal.CNF_fst_le_log`. -/
private theorem CNF_pairwise_aux (b o : ordinal.{u}) :
  (∀ p : ordinal × ordinal, p ∈ CNF b o → p.1 ≤ log b o) ∧ (CNF b o).pairwise (λ p q, q.1 < p.1) :=
begin
  by_cases b0 : b = 0,
  { simp only [b0, zero_CNF, list.pairwise.nil, and_true], exact λ _, false.elim },
  cases lt_or_eq_of_le (one_le_iff_ne_zero.2 b0) with b1 b1,
  { refine CNF_rec b0 _ _ o,
    { simp only [CNF_zero, list.pairwise.nil, and_true], exact λ _, false.elim },
    intros o o0 IH, cases IH with IH₁ IH₂,
    simp only [CNF_ne_zero b0 o0, list.forall_mem_cons, list.pairwise_cons, IH₂, and_true],
    refine ⟨⟨le_rfl, λ p m, _⟩, λ p m, _⟩,
    { exact (IH₁ p m).trans (log_mono_right _ $ le_of_lt $ mod_opow_log_lt_self b0 o0) },
    { refine (IH₁ p m).trans_lt ((lt_opow_iff_log_lt b1 _).1 _),
      { rw ordinal.pos_iff_ne_zero, intro e,
        rw e at m, simpa only [CNF_zero] using m },
      { exact mod_lt _ (opow_ne_zero _ b0) } } },
  { by_cases o0 : o = 0,
    { simp only [o0, CNF_zero, list.pairwise.nil, and_true], exact λ _, false.elim },
    rw [← b1, one_CNF o0],
    simp only [list.mem_singleton, log_one_left, forall_eq, le_refl, true_and,
      list.pairwise_singleton] }
end

theorem CNF_pairwise (b o : ordinal.{u}) :
  (CNF b o).pairwise (λ p q : ordinal × ordinal, q.1 < p.1) :=
(CNF_pairwise_aux _ _).2

theorem CNF_fst_le_log {b o : ordinal.{u}} :
  ∀ {p : ordinal × ordinal}, p ∈ CNF b o → p.1 ≤ log b o :=
(CNF_pairwise_aux _ _).1

theorem CNF_fst_le {b o : ordinal.{u}} {p : ordinal × ordinal} (hp : p ∈ CNF b o) : p.1 ≤ o :=
(CNF_fst_le_log hp).trans (log_le_self _ _)

/-- This theorem exists to factor out commonalities between the proofs of `ordinal.CNF_snd_lt` and
`ordinal.CNF_lt_snd`. -/
private theorem CNF_snd_lt_aux {b o : ordinal.{u}} (b1 : 1 < b) :
  ∀ {p : ordinal × ordinal}, p ∈ CNF b o → p.2 < b ∧ 0 < p.2 :=
begin
  have b0 := (zero_lt_one.trans b1).ne',
  refine CNF_rec b0 (λ _, by { rw CNF_zero, exact false.elim }) (λ o o0 IH, _) o,
  simp only [CNF_ne_zero b0 o0, list.mem_cons_iff, forall_eq_or_imp, iff_true_intro @IH, and_true],
  nth_rewrite 1 ←@succ_le_iff,
  rw [div_lt (opow_ne_zero _ b0), ←opow_succ, le_div (opow_ne_zero _ b0), succ_zero, mul_one],
  refine ⟨lt_opow_succ_log_self b1 _, opow_log_le_self _ _⟩,
  rwa ordinal.pos_iff_ne_zero
end

theorem CNF_snd_lt {b o : ordinal.{u}} (b1 : 1 < b) {p : ordinal × ordinal} (hp : p ∈ CNF b o) :
  p.2 < b :=
(CNF_snd_lt_aux b1 hp).1

theorem CNF_lt_snd {b o : ordinal.{u}} (b1 : 1 < b) {p : ordinal × ordinal} (hp : p ∈ CNF b o) :
  0 < p.2 :=
(CNF_snd_lt_aux b1 hp).2

theorem CNF_sorted (b o : ordinal) : ((CNF b o).map prod.fst).sorted (>) :=
by { rw [list.sorted, list.pairwise_map], exact CNF_pairwise b o }

end ordinal


import tactic.basic
import .ch02_induction
import .ch03_lists
import .ch04_poly

open basics (evenb oddb sub_two eqb)
open induction (double)
open lists (eqb_id)
open poly (split combine)
open poly.list (length filter)
open nat (
  succ add_one add_succ succ_add le_of_succ_le_succ succ_le_succ
  decidable_le
)

namespace tactics

variables {α β γ : Type}
variables (b : bool)
variables (n m o p : ℕ)

/-
Theorem silly1 : ∀(n m o p : nat),
     n = m →
     [n;o] = [n;p] →
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2. Qed.
-/

theorem silly₁ (eq₁ : n = m) (eq₂ : [n, o] = [n, p])
  : [n, o] = [m, p] :=
begin
  rw ←eq₁,
  apply eq₂,
end

/-
Theorem silly2 : ∀(n m o p : nat),
     n = m →
     (∀(q r : nat), q = r → [q;o] = [r;p]) →
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1. Qed.
-/

theorem silly₂
  (eq₁ : n = m)
  (eq₂ : ∀ q r : ℕ, q = r → [q, o] = [r, p])
  : [n, o] = [m, p] :=
begin
  apply eq₂,
  apply eq₁,
end

/-
Theorem silly2a : ∀(n m : nat),
     (n,n) = (m,m) →
     (∀(q r : nat), (q,q) = (r,r) → [q] = [r]) →
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1. Qed.
-/

theorem silly₂a
  (eq₁ : (n, n) = (m, m))
  (eq₂ : ∀ q r : ℕ, (q, q) = (r, r) → [q] = [r]) : [n] = [m] :=
begin
  apply eq₂,
  apply eq₁,
end

/-
Theorem silly_ex :
     (∀n, evenb n = true → oddb (S n) = true) →
     oddb 3 = true →
     evenb 4 = true.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem silly_ex
  (h : evenb n = tt → oddb n.succ = tt)
  (v : oddb 3 = tt)
  : evenb 4 = tt := rfl

/-
Theorem silly3_firsttry : ∀(n : nat),
     true = (n =? 5) →
     (S (S n)) =? 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H. Qed.
-/

theorem silly₃_firsttry (h: tt = (n =? 5)) :
  n.succ.succ =? 7 = tt :=
begin
  symmetry,
  apply h,
end

/-
Theorem rev_exercise1 : ∀(l l' : list nat),
     l = rev l' →
     l' = rev l.
Proof.
  (* FILL IN HERE *) Admitted.
-/

/-
  also, lean doesn't appear to have any relevant lemmas
-/

/-
using poly.list as we already proved the relevant lemma,
and doing this with the library version is unpleasant,
and unnecessary given the goal of this exercise
-/
theorem rev_exercise₁ (l l' : poly.list ℕ) (h: l = l'.reverse)
  : l' = l.reverse :=
begin
  rw h,
  symmetry,
  apply poly.reverse_involutive,
end

/-
Example trans_eq_example : ∀(a b c d e f : nat),
     [a;b] = [c;d] →
     [c;d] = [e;f] →
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite → eq1. rewrite → eq2. reflexivity. Qed.
-/

example
  (a b c d e f : ℕ)
  (eq1 : [a, b] = [c, d])
  (eq2 : [c, d] = [e, f])
  : [a, b] = [e, f] :=
begin
  rw eq1,
  rw eq2,
end

/-
Theorem trans_eq : ∀(X:Type) (n m o : X),
  n = m → m = o → n = o.
Proof.
  intros X n m o eq1 eq2. rewrite → eq1. rewrite → eq2.
  reflexivity. Qed.
-/

theorem eq.trans
  (n m o : α)
  (eq1 : n = m)
  (eq2 : m = o) : n = o := by rw [eq1, eq2]

/-
Example trans_eq_example' : ∀(a b c d e f : nat),
     [a;b] = [c;d] →
     [c;d] = [e;f] →
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with (m:=[c;d]).
  apply eq1. apply eq2. Qed.
-/

/-
TODO: figure out if there's similar notation
      applying eq1 solves the metavariable in lean
-/
example
  (a b c d e f : ℕ)
  (eq₁ : [a, b] = [c, d])
  (eq₂ : [c, d] = [e, f]) : [a, b] = [e, f] :=
begin
  apply eq.trans,
  apply eq₁,
  apply eq₂,
end

/-
Example trans_eq_exercise : ∀(n m o p : nat),
     m = (minustwo o) →
     (n + p) = m →
     (n + p) = (minustwo o).
Proof.
  (* FILL IN HERE *) Admitted.
-/

/- no clue why this is 3 stars-/
example
  (eq₁ : m = sub_two o)
  (eq₂ : n + p = m) : (n + p) = (sub_two o) :=
begin
  apply eq.trans,
  apply eq₂,
  apply eq₁,
end

/-
Theorem S_injective : ∀(n m : nat),
  S n = S m →
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.
-/

/-
TODO: is there a rw that's better at finishing?
-/
theorem succ_inj (h₁ : n.succ = m.succ) : n = m :=
begin
  have h₂ : n = n.succ.pred, refl,
  rw h₂,
  rw h₁,
  refl,
end

/-
Theorem S_injective' : ∀(n m : nat),
  S n = S m →
  n = m.
Proof.
  intros n m H.
  injection H. intros Hnm. apply Hnm.
Qed.
-/

/- back to lean doing just a bit extra -/
theorem succ_inj' (h : n.succ = m.succ) : n = m := by injection h

/-
Theorem injection_ex1 : ∀(n m o : nat),
  [n; m] = [o; o] →
  [n] = [m].
Proof.
  intros n m o H.
  injection H. intros H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.
-/

theorem injection_ex₁ (h : [n, m] = [o, o]) : [n] = [m] :=
begin
  injection h with h₁ h₂,
  rw h₁,
  rw h₂,
end

/-
Theorem injection_ex2 : ∀(n m : nat),
  [n] = [m] →
  n = m.
Proof.
  intros n m H.
  injection H as Hnm. rewrite Hnm.
  reflexivity. Qed.
-/

theorem injection_ex₂ (h : [n] = [m]) : n = m := by injection h

/-
Example injection_ex3 : ∀(X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j →
  y :: l = x :: j →
  x = y.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem injection_ex₃
  (x y z : α) (l j : list α)
  (eq₁ : x :: y :: l = z :: j)
  (eq₂ : y :: l = x :: j) : x = y :=
begin
  injection eq₂ with h₁ h₂,
  rw h₁,
end

/-
Theorem eqb_0_l : ∀n,
   0 =? n = true → n = 0.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.
  - (* n = S n' *)
    simpl.
    intros H. discriminate H.
Qed.
-/

/-
not the last time cases will subsume another tactic
TODO: check earlier usages of cases to see if i already used it like this
-/

theorem eqb_0_l (h: 0 =? n = tt) : n = 0 :=
begin
  cases n,
    refl,
  cases h,
end

/-
Theorem discriminate_ex1 : ∀(n : nat),
  S n = O →
  2 + 2 = 5.
Proof.
  intros n contra. discriminate contra. Qed.

Theorem discriminate_ex2 : ∀(n m : nat),
  false = true →
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.
-/

theorem discriminate_ex₁ (h : n.succ = 0) : 2 + 2 = 5 := by cases h

theorem discriminate_ex₂ (n m : ℕ) (h : ff = tt) : [n] = [m] := by cases h

/-
Example discriminate_ex3 :
  ∀(X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] →
    x = z.
Proof.
  (* FILL IN HERE *) Admitted.
-/

example (x y z : α) (l j : list α) (h : x :: y :: l = []) : x = z := by cases h

/-
Theorem S_inj : ∀(n m : nat) (b : bool),
     (S n) =? (S m) = b →
     n =? m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.
-/

/-
this is the first place with in/at?!?!?!
(and i don't even use it here)
-/
theorem succ_injb (h : n.succ =? m.succ = b) : n =? m = b := by apply h

/-
Theorem silly3' : ∀(n : nat),
  (n =? 5 = true → (S (S n)) =? 7 = true) →
  true = (n =? 5) →
  true = ((S (S n)) =? 7).
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.
-/

/-
lean doesn't have symmetry at or apply at.
let's learn replace and specialize instead
-/
theorem silly₃'
  (heq : n =? 5 = tt → n.succ.succ =? 7 = tt)
  (h : tt = (n =? 5)) : tt = (n.succ.succ =? 7) :=
begin
  replace h, exact eq.symm h,
  specialize heq h,
  replace h, exact eq.symm h,
  apply h,
end

/-
Theorem plus_n_n_injective : ∀n m,
     n + n = m + m →
     n = m.
Proof.
  intros n. induction n as [| n'].
  (* FILL IN HERE *) Admitted.
-/

/- in library as bit0_inj -/
theorem add_self_inj : ∀{n m : ℕ}, n + n = m + m → n = m :=
begin
  intro n,
  induction n with n ih,
    intro m,
    cases m,
      intro h,
      refl,
    intro h,
    cases h,
  intro m,
  cases m,
    intro h,
    cases h,
  intro h,
  rw [succ_add, succ_add, add_succ, add_succ] at h,
  injection h with h,
  injection h with h,
  rw ih h,
end

/-
  leaving for posterity
  this was way easier to write
-/
theorem add_self_inj' : ∀{n m : ℕ}, n + n = m + m → n = m
| 0 0 := by intro; refl
| 0 (m + 1) := by contradiction
| (n + 1) 0 := by contradiction
| (n + 1) (m + 1) :=
begin
  intro h,
  simp only [add_succ, succ_add, add_zero] at h,
  rw add_self_inj' h,
end

/- this section really really needs to come before the last problem -/

/-
Theorem double_injective_FAILED : ∀n m,
     double n = double m →
     n = m.
Proof.
  intros n m. induction n as [| n'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) discriminate eq.
    + (* m = S m' *) apply f_equal.
Abort.
-/

-- theorem double_injective_FAILED
--   (n m : ℕ) : double n = m → n = m :=
-- begin
--   induction n with n ihn,
--     simp,
--     intro eq,
--     cases m,
--       refl,
--     contradiction,
--   intro eq,
--   cases m,
--     contradiction,
--   apply congr_arg, /- coq's f_equal -/
--   -- abort --
-- end

/-
Theorem double_injective : ∀n m,
     double n = double m →
     n = m.
Proof.
  intros n. induction n as [| n'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) simpl.
    intros m eq.
    destruct m as [| m'] eqn:E.
    + (* m = O *) simpl.
      discriminate eq.
    + (* m = S m' *)
      apply f_equal.
      apply IHn'. injection eq as goal. apply goal. Qed.
-/

theorem double_injective (n m : ℕ)
  : double n = double m → n = m :=
begin
  -- gains nothing over having the nats on the right
  -- and using intro n, but what the heck
  revert m,
  induction n with n ihn,
    intros m eq,
    cases m,
      refl,
    contradiction,
  intros m eq,
  cases m,
    contradiction,
  apply congr_arg,
  apply ihn,
  injection eq with goal,
  injection goal
end

/-
Theorem eqb_true : ∀n m,
    n =? m = true → n = m.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem eqb_true : ∀ n m : ℕ, n =? m = tt → n = m :=
begin
  intro n,
  induction n with n ih,
    intros m eq,
    cases m,
      refl,
    contradiction,
  intros m eq,
  cases m,
    contradiction,
  simp at *,
  apply ih,
  exact eq
end

/-
Theorem double_injective_take2_FAILED : ∀n m,
     double n = double m →
     n = m.
Proof.
  intros n m. induction m as [| m'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
        (* Stuck again here, just like before. *)
Abort.
-/

-- theorem double_injective_take2_FAILED
--   (n m : ℕ) : double n = double m → n = m :=
-- begin
--   induction m,
--     simp,
--     intro eq,
--     cases n,
--       refl,
--     contradiction,
--   intro eq,
--   cases n,
--     contradiction,
--   apply congr_arg,
--   /- abort -/
-- end

/-
Theorem double_injective_take2 : ∀n m,
     double n = double m →
     n = m.
Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* Now n is back in the goal and we can do induction on
     m and get a sufficiently general IH. *)
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed.
-/

theorem double_injective_take₂ (eq : double n = double m) : n = m :=
begin
  -- could also use revert before the induction
  -- and intros after
  induction m with m ih generalizing n eq,
    cases n,
      refl,
    cases eq,
  cases n,
    cases eq,
  simp,
  apply ih,
  injection eq with goal,
  injection goal,
end

/-
Theorem eqb_id_true : ∀x y,
  eqb_id x y = true → x = y.
Proof.
  intros [m] [n]. simpl. intros H.
  assert (H' : m = n). { apply eqb_true. apply H. }
  rewrite H'. reflexivity.
Qed.
-/

/-
congr is like injection but for the goal
-/

theorem eqb_id_true : ∀x y, eqb_id x y = tt → x = y :=
begin
  rintro ⟨m⟩ ⟨n⟩ h,
  congr,
  apply eqb_true,
  apply h,
end

/-
Theorem nth_error_after_last: ∀(n : nat) (X : Type) (l : list X),
     length l = n →
     nth_error l n = None.
Proof.
  (* FILL IN HERE *) Admitted.
-/

/- lean's nth should be the same as coq's nth_error -/
theorem nth_error_after_last (l : list α) (h : l.length = n) : l.nth n = none :=
begin
  induction n with n ih generalizing l h,
    cases l with a l,
      refl,
    cases h,
  cases l with a l,
    cases h,
  apply ih,
  injection h,
end

/-
Definition square n := n * n.

Lemma square_mult : ∀n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.
  unfold square.
  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.
-/

/-
TODO: figure out best place to introduce typeclass stuff
-/
def square [has_mul α] (n : α) := n * n

/-
Lemma square_mult : ∀n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.
  unfold square.
  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.
-/

/-
TODO: i've been using rw for this. should i use dsimp earlier?
TODO: figure out if this is the right spot to intro calc
TODO: find the right place to intro conv
-/
lemma square_mult : square (n * m) = square n * square m :=
begin
  unfold square,
  exact calc
    n * m * (n * m) = n * (m * n * m) : by rw [mul_assoc, mul_assoc]
    ...             = n * (n * m * m) : by rw mul_comm n m
    ...             = n * n * m * m   : by rw [←mul_assoc, ←mul_assoc]
    ...             = n * n * (m * m) : by rw mul_assoc,
end

/-
Definition foo (x: nat) := 5.
-/

def foo (x : ℕ) := 5

/-
Fact silly_fact_1 : ∀m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.
-/

/-
  this is not at all true in lean.
  lean requires either a simp attribute
  or explicitly adding as an arg to simp

  reflexivity is much more aggressive
-/
lemma silly_fact_1 : foo m + 1 = foo (m + 1) + 1 := rfl

section silly

local attribute [simp] foo

lemma silly_fact_1' : foo m + 1 = foo (m + 1) + 1 := by simp

end silly

/-
Definition bar x :=
  match x with
  | O ⇒ 5
  | S _ ⇒ 5
  end.
-/

/--
unfold and simp have serious issues with placeholders
instead of explicit constructors
refl has no such problem
if lean 3 wasn't dead, i'd be filing an issue
-/
def bar : ℕ → ℕ
| 0 := 5
| (succ _) := 5

/-
Fact silly_fact_2_FAILED : ∀m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* Does nothing! *)
Abort.
-/

-- lemma silly_fact_2_FAILED : bar m + 1 = bar (m + 1) + 1 :=
-- begin
--   simp [bar],
-- end

/-
Fact silly_fact_2 : ∀m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
-/

lemma silly_fact_2 : bar m + 1 = bar (m + 1) + 1 :=
begin
  cases m,
    refl,
  refl,
end

/-
Fact silly_fact_2' : ∀m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed.
-/

/-
unfold in lean doesn't unfold to a match statement
-/
lemma silly_fact_2' : bar m + 1 = bar (m + 1) + 1 :=
begin
  unfold bar,
  cases m,
    refl,
  refl,
end

/-
Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.

Theorem sillyfun_false : ∀(n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n =? 3) eqn:E1.
    - (* n =? 3 = true *) reflexivity.
    - (* n =? 3 = false *) destruct (n =? 5) eqn:E2.
      + (* n =? 5 = true *) reflexivity.
      + (* n =? 5 = false *) reflexivity. Qed.
-/

def sillyfun : bool :=
  if n =? 3 then ff
  else if n =? 5 then ff
  else ff

theorem sillyfun_false : sillyfun n = ff :=
begin
  unfold sillyfun,
  cases n =? 3,
  case tt : { refl }, /- messing around to reduce nesting -/
  cases n =? 5,
    refl,
  refl,
end

/-
Theorem combine_split : ∀X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) →
  combine l1 l2 = l.
Proof.
  (* FILL IN HERE *) Admitted.
-/

/-
TODO: look for something simpler
-/

section split

/-
using poly.list and notation since that's what split
and combine were defined with
-/
local notation `[]` := poly.list.nil
local infix :: := poly.list.cons
local notation {x, y} := poly.prod.mk x y
local infix × := poly.prod

/-
injections is a recursive injection at all hypotheses
changes is show for hypotheses
-/
lemma split_injective
  {h : α × β} {t h₁ t₁ h₂ t₂}
  (eq : split (h::t) = {h₁::t₁, h₂::t₂}) :
  {h₁, h₂} = h ∧ split t = {t₁, t₂} :=
begin
  rw split at eq,
  injections with eq₁ eq₂ eq₃ eq₄ eq₅ eq₆,
  change (split t).fst = t₁ at eq₄,
  change (split t).snd = t₂ at eq₆,
  cases h with h₁' h₂',
  constructor,
    rw [←eq₃, ←eq₅],
  cases (split t) with t₁' t₂',
  cases eq₄,
  cases eq₆,
  refl,
end

theorem combine_split :
  ∀{l : poly.list (α × β)} {l₁ l₂} (hs : split l = {l₁, l₂}),
  combine l₁ l₂ = l
| [] [] [] hs := rfl
| (h::t) [] _ hs := by cases hs
| (h::t) _ [] hs := by cases hs
| [] (h₁::t₁) _ hs := by cases hs
| [] _ (h₂::t₂) hs := by cases hs
| (h::t) (h₁::t₁) (h₂::t₂) hs :=
begin
  have, exact split_injective hs,
  rw combine,
  congr,
    exact this.left,
  exact combine_split this.right,
end

end split

/-
Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
  else false.
-/

def sillyfun₁ : bool :=
  if n =? 3 then tt
  else if n =? 5 then tt
  else ff

/-
Theorem sillyfun1_odd_FAILED : ∀(n : nat),
     sillyfun1 n = true →
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3).
  (* stuck... *)
Abort.
-/

-- theorem sillyfun₁_odd_FAILED (eq : sillyfun₁ n = tt) : oddb n = tt :=
-- begin
--   unfold sillyfun₁ at eq,
--   cases (n =? 3),
--   /- stuck -/
-- end
/-
Theorem sillyfun1_odd : ∀(n : nat),
     sillyfun1 n = true →
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra
     equality assumption, which is exactly what we need to
     make progress. *)
    - (* e3 = true *) apply eqb_true in Heqe3.
      rewrite → Heqe3. reflexivity.
    - (* e3 = false *)
     (* When we come to the second equality test in the body
        of the function we are reasoning about, we can use
        eqn: again in the same way, allowing us to finish the
        proof. *)
      destruct (n =? 5) eqn:Heqe5.
        + (* e5 = true *)
          apply eqb_true in Heqe5.
          rewrite → Heqe5. reflexivity.
        + (* e5 = false *) discriminate eq. Qed.
-/

/- lean's case equation does less rewriting than coq's -/
theorem sillyfun₁_odd (eq : sillyfun₁ n = tt) : oddb n = tt :=
begin
  unfold sillyfun₁ at eq,
  cases heqe3 : (n =? 3),
    rw heqe3 at eq,
    cases heqe5 : (n =? 5),
      rw heqe5 at eq,
      cases eq,
    rw eqb_true n 5 heqe5,
    refl,
  rw eqb_true n 3 heqe3,
  refl,
end

/-
Theorem bool_fn_applied_thrice :
  ∀(f : bool → bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem bool_fn_applied_thrice (f: bool → bool) : f (f (f b)) = f b :=
begin
  cases fb : f b,
    cases bb : b,
      rw bb at fb,
      rw [fb, fb],
    cases ff : f ff,
      exact ff,
    rw bb at fb,
    exact fb,
  cases bb : b,
    cases ft : f tt,
      rw bb at fb,
      exact fb,
    exact ft,
  rw bb at fb,
  rw [fb, fb],
end

/-
Theorem eqb_sym : ∀(n m : nat),
  (n =? m) = (m =? n).
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem eqb_sym : ∀n m : ℕ, (n =? m) = (m =? n)
| 0 0 := rfl
| 0 (m + 1) := rfl
| (n + 1) 0 := rfl
| (n + 1) (m + 1) := eqb_sym n m

/-
Theorem eqb_trans : ∀n m p,
  n =? m = true →
  m =? p = true →
  n =? p = true.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem eqb_trans : ∀n m p : ℕ, n =? m = tt → m =? p = tt → n =? p = tt
| 0 0 0 hn hm := rfl
| 0 (m + 1) _ hn hm := by cases hn
| (n + 1) 0 _ hn hm := by cases hn
| _ 0 (p + 1) hn hm := by cases hm
| _ (m + 1) 0 hn hm := by cases hm
| (n + 1) (m + 1) (p + 1) hn hm := eqb_trans n m p hn hm

/-
Definition split_combine_statement : Prop
  (* (": Prop" means that we are giving a name to a
     logical proposition here.) *)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
Theorem split_combine : split_combine_statement.
Proof.
(* FILL IN HERE *) Admitted.
-/

/-
TODO: this is horrible
could try cleaning it up, but i'm confident that the approach is wrong
-/

section poly

/-
using poly.list and notation since that's what split
and combine were defined with
-/
local notation `[]` := poly.list.nil
local infix :: := poly.list.cons
local notation {x, y} := poly.prod.mk x y
local infix × := poly.prod

lemma min_succ : min (succ m) (succ n) = min m n + 1 :=
begin
  have : (succ m) ≤ (succ n) ↔ m ≤ n,
    constructor,
      exact le_of_succ_le_succ,
    exact succ_le_succ,
  rw [min, min],
  simp only [this], /- no idea why i can't rw this -/
  cases decidable_le m n,
    simp only [h], /- also not sure how to plug this in -/
    rw [if_false, if_false],
  simp only [h],
  rw [if_true, if_true],
end

lemma combine_len  :
  ∀(l₁ : poly.list α) (l₂ : poly.list β),
  (combine l₁ l₂).length = min l₁.length l₂.length
| [] [] := rfl
| (h::t) [] := rfl
| [] (h::t) := rfl
| (h₁::t₁) (h₂::t₂) :=
begin
  unfold combine length,
  rw min_succ,
  congr,
  exact combine_len t₁ t₂,
end

theorem split_combine :
  ∀{l : poly.list (α × β)} {l₁ l₂}
  (hc : combine l₁ l₂ = l)
  (hl : l₁.length = l₂.length),
  split l = {l₁, l₂}
| [] [] [] hc hl := rfl
| (h::t) [] l₂ hc hl := by cases hc
| (h::t) (h₁::t₁) [] hc hl := by cases hc
| [] (h₁::t₁) l₂ hc hl :=
begin
  replace hc, exact congr_arg length hc,
  have hc' : (combine (h₁::t₁) l₂).length = (h₁::t₁).length,
    rw combine_len (h₁::t₁) l₂,
    rw ←hl,
    rw min_self,
  rw hc' at hc,
  cases hc,
end
| [] l₁ (h₂::t₂) hc hl :=
begin
  replace hc, exact congr_arg length hc,
  have hc' : (combine l₁ (h₂::t₂)).length = (h₂::t₂).length,
    rw combine_len l₁ (h₂::t₂),
    rw ←hl,
    rw min_self,
  rw hc' at hc,
  cases hc,
end
| (h::t) (h₁::t₁) (h₂::t₂) hc hl :=
begin
  injection hl with hl,
  simp only [combine] at hc,
  unfold split,
  congr,
        rw ←hc.left,
      show (split t).fst = t₁,
      rw split_combine hc.right hl,
    rw ←hc.left,
  show (split t).snd = t₂,
  rw split_combine hc.right hl,
end

/-
Theorem filter_exercise : ∀(X : Type) (test : X → bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf →
     test x = true.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem filter_exercise {test} {a : α} :
  ∀{l lf} (eq : filter test l = a :: lf), test a = tt
| [] :=
begin
  intros,
  cases eq,
end
| (h::t) :=
begin
  intros,
  rw filter at eq,
  cases th : test h,
    simp only [th, bool.coe_sort_ff, if_false] at eq,
    exact filter_exercise eq,
  simp only [th, bool.coe_sort_tt, if_true] at eq,
  rwa eq.left at th,
end

end poly

/-
Fixpoint forallb {X : Type} (test : X → bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. (* FILL IN HERE *) Admitted.

Fixpoint existsb {X : Type} (test : X → bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_4 : existsb evenb [] = false.
Proof. (* FILL IN HERE *) Admitted.

Definition existsb' {X : Type} (test : X → bool) (l : list X) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem existsb_existsb' : ∀(X : Type) (test : X → bool) (l : list X),
  existsb test l = existsb' test l.
Proof. (* FILL IN HERE *) Admitted.
-/

def all : list α → (α → bool) → bool
| [] p := tt
| (h::t) p := if p h then all t p else ff

example : all [1, 3, 5, 7, 9] oddb := rfl

example : all [ff, ff] bnot := rfl

example : all [0, 2, 4, 5] evenb = ff := rfl

example : all [] (eqb 5) := rfl

def any : list α → (α → bool) → bool
| [] p := ff
| (h::t) p := if p h then tt else any t p

example : any [0, 2, 4, 6] (eqb 5) = ff := rfl

example : any [tt, tt, ff] (band tt) := rfl

example : any [1, 0, 0, 0, 0, 3] oddb := rfl

example : any [] evenb = ff := rfl

def any' (l : list α) (p : α → bool) : bool := bnot $ all l (bnot ∘ p)

theorem existsb_existsb' (p) (l : list α) : any l p = any' l p :=
begin
  induction l with a l ih,
    refl,
  cases pa : p a,
    simp only [any, any', all, function.comp_app],
    simp only [pa],
    simp only [
      bool.coe_sort_ff, bool.bnot_false, if_false, if_true, bool.coe_sort_tt
    ],
    exact ih,
  simp only [any, any', all, function.comp_app],
  simp only [pa],
  simp only [
    bool.coe_sort_ff, bool.bnot_false, if_false, if_true,
    bool.coe_sort_tt, bool.bnot_true
  ],
end

end tactics


import for_mathlib.mod_forms2
import number_theory.modular
import mod_forms.general_q_expansions.q_expansion

/-! **Bounds for the integrand of the Petersson product**

The main result here is that if f is a cusp form of level 1, then
`abs (f z) ^ 2 * (im z) ^ k` is uniformly bounded on the upper half-plane.

FIXME : The code here depends on a couple of lemmas at the end of `mod_forms2.lean`, which ought
to be trivial but are gnarly because of the coercion issues around SL2Z actions. For some reason
that code stops working if I transplant it to this file. -/

open modular_form complex filter asymptotics
open_locale real topology manifold filter modular_form

noncomputable theory

local notation `ℍ` := upper_half_plane
local notation `SL(` n `, ` R `)`:= matrix.special_linear_group (fin n) R

/-- The Petersson function of a cuspform is continuous. -/
lemma pet_cts  {k : ℤ} (f : cusp_form ⊤ k) : continuous (pet_self f k) :=
begin
  apply continuous.mul,
  { continuity,
    exact f.holo'.continuous },
  { simp_rw upper_half_plane.im, continuity, exact or.inl a.2.ne',}
end

/-- The image of a trunction of the fundamental domain, under the inclusion `ℍ → ℂ`, defined by `≤`
inequalities (so it will be a closed subset of `ℂ`). -/
lemma image_fd (A : ℝ) : ( coe '' { x : ℍ | x ∈ modular_group.fd ∧ x.im ≤ A} : set ℂ) =
  { x : ℂ | (0 ≤ x.im) ∧ (|x.re| ≤ 1/2) ∧ (1 ≤ abs x) ∧ (im x ≤ A)} :=
begin
  ext1 z, rw modular_group.fd, dsimp,
  split,
  { intro hz,
    obtain ⟨x, ⟨⟨hx1, hx2⟩, hx3⟩, hzx⟩ := hz,
    rw ←hzx,
    refine ⟨x.2.le, hx2, _, hx3⟩,
    rw [←one_le_sq_iff, ←norm_sq_eq_abs], exact hx1, apply complex.abs.nonneg, },
  { intro hz, obtain ⟨hz1, hz2, hz3, hz4⟩ := hz,
    rcases le_or_lt (im z) 0,
    -- This is a clumsy way of showing that im z = 0 leads to a contradiction.
    -- Todo: improve this by comparison with three_lt_four_mul_im_sq_of_mem_fdo in modular.lean.
    { have : im z = 0 := by linarith,
      have t := (one_le_sq_iff (complex.abs.nonneg _)).mpr hz3,
      rw ←norm_sq_eq_abs at t, rw norm_sq at t, simp only [monoid_with_zero_hom.coe_mk] at t,
      rw this at t, simp only [mul_zero, add_zero] at t,
      rw ←abs_mul_self at t, rw ←pow_two at t, rw _root_.abs_pow at t,
      have tt : |re z| ^ 2 ≤ (1 / 2) ^ 2,
      { rw sq_le_sq, rw _root_.abs_abs,
        have : 0 < (1/2 : ℝ) := by simp,
        conv begin to_rhs, rw abs_of_pos this, end,
        exact hz2, },
      have t3 := le_trans t tt, exfalso, field_simp at t3, rw le_one_div at t3,
      { simp at t3, linarith }, { linarith }, { linarith }, },
    -- Now the main argument.
    use ⟨z, h⟩, refine ⟨⟨⟨_, hz2⟩, hz4⟩, by simp⟩,
    rw norm_sq_eq_abs, rw one_le_sq_iff (complex.abs.nonneg _), exact hz3,
  }
end

/-- The standard fundamental domain, truncated at some finite height, is compact. -/
lemma compact_trunc_fd (A : ℝ) : is_compact {x : ℍ | x ∈ modular_group.fd ∧ x.im ≤ A} :=
begin
  rw [embedding_subtype_coe.is_compact_iff_is_compact_image, image_fd A],
  apply metric.is_compact_of_is_closed_bounded,
  { apply_rules [is_closed.inter],
    { apply is_closed_Ici.preimage continuous_im, },
    { have : continuous (λ u, |re u| : ℂ → ℝ) := by { continuity },
      refine is_closed.preimage this (@is_closed_Iic _ _ _ _ (1/2)) },
    { apply is_closed_Ici.preimage complex.continuous_abs, },
    { apply is_closed_Iic.preimage continuous_im, } },
  { rw bounded_iff_forall_norm_le, use real.sqrt (A ^ 2 + (1 / 2) ^ 2),
    intros x hx, rw set.mem_set_of_eq at hx,
    rw norm_eq_abs, rw complex.abs, apply real.le_sqrt_of_sq_le,
    simp,
    rw real.sq_sqrt (norm_sq_nonneg _),
    rw norm_sq, dsimp, rw add_comm, apply add_le_add,
    { rw ←pow_two, rw sq_le_sq, apply abs_le_abs,
      { exact hx.2.2.2 }, { exact le_trans (by linarith) (le_trans hx.1 hx.2.2.2), } },
    { rw ←pow_two, rw ←inv_pow, rw sq_le_sq,  rw inv_eq_one_div, apply abs_le_abs,
      { exact le_trans (le_abs_self (re x)) hx.2.1 },
      { exact le_trans (neg_le_abs_self (re x)) hx.2.1 } } }
end

/-- The Petersson function is bounded on the standard fundamental domain. -/
lemma pet_bound_on_fd {k : ℤ}  (f : cusp_form ⊤ k) :
  ∃ (C : ℝ), ∀ (z : ℍ), (z ∈ modular_group.fd) → |pet_self f k z| ≤ C :=
begin
  obtain ⟨A, C1, H1⟩ := pet_bounded_large f,
  have := (compact_trunc_fd A).exists_bound_of_continuous_on (pet_cts f).continuous_on,
  cases this with C2 H2, use max C1 C2, intros z hz,
  rcases le_or_lt (im z) A,
  { exact le_trans (H2 z ⟨hz, h⟩) (le_max_right _ _), },
  { convert le_trans (H1 z h.le) (le_max_left C1 C2),
    apply _root_.abs_of_nonneg,
    rw pet_self, apply mul_nonneg,
    { apply pow_nonneg, apply absolute_value.nonneg},
    { apply zpow_nonneg, exact z.2.le }, }
end

/-- The Petersson function is bounded everywhere. -/
theorem pet_bound {k : ℤ}   (f : cusp_form ⊤ k) :
  ∃ (C : ℝ), ∀ (z : ℍ), |pet_self f k z| ≤ C :=
begin
  obtain ⟨C, HC⟩ := pet_bound_on_fd f, use C, intro z,
  obtain ⟨g, hg⟩ := modular_group.exists_smul_mem_fd z,
  replace HC := HC (g • z) hg,
  have : pet_self f k (g • z) = pet_self f k z,
  { apply pet_self_is_invariant f.to_slash_invariant_form ,
    simp [g.2] },
  rwa this at HC
end


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import filter
import ring_seminorm

/-!
# seminorm_from_const

In this file, we prove [BGR, Proposition 1.3.2/2] : starting from a power-multiplicative seminorm
on a commutative ring `R` and a nonzero `c : R`, we create a new power-multiplicative seminorm for
which `c` is multiplicative.

## Main Definitions

* `seminorm_from_const'` : the real-valued function sending `x ∈ R` to the limit of
  `(f (x * c^n))/((f c)^n)`.
* `seminorm_from_const` : the function `seminorm_from_const'` is a `ring_seminorm` on `R`.

## Main Results
* `seminorm_from_const_is_nonarchimedean` : the function `seminorm_from_const' hf1 hc hpm`
  is nonarchimedean when f is nonarchimedean.
* `seminorm_from_const_is_pow_mul` : the function `seminorm_from_const' hf1 hc hpm`
  is power-multiplicative.
* `seminorm_from_const_c_is_mul` : for every `x : R`, `seminorm_from_const' hf1 hc hpm (c * x)`
  equals the product `seminorm_from_const' hf1 hc hpm c * seminorm_from_const' hf1 hc hpm x`.

## References
* [S. Bosch, U. Güntzer, R. Remmert, *Non-Archimedean Analysis*][bosch-guntzer-remmert]

## Tags

seminorm_from_const, seminorm, nonarchimedean
-/

noncomputable theory

open_locale topological_space

section ring

variables {R : Type*} [comm_ring R] (c : R) (f : ring_seminorm R) (hf1 : f 1 ≤ 1)
  (hc : 0 ≠ f c) (hpm : is_pow_mul f)

/-- For a ring seminorm `f` on `R` and `c ∈ R`, the sequence given by `(f (x * c^n))/((f c)^n)`. -/
def seminorm_from_const_seq (x : R) : ℕ → ℝ :=
λ n, (f (x * c^n))/((f c)^n)

/-- The terms in the sequence `seminorm_from_const_seq c f x` are nonnegative. -/
lemma seminorm_from_const_seq_nonneg (x : R) (n : ℕ) : 0 ≤ seminorm_from_const_seq c f x n :=
div_nonneg (map_nonneg f (x * c ^ n)) (pow_nonneg (map_nonneg f c) n)

/-- The image of `seminorm_from_const_seq c f x` is bounded below by zero. -/
lemma seminorm_from_const_is_bounded (x : R) :
  bdd_below (set.range (seminorm_from_const_seq c f x)) :=
begin
  use 0,
  rw mem_lower_bounds,
  intros r hr,
  obtain ⟨n, hn⟩ := hr,
  rw ← hn,
  exact seminorm_from_const_seq_nonneg c f x n,
end

variable {f}

/-- `seminorm_from_const_seq c f 0` is the constant sequence zero. -/
lemma seminorm_from_const_seq_zero (hf : f 0 = 0) :
  seminorm_from_const_seq c f 0 = 0 :=
begin
  simp only [seminorm_from_const_seq],
  ext n,
  rw [zero_mul, hf, zero_div],
  refl,
end

variable {c}

include hc hpm

/-- If `1 ≤ n`, then `seminorm_from_const_seq c f 1 n = 1`. -/
lemma seminorm_from_const_seq_one (n : ℕ) (hn : 1 ≤ n) :
  seminorm_from_const_seq c f 1 n = 1 :=
begin
  simp only [seminorm_from_const_seq],
  rw [one_mul, hpm _ hn, div_self (pow_ne_zero n (ne.symm hc))],
end

include hf1

/-- `seminorm_from_const_seq c f x` is antitone. -/
lemma seminorm_from_const_seq_antitone (x : R) :
  antitone (seminorm_from_const_seq c f x) :=
begin
  intros m n hmn,
  simp only [seminorm_from_const_seq],
  nth_rewrite 0 ← nat.add_sub_of_le hmn,
  rw [pow_add, ← mul_assoc],
  have hc_pos : 0 < f c := lt_of_le_of_ne (map_nonneg f _) hc,
  apply le_trans ((div_le_div_right (pow_pos hc_pos _)).mpr (map_mul_le_mul f _ _)),
  by_cases heq : m = n,
  { have : n - m = 0,
    { rw heq, exact nat.sub_self n, },
    rw [this, heq, div_le_div_right (pow_pos hc_pos _), pow_zero],
    conv_rhs{rw ← mul_one (f (x * c ^ n))},
    exact mul_le_mul_of_nonneg_left hf1 (map_nonneg f _) },
  { have h1 : 1 ≤ n - m,
    { rw [nat.one_le_iff_ne_zero, ne.def, nat.sub_eq_zero_iff_le, not_le],
    exact lt_of_le_of_ne hmn heq,},
    rw [hpm c h1, mul_div_assoc, div_eq_mul_inv, pow_sub₀ _ (ne.symm hc) hmn, mul_assoc,
      mul_comm (f c ^ m)⁻¹, ← mul_assoc (f c ^ n), mul_inv_cancel (pow_ne_zero n (ne.symm hc)),
      one_mul, div_eq_mul_inv] }
end

/-- The real-valued function sending `x ∈ R` to the limit of `(f (x * c^n))/((f c)^n)`. -/
def seminorm_from_const' (x : R) : ℝ :=
classical.some (real.tendsto_of_is_bounded_antitone (seminorm_from_const_is_bounded c f x)
  (seminorm_from_const_seq_antitone hf1 hc hpm x))

/-- We prove that `seminorm_from_const' hf1 hc hpm x` is the limit of the sequence
  `seminorm_from_const_seq c f x` as `n` tends to infinity. -/
lemma seminorm_from_const_is_limit (x : R) :
  filter.tendsto ((seminorm_from_const_seq c f x)) filter.at_top
    (𝓝 (seminorm_from_const' hf1 hc hpm x)) :=
classical.some_spec (real.tendsto_of_is_bounded_antitone (seminorm_from_const_is_bounded c f x)
  (seminorm_from_const_seq_antitone hf1 hc hpm x))

/-- `seminorm_from_const' hf1 hc hpm 0 = 0`. -/
lemma seminorm_from_const_zero : seminorm_from_const' hf1 hc hpm 0 = 0 :=
tendsto_nhds_unique (seminorm_from_const_is_limit hf1 hc hpm 0)
  (by simpa [seminorm_from_const_seq_zero c (map_zero _)] using tendsto_const_nhds)

/-- `seminorm_from_const' hf1 hc hpm 1 = 1`. -/
lemma seminorm_from_const_is_norm_one_class : seminorm_from_const' hf1 hc hpm 1 = 1 :=
begin
  apply tendsto_nhds_unique_of_eventually_eq (seminorm_from_const_is_limit hf1 hc hpm 1)
    tendsto_const_nhds,
  simp only [filter.eventually_eq, filter.eventually_at_top, ge_iff_le],
  exact ⟨1,  seminorm_from_const_seq_one hc hpm⟩,
end

/-- `seminorm_from_const' hf1 hc hpm` is submultiplicative. -/
lemma seminorm_from_const_mul (x y : R) :
  seminorm_from_const' hf1 hc hpm (x * y) ≤
    seminorm_from_const' hf1 hc hpm x * seminorm_from_const' hf1 hc hpm y :=
begin
  have hlim : filter.tendsto (λ n, seminorm_from_const_seq c f (x * y) (2 *n)) filter.at_top
    (𝓝 (seminorm_from_const' hf1 hc hpm (x * y) )),
  { refine filter.tendsto.comp (seminorm_from_const_is_limit hf1 hc hpm (x * y)) _,
    apply filter.tendsto_at_top_at_top_of_monotone,
    { intros n m hnm, simp only [mul_le_mul_left, nat.succ_pos', hnm], },
    { rintro n, use n, linarith, }},
  apply le_of_tendsto_of_tendsto' hlim (filter.tendsto.mul
    (seminorm_from_const_is_limit hf1 hc hpm x)
    (seminorm_from_const_is_limit hf1 hc hpm y)),
  intro n,
  simp only [seminorm_from_const_seq],
  rw [div_mul_div_comm, ← pow_add, two_mul, div_le_div_right
    (pow_pos (lt_of_le_of_ne (map_nonneg f _) hc) _),
    pow_add, ← mul_assoc, mul_comm (x * y), ← mul_assoc, mul_assoc, mul_comm (c^n)],
  exact map_mul_le_mul f (x * c ^ n) (y * c ^ n),
end

/-- `seminorm_from_const' hf1 hc hpm` is invariant under negation of `x`. -/
lemma seminorm_from_const_neg (x : R)  :
  seminorm_from_const' hf1 hc hpm (-x) = seminorm_from_const' hf1 hc hpm x  :=
begin
  apply tendsto_nhds_unique_of_eventually_eq (seminorm_from_const_is_limit hf1 hc hpm (-x))
    (seminorm_from_const_is_limit hf1 hc hpm x),
  simp only [filter.eventually_eq, filter.eventually_at_top],
  use 0,
  intros n hn,
  simp only [seminorm_from_const_seq],
  rw [neg_mul, map_neg_eq_map],
end

/-- `seminorm_from_const' hf1 hc hpm` satisfies the triangle inequality. -/
lemma seminorm_from_const_add (x y : R)  :
  seminorm_from_const' hf1 hc hpm (x + y) ≤
    seminorm_from_const' hf1 hc hpm x +  seminorm_from_const' hf1 hc hpm y :=
begin
  apply le_of_tendsto_of_tendsto' (seminorm_from_const_is_limit hf1 hc hpm (x + y))
    (filter.tendsto.add (seminorm_from_const_is_limit hf1 hc hpm x)
    (seminorm_from_const_is_limit hf1 hc hpm y)),
  intro n,
  have h_add : f ((x + y) * c ^ n) ≤ (f (x * c ^ n)) + (f (y * c ^ n)),
  { rw add_mul, exact map_add_le_add f _ _ },
  simp only [seminorm_from_const_seq],
  rw div_add_div_same,
  exact (div_le_div_right (pow_pos (lt_of_le_of_ne (map_nonneg f _) hc) _)).mpr h_add,
end

/-- The function `seminorm_from_const` is a `ring_seminorm` on `R`. -/
def seminorm_from_const :
  ring_seminorm R  :=
{ to_fun    := seminorm_from_const' hf1 hc hpm,
  map_zero' := seminorm_from_const_zero hf1 hc hpm,
  add_le'   := seminorm_from_const_add hf1 hc hpm,
  neg'      := seminorm_from_const_neg hf1 hc hpm,
  mul_le'   := seminorm_from_const_mul hf1 hc hpm }

lemma seminorm_from_const_def (x : R) :
  seminorm_from_const hf1 hc hpm x =  seminorm_from_const' hf1 hc hpm x := rfl

/-- `seminorm_from_const' hf1 hc hpm 1 ≤ 1`. -/
lemma seminorm_from_const_is_norm_le_one_class :
  seminorm_from_const' hf1 hc hpm 1 ≤ 1 :=
le_of_eq (seminorm_from_const_is_norm_one_class hf1 hc hpm)

/-- The function `seminorm_from_const' hf1 hc hpm` is nonarchimedean. -/
lemma seminorm_from_const_is_nonarchimedean (hna : is_nonarchimedean f) :
  is_nonarchimedean (seminorm_from_const' hf1 hc hpm)  :=
begin
  intros x y,
  apply le_of_tendsto_of_tendsto' (seminorm_from_const_is_limit hf1 hc hpm (x + y))
    (filter.tendsto.max (seminorm_from_const_is_limit hf1 hc hpm x)
    (seminorm_from_const_is_limit hf1 hc hpm y)),
  intro n,
  have hmax : f ((x + y) * c ^ n) ≤ max (f (x * c ^ n)) (f (y * c ^ n)),
  { rw add_mul, exact hna _ _ },
  rw le_max_iff at hmax ⊢,
  cases hmax; [left, right];
  exact (div_le_div_right (pow_pos (lt_of_le_of_ne (map_nonneg f c) hc) _)).mpr hmax,
end

/-- The function `seminorm_from_const' hf1 hc hpm` is power-multiplicative. -/
lemma seminorm_from_const_is_pow_mul : is_pow_mul (seminorm_from_const' hf1 hc hpm) :=
begin
  intros x m hm,
  simp only [seminorm_from_const'],
  have hpow := filter.tendsto.pow (seminorm_from_const_is_limit hf1 hc hpm x) m,
  have hlim : filter.tendsto (λ n, seminorm_from_const_seq c f (x^m) (m*n)) filter.at_top
    (𝓝 (seminorm_from_const' hf1 hc hpm (x^m) )),
  { refine filter.tendsto.comp (seminorm_from_const_is_limit hf1 hc hpm (x^m)) _,
    apply filter.tendsto_at_top_at_top_of_monotone,
    { intros n k hnk, exact mul_le_mul_left' hnk m, },
    { rintro n, use n, exact le_mul_of_one_le_left' hm, }},
  apply tendsto_nhds_unique hlim,
  convert filter.tendsto.pow (seminorm_from_const_is_limit hf1 hc hpm x) m,
  ext n,
  simp only [seminorm_from_const_seq],
  rw [div_pow, ← hpm _ hm, ← pow_mul, mul_pow, ← pow_mul, mul_comm m n],
end

/-- The function `seminorm_from_const' hf1 hc hpm` is bounded above by `x`. -/
lemma seminorm_from_const_le_seminorm (x : R) : seminorm_from_const' hf1 hc hpm x ≤ f x :=
begin
  apply le_of_tendsto (seminorm_from_const_is_limit hf1 hc hpm x),
  simp only [filter.eventually_at_top, ge_iff_le],
  use 1,
  rintros n hn,
  apply le_trans ((div_le_div_right (pow_pos (lt_of_le_of_ne (map_nonneg f c) hc) _)).mpr
    (map_mul_le_mul _ _ _)),
  rw [hpm c hn, mul_div_assoc, div_self (pow_ne_zero n hc.symm), mul_one],
end

/-- If `x : R` is multiplicative for `f`, then `seminorm_from_const' hf1 hc hpm x = f x`. -/
lemma seminorm_from_const_apply_of_is_mul {x : R} (hx : ∀ y : R, f (x * y) = f x * f y) :
  seminorm_from_const' hf1 hc hpm x = f x :=
begin
  have hlim : filter.tendsto (seminorm_from_const_seq c f x) filter.at_top (𝓝 (f x)),
  { have hseq : seminorm_from_const_seq c f x = λ n, f x,
    { ext n,
      by_cases hn : n = 0,
      { simp only [seminorm_from_const_seq],
        rw [hn, pow_zero, pow_zero, mul_one, div_one], },
      { simp only [seminorm_from_const_seq],
        rw [hx (c ^n), hpm _ (nat.one_le_iff_ne_zero.mpr hn), mul_div_assoc,
          div_self (pow_ne_zero n hc.symm), mul_one], }},
    simpa [hseq] using tendsto_const_nhds, },
  exact tendsto_nhds_unique (seminorm_from_const_is_limit hf1 hc hpm x) hlim,
end

/-- If `x : R` is multiplicative for `f`, then it is multiplicative for
  `seminorm_from_const' hf1 hc hpm`. -/
lemma seminorm_from_const_is_mul_of_is_mul {x : R} (hx : ∀ y : R, f (x * y) = f x * f y) (y : R) :
  seminorm_from_const' hf1 hc hpm (x * y) =
    seminorm_from_const' hf1 hc hpm x * seminorm_from_const' hf1 hc hpm y :=
begin
  have hlim : filter.tendsto (seminorm_from_const_seq c f (x * y)) filter.at_top
    (𝓝 (seminorm_from_const' hf1 hc hpm x * seminorm_from_const' hf1 hc hpm y)),
  { rw seminorm_from_const_apply_of_is_mul hf1 hc hpm hx,
    have hseq : seminorm_from_const_seq c f (x * y) = λ n, f x * seminorm_from_const_seq c f y n,
    { ext n,
      simp only [seminorm_from_const_seq],
      rw [mul_assoc, hx, mul_div_assoc], },
    simpa [hseq]
      using filter.tendsto.const_mul _(seminorm_from_const_is_limit hf1 hc hpm y) },
  exact tendsto_nhds_unique (seminorm_from_const_is_limit hf1 hc hpm (x * y)) hlim,
end

/-- `seminorm_from_const' hf1 hc hpm c = f c`. -/
lemma seminorm_from_const_apply_c : seminorm_from_const' hf1 hc hpm c = f c :=
begin
  have hlim : filter.tendsto (seminorm_from_const_seq c f c) filter.at_top (𝓝 (f c)),
  { have hseq : seminorm_from_const_seq c f c = λ n, f c,
    { ext n,
      simp only [seminorm_from_const_seq],
      rw [← pow_succ, hpm _ le_add_self, pow_succ, mul_div_assoc, div_self (pow_ne_zero n hc.symm),
        mul_one], },
    simpa [hseq] using tendsto_const_nhds },
    exact tendsto_nhds_unique (seminorm_from_const_is_limit hf1 hc hpm c) hlim,
end

/-- For every `x : R`, `seminorm_from_const' hf1 hc hpm (c * x)` equals the product
  `seminorm_from_const' hf1 hc hpm c * seminorm_from_const' hf1 hc hpm x`. -/
lemma seminorm_from_const_c_is_mul (x : R) :
  seminorm_from_const' hf1 hc hpm (c * x) =
    seminorm_from_const' hf1 hc hpm c * seminorm_from_const' hf1 hc hpm x :=
begin
  have hlim : filter.tendsto (λ n, seminorm_from_const_seq c f x (n + 1)) filter.at_top
    (𝓝 (seminorm_from_const' hf1 hc hpm x)),
  { refine filter.tendsto.comp (seminorm_from_const_is_limit hf1 hc hpm x) _,
    apply filter.tendsto_at_top_at_top_of_monotone,
    { intros n m hnm,
      exact add_le_add_right hnm 1, },
    { rintro n, use n, linarith, }},
  rw seminorm_from_const_apply_c hf1 hc hpm,
  apply tendsto_nhds_unique (seminorm_from_const_is_limit hf1 hc hpm (c * x)),
  have hterm : seminorm_from_const_seq c f (c * x) =
    (λ n, f c * (seminorm_from_const_seq c f x (n + 1))),
  { simp only [seminorm_from_const_seq],
    ext n,
    rw [mul_comm c, pow_succ, pow_succ, mul_div, div_eq_mul_inv _ (f c * f c ^ n), mul_inv,
      ← mul_assoc, mul_comm (f c), mul_assoc _ (f c), mul_inv_cancel hc.symm,
      mul_one, mul_assoc, div_eq_mul_inv] },
  simpa [hterm] using filter.tendsto.mul tendsto_const_nhds hlim,
end

end ring

section field

variables {K : Type*} [field K]

/-- If `K` is a field, the function `seminorm_from_const` is a `ring_norm` on `K`. -/
def seminorm_from_const_ring_norm_of_field {k : K} {g : ring_seminorm K} (hg1 : g 1 ≤ 1)
  (hg_k : g k ≠ 0) (hg_pm : is_pow_mul g) : ring_norm K :=
(seminorm_from_const hg1 hg_k.symm hg_pm).to_ring_norm
  (ring_seminorm.ne_zero_iff.mpr⟨k,
    by simpa [seminorm_from_const_def, seminorm_from_const_apply_c] using hg_k⟩)

lemma seminorm_from_const_ring_norm_of_field_def {k : K} {g : ring_seminorm K} (hg1 : g 1 ≤ 1)
  (hg_k : g k ≠ 0) (hg_pm : is_pow_mul g) (x : K) :
  seminorm_from_const_ring_norm_of_field hg1 hg_k hg_pm x =
    seminorm_from_const' hg1 hg_k.symm hg_pm x :=
rfl

end field