/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Kevin Buzzard
-/
import algebra.big_operators.nat_antidiagonal
import algebra.geom_sum
import data.fintype.card
import ring_theory.power_series.well_known
import tactic.field_simp

/-!
# Bernoulli numbers

The Bernoulli numbers are a sequence of rational numbers that frequently show up in
number theory.

## Mathematical overview

The Bernoulli numbers $(B_0, B_1, B_2, \ldots)=(1, -1/2, 1/6, 0, -1/30, \ldots)$ are
a sequence of rational numbers. They show up in the formula for the sums of $k$th
powers. They are related to the Taylor series expansions of $x/\tan(x)$ and
of $\coth(x)$, and also show up in the values that the Riemann Zeta function
takes both at both negative and positive integers (and hence in the
theory of modular forms). For example, if $1 \leq n$ is even then

$$\zeta(2n)=\sum_{t\geq1}t^{-2n}=(-1)^{n+1}\frac{(2\pi)^{2n}B_{2n}}{2(2n)!}.$$

Note however that this result is not yet formalised in Lean.

The Bernoulli numbers can be formally defined using the power series

$$\sum B_n\frac{t^n}{n!}=\frac{t}{1-e^{-t}}$$

although that happens to not be the definition in mathlib (this is an *implementation
detail* and need not concern the mathematician).

Note that $B_1=-1/2$, meaning that we are using the $B_n^-$ of
[from Wikipedia](https://en.wikipedia.org/wiki/Bernoulli_number).

## Implementation detail

The Bernoulli numbers are defined using well-founded induction, by the formula
$$B_n=1-\sum_{k\lt n}\frac{\binom{n}{k}}{n-k+1}B_k.$$
This formula is true for all $n$ and in particular $B_0=1$. Note that this is the definition
for positive Bernoulli numbers, which we call `bernoulli'`. The negative Bernoulli numbers are
then defined as `bernoulli := (-1)^n * bernoulli'`.

## Main theorems

`sum_bernoulli : ∑ k in finset.range n, (n.choose k : ℚ) * bernoulli k = 0`
-/

open_locale nat big_operators
open finset nat finset.nat power_series
variables (A : Type*) [comm_ring A] [algebra ℚ A]

/-! ### Definitions -/

/-- The Bernoulli numbers:
the $n$-th Bernoulli number $B_n$ is defined recursively via
$$B_n = 1 - \sum_{k < n} \binom{n}{k}\frac{B_k}{n+1-k}$$ -/
def bernoulli' : ℕ → ℚ :=
well_founded.fix lt_wf $
  λ n bernoulli', 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k k.2

lemma bernoulli'_def' (n : ℕ) :
  bernoulli' n = 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k :=
well_founded.fix_eq _ _ _

lemma bernoulli'_def (n : ℕ) :
  bernoulli' n = 1 - ∑ k in range n, n.choose k / (n - k + 1) * bernoulli' k :=
by { rw [bernoulli'_def', ← fin.sum_univ_eq_sum_range], refl }

lemma bernoulli'_spec (n : ℕ) :
  ∑ k in range n.succ, (n.choose (n - k) : ℚ) / (n - k + 1) * bernoulli' k = 1 :=
begin
  rw [sum_range_succ_comm, bernoulli'_def n, tsub_self],
  conv in (n.choose (_ - _)) { rw choose_symm (mem_range.1 H).le },
  simp only [one_mul, cast_one, sub_self, sub_add_cancel, choose_zero_right, zero_add, div_one],
end

lemma bernoulli'_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli' k.1 = 1 :=
begin
  refine ((sum_antidiagonal_eq_sum_range_succ_mk _ n).trans _).trans (bernoulli'_spec n),
  refine sum_congr rfl (λ x hx, _),
  simp only [add_tsub_cancel_of_le, mem_range_succ_iff.mp hx, cast_sub],
end

/-! ### Examples -/

section examples

@[simp] lemma bernoulli'_zero : bernoulli' 0 = 1 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_one : bernoulli' 1 = 1/2 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_two : bernoulli' 2 = 1/6 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_three : bernoulli' 3 = 0 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_four : bernoulli' 4 = -1/30 :=
have nat.choose 4 2 = 6 := dec_trivial, -- shrug
by { rw bernoulli'_def, norm_num [sum_range_succ, this] }

end examples

@[simp] lemma sum_bernoulli' (n : ℕ) :
  ∑ k in range n, (n.choose k : ℚ) * bernoulli' k = n :=
begin
  cases n, { simp },
  suffices : (n + 1 : ℚ) * ∑ k in range n, ↑(n.choose k) / (n - k + 1) * bernoulli' k =
    ∑ x in range n, ↑(n.succ.choose x) * bernoulli' x,
  { rw_mod_cast [sum_range_succ, bernoulli'_def, ← this, choose_succ_self_right], ring },
  simp_rw [mul_sum, ← mul_assoc],
  refine sum_congr rfl (λ k hk, _),
  congr',
  have : ((n - k : ℕ) : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  field_simp [← cast_sub (mem_range.1 hk).le, mul_comm],
  rw_mod_cast [tsub_add_eq_add_tsub (mem_range.1 hk).le, choose_mul_succ_eq],
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli' n`. -/
def bernoulli'_power_series := mk $ λ n, algebra_map ℚ A (bernoulli' n / n!)

theorem bernoulli'_power_series_mul_exp_sub_one :
  bernoulli'_power_series A * (exp A - 1) = X * exp A :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  rw [bernoulli'_power_series, coeff_mul, mul_comm X, sum_antidiagonal_succ'],
  suffices : ∑ p in antidiagonal n, (bernoulli' p.1 / p.1!) * ((p.2 + 1) * p.2!)⁻¹ = n!⁻¹,
  { simpa [ring_hom.map_sum] using congr_arg (algebra_map ℚ A) this },
  apply eq_inv_of_mul_left_eq_one,
  rw sum_mul,
  convert bernoulli'_spec' n using 1,
  apply sum_congr rfl,
  simp_rw [mem_antidiagonal],
  rintro ⟨i, j⟩ rfl,
  have : (j + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j,
  have : (j + 1 : ℚ) * j! * i! ≠ 0 := by simpa [factorial_ne_zero],
  have := factorial_mul_factorial_dvd_factorial_add i j,
  field_simp [mul_comm _ (bernoulli' i), mul_assoc, add_choose],
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc],
  rw [cast_mul, cast_mul, mul_div_mul_right, cast_dvd_char_zero, cast_mul],
  assumption',
end

/-- Odd Bernoulli numbers (greater than 1) are zero. -/
theorem bernoulli'_odd_eq_zero {n : ℕ} (h_odd : odd n) (hlt : 1 < n) : bernoulli' n = 0 :=
begin
  let B := mk (λ n, bernoulli' n / n!),
  suffices : (B - eval_neg_hom B) * (exp ℚ - 1) = X * (exp ℚ - 1),
  { cases mul_eq_mul_right_iff.mp this;
    simp only [power_series.ext_iff, eval_neg_hom, coeff_X] at h,
    { apply eq_zero_of_neg_eq,
      specialize h n,
      split_ifs at h;
      simp [neg_one_pow_of_odd h_odd, factorial_ne_zero, *] at * },
    { simpa using h 1 } },
  have h : B * (exp ℚ - 1) = X * exp ℚ,
  { simpa [bernoulli'_power_series] using bernoulli'_power_series_mul_exp_sub_one ℚ },
  rw [sub_mul, h, mul_sub X, sub_right_inj, ← neg_sub, ← neg_mul_eq_mul_neg, neg_eq_iff_neg_eq],
  suffices : eval_neg_hom (B * (exp ℚ - 1)) * exp ℚ = eval_neg_hom (X * exp ℚ) * exp ℚ,
  { simpa [mul_assoc, sub_mul, mul_comm (eval_neg_hom (exp ℚ)), exp_mul_exp_neg_eq_one, eq_comm] },
  congr',
end

/-- The Bernoulli numbers are defined to be `bernoulli'` with a parity sign. -/
def bernoulli (n : ℕ) : ℚ := (-1)^n * bernoulli' n

lemma bernoulli'_eq_bernoulli (n : ℕ) : bernoulli' n = (-1)^n * bernoulli n :=
by simp [bernoulli, ← mul_assoc, ← sq, ← pow_mul, mul_comm n 2, pow_mul]

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

@[simp] lemma bernoulli_one : bernoulli 1 = -1/2 :=
by norm_num [bernoulli]

theorem bernoulli_eq_bernoulli'_of_ne_one {n : ℕ} (hn : n ≠ 1) : bernoulli n = bernoulli' n :=
begin
  by_cases h0 : n = 0, { simp [h0] },
  rw [bernoulli, neg_one_pow_eq_pow_mod_two],
  cases mod_two_eq_zero_or_one n, { simp [h] },
  simp [bernoulli'_odd_eq_zero (odd_iff.mpr h) (one_lt_iff_ne_zero_and_ne_one.mpr ⟨h0, hn⟩)],
end

@[simp] theorem sum_bernoulli (n : ℕ):
  ∑ k in range n, (n.choose k : ℚ) * bernoulli k = if n = 1 then 1 else 0 :=
begin
  cases n, { simp },
  cases n, { simp },
  suffices : ∑ i in range n, ↑((n + 2).choose (i + 2)) * bernoulli (i + 2) = n / 2,
  { simp only [this, sum_range_succ', cast_succ, bernoulli_one, bernoulli_zero, choose_one_right,
    mul_one, choose_zero_right, cast_zero, if_false, zero_add, succ_succ_ne_one], ring },
  have f := sum_bernoulli' n.succ.succ,
  simp_rw [sum_range_succ', bernoulli'_one, choose_one_right, cast_succ, ← eq_sub_iff_add_eq] at f,
  convert f,
  { ext x, rw bernoulli_eq_bernoulli'_of_ne_one (succ_ne_zero x ∘ succ.inj) },
  { simp only [one_div, mul_one, bernoulli'_zero, cast_one, choose_zero_right, add_sub_cancel],
    ring },
end

lemma bernoulli_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli k.1 =
    if n = 0 then 1 else 0 :=
begin
  cases n, { simp },
  rw if_neg (succ_ne_zero _),
  -- algebra facts
  have h₁ : (1, n) ∈ antidiagonal n.succ := by simp [mem_antidiagonal, add_comm],
  have h₂ : (n : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  have h₃ : (1 + n).choose n = n + 1 := by simp [add_comm],
  -- key equation: the corresponding fact for `bernoulli'`
  have H := bernoulli'_spec' n.succ,
  -- massage it to match the structure of the goal, then convert piece by piece
  rw sum_eq_add_sum_diff_singleton h₁ at H ⊢,
  apply add_eq_of_eq_sub',
  convert eq_sub_of_add_eq' H using 1,
  { refine sum_congr rfl (λ p h, _),
    obtain ⟨h', h''⟩ : p ∈ _ ∧ p ≠ _ := by rwa [mem_sdiff, mem_singleton] at h,
    simp [bernoulli_eq_bernoulli'_of_ne_one ((not_congr (antidiagonal_congr h' h₁)).mp h'')] },
  { field_simp [h₃],
    norm_num },
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli n`. -/
def bernoulli_power_series := mk $ λ n, algebra_map ℚ A (bernoulli n / n!)

theorem bernoulli_power_series_mul_exp_sub_one :
  bernoulli_power_series A * (exp A - 1) = X :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  simp only [bernoulli_power_series, coeff_mul, coeff_X, sum_antidiagonal_succ', one_div, coeff_mk,
    coeff_one, coeff_exp, linear_map.map_sub, factorial, if_pos, cast_succ, cast_one, cast_mul,
    sub_zero, ring_hom.map_one, add_eq_zero_iff, if_false, inv_one, zero_add, one_ne_zero, mul_zero,
    and_false, sub_self, ← ring_hom.map_mul, ← ring_hom.map_sum],
  suffices : ∑ x in antidiagonal n, bernoulli x.1 / x.1! * ((x.2 + 1) * x.2!)⁻¹
           = if n.succ = 1 then 1 else 0, { split_ifs; simp [h, this] },
  cases n, { simp },
  have hfact : ∀ m, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  have hite1 : ite (n.succ.succ = 1) 1 0 = (0 / n.succ! : ℚ) := by simp,
  have hite2 : ite (n.succ = 0) 1 0 = (0 : ℚ) := by simp [succ_ne_zero],
  rw [hite1, eq_div_iff (hfact n.succ), ← hite2, ← bernoulli_spec', sum_mul],
  apply sum_congr rfl,
  rintro ⟨i, j⟩ h,
  rw mem_antidiagonal at h,
  have hj : (j.succ : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j,
  field_simp [← h, mul_ne_zero hj (hfact j), hfact i, mul_comm _ (bernoulli i), mul_assoc],
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc],
  rw [cast_mul, cast_mul, mul_div_mul_right _ _ hj, add_choose, cast_dvd_char_zero],
  apply factorial_mul_factorial_dvd_factorial_add,
end

section faulhaber

/-- **Faulhaber's theorem** relating the **sum of of p-th powers** to the Bernoulli numbers:
$$\sum_{k=0}^{n-1} k^p = \sum_{i=0}^p B_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
See https://proofwiki.org/wiki/Faulhaber%27s_Formula and [orosi2018faulhaber] for
the proof provided here. -/
theorem sum_range_pow (n p : ℕ) :
  ∑ k in range n, (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  have hne : ∀ m : ℕ, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  -- compute the Cauchy product of two power series
  have h_cauchy : mk (λ p, bernoulli p / p!) * mk (λ q, coeff ℚ (q + 1) (exp ℚ ^ n))
                = mk (λ p, ∑ i in range (p + 1),
                      bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
  { ext q,
    let f := λ a b, bernoulli a / a! * coeff ℚ (b + 1) (exp ℚ ^ n),
    -- key step: use `power_series.coeff_mul` and then rewrite sums
    simp only [coeff_mul, coeff_mk, cast_mul, sum_antidiagonal_eq_sum_range_succ f],
    apply sum_congr rfl,
    simp_intros m h only [finset.mem_range],
    simp only [f, exp_pow_eq_rescale_exp, rescale, one_div, coeff_mk, ring_hom.coe_mk, coeff_exp,
              ring_hom.id_apply, cast_mul, rat.algebra_map_rat_rat],
    -- manipulate factorials and binomial coefficients
    rw [choose_eq_factorial_div_factorial h.le, eq_comm, div_eq_iff (hne q.succ), succ_eq_add_one,
        mul_assoc _ _ ↑q.succ!, mul_comm _ ↑q.succ!, ← mul_assoc, div_mul_eq_mul_div,
        mul_comm (↑n ^ (q - m + 1)), ← mul_assoc _ _ (↑n ^ (q - m + 1)), ← one_div, mul_one_div,
        div_div_eq_div_mul, tsub_add_eq_add_tsub (le_of_lt_succ h), cast_dvd, cast_mul],
    { ring },
    { exact factorial_mul_factorial_dvd_factorial h.le },
    { simp [hne] } },
  -- same as our goal except we pull out `p!` for convenience
  have hps : ∑ k in range n, ↑k ^ p
          = (∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!)
            * p!,
  { suffices : mk (λ p, ∑ k in range n, ↑k ^ p * algebra_map ℚ ℚ p!⁻¹)
             = mk (λ p, ∑ i in range (p + 1),
                    bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
    { rw [← div_eq_iff (hne p), div_eq_mul_inv, sum_mul],
      rw power_series.ext_iff at this,
      simpa using this p },
    -- the power series `exp ℚ - 1` is non-zero, a fact we need in order to use `mul_right_inj'`
    have hexp : exp ℚ - 1 ≠ 0,
    { simp only [exp, power_series.ext_iff, ne, not_forall],
      use 1,
      simp },
    have h_r : exp ℚ ^ n - 1 = X * mk (λ p, coeff ℚ (p + 1) (exp ℚ ^ n)),
    { have h_const : C ℚ (constant_coeff ℚ (exp ℚ ^ n)) = 1 := by simp,
      rw [← h_const, sub_const_eq_X_mul_shift] },
    -- key step: a chain of equalities of power series
    rw [← mul_right_inj' hexp, mul_comm, ← exp_pow_sum, ← geom_sum_def, geom_sum_mul, h_r,
        ← bernoulli_power_series_mul_exp_sub_one, bernoulli_power_series, mul_right_comm],
    simp [h_cauchy, mul_comm] },
  -- massage `hps` into our goal
  rw [hps, sum_mul],
  refine sum_congr rfl (λ x hx, _),
  field_simp [mul_right_comm _ ↑p!, ← mul_assoc _ _ ↑p!, cast_add_one_ne_zero, hne],
end

/-- Alternate form of **Faulhaber's theorem**, relating the sum of p-th powers to the Bernoulli
numbers: $$\sum_{k=1}^{n} k^p = \sum_{i=0}^p (-1)^iB_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
Deduced from `sum_range_pow`. -/
theorem sum_Ico_pow (n p : ℕ) :
  ∑ k in Ico 1 (n + 1), (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli' i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  -- dispose of the trivial case
  cases p, { simp },
  let f := λ i, bernoulli i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  let f' := λ i, bernoulli' i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  suffices : ∑ k in Ico 1 n.succ, ↑k ^ p.succ = ∑ i in range p.succ.succ, f' i, { convert this },
  -- prove some algebraic facts that will make things easier for us later on
  have hle := nat.le_add_left 1 n,
  have hne : (p + 1 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero p.succ,
  have h1 : ∀ r : ℚ, r * (p + 1 + 1) * n ^ p.succ / (p + 1 + 1 : ℚ) = r * n ^ p.succ :=
    λ r, by rw [mul_div_right_comm, mul_div_cancel _ hne],
  have h2 : f 1 + n ^ p.succ = 1 / 2 * n ^ p.succ,
  { simp_rw [f, bernoulli_one, choose_one_right, succ_sub_succ_eq_sub, cast_succ, tsub_zero, h1],
    ring },
  have : ∑ i in range p, bernoulli (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2)
       = ∑ i in range p, bernoulli' (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2) :=
    sum_congr rfl (λ i h, by rw bernoulli_eq_bernoulli'_of_ne_one (succ_succ_ne_one i)),
  calc  ∑ k in Ico 1 n.succ, ↑k ^ p.succ
        -- replace sum over `Ico` with sum over `range` and simplify
      = ∑ k in range n.succ, ↑k ^ p.succ : by simp [sum_Ico_eq_sub _ hle, succ_ne_zero]
        -- extract the last term of the sum
  ... = ∑ k in range n, (k : ℚ) ^ p.succ + n ^ p.succ : by rw sum_range_succ
        -- apply the key lemma, `sum_range_pow`
  ... = ∑ i in range p.succ.succ, f i + n ^ p.succ : by simp [f, sum_range_pow]
        -- extract the first two terms of the sum
  ... = ∑ i in range p, f i.succ.succ + f 1 + f 0 + n ^ p.succ : by simp_rw [sum_range_succ']
  ... = ∑ i in range p, f i.succ.succ + (f 1 + n ^ p.succ) + f 0 : by ring
  ... = ∑ i in range p, f i.succ.succ + 1 / 2 * n ^ p.succ + f 0 : by rw h2
        -- convert from `bernoulli` to `bernoulli'`
  ... = ∑ i in range p, f' i.succ.succ + f' 1 + f' 0 : by { simp only [f, f'], simpa [h1] }
        -- rejoin the first two terms of the sum
  ... = ∑ i in range p.succ.succ, f' i : by simp_rw [sum_range_succ'],
end

end faulhaber


import soundness
import completeness

/- With the soundness and completeness theorems, we can now show the equivalence
of syntactic derivation to semantic entailment. We use this to prove the
semantic compactness theorem as a corollary. -/

variables {vars : Type} [denumerable vars] {Γ : set (Form vars)} {A : Form vars}

theorem deriv_iff_entail : (Γ ⊩ A) ↔ (Γ ⊨ A) :=
begin
  split,
  exact soundness,
  exact completeness
end

theorem consistent_iff_satisfiable : consistent Γ ↔ satisfiable Γ :=
begin
  rw [satisfiable_iff],
  split,
  exact mt completeness,
  exact mt soundness
end

/-- A corollary of the soundness + completeness theorem is semantic compactness:
If Γ ⊨ A, then A is entailed also by a finite subset of Γ. -/
theorem compactness (h : Γ ⊨ A) : ∃ Δ, Δ ⊆ Γ ∧ Δ.finite ∧ (Δ ⊨ A) :=
begin
  rw ←deriv_iff_entail at h,
  have := deriv_compactness h,
  rcases this with ⟨Δ, this⟩,
  use Δ,
  rw ←deriv_iff_entail,
  exact this
end

/-- Alternate form of compactness theorem:
every finite subset of Γ is satisfiable, then Γ itself is satisfiable. -/
theorem compactness' (hfinsat : ∀ (Δ : set (Form vars)), Δ ⊆ Γ → Δ.finite → satisfiable Δ)
  : satisfiable Γ :=
begin
rw ←consistent_iff_satisfiable,
apply deriv_compactness',
intro Δ,
specialize hfinsat Δ,
rw ←consistent_iff_satisfiable at hfinsat,
exact hfinsat
end

#lint


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

! This file was ported from Lean 3 source module combinatorics.pigeonhole
! leanprover-community/mathlib commit d6fad0e5bf2d6f48da9175d25c3dc5706b3834ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.ModEq
import Mathlib.Data.Set.Finite
import Mathlib.Algebra.BigOperators.Order
import Mathlib.Algebra.Module.Basic
import Mathlib.Algebra.Module.BigOperators

/-!
# Pigeonhole principles

Given pigeons (possibly infinitely many) in pigeonholes, the
pigeonhole principle states that, if there are more pigeons than
pigeonholes, then there is a pigeonhole with two or more pigeons.

There are a few variations on this statement, and the conclusion can
be made stronger depending on how many pigeons you know you might
have.

The basic statements of the pigeonhole principle appear in the
following locations:

* `Data.Finset.Basic` has `Finset.exists_ne_map_eq_of_card_lt_of_maps_to`
* `Data.Fintype.Basic` has `Fintype.exists_ne_map_eq_of_card_lt`
* `Data.Fintype.Basic` has `Finite.exists_ne_map_eq_of_infinite`
* `Data.Fintype.Basic` has `Finite.exists_infinite_fiber`
* `Data.Set.Finite` has `Set.infinite.exists_ne_map_eq_of_mapsTo`

This module gives access to these pigeonhole principles along with 20 more.
The versions vary by:

* using a function between `Fintype`s or a function between possibly infinite types restricted to
  `Finset`s;
* counting pigeons by a general weight function (`∑ x in s, w x`) or by heads (`Finset.card s`);
* using strict or non-strict inequalities;
* establishing upper or lower estimate on the number (or the total weight) of the pigeons in one
  pigeonhole;
* in case when we count pigeons by some weight function `w` and consider a function `f` between
  `Finset`s `s` and `t`, we can either assume that each pigeon is in one of the pigeonholes
  (`∀ x ∈ s, f x ∈ t`), or assume that for `y ∉ t`, the total weight of the pigeons in this
  pigeonhole `∑ x in s.filter (λ x, f x = y), w x` is nonpositive or nonnegative depending on
  the inequality we are proving.

Lemma names follow `mathlib` convention (e.g.,
`Finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`); "pigeonhole principle" is mentioned in the
docstrings instead of the names.

## See also

* `Ordinal.infinite_pigeonhole`: pigeonhole principle for cardinals, formulated using cofinality;

* `measure_theory.exists_nonempty_inter_of_measure_univ_lt_tsum_measure`,
  `measure_theory.exists_nonempty_inter_of_measure_univ_lt_sum_measure`: pigeonhole principle in a
  measure space.

## Tags

pigeonhole principle
-/

universe u v w

variable {α : Type u} {β : Type v} {M : Type w} [DecidableEq β]

open Nat

open BigOperators

namespace Finset

variable {s : Finset α} {t : Finset β} {f : α → β} {w : α → M} {b : M} {n : ℕ}

/-!
### The pigeonhole principles on `Finset`s, pigeons counted by weight

In this section we prove the following version of the pigeonhole principle: if the total weight of a
finite set of pigeons is greater than `n • b`, and they are sorted into `n` pigeonholes, then for
some pigeonhole, the total weight of the pigeons in this pigeonhole is greater than `b`, and a few
variations of this theorem.

The principle is formalized in the following way, see
`Finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`: if `f : α → β` is a function which maps all
elements of `s : Finset α` to `t : Finset β` and `card t • b < ∑ x in s, w x`, where `w : α → M` is
a weight function taking values in a `LinearOrderedCancelAddCommMonoid`, then for
some `y ∈ t`, the sum of the weights of all `x ∈ s` such that `f x = y` is greater than `b`.

There are a few bits we can change in this theorem:

* reverse all inequalities, with obvious adjustments to the name;
* replace the assumption `∀ a ∈ s, f a ∈ t` with
  `∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0`,
  and replace `of_maps_to` with `of_sum_fiber_nonpos` in the name;
* use non-strict inequalities assuming `t` is nonempty.

We can do all these variations independently, so we have eight versions of the theorem.
-/

section

variable [LinearOrderedCancelAddCommMonoid M]

/-!
#### Strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, and they are sorted into
`n` pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is
greater than `b`. -/
theorem exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (hf : ∀ a ∈ s, f a ∈ t)
    (hb : t.card • b < ∑ x in s, w x) : ∃ y ∈ t, b < ∑ x in s.filter fun x => f x = y, w x :=
  exists_lt_of_sum_lt <| by simpa only [sum_fiberwise_of_maps_to hf, sum_const]
#align finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum Finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, and they are sorted into `n`
pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is less
than `b`. -/
theorem exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul (hf : ∀ a ∈ s, f a ∈ t)
    (hb : (∑ x in s, w x) < t.card • b) : ∃ y ∈ t, (∑ x in s.filter fun x => f x = y, w x) < b :=
  @exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf hb
#align finset.exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul Finset.exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonpositive,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is greater than `b`. -/
theorem exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum
    (ht : ∀ (y) (_ : y ∉ t), (∑ x in s.filter fun x => f x = y, w x) ≤ 0)
    (hb : t.card • b < ∑ x in s, w x) : ∃ y ∈ t, b < ∑ x in s.filter fun x => f x = y, w x :=
  exists_lt_of_sum_lt <|
    calc
      (∑ _y in t, b) < ∑ x in s, w x := by simpa
      _ ≤ ∑ y in t, ∑ x in s.filter fun x => f x = y, w x :=
        sum_le_sum_fiberwise_of_sum_fiber_nonpos ht

#align finset.exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum Finset.exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonnegative,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is less than `b`. -/
theorem exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul
    (ht : ∀ (y) (_ : y ∉ t), (0 : M) ≤ ∑ x in s.filter fun x => f x = y, w x)
    (hb : (∑ x in s, w x) < t.card • b) : ∃ y ∈ t, (∑ x in s.filter fun x => f x = y, w x) < b :=
  @exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ ht hb
#align finset.exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul Finset.exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul

/-!
#### Non-strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, and
they are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons
in this pigeonhole is greater than or equal to `b`. -/
theorem exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (hf : ∀ a ∈ s, f a ∈ t) (ht : t.Nonempty)
    (hb : t.card • b ≤ ∑ x in s, w x) : ∃ y ∈ t, b ≤ ∑ x in s.filter fun x => f x = y, w x :=
  exists_le_of_sum_le ht <| by simpa only [sum_fiberwise_of_maps_to hf, sum_const]
#align finset.exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum Finset.exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, and they
are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons in
this pigeonhole is less than or equal to `b`. -/
theorem exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul (hf : ∀ a ∈ s, f a ∈ t) (ht : t.Nonempty)
    (hb : (∑ x in s, w x) ≤ t.card • b) : ∃ y ∈ t, (∑ x in s.filter fun x => f x = y, w x) ≤ b :=
  @exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf ht hb
#align finset.exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul Finset.exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, they
are sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the
pigeons there is nonpositive, then for at least one of these `n` pigeonholes, the total weight of
the pigeons in this pigeonhole is greater than or equal to `b`. -/
theorem exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum
    (hf : ∀ (y) (_ : y ∉ t), (∑ x in s.filter fun x => f x = y, w x) ≤ 0) (ht : t.Nonempty)
    (hb : t.card • b ≤ ∑ x in s, w x) : ∃ y ∈ t, b ≤ ∑ x in s.filter fun x => f x = y, w x :=
  exists_le_of_sum_le ht <|
    calc
      (∑ _y in t, b) ≤ ∑ x in s, w x := by simpa
      _ ≤ ∑ y in t, ∑ x in s.filter fun x => f x = y, w x :=
        sum_le_sum_fiberwise_of_sum_fiber_nonpos hf

#align finset.exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum Finset.exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, they are
sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the pigeons
there is nonnegative, then for at least one of these `n` pigeonholes, the total weight of the
pigeons in this pigeonhole is less than or equal to `b`. -/
theorem exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul
    (hf : ∀ (y) (_ : y ∉ t), (0 : M) ≤ ∑ x in s.filter fun x => f x = y, w x) (ht : t.Nonempty)
    (hb : (∑ x in s, w x) ≤ t.card • b) : ∃ y ∈ t, (∑ x in s.filter fun x => f x = y, w x) ≤ b :=
  @exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf ht hb
#align finset.exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul Finset.exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul

end

variable [LinearOrderedCommSemiring M]

/-!
### The pigeonhole principles on `Finset`s, pigeons counted by heads

In this section we formalize a few versions of the following pigeonhole principle: there is a
pigeonhole with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes.

First, we can use strict or non-strict inequalities. While the versions with non-strict inequalities
are weaker than those with strict inequalities, sometimes it might be more convenient to apply the
weaker version. Second, we can either state that there exists a pigeonhole with at least `n`
pigeons, or state that there exists a pigeonhole with at most `n` pigeons. In the latter case we do
not need the assumption `∀ a ∈ s, f a ∈ t`.

So, we prove four theorems: `Finset.exists_lt_card_fiber_of_maps_to_of_mul_lt_card`,
`Finset.exists_le_card_fiber_of_maps_to_of_mul_le_card`,
`Finset.exists_card_fiber_lt_of_card_lt_mul`, and `Finset.exists_card_fiber_le_of_card_le_mul`. -/

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes. -/

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function between finite sets `s` and `t` and a natural number `n` such that
`card t * n < card s`, there exists `y ∈ t` such that its preimage in `s` has more than `n`
elements. -/
theorem exists_lt_card_fiber_of_mul_lt_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t)
    (hn : t.card * n < s.card) : ∃ y ∈ t, n < (s.filter fun x => f x = y).card :=
  exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to hf hn
#align finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to Finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes. -/
theorem exists_card_fiber_lt_of_card_lt_nsmul (ht : ↑s.card < t.card • b) :
    ∃ y ∈ t, ↑(s.filter fun x => f x = y).card < b := by
  simp_rw [cast_card] at ht⊢
  exact
    exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul
      (fun _ _ => sum_nonneg fun _ _ => zero_le_one) ht
#align finset.exists_card_fiber_lt_of_card_lt_nsmul Finset.exists_card_fiber_lt_of_card_lt_nsmul

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.  ("The
minimum is at most the mean" specialized to integers.)

More formally, given a function `f`, a finite sets `s` in its domain, a finite set `t` in its
codomain, and a natural number `n` such that `card s < card t * n`, there exists `y ∈ t` such that
its preimage in `s` has less than `n` elements. -/
theorem exists_card_fiber_lt_of_card_lt_mul (hn : s.card < t.card * n) :
    ∃ y ∈ t, (s.filter fun x => f x = y).card < n :=
  exists_card_fiber_lt_of_card_lt_nsmul hn
#align finset.exists_card_fiber_lt_of_card_lt_mul Finset.exists_card_fiber_lt_of_card_lt_mul

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a number `b` such that `card t • b ≤ card s`, there exists `y ∈ t` such
that its preimage in `s` has at least `b` elements.
See also `Finset.exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to` for a stronger statement. -/
theorem exists_le_card_fiber_of_nsmul_le_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t) (ht : t.Nonempty)
    (hb : t.card • b ≤ s.card) : ∃ y ∈ t, b ≤ (s.filter fun x => f x = y).card := by
  simp_rw [cast_card] at hb⊢
  exact exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum hf ht hb
#align finset.exists_le_card_fiber_of_nsmul_le_card_of_maps_to Finset.exists_le_card_fiber_of_nsmul_le_card_of_maps_to

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a natural number `b` such that `card t * n ≤ card s`, there exists
`y ∈ t` such that its preimage in `s` has at least `n` elements. See also
`Finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to` for a stronger statement. -/
theorem exists_le_card_fiber_of_mul_le_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t) (ht : t.Nonempty)
    (hn : t.card * n ≤ s.card) : ∃ y ∈ t, n ≤ (s.filter fun x => f x = y).card :=
  exists_le_card_fiber_of_nsmul_le_card_of_maps_to hf ht hn
#align finset.exists_le_card_fiber_of_mul_le_card_of_maps_to Finset.exists_le_card_fiber_of_mul_le_card_of_maps_to

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` and `t`, and a number `b` such that `card s ≤ card t • b`, there exists `y ∈ t` such
that its preimage in `s` has no more than `b` elements.
See also `Finset.exists_card_fiber_lt_of_card_lt_nsmul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_nsmul (ht : t.Nonempty) (hb : ↑s.card ≤ t.card • b) :
    ∃ y ∈ t, ↑(s.filter fun x => f x = y).card ≤ b := by
  simp_rw [cast_card] at hb⊢
  refine'
    exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul
      (fun _ _ => sum_nonneg fun _ _ => zero_le_one) ht hb
#align finset.exists_card_fiber_le_of_card_le_nsmul Finset.exists_card_fiber_le_of_card_le_nsmul

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` in its domain, a finite set `t` in its codomain, and a natural number `n` such that
`card s ≤ card t * n`, there exists `y ∈ t` such that its preimage in `s` has no more than `n`
elements. See also `Finset.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_mul (ht : t.Nonempty) (hn : s.card ≤ t.card * n) :
    ∃ y ∈ t, (s.filter fun x => f x = y).card ≤ n :=
  exists_card_fiber_le_of_card_le_nsmul ht hn
#align finset.exists_card_fiber_le_of_card_le_mul Finset.exists_card_fiber_le_of_card_le_mul

end Finset

namespace Fintype

open Finset

variable [Fintype α] [Fintype β] (f : α → β) {w : α → M} {b : M} {n : ℕ}

section

variable [LinearOrderedCancelAddCommMonoid M]

/-!
### The pigeonhole principles on `Fintypes`s, pigeons counted by weight

In this section we specialize theorems from the previous section to the special case of functions
between `Fintype`s and `s = univ`, `t = univ`. In this case the assumption `∀ x ∈ s, f x ∈ t` always
holds, so we have four theorems instead of eight. -/

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than `b` provided that
the total number of pigeonholes times `b` is less than the total weight of all pigeons. -/
theorem exists_lt_sum_fiber_of_nsmul_lt_sum (hb : card β • b < ∑ x, w x) :
    ∃ y, b < ∑ x in univ.filter fun x => f x = y, w x :=
  let ⟨y, _, hy⟩ := exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (fun _ _ => mem_univ _) hb
  ⟨y, hy⟩
#align fintype.exists_lt_sum_fiber_of_nsmul_lt_sum Fintype.exists_lt_sum_fiber_of_nsmul_lt_sum

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than or equal to `b`
provided that the total number of pigeonholes times `b` is less than or equal to the total weight of
all pigeons. -/
theorem exists_le_sum_fiber_of_nsmul_le_sum [Nonempty β] (hb : card β • b ≤ ∑ x, w x) :
    ∃ y, b ≤ ∑ x in univ.filter fun x => f x = y, w x :=
  let ⟨y, _, hy⟩ :=
    exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (fun _ _ => mem_univ _) univ_nonempty hb
  ⟨y, hy⟩
#align fintype.exists_le_sum_fiber_of_nsmul_le_sum Fintype.exists_le_sum_fiber_of_nsmul_le_sum

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than `b` provided that
the total number of pigeonholes times `b` is greater than the total weight of all pigeons. -/
theorem exists_sum_fiber_lt_of_sum_lt_nsmul (hb : (∑ x, w x) < card β • b) :
    ∃ y, (∑ x in univ.filter fun x => f x = y, w x) < b :=
  @exists_lt_sum_fiber_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ hb
#align fintype.exists_sum_fiber_lt_of_sum_lt_nsmul Fintype.exists_sum_fiber_lt_of_sum_lt_nsmul

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than or equal to `b`
provided that the total number of pigeonholes times `b` is greater than or equal to the total weight
of all pigeons. -/
theorem exists_sum_fiber_le_of_sum_le_nsmul [Nonempty β] (hb : (∑ x, w x) ≤ card β • b) :
    ∃ y, (∑ x in univ.filter fun x => f x = y, w x) ≤ b :=
  @exists_le_sum_fiber_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ _ hb
#align fintype.exists_sum_fiber_le_of_sum_le_nsmul Fintype.exists_sum_fiber_le_of_sum_le_nsmul

end

variable [LinearOrderedCommSemiring M]

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes. There is a pigeonhole
with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes. -/
theorem exists_lt_card_fiber_of_nsmul_lt_card (hb : card β • b < card α) :
    ∃ y : β, b < (univ.filter fun x => f x = y).card :=
  let ⟨y, _, h⟩ := exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to (fun _ _ => mem_univ _) hb
  ⟨y, h⟩
#align fintype.exists_lt_card_fiber_of_nsmul_lt_card Fintype.exists_lt_card_fiber_of_nsmul_lt_card

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at least as many pigeons as
the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card β * n < card α`, there exists an element `y : β` such that its preimage has more than `n`
elements. -/
theorem exists_lt_card_fiber_of_mul_lt_card (hn : card β * n < card α) :
    ∃ y : β, n < (univ.filter fun x => f x = y).card :=
  exists_lt_card_fiber_of_nsmul_lt_card _ hn
#align fintype.exists_lt_card_fiber_of_mul_lt_card Fintype.exists_lt_card_fiber_of_mul_lt_card

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes. There is a pigeonhole
with at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.
-/
theorem exists_card_fiber_lt_of_card_lt_nsmul (hb : ↑(card α) < card β • b) :
    ∃ y : β, ↑(univ.filter fun x => f x = y).card < b :=
  let ⟨y, _, h⟩ := Finset.exists_card_fiber_lt_of_card_lt_nsmul (f := f) hb
  ⟨y, h⟩
#align fintype.exists_card_fiber_lt_of_card_lt_nsmul Fintype.exists_card_fiber_lt_of_card_lt_nsmul

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at most as many pigeons as
the floor of the average number of pigeons across all pigeonholes.
("The minimum is at most the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card α < card β * n`, there exists an element `y : β` such that its preimage has less than `n`
elements. -/
theorem exists_card_fiber_lt_of_card_lt_mul (hn : card α < card β * n) :
    ∃ y : β, (univ.filter fun x => f x = y).card < n :=
  exists_card_fiber_lt_of_card_lt_nsmul _ hn
#align fintype.exists_card_fiber_lt_of_card_lt_mul Fintype.exists_card_fiber_lt_of_card_lt_mul

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `b` such that `card β • b ≤ card α`, there exists an
element `y : β` such that its preimage has at least `b` elements.
See also `Fintype.exists_lt_card_fiber_of_nsmul_lt_card` for a stronger statement. -/
theorem exists_le_card_fiber_of_nsmul_le_card [Nonempty β] (hb : card β • b ≤ card α) :
    ∃ y : β, b ≤ (univ.filter fun x => f x = y).card :=
  let ⟨y, _, h⟩ :=
    exists_le_card_fiber_of_nsmul_le_card_of_maps_to (fun _ _ => mem_univ _) univ_nonempty hb
  ⟨y, h⟩
#align fintype.exists_le_card_fiber_of_nsmul_le_card Fintype.exists_le_card_fiber_of_nsmul_le_card

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card β * n ≤ card α`, there exists an
element `y : β` such that its preimage has at least `n` elements. See also
`Fintype.exists_lt_card_fiber_of_mul_lt_card` for a stronger statement. -/
theorem exists_le_card_fiber_of_mul_le_card [Nonempty β] (hn : card β * n ≤ card α) :
    ∃ y : β, n ≤ (univ.filter fun x => f x = y).card :=
  exists_le_card_fiber_of_nsmul_le_card _ hn
#align fintype.exists_le_card_fiber_of_mul_le_card Fintype.exists_le_card_fiber_of_mul_le_card

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `b` such that `card α ≤ card β • b`, there exists an
element `y : β` such that its preimage has at most `b` elements.
See also `Fintype.exists_card_fiber_lt_of_card_lt_nsmul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_nsmul [Nonempty β] (hb : ↑(card α) ≤ card β • b) :
    ∃ y : β, ↑(univ.filter fun x => f x = y).card ≤ b :=
  let ⟨y, _, h⟩ := Finset.exists_card_fiber_le_of_card_le_nsmul univ_nonempty hb
  ⟨y, h⟩
#align fintype.exists_card_fiber_le_of_card_le_nsmul Fintype.exists_card_fiber_le_of_card_le_nsmul

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card α ≤ card β * n`, there exists an
element `y : β` such that its preimage has at most `n` elements. See also
`Fintype.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
theorem exists_card_fiber_le_of_card_le_mul [Nonempty β] (hn : card α ≤ card β * n) :
    ∃ y : β, (univ.filter fun x => f x = y).card ≤ n :=
  exists_card_fiber_le_of_card_le_nsmul _ hn
#align fintype.exists_card_fiber_le_of_card_le_mul Fintype.exists_card_fiber_le_of_card_le_mul

end Fintype

namespace Nat

open Set

/-- If `s` is an infinite set of natural numbers and `k > 0`, then `s` contains two elements `m < n`
that are equal mod `k`. -/
theorem exists_lt_modEq_of_infinite {s : Set ℕ} (hs : s.Infinite) {k : ℕ} (hk : 0 < k) :
    ∃ m ∈ s, ∃ n ∈ s, m < n ∧ m ≡ n [MOD k] :=
  (hs.exists_lt_map_eq_of_mapsTo $ fun n _ => show n % k ∈ Iio k from Nat.mod_lt n hk) <|
    finite_lt_nat k
#align nat.exists_lt_modeq_of_infinite Nat.exists_lt_modEq_of_infinite

end Nat


-- import all
-- import utils.util
-- import data_util.basic
-- import data_util.lean_step
-- import lean_step

-- -- #check times_cont_diff_at_of_subsingleto

-- #check continuous_linear_map.complete_space

-- #check abs_max_sub_max_le_abs

-- theorem triangle_inequality {α} [_inst_1 : normed_group α]
--   (g h : α) : ∥g + h∥ ≤ ∥g∥ + ∥h∥ :=
-- begin
--   convert dist_triangle g 0 (-h); rw [dist_eq_norm],
--     { rw [sub_neg_eq_add] },
--     { rw [sub_zero] },
--     { rw [sub_neg_eq_add, zero_add] }
-- end

-- run_cmd do {
--   pf ← tactic.get_proof_from_env `norm_add_le >>= expr.unfold_macros,
--   tactic.pp pf >>= tactic.trace
-- }

-- run_cmd do {
--   pf ← tactic.get_proof_from_env `triangle_inequality >>= expr.unfold_macros,
--   tactic.pp pf >>= tactic.trace
-- }
-- -- #check lean_step_main
-- -- run_cmd lean_step_main dummy_dp_handler {rec_limit := 1000} `triangle_inequality 0 0
-- theorem iff_of_true' {P} : (P ↔ true) → P :=
-- begin
--   intro H, cases H with H₁ H₂, apply H₂, trivial
-- end
-- #check iff_of_true'


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yaël Dillies

! This file was ported from Lean 3 source module order.complete_boolean_algebra
! leanprover-community/mathlib commit 71b36b6f3bbe3b44e6538673819324d3ee9fcc96
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.CompleteLattice
import Mathlib.Order.Directed
import Mathlib.Logic.Equiv.Set

/-!
# Frames, completely distributive lattices and Boolean algebras

In this file we define and provide API for frames, completely distributive lattices and completely
distributive Boolean algebras.

## Typeclasses

* `Order.Frame`: Frame: A complete lattice whose `⊓` distributes over `⨆`.
* `Order.Coframe`: Coframe: A complete lattice whose `⊔` distributes over `⨅`.
* `CompleteDistribLattice`: Completely distributive lattices: A complete lattice whose `⊓` and `⊔`
  distribute over `⨆` and `⨅` respectively.
* `CompleteBooleanAlgebra`: Completely distributive Boolean algebra: A Boolean algebra whose `⊓`
  and `⊔` distribute over `⨆` and `⨅` respectively.

A set of opens gives rise to a topological space precisely if it forms a frame. Such a frame is also
completely distributive, but not all frames are. `Filter` is a coframe but not a completely
distributive lattice.

## TODO

Add instances for `Prod`

## References

* [Wikipedia, *Complete Heyting algebra*](https://en.wikipedia.org/wiki/Complete_Heyting_algebra)
* [Francis Borceux, *Handbook of Categorical Algebra III*][borceux-vol3]
-/

open Function Set

universe u v w

variable {α : Type u} {β : Type v} {ι : Sort w} {κ : ι → Sort _}

/-- A frame, aka complete Heyting algebra, is a complete lattice whose `⊓` distributes over `⨆`. -/
class Order.Frame (α : Type _) extends CompleteLattice α where
  inf_supₛ_le_supᵢ_inf (a : α) (s : Set α) : a ⊓ supₛ s ≤ ⨆ b ∈ s, a ⊓ b
#align order.frame Order.Frame

/-- In a frame, `⊓` distributes over `⨆`. -/
add_decl_doc Order.Frame.inf_supₛ_le_supᵢ_inf

/-- A coframe, aka complete Brouwer algebra or complete co-Heyting algebra, is a complete lattice
whose `⊔` distributes over `⨅`. -/
class Order.Coframe (α : Type _) extends CompleteLattice α where
  infᵢ_sup_le_sup_infₛ (a : α) (s : Set α) : (⨅ b ∈ s, a ⊔ b) ≤ a ⊔ infₛ s
#align order.coframe Order.Coframe

/-- In a coframe, `⊔` distributes over `⨅`. -/
add_decl_doc Order.Coframe.infᵢ_sup_le_sup_infₛ

open Order

/-- A completely distributive lattice is a complete lattice whose `⊔` and `⊓` respectively
distribute over `⨅` and `⨆`. -/
class CompleteDistribLattice (α : Type _) extends Frame α where
  infᵢ_sup_le_sup_infₛ : ∀ a s, (⨅ b ∈ s, a ⊔ b) ≤ a ⊔ infₛ s
#align complete_distrib_lattice CompleteDistribLattice

/-- In a completely distributive lattice, `⊔` distributes over `⨅`. -/
add_decl_doc CompleteDistribLattice.infᵢ_sup_le_sup_infₛ

-- See note [lower instance priority]
instance (priority := 100) CompleteDistribLattice.toCoframe [CompleteDistribLattice α] :
    Coframe α :=
  { ‹CompleteDistribLattice α› with }
#align complete_distrib_lattice.to_coframe CompleteDistribLattice.toCoframe

section Frame

variable [Frame α] {s t : Set α} {a b : α}

instance OrderDual.coframe : Coframe αᵒᵈ :=
  { OrderDual.completeLattice α with infᵢ_sup_le_sup_infₛ := @Frame.inf_supₛ_le_supᵢ_inf α _ }
#align order_dual.coframe OrderDual.coframe

theorem inf_supₛ_eq : a ⊓ supₛ s = ⨆ b ∈ s, a ⊓ b :=
  (Frame.inf_supₛ_le_supᵢ_inf _ _).antisymm supᵢ_inf_le_inf_supₛ
#align inf_Sup_eq inf_supₛ_eq

theorem supₛ_inf_eq : supₛ s ⊓ b = ⨆ a ∈ s, a ⊓ b := by
  simpa only [inf_comm] using @inf_supₛ_eq α _ s b
#align Sup_inf_eq supₛ_inf_eq

theorem supᵢ_inf_eq (f : ι → α) (a : α) : (⨆ i, f i) ⊓ a = ⨆ i, f i ⊓ a := by
  rw [supᵢ, supₛ_inf_eq, supᵢ_range]
#align supr_inf_eq supᵢ_inf_eq

theorem inf_supᵢ_eq (a : α) (f : ι → α) : (a ⊓ ⨆ i, f i) = ⨆ i, a ⊓ f i := by
  simpa only [inf_comm] using supᵢ_inf_eq f a
#align inf_supr_eq inf_supᵢ_eq

theorem supᵢ₂_inf_eq {f : ∀ i, κ i → α} (a : α) : (⨆ (i) (j), f i j) ⊓ a = ⨆ (i) (j), f i j ⊓ a :=
  by simp only [supᵢ_inf_eq]
#align bsupr_inf_eq supᵢ₂_inf_eq

theorem inf_supᵢ₂_eq {f : ∀ i, κ i → α} (a : α) : (a ⊓ ⨆ (i) (j), f i j) = ⨆ (i) (j), a ⊓ f i j :=
  by simp only [inf_supᵢ_eq]
#align inf_bsupr_eq inf_supᵢ₂_eq

theorem supᵢ_inf_supᵢ {ι ι' : Type _} {f : ι → α} {g : ι' → α} :
    ((⨆ i, f i) ⊓ ⨆ j, g j) = ⨆ i : ι × ι', f i.1 ⊓ g i.2 := by
  simp_rw [supᵢ_inf_eq, inf_supᵢ_eq, supᵢ_prod]
#align supr_inf_supr supᵢ_inf_supᵢ

theorem bsupᵢ_inf_bsupᵢ {ι ι' : Type _} {f : ι → α} {g : ι' → α} {s : Set ι} {t : Set ι'} :
    ((⨆ i ∈ s, f i) ⊓ ⨆ j ∈ t, g j) = ⨆ p ∈ s ×ˢ t, f (p : ι × ι').1 ⊓ g p.2 := by
  simp only [supᵢ_subtype', supᵢ_inf_supᵢ]
  exact (Equiv.surjective _).supᵢ_congr (Equiv.Set.prod s t).symm fun x => rfl
#align bsupr_inf_bsupr bsupᵢ_inf_bsupᵢ

theorem supₛ_inf_supₛ : supₛ s ⊓ supₛ t = ⨆ p ∈ s ×ˢ t, (p : α × α).1 ⊓ p.2 := by
  simp only [supₛ_eq_supᵢ, bsupᵢ_inf_bsupᵢ]
#align Sup_inf_Sup supₛ_inf_supₛ

theorem supᵢ_disjoint_iff {f : ι → α} : Disjoint (⨆ i, f i) a ↔ ∀ i, Disjoint (f i) a := by
  simp only [disjoint_iff, supᵢ_inf_eq, supᵢ_eq_bot]
#align supr_disjoint_iff supᵢ_disjoint_iff

theorem disjoint_supᵢ_iff {f : ι → α} : Disjoint a (⨆ i, f i) ↔ ∀ i, Disjoint a (f i) := by
  simpa only [disjoint_comm] using @supᵢ_disjoint_iff
#align disjoint_supr_iff disjoint_supᵢ_iff

theorem supᵢ₂_disjoint_iff {f : ∀ i, κ i → α} :
    Disjoint (⨆ (i) (j), f i j) a ↔ ∀ i j, Disjoint (f i j) a := by
  simp_rw [supᵢ_disjoint_iff]
#align supr₂_disjoint_iff supᵢ₂_disjoint_iff

theorem disjoint_supᵢ₂_iff {f : ∀ i, κ i → α} :
    Disjoint a (⨆ (i) (j), f i j) ↔ ∀ i j, Disjoint a (f i j) := by
  simp_rw [disjoint_supᵢ_iff]
#align disjoint_supr₂_iff disjoint_supᵢ₂_iff

theorem supₛ_disjoint_iff {s : Set α} : Disjoint (supₛ s) a ↔ ∀ b ∈ s, Disjoint b a := by
  simp only [disjoint_iff, supₛ_inf_eq, supᵢ_eq_bot]
#align Sup_disjoint_iff supₛ_disjoint_iff

theorem disjoint_supₛ_iff {s : Set α} : Disjoint a (supₛ s) ↔ ∀ b ∈ s, Disjoint a b := by
  simpa only [disjoint_comm] using @supₛ_disjoint_iff
#align disjoint_Sup_iff disjoint_supₛ_iff

theorem supᵢ_inf_of_monotone {ι : Type _} [Preorder ι] [IsDirected ι (· ≤ ·)] {f g : ι → α}
    (hf : Monotone f) (hg : Monotone g) : (⨆ i, f i ⊓ g i) = (⨆ i, f i) ⊓ ⨆ i, g i := by
  refine' (le_supᵢ_inf_supᵢ f g).antisymm _
  rw [supᵢ_inf_supᵢ]
  refine' supᵢ_mono' fun i => _
  rcases directed_of (· ≤ ·) i.1 i.2 with ⟨j, h₁, h₂⟩
  exact ⟨j, inf_le_inf (hf h₁) (hg h₂)⟩
#align supr_inf_of_monotone supᵢ_inf_of_monotone

theorem supᵢ_inf_of_antitone {ι : Type _} [Preorder ι] [IsDirected ι (swap (· ≤ ·))] {f g : ι → α}
    (hf : Antitone f) (hg : Antitone g) : (⨆ i, f i ⊓ g i) = (⨆ i, f i) ⊓ ⨆ i, g i :=
  @supᵢ_inf_of_monotone α _ ιᵒᵈ _ _ f g hf.dual_left hg.dual_left
#align supr_inf_of_antitone supᵢ_inf_of_antitone

instance Pi.frame {ι : Type _} {π : ι → Type _} [∀ i, Frame (π i)] : Frame (∀ i, π i) :=
  { Pi.completeLattice with
    inf_supₛ_le_supᵢ_inf := fun a s i => by
      simp only [supₛ_apply, supᵢ_apply, inf_apply, inf_supᵢ_eq, ← supᵢ_subtype'']; rfl }
#align pi.frame Pi.frame

-- see Note [lower instance priority]
instance (priority := 100) Frame.toDistribLattice : DistribLattice α :=
  DistribLattice.ofInfSupLe fun a b c => by
    rw [← supₛ_pair, ← supₛ_pair, inf_supₛ_eq, ← supₛ_image, image_pair]
#align frame.to_distrib_lattice Frame.toDistribLattice

end Frame

section Coframe

variable [Coframe α] {s t : Set α} {a b : α}

instance OrderDual.frame : Frame αᵒᵈ :=
  { OrderDual.completeLattice α with inf_supₛ_le_supᵢ_inf := @Coframe.infᵢ_sup_le_sup_infₛ α _ }
#align order_dual.frame OrderDual.frame

theorem sup_infₛ_eq : a ⊔ infₛ s = ⨅ b ∈ s, a ⊔ b :=
  @inf_supₛ_eq αᵒᵈ _ _ _
#align sup_Inf_eq sup_infₛ_eq

theorem infₛ_sup_eq : infₛ s ⊔ b = ⨅ a ∈ s, a ⊔ b :=
  @supₛ_inf_eq αᵒᵈ _ _ _
#align Inf_sup_eq infₛ_sup_eq

theorem infᵢ_sup_eq (f : ι → α) (a : α) : (⨅ i, f i) ⊔ a = ⨅ i, f i ⊔ a :=
  @supᵢ_inf_eq αᵒᵈ _ _ _ _
#align infi_sup_eq infᵢ_sup_eq

theorem sup_infᵢ_eq (a : α) (f : ι → α) : (a ⊔ ⨅ i, f i) = ⨅ i, a ⊔ f i :=
  @inf_supᵢ_eq αᵒᵈ _ _ _ _
#align sup_infi_eq sup_infᵢ_eq

theorem infᵢ₂_sup_eq {f : ∀ i, κ i → α} (a : α) : (⨅ (i) (j), f i j) ⊔ a = ⨅ (i) (j), f i j ⊔ a :=
  @supᵢ₂_inf_eq αᵒᵈ _ _ _ _ _
#align binfi_sup_eq infᵢ₂_sup_eq

theorem sup_infᵢ₂_eq {f : ∀ i, κ i → α} (a : α) : (a ⊔ ⨅ (i) (j), f i j) = ⨅ (i) (j), a ⊔ f i j :=
  @inf_supᵢ₂_eq αᵒᵈ _ _ _ _ _
#align sup_binfi_eq sup_infᵢ₂_eq

theorem infᵢ_sup_infᵢ {ι ι' : Type _} {f : ι → α} {g : ι' → α} :
    ((⨅ i, f i) ⊔ ⨅ i, g i) = ⨅ i : ι × ι', f i.1 ⊔ g i.2 :=
  @supᵢ_inf_supᵢ αᵒᵈ _ _ _ _ _
#align infi_sup_infi infᵢ_sup_infᵢ

theorem binfᵢ_sup_binfᵢ {ι ι' : Type _} {f : ι → α} {g : ι' → α} {s : Set ι} {t : Set ι'} :
    ((⨅ i ∈ s, f i) ⊔ ⨅ j ∈ t, g j) = ⨅ p ∈ s ×ˢ t, f (p : ι × ι').1 ⊔ g p.2 :=
  @bsupᵢ_inf_bsupᵢ αᵒᵈ _ _ _ _ _ _ _
#align binfi_sup_binfi binfᵢ_sup_binfᵢ

theorem infₛ_sup_infₛ : infₛ s ⊔ infₛ t = ⨅ p ∈ s ×ˢ t, (p : α × α).1 ⊔ p.2 :=
  @supₛ_inf_supₛ αᵒᵈ _ _ _
#align Inf_sup_Inf infₛ_sup_infₛ

theorem infᵢ_sup_of_monotone {ι : Type _} [Preorder ι] [IsDirected ι (swap (· ≤ ·))] {f g : ι → α}
    (hf : Monotone f) (hg : Monotone g) : (⨅ i, f i ⊔ g i) = (⨅ i, f i) ⊔ ⨅ i, g i :=
  @supᵢ_inf_of_antitone αᵒᵈ _ _ _ _ _ _ hf.dual_right hg.dual_right
#align infi_sup_of_monotone infᵢ_sup_of_monotone

theorem infᵢ_sup_of_antitone {ι : Type _} [Preorder ι] [IsDirected ι (· ≤ ·)] {f g : ι → α}
    (hf : Antitone f) (hg : Antitone g) : (⨅ i, f i ⊔ g i) = (⨅ i, f i) ⊔ ⨅ i, g i :=
  @supᵢ_inf_of_monotone αᵒᵈ _ _ _ _ _ _ hf.dual_right hg.dual_right
#align infi_sup_of_antitone infᵢ_sup_of_antitone

instance Pi.coframe {ι : Type _} {π : ι → Type _} [∀ i, Coframe (π i)] : Coframe (∀ i, π i) :=
  { Pi.completeLattice with
    infᵢ_sup_le_sup_infₛ := fun a s i => by
      simp only [infₛ_apply, infᵢ_apply, sup_apply, sup_infᵢ_eq, ← infᵢ_subtype'']; rfl }
#align pi.coframe Pi.coframe

-- see Note [lower instance priority]
instance (priority := 100) Coframe.toDistribLattice : DistribLattice α :=
  { ‹Coframe α› with
    le_sup_inf := fun a b c => by
      rw [← infₛ_pair, ← infₛ_pair, sup_infₛ_eq, ← infₛ_image, image_pair] }
#align coframe.to_distrib_lattice Coframe.toDistribLattice

end Coframe

section CompleteDistribLattice

variable [CompleteDistribLattice α] {a b : α} {s t : Set α}

-- Porting note: this is mysteriously slow. Minimised in
-- https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/Performance.20issue.20with.20.60CompleteBooleanAlgebra.60
-- but not yet resolved.
instance : CompleteDistribLattice αᵒᵈ :=
  { OrderDual.frame, OrderDual.coframe with }

instance Pi.completeDistribLattice {ι : Type _} {π : ι → Type _}
    [∀ i, CompleteDistribLattice (π i)] : CompleteDistribLattice (∀ i, π i) :=
  { Pi.frame, Pi.coframe with }
#align pi.complete_distrib_lattice Pi.completeDistribLattice

end CompleteDistribLattice

/-- A complete Boolean algebra is a completely distributive Boolean algebra. -/
class CompleteBooleanAlgebra (α) extends BooleanAlgebra α, CompleteDistribLattice α
#align complete_boolean_algebra CompleteBooleanAlgebra

instance Pi.completeBooleanAlgebra {ι : Type _} {π : ι → Type _}
    [∀ i, CompleteBooleanAlgebra (π i)] : CompleteBooleanAlgebra (∀ i, π i) :=
  { Pi.booleanAlgebra, Pi.completeDistribLattice with }
#align pi.complete_boolean_algebra Pi.completeBooleanAlgebra

instance Prop.completeBooleanAlgebra : CompleteBooleanAlgebra Prop :=
  { Prop.booleanAlgebra, Prop.completeLattice with
    infᵢ_sup_le_sup_infₛ := fun p s =>
      Iff.mp <| by simp only [forall_or_left, infᵢ_Prop_eq, infₛ_Prop_eq, sup_Prop_eq]
    inf_supₛ_le_supᵢ_inf := fun p s =>
      Iff.mp <| by
        simp only [inf_Prop_eq, exists_and_left, supᵢ_Prop_eq, supₛ_Prop_eq, exists_prop] }
#align Prop.complete_boolean_algebra Prop.completeBooleanAlgebra

section CompleteBooleanAlgebra

variable [CompleteBooleanAlgebra α] {a b : α} {s : Set α} {f : ι → α}

theorem compl_infᵢ : infᵢ fᶜ = ⨆ i, f iᶜ :=
  le_antisymm
    (compl_le_of_compl_le <| le_infᵢ fun i => compl_le_of_compl_le <|
      le_supᵢ (HasCompl.compl ∘ f) i)
    (supᵢ_le fun _ => compl_le_compl <| infᵢ_le _ _)
#align compl_infi compl_infᵢ

theorem compl_supᵢ : supᵢ fᶜ = ⨅ i, f iᶜ :=
  compl_injective (by simp [compl_infᵢ])
#align compl_supr compl_supᵢ

theorem compl_infₛ : infₛ sᶜ = ⨆ i ∈ s, iᶜ := by simp only [infₛ_eq_infᵢ, compl_infᵢ]
#align compl_Inf compl_infₛ

theorem compl_supₛ : supₛ sᶜ = ⨅ i ∈ s, iᶜ := by simp only [supₛ_eq_supᵢ, compl_supᵢ]
#align compl_Sup compl_supₛ

theorem compl_infₛ' : infₛ sᶜ = supₛ (HasCompl.compl '' s) :=
  compl_infₛ.trans supₛ_image.symm
#align compl_Inf' compl_infₛ'

theorem compl_supₛ' : supₛ sᶜ = infₛ (HasCompl.compl '' s) :=
  compl_supₛ.trans infₛ_image.symm
#align compl_Sup' compl_supₛ'

end CompleteBooleanAlgebra

section lift

-- See note [reducible non-instances]
/-- Pullback an `Order.Frame` along an injection. -/
@[reducible]
protected def Function.Injective.frame [Sup α] [Inf α] [SupSet α] [InfSet α] [Top α] [Bot α]
    [Frame β] (f : α → β) (hf : Injective f) (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b)
    (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b) (map_supₛ : ∀ s, f (supₛ s) = ⨆ a ∈ s, f a)
    (map_infₛ : ∀ s, f (infₛ s) = ⨅ a ∈ s, f a) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) :
    Frame α :=
  { hf.completeLattice f map_sup map_inf map_supₛ map_infₛ map_top map_bot with
    inf_supₛ_le_supᵢ_inf := fun a s => by
      change f (a ⊓ supₛ s) ≤ f _
      rw [← supₛ_image, map_inf, map_supₛ s, inf_supᵢ₂_eq]
      simp_rw [← map_inf]
      exact ((map_supₛ _).trans supᵢ_image).ge }
#align function.injective.frame Function.Injective.frame

-- See note [reducible non-instances]
/-- Pullback an `Order.Coframe` along an injection. -/
@[reducible]
protected def Function.Injective.coframe [Sup α] [Inf α] [SupSet α] [InfSet α] [Top α] [Bot α]
    [Coframe β] (f : α → β) (hf : Injective f) (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b)
    (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b) (map_supₛ : ∀ s, f (supₛ s) = ⨆ a ∈ s, f a)
    (map_infₛ : ∀ s, f (infₛ s) = ⨅ a ∈ s, f a) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) :
    Coframe α :=
  { hf.completeLattice f map_sup map_inf map_supₛ map_infₛ map_top map_bot with
    infᵢ_sup_le_sup_infₛ := fun a s => by
      change f _ ≤ f (a ⊔ infₛ s)
      rw [← infₛ_image, map_sup, map_infₛ s, sup_infᵢ₂_eq]
      simp_rw [← map_sup]
      exact ((map_infₛ _).trans infᵢ_image).le }
#align function.injective.coframe Function.Injective.coframe

-- See note [reducible non-instances]
/-- Pullback a `CompleteDistribLattice` along an injection. -/
@[reducible]
protected def Function.Injective.completeDistribLattice [Sup α] [Inf α] [SupSet α] [InfSet α]
    [Top α] [Bot α] [CompleteDistribLattice β] (f : α → β) (hf : Function.Injective f)
    (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b)
    (map_supₛ : ∀ s, f (supₛ s) = ⨆ a ∈ s, f a) (map_infₛ : ∀ s, f (infₛ s) = ⨅ a ∈ s, f a)
    (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) : CompleteDistribLattice α :=
  { hf.frame f map_sup map_inf map_supₛ map_infₛ map_top map_bot,
    hf.coframe f map_sup map_inf map_supₛ map_infₛ map_top map_bot with }
#align function.injective.complete_distrib_lattice Function.Injective.completeDistribLattice

-- See note [reducible non-instances]
/-- Pullback a `CompleteBooleanAlgebra` along an injection. -/
@[reducible]
protected def Function.Injective.completeBooleanAlgebra [Sup α] [Inf α] [SupSet α] [InfSet α]
    [Top α] [Bot α] [HasCompl α] [SDiff α] [CompleteBooleanAlgebra β] (f : α → β)
    (hf : Function.Injective f) (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b)
    (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b) (map_supₛ : ∀ s, f (supₛ s) = ⨆ a ∈ s, f a)
    (map_infₛ : ∀ s, f (infₛ s) = ⨅ a ∈ s, f a) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥)
    (map_compl : ∀ a, f (aᶜ) = f aᶜ) (map_sdiff : ∀ a b, f (a \ b) = f a \ f b) :
    CompleteBooleanAlgebra α :=
  { hf.completeDistribLattice f map_sup map_inf map_supₛ map_infₛ map_top map_bot,
    hf.booleanAlgebra f map_sup map_inf map_top map_bot map_compl map_sdiff with }
#align function.injective.complete_boolean_algebra Function.Injective.completeBooleanAlgebra

end lift

namespace PUnit

variable (s : Set PUnit.{u + 1}) (x y : PUnit.{u + 1})

-- Porting note: we don't have `refine_struct` ported yet, so we do it by hand
instance completeBooleanAlgebra : CompleteBooleanAlgebra PUnit := by
  refine'
    { PUnit.booleanAlgebra with
      supₛ := fun _ => unit
      infₛ := fun _ => unit
      .. } <;>
  intros <;>
  first|trivial

@[simp]
theorem supₛ_eq : supₛ s = unit :=
  rfl
#align punit.Sup_eq PUnit.supₛ_eq

@[simp]
theorem infₛ_eq : infₛ s = unit :=
  rfl
#align punit.Inf_eq PUnit.infₛ_eq

end PUnit


/-
Copyright (c) 2018 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta, Kevin Buzzard, Alistair Tucker, Johannes Hölzl, Yury Kudryashov
-/
import logic.function.iterate
import data.set.intervals.proj_Icc
import topology.algebra.order.field
import topology.metric_space.basic
import topology.bornology.hom

/-!
# Lipschitz continuous functions

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

A map `f : α → β` between two (extended) metric spaces is called *Lipschitz continuous*
with constant `K ≥ 0` if for all `x, y` we have `edist (f x) (f y) ≤ K * edist x y`.
For a metric space, the latter inequality is equivalent to `dist (f x) (f y) ≤ K * dist x y`.
There is also a version asserting this inequality only for `x` and `y` in some set `s`.

In this file we provide various ways to prove that various combinations of Lipschitz continuous
functions are Lipschitz continuous. We also prove that Lipschitz continuous functions are
uniformly continuous.

## Main definitions and lemmas

* `lipschitz_with K f`: states that `f` is Lipschitz with constant `K : ℝ≥0`
* `lipschitz_on_with K f`: states that `f` is Lipschitz with constant `K : ℝ≥0` on a set `s`
* `lipschitz_with.uniform_continuous`: a Lipschitz function is uniformly continuous
* `lipschitz_on_with.uniform_continuous_on`: a function which is Lipschitz on a set is uniformly
  continuous on that set.

## Implementation notes

The parameter `K` has type `ℝ≥0`. This way we avoid conjuction in the definition and have
coercions both to `ℝ` and `ℝ≥0∞`. Constructors whose names end with `'` take `K : ℝ` as an
argument, and return `lipschitz_with (real.to_nnreal K) f`.
-/

universes u v w x

open filter function set
open_locale topology nnreal ennreal

variables {α : Type u} {β : Type v} {γ : Type w} {ι : Type x}

/-- A function `f` is Lipschitz continuous with constant `K ≥ 0` if for all `x, y`
we have `dist (f x) (f y) ≤ K * dist x y` -/
def lipschitz_with [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0) (f : α → β) :=
∀x y, edist (f x) (f y) ≤ K * edist x y

lemma lipschitz_with_iff_dist_le_mul [pseudo_metric_space α] [pseudo_metric_space β] {K : ℝ≥0}
  {f : α → β} : lipschitz_with K f ↔ ∀ x y, dist (f x) (f y) ≤ K * dist x y :=
by { simp only [lipschitz_with, edist_nndist, dist_nndist], norm_cast }

alias lipschitz_with_iff_dist_le_mul ↔ lipschitz_with.dist_le_mul lipschitz_with.of_dist_le_mul

/-- A function `f` is Lipschitz continuous with constant `K ≥ 0` on `s` if for all `x, y` in `s`
we have `dist (f x) (f y) ≤ K * dist x y` -/
def lipschitz_on_with [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0) (f : α → β)
  (s : set α) :=
∀ ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s), edist (f x) (f y) ≤ K * edist x y

@[simp] lemma lipschitz_on_with_empty [pseudo_emetric_space α] [pseudo_emetric_space β] (K : ℝ≥0)
  (f : α → β) : lipschitz_on_with K f ∅ :=
λ x x_in y y_in, false.elim x_in

lemma lipschitz_on_with.mono [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {s t : set α} {f : α → β} (hf : lipschitz_on_with K f t) (h : s ⊆ t) : lipschitz_on_with K f s :=
λ x x_in y y_in, hf (h x_in) (h y_in)

lemma lipschitz_on_with_iff_dist_le_mul [pseudo_metric_space α] [pseudo_metric_space β] {K : ℝ≥0}
  {s : set α} {f : α → β} :
  lipschitz_on_with K f s ↔ ∀ (x ∈ s) (y ∈ s), dist (f x) (f y) ≤ K * dist x y :=
by { simp only [lipschitz_on_with, edist_nndist, dist_nndist], norm_cast }

alias lipschitz_on_with_iff_dist_le_mul ↔
  lipschitz_on_with.dist_le_mul lipschitz_on_with.of_dist_le_mul

@[simp] lemma lipschitz_on_univ [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {f : α → β} : lipschitz_on_with K f univ ↔ lipschitz_with K f :=
by simp [lipschitz_on_with, lipschitz_with]

lemma lipschitz_on_with_iff_restrict [pseudo_emetric_space α] [pseudo_emetric_space β] {K : ℝ≥0}
  {f : α → β} {s : set α} : lipschitz_on_with K f s ↔ lipschitz_with K (s.restrict f) :=
by simp only [lipschitz_on_with, lipschitz_with, set_coe.forall', restrict, subtype.edist_eq]

alias lipschitz_on_with_iff_restrict ↔ lipschitz_on_with.to_restrict _

lemma maps_to.lipschitz_on_with_iff_restrict [pseudo_emetric_space α] [pseudo_emetric_space β]
  {K : ℝ≥0} {f : α → β} {s : set α} {t : set β} (h : maps_to f s t) :
  lipschitz_on_with K f s ↔ lipschitz_with K (h.restrict f s t) :=
lipschitz_on_with_iff_restrict

alias maps_to.lipschitz_on_with_iff_restrict ↔ lipschitz_on_with.to_restrict_maps_to _

namespace lipschitz_with

section emetric

open emetric

variables [pseudo_emetric_space α] [pseudo_emetric_space β] [pseudo_emetric_space γ]
variables {K : ℝ≥0} {f : α → β} {x y : α} {r : ℝ≥0∞}

protected lemma lipschitz_on_with (h : lipschitz_with K f) (s : set α) : lipschitz_on_with K f s :=
λ x _ y _, h x y

lemma edist_le_mul (h : lipschitz_with K f) (x y : α) : edist (f x) (f y) ≤ K * edist x y := h x y

lemma edist_le_mul_of_le (h : lipschitz_with K f) (hr : edist x y ≤ r) :
  edist (f x) (f y) ≤ K * r :=
(h x y).trans $ ennreal.mul_left_mono hr

lemma edist_lt_mul_of_lt (h : lipschitz_with K f) (hK : K ≠ 0) (hr : edist x y < r) :
  edist (f x) (f y) < K * r :=
(h x y).trans_lt $ (ennreal.mul_lt_mul_left (ennreal.coe_ne_zero.2 hK) ennreal.coe_ne_top).2 hr

lemma maps_to_emetric_closed_ball (h : lipschitz_with K f) (x : α) (r : ℝ≥0∞) :
  maps_to f (closed_ball x r) (closed_ball (f x) (K * r)) :=
λ y hy, h.edist_le_mul_of_le hy

lemma maps_to_emetric_ball (h : lipschitz_with K f) (hK : K ≠ 0) (x : α) (r : ℝ≥0∞) :
  maps_to f (ball x r) (ball (f x) (K * r)) :=
λ y hy, h.edist_lt_mul_of_lt hK hy

lemma edist_lt_top (hf : lipschitz_with K f) {x y : α} (h : edist x y ≠ ⊤) :
  edist (f x) (f y) < ⊤ :=
(hf x y).trans_lt $ ennreal.mul_lt_top ennreal.coe_ne_top h

lemma mul_edist_le (h : lipschitz_with K f) (x y : α) :
  (K⁻¹ : ℝ≥0∞) * edist (f x) (f y) ≤ edist x y :=
begin
  rw [mul_comm, ← div_eq_mul_inv],
  exact ennreal.div_le_of_le_mul' (h x y)
end

protected lemma of_edist_le (h : ∀ x y, edist (f x) (f y) ≤ edist x y) :
  lipschitz_with 1 f :=
λ x y, by simp only [ennreal.coe_one, one_mul, h]

protected lemma weaken (hf : lipschitz_with K f) {K' : ℝ≥0} (h : K ≤ K') :
  lipschitz_with K' f :=
assume x y, le_trans (hf x y) $ ennreal.mul_right_mono (ennreal.coe_le_coe.2 h)

lemma ediam_image_le (hf : lipschitz_with K f) (s : set α) :
  emetric.diam (f '' s) ≤ K * emetric.diam s :=
begin
  apply emetric.diam_le,
  rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩,
  exact hf.edist_le_mul_of_le (emetric.edist_le_diam_of_mem hx hy)
end

lemma edist_lt_of_edist_lt_div (hf : lipschitz_with K f) {x y : α} {d : ℝ≥0∞}
  (h : edist x y < d / K) : edist (f x) (f y) < d :=
calc edist (f x) (f y) ≤ K * edist x y : hf x y
... < d : ennreal.mul_lt_of_lt_div' h

/-- A Lipschitz function is uniformly continuous -/
protected lemma uniform_continuous (hf : lipschitz_with K f) :
  uniform_continuous f :=
begin
  refine emetric.uniform_continuous_iff.2 (λε εpos, _),
  use [ε / K, ennreal.div_pos_iff.2 ⟨ne_of_gt εpos, ennreal.coe_ne_top⟩],
  exact λ x y, hf.edist_lt_of_edist_lt_div
end

/-- A Lipschitz function is continuous -/
protected lemma continuous (hf : lipschitz_with K f) :
  continuous f :=
hf.uniform_continuous.continuous

protected lemma const (b : β) : lipschitz_with 0 (λa:α, b) :=
assume x y, by simp only [edist_self, zero_le]

protected lemma id : lipschitz_with 1 (@id α) :=
lipschitz_with.of_edist_le $ assume x y, le_rfl

protected lemma subtype_val (s : set α) : lipschitz_with 1 (subtype.val : s → α) :=
lipschitz_with.of_edist_le $ assume x y, le_rfl

protected lemma subtype_coe (s : set α) : lipschitz_with 1 (coe : s → α) :=
lipschitz_with.subtype_val s

lemma subtype_mk (hf : lipschitz_with K f) {p : β → Prop} (hp : ∀ x, p (f x)) :
  lipschitz_with K (λ x, ⟨f x, hp x⟩ : α → {y // p y}) :=
hf

protected lemma eval {α : ι → Type u} [Π i, pseudo_emetric_space (α i)] [fintype ι] (i : ι) :
  lipschitz_with 1 (function.eval i : (Π i, α i) → α i) :=
lipschitz_with.of_edist_le $ λ f g, by convert edist_le_pi_edist f g i

protected lemma restrict (hf : lipschitz_with K f) (s : set α) :
  lipschitz_with K (s.restrict f) :=
λ x y, hf x y

protected lemma comp {Kf Kg : ℝ≥0} {f : β → γ} {g : α → β}
  (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) : lipschitz_with (Kf * Kg) (f ∘ g) :=
assume x y,
calc edist (f (g x)) (f (g y)) ≤ Kf * edist (g x) (g y) : hf _ _
... ≤ Kf * (Kg * edist x y) : ennreal.mul_left_mono (hg _ _)
... = (Kf * Kg : ℝ≥0) * edist x y : by rw [← mul_assoc, ennreal.coe_mul]

lemma comp_lipschitz_on_with {Kf Kg : ℝ≥0} {f : β → γ} {g : α → β} {s : set α}
  (hf : lipschitz_with Kf f) (hg : lipschitz_on_with Kg g s) :
  lipschitz_on_with (Kf * Kg) (f ∘ g) s :=
lipschitz_on_with_iff_restrict.mpr $ hf.comp hg.to_restrict

protected lemma prod_fst : lipschitz_with 1 (@prod.fst α β) :=
lipschitz_with.of_edist_le $ assume x y, le_max_left _ _

protected lemma prod_snd : lipschitz_with 1 (@prod.snd α β) :=
lipschitz_with.of_edist_le $ assume x y, le_max_right _ _

protected lemma prod {f : α → β} {Kf : ℝ≥0} (hf : lipschitz_with Kf f)
  {g : α → γ} {Kg : ℝ≥0} (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, (f x, g x)) :=
begin
  assume x y,
  rw [ennreal.coe_mono.map_max, prod.edist_eq, ennreal.max_mul],
  exact max_le_max (hf x y) (hg x y)
end

protected

protected lemma prod_mk_right (b : β) : lipschitz_with 1 (λ a : α, (a, b)) :=
by simpa only [max_eq_left zero_le_one] using lipschitz_with.id.prod (lipschitz_with.const b)

protected lemma uncurry {f : α → β → γ} {Kα Kβ : ℝ≥0} (hα : ∀ b, lipschitz_with Kα (λ a, f a b))
  (hβ : ∀ a, lipschitz_with Kβ (f a)) :
  lipschitz_with (Kα + Kβ) (function.uncurry f) :=
begin
  rintros ⟨a₁, b₁⟩ ⟨a₂, b₂⟩,
  simp only [function.uncurry, ennreal.coe_add, add_mul],
  apply le_trans (edist_triangle _ (f a₂ b₁) _),
  exact add_le_add (le_trans (hα _ _ _) $ ennreal.mul_left_mono $ le_max_left _ _)
    (le_trans (hβ _ _ _) $ ennreal.mul_left_mono $ le_max_right _ _)
end

protected lemma iterate {f : α → α} (hf : lipschitz_with K f) :
  ∀n, lipschitz_with (K ^ n) (f^[n])
| 0       := by simpa only [pow_zero] using lipschitz_with.id
| (n + 1) := by rw [pow_succ']; exact (iterate n).comp hf

lemma edist_iterate_succ_le_geometric {f : α → α} (hf : lipschitz_with K f) (x n) :
  edist (f^[n] x) (f^[n + 1] x) ≤ edist x (f x) * K ^ n :=
begin
  rw [iterate_succ, mul_comm],
  simpa only [ennreal.coe_pow] using (hf.iterate n) x (f x)
end

protected lemma mul {f g : function.End α} {Kf Kg} (hf : lipschitz_with Kf f)
  (hg : lipschitz_with Kg g) :
  lipschitz_with (Kf * Kg) (f * g : function.End α) :=
hf.comp hg

/-- The product of a list of Lipschitz continuous endomorphisms is a Lipschitz continuous
endomorphism. -/
protected lemma list_prod (f : ι → function.End α) (K : ι → ℝ≥0)
  (h : ∀ i, lipschitz_with (K i) (f i)) :
  ∀ l : list ι, lipschitz_with (l.map K).prod (l.map f).prod
| [] := by simpa using lipschitz_with.id
| (i :: l) := by { simp only [list.map_cons, list.prod_cons], exact (h i).mul (list_prod l) }

protected lemma pow {f : function.End α} {K} (h : lipschitz_with K f) :
  ∀ n : ℕ, lipschitz_with (K^n) (f^n : function.End α)
| 0       := by simpa only [pow_zero] using lipschitz_with.id
| (n + 1) := by { rw [pow_succ, pow_succ], exact h.mul (pow n) }

end emetric

section metric

variables [pseudo_metric_space α] [pseudo_metric_space β] [pseudo_metric_space γ]
  {K : ℝ≥0} {f : α → β} {x y : α} {r : ℝ}

protected lemma of_dist_le' {K : ℝ} (h : ∀ x y, dist (f x) (f y) ≤ K * dist x y) :
  lipschitz_with (real.to_nnreal K) f :=
of_dist_le_mul $ λ x y, le_trans (h x y) $
  mul_le_mul_of_nonneg_right (real.le_coe_to_nnreal K) dist_nonneg

protected lemma mk_one (h : ∀ x y, dist (f x) (f y) ≤ dist x y) :
  lipschitz_with 1 f :=
of_dist_le_mul $ by simpa only [nnreal.coe_one, one_mul] using h

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
doesn't assume `0≤K`. -/
protected lemma of_le_add_mul' {f : α → ℝ} (K : ℝ) (h : ∀x y, f x ≤ f y + K * dist x y) :
  lipschitz_with (real.to_nnreal K) f :=
have I : ∀ x y, f x - f y ≤ K * dist x y,
  from assume x y, sub_le_iff_le_add'.2 (h x y),
lipschitz_with.of_dist_le' $
assume x y,
abs_sub_le_iff.2 ⟨I x y, dist_comm y x ▸ I y x⟩

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
assumes `0≤K`. -/
protected lemma of_le_add_mul {f : α → ℝ} (K : ℝ≥0) (h : ∀x y, f x ≤ f y + K * dist x y) :
  lipschitz_with K f :=
by simpa only [real.to_nnreal_coe] using lipschitz_with.of_le_add_mul' K h

protected lemma of_le_add {f : α → ℝ} (h : ∀ x y, f x ≤ f y + dist x y) :
  lipschitz_with 1 f :=
lipschitz_with.of_le_add_mul 1 $ by simpa only [nnreal.coe_one, one_mul]

protected lemma le_add_mul {f : α → ℝ} {K : ℝ≥0} (h : lipschitz_with K f) (x y) :
  f x ≤ f y + K * dist x y :=
sub_le_iff_le_add'.1 $ le_trans (le_abs_self _) $ h.dist_le_mul x y

protected lemma iff_le_add_mul {f : α → ℝ} {K : ℝ≥0} :
  lipschitz_with K f ↔ ∀ x y, f x ≤ f y + K * dist x y :=
⟨lipschitz_with.le_add_mul, lipschitz_with.of_le_add_mul K⟩

lemma nndist_le (hf : lipschitz_with K f) (x y : α) :
  nndist (f x) (f y) ≤ K * nndist x y :=
hf.dist_le_mul x y

lemma dist_le_mul_of_le (hf : lipschitz_with K f) (hr : dist x y ≤ r) :
  dist (f x) (f y) ≤ K * r :=
(hf.dist_le_mul x y).trans $ mul_le_mul_of_nonneg_left hr K.coe_nonneg

lemma maps_to_closed_ball (hf : lipschitz_with K f) (x : α) (r : ℝ) :
  maps_to f (metric.closed_ball x r) (metric.closed_ball (f x) (K * r)) :=
λ y hy, hf.dist_le_mul_of_le hy

lemma dist_lt_mul_of_lt (hf : lipschitz_with K f) (hK : K ≠ 0) (hr : dist x y < r) :
  dist (f x) (f y) < K * r :=
(hf.dist_le_mul x y).trans_lt $ (mul_lt_mul_left $ nnreal.coe_pos.2 hK.bot_lt).2 hr

lemma maps_to_ball (hf : lipschitz_with K f) (hK : K ≠ 0) (x : α) (r : ℝ) :
  maps_to f (metric.ball x r) (metric.ball (f x) (K * r)) :=
λ y hy, hf.dist_lt_mul_of_lt hK hy

/-- A Lipschitz continuous map is a locally bounded map. -/
def to_locally_bounded_map (f : α → β) (hf : lipschitz_with K f) :
  locally_bounded_map α β :=
locally_bounded_map.of_map_bounded f $ λ s hs, let ⟨C, hC⟩ := metric.is_bounded_iff.1 hs
in metric.is_bounded_iff.2 ⟨K * C, ball_image_iff.2 $ λ x hx, ball_image_iff.2 $ λ y hy,
  hf.dist_le_mul_of_le (hC hx hy)⟩

@[simp] lemma coe_to_locally_bounded_map (hf : lipschitz_with K f) :
  ⇑(hf.to_locally_bounded_map f) = f :=
rfl

lemma comap_cobounded_le (hf : lipschitz_with K f) :
  comap f (bornology.cobounded β) ≤ bornology.cobounded α :=
(hf.to_locally_bounded_map f).2

lemma bounded_image (hf : lipschitz_with K f) {s : set α} (hs : metric.bounded s) :
  metric.bounded (f '' s) :=
metric.bounded_iff_ediam_ne_top.2 $ ne_top_of_le_ne_top
  (ennreal.mul_ne_top ennreal.coe_ne_top hs.ediam_ne_top) (hf.ediam_image_le s)

lemma diam_image_le (hf : lipschitz_with K f) (s : set α) (hs : metric.bounded s) :
  metric.diam (f '' s) ≤ K * metric.diam s :=
metric.diam_le_of_forall_dist_le (mul_nonneg K.coe_nonneg metric.diam_nonneg) $
  ball_image_iff.2 $ λ x hx, ball_image_iff.2 $ λ y hy, hf.dist_le_mul_of_le $
    metric.dist_le_diam_of_mem hs hx hy

protected lemma dist_left (y : α) : lipschitz_with 1 (λ x, dist x y) :=
lipschitz_with.of_le_add $ assume x z, by { rw [add_comm], apply dist_triangle }

protected lemma dist_right (x : α) : lipschitz_with 1 (dist x) :=
lipschitz_with.of_le_add $ assume y z, dist_triangle_right _ _ _

protected lemma dist : lipschitz_with 2 (function.uncurry $ @dist α _) :=
lipschitz_with.uncurry lipschitz_with.dist_left lipschitz_with.dist_right

lemma dist_iterate_succ_le_geometric {f : α → α} (hf : lipschitz_with K f) (x n) :
  dist (f^[n] x) (f^[n + 1] x) ≤ dist x (f x) * K ^ n :=
begin
  rw [iterate_succ, mul_comm],
  simpa only [nnreal.coe_pow] using (hf.iterate n).dist_le_mul x (f x)
end

lemma _root_.lipschitz_with_max : lipschitz_with 1 (λ p : ℝ × ℝ, max p.1 p.2) :=
lipschitz_with.of_le_add $ λ p₁ p₂, sub_le_iff_le_add'.1 $
  (le_abs_self _).trans (abs_max_sub_max_le_max _ _ _ _)

lemma _root_.lipschitz_with_min : lipschitz_with 1 (λ p : ℝ × ℝ, min p.1 p.2) :=
lipschitz_with.of_le_add $ λ p₁ p₂, sub_le_iff_le_add'.1 $
  (le_abs_self _).trans (abs_min_sub_min_le_max _ _ _ _)

end metric

section emetric

variables {α} [pseudo_emetric_space α] {f g : α → ℝ} {Kf Kg : ℝ≥0}

protected lemma max (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, max (f x) (g x)) :=
by simpa only [(∘), one_mul] using lipschitz_with_max.comp (hf.prod hg)

protected lemma min (hf : lipschitz_with Kf f) (hg : lipschitz_with Kg g) :
  lipschitz_with (max Kf Kg) (λ x, min (f x) (g x)) :=
by simpa only [(∘), one_mul] using lipschitz_with_min.comp (hf.prod hg)

lemma max_const (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, max (f x) a) :=
by simpa only [max_eq_left (zero_le Kf)] using hf.max (lipschitz_with.const a)

lemma const_max (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, max a (f x)) :=
by simpa only [max_comm] using hf.max_const a

lemma min_const (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, min (f x) a) :=
by simpa only [max_eq_left (zero_le Kf)] using hf.min (lipschitz_with.const a)

lemma const_min (hf : lipschitz_with Kf f) (a : ℝ) : lipschitz_with Kf (λ x, min a (f x)) :=
by simpa only [min_comm] using hf.min_const a

end emetric

protected lemma proj_Icc {a b : ℝ} (h : a ≤ b) :
  lipschitz_with 1 (proj_Icc a b h) :=
((lipschitz_with.id.const_min _).const_max _).subtype_mk _

end lipschitz_with

namespace metric

variables [pseudo_metric_space α] [pseudo_metric_space β] {s : set α} {t : set β}

lemma bounded.left_of_prod (h : bounded (s ×ˢ t)) (ht : t.nonempty) : bounded s :=
by simpa only [fst_image_prod s ht] using (@lipschitz_with.prod_fst α β _ _).bounded_image h

lemma bounded.right_of_prod (h : bounded (s ×ˢ t)) (hs : s.nonempty) : bounded t :=
by simpa only [snd_image_prod hs t] using (@lipschitz_with.prod_snd α β _ _).bounded_image h

lemma bounded_prod_of_nonempty (hs : s.nonempty) (ht : t.nonempty) :
  bounded (s ×ˢ t) ↔ bounded s ∧ bounded t :=
⟨λ h, ⟨h.left_of_prod ht, h.right_of_prod hs⟩, λ h, h.1.prod h.2⟩

lemma bounded_prod : bounded (s ×ˢ t) ↔ s = ∅ ∨ t = ∅ ∨ bounded s ∧ bounded t :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hs, { simp },
  rcases t.eq_empty_or_nonempty with rfl|ht, { simp },
  simp only [bounded_prod_of_nonempty hs ht, hs.ne_empty, ht.ne_empty, false_or]
end

end metric

namespace lipschitz_on_with

section emetric

variables [pseudo_emetric_space α] [pseudo_emetric_space β] [pseudo_emetric_space γ]
variables {K : ℝ≥0} {s : set α} {f : α → β}

protected lemma uniform_continuous_on (hf : lipschitz_on_with K f s) : uniform_continuous_on f s :=
uniform_continuous_on_iff_restrict.mpr (lipschitz_on_with_iff_restrict.mp hf).uniform_continuous

protected lemma continuous_on (hf : lipschitz_on_with K f s) : continuous_on f s :=
hf.uniform_continuous_on.continuous_on

lemma edist_lt_of_edist_lt_div (hf : lipschitz_on_with K f s) {x y : α} (hx : x ∈ s) (hy : y ∈ s)
  {d : ℝ≥0∞} (hd : edist x y < d / K) : edist (f x) (f y) < d :=
(lipschitz_on_with_iff_restrict.mp hf).edist_lt_of_edist_lt_div $
  show edist (⟨x, hx⟩ : s) ⟨y, hy⟩ < d / K, from hd

protected lemma comp {g : β → γ} {t : set β} {Kg : ℝ≥0} (hg : lipschitz_on_with Kg g t)
  (hf : lipschitz_on_with K f s) (hmaps : maps_to f s t) :
  lipschitz_on_with (Kg * K) (g ∘ f) s :=
lipschitz_on_with_iff_restrict.mpr $ hg.to_restrict.comp (hf.to_restrict_maps_to hmaps)

end emetric

section metric

variables [pseudo_metric_space α] [pseudo_metric_space β] [pseudo_metric_space γ]
variables {K : ℝ≥0} {s : set α} {f : α → β}

protected lemma of_dist_le' {K : ℝ} (h : ∀ (x ∈ s) (y ∈ s), dist (f x) (f y) ≤ K * dist x y) :
  lipschitz_on_with (real.to_nnreal K) f s :=
of_dist_le_mul $ λ x hx y hy, le_trans (h x hx y hy) $
  mul_le_mul_of_nonneg_right (real.le_coe_to_nnreal K) dist_nonneg

protected lemma mk_one (h : ∀ (x ∈ s) (y ∈ s), dist (f x) (f y) ≤ dist x y) :
  lipschitz_on_with 1 f s :=
of_dist_le_mul $ by simpa only [nnreal.coe_one, one_mul] using h

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
doesn't assume `0≤K`. -/
protected lemma of_le_add_mul' {f : α → ℝ} (K : ℝ)
  (h : ∀ (x ∈ s) (y ∈ s), f x ≤ f y + K * dist x y) :
  lipschitz_on_with (real.to_nnreal K) f s :=
have I : ∀ (x ∈ s) (y ∈ s), f x - f y ≤ K * dist x y,
  from assume x hx y hy, sub_le_iff_le_add'.2 (h x hx y hy),
lipschitz_on_with.of_dist_le' $
assume x hx y hy,
abs_sub_le_iff.2 ⟨I x hx y hy, dist_comm y x ▸ I y hy x hx⟩

/-- For functions to `ℝ`, it suffices to prove `f x ≤ f y + K * dist x y`; this version
assumes `0≤K`. -/
protected lemma of_le_add_mul {f : α → ℝ} (K : ℝ≥0)
  (h : ∀ (x ∈ s) (y ∈ s), f x ≤ f y + K * dist x y) :
  lipschitz_on_with K f s :=
by simpa only [real.to_nnreal_coe] using lipschitz_on_with.of_le_add_mul' K h

protected lemma of_le_add {f : α → ℝ} (h : ∀ (x ∈ s) (y ∈ s), f x ≤ f y + dist x y) :
  lipschitz_on_with 1 f s :=
lipschitz_on_with.of_le_add_mul 1 $ by simpa only [nnreal.coe_one, one_mul]

protected lemma le_add_mul {f : α → ℝ} {K : ℝ≥0} (h : lipschitz_on_with K f s)
  {x : α} (hx : x ∈ s) {y : α} (hy : y ∈ s) :
  f x ≤ f y + K * dist x y :=
sub_le_iff_le_add'.1 $ le_trans (le_abs_self _) $ h.dist_le_mul x hx y hy

protected lemma iff_le_add_mul {f : α → ℝ} {K : ℝ≥0} :
  lipschitz_on_with K f s ↔ ∀ (x ∈ s) (y ∈ s), f x ≤ f y + K * dist x y :=
⟨lipschitz_on_with.le_add_mul, lipschitz_on_with.of_le_add_mul K⟩

end metric

end lipschitz_on_with

/-- Consider a function `f : α × β → γ`. Suppose that it is continuous on each “vertical fiber”
`{a} × t`, `a ∈ s`, and is Lipschitz continuous on each “horizontal fiber” `s × {b}`, `b ∈ t`
with the same Lipschitz constant `K`. Then it is continuous on `s × t`.

The actual statement uses (Lipschitz) continuity of `λ y, f (a, y)` and `λ x, f (x, b)` instead
of continuity of `f` on subsets of the product space. -/
lemma continuous_on_prod_of_continuous_on_lipschitz_on [pseudo_emetric_space α]
  [topological_space β] [pseudo_emetric_space γ] (f : α × β → γ) {s : set α} {t : set β}
  (K : ℝ≥0) (ha : ∀ a ∈ s, continuous_on (λ y, f (a, y)) t)
  (hb : ∀ b ∈ t, lipschitz_on_with K (λ x, f (x, b)) s) :
  continuous_on f (s ×ˢ t) :=
begin
  rintro ⟨x, y⟩ ⟨hx : x ∈ s, hy : y ∈ t⟩,
  refine emetric.tendsto_nhds.2 (λ ε (ε0 : 0 < ε), _),
  replace ε0 : 0 < ε / 2 := ennreal.half_pos (ne_of_gt ε0),
  have εK : 0 < ε / 2 / K := ennreal.div_pos_iff.2 ⟨ε0.ne', ennreal.coe_ne_top⟩,
  have A : s ∩ emetric.ball x (ε / 2 / K) ∈ 𝓝[s] x :=
    inter_mem_nhds_within _ (emetric.ball_mem_nhds _ εK),
  have B : {b : β | b ∈ t ∧ edist (f (x, b)) (f (x, y)) < ε / 2} ∈ 𝓝[t] y :=
    inter_mem self_mem_nhds_within (ha x hx y hy (emetric.ball_mem_nhds _ ε0)),
  filter_upwards [nhds_within_prod A B],
  rintro ⟨a, b⟩ ⟨⟨has : a ∈ s, hax : edist a x < ε / 2 / K⟩,
    hbt : b ∈ t, hby : edist (f (x, b)) (f (x, y)) < ε / 2⟩,
  calc edist (f (a, b)) (f (x, y)) ≤ edist (f (a, b)) (f (x, b)) + edist (f (x, b)) (f (x, y)) :
    edist_triangle _ _ _
  ... < ε / 2 + ε / 2 : ennreal.add_lt_add ((hb _ hbt).edist_lt_of_edist_lt_div has hx hax) hby
  ... = ε : ennreal.add_halves ε
end

/-- Consider a function `f : α × β → γ`. Suppose that it is continuous on each “vertical section”
`{a} × univ`, `a : α`, and is Lipschitz continuous on each “horizontal section”
`univ × {b}`, `b : β` with the same Lipschitz constant `K`. Then it is continuous.

The actual statement uses (Lipschitz) continuity of `λ y, f (a, y)` and `λ x, f (x, b)` instead
of continuity of `f` on subsets of the product space. -/
lemma continuous_prod_of_continuous_lipschitz [pseudo_emetric_space α]
  [topological_space β] [pseudo_emetric_space γ] (f : α × β → γ) (K : ℝ≥0)
  (ha : ∀ a, continuous (λ y, f (a, y))) (hb : ∀ b, lipschitz_with K (λ x, f (x, b))) :
  continuous f :=
begin
  simp only [continuous_iff_continuous_on_univ, ← univ_prod_univ, ← lipschitz_on_univ] at *,
  exact continuous_on_prod_of_continuous_on_lipschitz_on f K (λ a _, ha a) (λ b _, hb b)
end

open metric

/-- If a function is locally Lipschitz around a point, then it is continuous at this point. -/
lemma continuous_at_of_locally_lipschitz [pseudo_metric_space α] [pseudo_metric_space β]
  {f : α → β} {x : α}
  {r : ℝ} (hr : 0 < r) (K : ℝ) (h : ∀ y, dist y x < r → dist (f y) (f x) ≤ K * dist y x) :
  continuous_at f x :=
begin
  -- We use `h` to squeeze `dist (f y) (f x)` between `0` and `K * dist y x`
  refine tendsto_iff_dist_tendsto_zero.2
    (squeeze_zero' (eventually_of_forall $ λ _, dist_nonneg)
    (mem_of_superset (ball_mem_nhds _ hr) h) _),
  -- Then show that `K * dist y x` tends to zero as `y → x`
  refine (continuous_const.mul (continuous_id.dist continuous_const)).tendsto' _ _ _,
  simp
end

/-- A function `f : α → ℝ` which is `K`-Lipschitz on a subset `s` admits a `K`-Lipschitz extension
to the whole space. -/
lemma lipschitz_on_with.extend_real [pseudo_metric_space α] {f : α → ℝ} {s : set α} {K : ℝ≥0}
  (hf : lipschitz_on_with K f s) :
  ∃ g : α → ℝ, lipschitz_with K g ∧ eq_on f g s :=
begin
  /- An extension is given by `g y = Inf {f x + K * dist y x | x ∈ s}`. Taking `x = y`, one has
  `g y ≤ f y` for `y ∈ s`, and the other inequality holds because `f` is `K`-Lipschitz, so that it
  can not counterbalance the growth of `K * dist y x`. One readily checks from the formula that the
  extended function is also `K`-Lipschitz. -/
  rcases eq_empty_or_nonempty s with rfl|hs,
  { exact ⟨λ x, 0, (lipschitz_with.const _).weaken (zero_le _), eq_on_empty _ _⟩ },
  haveI : nonempty s, by simp only [hs, nonempty_coe_sort],
  let g := λ (y : α), infi (λ (x : s), f x + K * dist y x),
  have B : ∀ (y : α), bdd_below (range (λ (x : s), f x + K * dist y x)),
  { assume y,
    rcases hs with ⟨z, hz⟩,
    refine ⟨f z - K * dist y z, _⟩,
    rintros w ⟨t, rfl⟩,
    dsimp,
    rw [sub_le_iff_le_add, add_assoc, ← mul_add, add_comm (dist y t)],
    calc f z ≤ f t + K * dist z t : hf.le_add_mul hz t.2
      ... ≤ f t + K * (dist y z + dist y t) :
        add_le_add_left (mul_le_mul_of_nonneg_left (dist_triangle_left _ _ _) K.2) _ },
  have E : eq_on f g s,
  { assume x hx,
    refine le_antisymm (le_cinfi (λ y, hf.le_add_mul hx y.2)) _,
    simpa only [add_zero, subtype.coe_mk, mul_zero, dist_self] using cinfi_le (B x) ⟨x, hx⟩ },
  refine ⟨g, lipschitz_with.of_le_add_mul K (λ x y, _), E⟩,
  rw ← sub_le_iff_le_add,
  refine le_cinfi (λ z, _),
  rw sub_le_iff_le_add,
  calc g x ≤ f z + K * dist x z : cinfi_le (B x) _
  ... ≤ f z + K * dist y z + K * dist x y :
    begin
      rw [add_assoc, ← mul_add, add_comm (dist y z)],
      exact add_le_add_left (mul_le_mul_of_nonneg_left (dist_triangle _ _ _) K.2) _,
    end
end

/-- A function `f : α → (ι → ℝ)` which is `K`-Lipschitz on a subset `s` admits a `K`-Lipschitz
extension to the whole space.
TODO: state the same result (with the same proof) for the space `ℓ^∞ (ι, ℝ)` over a possibly
infinite type `ι`. -/
lemma lipschitz_on_with.extend_pi [pseudo_metric_space α] [fintype ι]
  {f : α → (ι → ℝ)} {s : set α} {K : ℝ≥0}
  (hf : lipschitz_on_with K f s) :
  ∃ g : α → (ι → ℝ), lipschitz_with K g ∧ eq_on f g s :=
begin
  have : ∀ i, ∃ g : α → ℝ, lipschitz_with K g ∧ eq_on (λ x, f x i) g s,
  { assume i,
    have : lipschitz_on_with K (λ (x : α), f x i) s,
    { apply lipschitz_on_with.of_dist_le_mul (λ x hx y hy, _),
      exact (dist_le_pi_dist _ _ i).trans (hf.dist_le_mul x hx y hy) },
    exact this.extend_real },
  choose g hg using this,
  refine ⟨λ x i, g i x, lipschitz_with.of_dist_le_mul (λ x y, _), _⟩,
  { exact (dist_pi_le_iff (mul_nonneg K.2 dist_nonneg)).2 (λ i, (hg i).1.dist_le_mul x y) },
  { assume x hx,
    ext1 i,
    exact (hg i).2 hx }
end