import topology.instances.real
import topology.basic
import topology.algebra.group
import tactic

open_locale filter topological_space
open filter

notation `|` x `|` := abs x

/-
First, we shall define the definition of convergence of a sequence. mathlib uses filters, so
we will show the filter statement and the common definition are in fact equivalent. We state the
theorems in terms of filters so that we can use the lemmas from mathlib as well when we don't want
to prove them.

NB: This is in mathlib as `metric.tendsto_at_top`
-/
lemma tendsto_seq_iff (x : ℕ → ℝ) (c : ℝ) :
  tendsto x at_top (𝓝 c) ↔ ∀ ε > 0, ∃ N, ∀ n ≥ N, |x n - c| < ε :=
begin
  split,
  { rintros h ε (hε : 0 < ε),
    let S := set.Ioo (c - ε) (c + ε),
    have hS : S ∈ 𝓝 c,
    { apply Ioo_mem_nhds;
      linarith },
    rw tendsto_def at h,
    specialize h S hS,
    rw mem_at_top_sets at h,
    cases h with N hN,
    use N,
    intros n hn,
    specialize hN n hn,
    cases hN with h1 h2,
    rw abs_lt,
    split;
    linarith },
  { intros h S hS,
    rw mem_nhds_iff_exists_Ioo_subset at hS,
    rcases hS with ⟨l, u, ⟨h1, h2⟩, h3⟩,
    let ε := min (c - l) (u - c),
    have hε : 0 < ε,
    { apply lt_min;
      linarith },
    cases h ε hε with N hN,
    rw [mem_map, mem_at_top_sets],
    use N,
    intros n hn,
    specialize hN n hn,
    rw abs_lt at hN,
    cases hN,
    apply h3,
    split,
    { have : ε ≤ c - l,
      { exact min_le_left _ _ },
      linarith },
    { have : ε ≤ u - c,
      { exact min_le_right _ _ },
      linarith } }
end .

/-
Definition of the Supremum

stuff
-/

/--
We say that a sequence xₙ is convergent if there exists a such that xₙ → a as n → ∞
-/
def is_convergent (x : ℕ → ℝ) := ∃ a, tendsto x at_top (𝓝 a)

lemma is_convergent_of_increasing_of_bdd_above {x : ℕ → ℝ} (A : ℝ) (hx₁ : ∀ n, x n ≤ x (n + 1))
  (hx₂ : ∀ n, x n ≤ A) : is_convergent x :=
begin
  set c := Sup (x '' set.univ) with hc,
  use c,
  rw tendsto_seq_iff,
  intros ε hε,
  have : ∃ N, c - ε < x N,
  { by_contra h,
    push_neg at h,
    have := @real.Sup_le_ub (x '' set.univ) _ (c - ε) _,
    { linarith },
    use [x 0, 0, set.mem_univ 0],
    rintros y ⟨N, hN₁, rfl⟩,
    apply h },
  cases this with N hN,
  use N,
  intros n hn,
  have hxn : x N ≤ x n,
  { exact monotone_of_monotone_nat hx₁ hn },
  have hxn' : x n ≤ c,
  { apply real.le_Sup _ _ _,
    { use A,
      rintros y ⟨k, hk, rfl⟩,
      apply hx₂ },
    use [n, set.mem_univ n] },
  rw abs_sub_lt_iff,
  split;
  linarith
end

lemma is_convergent_of_decreasing_of_bdd_below {x : ℕ → ℝ} (A : ℝ) (hx₁ : ∀ n, x (n + 1) ≤ x n)
  (hx₂ : ∀ n, A ≤ x n) : is_convergent x :=
begin
  set c := Inf (x '' set.univ) with hc,
  use c,
  rw tendsto_seq_iff,
  intros ε hε,
  have : ∃ N, x N < c + ε,
  { by_contra h,
    push_neg at h,
    have := @real.lb_le_Inf (x '' set.univ) _ (c + ε) _,
    { linarith },
    use [x 0, 0, set.mem_univ 0],
    rintros y ⟨N, hN₁, rfl⟩,
    apply h },
  cases this with N hN,
  use N,
  intros n hn,
  have hxn : x n ≤ x N,
  { induction hn with k ih₁ ih₂,
    { refl },
    { exact le_trans (hx₁ _) ih₂ } },
  have hxn' : c ≤ x n,
  { apply real.Inf_le,
    { use A,
      rintros y ⟨k, hk, rfl⟩,
      apply hx₂ },
    use [n, set.mem_univ n] },
  rw abs_sub_lt_iff,
  split;
  linarith
end

/-
Lemma 1.1 (i)

Limits are unique. If xₙ → a and xₙ → b, then a = b
-/
lemma tendsto_at_top_nhds_unique {x : ℕ → ℝ} {a b : ℝ} (ha : tendsto x at_top (𝓝 a))
  (hb : tendsto x at_top (𝓝 b)) : a = b :=
begin
  have key : ∀ ε > 0, |a - b| ≤ 2 * ε,
  { rintros ε (hε : 0 < ε),
    rw tendsto_seq_iff at *,
    cases ha ε hε with N₁ hN₁,
    cases hb ε hε with N₂ hN₂,
    let N := max N₁ N₂,
    specialize hN₁ N (le_max_left _ _),
    specialize hN₂ N (le_max_right _ _),
    rw [show a - b = (a - x N) + (x N - b), by ring],
    refine le_trans (abs_add _ _) _,
    rw abs_sub,
    linarith },
  by_contra hc,
  set ε := |a - b|/3 with hεdef,
  have hab: 0 < |a - b|,
  { rwa [abs_pos, sub_ne_zero] },
  have hε : 0 < ε,
  { linarith },
  specialize key ε hε,
  rw hεdef at key,
  linarith,
end

-- A useful lemma for strictly inceasing sequences
lemma le_of_nat_strict_mono {n : ℕ → ℕ} (hn : ∀ i, n i < n (i + 1)) (k : ℕ) : k ≤ n k :=
begin
  induction k with d ih,
  { exact nat.zero_le _ },
  { exact lt_of_le_of_lt ih (hn _) }
end

/-
Lemma 1.1 (ii)

If xₙ → a, and x_{n_j} is a subsequence, then it will also tend to a
-/
lemma tendsto_subseq {x : ℕ → ℝ} {a : ℝ} {n : ℕ → ℕ} (hn : ∀ k, n k < n (k+1))
  (hx : tendsto x at_top (𝓝 a)) : tendsto (x ∘ n) at_top (𝓝 a) :=
begin
  rw tendsto_seq_iff at *,
  intros ε hε,
  cases hx ε hε with N hN,
  use N,
  intros k hk,
  rw function.comp_apply,
  apply hN,
  exact le_trans hk (le_of_nat_strict_mono hn _),
end

/-
Lemma 1.1 (iii)

If xₙ = c for all n, then xₙ → c

NB: This is in mathlib as `tensto_const_nhds`
-/
lemma tendsto_const_at_top {c : ℝ} :
  tendsto (λ n : ℕ, c) at_top (𝓝 c) :=
begin
  intros s hs,
  rw [mem_map, mem_at_top_sets],
  use 0,
  intros b hb,
  rw set.mem_set_of_eq,
  exact mem_of_nhds hs
end

/-
Lemma 1.1 (iv)

If xₙ → a and yₙ → b, then xₙ + yₙ → a + b

NB: This is in mathlib as `filter.tendsto.add`
-/
lemma tendsto_add_at_top_nhds {x y : ℕ → ℝ} {a b : ℝ} (hx : tendsto x at_top (𝓝 a))
  (hy : tendsto y at_top (𝓝 b)) : tendsto (x + y) at_top (𝓝 (a + b)) :=
begin
  rw tendsto_seq_iff at *,
  intros ε hε,
  cases hx (ε/2) (half_pos hε) with N₁ hN₁,
  cases hy (ε/2) (half_pos hε) with N₂ hN₂,
  use max N₁ N₂,
  intros n hn,
  specialize hN₁ n (le_trans (le_max_left _ _) hn),
  specialize hN₂ n (le_trans (le_max_right _ _) hn),
  rw [pi.add_apply, show x n + y n - (a + b) = (x n - a) + (y n - b), by ring],
  refine lt_of_le_of_lt (abs_add _ _) _,
  linarith,
end

/-
Lemma 1.1 (v)

If xₙ → a and yₙ → b, then xₙyₙ → ab

NB: This is in mathlib as `filter.tendsto.mul`
-/
lemma tendsto_mul_at_top_nhds {x y : ℕ → ℝ} {a b : ℝ} (hx : tendsto x at_top (𝓝 a))
  (hy : tendsto y at_top (𝓝 b)) : tendsto (x * y) at_top (𝓝 (a * b)) :=
begin
  rw tendsto_seq_iff at *,
  intros ε hε,
  have h1 : 0 < |a| + |b| + 1,
  { linarith [abs_nonneg a, abs_nonneg b] },
  have hε' : 0 < ε / (|a| + |b| + 1) := div_pos hε h1,
  cases hx 1 zero_lt_one with N₁ hN₁,
  cases hx _ hε' with N₂ hN₂,
  cases hy _ hε' with N₃ hN₃,
  use max (max N₁ N₂) N₃,
  intros n hn,
  rw [pi.mul_apply, show x n * y n - a * b = x n * (y n - b) + (x n - a) * b, by ring],
  refine lt_of_le_of_lt (abs_add _ _) _,
  rw [abs_mul, abs_mul],
  specialize hN₁ n (le_trans (le_max_left _ _) (le_trans (le_max_left (max N₁ N₂) N₃) hn)),
  specialize hN₂ n (le_trans (le_max_right _ _) (le_trans (le_max_left (max N₁ N₂) N₃) hn)),
  specialize hN₃ n (le_trans (le_max_right _ _) hn),
  have : |x n| < |a| + 1,
  { rw abs_lt at hN₁ ⊢,
    cases hN₁ with h1 h2,
    by_cases ha : 0 ≤ a,
    { rw abs_of_nonneg ha,
      split; linarith },
    { rw not_le at ha,
      rw abs_of_neg ha,
      split; linarith } },
  calc |x n| * |y n - b| + |x n - a| * |b| ≤ (|a| + 1) * |y n - b| + |x n - a| * |b| : _
                                       ... < (|a| + 1) * (ε / (|a| + |b| + 1)) + ε / (|a| + |b| + 1) * |b| : _
                                       ... = ε : _,
  { apply add_le_add_right,
    apply mul_le_mul,
    { exact le_of_lt this },
    { refl },
    { exact abs_nonneg _ },
    { linarith [abs_nonneg a] } },
  { apply add_lt_add_of_lt_of_le,
    { rwa mul_lt_mul_left,
      linarith [abs_nonneg a] },
    { apply mul_le_mul,
      { exact le_of_lt hN₂ },
      { refl },
      { exact abs_nonneg _ },
      { exact le_of_lt (lt_of_le_of_lt (abs_nonneg _) hN₂) } } },
    { field_simp,
      apply div_eq_of_eq_mul,
      { linarith },
      ring }
end .

/-
Lemma 1.1 (vi)

If xₙ → a, ∀ n, xₙ ≠ 0, a ≠ 0 then 1/aₙ → 1/a

NB: This is in mathlib as `filter.tendsto.inv`
-/
lemma tendsto_inv_at_top_nhds {x : ℕ → ℝ} {a : ℝ} (hx₁ : ∀ n, x n ≠ 0) (ha : a ≠ 0)
  (hx₂ : tendsto x at_top (𝓝 a)) : tendsto x⁻¹ at_top (𝓝 a⁻¹) :=
begin
  rw tendsto_seq_iff at *,
  intros ε hε,
  have hε' : 0 < |a|^2 * ε / 2,
  { apply div_pos,
    { apply mul_pos,
      { apply pow_two_pos_of_ne_zero,
        apply ne_of_gt,
        apply abs_pos.mpr ‹_› },
      { exact hε } },
    { norm_num } },
  cases hx₂ (|a|/2) (div_pos (abs_pos.mpr ha) zero_lt_two) with N₁ hN₁,
  have hN₁ : ∀ n ≥ N₁, |a|/2 ≤ |x n|,
  { intros n hn,
    specialize hN₁ n hn,
    rw abs_sub_lt_iff at hN₁,
    by_cases hx : 0 ≤ x n; [rw abs_of_nonneg hx at *, { rw not_le at hx, rw abs_of_neg hx at * }];
    { by_cases ha' : 0 ≤ a,
      { rw [abs_of_nonneg ha'] at *,
        linarith },
      { rw [not_le] at ha',
        rw [abs_of_neg ha'] at *,
        linarith } } },
  cases hx₂ _ hε' with N₂ hN₂,
  use max N₁ N₂,
  intros n hn,
  specialize hN₁ n (le_of_max_le_left hn),
  rw div_le_iff at hN₁,
  specialize hN₂ n (le_of_max_le_right hn),
  rw [pi.inv_apply, inv_sub_inv (hx₁ _) ha, abs_div, abs_sub, div_lt_iff, abs_mul],
  calc |x n - a| < |a|^2 * ε / 2 : hN₂
             ... ≤ ε * (|x n| * |a|) : _,
  rwa [div_le_iff, pow_two, mul_comm, mul_assoc, mul_le_mul_left hε, mul_right_comm,
      mul_le_mul_right (abs_pos.mpr ha)],
  { norm_num },
  { rw abs_mul,
    apply mul_pos,
    { exact abs_pos.mpr (hx₁ n) },
    { exact abs_pos.mpr ha } },
  { norm_num },
end .

/-
Lemma 1.1 (vii)

If xₙ ≤ A, and xₙ → a, then a ≤ A
-/
lemma tendsto_lim_le_of_le {x : ℕ → ℝ} {a A : ℝ} (hx₁ : ∀ n, x n ≤ A)
  (hx₂ : tendsto x at_top (𝓝 a)) : a ≤ A :=
begin
  by_contra h,
  rw not_le at h,
  set ε := a - A with hε,
  have hε' : 0 < ε,
  { linarith },
  rw tendsto_seq_iff at hx₂,
  specialize hx₂ ε hε',
  cases hx₂ with N hN,
  specialize hN N (le_refl _),
  rw abs_sub_lt_iff at hN,
  cases hN,
  specialize hx₁ N,
  linarith,
end

/-
Lemma 1.2

1/n → 0
-/
lemma tendsto_one_div : tendsto (λ n, 1/(n + 1) : ℕ → ℝ) at_top (𝓝 0) :=
begin
  have h1 : ∃ a, tendsto (λ n, 1/(n + 1) : ℕ → ℝ) at_top (𝓝 a) := is_convergent_of_decreasing_of_bdd_below 0 _ _,
  cases h1 with a ha,
  have h2 : tendsto (λ n, 1/2 * (1/(n+1)) : ℕ → ℝ) at_top (𝓝 (1/2 * a)),
  { apply filter.tendsto.mul,
    { exact tendsto_const_nhds },
    { exact ha } },
  have h3 : tendsto (λ n, 1/2 * (1/(n+1)) : ℕ → ℝ) at_top (𝓝 a),
  { have : (λ n, 1/2 * (1/(n+1) : ℝ) : ℕ → ℝ) = (λ n, 1/(n + 1) : ℕ → ℝ) ∘ (λ n, 2 * n + 1 : ℕ → ℕ),
    { ext n,
      simp only [←mul_inv', mul_add, one_div, mul_one, nat.cast_bit0, inv_inj', nat.cast_add, nat.cast_one, nat.cast_mul],
      linarith, },
    rw this,
    apply tendsto_subseq,
    { intro k, omega },
    { exact ha } },
  have h4 : a = 1/2 * a,
  { exact tendsto_at_top_nhds_unique h3 h2 },
  have h5 : a = 0,
  { linarith },
  rw h5 at *,
  exact ha,
  { intro n,
    rw one_div_le_one_div,
    { norm_num },
    { linarith [@nat.cast_add ℝ _ _ n 1, @nat.cast_one ℝ _ _, @nat.cast_nonneg ℝ _ n] },
    { linarith [@nat.cast_nonneg ℝ _ n] } },
  intro n,
  apply le_of_lt,
  apply div_pos,
  { exact zero_lt_one },
  { linarith [@nat.cast_nonneg ℝ _ n] },
end .

/-
Remark: The definition of convergence of a sequence holds just as well for ℂ as it does for ℝ, that
is, we can define the convergence of xₙ ∈ ℂ just as well as xₙ ∈ ℝ
-/


import Chap3
namespace HTPI
set_option pp.funBinderTypes true

/- Definitions -/
def Dom {A B : Type} (R : Set (A × B)) : Set A :=
  { a : A | ∃ (b : B), (a, b) ∈ R }

def Ran {A B : Type} (R : Set (A × B)) : Set B :=
  { b : B | ∃ (a : A), (a, b) ∈ R }

def inv {A B : Type} (R : Set (A × B)) : Set (B × A) :=
  { (b, a) : B × A | (a, b) ∈ R }

def comp {A B C : Type}
    (S : Set (B × C)) (R : Set (A × B)) : Set (A × C) :=
  { (a, c) : A × C | ∃ (x : B), (a, x) ∈ R ∧ (x, c) ∈ S }

def extension {A B : Type} (R : Rel A B) : Set (A × B) :=
  { (a, b) : A × B | R a b }

def reflexive {A : Type} (R : BinRel A) : Prop :=
  ∀ (x : A), R x x

def symmetric {A : Type} (R : BinRel A) : Prop :=
  ∀ (x y : A), R x y → R y x

def transitive {A : Type} (R : BinRel A) : Prop :=
  ∀ (x y z : A), R x y → R y z → R x z

def elementhood (A : Type) (a : A) (X : Set A) : Prop := a ∈ X

def RelFromExt {A B : Type}
  (R : Set (A × B)) (a : A) (b : B) : Prop := (a, b) ∈ R

def antisymmetric {A : Type} (R : BinRel A) : Prop :=
  ∀ (x y : A), R x y → R y x → x = y

def partial_order {A : Type} (R : BinRel A) : Prop :=
  reflexive R ∧ transitive R ∧ antisymmetric R

def total_order {A : Type} (R : BinRel A) : Prop :=
  partial_order R ∧ ∀ (x y : A), R x y ∨ R y x

def sub (A : Type) (X Y : Set A) : Prop := X ⊆ Y

def smallestElt {A : Type} (R : BinRel A) (b : A) (B : Set A) : Prop :=
  b ∈ B ∧ ∀ x ∈ B, R b x

def minimalElt {A : Type} (R : BinRel A) (b : A) (B : Set A) : Prop :=
  b ∈ B ∧ ¬∃ x ∈ B, R x b ∧ x ≠ b

def upperBd {A : Type} (R : BinRel A) (a : A) (B : Set A) : Prop :=
  ∀ x ∈ B, R x a

def lub {A : Type} (R : BinRel A) (a : A) (B : Set A) : Prop :=
  smallestElt R a { c : A | upperBd R c B }

def equiv_rel {A : Type} (R : BinRel A) : Prop :=
  reflexive R ∧ symmetric R ∧ transitive R

def equivClass {A : Type} (R : BinRel A) (x : A) : Set A :=
  { y : A | R y x }

def mod (A : Type) (R : BinRel A) : Set (Set A) :=
  { equivClass R x | x : A }

def empty {A : Type} (X : Set A) : Prop := ¬∃ (x : A), x ∈ X

def pairwise_disjoint {A : Type} (F : Set (Set A)) : Prop :=
  ∀ X ∈ F, ∀ Y ∈ F, X ≠ Y → empty (X ∩ Y)

def partition {A : Type} (F : Set (Set A)) : Prop :=
  (∀ (x : A), x ∈ ⋃₀ F) ∧ pairwise_disjoint F ∧ ∀ X ∈ F, ¬empty X

def EqRelFromPart {A : Type} (F : Set (Set A)) (x y : A) : Prop :=
  ∃ X ∈ F, x ∈ X ∧ y ∈ X

/- Section 4.2 -/
theorem Theorem_4_2_5_1 {A B : Type}
    (R : Set (A × B)) : inv (inv R) = R := by rfl

theorem Theorem_4_2_5_2 {A B : Type}
    (R : Set (A × B)) : Dom (inv R) = Ran R := by rfl

theorem Theorem_4_2_5_3 {A B : Type}
    (R : Set (A × B)) : Ran (inv R) = Dom R := by rfl

theorem Theorem_4_2_5_4 {A B C D : Type}
    (R : Set (A × B)) (S : Set (B × C)) (T : Set (C × D)) :
    comp T (comp S R) = comp (comp T S) R := by
  apply Set.ext
  fix (a, d) : A × D
  apply Iff.intro
  · -- (→)
    assume h1 : (a, d) ∈ comp T (comp S R)
                     --Goal : (a, d) ∈ comp (comp T S) R
    define           --Goal : ∃ (x : B), (a, x) ∈ R ∧ (x, d) ∈ comp T S
    define at h1     --h1 : ∃ (x : C), (a, x) ∈ comp S R ∧ (x, d) ∈ T
    obtain (c : C) (h2 : (a, c) ∈ comp S R ∧ (c, d) ∈ T) from h1
    have h3 : (a, c) ∈ comp S R := h2.left
    define at h3     --h3 : ∃ (x : B), (a, x) ∈ R ∧ (x, c) ∈ S
    obtain (b : B) (h4 : (a, b) ∈ R ∧ (b, c) ∈ S) from h3
    apply Exists.intro b    --Goal : (a, b) ∈ R ∧ (b, d) ∈ comp T S
    apply And.intro h4.left --Goal : (b, d) ∈ comp T S
    define                  --Goal : ∃ (x : C), (b, x) ∈ S ∧ (x, d) ∈ T
    show ∃ (x : C), (b, x) ∈ S ∧ (x, d) ∈ T from
      Exists.intro c (And.intro h4.right h2.right)
    done
  · -- (←)
    assume h1 : (a, d) ∈ comp (comp T S) R
    define; define at h1
    obtain (b : B) (h2 : (a, b) ∈ R ∧ (b, d) ∈ comp T S) from h1
    have h3 : (b, d) ∈ comp T S := h2.right
    define at h3
    obtain (c : C) (h4 : (b, c) ∈ S ∧ (c, d) ∈ T) from h3
    apply Exists.intro c
    apply And.intro _ h4.right
    define
    show ∃ (x : B), (a, x) ∈ R ∧ (x, c) ∈ S from
      Exists.intro b (And.intro h2.left h4.left)
    done
  done

theorem inv_def {A B : Type} (R : Set (A × B)) (a : A) (b : B) :
    (b, a) ∈ inv R ↔ (a, b) ∈ R := by rfl

theorem Theorem_4_2_5_5 {A B C : Type}
    (R : Set (A × B)) (S : Set (B × C)) :
    inv (comp S R) = comp (inv R) (inv S) := by
  apply Set.ext
  fix (c, a) : C × A
  apply Iff.intro
  · -- (→)
    assume h1 : (c, a) ∈ inv (comp S R)
                      --Goal : (c, a) ∈ comp (inv R) (inv S)
    define at h1      --h1 : ∃ (x : B), (a, x) ∈ R ∧ (x, c) ∈ S
    define            --Goal : ∃ (x : B), (c, x) ∈ inv S ∧ (x, a) ∈ inv R
    obtain (b : B) (h2 : (a, b) ∈ R ∧ (b, c) ∈ S) from h1
    apply Exists.intro b         --Goal : (c, b) ∈ inv S ∧ (b, a) ∈ inv R
    rewrite [inv_def, inv_def] --Goal : (b, c) ∈ S ∧ (a, b) ∈ R
    show (b, c) ∈ S ∧ (a, b) ∈ R from And.intro h2.right h2.left
    done
  · -- (←)
    assume h1 : (c, a) ∈ comp (inv R) (inv S)
    define at h1
    define
    obtain (b : B) (h2 : (c, b) ∈ inv S ∧ (b, a) ∈ inv R) from h1
    apply Exists.intro b
    rewrite [inv_def, inv_def] at h2
    show (a, b) ∈ R ∧ (b, c) ∈ S from And.intro h2.right h2.left
    done
  done

/- Section 4.3 -/
theorem ext_def {A B : Type} (R : Rel A B) (a : A) (b : B) :
    (a, b) ∈ extension R ↔ R a b := by rfl

theorem Theorem_4_3_4_2 {A : Type} (R : BinRel A) :
    symmetric R ↔ extension R = inv (extension R) := by
  apply Iff.intro
  · -- (→)
    assume h1 : symmetric R
    define at h1             --h1 : ∀ (x y : A), R x y → R y x
    apply Set.ext
    fix (a, b) : A × A
    show (a, b) ∈ extension R ↔ (a, b) ∈ inv (extension R) from
      calc (a, b) ∈ extension R
        _ ↔ R a b := by rfl
        _ ↔ R b a := Iff.intro (h1 a b) (h1 b a)
        _ ↔ (a, b) ∈ inv (extension R) := by rfl
    done
  · -- (←)
    assume h1 : extension R = inv (extension R)
    define                   --Goal : ∀ (x y : A), R x y → R y x
    fix a : A; fix b : A
    assume h2 : R a b        --Goal : R b a
    rewrite [←ext_def R, h1, inv_def, ext_def] at h2
    show R b a from h2
    done
  done

theorem RelFromExt_def {A B : Type}
    (R : Set (A × B)) (a : A) (b : B) :
    RelFromExt R a b ↔ (a, b) ∈ R := by rfl

example {A B : Type} (R : Rel A B) :
    RelFromExt (extension R) = R := by rfl

example {A B : Type} (R : Set (A × B)) :
    extension (RelFromExt R) = R := by rfl

/- Section 4.4 -/
theorem Theorem_4_4_6_2 {A : Type} (R : BinRel A) (B : Set A) (b : A)
    (h1 : partial_order R) (h2 : smallestElt R b B) :
    minimalElt R b B ∧ ∀ (c : A), minimalElt R c B → b = c := by
  define at h1     --h1 : reflexive R ∧ transitive R ∧ antisymmetric R
  define at h2     --h2 : b ∈ B ∧ ∀ (x : A), x ∈ B → R b x
  apply And.intro
  · -- Proof that b is minimal
    define           --Goal : b ∈ B ∧ ¬∃ (x : A), x ∈ B ∧ R x b ∧ x ≠ b
    apply And.intro h2.left
    quant_neg        --Goal : ∀ (x : A), ¬(x ∈ B ∧ R x b ∧ x ≠ b)
    fix x : A
    demorgan         --Goal : ¬x ∈ B ∨ ¬(R x b ∧ x ≠ b)
    or_right with h3 --h3 : x ∈ B; Goal : ¬(R x b ∧ x ≠ b)
    demorgan         --Goal : ¬R x b ∨ x = b
    or_right with h4 --h4 : R x b; Goal : x = b
    have h5 : R b x := h2.right x h3
    have h6 : antisymmetric R := h1.right.right
    define at h6     --h6 : ∀ (x y : A), R x y → R y x → x = y
    show x = b from h6 x b h4 h5
    done
  · -- Proof that b is only minimal element
    fix c : A
    assume h3 : minimalElt R c B
    define at h3    --h3 : c ∈ B ∧ ¬∃ (x : A), x ∈ B ∧ R x c ∧ x ≠ c
    contradict h3.right with h4
                  --h4 : ¬b = c; Goal : ∃ (x : A), x ∈ B ∧ R x c ∧ x ≠ c
    have h5 : R b c := h2.right c h3.left
    show ∃ (x : A), x ∈ B ∧ R x c ∧ x ≠ c from
      Exists.intro b (And.intro h2.left (And.intro h5 h4))
    done
  done

theorem Theorem_4_4_6_3 {A : Type} (R : BinRel A) (B : Set A) (b : A)
    (h1 : total_order R) (h2 : minimalElt R b B) : smallestElt R b B := by
  define at h1         --h1 : partial_order R ∧ ∀ (x y : A), R x y ∨ R y x
  define at h2         --h2 : b ∈ B ∧ ¬∃ (x : A), x ∈ B ∧ R x b ∧ x ≠ b
  define               --Goal : b ∈ B ∧ ∀ (x : A), x ∈ B → R b x
  apply And.intro h2.left  --Goal : ∀ (x : A), x ∈ B → R b x
  fix x : A
  assume h3 : x ∈ B        --Goal : R b x
  by_cases h4 : x = b
  · -- Case 1. h4 : x = b
    rewrite [h4]             --Goal : R b b
    have h5 : partial_order R := h1.left
    define at h5
    have h6 : reflexive R := h5.left
    define at h6
    show R b b from h6 b
    done
  · -- Case 2. h4 : x ≠ b
    have h5 : ∀ (x y : A), R x y ∨ R y x := h1.right
    have h6 : R x b ∨ R b x := h5 x b
    have h7 : ¬R x b := by
      contradict h2.right with h8
      show ∃ (x : A), x ∈ B ∧ R x b ∧ x ≠ b from
        Exists.intro x (And.intro h3 (And.intro h8 h4))
      done
    disj_syll h6 h7
    show R b x from h6
    done
  done

/- Section 4.5 -/
lemma Lemma_4_5_5_1 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    ∀ (x : A), x ∈ equivClass R x := by
  fix x : A
  define           --Goal : R x x
  define at h      --h : reflexive R ∧ symmetric R ∧ transitive R
  have Rref : reflexive R := h.left
  show R x x from Rref x
  done

lemma Lemma_4_5_5_2 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    ∀ (x y : A), y ∈ equivClass R x ↔
      equivClass R y = equivClass R x := by
  have Rsymm : symmetric R := h.right.left
  have Rtrans : transitive R := h.right.right
  fix x : A; fix y : A
  apply Iff.intro
  · -- (→)
    assume h2 :
      y ∈ equivClass R x    --Goal : equivClass R y = equivClass R x
    define at h2                        --h2 : R y x
    apply Set.ext
    fix z : A
    apply Iff.intro
    · -- Proof that z ∈ equivClass R y → z ∈ equivClass R x
      assume h3 : z ∈ equivClass R y
      define                            --Goal : R z x
      define at h3                      --h3 : R z y
      show R z x from Rtrans z y x h3 h2
      done
    · -- Proof that z ∈ equivClass R x → z ∈ equivClass R y
      assume h3 : z ∈ equivClass R x
      define                            --Goal : R z y
      define at h3                      --h3 : R z x
      have h4 : R x y := Rsymm y x h2
      show R z y from Rtrans z x y h3 h4
      done
    done
  · -- (←)
    assume h2 :
      equivClass R y = equivClass R x   --Goal : y ∈ equivClass R x
    rewrite [←h2]                       --Goal : y ∈ equivClass R y
    show y ∈ equivClass R y from Lemma_4_5_5_1 R h y
    done
  done

lemma Theorem_4_5_4_part_1 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    ∀ (x : A), x ∈ ⋃₀ (mod A R) := by
  fix x : A
  define        --Goal : ∃ (t : Set A), t ∈ mod A R ∧ x ∈ t
  apply Exists.intro (equivClass R x)
  apply And.intro _ (Lemma_4_5_5_1 R h x)
                --Goal : equivClass R x ∈ mod A R
  define        --Goal : ∃ (x_1 : A), equivClass R x_1 = equivClass R x
  apply Exists.intro x
  rfl
  done

lemma Theorem_4_5_4_part_2 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    pairwise_disjoint (mod A R) := by
  define
  fix X : Set A
  assume h2 : X ∈ mod A R
  fix Y : Set A
  assume h3 : Y ∈ mod A R           --Goal : X ≠ Y → empty (X ∩ Y)
  define at h2; define at h3
  obtain (x : A) (h4 : equivClass R x = X) from h2
  obtain (y : A) (h5 : equivClass R y = Y) from h3
  contrapos
  assume h6 : ∃ (x : A), x ∈ X ∩ Y  --Goal : X = Y
  obtain (z : A) (h7 : z ∈ X ∩ Y) from h6
  define at h7
  rewrite [←h4, ←h5] at h7 --h7 : z ∈ equivClass R x ∧ z ∈ equivClass R y
  have h8 : equivClass R z = equivClass R x :=
    (Lemma_4_5_5_2 R h x z).ltr h7.left
  have h9 : equivClass R z = equivClass R y :=
    (Lemma_4_5_5_2 R h y z).ltr h7.right
  show X = Y from
    calc X
      _ = equivClass R x := h4.symm
      _ = equivClass R z := h8.symm
      _ = equivClass R y := h9
      _ = Y              := h5
  done

lemma Theorem_4_5_4_part_3 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    ∀ X ∈ mod A R, ¬empty X := by
  fix X : Set A
  assume h2 : X ∈ mod A R  --Goal : ¬empty X
  define; double_neg       --Goal : ∃ (x : A), x ∈ X
  define at h2             --h2 : ∃ (x : A), equivClass R x = X
  obtain (x : A) (h3 : equivClass R x = X) from h2
  rewrite [←h3]
  show ∃ (x_1 : A), x_1 ∈ equivClass R x from
    Exists.intro x (Lemma_4_5_5_1 R h x)
  done

theorem Theorem_4_5_4 {A : Type} (R : BinRel A) (h : equiv_rel R) :
    partition (mod A R) := And.intro (Theorem_4_5_4_part_1 R h)
      (And.intro (Theorem_4_5_4_part_2 R h) (Theorem_4_5_4_part_3 R h))

lemma overlap_implies_equal {A : Type}
    (F : Set (Set A)) (h : partition F) :
    ∀ X ∈ F, ∀ Y ∈ F, ∀ (x : A), x ∈ X → x ∈ Y → X = Y := sorry

lemma Lemma_4_5_7_ref {A : Type} (F : Set (Set A)) (h : partition F):
    reflexive (EqRelFromPart F) := sorry

lemma Lemma_4_5_7_symm {A : Type} (F : Set (Set A)) (h : partition F):
    symmetric (EqRelFromPart F) := sorry

lemma Lemma_4_5_7_trans {A : Type} (F : Set (Set A)) (h : partition F):
    transitive (EqRelFromPart F) := sorry

lemma Lemma_4_5_7 {A : Type} (F : Set (Set A)) (h : partition F) :
    equiv_rel (EqRelFromPart F) := And.intro (Lemma_4_5_7_ref F h)
      (And.intro (Lemma_4_5_7_symm F h) (Lemma_4_5_7_trans F h))

lemma Lemma_4_5_8 {A : Type} (F : Set (Set A)) (h : partition F) :
    ∀ X ∈ F, ∀ x ∈ X, equivClass (EqRelFromPart F) x = X := sorry

theorem Theorem_4_5_6 {A : Type} (F : Set (Set A)) (h: partition F) :
    ∃ (R : BinRel A), equiv_rel R ∧ mod A R = F := by
  let R : BinRel A := EqRelFromPart F
  apply Exists.intro R               --Goal : equiv_rel R ∧ mod A R = F
  apply And.intro (Lemma_4_5_7 F h)  --Goal : mod A R = F
  apply Set.ext
  fix X : Set A                      --Goal :  X ∈ mod A R ↔ X ∈ F
  apply Iff.intro
  · -- (→)
    assume h2 : X ∈ mod A R          --Goal : X ∈ F
    define at h2                     --h2 : ∃ (x : A), equivClass R x = X
    obtain (x : A) (h3 : equivClass R x = X) from h2
    have h4 : x ∈ ⋃₀ F := h.left x
    define at h4
    obtain (Y : Set A) (h5 : Y ∈ F ∧ x ∈ Y) from h4
    have h6 : equivClass R x = Y :=
      Lemma_4_5_8 F h Y h5.left x h5.right
    rewrite [←h3, h6]
    show Y ∈ F from h5.left
    done
  · -- (←)
    assume h2 : X ∈ F                --Goal : X ∈ mod A R
    have h3 : ¬empty X := h.right.right X h2
    define at h3; double_neg at h3   --h3 : ∃ (x : A), x ∈ X
    obtain (x : A) (h4 : x ∈ X) from h3
    define                       --Goal : ∃ (x : A), equivClass R x = X
    show ∃ (x : A), equivClass R x = X from
      Exists.intro x (Lemma_4_5_8 F h X h2 x h4)
    done
  done


import data.finset
import data.fintype.basic
import tactic
import week05.solutions.e00_intro

open finset

structure matroid (α : Type*) [fintype α] [decidable_eq α] :=
  (ind : set (finset α))
  (ind_empty : ind ∅)
  (ind_subset : ∀ ⦃A B⦄, A ⊆ B → ind B → ind A)
  (ind_exchange : ∀ (A B : finset α), ind A → ind B → A.card < B.card →
    (∃ (c ∈ B), (c ∉ A) ∧ ind (insert c A)))

namespace matroid

attribute [simp] matroid.ind_empty

variables {α : Type} [fintype α] [decidable_eq α] {A B X : finset α} {m : matroid α}

-- Попробуйте доказать в term mode
lemma dep_superset {A B} : A ⊆ B → ¬m.ind A → ¬m.ind B := λ h hA hB, hA (m.ind_subset h hB)

-- Базой множества A называется независимое множество B, что B ⊆ A, и для любого x ∈ A \ B, B ∪ {x} зависимо
-- x ∈ A \ B - неудобное определение, потому что везде придется переписывать mem_sdiff
-- Аналогично, для вставки x в B есть `insert x B`
def base_of (m : matroid α) (X A : finset α) := A ⊆ X ∧ m.ind A ∧ ∀ x ∈ X, x ∉ A → ¬m.ind (insert x A)

lemma base_of_ind : m.base_of X A → m.ind A := λ h, h.2.1

lemma base_of_subset : m.base_of X A → A ⊆ X := λ h, h.1

lemma base_of_dep_of_insert {x} : m.base_of X A → x ∈ X → x ∉ A → ¬m.ind (insert x A) := λ h hX hA, h.2.2 x hX hA

-- База матроида - аналогично, но без ограничения на подмножество
def base (m : matroid α) (B : finset α) := m.ind B ∧ ∀ x ∉ B, ¬m.ind (insert x B)

lemma base_ind : m.base A → m.ind A := λ h, h.1

@[simp] lemma base_of_univ_iff_base {A : finset α} : m.base_of univ A ↔ m.base A :=
  ⟨λ ⟨_, h_ind, h_ins⟩, ⟨h_ind, λ x hx, h_ins x (mem_univ _) hx⟩,
   λ ⟨h_ind, h_ins⟩, ⟨subset_univ A, h_ind, λ x _ hx, h_ins x hx⟩⟩

-- Секция с доказательствами про `base_of`
section base_of

-- A независимо тогда и только тогда, когда A - база A
lemma ind_iff_base_of_self : m.ind A ↔ m.base_of A A :=
begin
  refine ⟨λ Aind, _, base_of_ind⟩,
  refine ⟨subset.refl _, Aind, λ x hx hnx, absurd hx hnx⟩,
end

-- Все базы множества равномощны
-- Вспомните/подумайте про математическое доказательство
lemma base_of_card_eq (hA : m.base_of X A) (hB : m.base_of X B) : A.card = B.card :=
begin
  by_contradiction hne,
  wlog h : A.card < B.card := lt_or_gt_of_ne hne using [A B, B A],
  obtain ⟨w, wB, wA, winsert⟩ := m.ind_exchange _ _ (base_of_ind hA) (base_of_ind hB) h,
  refine base_of_dep_of_insert hA (base_of_subset hB wB) wA winsert,
end

-- Любое независимое подмножество X можно достроить до базы X
-- `by_contradiction` доказывает цель от противного
-- `push_neg` проталкивает отрицания максимально внутрь утверждения или цели
-- Также может помочь `nat.le_induction`

#check @nat.le_induction

lemma exists_base_of_superset_of_ind : A ⊆ X → m.ind A → ∃ B, A ⊆ B ∧ m.base_of X B :=
begin
  intros hAX hA,
  by_contradiction,
  push_neg at h,
  suffices ind_unbounded : ∀ k ≥ A.card, ∃ B, A ⊆ B ∧ B ⊆ X ∧ m.ind B ∧ B.card = k, {
    replace hAX := card_le_of_subset hAX,
    rcases ind_unbounded (X.card + 1) (by linarith) with ⟨B, -, hBX, -, Bcard⟩,
    replace hBX := card_le_of_subset hBX,
    linarith,
  },
  apply nat.le_induction, {
    use [A, subset.refl A, hAX, hA],
  }, {
    rintro n Acard ⟨B, hAB, hBX, Bind, rfl⟩,
    specialize h B hAB,
    rw base_of at h,
    push_neg at h,
    rcases h hBX Bind with ⟨w, wX, wB, w_insert⟩,
    use [insert w B],
    use [subset.trans hAB (subset_insert _ _)],
    use [insert_subset.2 ⟨wX, hBX⟩],
    use [w_insert, card_insert_of_not_mem wB],
  }
end

-- У каждого подмножества X существует база
theorem exists_base_of (m : matroid α) (X : finset α): ∃ A, m.base_of X A :=
begin
  obtain ⟨B, _, Bbase⟩ := exists_base_of_superset_of_ind (empty_subset X) m.ind_empty,
  exact ⟨B, Bbase⟩,
end

-- Мощность независимого подмножества A ⊆ X не больше мощности базы X
lemma ind_card_le_base_of_card : A ⊆ X → m.ind A → m.base_of X B → A.card ≤ B.card :=
begin
  intros hAX Aind Bbase,
  obtain ⟨T, hAT, Tbase⟩ := exists_base_of_superset_of_ind hAX Aind,
  rw base_of_card_eq Bbase Tbase,
  exact card_le_of_subset hAT,
end

end base_of

-- Теорема о базах матроида
section base

lemma base_eq_card (hA : m.base A) (hB : m.base B) : A.card = B.card :=
  by {rw [←base_of_univ_iff_base] at *, exact base_of_card_eq hA hB}

lemma ind_subset_base (hA : m.ind A) : ∃ B, A ⊆ B ∧ m.base B :=
begin
  obtain ⟨B, hAB, h_base⟩ := exists_base_of_superset_of_ind (subset_univ A) hA,
  rw base_of_univ_iff_base at h_base,
  use [B, hAB, h_base],
end

theorem exists_base : ∃ A, m.base A :=
begin
  obtain ⟨B, _, Bbase⟩ := ind_subset_base m.ind_empty,
  exact ⟨B, Bbase⟩,
end

theorem base_not_subset {A B} : m.base A → m.base B → A ⊆ B → A = B :=
begin
  rintro Abase Bbase h_subset,
  exact eq_of_subset_of_card_le h_subset (ge_of_eq $ base_eq_card Abase Bbase),
end

lemma ind_and_card_eq_card_base_iff_base {A B} (Abase : m.base A) : (m.ind B ∧ A.card = B.card) ↔ m.base B :=
begin
  split, {
    rintro ⟨Bind, Acard⟩,
    use Bind,
    intros x xB h_insert_ind,
    obtain ⟨C, Bsubset, Cbase⟩ := ind_subset_base h_insert_ind,
    replace Bsubset := card_le_of_subset Bsubset,
    rw [base_eq_card Abase Cbase] at Acard,
    rw card_insert_of_not_mem xB at Bsubset,
    linarith,
  }, {
    intro Bbase,
    exact ⟨base_ind Bbase, base_eq_card Abase Bbase⟩,
  }
end

-- Почитайте про тактику `finish`: https://leanprover-community.github.io/mathlib_docs/tactics.html#finish%20/%20clarify%20/%20safe
theorem base_exchange {A B} : m.base A → m.base B → ∀ x ∈ A \ B, ∃ b ∈ (B \ A), m.base (insert b (A.erase x)) :=
begin
  intros Abase Bbase x xA,
  rcases m.ind_exchange (A.erase x) B _ Bbase.1 _ with ⟨c, cB, cA, cinsert⟩,
  {
    use c,
    rw mem_sdiff at ⊢ xA,
    use [cB],
    {
      finish,
    }, {
      apply (ind_and_card_eq_card_base_iff_base Abase).1,
      use cinsert,
      rw [card_insert_of_not_mem cA, card_erase_of_mem' xA.1],
    },
  }, {
    exact m.ind_subset (erase_subset _ _) (base_ind Abase),
  }, {
    rw mem_sdiff at xA,
    rw [← base_eq_card Abase Bbase, card_erase_of_mem xA.1],
    exact nat.pred_lt (card_ne_zero_of_mem xA.1),
  },
end

end base

-- Цикл матроида это минимальное по включению зависимое множество

def circuit (m : matroid α) (A : finset α) := ¬ m.ind A ∧ ∀ x ∈ A, m.ind (A.erase x)

section circuit

theorem not_circuit : ¬ m.circuit ∅ := λ ⟨empty_dep, _⟩, empty_dep m.ind_empty

lemma circuit_ssubset : m.circuit A → B ⊂ A → m.ind B :=
begin
  rintro ⟨Anind, Aerase⟩ Bsubset,
  rw ssubset_iff at Bsubset,
  rcases Bsubset with ⟨x, xB, x_insert⟩,
  rw insert_subset at x_insert,
  cases x_insert with xA h_subset,
  apply m.ind_subset _ (Aerase x xA),
  rw ← erase_eq_of_not_mem xB,
  exact erase_subset_erase x h_subset,
end

theorem circuit_not_subset {A B} : m.circuit A → m.circuit B → A ⊆ B → A = B :=
begin
  rintro Acirc Bcirc h_subset,
  cases @lt_or_eq_of_le _ _ A B h_subset, {
    exfalso,
    exact Acirc.1 (circuit_ssubset Bcirc h),
  }, {
    exact h,
  }
end

-- Чтобы доказать эту лемму от противного, нужно доказать утверждение вида
-- "Если A зависимо и у него нет подмножеств-циклов,
-- то для всех k от 0 до |A| существует зависимое множество размера k"
-- Для этого я рекомендую использовать индукцию по убыванию k
-- В mathlib это nat.decreasing_induction
lemma ind_iff_no_circuit_subset (A) : m.ind A ↔ ∀ C ⊆ A, ¬m.circuit C :=
begin
  split, {
    intros Aind C hCA Ccirc,
    refine dep_superset hCA (Ccirc.1) Aind,
  }, {
    intros h,
    by_contradiction Aind,
    suffices subsets_dep : ∀ k ≤ A.card, ∃ B ⊆ A, B.card = k ∧ ¬ m.ind B, {
      obtain ⟨B, Bsub, Bcard, Bdep⟩ := subsets_dep 0 (zero_le _),
      apply Bdep,
      convert m.ind_empty,
      rwa card_eq_zero at Bcard,
    },
    intros k k_le_card,
    refine nat.decreasing_induction _ k_le_card _, {
      rintro n ⟨B, hBA, Bcard, Bdep⟩,
      specialize h B hBA,
      rw circuit at h,
      push_neg at h,
      obtain ⟨x, xAB, h_dep_erase⟩ := h Bdep,
      refine ⟨B.erase x, subset.trans (erase_subset _ _) hBA, _, h_dep_erase⟩,
      rw ← card_erase_of_mem' xAB at Bcard,
      exact add_right_cancel Bcard,
    }, {
      use [A, subset.refl _, rfl],
    }
  }
end

lemma dep_iff_contains_circuit (A) : ¬ m.ind A ↔ ∃ C ⊆ A, m.circuit C :=
begin
  convert (not_congr $ ind_iff_no_circuit_subset A),
  simp,
end

end circuit

-- Есть несколько способов определить ранговую функцию в матроиде
-- Я выбрал следующий: возьмем все независимые подмножества A и возьмем максимальную мощность среди них
-- Для такого определения нужно, чтобы проверка на независимость в матроиде была разрешимой

variable [decidable_pred m.ind]

def rank (m : matroid α) [decidable_pred m.ind] (A : finset α) : ℕ :=  sup (filter m.ind (powerset A)) card

section rank

@[simp] lemma rank_def : rank m A = sup (filter m.ind (powerset A)) card := rfl

@[simp] lemma rank_empty : rank m ∅ = 0 :=
begin
  rw rank,
  simp only [card_empty, filter_true_of_mem, ind_empty, forall_eq, powerset_empty, sup_singleton, mem_singleton],
end

-- Если B - база A, то ранг А равен мощности B
-- Леммы про `sup` здесь полезны: `finset.sup_le` и `le_sup`
lemma rank_eq_base_of_card (Bbase : m.base_of A B) : rank m A = B.card :=
begin
  rw rank_def,
  apply nat.le_antisymm, {
    apply finset.sup_le,
    intros C hC,
    rw [mem_filter, mem_powerset] at hC,
    exact ind_card_le_base_of_card hC.1 hC.2 Bbase,
  }, {
    apply le_sup,
    rw [mem_filter, mem_powerset],
    exact ⟨base_of_subset Bbase, base_of_ind Bbase⟩,
  }
end

lemma rank_exists_base_of (m : matroid α) [decidable_pred m.ind] (A : finset α) :
  ∃ (B : finset α), m.rank A = B.card ∧ m.base_of A B :=
begin
  obtain ⟨B, Bbase⟩ := exists_base_of m A,
  refine ⟨B, rank_eq_base_of_card Bbase, Bbase⟩,
end

theorem rank_le_card : rank m A ≤ A.card :=
begin
  obtain ⟨bA, bAcard, bAbase⟩ := rank_exists_base_of m A,
  rw bAcard,
  exact card_le_of_subset bAbase.1,
end

@[simp] lemma rank_le_of_subset (hAB : A ⊆ B) : rank m A ≤ rank m B :=
begin
  obtain ⟨bA, bAbase⟩ := exists_base_of m A,
  obtain ⟨bB, bBbase⟩ := exists_base_of m B,
  rw rank_eq_base_of_card bAbase,
  rw rank_eq_base_of_card bBbase,
  refine ind_card_le_base_of_card (subset.trans bAbase.1 hAB) bAbase.2.1 bBbase,
end

@[simp] lemma rank_ind : rank m A = A.card ↔ m.ind A :=
begin
  split, {
    intro h_card,
    obtain ⟨B, Bcard, Bbase⟩ := rank_exists_base_of m A,
    rw h_card at Bcard,
    suffices h_eq : A = B, {
      subst h_eq,
      exact Bbase.2.1,
    },
    symmetry,
    exact eq_of_subset_of_card_le Bbase.1 (le_of_eq Bcard),
  }, {
    intro Aind,
    rw [ind_iff_base_of_self] at Aind,
    rw rank_eq_base_of_card Aind,
  }
end

lemma not_mem_sdiff_iff {x : α} {A B : finset α} : x ∉ A \ B ↔ x ∉ A ∨ x ∈ B :=
begin
  rw not_iff_comm,
  push_neg,
  simp only [mem_sdiff, iff_self],
end

lemma card_sdiff_ℤ {A B : finset α} (hAB : A ⊆ B) : ((B \ A).card : ℤ) = (B.card : ℤ) - A.card :=
begin
  suffices h : (B \ A).card + A.card = B.card, {
    linarith,
  },
  rw [card_sdiff hAB, nat.sub_add_cancel (card_le_of_subset hAB)],
end

-- Сложный финальный босс!
-- http://neerc.ifmo.ru/wiki/index.php?title=%D0%A0%D0%B0%D0%BD%D0%B3%D0%BE%D0%B2%D0%B0%D1%8F_%D1%84%D1%83%D0%BD%D0%BA%D1%86%D0%B8%D1%8F,_%D0%BF%D0%BE%D0%BB%D1%83%D0%BC%D0%BE%D0%B4%D1%83%D0%BB%D1%8F%D1%80%D0%BD%D0%BE%D1%81%D1%82%D1%8C

theorem rank_submodular : m.rank (A ∩ B) + m.rank (A ∪ B) ≤ m.rank A + m.rank B :=
begin
  obtain ⟨bInter, bInter_base⟩ := exists_base_of m (A ∩ B),
  have rankInter := rank_eq_base_of_card bInter_base,

  obtain ⟨bA, bA_sub, bA_base⟩ := exists_base_of_superset_of_ind (subset.trans bInter_base.1 (inter_subset_left _ _)) (bInter_base.2.1),
  have rankA := rank_eq_base_of_card bA_base,

  obtain ⟨bUnion, bUnion_sub, bUnion_base⟩ :=
    exists_base_of_superset_of_ind (subset.trans bA_base.1 (subset_union_left A B)) bA_base.2.1,
  have rankUnion := rank_eq_base_of_card bUnion_base,

  obtain ⟨bB, bB_base⟩ := exists_base_of m B,
  have rankB := rank_eq_base_of_card bB_base,

  have indB_sub : (bUnion \ (bA \ bInter)) ⊆ B := by {
    intros x hx,
    rw [mem_sdiff, not_mem_sdiff_iff] at hx,
    rcases hx with ⟨xBunion, xA | xInter⟩, {
      have xAB := bUnion_base.1 xBunion,
      cases (mem_union.1 xAB), {
        exfalso,
        have h_insert_dep := bA_base.2.2 _ h xA,
        refine h_insert_dep (m.ind_subset _ (bUnion_base.2.1)),
        rw ← insert_eq_of_mem xBunion,
        refine insert_subset_insert x bUnion_sub,
      }, {
        exact h,
      }
    }, {
      exact mem_of_mem_inter_right (bInter_base.1 xInter),
    },
  },
  have indB_ind : m.ind (bUnion \ (bA \ bInter)) := m.ind_subset (sdiff_subset _ _) bUnion_base.2.1,
  have indB_card_le := ind_card_le_base_of_card indB_sub indB_ind bB_base,
  have indB_card : (bUnion \ (bA \ bInter)).card + bA.card = bUnion.card + bInter.card := by {
    zify,
    rw card_sdiff_ℤ (subset.trans (sdiff_subset bA bInter) bUnion_sub),
    rw card_sdiff_ℤ bA_sub,
    ring,
  },
  rw [rankInter, rankA, rankUnion, rankB],
  linarith,
end

end rank

end matroid


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Alena Gusakov, Yaël Dillies
-/
import data.finset.slice
import logic.function.iterate

/-!
# Shadows

This file defines shadows of a set family. The shadow of a set family is the set family of sets we
get by removing any element from any set of the original family. If one pictures `finset α` as a big
hypercube (each dimension being membership of a given element), then taking the shadow corresponds
to projecting each finset down once in all available directions.

## Main definitions

* `finset.shadow`: The shadow of a set family. Everything we can get by removing a new element from
  some set.
* `finset.up_shadow`: The upper shadow of a set family. Everything we can get by adding an element
  to some set.

## Notation

We define notation in locale `finset_family`:
* `∂ 𝒜`: Shadow of `𝒜`.
* `∂⁺ 𝒜`: Upper shadow of `𝒜`.

We also maintain the convention that `a, b : α` are elements of the ground type, `s, t : finset α`
are finsets, and `𝒜, ℬ : finset (finset α)` are finset families.

## References

* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf
* http://discretemath.imp.fu-berlin.de/DMII-2015-16/kruskal.pdf

## Tags

shadow, set family
-/

open finset nat

variables {α : Type*}

namespace finset
section shadow
variables [decidable_eq α] {𝒜 : finset (finset α)} {s t : finset α} {a : α} {k r : ℕ}

/-- The shadow of a set family `𝒜` is all sets we can get by removing one element from any set in
`𝒜`, and the (`k` times) iterated shadow (`shadow^[k]`) is all sets we can get by removing `k`
elements from any set in `𝒜`. -/
def shadow (𝒜 : finset (finset α)) : finset (finset α) := 𝒜.sup (λ s, s.image (erase s))

localized "notation `∂ `:90 := finset.shadow" in finset_family

/-- The shadow of the empty set is empty. -/
@[simp] lemma shadow_empty : ∂ (∅ : finset (finset α)) = ∅ := rfl

/-- The shadow is monotone. -/
@[mono] lemma shadow_monotone : monotone (shadow : finset (finset α) → finset (finset α)) :=
λ 𝒜 ℬ, sup_mono

/-- `s` is in the shadow of `𝒜` iff there is an `t ∈ 𝒜` from which we can remove one element to
get `s`. -/
lemma mem_shadow_iff : s ∈ ∂ 𝒜 ↔ ∃ t ∈ 𝒜, ∃ a ∈ t, erase t a = s :=
by simp only [shadow, mem_sup, mem_image]

lemma erase_mem_shadow (hs : s ∈ 𝒜) (ha : a ∈ s) : erase s a ∈ ∂ 𝒜 :=
mem_shadow_iff.2 ⟨s, hs, a, ha, rfl⟩

/-- The shadow of a family of `r`-sets is a family of `r - 1`-sets. -/
protected lemma sized.shadow (h𝒜 : (𝒜 : set (finset α)).sized r) :
  (∂ 𝒜 : set (finset α)).sized (r - 1) :=
begin
  intros A h,
  obtain ⟨A, hA, i, hi, rfl⟩ := mem_shadow_iff.1 h,
  rw [card_erase_of_mem hi, h𝒜 hA],
  refl,
end

/-- `t` is in the shadow of `𝒜` iff we can add an element to it so that the resulting finset is in
`𝒜`. -/
lemma mem_shadow_iff_insert_mem : s ∈ ∂ 𝒜 ↔ ∃ a ∉ s, insert a s ∈ 𝒜 :=
begin
  refine mem_shadow_iff.trans ⟨_, _⟩,
  { rintro ⟨s, hs, a, ha, rfl⟩,
    refine ⟨a, not_mem_erase a s, _⟩,
    rwa insert_erase ha },
  { rintro ⟨a, ha, hs⟩,
    exact ⟨insert a s, hs, a, mem_insert_self _ _, erase_insert ha⟩ }
end

/-- `s ∈ ∂ 𝒜` iff `s` is exactly one element less than something from `𝒜` -/
lemma mem_shadow_iff_exists_mem_card_add_one :
  s ∈ ∂ 𝒜 ↔ ∃ t ∈ 𝒜, s ⊆ t ∧ t.card = s.card + 1 :=
begin
  refine mem_shadow_iff_insert_mem.trans ⟨_, _⟩,
  { rintro ⟨a, ha, hs⟩,
    exact ⟨insert a s, hs, subset_insert _ _, card_insert_of_not_mem ha⟩ },
  { rintro ⟨t, ht, hst, h⟩,
    obtain ⟨a, ha⟩ : ∃ a, t \ s = {a} :=
      card_eq_one.1 (by rw [card_sdiff hst, h, add_tsub_cancel_left]),
    exact ⟨a, λ hat,
      not_mem_sdiff_of_mem_right hat ((ha.ge : _ ⊆ _) $ mem_singleton_self a),
      by rwa [insert_eq a s, ←ha, sdiff_union_of_subset hst]⟩ }
end

/-- Being in the shadow of `𝒜` means we have a superset in `𝒜`. -/
lemma exists_subset_of_mem_shadow (hs : s ∈ ∂ 𝒜) : ∃ t ∈ 𝒜, s ⊆ t :=
let ⟨t, ht, hst⟩ := mem_shadow_iff_exists_mem_card_add_one.1 hs in ⟨t, ht, hst.1⟩

/-- `t ∈ ∂^k 𝒜` iff `t` is exactly `k` elements less than something in `𝒜`. -/
lemma mem_shadow_iff_exists_mem_card_add :
  s ∈ (∂^[k]) 𝒜 ↔ ∃ t ∈ 𝒜, s ⊆ t ∧ t.card = s.card + k :=
begin
  induction k with k ih generalizing 𝒜 s,
  { refine ⟨λ hs, ⟨s, hs, subset.refl _, rfl⟩, _⟩,
    rintro ⟨t, ht, hst, hcard⟩,
    rwa eq_of_subset_of_card_le hst hcard.le },
  simp only [exists_prop, function.comp_app, function.iterate_succ],
  refine ih.trans _,
  clear ih,
  split,
  { rintro ⟨t, ht, hst, hcardst⟩,
    obtain ⟨u, hu, htu, hcardtu⟩ := mem_shadow_iff_exists_mem_card_add_one.1 ht,
    refine ⟨u, hu, hst.trans htu, _⟩,
    rw [hcardtu, hcardst],
    refl },
  { rintro ⟨t, ht, hst, hcard⟩,
    obtain ⟨u, hsu, hut, hu⟩ := finset.exists_intermediate_set k
      (by { rw [add_comm, hcard], exact le_succ _ }) hst,
    rw add_comm at hu,
    refine ⟨u, mem_shadow_iff_exists_mem_card_add_one.2 ⟨t, ht, hut, _⟩, hsu, hu⟩,
    rw [hcard, hu],
    refl }
end

end shadow

open_locale finset_family

section up_shadow
variables [decidable_eq α] [fintype α] {𝒜 : finset (finset α)} {s t : finset α} {a : α} {k r : ℕ}

/-- The upper shadow of a set family `𝒜` is all sets we can get by adding one element to any set in
`𝒜`, and the (`k` times) iterated upper shadow (`up_shadow^[k]`) is all sets we can get by adding
`k` elements from any set in `𝒜`. -/
def up_shadow (𝒜 : finset (finset α)) : finset (finset α) :=
𝒜.sup $ λ s, sᶜ.image $ λ a, insert a s

localized "notation `∂⁺ `:90 := finset.up_shadow" in finset_family

/-- The upper shadow of the empty set is empty. -/
@[simp] lemma up_shadow_empty : ∂⁺ (∅ : finset (finset α)) = ∅ := rfl

/-- The upper shadow is monotone. -/
@[mono] lemma up_shadow_monotone : monotone (up_shadow : finset (finset α) → finset (finset α)) :=
λ 𝒜 ℬ, sup_mono

/-- `s` is in the upper shadow of `𝒜` iff there is an `t ∈ 𝒜` from which we can remove one element
to get `s`. -/
lemma mem_up_shadow_iff : s ∈ ∂⁺ 𝒜 ↔ ∃ t ∈ 𝒜, ∃ a ∉ t, insert a t = s :=
by simp_rw [up_shadow, mem_sup, mem_image, exists_prop, mem_compl]

lemma insert_mem_up_shadow (hs : s ∈ 𝒜) (ha : a ∉ s) : insert a s ∈ ∂⁺ 𝒜 :=
mem_up_shadow_iff.2 ⟨s, hs, a, ha, rfl⟩

/-- The upper shadow of a family of `r`-sets is a family of `r + 1`-sets. -/
protected lemma sized.up_shadow (h𝒜 : (𝒜 : set (finset α)).sized r) :
  (∂⁺ 𝒜 : set (finset α)).sized (r + 1) :=
begin
  intros A h,
  obtain ⟨A, hA, i, hi, rfl⟩ := mem_up_shadow_iff.1 h,
  rw [card_insert_of_not_mem hi, h𝒜 hA],
end

/-- `t` is in the upper shadow of `𝒜` iff we can remove an element from it so that the resulting
finset is in `𝒜`. -/
lemma mem_up_shadow_iff_erase_mem : s ∈ ∂⁺ 𝒜 ↔ ∃ a ∈ s, s.erase a ∈ 𝒜 :=
begin
  refine mem_up_shadow_iff.trans ⟨_, _⟩,
  { rintro ⟨s, hs, a, ha, rfl⟩,
    refine ⟨a, mem_insert_self a s, _⟩,
    rwa erase_insert ha },
  { rintro ⟨a, ha, hs⟩,
    exact ⟨s.erase a, hs, a, not_mem_erase _ _, insert_erase ha⟩ }
end

/-- `s ∈ ∂⁺ 𝒜` iff `s` is exactly one element less than something from `𝒜`. -/
lemma mem_up_shadow_iff_exists_mem_card_add_one :
  s ∈ ∂⁺ 𝒜 ↔ ∃ t ∈ 𝒜, t ⊆ s ∧ t.card + 1 = s.card :=
begin
  refine mem_up_shadow_iff_erase_mem.trans ⟨_, _⟩,
  { rintro ⟨a, ha, hs⟩,
    exact ⟨s.erase a, hs, erase_subset _ _, card_erase_add_one ha⟩ },
  { rintro ⟨t, ht, hts, h⟩,
    obtain ⟨a, ha⟩ : ∃ a, s \ t = {a} :=
      card_eq_one.1 (by rw [card_sdiff hts, ←h, add_tsub_cancel_left]),
    refine ⟨a, sdiff_subset _ _ ((ha.ge : _ ⊆ _) $ mem_singleton_self a), _⟩,
    rwa [←sdiff_singleton_eq_erase, ←ha, sdiff_sdiff_eq_self hts] }
end

/-- Being in the upper shadow of `𝒜` means we have a superset in `𝒜`. -/
lemma exists_subset_of_mem_up_shadow (hs : s ∈ ∂⁺ 𝒜) : ∃ t ∈ 𝒜, t ⊆ s :=
let ⟨t, ht, hts, _⟩ := mem_up_shadow_iff_exists_mem_card_add_one.1 hs in ⟨t, ht, hts⟩

/-- `t ∈ ∂^k 𝒜` iff `t` is exactly `k` elements more than something in `𝒜`. -/
lemma mem_up_shadow_iff_exists_mem_card_add :
  s ∈ (∂⁺^[k]) 𝒜 ↔ ∃ t ∈ 𝒜, t ⊆ s ∧ t.card + k = s.card :=
begin
  induction k with k ih generalizing 𝒜 s,
  { refine ⟨λ hs, ⟨s, hs, subset.refl _, rfl⟩, _⟩,
    rintro ⟨t, ht, hst, hcard⟩,
    rwa ←eq_of_subset_of_card_le hst hcard.ge },
  simp only [exists_prop, function.comp_app, function.iterate_succ],
  refine ih.trans _,
  clear ih,
  split,
  { rintro ⟨t, ht, hts, hcardst⟩,
    obtain ⟨u, hu, hut, hcardtu⟩ := mem_up_shadow_iff_exists_mem_card_add_one.1 ht,
    refine ⟨u, hu, hut.trans hts, _⟩,
    rw [←hcardst, ←hcardtu, add_right_comm],
    refl },
  { rintro ⟨t, ht, hts, hcard⟩,
    obtain ⟨u, htu, hus, hu⟩ := finset.exists_intermediate_set 1
      (by { rw [add_comm, ←hcard], exact add_le_add_left (zero_lt_succ _) _ }) hts,
    rw add_comm at hu,
    refine ⟨u, mem_up_shadow_iff_exists_mem_card_add_one.2 ⟨t, ht, htu, hu.symm⟩, hus, _⟩,
    rw [hu, ←hcard, add_right_comm],
    refl }
end

@[simp] lemma shadow_image_compl : (∂ 𝒜).image compl = ∂⁺ (𝒜.image compl) :=
begin
  ext s,
  simp only [mem_image, exists_prop, mem_shadow_iff, mem_up_shadow_iff],
  split,
  { rintro ⟨_, ⟨s, hs, a, ha, rfl⟩, rfl⟩,
    exact ⟨sᶜ, ⟨s, hs, rfl⟩, a, not_mem_compl.2 ha, compl_erase.symm⟩ },
  { rintro ⟨_, ⟨s, hs, rfl⟩, a, ha, rfl⟩,
    exact ⟨s.erase a, ⟨s, hs, a, not_mem_compl.1 ha, rfl⟩, compl_erase⟩ }
end

@[simp] lemma up_shadow_image_compl : (∂⁺ 𝒜).image compl = ∂ (𝒜.image compl) :=
begin
  ext s,
  simp only [mem_image, exists_prop, mem_shadow_iff, mem_up_shadow_iff],
  split,
  { rintro ⟨_, ⟨s, hs, a, ha, rfl⟩, rfl⟩,
    exact ⟨sᶜ, ⟨s, hs, rfl⟩, a, mem_compl.2 ha, compl_insert.symm⟩ },
  { rintro ⟨_, ⟨s, hs, rfl⟩, a, ha, rfl⟩,
    exact ⟨insert a s, ⟨s, hs, a, mem_compl.1 ha, rfl⟩, compl_insert⟩ }
end

end up_shadow
end finset


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import analysis.normed_space.basic

/-!
# The integers as normed ring

This file contains basic facts about the integers as normed ring.

Recall that `∥n∥` denotes the norm of `n` as real number.
This norm is always nonnegative, so we can bundle the norm together with this fact,
to obtain a term of type `nnreal` (the nonnegative real numbers).
The resulting nonnegative real number is denoted by `∥n∥₊`.
-/

open_locale big_operators

namespace int

lemma norm_coe_units (e : ℤˣ) : ∥(e : ℤ)∥ = 1 :=
by rw [← coe_nnnorm, int.nnnorm_coe_units, nnreal.coe_one]

@[simp] lemma nnnorm_coe_nat (n : ℕ) : ∥(n : ℤ)∥₊ = n := real.nnnorm_coe_nat _

@[simp] lemma norm_coe_nat (n : ℕ) : ∥(n : ℤ)∥ = n := real.norm_coe_nat _

@[simp] lemma to_nat_add_to_nat_neg_eq_nnnorm (n : ℤ) : ↑(n.to_nat) + ↑((-n).to_nat) = ∥n∥₊ :=
by rw [← nat.cast_add, to_nat_add_to_nat_neg_eq_nat_abs, nnreal.coe_nat_abs]

@[simp] lemma to_nat_add_to_nat_neg_eq_norm (n : ℤ) : ↑(n.to_nat) + ↑((-n).to_nat) = ∥n∥ :=
by simpa only [nnreal.coe_nat_cast, nnreal.coe_add]
  using congr_arg (coe : _ → ℝ) (to_nat_add_to_nat_neg_eq_nnnorm n)

end int


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import data.fin.tuple
import data.real.basic
import data.set.intervals
import data.set.pairwise
import set_theory.cardinal
/-!
Proof that a cube (in dimension n ≥ 3) cannot be cubed:
There does not exist a partition of a cube into finitely many smaller cubes (at least two)
of different sizes.

We follow the proof described here:
http://www.alaricstephen.com/main-featured/2017/9/28/cubing-a-cube-proof
-/

open real set function fin
open_locale cardinal

noncomputable theory

variable {n : ℕ}

/-- Given three intervals `I, J, K` such that `J ⊂ I`,
  neither endpoint of `J` coincides with an endpoint of `I`, `¬ (K ⊆ J)` and
  `K` does not lie completely to the left nor completely to the right of `J`.
  Then `I ∩ K \ J` is nonempty. -/
lemma Ico_lemma {α} [linear_order α] {x₁ x₂ y₁ y₂ z₁ z₂ w : α}
  (h₁ : x₁ < y₁) (hy : y₁ < y₂) (h₂ : y₂ < x₂)
  (hz₁ : z₁ ≤ y₂) (hz₂ : y₁ ≤ z₂) (hw : w ∉ Ico y₁ y₂ ∧ w ∈ Ico z₁ z₂) :
  ∃w, w ∈ Ico x₁ x₂ ∧ w ∉ Ico y₁ y₂ ∧ w ∈ Ico z₁ z₂ :=
begin
  simp only [not_and, not_lt, mem_Ico] at hw,
  refine ⟨max x₁ (min w y₂), _, _, _⟩,
  { simp [le_refl, lt_trans h₁ (lt_trans hy h₂), h₂] },
  { simp [hw, lt_irrefl, not_le_of_lt h₁] {contextual := tt} },
  { simp [hw.2.1, hw.2.2, hz₁, lt_of_lt_of_le h₁ hz₂] at ⊢ }
end

/-- A (hyper)-cube (in standard orientation) is a vector `b` consisting of the bottom-left point
of the cube, a width `w` and a proof that `w > 0`. We use functions from `fin n` to denote vectors.
-/
structure cube (n : ℕ) : Type :=
(b : fin n → ℝ) -- bottom-left coordinate
(w : ℝ) -- width
(hw : 0 < w)

namespace cube
lemma hw' (c : cube n) : 0 ≤ c.w := le_of_lt c.hw

/-- The j-th side of a cube is the half-open interval `[b j, b j + w)` -/
def side (c : cube n) (j : fin n) : set ℝ :=
Ico (c.b j) (c.b j + c.w)

@[simp] lemma b_mem_side (c : cube n) (j : fin n) : c.b j ∈ c.side j :=
by simp [side, cube.hw, le_refl]

def to_set (c : cube n) : set (fin n → ℝ) :=
{ x | ∀j, x j ∈ side c j }

def to_set_subset {c c' : cube n} : c.to_set ⊆ c'.to_set ↔ ∀j, c.side j ⊆ c'.side j :=
begin
  split, intros h j x hx,
  let f : fin n → ℝ := λ j', if j' = j then x else c.b j',
  have : f ∈ c.to_set,
  { intro j', by_cases hj' : j' = j; simp [f, hj', if_pos, if_neg, hx] },
  convert h this j, { simp [f, if_pos] },
  intros h f hf j, exact h j (hf j)
end

def to_set_disjoint {c c' : cube n} : disjoint c.to_set c'.to_set ↔
  ∃j, disjoint (c.side j) (c'.side j) :=
begin
  split, intros h, classical, by_contra h',
  simp only [not_disjoint_iff, classical.skolem, not_exists] at h',
  cases h' with f hf,
  apply not_disjoint_iff.mpr ⟨f, _, _⟩ h; intro j, exact (hf j).1, exact (hf j).2,
  rintro ⟨j, hj⟩, rw [set.disjoint_iff], rintros f ⟨h1f, h2f⟩,
  apply not_disjoint_iff.mpr ⟨f j, h1f j, h2f j⟩ hj
end

lemma b_mem_to_set (c : cube n) : c.b ∈ c.to_set :=
by simp [to_set]

protected def tail (c : cube (n+1)) : cube n :=
⟨tail c.b, c.w, c.hw⟩

lemma side_tail (c : cube (n+1)) (j : fin n) : c.tail.side j = c.side j.succ := rfl

def bottom (c : cube (n+1)) : set (fin (n+1) → ℝ) :=
{ x | x 0 = c.b 0 ∧ tail x ∈ c.tail.to_set }

lemma b_mem_bottom (c : cube (n+1)) : c.b ∈ c.bottom :=
by simp [bottom, to_set, side, cube.hw, le_refl, cube.tail]

def xm (c : cube (n+1)) : ℝ :=
c.b 0 + c.w

lemma b_lt_xm (c : cube (n+1)) : c.b 0 < c.xm := by simp [xm, hw]
lemma b_ne_xm (c : cube (n+1)) : c.b 0 ≠ c.xm := ne_of_lt c.b_lt_xm

def shift_up (c : cube (n+1)) : cube (n+1) :=
⟨cons c.xm $ tail c.b, c.w, c.hw⟩

@[simp] lemma tail_shift_up (c : cube (n+1)) : c.shift_up.tail = c.tail :=
by simp [shift_up, cube.tail]

@[simp] lemma head_shift_up (c : cube (n+1)) : c.shift_up.b 0 = c.xm := rfl

def unit_cube : cube n :=
⟨λ _, 0, 1, by norm_num⟩

@[simp] lemma side_unit_cube {j : fin n} : unit_cube.side j = Ico 0 1 :=
by norm_num [unit_cube, side]

end cube
open cube

variables {ι : Type} [fintype ι] {cs : ι → cube (n+1)} {i i' : ι}

/-- A finite family of (at least 2) cubes partitioning the unit cube with different sizes -/
def correct (cs : ι → cube n) : Prop :=
pairwise (disjoint on (cube.to_set ∘ cs)) ∧
(⋃(i : ι), (cs i).to_set) = unit_cube.to_set ∧
injective (cube.w ∘ cs) ∧
2 ≤ #ι ∧
3 ≤ n

variable (h : correct cs)

include h
lemma to_set_subset_unit_cube {i} : (cs i).to_set ⊆ unit_cube.to_set :=
by { rw [←h.2.1], exact subset_Union _ i }

lemma side_subset {i j} : (cs i).side j ⊆ Ico 0 1 :=
by { have := to_set_subset_unit_cube h, rw [to_set_subset] at this,
     convert this j, norm_num [unit_cube] }

lemma zero_le_of_mem_side {i j x} (hx : x ∈ (cs i).side j) : 0 ≤ x :=
(side_subset h hx).1

lemma zero_le_of_mem {i p} (hp : p ∈ (cs i).to_set) (j) : 0 ≤ p j :=
zero_le_of_mem_side h (hp j)

lemma zero_le_b {i j} : 0 ≤ (cs i).b j :=
zero_le_of_mem h (cs i).b_mem_to_set j

lemma b_add_w_le_one {j} : (cs i).b j + (cs i).w ≤ 1 :=
by { have := side_subset h, rw [side, Ico_subset_Ico_iff] at this, convert this.2, simp [hw] }

/-- The width of any cube in the partition cannot be 1. -/
lemma w_ne_one (i : ι) : (cs i).w ≠ 1 :=
begin
  intro hi,
  have := h.2.2.2.1, rw [cardinal.two_le_iff' i] at this, cases this with i' hi',
  let p := (cs i').b,
  have hp : p ∈ (cs i').to_set := (cs i').b_mem_to_set,
  have h2p : p ∈ (cs i).to_set,
  { intro j, split,
    transitivity (0 : ℝ),
    { rw [←add_le_add_iff_right (1 : ℝ)], convert b_add_w_le_one h, rw hi, rw zero_add },
    apply zero_le_b h, apply lt_of_lt_of_le (side_subset h $ (cs i').b_mem_side j).2,
    simp [hi, zero_le_b h] },
  apply not_disjoint_iff.mpr ⟨p, hp, h2p⟩,
  apply h.1, exact hi'.symm
end

/-- The top of a cube (which is the bottom of the cube shifted up by its width) must be covered by
  bottoms of (other) cubes in the family. -/
lemma shift_up_bottom_subset_bottoms (hc : (cs i).xm ≠ 1) :
  (cs i).shift_up.bottom ⊆ ⋃(i : ι), (cs i).bottom :=
begin
  intros p hp, cases hp with hp0 hps, rw [tail_shift_up] at hps,
  have : p ∈ (unit_cube : cube (n+1)).to_set,
  { simp only [to_set, forall_fin_succ, hp0, side_unit_cube, mem_set_of_eq, mem_Ico,
      head_shift_up], refine ⟨⟨_, _⟩, _⟩,
    { rw [←zero_add (0 : ℝ)], apply add_le_add, apply zero_le_b h, apply (cs i).hw' },
    { exact lt_of_le_of_ne (b_add_w_le_one h) hc },
    intro j, exact side_subset h (hps j) },
  rw [←h.2.1] at this, rcases this with ⟨_, ⟨i', rfl⟩, hi'⟩,
  rw [mem_Union], use i', refine ⟨_, λ j, hi' j.succ⟩,
  have : i ≠ i', { rintro rfl, apply not_le_of_lt (hi' 0).2, rw [hp0], refl },
  have := h.1 i i' this, rw [on_fun, to_set_disjoint, exists_fin_succ] at this,
  rcases this with h0|⟨j, hj⟩,
  rw [hp0], symmetry, apply eq_of_Ico_disjoint h0 (by simp [hw]) _,
  convert hi' 0, rw [hp0], refl,
  exfalso, apply not_disjoint_iff.mpr ⟨tail p j, hps j, hi' j.succ⟩ hj
end
omit h

/-- A valley is a square on which cubes in the family of cubes are placed, so that the cubes
  completely cover the valley and none of those cubes is partially outside the square.
  We also require that no cube on it has the same size as the valley (so that there are at least
  two cubes on the valley).
  This is the main concept in the formalization.
  We prove that the smallest cube on a valley has another valley on the top of it, which
  gives an infinite sequence of cubes in the partition, which contradicts the finiteness.
  A valley is characterized by a cube `c` (which is not a cube in the family cs) by considering
  the bottom face of `c`. -/
def valley (cs : ι → cube (n+1)) (c : cube (n+1)) : Prop :=
c.bottom ⊆ (⋃(i : ι), (cs i).bottom) ∧
(∀i, (cs i).b 0 = c.b 0 → (∃x, x ∈ (cs i).tail.to_set ∩ c.tail.to_set) →
  (cs i).tail.to_set ⊆ c.tail.to_set) ∧
∀(i : ι), (cs i).b 0 = c.b 0 → (cs i).w ≠ c.w

variables {c : cube (n+1)} (v : valley cs c)

/-- The bottom of the unit cube is a valley -/
lemma valley_unit_cube (h : correct cs) : valley cs unit_cube :=
begin
  refine ⟨_, _, _⟩,
  { intro v,
    simp only [bottom, and_imp, mem_Union, mem_set_of_eq],
    intros h0 hv,
    have : v ∈ (unit_cube : cube (n+1)).to_set,
    { dsimp only [to_set, unit_cube, mem_set_of_eq],
      rw [forall_fin_succ, h0], split, norm_num [side, unit_cube], exact hv },
    rw [←h.2.1] at this, rcases this with ⟨_, ⟨i, rfl⟩, hi⟩,
    use i,
    split, { apply le_antisymm, rw h0, exact zero_le_b h, exact (hi 0).1 },
    intro j, exact hi _ },
  { intros i hi h', rw to_set_subset, intro j, convert side_subset h using 1, simp [side_tail] },
  { intros i hi, exact w_ne_one h i }
end

/-- the cubes which lie in the valley `c` -/
def bcubes (cs : ι → cube (n+1)) (c : cube (n+1)) : set ι :=
{ i : ι | (cs i).b 0 = c.b 0 ∧ (cs i).tail.to_set ⊆ c.tail.to_set }

/-- A cube which lies on the boundary of a valley in dimension `j` -/
def on_boundary (hi : i ∈ bcubes cs c) (j : fin n) : Prop :=
c.b j.succ = (cs i).b j.succ ∨ (cs i).b j.succ + (cs i).w = c.b j.succ + c.w

lemma tail_sub (hi : i ∈ bcubes cs c) : ∀j, (cs i).tail.side j ⊆ c.tail.side j :=
by { rw [←to_set_subset], exact hi.2 }

lemma bottom_mem_side (hi : i ∈ bcubes cs c) : c.b 0 ∈ (cs i).side 0 :=
by { convert b_mem_side (cs i) _ using 1, rw hi.1 }

lemma b_le_b (hi : i ∈ bcubes cs c) (j : fin n) : c.b j.succ ≤ (cs i).b j.succ :=
(tail_sub hi j $ b_mem_side _ _).1

lemma t_le_t (hi : i ∈ bcubes cs c) (j : fin n) :
  (cs i).b j.succ + (cs i).w ≤ c.b j.succ + c.w  :=
begin
  have h' := tail_sub hi j, dsimp only [side] at h', rw [Ico_subset_Ico_iff] at h',
  exact h'.2, simp [hw]
end

include h v
/-- Every cube in the valley must be smaller than it -/
lemma w_lt_w (hi : i ∈ bcubes cs c) : (cs i).w < c.w :=
begin
  apply lt_of_le_of_ne _ (v.2.2 i hi.1),
  have j : fin n := ⟨1, nat.le_of_succ_le_succ h.2.2.2.2⟩,
  rw [←add_le_add_iff_left ((cs i).b j.succ)],
  apply le_trans (t_le_t hi j), rw [add_le_add_iff_right], apply b_le_b hi,
end

open cardinal
/-- There are at least two cubes in a valley -/
lemma two_le_mk_bcubes : 2 ≤ #(bcubes cs c) :=
begin
  rw [two_le_iff],
  rcases v.1 c.b_mem_bottom with ⟨_, ⟨i, rfl⟩, hi⟩,
  have h2i : i ∈ bcubes cs c :=
    ⟨hi.1.symm, v.2.1 i hi.1.symm ⟨tail c.b, hi.2, λ j, c.b_mem_side j.succ⟩⟩,
  let j : fin (n+1) := ⟨2, h.2.2.2.2⟩,
  have hj : 0 ≠ j := by { simp only [fin.ext_iff, ne.def], contradiction },
  let p : fin (n+1) → ℝ := λ j', if j' = j then c.b j + (cs i).w else c.b j',
  have hp : p ∈ c.bottom,
  { split, { simp only [bottom, p, if_neg hj] },
    intro j', simp only [tail, side_tail],
    by_cases hj' : j'.succ = j,
    { simp [p, -add_comm, if_pos, side, hj', hw', w_lt_w h v h2i] },
    { simp [p, -add_comm, if_neg hj'] }},
  rcases v.1 hp with ⟨_, ⟨i', rfl⟩, hi'⟩,
  have h2i' : i' ∈ bcubes cs c := ⟨hi'.1.symm, v.2.1 i' hi'.1.symm ⟨tail p, hi'.2, hp.2⟩⟩,
  refine ⟨⟨i, h2i⟩, ⟨i', h2i'⟩, _⟩,
  intro hii', cases congr_arg subtype.val hii',
  apply not_le_of_lt (hi'.2 ⟨1, nat.le_of_succ_le_succ h.2.2.2.2⟩).2,
  simp only [-add_comm, tail, cube.tail, p],
  rw [if_pos, add_le_add_iff_right],
  { exact (hi.2 _).1 },
  refl
end

/-- There is a cube in the valley -/
lemma nonempty_bcubes : (bcubes cs c).nonempty :=
begin
  rw [←set.ne_empty_iff_nonempty], intro h', have := two_le_mk_bcubes h v, rw h' at this,
  apply not_lt_of_le this, rw mk_emptyc, norm_cast, norm_num
end

/-- There is a smallest cube in the valley -/
lemma exists_mi : ∃(i : ι), i ∈ bcubes cs c ∧ ∀(i' ∈ bcubes cs c),
  (cs i).w ≤ (cs i').w :=
by simpa
  using (bcubes cs c).exists_min_image (λ i, (cs i).w) (finite.of_fintype _) (nonempty_bcubes h v)

/-- We let `mi` be the (index for the) smallest cube in the valley `c` -/
def mi : ι := classical.some $ exists_mi h v

variables {h v}
lemma mi_mem_bcubes : mi h v ∈ bcubes cs c :=
(classical.some_spec $ exists_mi h v).1

lemma mi_minimal (hi : i ∈ bcubes cs c) : (cs $ mi h v).w ≤ (cs i).w :=
(classical.some_spec $ exists_mi h v).2 i hi

lemma mi_strict_minimal (hii' : mi h v ≠ i) (hi : i ∈ bcubes cs c) :
  (cs $ mi h v).w < (cs i).w :=
by { apply lt_of_le_of_ne (mi_minimal hi), apply h.2.2.1.ne, apply hii' }

/-- The top of `mi` cannot be 1, since there is a larger cube in the valley -/
lemma mi_xm_ne_one : (cs $ mi h v).xm ≠ 1 :=
begin
  apply ne_of_lt, rcases (two_le_iff' _).mp (two_le_mk_bcubes h v) with ⟨⟨i, hi⟩, h2i⟩,
  swap, exact ⟨mi h v, mi_mem_bcubes⟩,
  apply lt_of_lt_of_le _ (b_add_w_le_one h), exact i, exact 0,
  rw [xm, mi_mem_bcubes.1, hi.1, _root_.add_lt_add_iff_left],
  apply mi_strict_minimal _ hi, intro h', apply h2i, rw subtype.ext_iff_val, exact h'
end

/-- If `mi` lies on the boundary of the valley in dimension j, then this lemma expresses that all
  other cubes on the same boundary extend further from the boundary.
  More precisely, there is a j-th coordinate `x : ℝ` in the valley, but not in `mi`,
  such that every cube that shares a (particular) j-th coordinate with `mi` also contains j-th
  coordinate `x` -/
lemma smallest_on_boundary {j} (bi : on_boundary (mi_mem_bcubes : mi h v ∈ _) j) :
  ∃(x : ℝ), x ∈ c.side j.succ \ (cs $ mi h v).side j.succ ∧
  ∀{{i'}} (hi' : i' ∈ bcubes cs c), i' ≠ mi h v →
    (cs $ mi h v).b j.succ ∈ (cs i').side j.succ → x ∈ (cs i').side j.succ :=
begin
  let i := mi h v, have hi : i ∈ bcubes cs c := mi_mem_bcubes,
  cases bi,
  { refine ⟨(cs i).b j.succ + (cs i).w, ⟨_, _⟩, _⟩,
    { simp [side, bi, hw', w_lt_w h v hi] },
    { intro h', simpa [i, lt_irrefl] using h'.2 },
    intros i' hi' i'_i h2i', split,
    apply le_trans h2i'.1, { simp [hw'] },
    apply lt_of_lt_of_le (add_lt_add_left (mi_strict_minimal i'_i.symm hi') _),
    simp [bi.symm, b_le_b hi'] },
  let s := bcubes cs c \ { i },
  have hs : s.nonempty,
  { rcases (two_le_iff' (⟨i, hi⟩ : bcubes cs c)).mp (two_le_mk_bcubes h v) with ⟨⟨i', hi'⟩, h2i'⟩,
    refine ⟨i', hi', _⟩, simp only [mem_singleton_iff], intro h, apply h2i', simp [h] },
  rcases set.exists_min_image s (w ∘ cs) (finite.of_fintype _) hs with ⟨i', ⟨hi', h2i'⟩, h3i'⟩,
  rw [mem_singleton_iff] at h2i',
  let x := c.b j.succ + c.w - (cs i').w,
  have hx : x < (cs i).b j.succ,
  { dsimp only [x], rw [←bi, add_sub_assoc, add_lt_iff_neg_left, sub_lt_zero],
    apply mi_strict_minimal (ne.symm h2i') hi' },
  refine ⟨x, ⟨_, _⟩, _⟩,
  { simp only [side, x, -add_comm, -add_assoc, neg_lt_zero, hw, add_lt_iff_neg_left, and_true,
      mem_Ico, sub_eq_add_neg],
    rw [add_assoc, le_add_iff_nonneg_right, ←sub_eq_add_neg, sub_nonneg],
    apply le_of_lt (w_lt_w h v hi') },
  { simp only [side, not_and_distrib, not_lt, add_comm, not_le, mem_Ico], left, exact hx },
  intros i'' hi'' h2i'' h3i'', split, swap, apply lt_trans hx h3i''.2,
  simp only [x], rw [le_sub_iff_add_le],
  refine le_trans _ (t_le_t hi'' j), rw [add_le_add_iff_left], apply h3i' i'' ⟨hi'', _⟩,
  simp [mem_singleton, h2i'']
end

variables (h v)
/-- `mi` cannot lie on the boundary of the valley. Otherwise, the cube adjacent to it in the `j`-th
  direction will intersect one of the neighbouring cubes on the same boundary as `mi`. -/
lemma mi_not_on_boundary (j : fin n) : ¬on_boundary (mi_mem_bcubes : mi h v ∈ _) j :=
begin
  let i := mi h v, have hi : i ∈ bcubes cs c := mi_mem_bcubes,
  rcases (two_le_iff' j).mp _ with ⟨j', hj'⟩, swap,
  { rw [mk_fin, ←nat.cast_two, nat_cast_le], apply nat.le_of_succ_le_succ h.2.2.2.2 },
  intro hj,
  rcases smallest_on_boundary hj with ⟨x, ⟨hx, h2x⟩, h3x⟩,
  let p : fin (n+1) → ℝ := cons (c.b 0) (λ j₂, if j₂ = j then x else (cs i).b j₂.succ),
  have hp : p ∈ c.bottom,
  { suffices : ∀ (j' : fin n), ite (j' = j) x ((cs i).b j'.succ) ∈ c.side j'.succ,
    { simpa [bottom, p, to_set, tail, side_tail] },
    intro j₂,
    by_cases hj₂ : j₂ = j, { simp [hj₂, hx] },
    simp only [hj₂, if_false], apply tail_sub hi, apply b_mem_side },
  rcases v.1 hp with ⟨_, ⟨i', rfl⟩, hi'⟩,
  have h2i' : i' ∈ bcubes cs c := ⟨hi'.1.symm, v.2.1 i' hi'.1.symm ⟨tail p, hi'.2, hp.2⟩⟩,
  have i_i' : i ≠ i', { rintro rfl, simpa [p, side_tail, i, h2x] using hi'.2 j },
  have : nonempty ↥((cs i').tail.side j' \ (cs i).tail.side j'),
  { apply nonempty_Ico_sdiff, apply mi_strict_minimal i_i' h2i', apply hw },
  rcases this with ⟨⟨x', hx'⟩⟩,
  let p' : fin (n+1) → ℝ :=
  cons (c.b 0) (λ j₂, if j₂ = j' then x' else (cs i).b j₂.succ),
  have hp' : p' ∈ c.bottom,
  { suffices : ∀ (j : fin n), ite (j = j') x' ((cs i).b j.succ) ∈ c.side j.succ,
    { simpa [bottom, p', to_set, tail, side_tail] },
    intro j₂,
    by_cases hj₂ : j₂ = j', simp [hj₂], apply tail_sub h2i', apply hx'.1,
    simp only [if_congr, if_false, hj₂], apply tail_sub hi, apply b_mem_side },
  rcases v.1 hp' with ⟨_, ⟨i'', rfl⟩, hi''⟩,
  have h2i'' : i'' ∈ bcubes cs c := ⟨hi''.1.symm, v.2.1 i'' hi''.1.symm ⟨tail p', hi''.2, hp'.2⟩⟩,
  have i'_i'' : i' ≠ i'',
  { rintro ⟨⟩,
    have : (cs i).b ∈ (cs i').to_set,
    { simp only [to_set, forall_fin_succ, hi.1, bottom_mem_side h2i', true_and, mem_set_of_eq],
      intro j₂, by_cases hj₂ : j₂ = j,
      { simpa [side_tail, p', hj', hj₂] using hi''.2 j },
      { simpa [hj₂] using hi'.2 j₂ } },
    apply not_disjoint_iff.mpr ⟨(cs i).b, (cs i).b_mem_to_set, this⟩ (h.1 i i' i_i') },
  have i_i'' : i ≠ i'', { intro h, induction h, simpa [hx'.2] using hi''.2 j' },
  apply not.elim _ (h.1 i' i'' i'_i''),
  simp only [on_fun, to_set_disjoint, not_disjoint_iff, forall_fin_succ, not_exists, comp_app],
  refine ⟨⟨c.b 0, bottom_mem_side h2i', bottom_mem_side h2i''⟩, _⟩,
  intro j₂,
  by_cases hj₂ : j₂ = j,
  { cases hj₂, refine ⟨x, _, _⟩,
    { convert hi'.2 j, simp [p] },
    apply h3x h2i'' i_i''.symm, convert hi''.2 j, simp [p', hj'] },
  by_cases h2j₂ : j₂ = j',
  { cases h2j₂, refine ⟨x', hx'.1, _⟩, convert hi''.2 j', simp },
  refine ⟨(cs i).b j₂.succ, _, _⟩,
  { convert hi'.2 j₂, simp [hj₂] },
  { convert hi''.2 j₂, simp [h2j₂] }
end

variables {h v}
/-- The same result that `mi` cannot lie on the boundary of the valley written as inequalities. -/
lemma mi_not_on_boundary' (j : fin n) : c.tail.b j < (cs (mi h v)).tail.b j ∧
  (cs (mi h v)).tail.b j + (cs (mi h v)).w < c.tail.b j + c.w :=
begin
  have := mi_not_on_boundary h v j,
  simp only [on_boundary, not_or_distrib] at this, cases this with h1 h2,
  split,
  apply lt_of_le_of_ne (b_le_b mi_mem_bcubes _) h1,
  apply lt_of_le_of_ne _ h2,
  apply ((Ico_subset_Ico_iff _).mp (tail_sub mi_mem_bcubes j)).2,
  simp [hw]
end

/-- The top of `mi` gives rise to a new valley, since the neighbouring cubes extend further upward
  than `mi`. -/
def valley_mi : valley cs ((cs (mi h v)).shift_up) :=
begin
  let i := mi h v, have hi : i ∈ bcubes cs c := mi_mem_bcubes,
  refine ⟨_, _, _⟩,
  { intro p, apply shift_up_bottom_subset_bottoms h mi_xm_ne_one },
  { rintros i' hi' ⟨p2, hp2, h2p2⟩, simp only [head_shift_up] at hi', classical, by_contra h2i',
    rw [tail_shift_up] at h2p2, simp only [not_subset, tail_shift_up] at h2i',
    rcases h2i' with ⟨p1, hp1, h2p1⟩,
    have : ∃p3, p3 ∈ (cs i').tail.to_set ∧ p3 ∉ (cs i).tail.to_set ∧ p3 ∈ c.tail.to_set,
    { simp only [to_set, not_forall, mem_set_of_eq] at h2p1, cases h2p1 with j hj,
      rcases Ico_lemma (mi_not_on_boundary' j).1 (by simp [hw]) (mi_not_on_boundary' j).2
        (le_trans (hp2 j).1 $ le_of_lt (h2p2 j).2)
        (le_trans (h2p2 j).1 $ le_of_lt (hp2 j).2) ⟨hj, hp1 j⟩ with ⟨w, hw, h2w, h3w⟩,
      refine ⟨λ j', if j' = j then w else p2 j', _, _, _⟩,
      { intro j', by_cases h : j' = j,
        { simp only [if_pos h], convert h3w },
        { simp only [if_neg h], exact hp2 j' } },
      { simp only [to_set, not_forall, mem_set_of_eq], use j, rw [if_pos rfl], convert h2w },
      { intro j', by_cases h : j' = j,
        { simp only [if_pos h, side_tail], convert hw },
        { simp only [if_neg h], apply hi.2, apply h2p2 } } },
    rcases this with ⟨p3, h1p3, h2p3, h3p3⟩,
    let p := @cons n (λ_, ℝ) (c.b 0) p3,
    have hp : p ∈ c.bottom, { refine ⟨rfl, _⟩, rwa [tail_cons] },
    rcases v.1 hp with ⟨_, ⟨i'', rfl⟩, hi''⟩,
    have h2i'' : i'' ∈ bcubes cs c,
    { use hi''.1.symm, apply v.2.1 i'' hi''.1.symm,
      use tail p, split, exact hi''.2, rw [tail_cons], exact h3p3 },
    have h3i'' : (cs i).w < (cs i'').w,
    { apply mi_strict_minimal _ h2i'', rintro rfl, apply h2p3, convert hi''.2, rw [tail_cons] },
    let p' := @cons n (λ_, ℝ) (cs i).xm p3,
    have hp' : p' ∈ (cs i').to_set,
    { simpa [to_set, forall_fin_succ, p', hi'.symm] using h1p3 },
    have h2p' : p' ∈ (cs i'').to_set,
    { simp only [to_set, forall_fin_succ, p', cons_succ, cons_zero, mem_set_of_eq],
      refine ⟨_, by simpa [to_set, p] using hi''.2⟩,
      have : (cs i).b 0 = (cs i'').b 0, { by rw [hi.1, h2i''.1] },
      simp [side, hw', xm, this, h3i''] },
    apply not_disjoint_iff.mpr ⟨p', hp', h2p'⟩,
    apply h.1, rintro rfl, apply (cs i).b_ne_xm, rw [←hi', ←hi''.1, hi.1], refl },
  { intros i' hi' h2i',
    dsimp only [shift_up] at h2i',
    replace h2i' := h.2.2.1 h2i'.symm,
    induction h2i',
    exact b_ne_xm (cs i) hi' }
end

variables (h)
omit v

/-- We get a sequence of cubes whose size is decreasing -/
noncomputable def sequence_of_cubes : ℕ → { i : ι // valley cs ((cs i).shift_up) }
| 0     := let v := valley_unit_cube h      in ⟨mi h v, valley_mi⟩
| (k+1) := let v := (sequence_of_cubes k).2 in ⟨mi h v, valley_mi⟩

def decreasing_sequence (k : ℕ) : order_dual ℝ :=
(cs (sequence_of_cubes h k).1).w

lemma strict_mono_sequence_of_cubes : strict_mono $ decreasing_sequence h :=
strict_mono_nat_of_lt_succ $
begin
  intro k, let v := (sequence_of_cubes h k).2, dsimp only [decreasing_sequence, sequence_of_cubes],
  apply w_lt_w h v (mi_mem_bcubes : mi h v ∈ _),
end

omit h
/-- The infinite sequence of cubes contradicts the finiteness of the family. -/
theorem not_correct : ¬correct cs :=
begin
  intro h, apply not_le_of_lt (lt_omega_iff_fintype.mpr ⟨_inst_1⟩),
  rw [omega, lift_id], fapply mk_le_of_injective, exact λ n, (sequence_of_cubes h n).1,
  intros n m hnm, apply strict_mono.injective (strict_mono_sequence_of_cubes h),
  dsimp only [decreasing_sequence], rw hnm
end

/-- **Dissection of Cubes**: A cube cannot be cubed. -/
theorem cannot_cube_a_cube :
  ∀{n : ℕ}, n ≥ 3 →                              -- In ℝ^n for n ≥ 3
  ∀{ι : Type} [fintype ι] {cs : ι → cube n},     -- given a finite collection of (hyper)cubes
  2 ≤ #ι →                                       -- containing at least two elements
  pairwise (disjoint on (cube.to_set ∘ cs)) →    -- which is pairwise disjoint
  (⋃(i : ι), (cs i).to_set) = unit_cube.to_set → -- whose union is the unit cube
  injective (cube.w ∘ cs) →                      -- such that the widths of all cubes are different
  false :=                                       -- then we can derive a contradiction
begin
  intros n hn ι hι cs h1 h2 h3 h4, resetI,
  rcases n, cases hn,
  exact not_correct ⟨h2, h3, h4, h1, hn⟩
end


/-
Copyright (c) 2022. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Firsching, Fabian Kruse, Nikolas Kuhn

! This file was ported from Lean 3 source module analysis.special_functions.stirling
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.PSeries
import Mathbin.Analysis.SpecialFunctions.Log.Deriv
import Mathbin.Tactic.Positivity
import Mathbin.Data.Real.Pi.Wallis

/-!
# Stirling's formula

This file proves Stirling's formula for the factorial.
It states that $n!$ grows asymptotically like $\sqrt{2\pi n}(\frac{n}{e})^n$.

## Proof outline

The proof follows: <https://proofwiki.org/wiki/Stirling%27s_Formula>.

We proceed in two parts.

**Part 1**: We consider the sequence $a_n$ of fractions $\frac{n!}{\sqrt{2n}(\frac{n}{e})^n}$
and prove that this sequence converges to a real, positive number $a$. For this the two main
ingredients are
 - taking the logarithm of the sequence and
 - using the series expansion of $\log(1 + x)$.

**Part 2**: We use the fact that the series defined in part 1 converges againt a real number $a$
and prove that $a = \sqrt{\pi}$. Here the main ingredient is the convergence of Wallis' product
formula for `π`.
-/

open Topology Real BigOperators Nat

open Finset Filter Nat Real

namespace Stirling

/-!
 ### Part 1
 https://proofwiki.org/wiki/Stirling%27s_Formula#Part_1
-/

/-- Define `stirling_seq n` as $\frac{n!}{\sqrt{2n}(\frac{n}{e})^n}$.
Stirling's formula states that this sequence has limit $\sqrt(π)$.
-/
noncomputable def stirlingSeq (n : ℕ) : ℝ :=
  n ! / (sqrt (2 * n) * (n / exp 1) ^ n)
#align stirling.stirling_seq Stirling.stirlingSeq

@[simp]
theorem stirlingSeq_zero : stirlingSeq 0 = 0 := by
  rw [stirling_seq, cast_zero, MulZeroClass.mul_zero, Real.sqrt_zero, MulZeroClass.zero_mul,
    div_zero]
#align stirling.stirling_seq_zero Stirling.stirlingSeq_zero

@[simp]
theorem stirlingSeq_one : stirlingSeq 1 = exp 1 / sqrt 2 := by
  rw [stirling_seq, pow_one, factorial_one, cast_one, mul_one, mul_one_div, one_div_div]
#align stirling.stirling_seq_one Stirling.stirlingSeq_one

/-- We have the expression
`log (stirling_seq (n + 1)) = log(n + 1)! - 1 / 2 * log(2 * n) - n * log ((n + 1) / e)`.
-/
theorem log_stirlingSeq_formula (n : ℕ) :
    log (stirlingSeq n.succ) =
      log n.succ ! - 1 / 2 * log (2 * n.succ) - n.succ * log (n.succ / exp 1) :=
  by
  rw [stirling_seq, log_div, log_mul, sqrt_eq_rpow, log_rpow, Real.log_pow, tsub_tsub] <;>
      try apply ne_of_gt <;>
    positivity
#align stirling.log_stirling_seq_formula Stirling.log_stirlingSeq_formula

-- TODO: Make `positivity` handle `≠ 0` goals
/-- The sequence `log (stirling_seq (m + 1)) - log (stirling_seq (m + 2))` has the series expansion
   `∑ 1 / (2 * (k + 1) + 1) * (1 / 2 * (m + 1) + 1)^(2 * (k + 1))`
-/
theorem log_stirlingSeq_diff_hasSum (m : ℕ) :
    HasSum (fun k : ℕ => (1 : ℝ) / (2 * k.succ + 1) * ((1 / (2 * m.succ + 1)) ^ 2) ^ k.succ)
      (log (stirlingSeq m.succ) - log (stirlingSeq m.succ.succ)) :=
  by
  change HasSum ((fun b : ℕ => 1 / (2 * (b : ℝ) + 1) * ((1 / (2 * m.succ + 1)) ^ 2) ^ b) ∘ succ) _
  refine' (hasSum_nat_add_iff 1).mpr _
  convert(has_sum_log_one_add_inv <| cast_pos.mpr (succ_pos m)).mul_left ((m.succ : ℝ) + 1 / 2)
  · ext k
    rw [← pow_mul, pow_add]
    push_cast
    have : 2 * (k : ℝ) + 1 ≠ 0 := by
      norm_cast
      exact succ_ne_zero (2 * k)
    have : 2 * ((m : ℝ) + 1) + 1 ≠ 0 := by
      norm_cast
      exact succ_ne_zero (2 * m.succ)
    field_simp
    ring
  · have h : ∀ (x : ℝ) (hx : x ≠ 0), 1 + x⁻¹ = (x + 1) / x :=
      by
      intros
      rw [_root_.add_div, div_self hx, inv_eq_one_div]
    simp (disch :=
      norm_cast
      apply_rules [mul_ne_zero, succ_ne_zero, factorial_ne_zero, exp_ne_zero]
        ) only [log_stirling_seq_formula,
      log_div, log_mul, log_exp, factorial_succ, cast_mul, cast_succ, cast_zero, range_one,
      sum_singleton, h]
    ring
#align stirling.log_stirling_seq_diff_has_sum Stirling.log_stirlingSeq_diff_hasSum

/-- The sequence `log ∘ stirling_seq ∘ succ` is monotone decreasing -/
theorem log_stirling_seq'_antitone : Antitone (Real.log ∘ stirlingSeq ∘ succ) :=
  antitone_nat_of_succ_le fun n =>
    sub_nonneg.mp <| (log_stirlingSeq_diff_hasSum n).NonNeg fun m => by positivity
#align stirling.log_stirling_seq'_antitone Stirling.log_stirling_seq'_antitone

/-- We have a bound for successive elements in the sequence `log (stirling_seq k)`.
-/
theorem log_stirlingSeq_diff_le_geo_sum (n : ℕ) :
    log (stirlingSeq n.succ) - log (stirlingSeq n.succ.succ) ≤
      (1 / (2 * n.succ + 1)) ^ 2 / (1 - (1 / (2 * n.succ + 1)) ^ 2) :=
  by
  have h_nonneg : 0 ≤ (1 / (2 * (n.succ : ℝ) + 1)) ^ 2 := sq_nonneg _
  have g :
    HasSum (fun k : ℕ => ((1 / (2 * (n.succ : ℝ) + 1)) ^ 2) ^ k.succ)
      ((1 / (2 * n.succ + 1)) ^ 2 / (1 - (1 / (2 * n.succ + 1)) ^ 2)) :=
    by
    have := (hasSum_geometric_of_lt_1 h_nonneg _).mul_left ((1 / (2 * (n.succ : ℝ) + 1)) ^ 2)
    · simp_rw [← pow_succ] at this
      exact this
    rw [one_div, inv_pow]
    exact inv_lt_one (one_lt_pow ((lt_add_iff_pos_left 1).mpr <| by positivity) two_ne_zero)
  have hab :
    ∀ k : ℕ,
      1 / (2 * (k.succ : ℝ) + 1) * ((1 / (2 * n.succ + 1)) ^ 2) ^ k.succ ≤
        ((1 / (2 * n.succ + 1)) ^ 2) ^ k.succ :=
    by
    refine' fun k => mul_le_of_le_one_left (pow_nonneg h_nonneg k.succ) _
    rw [one_div]
    exact inv_le_one (le_add_of_nonneg_left <| by positivity)
  exact hasSum_le hab (log_stirling_seq_diff_has_sum n) g
#align stirling.log_stirling_seq_diff_le_geo_sum Stirling.log_stirlingSeq_diff_le_geo_sum

/-- We have the bound  `log (stirling_seq n) - log (stirling_seq (n+1))` ≤ 1/(4 n^2)
-/
theorem log_stirlingSeq_sub_log_stirlingSeq_succ (n : ℕ) :
    log (stirlingSeq n.succ) - log (stirlingSeq n.succ.succ) ≤ 1 / (4 * n.succ ^ 2) :=
  by
  have h₁ : 0 < 4 * ((n : ℝ) + 1) ^ 2 := by positivity
  have h₃ : 0 < (2 * ((n : ℝ) + 1) + 1) ^ 2 := by positivity
  have h₂ : 0 < 1 - (1 / (2 * ((n : ℝ) + 1) + 1)) ^ 2 :=
    by
    rw [← mul_lt_mul_right h₃]
    have H : 0 < (2 * ((n : ℝ) + 1) + 1) ^ 2 - 1 := by nlinarith [@cast_nonneg ℝ _ n]
    convert H using 1 <;> field_simp [h₃.ne']
  refine' (log_stirling_seq_diff_le_geo_sum n).trans _
  push_cast
  rw [div_le_div_iff h₂ h₁]
  field_simp [h₃.ne']
  rw [div_le_div_right h₃]
  ring_nf
  norm_cast
  linarith
#align stirling.log_stirling_seq_sub_log_stirling_seq_succ Stirling.log_stirlingSeq_sub_log_stirlingSeq_succ

/-- For any `n`, we have `log_stirling_seq 1 - log_stirling_seq n ≤ 1/4 * ∑' 1/k^2`  -/
theorem log_stirlingSeq_bounded_aux :
    ∃ c : ℝ, ∀ n : ℕ, log (stirlingSeq 1) - log (stirlingSeq n.succ) ≤ c :=
  by
  let d := ∑' k : ℕ, (1 : ℝ) / k.succ ^ 2
  use (1 / 4 * d : ℝ)
  let log_stirling_seq' : ℕ → ℝ := fun k => log (stirling_seq k.succ)
  intro n
  have h₁ : ∀ k, log_stirling_seq' k - log_stirling_seq' (k + 1) ≤ 1 / 4 * (1 / k.succ ^ 2) :=
    by
    intro k
    convert log_stirling_seq_sub_log_stirling_seq_succ k using 1
    field_simp
  have h₂ : (∑ k : ℕ in range n, (1 : ℝ) / k.succ ^ 2) ≤ d :=
    sum_le_tsum (range n) (fun k _ => by positivity)
      ((summable_nat_add_iff 1).mpr <| real.summable_one_div_nat_pow.mpr one_lt_two)
  calc
    log (stirling_seq 1) - log (stirling_seq n.succ) = log_stirling_seq' 0 - log_stirling_seq' n :=
      rfl
    _ = ∑ k in range n, log_stirling_seq' k - log_stirling_seq' (k + 1) := by
      rw [← sum_range_sub' log_stirling_seq' n]
    _ ≤ ∑ k in range n, 1 / 4 * (1 / k.succ ^ 2) := (sum_le_sum fun k _ => h₁ k)
    _ = 1 / 4 * ∑ k in range n, 1 / k.succ ^ 2 := by rw [mul_sum]
    _ ≤ 1 / 4 * d := mul_le_mul_of_nonneg_left h₂ <| by positivity

#align stirling.log_stirling_seq_bounded_aux Stirling.log_stirlingSeq_bounded_aux

/-- The sequence `log_stirling_seq` is bounded below for `n ≥ 1`. -/
theorem log_stirlingSeq_bounded_by_constant : ∃ c, ∀ n : ℕ, c ≤ log (stirlingSeq n.succ) :=
  by
  obtain ⟨d, h⟩ := log_stirling_seq_bounded_aux
  exact ⟨log (stirling_seq 1) - d, fun n => sub_le_comm.mp (h n)⟩
#align stirling.log_stirling_seq_bounded_by_constant Stirling.log_stirlingSeq_bounded_by_constant

/-- The sequence `stirling_seq` is positive for `n > 0`  -/
theorem stirling_seq'_pos (n : ℕ) : 0 < stirlingSeq n.succ :=
  by
  unfold stirling_seq
  positivity
#align stirling.stirling_seq'_pos Stirling.stirling_seq'_pos

/-- The sequence `stirling_seq` has a positive lower bound.
-/
theorem stirling_seq'_bounded_by_pos_constant : ∃ a, 0 < a ∧ ∀ n : ℕ, a ≤ stirlingSeq n.succ :=
  by
  cases' log_stirling_seq_bounded_by_constant with c h
  refine' ⟨exp c, exp_pos _, fun n => _⟩
  rw [← le_log_iff_exp_le (stirling_seq'_pos n)]
  exact h n
#align stirling.stirling_seq'_bounded_by_pos_constant Stirling.stirling_seq'_bounded_by_pos_constant

/-- The sequence `stirling_seq ∘ succ` is monotone decreasing -/
theorem stirling_seq'_antitone : Antitone (stirlingSeq ∘ succ) := fun n m h =>
  (log_le_log (stirling_seq'_pos m) (stirling_seq'_pos n)).mp (log_stirling_seq'_antitone h)
#align stirling.stirling_seq'_antitone Stirling.stirling_seq'_antitone

/-- The limit `a` of the sequence `stirling_seq` satisfies `0 < a` -/
theorem stirlingSeq_has_pos_limit_a : ∃ a : ℝ, 0 < a ∧ Tendsto stirlingSeq atTop (𝓝 a) :=
  by
  obtain ⟨x, x_pos, hx⟩ := stirling_seq'_bounded_by_pos_constant
  have hx' : x ∈ lowerBounds (Set.range (stirling_seq ∘ succ)) := by simpa [lowerBounds] using hx
  refine' ⟨_, lt_of_lt_of_le x_pos (le_cinfₛ (Set.range_nonempty _) hx'), _⟩
  rw [← Filter.tendsto_add_atTop_iff_nat 1]
  exact tendsto_atTop_cinfᵢ stirling_seq'_antitone ⟨x, hx'⟩
#align stirling.stirling_seq_has_pos_limit_a Stirling.stirlingSeq_has_pos_limit_a

/-!
 ### Part 2
 https://proofwiki.org/wiki/Stirling%27s_Formula#Part_2
-/

/-- The sequence `n / (2 * n + 1)` tends to `1/2` -/
theorem tendsto_self_div_two_mul_self_add_one :
    Tendsto (fun n : ℕ => (n : ℝ) / (2 * n + 1)) atTop (𝓝 (1 / 2)) :=
  by
  conv =>
    congr
    skip
    skip
    rw [one_div, ← add_zero (2 : ℝ)]
  refine'
    (((tendsto_const_div_atTop_nhds_0_nat 1).const_add (2 : ℝ)).inv₀
          ((add_zero (2 : ℝ)).symm ▸ two_ne_zero)).congr'
      (eventually_at_top.mpr ⟨1, fun n hn => _⟩)
  rw [add_div' (1 : ℝ) 2 n (cast_ne_zero.mpr (one_le_iff_ne_zero.mp hn)), inv_div]
#align stirling.tendsto_self_div_two_mul_self_add_one Stirling.tendsto_self_div_two_mul_self_add_one

/-- For any `n ≠ 0`, we have the identity
`(stirling_seq n)^4 / (stirling_seq (2*n))^2 * (n / (2 * n + 1)) = W n`, where `W n` is the
`n`-th partial product of Wallis' formula for `π / 2`. -/
theorem stirlingSeq_pow_four_div_stirlingSeq_pow_two_eq (n : ℕ) (hn : n ≠ 0) :
    stirlingSeq n ^ 4 / stirlingSeq (2 * n) ^ 2 * (n / (2 * n + 1)) = Wallis.w n :=
  by
  rw [bit0_eq_two_mul, stirling_seq, pow_mul, stirling_seq, wallis.W_eq_factorial_ratio]
  simp_rw [div_pow, mul_pow]
  rw [sq_sqrt, sq_sqrt]
  any_goals positivity
  have : (n : ℝ) ≠ 0 := cast_ne_zero.mpr hn
  have : exp 1 ≠ 0 := exp_ne_zero 1
  have : ((2 * n)! : ℝ) ≠ 0 := cast_ne_zero.mpr (factorial_ne_zero (2 * n))
  have : 2 * (n : ℝ) + 1 ≠ 0 := by
    norm_cast
    exact succ_ne_zero (2 * n)
  field_simp
  simp only [mul_pow, mul_comm 2 n, mul_comm 4 n, pow_mul]
  ring
#align stirling.stirling_seq_pow_four_div_stirling_seq_pow_two_eq Stirling.stirlingSeq_pow_four_div_stirlingSeq_pow_two_eq

/-- Suppose the sequence `stirling_seq` (defined above) has the limit `a ≠ 0`.
Then the Wallis sequence `W n` has limit `a^2 / 2`.
-/
theorem second_wallis_limit (a : ℝ) (hane : a ≠ 0) (ha : Tendsto stirlingSeq atTop (𝓝 a)) :
    Tendsto Wallis.w atTop (𝓝 (a ^ 2 / 2)) :=
  by
  refine'
    tendsto.congr'
      (eventually_at_top.mpr
        ⟨1, fun n hn =>
          stirling_seq_pow_four_div_stirling_seq_pow_two_eq n (one_le_iff_ne_zero.mp hn)⟩)
      _
  have h : a ^ 2 / 2 = a ^ 4 / a ^ 2 * (1 / 2) :=
    by
    rw [mul_one_div, ← mul_one_div (a ^ 4) (a ^ 2), one_div, ← pow_sub_of_lt a]
    norm_num
  rw [h]
  exact
    ((ha.pow 4).div ((ha.comp (tendsto_id.const_mul_at_top' two_pos)).pow 2)
          (pow_ne_zero 2 hane)).mul
      tendsto_self_div_two_mul_self_add_one
#align stirling.second_wallis_limit Stirling.second_wallis_limit

/-- **Stirling's Formula** -/
theorem tendsto_stirlingSeq_sqrt_pi : Tendsto (fun n : ℕ => stirlingSeq n) atTop (𝓝 (sqrt π)) :=
  by
  obtain ⟨a, hapos, halimit⟩ := stirling_seq_has_pos_limit_a
  have hπ : π / 2 = a ^ 2 / 2 :=
    tendsto_nhds_unique wallis.tendsto_W_nhds_pi_div_two (second_wallis_limit a hapos.ne' halimit)
  rwa [(div_left_inj' (two_ne_zero' ℝ)).mp hπ, sqrt_sq hapos.le]
#align stirling.tendsto_stirling_seq_sqrt_pi Stirling.tendsto_stirlingSeq_sqrt_pi

end Stirling