diff --git a/LeanPool/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett.lean index 99960bb41b..f65ad46595 100644 --- a/LeanPool/DensityHalesJewett.lean +++ b/LeanPool/DensityHalesJewett.lean @@ -7,6 +7,7 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Ackermann public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers @@ -14,6 +15,8 @@ public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Pa public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.DensityHalesJewett.HalesJewett +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Induction public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace @@ -30,7 +33,9 @@ public import LeanPool.DensityHalesJewett.Solution Source: url:https://github.com/gdahia/densityhalesjewett Authors: Gabriel Dahia Status: verified -Main declarations: `Combinatorics.Line.exists_of_density_atTop` +Main declarations: `Combinatorics.Line.exists_of_density_atTop`, + `Combinatorics.Line.exists_of_density`, + `Combinatorics.ArithmeticProgression.exists_of_density_nat` Tags: combinatorics MSC: 05D10, 05A05, 11B75, 68R15 -/ diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett.lean index d8ecec276c..75b15acbb7 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett.lean @@ -5,6 +5,7 @@ Authors: Gabriel Dahia -/ module +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Ackermann public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers @@ -12,6 +13,8 @@ public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Pa public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.DensityHalesJewett.HalesJewett +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Induction public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean new file mode 100644 index 0000000000..b3607aad04 --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean @@ -0,0 +1,643 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive +public import Mathlib.Computability.Ackermann +import LeanPool.DensityHalesJewett.DensityHalesJewett.Induction +import LeanPool.ShelahHalesJewett.Ackermann + +/-! +# Density Hales--Jewett with the Ackermann function as the bound + +Density Hales--Jewett holds for `k ≥ 2` letters in every dimension at least +`ack (4 * k) (k + ⌈1 / δ⌉₊)`: this is `DensityHalesJewett.isDHJBound_ack`. The proof is the +induction on `k`, with `isDHJBound_two` as the base case and `IsDHJBound.step` as the step, +together with a bound for the dimensions that the step produces. + +Shelah's bound for the Hales--Jewett numbers is below `ack 5`, by +`Combinatorics.Line.shelahBound_lt_ack`. Sums, products and powers are also below `ack 5`, so for +`M ≥ 5` an expression built from them is a fixed number of applications of `ack M` above its +arguments: `AckBounded M s c x` says that `x ≤ (ack M)^[c] s`. Iterating such an expression `t` +times is below `ack (M + 1)` at a multiple of `t`, by `iterate_le_ack`. + +The Graham--Rothschild bound iterates Shelah's bound, so it is a fixed number of applications of +`ack 6` above its parameters. Passing from `k` to `k + 1` letters iterates the bound `F` for `k` +letters three times, one inside the other: in `Subspace.densityBound`, in +`IsInsensitive.intersectionTilingBound` and in `stepBound`. A fourth level turns the result into a +single application of `ack`, so the bound for `k + 2` letters is below `ack (4 * k + 5)`. The +levels are not optimized. + +## Main results + +* `DensityHalesJewett.isDHJBound_ack`: density Hales--Jewett for `k ≥ 2` letters in every + dimension at least `ack (4 * k) (k + ⌈1 / δ⌉₊)`. +* `DensityHalesJewett.exists_isDHJDimension_ackBounded`: for `k + 2` letters, a dimension one + application of `ack (4 * k + 5)` above a bound for `1 / δ`. The thresholds of Szemerédi's and + Varnavides' theorems are bounded from this form. +-/ + +@[expose] public section + +open Combinatorics Finset + +namespace DensityHalesJewett + +/-! ### Elementary functions and the Ackermann function -/ + +private lemma add_le_ack (a b : ℕ) : a + b ≤ ack 2 (max a b) := by + rw [ack_two] + omega + +private lemma sq_add_three_le (m : ℕ) : m * m + 3 ≤ 2 ^ (m + 3) := by + induction m with + | zero => norm_num + | succ m ih => + rw [pow_succ] + nlinarith + +private lemma mul_le_ack (a b : ℕ) : a * b ≤ ack 3 (max a b) := by + rw [ack_three] + have h := sq_add_three_le (max a b) + have h' : a * b ≤ max a b * max a b := Nat.mul_le_mul (le_max_left _ _) (le_max_right _ _) + omega + +private lemma two_pow_le_ack (x : ℕ) : 2 ^ x ≤ ack 3 x := by + rw [ack_three, pow_add] + have : 1 ≤ 2 ^ x := Nat.one_le_two_pow + omega + +private lemma pow_le_ack (a b : ℕ) : a ^ b ≤ ack 5 (max a b) := + calc a ^ b ≤ (2 ^ a) ^ b := Nat.pow_le_pow_left (Nat.lt_two_pow_self).le b + _ = 2 ^ (a * b) := (pow_mul 2 a b).symm + _ ≤ ack 3 (a * b) := two_pow_le_ack _ + _ ≤ ack 3 (ack 3 (max a b)) := ack_mono_right _ (mul_le_ack a b) + _ ≤ ack 5 (max a b) := (ack_ack_lt_ack_max_add_two 3 3 _).le + +private lemma ack_four_one : ack 4 1 = 65533 := by + have h1 : ack 4 1 = ack 3 (ack 4 0) := ack_succ_succ 3 0 + have h2 : ack 4 0 = ack 3 1 := ack_succ_zero 3 + rw [h1, h2, ack_three, ack_three] + norm_num + +private lemma add_le_ack_four {c s : ℕ} (hc : c ≤ 65532) (hs : 1 ≤ s) : c + s ≤ ack 4 s := by + obtain ⟨t, rfl⟩ := Nat.exists_eq_add_of_le' hs + have h := (ack_strictMono_right 4).add_le_nat t 1 + rw [ack_four_one] at h + omega + +private lemma ack_add_le {M c s : ℕ} (hM : 2 ≤ M) (hc : c ≤ 65532) (hs : 1 ≤ s) : + ack (M + 1) (c + s) ≤ ack (M + 3) s := + calc ack (M + 1) (c + s) ≤ ack (M + 1) (ack (M + 2) s) := + ack_mono_right _ ((add_le_ack_four hc hs).trans (ack_mono_left s (by omega))) + _ = ack (M + 2) (s + 1) := (ack_succ_succ (M + 1) s).symm + _ ≤ ack (M + 3) s := ack_succ_right_le_ack_succ_left (M + 2) s + +private lemma ack_ack_add_le {M c s : ℕ} (hM : 2 ≤ M) (hc : c ≤ 65532) (hs : 1 ≤ s) : + ack (M + 3) (ack (M + 1) (c + s)) ≤ ack (M + 4) s := by + obtain ⟨t, rfl⟩ := Nat.exists_eq_add_of_le' hs + calc ack (M + 3) (ack (M + 1) (c + (t + 1))) ≤ ack (M + 3) (ack (M + 3) (t + 1)) := + ack_mono_right _ (ack_add_le hM hc hs) + _ ≤ ack (M + 3) (ack (M + 4) t) := + ack_mono_right _ (ack_succ_right_le_ack_succ_left (M + 3) t) + _ = ack (M + 4) (t + 1) := (ack_succ_succ (M + 3) t).symm + +private lemma le_iterate_ack (M c s : ℕ) : s ≤ (ack M)^[c] s := by + induction c with + | zero => rfl + | succ c ih => + rw [Function.iterate_succ_apply'] + exact ih.trans (lt_ack_right _ _).le + +private lemma iterate_ack_le (M t x : ℕ) : (ack M)^[t] x ≤ ack (M + 1) (t + x) := by + induction t with + | zero => simpa using (lt_ack_right _ _).le + | succ t ih => + rw [Function.iterate_succ_apply', (by omega : t + 1 + x = t + x + 1), ack_succ_succ] + exact ack_mono_right _ ih + +private lemma iterate_add_le {f : ℕ → ℕ} (hf : StrictMono f) (t y q : ℕ) : + f^[t] y + q ≤ f^[t] (y + q) := by + induction t generalizing y with + | zero => rfl + | succ t ih => + rw [Function.iterate_succ_apply, Function.iterate_succ_apply] + refine (ih (f y)).trans ((hf.iterate t).monotone ?_) + simpa [add_comm] using hf.add_le_nat q y + +/-- `x` is at most `c` applications of `ack M` above `s`. -/ +def AckBounded (M s c x : ℕ) : Prop := x ≤ (ack M)^[c] s + +namespace AckBounded + +variable {M M' s s' c c' x y g : ℕ} + +lemma of_le (h : x ≤ s) : AckBounded M s 0 x := h + +lemma num (hM : 5 ≤ M) (x : ℕ) (h : x ≤ 65533 := by norm_num) : AckBounded M s 1 x := by + change x ≤ ack M s + exact (h.trans_eq ack_four_one.symm).trans + ((ack_succ_zero 4).symm.le.trans (ack_le_ack hM (Nat.zero_le s))) + +lemma mono (h : AckBounded M s c x) (hc : c ≤ c') : AckBounded M s c' x := by + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hc + rw [AckBounded, add_comm, Function.iterate_add_apply] + exact h.trans (le_iterate_ack M d _) + +lemma le (h : AckBounded M s c y) (hxy : x ≤ y) : AckBounded M s c x := hxy.trans h + +lemma size (h : AckBounded M s c x) (hs : s ≤ s') : AckBounded M s' c x := + h.trans ((ack_mono_right M).iterate c hs) + +lemma lift (h : AckBounded M s c x) (hM : M ≤ M') : AckBounded M' s c x := + h.trans (Monotone.iterate_le_of_le (ack_mono_right M) (fun y ↦ ack_mono_left y hM) c s) + +lemma join (hx : AckBounded M s c x) (hy : AckBounded M s c' y) : + AckBounded M s (max c c') (max x y) := + max_le (hx.mono (le_max_left _ _)) (hy.mono (le_max_right _ _)) + +lemma comp (hx : AckBounded M s c x) (hg : g ≤ M) (hy : y ≤ ack g x) : + AckBounded M s (c + 1) y := by + rw [AckBounded, Function.iterate_succ_apply'] + exact hy.trans (ack_le_ack hg hx) + +lemma trans (hx : AckBounded M s c x) (hy : AckBounded M x c' y) : + AckBounded M s (c' + c) y := by + rw [AckBounded, Function.iterate_add_apply] + exact le_trans hy ((ack_mono_right M).iterate c' hx) + +lemma add (hx : AckBounded M s c x) (hM : 5 ≤ M) (hy : AckBounded M s c' y) : + AckBounded M s (max c c' + 1) (x + y) := + (hx.join hy).comp (by omega) (add_le_ack x y) + +lemma mul (hx : AckBounded M s c x) (hM : 5 ≤ M) (hy : AckBounded M s c' y) : + AckBounded M s (max c c' + 1) (x * y) := + (hx.join hy).comp (by omega) (mul_le_ack x y) + +lemma pow (hx : AckBounded M s c x) (hM : 5 ≤ M) (hy : AckBounded M s c' y) : + AckBounded M s (max c c' + 1) (x ^ y) := + (hx.join hy).comp hM (pow_le_ack x y) + +/-- A bounded number of applications of `ack M` is below `ack (M + 3)`. -/ +lemma le_ack (h : AckBounded M s c x) (hM : 2 ≤ M) (hc : c ≤ 65532) (hs : 1 ≤ s) : + x ≤ ack (M + 3) s := + (le_trans h (iterate_ack_le M c s)).trans (ack_add_le hM hc hs) + +end AckBounded + +open AckBounded + +/-- Iterating a function that is `c` applications of `ack M` above its argument. -/ +private lemma iterate_le_ack {f : ℕ → ℕ} {M σ c : ℕ} (hf : ∀ x, AckBounded M (max σ x) c (f x)) + (t x₀ : ℕ) : f^[t] x₀ ≤ ack (M + 1) (c * t + max σ x₀) := by + refine le_trans ?_ (iterate_ack_le M _ _) + induction t with + | zero => exact le_max_right σ x₀ + | succ t ih => + rw [Function.iterate_succ_apply', Nat.mul_succ, add_comm (c * t) c, + Function.iterate_add_apply] + exact le_trans (hf _) ((ack_mono_right M).iterate c + (max_le ((le_max_left σ x₀).trans (le_iterate_ack M _ _)) ih)) + +/-! ### The Graham--Rothschild bound -/ + +private lemma ackBounded_translatedCubeBound {s c n : ℕ} (hc : c ≤ s) (hn : n ≤ s) : + AckBounded 5 s 7 (FiniteUnions.translatedCubeBound c n) := by + have h1 : AckBounded 5 s _ (n + 1) := (of_le hn).add le_rfl (num le_rfl 1) + have h2 : AckBounded 5 s _ (2 * 2 ^ (n + 1) + c) := + ((num le_rfl 2).mul le_rfl ((num le_rfl 2).pow le_rfl h1)).add le_rfl (of_le hc) + exact ((h2.comp le_rfl (Line.shelahBound_lt_ack _ _).le).mul le_rfl h1).mono (by grind) + +private lemma minCanonicalBound_eq (c t : ℕ) : + FiniteUnions.minCanonicalBound c t = (FiniteUnions.translatedCubeBound c)^[t] 0 := by + induction t with + | zero => rfl + | succ t ih => rw [FiniteUnions.minCanonicalBound, ih, Function.iterate_succ_apply'] + +private lemma minCanonicalBound_le {s c : ℕ} (hc : c ≤ s) (t : ℕ) : + FiniteUnions.minCanonicalBound c t ≤ ack 6 (7 * t + s) := by + rw [minCanonicalBound_eq] + simpa using iterate_le_ack (f := FiniteUnions.translatedCubeBound c) (σ := s) + (fun x ↦ ackBounded_translatedCubeBound (hc.trans (le_max_left _ _)) (le_max_right _ _)) t 0 + +private lemma ackBounded_monochromaticUnionsBound {s c m : ℕ} (hc : c ≤ s) (hm : m ≤ s) : + AckBounded 6 s 5 (FiniteUnions.monochromaticUnionsBound c m) := by + obtain _ | m := m + · exact of_le (Nat.zero_le s) |>.mono (Nat.zero_le 5) + have h6 : 5 ≤ 6 := by norm_num + have ht : AckBounded 6 s _ (7 * (m * c + 1) + s) := + ((num h6 7).mul h6 (((of_le ((Nat.le_succ m).trans hm)).mul h6 (of_le hc)).add h6 + (num h6 1))).add h6 (of_le le_rfl) + exact (ht.comp le_rfl (minCanonicalBound_le hc _)).mono (by grind) + +/-- One step of the recursion `Canonization.bound`. -/ +private lemma ackBounded_canonizationStep {σ k c p : ℕ} (hk : k + 1 ≤ σ) (hc : c ≤ σ) + (hp : p ≤ σ) (B s : ℕ) : + AckBounded 5 (max σ (max B s)) 7 (B + Line.shelahBound k (c ^ (k + 1) ^ (p + B + s))) := by + have hσ : σ ≤ max σ (max B s) := le_max_left _ _ + have hB : AckBounded 5 (max σ (max B s)) 0 B := of_le ((le_max_left _ _).trans (le_max_right _ _)) + have harg : AckBounded 5 (max σ (max B s)) _ (2 * k + c ^ (k + 1) ^ (p + B + s)) := + ((num le_rfl 2).mul le_rfl (of_le ((Nat.le_succ k).trans (hk.trans hσ)))).add le_rfl + ((of_le (hc.trans hσ)).pow le_rfl ((of_le (hk.trans hσ)).pow le_rfl + (((of_le (hp.trans hσ)).add le_rfl hB).add le_rfl + (of_le ((le_max_right _ _).trans (le_max_right _ _)))))) + exact (hB.add le_rfl (harg.comp le_rfl (Line.shelahBound_lt_ack _ _).le)).mono (by grind) + +private lemma canonizationBound_le_iterate {σ k c p : ℕ} (hk : k + 1 ≤ σ) (hc : c ≤ σ) + (hp : p ≤ σ) (ℓ s : ℕ) : Canonization.bound k c ℓ p s ≤ (ack 5)^[7 * ℓ] (σ + s + ℓ) := by + induction ℓ generalizing s with + | zero => simp [Canonization.bound] + | succ ℓ ih => + rw [Canonization.bound, Nat.mul_succ, add_comm (7 * ℓ) 7, Function.iterate_add_apply, + (by omega : σ + s + (ℓ + 1) = σ + (s + 1) + ℓ)] + refine le_trans (ackBounded_canonizationStep hk hc hp _ s) + ((ack_mono_right 5).iterate 7 (max_le ?_ (max_le (ih _) ?_))) + · exact (by omega : σ ≤ σ + (s + 1) + ℓ).trans (le_iterate_ack _ _ _) + · exact (by omega : s ≤ σ + (s + 1) + ℓ).trans (le_iterate_ack _ _ _) + +private lemma canonizationBound_le {σ k c p : ℕ} (hk : k + 1 ≤ σ) (hc : c ≤ σ) (hp : p ≤ σ) + (ℓ s : ℕ) : Canonization.bound k c ℓ p s ≤ ack 6 (8 * ℓ + σ + s) := + (canonizationBound_le_iterate hk hc hp ℓ s).trans + ((iterate_ack_le 5 _ _).trans (ack_mono_right 6 (by omega))) + +/-- The Graham--Rothschild bound is eight applications of `ack 6` above its parameters. -/ +private lemma ackBounded_grahamRothschildBound {s k r m : ℕ} (hk : k + 1 ≤ s) (hr : r ≤ s) + (hm : m ≤ s) : AckBounded 6 s 8 (GrahamRothschild.bound k r m) := by + have h6 : 5 ≤ 6 := by norm_num + have harg : AckBounded 6 s _ (8 * FiniteUnions.monochromaticUnionsBound r m + s) := + ((num h6 8).mul h6 (ackBounded_monochromaticUnionsBound hr hm)).add h6 (of_le le_rfl) + exact (harg.comp le_rfl (canonizationBound_le hk hr (Nat.zero_le _) _ 0)).mono (by grind) + +/-! ### Natural bounds for the reciprocals of the real parameters -/ + +section Reciprocals + +variable {k N n : ℕ} {δ : ℝ} + +private lemma one_div_mul_le {a b A B : ℝ} (ha : 0 < a) (hb : 0 < b) (hA : 1 / a ≤ A) + (hB : 1 / b ≤ B) : 1 / (a * b) ≤ A * B := by + rw [← one_div_mul_one_div] + exact mul_le_mul hA hB (by positivity) ((by positivity : (0 : ℝ) ≤ 1 / a).trans hA) + +private lemma one_div_div_le {a c A : ℝ} (hc : 0 ≤ c) (hA : 1 / a ≤ A) : + 1 / (a / c) ≤ c * A := by + rw [one_div_div, div_eq_mul_one_div] + exact mul_le_mul_of_nonneg_left hA hc + +private lemma one_div_sq_le {a A : ℝ} (ha : 0 < a) (hA : 1 / a ≤ A) : 1 / a ^ 2 ≤ A ^ 2 := by + rw [← one_div_pow] + exact pow_le_pow_left₀ (by positivity) hA 2 + +private lemma one_div_min_le {a b E : ℝ} (ha : 1 / a ≤ E) (hb : 1 / b ≤ E) : 1 / min a b ≤ E := by + rcases min_choice a b with h | h <;> rw [h] <;> assumption + +private lemma floor_div_le {a E : ℕ} {ε : ℝ} (hE : 1 / ε ≤ E) : ⌊(a : ℝ) / ε⌋₊ ≤ a * E := by + refine Nat.floor_le_of_le ?_ + rw [div_eq_mul_one_div, Nat.cast_mul] + exact mul_le_mul_of_nonneg_left hE (Nat.cast_nonneg _) + +lemma one_div_half_le (hn : 1 / δ ≤ n) : 1 / (δ / 2) ≤ ((2 * n : ℕ) : ℝ) := by + exact_mod_cast one_div_div_le zero_le_two hn + +private lemma one_div_quarter_le (hn : 1 / δ ≤ n) : 1 / (δ / 4) ≤ ((4 * n : ℕ) : ℝ) := by + exact_mod_cast one_div_div_le zero_le_four hn + +/-- `variableCutFibersBound` in terms of a natural bound for `1 / ε`. -/ +private lemma variableCutFibersBound_le {a d E : ℕ} {ε : ℝ} (hE : 1 / ε ≤ E) : + Subspace.variableCutFibersBound a d ε ≤ d * (a ^ d * E + 1 + 1) + 1 := by + have h : ⌊(a : ℝ) ^ d / ε⌋₊ ≤ a ^ d * E := by exact_mod_cast floor_div_le (a := a ^ d) hE + unfold Subspace.variableCutFibersBound + gcongr + +/-- A natural bound for `1 / θ`. -/ +private def invθBound (k N n : ℕ) : ℕ := 4 * n * (k + 1) ^ (N + 1) + +/-- A natural bound for `1 / η`. -/ +private def invηBound (k N n : ℕ) : ℕ := 48 * n * invθBound k N n + 4 * invθBound k N n + 6 * n + +/-- A natural bound for `1 / γ`. -/ +private def invγBound (k N n : ℕ) : ℕ := + k * n * invηBound k N n ^ 2 + 2 * invηBound k N n ^ 2 + invηBound k N n + +private lemma one_div_θ_le (hδ : 0 < δ) (hn : 1 / δ ≤ n) : + 1 / Parameters.θ k N δ ≤ invθBound k N n := by + have hden : (((k + 1) ^ (N + 1) - k ^ (N + 1) : ℕ) : ℝ) ≤ (k + 1) ^ (N + 1) := by + exact_mod_cast Nat.sub_le _ _ + have hnδ : 1 ≤ n * δ := by rwa [div_le_iff₀ hδ] at hn + rw [Parameters.θ, one_div_div, invθBound, div_div_eq_mul_div, div_le_iff₀ hδ] + push_cast + nlinarith [mul_le_mul_of_nonneg_left hnδ (by positivity : (0 : ℝ) ≤ 4 * (k + 1) ^ (N + 1))] + +private lemma max_max_le_add_add {x y z : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) (hz : 0 ≤ z) : + max x (max y z) ≤ x + y + z := by + refine max_le ?_ (max_le ?_ ?_) <;> linarith + +private lemma one_div_η_le (hδ : 0 < δ) (hn : 1 / δ ≤ n) : + 1 / Parameters.η k N δ ≤ invηBound k N n := by + have hθ := one_div_θ_le (k := k) (N := N) hδ hn + calc 1 / Parameters.η k N δ + ≤ max (48 * ((n : ℝ) * invθBound k N n)) (max (4 * (invθBound k N n : ℝ)) (6 * n)) := + one_div_min_le (le_max_of_le_left (one_div_div_le (by norm_num) + (one_div_mul_le hδ (Parameters.θ_pos k N hδ) hn hθ))) + (one_div_min_le (le_max_of_le_right (le_max_of_le_left (one_div_div_le (by norm_num) hθ))) + (le_max_of_le_right (le_max_of_le_right (one_div_div_le (by norm_num) hn)))) + _ ≤ 48 * ((n : ℝ) * invθBound k N n) + 4 * (invθBound k N n : ℝ) + 6 * n := + max_max_le_add_add (by positivity) (by positivity) (by positivity) + _ = invηBound k N n := by + unfold invηBound + push_cast + ring + +private lemma one_div_γ_le (hδ : 0 < δ) (hn : 1 / δ ≤ n) : + 1 / Parameters.γ k N δ ≤ invγBound k N n := by + have hη := one_div_η_le (k := k) (N := N) hδ hn + have hη₀ := Parameters.η_pos k N hδ + calc 1 / Parameters.γ k N δ + ≤ max ((k : ℝ) * (n * (invηBound k N n : ℝ) ^ 2)) + (max (2 * (invηBound k N n : ℝ) ^ 2) (1 / 3 * invηBound k N n)) := + one_div_min_le (le_max_of_le_left (one_div_div_le k.cast_nonneg + (one_div_mul_le hδ (by positivity) hn (one_div_sq_le hη₀ hη)))) + (one_div_min_le (le_max_of_le_right (le_max_of_le_left + (one_div_div_le zero_le_two (one_div_sq_le hη₀ hη)))) + (le_max_of_le_right (le_max_of_le_right + (one_div_mul_le (by norm_num) hη₀ (le_refl (1 / 3 : ℝ)) hη)))) + _ ≤ (k : ℝ) * (n * (invηBound k N n : ℝ) ^ 2) + 2 * (invηBound k N n : ℝ) ^ 2 + + 1 / 3 * invηBound k N n := + max_max_le_add_add (by positivity) (by positivity) (by positivity) + _ ≤ invγBound k N n := by + unfold invγBound + push_cast + linarith [(by positivity : (0 : ℝ) ≤ invηBound k N n)] + +/-- The nested density of the recursion `Subspace.densityBound`. -/ +private lemma one_div_nested_le {q : ℕ} (hδ : 0 < δ) (hn : 1 / δ ≤ n) (hq : 1 ≤ q) : + 0 < δ / (2 * (((k + 1) ^ q - k ^ q : ℕ) : ℝ)) ∧ + 1 / (δ / (2 * (((k + 1) ^ q - k ^ q : ℕ) : ℝ))) ≤ ((2 * (k + 1) ^ q * n : ℕ) : ℝ) := by + have hD : 0 < (k + 1) ^ q - k ^ q := + Nat.sub_pos_of_lt (Nat.pow_lt_pow_left k.lt_succ_self (by omega)) + refine ⟨div_pos hδ (mul_pos two_pos (Nat.cast_pos.2 hD)), + (one_div_div_le (by positivity) hn).trans ?_⟩ + push_cast + gcongr + exact_mod_cast Nat.sub_le _ _ + +end Reciprocals + +/-! ### The density increment -/ + +/-- `F` is below level `L` of the Ackermann function at `max (k + 2) n`, for every natural `n` +that bounds the reciprocal of the density. -/ +private def AtLevel (k L : ℕ) (F : ℝ → ℕ) : Prop := + ∀ δ : ℝ, 0 < δ → ∀ n : ℕ, 1 / δ ≤ n → F δ ≤ ack L (max (k + 2) n) + +section Density + +variable {k L M s σ n : ℕ} {F : ℝ → ℕ} {δ : ℝ} + +private lemma AtLevel.ackBounded_half (hF : AtLevel k L F) (hM : 5 ≤ M) (hLM : L ≤ M) + (hk : k + 2 ≤ s) (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded M s 3 (F (δ / 2)) := + (((of_le hk).join ((num hM 2).mul hM (of_le hn))).comp hLM + (hF _ (by positivity) _ (one_div_half_le hnδ))).mono (by grind) + +private lemma AtLevel.ackBounded_quarter (hF : AtLevel k L F) (hM : 5 ≤ M) (hLM : L ≤ M) + (hk : k + 2 ≤ s) (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded M s 3 (F (δ / 4)) := + (((of_le hk).join ((num hM 4).mul hM (of_le hn))).comp hLM + (hF _ (by positivity) _ (one_div_quarter_le hnδ))).mono (by grind) + +/-- One step of the recursion `Subspace.densityBound`. -/ +private lemma ackBounded_densityBound_step (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) + (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : AckBounded L (max σ n) 7 + (max σ (2 * (k + 1) ^ max 1 (F (δ / 2)) * n) + max 1 (F (δ / 2))) := by + have hσ : σ ≤ max σ n := le_max_left _ _ + have hq : AckBounded L (max σ n) _ (max 1 (F (δ / 2))) := + (num hL 1).join (hF.ackBounded_half hL le_rfl (hk.trans hσ) (le_max_right _ _) hδ hnδ) + exact (((of_le hσ).join (((num hL 2).mul hL + ((of_le ((by omega : k + 1 ≤ σ).trans hσ)).pow hL hq)).mul hL + (of_le (le_max_right _ _)))).add hL hq).mono (by grind) + +private lemma densityBound_succ_le (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) (m : ℕ) + (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + Subspace.densityBound k F (m + 1) δ ≤ (ack L)^[7 * m + 1] (max σ n) := by + induction m generalizing δ n with + | zero => exact (hF δ hδ n hnδ).trans (ack_mono_right L (max_le_max_right n hk)) + | succ m ih => + rw [Subspace.densityBound_succ k F (by omega : 1 ≤ m + 1)] + obtain ⟨hδ', hnδ'⟩ := one_div_nested_le (k := k) hδ hnδ (le_max_left 1 (F (δ / 2))) + calc _ ≤ (ack L)^[7 * m + 1] (max σ (2 * (k + 1) ^ max 1 (F (δ / 2)) * n)) + + max 1 (F (δ / 2)) := + Nat.add_le_add_right (ih hδ' hnδ') _ + _ ≤ (ack L)^[7 * m + 1] + (max σ (2 * (k + 1) ^ max 1 (F (δ / 2)) * n) + max 1 (F (δ / 2))) := + iterate_add_le (ack_strictMono_right L) _ _ _ + _ ≤ (ack L)^[7 * m + 1] ((ack L)^[7] (max σ n)) := + (ack_mono_right L).iterate _ (ackBounded_densityBound_step hF hL hk hδ hnδ) + _ = (ack L)^[7 * (m + 1) + 1] (max σ n) := by + rw [← Function.iterate_add_apply] + congr 1 + +private lemma densityBound_le (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) (m : ℕ) + (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + Subspace.densityBound k F m δ ≤ ack (L + 1) (7 * m + max σ n) := by + cases m with + | zero => exact Nat.zero_le _ + | succ m => + exact (densityBound_succ_le hF hL hk m hδ hnδ).trans + ((iterate_ack_le L _ _).trans (ack_mono_right _ (by omega))) + +private lemma ackBounded_restrictAlphabetBound (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) + (m : ℕ) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded (L + 1) (max σ (max m n)) 10 (Subspace.restrictAlphabetBound k F m δ) := by + have hL' : 5 ≤ L + 1 := by omega + have hσ : σ ≤ max σ (max m n) := le_max_left _ _ + have h2n : AckBounded (L + 1) (max σ (max m n)) _ (2 * n) := + (num hL' 2).mul hL' (of_le ((le_max_right _ _).trans (le_max_right _ _))) + have hd : AckBounded (L + 1) (max σ (max m n)) _ + (max 1 (Subspace.densityBound k F m (δ / 2))) := + (num hL' 1).join ((((num hL' 7).mul hL' + (of_le ((le_max_left _ _).trans (le_max_right _ _)))).add hL' ((of_le hσ).join h2n)).comp + le_rfl + (densityBound_le hF hL hk m (by positivity) (one_div_half_le hnδ))) + exact ((((hd.mul hL' (((((of_le ((by omega : k + 1 ≤ σ).trans hσ)).pow hL' hd).mul hL' + h2n).add hL' (num hL' 1)).add hL' (num hL' 1))).add hL' (num hL' 1))).le + (variableCutFibersBound_le (one_div_half_le hnδ))).mono (by grind) + +private lemma ackBounded_tilingBound (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) (m : ℕ) + {β : ℝ} {E : ℕ} (hβ : 0 < β) (hE : 1 / β ≤ E) : + AckBounded (L + 1) (max σ (max m E)) 14 (IsInsensitive.tilingBound k F m β) := by + have hL' : 5 ≤ L + 1 := by omega + have hσ : σ ≤ max σ (max m E) := le_max_left _ _ + have hb : AckBounded (L + 1) (max σ (max m E)) _ + (max m (Subspace.restrictAlphabetBound k F m β)) := + (of_le ((le_max_left _ _).trans (le_max_right _ _))).join + (ackBounded_restrictAlphabetBound hF hL hk m hβ hE) + have hfloor : ⌊((k : ℝ) + 1) ^ max m (Subspace.restrictAlphabetBound k F m β) / β⌋₊ ≤ + (k + 1) ^ max m (Subspace.restrictAlphabetBound k F m β) * E := by + exact_mod_cast floor_div_le (a := (k + 1) ^ max m (Subspace.restrictAlphabetBound k F m β)) hE + exact ((((((of_le ((by omega : k + 1 ≤ σ).trans hσ)).pow hL' hb).mul hL' + (of_le ((le_max_right _ _).trans (le_max_right _ _)))).add hL' (num hL' 1)).mul hL' hb).le + (Nat.mul_le_mul_right _ (Nat.add_le_add_right hfloor 1))).mono (by grind) + +private lemma intersectionTilingBound_succ_le (r m : ℕ) (β : ℝ) : + IsInsensitive.intersectionTilingBound k F (r + 1) m β ≤ + (fun x ↦ max 1 (IsInsensitive.tilingBound k F x β))^[r + 1] m := by + induction r generalizing m with + | zero => exact le_max_right _ _ + | succ r ih => + rw [IsInsensitive.intersectionTilingBound, Function.iterate_succ_apply] + exact ih _ + +private lemma intersectionTilingBound_le (hF : AtLevel k L F) (hL : 5 ≤ L) (hk : k + 2 ≤ σ) + (r m : ℕ) {β : ℝ} {E : ℕ} (hβ : 0 < β) (hE : 1 / β ≤ E) : + IsInsensitive.intersectionTilingBound k F r m β ≤ + ack (L + 2) (14 * r + max (max σ E) m) := by + cases r with + | zero => exact Nat.zero_le _ + | succ r => + exact (intersectionTilingBound_succ_le r m β).trans (iterate_le_ack (fun x ↦ + (((num (by omega) 1).join (ackBounded_tilingBound hF hL hk x hβ hE)).mono + (by grind)).size (by omega)) (r + 1) m) + +private lemma ackBounded_invηBound (hF : AtLevel k L F) (hM : 5 ≤ M) (hLM : L ≤ M) (hk : k + 2 ≤ s) + (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded M s 9 (invηBound k (F (δ / 4)) n) := by + have hθ : AckBounded M s _ (invθBound k (F (δ / 4)) n) := + ((num hM 4).mul hM (of_le hn)).mul hM ((of_le (by omega : k + 1 ≤ s)).pow hM + ((hF.ackBounded_quarter hM hLM hk hn hδ hnδ).add hM (num hM 1))) + exact (((((num hM 48).mul hM (of_le hn)).mul hM hθ).add hM ((num hM 4).mul hM hθ)).add hM + ((num hM 6).mul hM (of_le hn))).mono (by grind) + +private lemma ackBounded_invγBound (hF : AtLevel k L F) (hM : 5 ≤ M) (hLM : L ≤ M) (hk : k + 2 ≤ s) + (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded M s 13 (invγBound k (F (δ / 4)) n) := by + have hη := ackBounded_invηBound hF hM hLM hk hn hδ hnδ + have hsq : AckBounded M s _ (invηBound k (F (δ / 4)) n ^ 2) := hη.pow hM (num hM 2) + exact (((((of_le (by omega : k ≤ s)).mul hM (of_le hn)).mul hM hsq).add hM + ((num hM 2).mul hM hsq)).add hM hη).mono (by grind) + +private lemma ackBounded_workingDimension (hF : AtLevel k L F) (hL : 5 ≤ L) (hk2 : 2 ≤ k) + (hk : k + 2 ≤ s) (d : ℕ) (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded (L + 2) (max s d) 17 (workingDimension k F d δ) := by + have hM : 5 ≤ L + 2 := by omega + have hs : s ≤ max s d := le_max_left _ _ + have hkS : AckBounded (L + 2) (max s d) 0 k := of_le (by omega) + have hγ := Parameters.γ_pos hk2 (F (δ / 4)) hδ + have hceil : ⌈(k : ℝ) / Parameters.η k (F (δ / 4)) δ⌉₊ ≤ k * invηBound k (F (δ / 4)) n := by + rw [Nat.ceil_le, ← one_div_div] + exact_mod_cast one_div_div_le k.cast_nonneg (one_div_η_le hδ hnδ) + have hβ : 1 / (Parameters.γ k (F (δ / 4)) δ ^ 2 / (4 * (k : ℝ))) ≤ + ((4 * k * invγBound k (F (δ / 4)) n ^ 2 : ℕ) : ℝ) := by + push_cast + exact one_div_div_le (by positivity) (one_div_sq_le hγ (one_div_γ_le hδ hnδ)) + have harg : AckBounded (L + 2) (max s d) _ + (14 * k + max (max (max s d) (4 * k * invγBound k (F (δ / 4)) n ^ 2)) d) := + ((num hM 14).mul hM hkS).add hM (((of_le le_rfl).join (((num hM 4).mul hM hkS).mul hM + ((ackBounded_invγBound hF hM (by omega) (hk.trans hs) (hn.trans hs) hδ hnδ).pow hM + (num hM 2)))).join (of_le (le_max_right s d))) + exact (((num hM 1).join ((hkS.mul hM (ackBounded_invηBound hF hM (by omega) (hk.trans hs) + (hn.trans hs) hδ hnδ)).le hceil)).join (harg.comp le_rfl + (intersectionTilingBound_le hF hL (hk.trans hs) k d (by positivity) hβ))).mono (by grind) + +private lemma ackBounded_incrementBound (hF : AtLevel k L F) (hL : 5 ≤ L) (hk2 : 2 ≤ k) + (hk : k + 2 ≤ s) (d : ℕ) (hn : n ≤ s) (hδ : 0 < δ) (hnδ : 1 / δ ≤ n) : + AckBounded (L + 2) (max s d) 31 (incrementBound k F d δ) := by + have hM : 5 ≤ L + 2 := by omega + have hs : s ≤ max s d := le_max_left _ _ + have harg : AckBounded (L + 2) (max s d) _ + (max (k + 2) (max (workingDimension k F d δ) (F (δ / 4) + 1))) := + (of_le (hk.trans hs)).join ((ackBounded_workingDimension hF hL hk2 hk d hn hδ hnδ).join + ((hF.ackBounded_quarter hM (by omega) (hk.trans hs) (hn.trans hs) hδ hnδ).add hM + (num hM 1))) + have hgr : AckBounded (L + 2) (max s d) _ (max 1 (GrahamRothschild.bound (k + 1) 2 + (max (workingDimension k F d δ) (F (δ / 4) + 1)))) := + (num hM 1).join (harg.trans ((ackBounded_grahamRothschildBound (le_max_left _ _) + ((by omega : 2 ≤ k + 2).trans (le_max_left _ _)) (le_max_right _ _)).lift (by omega))) + have hε : 1 / (Parameters.η k (F (δ / 4)) δ ^ 2 / 2) ≤ + ((2 * invηBound k (F (δ / 4)) n ^ 2 : ℕ) : ℝ) := by + exact_mod_cast one_div_div_le zero_le_two + (one_div_sq_le (Parameters.η_pos k (F (δ / 4)) hδ) (one_div_η_le hδ hnδ)) + have hE : AckBounded (L + 2) (max s d) _ (2 * invηBound k (F (δ / 4)) n ^ 2) := + (num hM 2).mul hM ((ackBounded_invηBound hF hM (by omega) (hk.trans hs) (hn.trans hs) hδ + hnδ).pow hM (num hM 2)) + exact ((((hgr.mul hM (((((of_le (by omega : k + 1 ≤ max s d)).pow hM hgr).mul hM hE).add hM + (num hM 1)).add hM (num hM 1))).add hM (num hM 1))).le + (variableCutFibersBound_le hε)).mono (by grind) + +/-- If the bound for `k` letters is at level `L`, the bound for `k + 1` letters is at level +`L + 4`. -/ +private lemma AtLevel.step (hF : AtLevel k L F) (hL : 5 ≤ L) (hk2 : 2 ≤ k) : + AtLevel (k + 1) (L + 4) (stepBound k F) := by + intro δ hδ n hnδ + have hk : k + 2 ≤ max (k + 1 + 2) n := by omega + have hn : n ≤ max (k + 1 + 2) n := le_max_right _ _ + have ht : ⌈2 / Parameters.γ k (F (δ / 4)) δ⌉₊ ≤ 2 * invγBound k (F (δ / 4)) n := by + rw [Nat.ceil_le, ← one_div_div] + exact_mod_cast one_div_div_le zero_le_two (one_div_γ_le hδ hnδ) + have hX : AckBounded L (max (k + 1 + 2) n) 17 + (31 * (⌈2 / Parameters.γ k (F (δ / 4)) δ⌉₊ + 1) + max (max (k + 1 + 2) n) 1) := + (((num hL 31).mul hL ((((num hL 2).mul hL (ackBounded_invγBound hF hL le_rfl hk hn hδ hnδ)).le + ht).add hL (num hL 1))).add hL ((of_le le_rfl).join (num hL 1))).mono (by grind) + calc stepBound k F δ + ≤ ack (L + 3) (31 * (⌈2 / Parameters.γ k (F (δ / 4)) δ⌉₊ + 1) + max (max (k + 1 + 2) n) 1) := + iterate_le_ack (fun x ↦ ((num (by omega) 1).join + (ackBounded_incrementBound hF hL hk2 hk x hn hδ hnδ)).mono (by grind)) _ 1 + _ ≤ ack (L + 3) (ack (L + 1) (17 + max (k + 1 + 2) n)) := + ack_mono_right _ (le_trans hX (iterate_ack_le L 17 _)) + _ ≤ ack (L + 4) (max (k + 1 + 2) n) := ack_ack_add_le (by omega) (by norm_num) (by omega) + +end Density + +private lemma atLevel_two : AtLevel 2 5 fun δ ↦ 2 * ⌈1 / δ ^ 2⌉₊ := by + intro δ hδ n hnδ + have hceil : ⌈1 / δ ^ 2⌉₊ ≤ n * n := by + rw [Nat.ceil_le] + exact_mod_cast (one_div_sq_le hδ hnδ).trans_eq (sq _) + calc 2 * ⌈1 / δ ^ 2⌉₊ ≤ ack 2 (n * n) := by + rw [ack_two] + omega + _ ≤ ack 2 (ack 3 n) := ack_mono_right 2 (by simpa using mul_le_ack n n) + _ ≤ ack 5 n := (ack_ack_lt_ack_max_add_two 2 3 n).le + _ ≤ ack 5 (max (2 + 2) n) := ack_mono_right 5 (le_max_right _ _) + +/-- The induction on the alphabet: density Hales--Jewett for `k + 2` letters has a bound at level +`4 * k + 5`. -/ +private lemma exists_isDHJBound_atLevel (k : ℕ) : + ∃ F, IsDHJBound (k + 2) F ∧ AtLevel (k + 2) (4 * k + 5) F := by + induction k with + | zero => exact ⟨_, isDHJBound_two, atLevel_two⟩ + | succ k ih => + obtain ⟨F, hF, hL⟩ := ih + refine ⟨stepBound (k + 2) F, hF.step (by omega), ?_⟩ + rw [(by omega : 4 * (k + 1) + 5 = 4 * k + 5 + 4)] + exact hL.step (by omega) (by omega) + +lemma ack_max_le {M k n : ℕ} (hn : 0 < n) : ack M (max (k + 4) n) ≤ ack (M + 1) (k + 2 + n) := + (ack_mono_right M (by omega : max (k + 4) n ≤ k + 2 + n + 1)).trans + (ack_succ_right_le_ack_succ_left M _) + +/-- A dimension in which density Hales--Jewett holds for `k + 2` letters and density `δ`, one +application of `ack M` above a bound `N` for `1 / δ`. -/ +lemma exists_isDHJDimension_ackBounded (k : ℕ) {δ : ℝ} (hδ : 0 < δ) {M s c N : ℕ} + (hM : 4 * k + 5 ≤ M) (hs : k + 4 ≤ s) (hN : AckBounded M s c N) (hδN : 1 / δ ≤ N) : + ∃ d, IsDHJDimension (k + 2) δ d ∧ AckBounded M s (c + 1) d := by + obtain ⟨F, hF, hL⟩ := exists_isDHJBound_atLevel k + exact ⟨F δ, hF δ hδ _ le_rfl, + (((of_le hs).join hN).comp hM (hL δ hδ N hδN)).mono (by omega)⟩ + +/-- **Density Hales--Jewett** for `k ≥ 2` letters holds in every dimension +`n ≥ ack (4 * k) (k + ⌈1 / δ⌉₊)`. -/ +theorem isDHJBound_ack {k : ℕ} (hk : 2 ≤ k) : + IsDHJBound k fun δ ↦ ack (4 * k) (k + ⌈1 / δ⌉₊) := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le' hk + obtain ⟨F, hF, hL⟩ := exists_isDHJBound_atLevel k + intro δ hδ n hn + refine hF δ hδ n (le_trans ?_ hn) + calc F δ ≤ ack (4 * k + 5) (max (k + 4) ⌈1 / δ⌉₊) := hL δ hδ _ (Nat.le_ceil _) + _ ≤ ack (4 * k + 5 + 1) (k + 2 + ⌈1 / δ⌉₊) := ack_max_le (Nat.ceil_pos.2 (by positivity)) + _ ≤ ack (4 * (k + 2)) (k + 2 + ⌈1 / δ⌉₊) := ack_mono_left _ (by omega) + +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean index ac90832154..e3208c5fb7 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean @@ -6,22 +6,23 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace -import Mathlib.Basic.Finite.Prod -import Mathlib.Basic.Finite.Sum +public import LeanPool.ShelahHalesJewett.HalesJewett +import Mathlib.Tactic.Ring.RingNF /-! # Canonization of the constant letters A word over the alphabet `Option α` is a word over `α` with variable positions marked by `none`; -its support is the set of variable positions. Substituting such a word into a combinatorial +its support is the set of variable positions. Substituting such a word into a combinatorial subspace gives `Subspace.wordMap`, which turns a subspace of dimension `ℓ` into a map from words of length `ℓ` to words of length the ambient dimension. -The main result `exists_canonical` is the support canonization lemma of -`graham_rothschild_lines_from_mhj.tex`: after passing to a suitable `ℓ`-dimensional subspace, the -colour of a substituted word depends only on its support. It is proved by induction on `ℓ`, one -application of the ordinary Hales--Jewett theorem per variable, each of them applied to the -profile of colours obtained by letting the remaining positions vary. +The main result `exists_canonical` is support canonization: after passing to a suitable +`ℓ`-dimensional subspace, the colour of a substituted word depends only on its support. It is +proved by induction on `ℓ`, one application of the ordinary Hales--Jewett theorem per variable, +each of them applied to the profile of colours obtained by letting the remaining positions vary. +The dimension it needs is `Canonization.bound`, an explicit expression in Shelah's bound +`Combinatorics.Line.shelahBound` for the Hales--Jewett numbers. -/ @[expose] public section @@ -93,6 +94,12 @@ lemma wordMap_consLine {ℓ : ℕ} {B B' : Type*} (V : Combinatorics.Subspace (F | inl b => cases h : V.idxFun b <;> simp [wordMap, consLine, h] | inr i => cases h : l.idxFun i <;> simp [wordMap, consLine, Line.fillOption, h] +lemma wordMap_reindex {ι' : Type*} (V : Combinatorics.Subspace η α ι) (e : ι ≃ ι') + (x : η → Option α) : + wordMap (V.reindex (Equiv.refl _) (Equiv.refl _) e) x = wordMap V x ∘ e.symm := by + funext i + cases h : V.idxFun (e.symm i) <;> simp [wordMap, Combinatorics.Subspace.reindex, h] + /-- Embed the first `N` coordinates of a cube into a larger one, filling the remaining coordinates with a fixed letter. -/ noncomputable def padInitial (α : Type*) [Nonempty α] {N n : ℕ} (h : N ≤ n) : @@ -104,88 +111,99 @@ end Subspace namespace Canonization -variable {α : Type*} - open Subspace +/-- The number of positions used by support canonization of `ℓ` variables over `k` letters with +`c` colours, when `p` positions precede the block and `s` variable slots follow it. Each variable +adds the dimension of one application of the Hales--Jewett theorem, to the colouring by profiles +over the remaining positions. -/ +def bound (k c : ℕ) : ℕ → ℕ → ℕ → ℕ + | 0, _, _ => 0 + | ℓ + 1, p, s => + bound k c ℓ p (s + 1) + + Combinatorics.Line.shelahBound k (c ^ (k + 1) ^ (p + bound k c ℓ p (s + 1) + s)) + /-- The inductive form of support canonization: for any block of positions preceding the -variables and any block of variable slots following them, there is a block of positions carrying +variables and any block of variable slots following them, there is a block of positions with `ℓ` variables on which every colouring becomes a function of the support alone. -/ -private lemma exists_canonical_aux (α : Type*) [Finite α] (C : Type*) [Finite C] (ℓ : ℕ) : - ∀ (P S : Type) [Finite P] [Finite S], ∃ (B : Type) (_ : Finite B), - ∀ χ : (P → Option α) → (B → Option α) → (S → Option α) → C, +private lemma exists_canonical_aux (α : Type*) [Fintype α] (κ : Type*) [Fintype κ] (ℓ : ℕ) : + ∀ (P S : Type) [Fintype P] [Fintype S], ∃ (B : Type) (_ : Fintype B), + Fintype.card B = bound (Fintype.card α) (Fintype.card κ) ℓ (Fintype.card P) + (Fintype.card S) ∧ + ∀ C : (P → Option α) → (B → Option α) → (S → Option α) → κ, ∃ V : Combinatorics.Subspace (Fin ℓ) α B, ∀ (p : P → Option α) (s : S → Option α) (x y : Fin ℓ → Option α), - SameSupport x y → χ p (wordMap V x) s = χ p (wordMap V y) s := by + SameSupport x y → C p (wordMap V x) s = C p (wordMap V y) s := by + classical induction ℓ with | zero => intro P S _ _ - refine ⟨PEmpty, inferInstance, ?_⟩ - intro χ - refine ⟨⟨PEmpty.elim, ?_⟩, ?_⟩ - · intro e - exact e.elim0 - · intro p s _ _ _ - exact congrArg (fun w ↦ χ p w s) (funext fun i ↦ i.elim) + refine ⟨PEmpty, inferInstance, by simp [bound], ?_⟩ + intro C + refine ⟨⟨PEmpty.elim, fun e ↦ e.elim0⟩, ?_⟩ + intro p s _ _ _ + exact congrArg (fun w ↦ C p w s) (funext fun i ↦ i.elim) | succ ℓ ih => intro P S _ _ - obtain ⟨B, _, hB⟩ := ih P (Unit ⊕ S) - obtain ⟨B', _, hB'⟩ := Combinatorics.Line.exists_mono_in_high_dimension α - ((P → Option α) → (B → Option α) → (S → Option α) → C) - refine ⟨B ⊕ B', inferInstance, ?_⟩ - intro χ - obtain ⟨l, prof, hprof⟩ := hB' fun u p b s ↦ χ p (Sum.elim b (some ∘ u)) s - have hprof' : ∀ (a : α) (p : P → Option α) (b : B → Option α) (s : S → Option α), - χ p (Sum.elim b (some ∘ l a)) s = prof p b s := - fun a p b s ↦ congrFun (congrFun (congrFun (hprof a) p) b) s + obtain ⟨B, _, hcard, hB⟩ := ih P (Unit ⊕ S) + rw [Fintype.card_sum, Fintype.card_unit, add_comm 1] at hcard + have hprofiles : Fintype.card ((P → Option α) → (B → Option α) → (S → Option α) → κ) = + Fintype.card κ ^ (Fintype.card α + 1) ^ (Fintype.card P + Fintype.card B + + Fintype.card S) := by + simp only [Fintype.card_fun, Fintype.card_option, ← pow_mul, ← pow_add] + congr 2 + ring + refine ⟨B ⊕ Fin (Combinatorics.Line.shelahBound (Fintype.card α) + (Fintype.card ((P → Option α) → (B → Option α) → (S → Option α) → κ))), + inferInstance, by rw [Fintype.card_sum, Fintype.card_fin, hprofiles, hcard, bound], ?_⟩ + intro C + -- A line on the new block along which the colouring of the other positions is constant. + obtain ⟨l, profile, hl⟩ := Combinatorics.Line.exists_mono_of_card_eq_shelahBound + (Fintype.card_fin _) fun (u : _ → α) p b s ↦ C p (Sum.elim b (some ∘ u)) s + have hprofile (a : α) (p : P → Option α) (b : B → Option α) (s : S → Option α) : + C p (Sum.elim b (some ∘ l a)) s = profile p b s := + congrFun (congrFun (congrFun (hl a) p) b) s + -- Canonize the earlier variables, with the new one among the slots that follow them. obtain ⟨V, hV⟩ := hB fun p b q ↦ - χ p (Sum.elim b (Line.fillOption l (q (Sum.inl ())))) fun s ↦ q (Sum.inr s) + C p (Sum.elim b (Line.fillOption l (q (Sum.inl ())))) fun s ↦ q (Sum.inr s) refine ⟨consLine V l, ?_⟩ intro p s x y hxy rw [wordMap_consLine, wordMap_consLine] - apply Eq.trans (hV p (Sum.elim (fun _ ↦ x 0) s) (fun i ↦ x i.succ) (fun i ↦ y i.succ) - fun i ↦ hxy i.succ) + refine (hV p (Sum.elim (fun _ ↦ x 0) s) (fun i ↦ x i.succ) (fun i ↦ y i.succ) + fun i ↦ hxy i.succ).trans ?_ simp only [Sum.elim_inl, Sum.elim_inr] cases hx : x 0 with | none => rw [(hxy 0).1 hx] | some a => cases hy : y 0 with | none => simp [(hxy 0).2 hy] at hx - | some b => - rw [Line.fillOption_some, Line.fillOption_some, hprof' a, hprof' b] + | some b => rw [Line.fillOption_some, Line.fillOption_some, hprofile a, hprofile b] + +variable {α κ : Type*} [Fintype α] [Fintype κ] {ℓ : ℕ} /-- **Support canonization**: in a large enough cube every colouring of words over `Option α` admits an `ℓ`-dimensional subspace on which the colour of a substituted word depends only on its support. -/ -lemma exists_canonical (α : Type*) [Finite α] (C : Type*) [Finite C] (ℓ : ℕ) : - ∃ N : ℕ, ∀ χ : (Fin N → Option α) → C, - ∃ V : Combinatorics.Subspace (Fin ℓ) α (Fin N), - ∀ x y : Fin ℓ → Option α, SameSupport x y → χ (wordMap V x) = χ (wordMap V y) := by - obtain ⟨B, _, hB⟩ := exists_canonical_aux α C ℓ PEmpty PEmpty - have := Fintype.ofFinite B - refine ⟨Fintype.card B, ?_⟩ - intro χ - obtain ⟨V, hV⟩ := hB fun _ w _ ↦ χ (w ∘ (Fintype.equivFin B).symm) - have hw (z : Fin ℓ → Option α) : - wordMap (V.reindex (Equiv.refl _) (Equiv.refl _) (Fintype.equivFin B)) z - = wordMap V z ∘ (Fintype.equivFin B).symm := by - funext i - cases h : V.idxFun ((Fintype.equivFin B).symm i) <;> - simp [wordMap, Combinatorics.Subspace.reindex, h] - refine ⟨V.reindex (Equiv.refl _) (Equiv.refl _) (Fintype.equivFin B), ?_⟩ +lemma exists_canonical + (C : (Fin (bound (Fintype.card α) (Fintype.card κ) ℓ 0 0) → Option α) → κ) : + ∃ V : Combinatorics.Subspace (Fin ℓ) α + (Fin (bound (Fintype.card α) (Fintype.card κ) ℓ 0 0)), + ∀ x y : Fin ℓ → Option α, SameSupport x y → C (wordMap V x) = C (wordMap V y) := by + obtain ⟨B, _, hcard, hB⟩ := exists_canonical_aux α κ ℓ PEmpty PEmpty + rw [Fintype.card_pempty] at hcard + let e := Fintype.equivFinOfCardEq hcard + obtain ⟨V, hV⟩ := hB fun _ w _ ↦ C (w ∘ e.symm) + refine ⟨V.reindex (Equiv.refl _) (Equiv.refl _) e, ?_⟩ intro x y hxy - rw [hw x, hw y] + rw [wordMap_reindex, wordMap_reindex] exact hV PEmpty.elim PEmpty.elim x y hxy /-- Support canonization holds in every ambient dimension beyond the one it produces. -/ -lemma exists_canonical_of_le (α : Type*) [Finite α] [Nonempty α] (C : Type*) [Finite C] (ℓ : ℕ) : - ∃ N : ℕ, ∀ n, N ≤ n → ∀ χ : (Fin n → Option α) → C, - ∃ V : Combinatorics.Subspace (Fin ℓ) α (Fin n), - ∀ x y : Fin ℓ → Option α, SameSupport x y → χ (wordMap V x) = χ (wordMap V y) := by - obtain ⟨N, hN⟩ := exists_canonical α C ℓ - refine ⟨N, ?_⟩ - intro n hn χ - obtain ⟨V, hV⟩ := hN fun w ↦ χ (wordMap (padInitial α hn) w) +lemma exists_canonical_of_le [Nonempty α] {n : ℕ} + (hn : bound (Fintype.card α) (Fintype.card κ) ℓ 0 0 ≤ n) (C : (Fin n → Option α) → κ) : + ∃ V : Combinatorics.Subspace (Fin ℓ) α (Fin n), + ∀ x y : Fin ℓ → Option α, SameSupport x y → C (wordMap V x) = C (wordMap V y) := by + obtain ⟨V, hV⟩ := exists_canonical fun w ↦ C (wordMap (padInitial α hn) w) refine ⟨compose (padInitial α hn) V, ?_⟩ intro x y hxy rw [wordMap_compose, wordMap_compose] diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean index e92c8e3e13..9c7399dcf8 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean @@ -6,15 +6,13 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation -import Mathlib.Algebra.BigOperators.Field -import Mathlib.Algebra.Order.Archimedean.Real.Basic -import Mathlib.Data.NNRat.BigOperators +import Mathlib.Algebra.Order.BigOperators.Expect /-! # The density-increment dichotomy Tiling a structured insensitive intersection by subspaces and averaging over the tiles turns -structured correlation into a genuine density increment on a subspace. +structured correlation into a density increment on a subspace. -/ @[expose] public section @@ -25,243 +23,7 @@ open scoped BigOperators namespace DensityHalesJewett -/-- An ambient dimension supports all working dimensions needed by the density-increment -dichotomy. -/ -def IncrementBoundSufficient (k d : ℕ) (δ : ℝ) (n : ℕ) : Prop := - ∀ (_ : 2 ≤ k), HasDensityHJ k → 1 ≤ d → 0 < δ → δ ≤ 1 → - ∃ m, 1 ≤ m ∧ - insensitiveIntersectionDimension k δ ≤ m ∧ - manyLinesBound k m δ ≤ n ∧ - IsInsensitive.intersectionTilingBound k k d - (Parameters.γ k δ ^ 2 / (4 * (k : ℝ))) ≤ m - -/-- Sufficient ambient dimensions for the density-increment dichotomy occur eventually. -/ -lemma exists_eventually_incrementBoundSufficient (k d : ℕ) (δ : ℝ) : - ∃ N, ∀ n ≥ N, IncrementBoundSufficient k d δ n := by - let m := max (max 1 (insensitiveIntersectionDimension k δ)) - (IsInsensitive.intersectionTilingBound k k d - (Parameters.γ k δ ^ 2 / (4 * (k : ℝ)))) - refine ⟨manyLinesBound k m δ, ?_⟩ - intro n hn _ _ _ _ _ - refine ⟨m, ?_, ?_, hn, ?_⟩ <;> - dsimp only [m] <;> omega - -/-- A sufficient ambient dimension for the density-increment dichotomy. -/ -noncomputable def incrementBound (k d : ℕ) (δ : ℝ) : ℕ := by - classical - exact Nat.find (exists_eventually_incrementBoundSufficient k d δ) - -/-- Select one working dimension supporting both structured correlation and the final tiling -argument. - -The bound simultaneously leaves enough ambient coordinates for the many-lines construction and -makes the resulting parameter cube large enough for the insensitive-intersection construction and -for tiling that intersection by `d`-subspaces. -/ -lemma incrementBound_spec {k d : ℕ} (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) (hd : 1 ≤ d) - {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - {n : ℕ} (hn : incrementBound k d δ ≤ n) : - ∃ m, 1 ≤ m ∧ - insensitiveIntersectionDimension k δ ≤ m ∧ - manyLinesBound k m δ ≤ n ∧ - IsInsensitive.intersectionTilingBound k k d - (Parameters.γ k δ ^ 2 / (4 * (k : ℝ))) ≤ m := by - classical - unfold incrementBound at hn - exact Nat.find_spec (exists_eventually_incrementBoundSufficient k d δ) n hn - hk hDHJ hd hδ₀ hδ₁ - -/-- The insensitive-intersection tiling theorem supplies a nonempty finite family of disjoint -`d`-subspaces with small uncovered part. -/ -lemma exists_finite_structured_tiling {k d m : ℕ} - (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) (hd : 1 ≤ d) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hm_tiling : IsInsensitive.intersectionTilingBound k k d - (Parameters.γ k δ ^ 2 / (4 * (k : ℝ))) ≤ m) - (D : Fin k → Finset (Fin m → Fin (k + 1))) - (hD : ∀ i, IsInsensitive i.castSucc (Fin.last k) (D i)) - (hDdense : Parameters.γ k δ ≤ ((IsInsensitive.intersection D).dens : ℝ)) : - ∃ 𝒱 : Finset (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m)), - 𝒱.Nonempty ∧ - (∀ W ∈ 𝒱, Subspace.IsContained W (IsInsensitive.intersection D)) ∧ - ((𝒱 : Set (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))).PairwiseDisjoint fun W ↦ - (Subspace.range W : Set (Fin m → Fin (k + 1)))) ∧ - ((IsInsensitive.uncovered (η := Fin d) - (IsInsensitive.intersection D) (𝒱 : Set _)).dens : ℝ) < - Parameters.γ k δ ^ 2 / 2 := by - classical - let β := Parameters.γ k δ ^ 2 / (4 * (k : ℝ)) - have hγ₀ := Parameters.γ_pos hk hδ₀ - have hγ₁ : Parameters.γ k δ ≤ 1 := by - linarith [Parameters.γ_le_three_mul_η k δ, Parameters.η_le_δ_div_six k δ] - have hβ₀ : 0 < β := by positivity - have hβ_simplify : - 2 * (k : ℝ) * β = Parameters.γ k δ ^ 2 / 2 := by - dsimp only [β] - field_simp - ring - have hDβ : - 2 * (k : ℝ) * β ≤ ((IsInsensitive.intersection D).dens : ℝ) := by - rw [hβ_simplify] - nlinarith - obtain ⟨𝒱, h𝒱finite, hcontained, hpairwise, huncovered⟩ := - IsInsensitive.exists_disjoint_subspaces_iInter (k := k) k d m hDHJ (by omega) le_rfl hd - β hβ₀ hm_tiling D (by - simpa only [Fin.castLE_rfl, id_eq] using hD) hDβ - have h𝒱nonempty : 𝒱.Nonempty := by - by_contra h𝒱 - rw [Set.not_nonempty_iff_eq_empty.mp h𝒱] at huncovered - have hempty : - IsInsensitive.uncovered (η := Fin d) - (IsInsensitive.intersection D) (∅ : Set _) = - IsInsensitive.intersection D := by - ext x - simp [IsInsensitive.uncovered] - rw [hempty, hβ_simplify] at huncovered - nlinarith - refine ⟨h𝒱finite.toFinset, h𝒱finite.toFinset_nonempty.mpr h𝒱nonempty, ?_, ?_, ?_⟩ - · intro W hW - exact hcontained W (h𝒱finite.mem_toFinset.mp hW) - · simpa only [h𝒱finite.coe_toFinset] using hpairwise - · simpa only [h𝒱finite.coe_toFinset, hβ_simplify] using huncovered - -/-- The structured correlation and the small uncovered part give an aggregate density gain over -the disjoint tile family. -/ -lemma structured_tiling_density_sum {k d m n : ℕ} - (hk : 2 ≤ k) {δ : ℝ} (hδ₀ : 0 < δ) - (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) - (D : Fin k → Finset (Fin m → Fin (k + 1))) - (hDdense : Parameters.γ k δ ≤ ((IsInsensitive.intersection D).dens : ℝ)) - (hcorrelation : (δ + Parameters.γ k δ) * - ((IsInsensitive.intersection D).dens : ℝ) ≤ - ((pullback V A ∩ IsInsensitive.intersection D).dens : ℝ)) - (𝒱 : Finset (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))) - (hcontained : ∀ W ∈ 𝒱, Subspace.IsContained W (IsInsensitive.intersection D)) - (hpairwise : - ((𝒱 : Set (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))).PairwiseDisjoint fun W ↦ - (Subspace.range W : Set (Fin m → Fin (k + 1))))) - (huncovered : - ((IsInsensitive.uncovered (η := Fin d) - (IsInsensitive.intersection D) (𝒱 : Set _)).dens : ℝ) < - Parameters.γ k δ ^ 2 / 2) : - (δ + Parameters.γ k δ / 2) * - ∑ W ∈ 𝒱, ((Subspace.range W).dens : ℝ) ≤ - ∑ W ∈ 𝒱, ((pullback V A ∩ Subspace.range W).dens : ℝ) := by - classical - let C := IsInsensitive.intersection D - let P := pullback V A - let T := 𝒱.biUnion Subspace.range - have hTsub : T ⊆ C := by - intro x hx - simp only [T, Finset.mem_biUnion] at hx - obtain ⟨W, hW, hxW⟩ := hx - obtain ⟨z, rfl⟩ := Subspace.mem_range.mp hxW - exact hcontained W hW z - have hpairwise_fin : - Set.PairwiseDisjoint - (𝒱 : Set (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))) - Subspace.range := by - intro W hW W' hW' hne - apply Finset.disjoint_left.mpr - intro x hxW hxW' - exact Set.disjoint_left.mp (hpairwise hW hW' hne) hxW hxW' - have hsumT : - ∑ W ∈ 𝒱, ((Subspace.range W).dens : ℝ) = (T.dens : ℝ) := by - exact_mod_cast (Finset.dens_biUnion hpairwise_fin).symm - have hpairwise_inter : - Set.PairwiseDisjoint - (𝒱 : Set (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))) - (fun W ↦ P ∩ Subspace.range W) := by - intro W hW W' hW' hne - exact (hpairwise_fin hW hW' hne).mono - Finset.inter_subset_right Finset.inter_subset_right - have hinterT : - 𝒱.biUnion (fun W ↦ P ∩ Subspace.range W) = P ∩ T := by - ext x - simp only [Finset.mem_biUnion, Finset.mem_inter, T] - aesop - have hsumPT : - ∑ W ∈ 𝒱, ((P ∩ Subspace.range W).dens : ℝ) = ((P ∩ T).dens : ℝ) := by - rw [← hinterT] - exact_mod_cast (Finset.dens_biUnion hpairwise_inter).symm - have huncovered_eq : IsInsensitive.uncovered (η := Fin d) C (𝒱 : Set _) = C \ T := by - ext x - simp [IsInsensitive.uncovered, T] - have hPT_eq : (P ∩ C) ∩ T = P ∩ T := by - rw [Finset.inter_assoc, Finset.inter_eq_right.mpr hTsub] - have hremainder_real : - (((P ∩ C) \ T).dens : ℝ) ≤ ((C \ T).dens : ℝ) := by - exact_mod_cast Finset.dens_le_dens - (Finset.sdiff_subset_sdiff Finset.inter_subset_right (subset_refl T)) - have hdecomp : - ((P ∩ T).dens : ℝ) + (((P ∩ C) \ T).dens : ℝ) = - ((P ∩ C).dens : ℝ) := by - norm_cast - simpa only [hPT_eq] using Finset.dens_inter_add_dens_sdiff (P ∩ C) T - have hTdens : (T.dens : ℝ) ≤ (C.dens : ℝ) := by exact_mod_cast Finset.dens_le_dens hTsub - have hγ₀ := Parameters.γ_pos hk hδ₀ - have hcoefficient : 0 ≤ δ + Parameters.γ k δ / 2 := by linarith - rw [hsumT, hsumPT] - apply (mul_le_mul_of_nonneg_left hTdens hcoefficient).trans - rw [huncovered_eq] at huncovered - dsimp only [C, P] at hDdense hcorrelation huncovered hdecomp hremainder_real hTdens ⊢ - nlinarith - -/-- Intersecting a family with a subspace range factors its ambient density into relative density -and range density. -/ -lemma Subspace.dens_inter_range_eq_relativeDensity_mul_range - {η α ι : Type*} [Fintype (η → α)] [Fintype (ι → α)] - [DecidableEq (ι → α)] - (W : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : - ((A ∩ range W).dens : ℝ) = - (relativeDensity W A : ℝ) * ((range W).dens : ℝ) := by - classical - let B := Finset.univ.filter fun x : η → α ↦ W x ∈ A - have hAB : A ∩ range W = B.image W := by - ext w - simp only [B, range, Finset.mem_inter, Finset.mem_image, Finset.mem_filter, - Finset.mem_univ, true_and] - grind - rw [hAB] - simp only [Finset.nnratCast_dens, relativeDensity, range, B] - rw [Finset.card_image_iff.mpr (Subspace.injective W).injOn, - Finset.card_image_iff.mpr (Subspace.injective W).injOn] - by_cases h : Fintype.card (η → α) = 0 - · let : IsEmpty (η → α) := Fintype.card_eq_zero_iff.mp h - have hB : (Finset.univ.filter fun x : η → α ↦ W x ∈ A) = ∅ := - Subsingleton.elim _ _ - rw [hB] - simp - · field_simp - simp only [Finset.card_univ] - -/-- Finite weighted averaging selects a tile whose pullback density realizes the aggregate -gain. -/ -lemma exists_dense_tile_of_density_sum {k d m n : ℕ} - {δ : ℝ} (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) - (𝒱 : Finset (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin m))) - (h𝒱 : 𝒱.Nonempty) - (hsum : (δ + Parameters.γ k δ / 2) * - ∑ W ∈ 𝒱, ((Subspace.range W).dens : ℝ) ≤ - ∑ W ∈ 𝒱, ((pullback V A ∩ Subspace.range W).dens : ℝ)) : - ∃ W ∈ 𝒱, - δ + Parameters.γ k δ / 2 ≤ - (Subspace.relativeDensity W (pullback V A) : ℝ) := by - by_contra! h - apply (not_lt_of_ge hsum) - calc - (∑ W ∈ 𝒱, ((pullback V A ∩ Subspace.range W).dens : ℝ)) < - ∑ W ∈ 𝒱, (δ + Parameters.γ k δ / 2) * - ((Subspace.range W).dens : ℝ) := by - apply Finset.sum_lt_sum_of_nonempty h𝒱 - intro W hW - rw [Subspace.dens_inter_range_eq_relativeDensity_mul_range] - apply mul_lt_mul_of_pos_right (h W hW) - exact_mod_cast Finset.dens_pos.mpr - ⟨W (fun _ ↦ 0), Subspace.mem_range.mpr ⟨fun _ ↦ 0, rfl⟩⟩ - _ = (δ + Parameters.γ k δ / 2) * - ∑ W ∈ 𝒱, ((Subspace.range W).dens : ℝ) := by - rw [Finset.mul_sum] +variable {N : ℕ} /-- Relative density in a composite subspace is relative density in the inner subspace of the outer pullback. -/ @@ -272,64 +34,116 @@ lemma Subspace.relativeDensity_compose {α η ζ ι : Type*} (A : Finset (ι → α)) : (relativeDensity (compose V W) A : ℝ) = (relativeDensity W (pullback V A) : ℝ) := by - simp only [relativeDensity, pullback, parameterPreimage, Finset.mem_filter, Finset.mem_univ, - true_and, + simp only [relativeDensity, pullback, parameterPreimage, mem_filter, mem_univ, true_and, compose_apply] -/-- Tile a structured insensitive intersection and extract a dense tile. - -Apply `IsInsensitive.exists_disjoint_subspaces_iInter` with error -`γ² / (4k)`. Pairwise disjointness turns the densities on the tile ranges into finite sums, and -the uncovered-density estimate preserves half of the correlation gain. Finite averaging then -selects one `d`-tile of relative `A`-density at least `δ + γ/2`; composing that tile with `V` -gives the required ambient subspace. -/ -lemma exists_density_increment_subspace_of_structured_correlation {k d m n : ℕ} - (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) (hd : 1 ≤ d) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hm_tiling : IsInsensitive.intersectionTilingBound k k d - (Parameters.γ k δ ^ 2 / (4 * (k : ℝ))) ≤ m) - (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) - (D : Fin k → Finset (Fin m → Fin (k + 1))) +/-- If `P` has density at least `δ + γ` relative to `C`, of density at least `γ`, then it has +density at least `δ + γ / 2` relative to `C` minus a set of density at most `γ ^ 2 / 2`. -/ +lemma add_div_two_mul_dens_sdiff_le {X : Type*} [Fintype X] [DecidableEq X] {P C U : Finset X} + {δ γ : ℝ} (hδ : 0 ≤ δ) (hγ : 0 ≤ γ) (hC : γ ≤ (C.dens : ℝ)) + (hPC : (δ + γ) * (C.dens : ℝ) ≤ ((P ∩ C).dens : ℝ)) (hU : (U.dens : ℝ) ≤ γ ^ 2 / 2) : + (δ + γ / 2) * ((C \ U).dens : ℝ) ≤ ((P ∩ (C \ U)).dens : ℝ) := by + have hP : ((P ∩ C).dens : ℝ) ≤ ((P ∩ (C \ U)).dens : ℝ) + (U.dens : ℝ) := + mod_cast (dens_le_dens (t := P ∩ (C \ U) ∪ U) fun x ↦ by simp; tauto).trans + (dens_union_le _ _) + have hCU : ((C \ U).dens : ℝ) ≤ (C.dens : ℝ) := mod_cast dens_le_dens sdiff_subset + nlinarith [mul_le_mul_of_nonneg_left hCU (by positivity : 0 ≤ δ + γ / 2), + mul_le_mul_of_nonneg_left hC hγ] + +/-- A structured correlation inside `V` gives a `d`-dimensional subspace on which `A` has relative +density at least `δ + γ / 2`: tile the insensitive intersection by `d`-subspaces with tolerance +`β ≤ γ ^ 2 / (4 * k)`, keep half of the correlation gain on the covered part, average over the +tiles and compose the chosen tile with `V`. -/ +lemma exists_density_increment_subspace_of_structured_correlation {k d m n : ℕ} {F : ℝ → ℕ} + (hk : 2 ≤ k) (hF : IsDHJBound k F) (hd : 1 ≤ d) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) + {β : ℝ} (hβ₀ : 0 < β) (hβ : β ≤ Parameters.γ k N δ ^ 2 / (4 * (k : ℝ))) + (hm_tiling : IsInsensitive.intersectionTilingBound k F k d β ≤ m) + {A : Finset (Fin n → Fin (k + 1))} + {V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)} + {D : Fin k → Finset (Fin m → Fin (k + 1))} (hD : ∀ i, IsInsensitive i.castSucc (Fin.last k) (D i)) - (hDdense : Parameters.γ k δ ≤ ((IsInsensitive.intersection D).dens : ℝ)) - (hcorrelation : (δ + Parameters.γ k δ) * + (hDdense : Parameters.γ k N δ ≤ ((IsInsensitive.intersection D).dens : ℝ)) + (hcorrelation : (δ + Parameters.γ k N δ) * ((IsInsensitive.intersection D).dens : ℝ) ≤ ((pullback V A ∩ IsInsensitive.intersection D).dens : ℝ)) : ∃ W : Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin n), - δ + Parameters.γ k δ / 2 ≤ (Subspace.relativeDensity W A : ℝ) := by - obtain ⟨𝒱, h𝒱, hcontained, hpairwise, huncovered⟩ := - exists_finite_structured_tiling hk hDHJ hd hδ₀ hδ₁ hm_tiling D hD hDdense - obtain ⟨W, _, hW⟩ := - exists_dense_tile_of_density_sum A V 𝒱 h𝒱 <| - structured_tiling_density_sum hk hδ₀ A V D hDdense hcorrelation 𝒱 - hcontained hpairwise huncovered - refine ⟨Subspace.compose V W, ?_⟩ - rwa [Subspace.relativeDensity_compose] - -/-- A dense word family either contains a line or has increased density on a prescribed-dimensional -subspace. -/ -lemma density_increment {k : ℕ} (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) - (d : ℕ) (hd : 1 ≤ d) (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (n : ℕ) (hn : incrementBound k d δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) : + δ + Parameters.γ k N δ / 2 ≤ (Subspace.relativeDensity W A : ℝ) := by + classical + obtain ⟨𝒱, h𝒱, hU⟩ := IsInsensitive.exists_disjoint_subspaces_iInter hF (by omega) le_rfl hd + hβ₀ hm_tiling (by simpa using hD) + have hγ₀ := Parameters.γ_pos hk N hδ₀ + replace hU : ((IsInsensitive.uncovered (IsInsensitive.intersection D) 𝒱).dens : ℝ) ≤ + Parameters.γ k N δ ^ 2 / 2 := by + linarith [(le_div_iff₀ (by exact_mod_cast (by omega : 0 < 4 * k))).1 hβ] + have hne : (IsInsensitive.intersection D \ + IsInsensitive.uncovered (IsInsensitive.intersection D) 𝒱).Nonempty := + sdiff_nonempty.2 fun hsub ↦ (dens_le_dens hsub).not_gt <| mod_cast hU.trans_lt <| + (by nlinarith [Parameters.γ_le_three_mul_η k N δ, Parameters.η_le_δ_div_six k N δ] : + Parameters.γ k N δ ^ 2 / 2 < Parameters.γ k N δ).trans_le hDdense + obtain ⟨W, -, hW⟩ := h𝒱.exists_le_relativeDensity (A := pullback V A) hne + (add_div_two_mul_dens_sdiff_le hδ₀.le hγ₀.le hDdense hcorrelation hU) + exact ⟨Subspace.compose V W, by rwa [Subspace.relativeDensity_compose]⟩ + +/-- The dimension of the parameter cube on which one density increment towards a `d`-dimensional +subspace is carried out: large enough for the insensitive-intersection construction and for +tiling that intersection by `d`-subspaces. -/ +noncomputable def workingDimension (k : ℕ) (F : ℝ → ℕ) (d : ℕ) (δ : ℝ) : ℕ := + max (max 1 ⌈(k : ℝ) / Parameters.η k (F (δ / 4)) δ⌉₊) + (IsInsensitive.intersectionTilingBound k F k d + (Parameters.γ k (F (δ / 4)) δ ^ 2 / (4 * (k : ℝ)))) + +/-- An ambient dimension in which a line-free family of density at least `δ` over `k + 1` letters +has a density increment on a `d`-dimensional subspace, given a bound `F` for density Hales--Jewett +over `k` letters. -/ +noncomputable def incrementBound (k : ℕ) (F : ℝ → ℕ) (d : ℕ) (δ : ℝ) : ℕ := + manyLinesBound k (F (δ / 4)) (workingDimension k F d δ) δ + +/-- The density increment in a working dimension `m` and with density Hales--Jewett over `k` +letters applied in dimension `N + 1`. The family may have any density `ρ ≥ δ`, while the +dimensions and the increment are those of the density `δ`. -/ +lemma density_increment_of_le {k d m n : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} (hF : IsDHJBound k F) + (hd : 1 ≤ d) {δ ρ : ℝ} (hδ₀ : 0 < δ) (hδρ : δ ≤ ρ) (hρ₁ : ρ ≤ 1) + (hN : IsDHJDimension k (δ / 4) (N + 1)) (hm : 1 ≤ m) + (hm_large : ⌈(k : ℝ) / Parameters.η k N δ⌉₊ ≤ m) + (hm_tiling : IsInsensitive.intersectionTilingBound k F k d + (Parameters.γ k N δ ^ 2 / (4 * (k : ℝ))) ≤ m) + (hn : manyLinesBound k N m δ ≤ n) + {A : Finset (Fin n → Fin (k + 1))} (hA : ρ ≤ (A.dens : ℝ)) (hfree : IsLineFree A) : + ∃ V : Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin n), + ρ + Parameters.γ k N δ / 2 ≤ (Subspace.relativeDensity V A : ℝ) := by + have hρ₀ : 0 < ρ := hδ₀.trans_le hδρ + have hη := Parameters.η_mono k N hδ₀ hδρ + have hγ := Parameters.γ_mono k N hδ₀ hδρ + have : Nonempty (Fin m) := ⟨⟨0, hm⟩⟩ + have : Nonempty (Combinatorics.Line (Fin k) (Fin m)) := + ⟨Combinatorics.Line.diagonal (Fin k) (Fin m)⟩ + obtain ⟨V, D, hD, hDdense, hcorrelation⟩ := + exists_structured_correlation hk hm (hN.mono (by linarith)) hρ₀ hρ₁ + ((div_add_one_pow_le (by omega) (Parameters.η_pos k N hδ₀) hm_large).trans hη) + ((Subspace.variableCutFibersBound_mono (by omega) le_rfl + (by positivity [Parameters.η_pos k N hδ₀]) + (by gcongr; positivity [Parameters.η_pos k N hδ₀])).trans hn) hA hfree + obtain ⟨W, hW⟩ := + exists_density_increment_subspace_of_structured_correlation hk hF hd hρ₀ hρ₁ + (by positivity [Parameters.γ_pos hk N hδ₀, (by omega : 0 < k)]) + (by gcongr; positivity [Parameters.γ_pos hk N hδ₀]) hm_tiling hD hDdense hcorrelation + exact ⟨W, by linarith⟩ + +/-- A word family of density at least `ρ ≥ δ` contains a line or has density at least `ρ + γ / 2` +on a `d`-dimensional subspace, in every dimension `n ≥ incrementBound k F d δ`. -/ +lemma density_increment {k : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} (hF : IsDHJBound k F) + {d : ℕ} (hd : 1 ≤ d) {δ ρ : ℝ} (hδ₀ : 0 < δ) (hδρ : δ ≤ ρ) (hρ₁ : ρ ≤ 1) + {n : ℕ} (hn : incrementBound k F d δ ≤ n) + {A : Finset (Fin n → Fin (k + 1))} (hA : ρ ≤ (A.dens : ℝ)) : (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ ∃ V : Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin n), - δ + Parameters.γ k δ / 2 ≤ (Subspace.relativeDensity V A : ℝ) := by - classical + ρ + Parameters.γ k (F (δ / 4)) δ / 2 ≤ (Subspace.relativeDensity V A : ℝ) := by by_cases hfree : IsLineFree A - · obtain ⟨m, hm, hm_large, hmn, hm_tiling⟩ := - incrementBound_spec hk hDHJ hd hδ₀ hδ₁ hn - let : Nonempty (Fin m) := ⟨⟨0, hm⟩⟩ - let : Nonempty (Combinatorics.Line (Fin k) (Fin m)) := - ⟨Combinatorics.Line.diagonal (Fin k) (Fin m)⟩ - obtain ⟨V, D, hD, hDdense, hcorrelation⟩ := - exists_structured_correlation hk hDHJ m n hm δ hδ₀ hδ₁ hm_large hmn A hA hfree - exact Or.inr <| - exists_density_increment_subspace_of_structured_correlation hk hDHJ hd hδ₀ hδ₁ hm_tiling - A V D hD hDdense hcorrelation - · rw [IsLineFree] at hfree - push Not at hfree - left - exact hfree + · exact Or.inr <| + density_increment_of_le hk hF hd hδ₀ hδρ hρ₁ + (hF (δ / 4) (by linarith) _ (Nat.le_succ _)) + ((le_max_left _ _).trans (le_max_left _ _)) + ((le_max_right _ _).trans (le_max_left _ _)) (le_max_right _ _) hn hA hfree + · exact Or.inl (by simpa [IsLineFree] using hfree) end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean index 72a20aac06..79e4f416f4 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean @@ -6,15 +6,16 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive -import Mathlib.Tactic.Linarith +public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers +import Mathlib.Algebra.Order.BigOperators.Expect /-! # Correlated fibers and many parameter lines Uniformization and line canonization produce a subspace whose parameter-cube lines all have dense common fibers; averaging over fixed suffixes then yields either an immediate density increment or a -suffix carrying many complete restricted-alphabet lines. +suffix with many complete restricted-alphabet lines. -/ @[expose] public section @@ -42,352 +43,151 @@ lemma dens_pullback {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι unfold pullback parameterPreimage Subspace.relativeDensity congr 1 ext x - simp only [Finset.mem_filter] - -/-- The working parameter dimension of the correlated-fibers lemma. -/ -noncomputable def correlatedFibersParameters (k m : ℕ) (δ : ℝ) : ℕ := - max m (Parameters.m₀ k δ) - -/-- The line-canonization dimension of the correlated-fibers lemma. -/ -noncomputable def correlatedFibersLines (k m : ℕ) (δ : ℝ) : ℕ := - max 1 (GrahamRothschild.bound (k + 1) 2 (correlatedFibersParameters k m δ)) - -/-- A bound for the correlated-fibers lemma. Uniformization now returns its own coordinate cut, -so the bound constrains the total ambient dimension. -/ -noncomputable def correlatedFibersBound (k m : ℕ) (δ : ℝ) : ℕ := - Subspace.variableCutFibersBound (k + 1) (correlatedFibersLines k m δ) - (Parameters.η k δ ^ 2 / 2) - -/-- Uniformization followed by line canonization produces a large subspace on which every -restricted-alphabet line is uniformly good or uniformly sparse. -/ -lemma exists_uniform_fibers_and_homogeneous_lines {k M L : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) - {ι κ : Type*} [Finite ι] [Fintype (κ → Fin (k + 1))] - [Fintype (ι ⊕ κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (hGR : GrahamRothschild.bound (k + 1) 2 M ≤ L) - (A : Finset (ι ⊕ κ → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) - (huniform : 1 ≤ L → ∃ U : Combinatorics.Subspace (Fin L) (Fin (k + 1)) ι, - ∀ x, (A.dens : ℝ) - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (U x)).dens : ℝ)) : + simp only [mem_filter] + +variable {N : ℕ} + +/-- Graham--Rothschild applied to a subspace with uniformly dense fibers: a subspace of it on which +either every restricted-alphabet line has common-suffix density at least `θ`, or every one has +common-suffix density below `θ`. -/ +lemma exists_uniform_fibers_and_homogeneous_lines {k M L : ℕ} {δ : ℝ} {ι κ : Type*} + [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] + (hGR : GrahamRothschild.bound (k + 1) 2 M ≤ L) {A : Finset (ι ⊕ κ → Fin (k + 1))} + {U : Combinatorics.Subspace (Fin L) (Fin (k + 1)) ι} + (hU : ∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (U x)).dens : ℝ)) : ∃ W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) ∧ + (∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) ∧ ((∀ l : Combinatorics.Line (Fin k) (Fin M), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) ∨ (∀ l : Combinatorics.Line (Fin k) (Fin M), - ((Finset.univ.filter fun y ↦ + ((univ.filter fun y ↦ ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) < - Parameters.θ k δ)) := by - let : Nontrivial (Fin (k + 1)) := - Fintype.one_lt_card_iff_nontrivial.mp (by - simp only [Fintype.card_fin] - omega) - let ε := Parameters.η k δ ^ 2 / 2 - have hε₀ : 0 < ε := by positivity [Parameters.η_pos hk hδ₀] - by_cases hM : 1 ≤ M - · have hL : 1 ≤ L := by - by_contra hL - obtain rfl : L = 0 := by omega - obtain ⟨R, _⟩ := - GrahamRothschild.lines_twoColor (Fin (k + 1)) M 0 - (by simpa only [Fintype.card_fin] using hGR) ∅ - obtain ⟨i, _⟩ := R.proper ⟨0, hM⟩ - exact Fin.elim0 i - obtain ⟨U, hU⟩ := huniform hL - let : Fintype (Combinatorics.Line (Fin (k + 1)) (Fin L)) := - Subspace.lineFintype (k + 1) L - let goodLines := - Finset.univ.filter fun q : Combinatorics.Line (Fin (k + 1)) (Fin L) ↦ - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ - ∀ a : Fin k, Sum.elim (U (q a.castSucc)) y ∈ A).dens : ℝ) - obtain ⟨R, hgood | hbad⟩ := - GrahamRothschild.lines_twoColor (Fin (k + 1)) M L - (by simpa only [Fintype.card_fin] using hGR) goodLines - · refine ⟨Subspace.compose U R, ?_, ?_⟩ - · intro x - rw [Subspace.compose_apply] - have hx := hU (R x) - linarith - · left - intro l - have hl := hgood (l.map Fin.castSucc) - simpa only [goodLines, Finset.mem_filter, Finset.mem_univ, true_and, - Subspace.mapLine_apply, Combinatorics.Line.map_apply, - Subspace.compose_apply] using hl - · refine ⟨Subspace.compose U R, ?_, ?_⟩ - · intro x - rw [Subspace.compose_apply] - have hx := hU (R x) - linarith - · right - intro l - have hl := hbad (l.map Fin.castSucc) - simp only [goodLines, Finset.mem_filter, Finset.mem_univ, true_and, - Subspace.mapLine_apply, Combinatorics.Line.map_apply] at hl - simpa only [Subspace.compose_apply] using lt_of_not_ge hl - · have hM₀ : M = 0 := by omega - subst M - let : Fintype (ι → Fin (k + 1)) := Fintype.ofFinite _ - have havg : - δ ≤ 𝔼 x : ι → Fin (k + 1), ((fiber A x).dens : ℝ) := by - simpa only [average_density_fiber] using hA - obtain ⟨x, _, hx⟩ := - Finset.exists_le_of_le_expect Finset.univ_nonempty havg - let W : Combinatorics.Subspace (Fin 0) (Fin (k + 1)) ι := { - idxFun := fun i ↦ Sum.inl (x i) - proper := fun e ↦ Fin.elim0 e - } - refine ⟨W, ?_, ?_⟩ - · intro z - have hW : W z = x := by - funext i - simp only [W, Combinatorics.Subspace.coe_apply, Sum.elim_inl, id_eq] - rw [hW] - dsimp only [ε] at hε₀ - linarith - · left - intro l - exact Fin.elim0 l.proper.choose + Parameters.θ k N δ)) := by + classical + let := Subspace.lineFintype (k + 1) L + obtain ⟨R, hR⟩ := GrahamRothschild.exists_mapLine_mem_or_notMem (by simpa using hGR) + (univ.filter fun l : Combinatorics.Line (Fin (k + 1)) (Fin L) ↦ Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a : Fin k, Sum.elim (U (l a.castSucc)) y ∈ A).dens : ℝ)) + refine ⟨Subspace.compose U R, ?_, ?_⟩ + · intro x + simpa using hU (R x) + · refine hR.imp ?_ ?_ + · intro h l + simpa [Combinatorics.Line.map_apply] using h (l.map Fin.castSucc) + · intro h l + simpa [Combinatorics.Line.map_apply] using h (l.map Fin.castSucc) /-- Restricting the parameter directions of a good correlated-fibers subspace preserves its uniform fiber and common-line-fiber estimates. -/ lemma restrict_correlated_fibers_subspace {k m M : ℕ} (hm : 1 ≤ m) (hmM : m ≤ M) {δ : ℝ} {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) + {A : Finset (ι ⊕ κ → Fin (k + 1))} + {W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι} (hfibers : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) (hlines : ∀ l : Combinatorics.Line (Fin k) (Fin M), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ + (∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ ∀ l : Combinatorics.Line (Fin k) (Fin m), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := by let R := Subspace.repeatInitial (Fin (k + 1)) hm hmM let V := Subspace.compose W R refine ⟨V, ?_, ?_⟩ · intro x - simpa only [V, Subspace.compose_apply] using hfibers (R x) + simpa [V, Subspace.compose_apply] using hfibers (R x) · intro l let Rk := Subspace.repeatInitial (Fin k) hm hmM - simpa only [V, R, Rk, Subspace.compose_apply, Subspace.composeLine_apply, + simpa [V, R, Rk, Subspace.compose_apply, Subspace.composeLine_apply, Subspace.repeatInitial_map] using hlines (Subspace.composeLine Rk l) -/-- Uniformize the fibers and canonize their line-density coloring. - -The working parameter dimension is chosen large enough both for the requested `m`-dimensional -output and for the density Hales--Jewett argument at dimension `Parameters.m₀ k δ`. In the -monochromatic good case, restrict the working subspace to `m` parameters. In the bad case, retain -the larger subspace as a certificate whose every restricted-alphabet line has common-suffix density -strictly below `Parameters.θ k δ`. -/ -lemma exists_correlated_fibers_or_sparse_certificate {k M L : ℕ} (hk : 2 ≤ k) - (m : ℕ) (hm : 1 ≤ m) - (δ : ℝ) (hδ₀ : 0 < δ) - {ι κ : Type*} [Finite ι] [Fintype (κ → Fin (k + 1))] - [Fintype (ι ⊕ κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (hmM : m ≤ M) (hm₀M : Parameters.m₀ k δ ≤ M) - (hGR : GrahamRothschild.bound (k + 1) 2 M ≤ L) - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (hA : δ ≤ (A.dens : ℝ)) - (huniform : 1 ≤ L → ∃ U : Combinatorics.Subspace (Fin L) (Fin (k + 1)) ι, - ∀ x, (A.dens : ℝ) - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (U x)).dens : ℝ)) : - (∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ - ∀ l : Combinatorics.Line (Fin k) (Fin m), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) ∨ - ∃ M : ℕ, Parameters.m₀ k δ ≤ M ∧ - ∃ W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) ∧ - ∀ l : Combinatorics.Line (Fin k) (Fin M), - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) < - Parameters.θ k δ := by - obtain ⟨W, hfibers, hgood | hsparse⟩ := - exists_uniform_fibers_and_homogeneous_lines hk hδ₀ hGR A hA huniform - · exact .inl <| - restrict_correlated_fibers_subspace hm hmM A W hfibers hgood - · right - exact ⟨M, hm₀M, W, hfibers, hsparse⟩ - /-- Uniformly dense fibers force a positive-density set of suffixes whose restricted parameter slice has density at least `δ / 4`. -/ lemma dense_suffixes_of_uniform_fibers {k M : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) + {A : Finset (ι ⊕ κ → Fin (k + 1))} + {W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι} (hfibers : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : δ / 4 ≤ - ((Finset.univ.filter fun y : κ → Fin (k + 1) ↦ + ((univ.filter fun y : κ → Fin (k + 1) ↦ δ / 4 ≤ - ((Finset.univ.filter fun x : Fin M → Fin k ↦ + ((univ.filter fun x : Fin M → Fin k ↦ Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ)).dens : ℝ) := by let : Nonempty (Fin k) := ⟨⟨0, by omega⟩⟩ - let f := fun y : κ → Fin (k + 1) ↦ - ((Finset.univ.filter fun x : Fin M → Fin k ↦ - Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ) - have hη₀ := Parameters.η_pos hk hδ₀ - have hηδ := Parameters.η_le_δ_div_six k δ - have havg : δ - Parameters.η k δ ^ 2 / 2 ≤ - Finset.expect Finset.univ f := by - rw [Subspace.average_restrictedParameterSlice] - exact Finset.le_expect Finset.univ_nonempty fun x _ ↦ hfibers (Fin.castSucc ∘ x) - have hthreshold := density_ge_threshold f - (δ - Parameters.η k δ ^ 2 / 2) (δ / 4) - (fun y ↦ by - dsimp only [f] - exact_mod_cast Finset.dens_le_one) - (by nlinarith [sq_nonneg δ]) havg - refine (le_div_iff₀ (by linarith : 0 < 1 - δ / 4)).mpr ?_ |>.trans hthreshold - nlinarith [sq_nonneg δ] - -/-- Density Hales--Jewett in every dense suffix slice, followed by finite pigeonhole, produces -one parameter line shared by at least a `θ`-density set of suffixes. -/ + have hη₀ := Parameters.η_pos k N hδ₀ + have hηδ := Parameters.η_le_δ_div_six k N δ + refine le_trans ?_ (density_ge_threshold (fun y ↦ by exact_mod_cast dens_le_one) + (by nlinarith : δ / 4 < δ - Parameters.η k N δ ^ 2 / 2) + ((le_expect univ_nonempty fun x _ ↦ hfibers (Fin.castSucc ∘ x)).trans_eq + (Subspace.average_restrictedParameterSlice A W).symm)) + rw [le_div_iff₀ (by linarith)] + nlinarith + +/-- Density Hales--Jewett in every dense suffix slice, followed by pigeonhole on lines, produces +one parameter line shared by a set of suffixes of density at least `θ`. -/ lemma exists_popular_line_of_dense_suffixes {k M : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hM : Parameters.m₀ k δ ≤ M) + {δ : ℝ} (hN : IsDHJDimension k (δ / 4) (N + 1)) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) + (hM : N + 1 ≤ M) {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) + {A : Finset (ι ⊕ κ → Fin (k + 1))} + {W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι} (hfibers : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : ∃ l : Combinatorics.Line (Fin k) (Fin M), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := by - classical - let q := Parameters.m₀ k δ - have hq₀ : 0 < q := Parameters.m₀_pos k δ - let R := Subspace.repeatInitial (Fin (k + 1)) (Nat.one_le_iff_ne_zero.mpr hq₀.ne') hM - let W₀ := Subspace.compose W R - have hW₀ : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W₀ x)).dens : ℝ) := by - intro x - simpa only [W₀, Subspace.compose_apply] using hfibers (R x) - have hdense := dense_suffixes_of_uniform_fibers hk hδ₀ hδ₁ A W₀ hW₀ - let := Subspace.lineFintype k q - let B := Finset.univ.filter fun y : κ → Fin (k + 1) ↦ - δ / 4 ≤ - ((Finset.univ.filter fun x : Fin q → Fin k ↦ - Sum.elim (W₀ (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ) - have hB : δ / 4 ≤ (B.dens : ℝ) := by - simpa only [B] using hdense - have hBne : B.Nonempty := - Finset.dens_pos.mp (by exact_mod_cast lt_of_lt_of_le (by linarith : 0 < δ / 4) hB) - have hbound : Subspace.densityOneBound k (δ / 4) ≤ q := by - dsimp only [q] - rw [Subspace.densityOneBound, dite_eq_left ⟨by linarith, hDHJ⟩, - Parameters.m₀, dite_eq_left ⟨hδ₀, hDHJ⟩] - omega - have existsLine (y : κ → Fin (k + 1)) (hy : y ∈ B) : - ∃ l : Combinatorics.Line (Fin k) (Fin q), - ∀ a, Sum.elim (W₀ (Fin.castSucc ∘ l a)) y ∈ A := by - let S := Finset.univ.filter fun x : Fin q → Fin k ↦ - Sum.elim (W₀ (Fin.castSucc ∘ x)) y ∈ A - obtain ⟨l, hl⟩ := - Subspace.densityOneBound_spec hDHJ (δ / 4) (by linarith) q hbound S <| - Subspace.card_le_of_density_le (by omega) (δ / 4) S - (by simpa only [B, Finset.mem_filter, Finset.mem_univ, true_and, S] using hy) - exact ⟨l, fun a ↦ by - simpa only [S, Finset.mem_filter, Finset.mem_univ, true_and] using hl a⟩ - choose lineAt hlineAt using fun y : {y // y ∈ B} ↦ existsLine y y.2 - let l₀ := lineAt ⟨hBne.choose, hBne.choose_spec⟩ - let : Nonempty (Combinatorics.Line (Fin k) (Fin q)) := ⟨l₀⟩ - let f : (κ → Fin (k + 1)) → Combinatorics.Line (Fin k) (Fin q) := fun y ↦ - if hy : y ∈ B then lineAt ⟨y, hy⟩ else l₀ - obtain ⟨l, hl⟩ := Subspace.exists_fiber_density B f - have hcommon : - (B.filter fun y ↦ f y = l) ⊆ - Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (W₀ (Fin.castSucc ∘ l a)) y ∈ A := by - intro y hy - simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hy ⊢ - have hline : lineAt ⟨y, hy.1⟩ = l := by - simpa only [f, dite_eq_left hy.1] using hy.2 - intro a - rw [← hline] - exact hlineAt ⟨y, hy.1⟩ a - have hcard : - (Fintype.card (Combinatorics.Line (Fin k) (Fin q)) : ℝ) = - ((k + 1 : ℕ) : ℝ) ^ q - (k : ℝ) ^ q := by - rw [Subspace.card_line k q (by omega), Nat.cast_sub] - · simp only [Nat.cast_pow, Nat.cast_add, Nat.cast_one] - · exact Nat.pow_le_pow_left (Nat.le_succ k) q - have hθ : - Parameters.θ k δ ≤ - (B.dens : ℝ) / Fintype.card (Combinatorics.Line (Fin k) (Fin q)) := by - unfold Parameters.θ - rw [← hcard] - exact div_le_div_of_nonneg_right hB (by positivity) - let Rk := Subspace.repeatInitial (Fin k) (Nat.one_le_iff_ne_zero.mpr hq₀.ne') hM - refine ⟨Subspace.composeLine Rk l, hθ.trans (hl.trans ?_)⟩ - exact_mod_cast Finset.dens_le_dens <| by - simpa only [W₀, R, Rk, Subspace.compose_apply, Subspace.composeLine_apply, - Subspace.repeatInitial_map] using hcommon - -/-- The uniformly sparse certificate is impossible. - -Average the dense fibers over suffixes, find many suffix slices of density at least `δ / 4`, and -apply `hDHJ` on an embedded `Parameters.m₀ k δ`-dimensional parameter cube in each such slice. -Pigeonholing the resulting lines gives one line with common-suffix density at least -`Parameters.θ k δ`, contradicting the certificate. -/ -lemma not_exists_sparse_correlated_fibers_certificate {k : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - {ι κ : Type*} [Fintype (κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) : - ¬ ∃ M : ℕ, Parameters.m₀ k δ ≤ M ∧ - ∃ W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) ∧ - ∀ l : Combinatorics.Line (Fin k) (Fin M), - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) < - Parameters.θ k δ := by - rintro ⟨M, hM, W, hfibers, hsparse⟩ - obtain ⟨l, hl⟩ := - exists_popular_line_of_dense_suffixes hk hDHJ hδ₀ hδ₁ hM A W hfibers - exact (not_lt_of_ge hl) (hsparse l) - -/-- Every parameter-cube line in a suitable subspace has a dense common fiber. -/ + let R := Subspace.repeatInitial (Fin (k + 1)) (Nat.le_add_left 1 N) hM + let Rk := Subspace.repeatInitial (Fin k) (Nat.le_add_left 1 N) hM + obtain ⟨l, hl⟩ := Subspace.exists_line_forall_mem_slices (by omega) hN + (fun y ↦ univ.filter fun x ↦ Sum.elim (Subspace.compose W R (Fin.castSucc ∘ x)) y ∈ A) + (by positivity) (dense_suffixes_of_uniform_fibers hk hδ₀ hδ₁ (W := Subspace.compose W R) + fun x ↦ by simpa using hfibers (R x)) + fun y hy ↦ (mem_filter.1 hy).2 + refine ⟨Subspace.composeLine Rk l, hl.trans (mod_cast dens_le_dens ?_)⟩ + intro y + simp [Subspace.compose_apply, Subspace.composeLine_apply, Subspace.repeatInitial_map, R, Rk] + +/-- Every parameter-cube line in a suitable subspace has a dense common fiber. + +Graham--Rothschild makes the lines of a subspace of dimension `M` all dense or all sparse, and +`exists_popular_line_of_dense_suffixes` rules out the second case. The subspace is then restricted +to `m` parameters. -/ lemma exists_subspace_correlated_fibers {k M L : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) (m : ℕ) (hm : 1 ≤ m) - (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - {ι κ : Type*} [Finite ι] [Fintype (κ → Fin (k + 1))] - [Fintype (ι ⊕ κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (hmM : m ≤ M) (hm₀M : Parameters.m₀ k δ ≤ M) + {m : ℕ} (hm : 1 ≤ m) + {δ : ℝ} (hN : IsDHJDimension k (δ / 4) (N + 1)) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) + {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] + (hmM : m ≤ M) (hNM : N + 1 ≤ M) (hGR : GrahamRothschild.bound (k + 1) 2 M ≤ L) - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (hA : δ ≤ (A.dens : ℝ)) - (huniform : 1 ≤ L → ∃ U : Combinatorics.Subspace (Fin L) (Fin (k + 1)) ι, - ∀ x, (A.dens : ℝ) - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (U x)).dens : ℝ)) : + {A : Finset (ι ⊕ κ → Fin (k + 1))} {U : Combinatorics.Subspace (Fin L) (Fin (k + 1)) ι} + (hU : ∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (U x)).dens : ℝ)) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι, - (∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ + (∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ ∀ l : Combinatorics.Line (Fin k) (Fin m), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := - (exists_correlated_fibers_or_sparse_certificate hk m hm δ hδ₀ hmM hm₀M hGR A hA - huniform).resolve_right (not_exists_sparse_correlated_fibers_certificate hk hDHJ δ hδ₀ hδ₁ A) + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := by + obtain ⟨W, hW, hgood | hsparse⟩ := exists_uniform_fibers_and_homogeneous_lines hGR hU + · exact restrict_correlated_fibers_subspace hm hmM hW hgood + · obtain ⟨l, hl⟩ := exists_popular_line_of_dense_suffixes hk hN hδ₀ hδ₁ hNM hW + exact absurd hl (hsparse l).not_ge /-- The pullback of a word family to a subspace after fixing the suffix coordinates. -/ def suffixPullback {α η ι κ : Type*} [Fintype (η → α)] [DecidableEq (ι ⊕ κ → α)] (V : Combinatorics.Subspace η α ι) (A : Finset (ι ⊕ κ → α)) (y : κ → α) : Finset (η → α) := - Finset.univ.filter fun x ↦ Sum.elim (V x) y ∈ A + univ.filter fun x ↦ Sum.elim (V x) y ∈ A /-- The parameter lines whose first-`k` points belong to a word family at a fixed suffix. -/ def suffixLines {k m : ℕ} {ι κ : Type*} @@ -396,303 +196,169 @@ def suffixLines {k m : ℕ} {ι κ : Type*} (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) (A : Finset (ι ⊕ κ → Fin (k + 1))) (y : κ → Fin (k + 1)) : Finset (Combinatorics.Line (Fin k) (Fin m)) := - Finset.univ.filter fun l ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A - -/-- Fix suffix coordinates of a subspace. -/ -def Subspace.fixSuffix {α η ι κ : Type*} (V : Combinatorics.Subspace η α ι) - (y : κ → α) : Combinatorics.Subspace η α (ι ⊕ κ) where - idxFun := Sum.elim V.idxFun (Sum.inl ∘ y) - proper e := by - obtain ⟨i, hi⟩ := V.proper e - exact ⟨Sum.inl i, hi⟩ - -/-- Fix suffix coordinates and transport the ambient coordinates along an equivalence. -/ -def Subspace.fixSuffixReindex {α η ι κ ζ : Type*} (e : ι ⊕ κ ≃ ζ) - (V : Combinatorics.Subspace η α ι) (y : κ → α) : - Combinatorics.Subspace η α ζ := - (Subspace.fixSuffix V y).reindex (Equiv.refl _) (Equiv.refl _) e + univ.filter fun l ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A /-- Pointwise fiber lower bounds imply the corresponding average lower bound for fixed-suffix -pullbacks. This is a finite double-counting argument. -/ +pullbacks, by double counting. -/ lemma average_suffixPullback_lower {α η ι κ : Type*} [Nonempty α] [Fintype (η → α)] [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] - (V : Combinatorics.Subspace η α ι) (A : Finset (ι ⊕ κ → α)) (r : ℝ) + {V : Combinatorics.Subspace η α ι} {A : Finset (ι ⊕ κ → α)} {r : ℝ} (hV : ∀ x, r ≤ ((fiber A (V x)).dens : ℝ)) : - r ≤ 𝔼 y : κ → α, ((suffixPullback V A y).dens : ℝ) := by - have h_expect_eq : 𝔼 x : η → α, ((fiber A (V x)).dens : ℝ) = - 𝔼 y : κ → α, ((suffixPullback V A y).dens : ℝ) := by - calc - 𝔼 x : η → α, ((fiber A (V x)).dens : ℝ) - = 𝔼 x : η → α, 𝔼 y : κ → α, (Set.indicator (fiber A (V x)) (1 : (κ → α) → ℝ) y : ℝ) := by - simp - _ = 𝔼 y : κ → α, 𝔼 x : η → α, (Set.indicator (fiber A (V x)) (1 : (κ → α) → ℝ) y : ℝ) := by - rw [Finset.expect_comm (Finset.univ : Finset (η → α)) (Finset.univ : Finset (κ → α))] - _ = 𝔼 y : κ → α, 𝔼 x : η → α, - (Set.indicator (suffixPullback V A y) (1 : (η → α) → ℝ) x : ℝ) := by - apply Finset.expect_congr rfl - intro y _ - apply Finset.expect_congr rfl - intro x _ - by_cases h : Sum.elim (V x) y ∈ A <;> simp [fiber, suffixPullback, h] - _ = 𝔼 y : κ → α, ((suffixPullback V A y).dens : ℝ) := by - simp - have h_r_le_expect : r ≤ 𝔼 x : η → α, ((fiber A (V x)).dens : ℝ) := - Finset.le_expect (Finset.univ_nonempty (α := η → α)) fun x _ => hV x - exact h_r_le_expect.trans h_expect_eq.le + r ≤ 𝔼 y : κ → α, ((suffixPullback V A y).dens : ℝ) := + (le_expect univ_nonempty fun x _ ↦ hV x).trans_eq + (Subspace.expect_dens_filter_comm fun x y ↦ Sum.elim (V x) y ∈ A) /-- If a function has average at least `δ - η²/2` but never reaches `δ + η²/2`, then it is at least `δ - 2η` on all but an `η`-fraction of its domain. -/ lemma density_near_average {X : Type*} [Fintype X] [Nonempty X] - (f : X → ℝ) (δ η : ℝ) (hη₀ : 0 < η) + {f : X → ℝ} {δ η : ℝ} (hη₀ : 0 < η) (havg : δ - η ^ 2 / 2 ≤ 𝔼 x : X, f x) (hupper : ∀ x, f x < δ + η ^ 2 / 2) : - 1 - η ≤ ((Finset.univ.filter fun x ↦ δ - 2 * η ≤ f x).dens : ℝ) := by - set H := Finset.univ.filter fun x ↦ δ - 2 * η ≤ f x - by_cases hH : 1 - η ≤ (H.dens : ℝ) - · exact hH - · exfalso - have hfg : ∀ x : X, f x ≤ (δ - 2 * η) + (η ^ 2 / 2 + 2 * η) - * (Set.indicator H (1 : X → ℝ) x : ℝ) := by - intro x - by_cases hxH : x ∈ H - · rw [Set.indicator_of_mem (by simpa using hxH), Pi.one_apply, mul_one] - linarith [hupper x] - · rw [Set.indicator_of_notMem (by simpa using hxH), mul_zero, add_zero] - have : ¬(δ - 2 * η ≤ f x) := by simpa [H] using hxH - linarith - have hexpect : 𝔼 x : X, f x ≤ (δ - 2 * η) + (η ^ 2 / 2 + 2 * η) * ((H.dens : ℝ)) := by - apply (Finset.expect_le_expect fun x _ ↦ hfg x).trans_eq - rw [Finset.expect_add_distrib, Finset.expect_const univ_nonempty, ← Finset.mul_expect] - simp - linarith [havg, hexpect, - mul_le_mul_of_nonneg_left (not_le.mp hH).le (by positivity : (0 : ℝ) ≤ η ^ 2 / 2 + 2 * η), - mul_pos hη₀ hη₀, pow_pos hη₀ 3] + 1 - η ≤ ((univ.filter fun x ↦ δ - 2 * η ≤ f x).dens : ℝ) := by + set H := univ.filter fun x ↦ δ - 2 * η ≤ f x + have hf (x : X) : f x ≤ (δ - 2 * η) + (η ^ 2 / 2 + 2 * η) * Set.indicator H 1 x := by + by_cases hx : x ∈ H + · rw [Set.indicator_of_mem (by simpa using hx), Pi.one_apply, mul_one] + linarith [hupper x] + · rw [Set.indicator_of_notMem (by simpa using hx), mul_zero, add_zero] + exact (not_le.1 (by simpa [H] using hx)).le + have hexpect : 𝔼 x : X, f x ≤ (δ - 2 * η) + (η ^ 2 / 2 + 2 * η) * (H.dens : ℝ) := by + refine (expect_le_expect fun x _ ↦ hf x).trans_eq ?_ + rw [expect_add_distrib, expect_const univ_nonempty, ← mul_expect, expect_indicator_one] + by_contra! hH + nlinarith [mul_le_mul_of_nonneg_left hH.le (by positivity : (0 : ℝ) ≤ η ^ 2 / 2 + 2 * η)] /-- Dense common suffix fibers for every line give the same lower bound for the average -fixed-suffix line density. This is the second finite double-counting step. -/ +fixed-suffix line density, by double counting. -/ lemma average_suffixLines_lower {k m : ℕ} {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [Fintype (Combinatorics.Line (Fin k) (Fin m))] [Nonempty (Combinatorics.Line (Fin k) (Fin m))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) - (A : Finset (ι ⊕ κ → Fin (k + 1))) (θ : ℝ) + {V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι} + {A : Finset (ι ⊕ κ → Fin (k + 1))} {θ : ℝ} (hV : ∀ l : Combinatorics.Line (Fin k) (Fin m), - θ ≤ ((Finset.univ.filter fun y ↦ + θ ≤ ((univ.filter fun y ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) : θ ≤ 𝔼 y : κ → Fin (k + 1), ((suffixLines V A y).dens : ℝ) := by - have h_expect_eq : 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) = - 𝔼 y : κ → Fin (k + 1), ((suffixLines V A y).dens : ℝ) := by - calc - 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) - = 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - 𝔼 y : κ → Fin (k + 1), - (Set.indicator (Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A) - (1 : (κ → Fin (k + 1)) → ℝ) y : ℝ) := by - apply Finset.expect_congr rfl - intro l _ - rw [← Finset.expect_indicator_one] - _ = 𝔼 y : κ → Fin (k + 1), - 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - (Set.indicator (Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A) - (1 : (κ → Fin (k + 1)) → ℝ) y : ℝ) := by - rw [Finset.expect_comm (Finset.univ : Finset (Combinatorics.Line (Fin k) (Fin m))) - (Finset.univ : Finset (κ → Fin (k + 1)))] - _ = 𝔼 y : κ → Fin (k + 1), - 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - (Set.indicator (suffixLines V A y) - (1 : Combinatorics.Line (Fin k) (Fin m) → ℝ) l : ℝ) := by - apply Finset.expect_congr rfl - intro y _ - apply Finset.expect_congr rfl - intro l _ - dsimp [suffixLines] - by_cases h : ∀ a : Fin k, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A <;> simp [h] - _ = 𝔼 y : κ → Fin (k + 1), ((suffixLines V A y).dens : ℝ) := by - simp - have h_θ_le_expect : θ ≤ 𝔼 l : Combinatorics.Line (Fin k) (Fin m), - ((Finset.univ.filter fun y ↦ - ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := - Finset.le_expect (Finset.univ_nonempty (α := Combinatorics.Line (Fin k) (Fin m))) - fun l _ => hV l - exact h_θ_le_expect.trans h_expect_eq.le + refine (le_expect univ_nonempty fun l _ ↦ hV l).trans_eq ?_ + unfold suffixLines + exact Subspace.expect_dens_filter_comm _ /-- A function bounded above by one with average at least `θ` exceeds `θ/2` on a set of density at least `θ/2`. -/ lemma density_half_threshold {X : Type*} [Fintype X] [Nonempty X] - (f : X → ℝ) (θ : ℝ) (hθ₀ : 0 < θ) (hθ₁ : θ ≤ 1) + {f : X → ℝ} {θ : ℝ} (hθ₀ : 0 < θ) (hθ₁ : θ ≤ 1) (hf₁ : ∀ x, f x ≤ 1) (havg : θ ≤ 𝔼 x : X, f x) : - θ / 2 ≤ ((Finset.univ.filter fun x ↦ θ / 2 ≤ f x).dens : ℝ) := by + θ / 2 ≤ ((univ.filter fun x ↦ θ / 2 ≤ f x).dens : ℝ) := by refine le_trans ?_ - (density_ge_threshold f θ (θ / 2) hf₁ (by linarith) havg) + (density_ge_threshold hf₁ (by linarith) havg) rw [le_div_iff₀ (by linarith : (0 : ℝ) < 1 - θ / 2)] nlinarith [sq_nonneg (θ / 2)] /-- Two subsets of densities at least `1-η` and `θ/2` intersect when `η < θ/2`. -/ lemma exists_mem_inter_of_large_density {X : Type*} [Fintype X] - (S T : Finset X) (η θ : ℝ) + {S T : Finset X} {η θ : ℝ} (hS : 1 - η ≤ (S.dens : ℝ)) (hT : θ / 2 ≤ (T.dens : ℝ)) (hηθ : η < θ / 2) : ∃ x, x ∈ S ∧ x ∈ T := by classical - by_contra h + by_contra! h have hunion : ((S ∪ T).dens : ℝ) = (S.dens : ℝ) + (T.dens : ℝ) := by - exact_mod_cast Finset.dens_union_of_disjoint - (Finset.disjoint_left.mpr fun x hxS hxT ↦ h ⟨x, hxS, hxT⟩) - have hle : ((S ∪ T).dens : ℝ) ≤ 1 := by - exact_mod_cast Finset.dens_le_one (s := S ∪ T) - linarith [hunion, hle] + exact_mod_cast dens_union_of_disjoint (disjoint_left.mpr h) + linarith [(by exact_mod_cast dens_le_one : ((S ∪ T).dens : ℝ) ≤ 1)] /-- Correlated fibers yield either a dense fixed suffix or a fixed suffix supporting many -complete parameter lines. -/ -lemma exists_suffix_many_lines {k m : ℕ} (hk : 2 ≤ k) +complete parameter lines. + +If no suffix pullback reaches density `δ + η²/2`, then all but an `η`-fraction of the suffixes +have pullback density at least `δ - 2η`, a `θ/2`-fraction support a `θ/2`-fraction of the lines, +and `η < θ/2` makes the two sets meet. -/ +lemma exists_suffix_many_lines {k m : ℕ} [Fintype (Combinatorics.Line (Fin k) (Fin m))] [Nonempty (Combinatorics.Line (Fin k) (Fin m))] - (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) + {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) {ι κ : Type*} [Fintype (Fin m → Fin (k + 1))] [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) - (hfiber : ∀ x, δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) + {A : Finset (ι ⊕ κ → Fin (k + 1))} + {V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι} + (hfiber : ∀ x, δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) (hlines : ∀ l : Combinatorics.Line (Fin k) (Fin m), - Parameters.θ k δ ≤ - ((Finset.univ.filter fun y ↦ + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) : - (∃ y, δ + Parameters.η k δ ^ 2 / 2 ≤ + (∃ y, δ + Parameters.η k N δ ^ 2 / 2 ≤ ((suffixPullback V A y).dens : ℝ)) ∨ - ∃ y, δ - 2 * Parameters.η k δ ≤ ((suffixPullback V A y).dens : ℝ) ∧ - Parameters.θ k δ / 2 ≤ ((suffixLines V A y).dens : ℝ) := by - classical - let f := fun y : κ → Fin (k + 1) ↦ ((suffixPullback V A y).dens : ℝ) - let g := fun y : κ → Fin (k + 1) ↦ ((suffixLines V A y).dens : ℝ) - by_cases hinc : ∃ y, δ + Parameters.η k δ ^ 2 / 2 ≤ f y - · exact .inl hinc - right - have hη₀ : 0 < Parameters.η k δ := Parameters.η_pos hk hδ₀ - have hη₁ : Parameters.η k δ ≤ 1 := - (Parameters.η_le_δ_div_six k δ).trans (by linarith) - have havgf : δ - Parameters.η k δ ^ 2 / 2 ≤ 𝔼 y, f y := - average_suffixPullback_lower V A _ hfiber - have hupper : ∀ y, f y < δ + Parameters.η k δ ^ 2 / 2 := by - intro y - exact lt_of_not_ge fun hy ↦ hinc ⟨y, hy⟩ - have hmostly : 1 - Parameters.η k δ ≤ - ((Finset.univ.filter fun y ↦ δ - 2 * Parameters.η k δ ≤ f y).dens : ℝ) := - density_near_average f δ (Parameters.η k δ) hη₀ havgf hupper - have havgg : Parameters.θ k δ ≤ 𝔼 y, g y := - average_suffixLines_lower V A (Parameters.θ k δ) hlines - have hmany : Parameters.θ k δ / 2 ≤ - ((Finset.univ.filter fun y ↦ Parameters.θ k δ / 2 ≤ g y).dens : ℝ) := by - refine density_half_threshold g (Parameters.θ k δ) (Parameters.θ_pos hk hδ₀) - (Parameters.θ_le_one hk hδ₁) ?_ havgg - intro y - dsimp only [g] - exact_mod_cast Finset.dens_le_one (s := suffixLines V A y) - obtain ⟨y, hy₁, hy₂⟩ := exists_mem_inter_of_large_density - (Finset.univ.filter fun y ↦ δ - 2 * Parameters.η k δ ≤ f y) - (Finset.univ.filter fun y ↦ Parameters.θ k δ / 2 ≤ g y) - (Parameters.η k δ) (Parameters.θ k δ) hmostly hmany - (Parameters.η_lt_θ_div_two hk hδ₀) - refine ⟨y, ?_, ?_⟩ - · simpa only [Finset.mem_filter, Finset.mem_univ, true_and, f] using hy₁ - · simpa only [Finset.mem_filter, Finset.mem_univ, true_and, g] using hy₂ - -/-- Fixing a suffix and reindexing preserves the relative-density and complete-line statistics. -The proof is coordinate bookkeeping using `Subspace.reindex_apply` and `Finset.mem_map_equiv`. -/ -lemma Subspace.fixSuffixReindex_statistics {k m : ℕ} {ι κ ζ : Type*} - [Fintype (Fin m → Fin (k + 1))] - [Fintype (Combinatorics.Line (Fin k) (Fin m))] - [DecidableEq (ζ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (e : ι ⊕ κ ≃ ζ) (A : Finset (ζ → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) - (y : κ → Fin (k + 1)) : - let A' := A.map ((e.arrowCongr (Equiv.refl _)).symm.toEmbedding) - (Subspace.relativeDensity (Subspace.fixSuffixReindex e V y) A : ℝ) = - ((suffixPullback V A' y).dens : ℝ) ∧ - ((Finset.univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ - ∀ a, Subspace.fixSuffixReindex e V y (Fin.castSucc ∘ l a) ∈ A).dens : ℝ) = - ((suffixLines V A' y).dens : ℝ) := by - intro A' - have h_fixSuffix_eval (x : Fin m → Fin (k + 1)) : - (Subspace.fixSuffix V y : (Fin m → Fin (k + 1)) → (ι ⊕ κ → Fin (k + 1))) x - = Sum.elim (V x) y := by - ext j - cases j <;> simp [Subspace.fixSuffix, Combinatorics.Subspace.coe_apply] - have h_eval (x : Fin m → Fin (k + 1)) : - Subspace.fixSuffixReindex e V y x = Sum.elim (V x) y ∘ e.symm := by - calc - Subspace.fixSuffixReindex e V y x - = (Subspace.fixSuffix V y) x ∘ e.symm := by - ext i - simp [Subspace.fixSuffixReindex, Combinatorics.Subspace.reindex_apply] - _ = Sum.elim (V x) y ∘ e.symm := by rw [h_fixSuffix_eval x] - have h_mem_map (x : Fin m → Fin (k + 1)) : - Subspace.fixSuffixReindex e V y x ∈ A ↔ Sum.elim (V x) y ∈ A' := by - rw [h_eval x] - dsimp [A'] - simp [Finset.mem_map_equiv, Equiv.arrowCongr] - constructor - · dsimp [Subspace.relativeDensity, suffixPullback] - congr - ext x - simp [h_mem_map x] - · dsimp [suffixLines] - congr - ext l - exact forall_congr' fun a ↦ h_mem_map (Fin.castSucc ∘ l a) - -/-- A bound for the many-lines lemma. -/ -noncomputable def manyLinesBound (k m : ℕ) (δ : ℝ) : ℕ := - correlatedFibersBound k m δ + ∃ y, δ - 2 * Parameters.η k N δ ≤ ((suffixPullback V A y).dens : ℝ) ∧ + Parameters.θ k N δ / 2 ≤ ((suffixLines V A y).dens : ℝ) := by + rw [or_iff_not_imp_left] + intro hinc + push Not at hinc + obtain ⟨y, hy, hylines⟩ := exists_mem_inter_of_large_density + (density_near_average (Parameters.η_pos k N hδ₀) (average_suffixPullback_lower hfiber) hinc) + (density_half_threshold (Parameters.θ_pos k N hδ₀) (Parameters.θ_le_one k N hδ₁) + (fun y ↦ by exact_mod_cast dens_le_one) (average_suffixLines_lower hlines)) + (Parameters.η_lt_θ_div_two k N hδ₀) + exact ⟨y, (mem_filter.1 hy).2, (mem_filter.1 hylines).2⟩ + +/-- Fixing a suffix and transporting the coordinates turns the relative density into the density +of the suffix pullback. -/ +lemma Subspace.relativeDensity_fixSuffixReindex {k m p q n : ℕ} (e : Fin p ⊕ Fin q ≃ Fin n) + (A : Finset (Fin n → Fin (k + 1))) (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin p)) + (y : Fin q → Fin (k + 1)) : + Subspace.relativeDensity (Subspace.fixSuffixReindex e V y) A = + (suffixPullback V (Subspace.splitWords e A) y).dens := by + rw [Subspace.relativeDensity, suffixPullback] + congr 1 + ext x + simp + +/-- Fixing a suffix and transporting the coordinates turns the complete lines into the suffix +lines. -/ +lemma Subspace.filter_fixSuffixReindex_eq_suffixLines {k m p q n : ℕ} + [Fintype (Combinatorics.Line (Fin k) (Fin m))] (e : Fin p ⊕ Fin q ≃ Fin n) + (A : Finset (Fin n → Fin (k + 1))) (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin p)) + (y : Fin q → Fin (k + 1)) : + (univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + ∀ a, Subspace.fixSuffixReindex e V y (Fin.castSucc ∘ l a) ∈ A) = + suffixLines V (Subspace.splitWords e A) y := by + ext l + simp [suffixLines] + +/-- The ambient dimension required by the many-lines lemma `exists_subspace_many_lines`: large +enough to make the fibers uniform above a subspace on which Graham--Rothschild canonizes the lines +of a parameter cube of dimension `max m (N + 1)`. -/ +noncomputable def manyLinesBound (k N m : ℕ) (δ : ℝ) : ℕ := + Subspace.variableCutFibersBound (k + 1) + (max 1 (GrahamRothschild.bound (k + 1) 2 (max m (N + 1)))) (Parameters.η k N δ ^ 2 / 2) /-- Either density has already increased on an `m`-subspace, or a dense slice contains a positive proportion of all parameter-cube lines. -/ -lemma exists_subspace_many_lines {k : ℕ} (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) - (m : ℕ) [Fintype (Combinatorics.Line (Fin k) (Fin m))] +lemma exists_subspace_many_lines {k : ℕ} (hk : 2 ≤ k) + {m : ℕ} [Fintype (Combinatorics.Line (Fin k) (Fin m))] [Nonempty (Combinatorics.Line (Fin k) (Fin m))] - (hm : 1 ≤ m) (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (n : ℕ) (hn : manyLinesBound k m δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) : + (hm : 1 ≤ m) {δ : ℝ} (hN : IsDHJDimension k (δ / 4) (N + 1)) (hδ₀ : 0 < δ) + (hδ₁ : δ ≤ 1) + {n : ℕ} (hn : manyLinesBound k N m δ ≤ n) + {A : Finset (Fin n → Fin (k + 1))} (hA : δ ≤ (A.dens : ℝ)) : (∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - δ + Parameters.η k δ ^ 2 / 2 ≤ (Subspace.relativeDensity V A : ℝ)) ∨ + δ + Parameters.η k N δ ^ 2 / 2 ≤ (Subspace.relativeDensity V A : ℝ)) ∨ ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - δ - 2 * Parameters.η k δ ≤ (Subspace.relativeDensity V A : ℝ) ∧ - Parameters.θ k δ / 2 ≤ - ((Finset.univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + δ - 2 * Parameters.η k N δ ≤ (Subspace.relativeDensity V A : ℝ) ∧ + Parameters.θ k N δ / 2 ≤ + ((univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ ∀ a, V (Fin.castSucc ∘ l a) ∈ A).dens : ℝ) := by classical - have hε₀ : 0 < Parameters.η k δ ^ 2 / 2 := by - positivity [Parameters.η_pos hk hδ₀] - obtain ⟨p, q, e, _hq, U, hU⟩ := - Subspace.variableCutFibersBound_spec (k + 1) (correlatedFibersLines k m δ) n - (le_max_left _ _) hε₀ (by simpa only [manyLinesBound, correlatedFibersBound] using hn) A - let A' := Subspace.splitWords e A - have hA' : δ ≤ (A'.dens : ℝ) := by - simpa only [A', Subspace.dens_splitWords] using hA - obtain ⟨W, hWfiber, hWlines⟩ := - exists_subspace_correlated_fibers hk hDHJ m hm δ hδ₀ hδ₁ - (ι := Fin p) (κ := Fin q) (M := correlatedFibersParameters k m δ) - (L := correlatedFibersLines k m δ) (le_max_left _ _) (le_max_right _ _) - (le_max_right _ _) A' hA' (fun _ ↦ ⟨U, fun x ↦ by - simpa only [A', Subspace.dens_splitWords] using hU x⟩) - obtain ⟨y, hy⟩ | ⟨y, hy, hylines⟩ := - exists_suffix_many_lines hk δ hδ₀ hδ₁ A' W hWfiber hWlines - · left - use Subspace.fixSuffixReindex e W y - rw [(Subspace.fixSuffixReindex_statistics e A W y).1] - simpa only [A', Subspace.splitWords] using hy - · right - refine ⟨Subspace.fixSuffixReindex e W y, ?_, ?_⟩ - · rw [(Subspace.fixSuffixReindex_statistics e A W y).1] - simpa only [A', Subspace.splitWords] using hy - · rw [(Subspace.fixSuffixReindex_statistics e A W y).2] - simpa only [A', Subspace.splitWords] using hylines + obtain ⟨p, q, e, -, U, hU⟩ := Subspace.variableCutFibersSufficient_of_le (le_max_left _ _) + (by positivity [Parameters.η_pos k N hδ₀]) hn A + obtain ⟨W, hWfiber, hWlines⟩ := exists_subspace_correlated_fibers hk hm hN hδ₀ hδ₁ + (M := max m (N + 1)) (le_max_left _ _) (le_max_right _ _) (le_max_right _ _) + (A := Subspace.splitWords e A) (U := U) fun x ↦ by linarith [hU x] + obtain ⟨y, hy⟩ | ⟨y, hy, hylines⟩ := exists_suffix_many_lines hδ₀ hδ₁ hWfiber hWlines + · exact .inl ⟨Subspace.fixSuffixReindex e W y, by + rwa [Subspace.relativeDensity_fixSuffixReindex]⟩ + · exact .inr ⟨Subspace.fixSuffixReindex e W y, by + rwa [Subspace.relativeDensity_fixSuffixReindex], by + rwa [Subspace.filter_fixSuffixReindex_eq_suffixLines]⟩ end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean index 95381329d3..f3c2b9b47a 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean @@ -5,205 +5,133 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers -import Mathlib.Tactic.Linarith +public import Mathlib.Basic.Real.Basic +import Mathlib.Data.Rat.Cast.Order +import Mathlib.Tactic.Linarith.Frontend +import Mathlib.Tactic.NormNum.Abs +import Mathlib.Tactic.NormNum.DivMod +import Mathlib.Tactic.NormNum.OfScientific +import Mathlib.Tactic.Positivity.Finset /-! # Numerical parameters of the density increment -The thresholds `θ`, `η`, and `γ` attached to an alphabet size and a density, together with their -monotonicity and positivity properties. +The thresholds `θ`, `η` and `γ` for `k` letters and density `δ`, and their monotonicity and +positivity. They also depend on a number `N`: the proof applies density Hales--Jewett over `k` +letters at density `δ / 4` in dimension `N + 1`. -/ @[expose] public section -open Finset -open Combinatorics -open scoped BigOperators - namespace DensityHalesJewett namespace Parameters -/-- A positive dimension selected from the density Hales--Jewett assertion when available. -/ -noncomputable def m₀ (k : ℕ) (δ : ℝ) : ℕ := by - classical - exact if h : 0 < δ ∧ HasDensityHJ k then - Nat.succ <| Nat.find <| h.2 (δ / 4) (by linarith) - else 1 - -lemma m₀_pos (k : ℕ) (δ : ℝ) : 0 < m₀ k δ := by - classical - unfold m₀ - split <;> simp - -/-- The selected dimension is antitone in the density threshold. -/ -lemma m₀_antitone {k : ℕ} (hDHJ : HasDensityHJ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : m₀ k ρ ≤ m₀ k δ := by - classical - rw [m₀, dite_eq_left ⟨hδ.trans_le hδρ, hDHJ⟩, m₀, dite_eq_left ⟨hδ, hDHJ⟩] - apply Nat.succ_le_succ - apply Nat.find_min' - intro n hn A hA - exact Nat.find_spec (hDHJ (δ / 4) (by linarith)) n hn A (le_trans (by gcongr) hA) - -/-- The denominator in the parameter definition grows with the selected dimension. -/ -lemma power_difference_mono (k : ℕ) {m n : ℕ} (hmn : m ≤ n) : - ((k + 1 : ℕ) : ℝ) ^ m - (k : ℝ) ^ m ≤ - ((k + 1 : ℕ) : ℝ) ^ n - (k : ℝ) ^ n := by - induction n, hmn using Nat.le_induction with - | base => rfl - | succ n _ ih => - rw [pow_succ, pow_succ] - apply ih.trans - rw [Nat.cast_add, Nat.cast_one] - suffices 0 ≤ (k : ℝ) * (((k + 1 : ℕ) : ℝ) ^ n - (k : ℝ) ^ n) by - rw [Nat.cast_add, Nat.cast_one] at this - nlinarith [pow_nonneg (by positivity : 0 ≤ (k : ℝ)) n] - apply mul_nonneg - · positivity - · apply sub_nonneg.mpr - apply pow_le_pow_left₀ - · positivity - · exact_mod_cast Nat.le_succ k - -/-- The denominator defining `θ` is positive for every admissible alphabet and density. -/ -lemma θ_denominator_pos {k : ℕ} (hk : 2 ≤ k) (δ : ℝ) : - 0 < ((k + 1 : ℕ) : ℝ) ^ m₀ k δ - (k : ℝ) ^ m₀ k δ := by - apply sub_pos.mpr - apply pow_lt_pow_left₀ - · exact_mod_cast Nat.lt_succ_self k - · positivity - · exact Nat.ne_of_gt <| m₀_pos k δ - -/-- The correlated-fibers threshold attached to an alphabet size and density. -/ -noncomputable def θ (k : ℕ) (δ : ℝ) : ℝ := - (δ / 4) / - (((k + 1 : ℕ) : ℝ) ^ m₀ k δ - (k : ℝ) ^ m₀ k δ) - -/-- The threshold is monotone in the density parameter. -/ -lemma θ_mono_of_dhj {k : ℕ} (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : θ k δ ≤ θ k ρ := by +/-- The denominator of `θ`, the number of lines in dimension `N + 1` over `k` letters, is +positive. -/ +lemma θ_denominator_pos (k N : ℕ) : 0 < (k + 1) ^ (N + 1) - k ^ (N + 1) := + Nat.sub_pos_of_lt (Nat.pow_lt_pow_left (lt_add_one k) N.succ_ne_zero) + +/-- The correlated-fibers threshold for `k` letters and density `δ`. -/ +noncomputable def θ (k N : ℕ) (δ : ℝ) : ℝ := + δ / 4 / ((k + 1) ^ (N + 1) - k ^ (N + 1) : ℕ) + +/-- The threshold is monotone in the density. -/ +lemma θ_mono (k N : ℕ) {δ ρ : ℝ} (hδρ : δ ≤ ρ) : θ k N δ ≤ θ k N ρ := by unfold θ - refine div_le_div₀ ?_ (by linarith) (θ_denominator_pos hk ρ) ?_ - · exact div_nonneg (hδ.trans_le hδρ).le (by norm_num) - · exact power_difference_mono k <| m₀_antitone hDHJ hδ hδρ - -/-- The threshold is monotone even when the density Hales--Jewett assertion is unavailable. -/ -lemma θ_mono {k : ℕ} (hk : 2 ≤ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : θ k δ ≤ θ k ρ := by - classical - by_cases hDHJ : HasDensityHJ k - · exact θ_mono_of_dhj hk hDHJ hδ hδρ - · unfold θ - rw [m₀, dite_eq_right (fun h ↦ hDHJ h.2), m₀, dite_eq_right (fun h ↦ hDHJ h.2)] - apply div_le_div_of_nonneg_right - · linarith - · rw [pow_one, pow_one, Nat.cast_add, Nat.cast_one] - linarith - -lemma θ_pos {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : 0 < θ k δ := by + exact div_le_div_of_nonneg_right (by linarith) (Nat.cast_nonneg _) + +lemma θ_pos (k N : ℕ) {δ : ℝ} (hδ : 0 < δ) : 0 < θ k N δ := by unfold θ - exact div_pos (by positivity) (θ_denominator_pos hk δ) + exact div_pos (by positivity) (Nat.cast_pos.2 (θ_denominator_pos k N)) -/-- The error tolerance attached to an alphabet size and density. -/ -noncomputable def η (k : ℕ) (δ : ℝ) : ℝ := - min (δ * θ k δ / 48) (min (θ k δ / 4) (δ / 6)) +/-- The error tolerance for `k` letters and density `δ`. -/ +noncomputable def η (k N : ℕ) (δ : ℝ) : ℝ := + min (δ * θ k N δ / 48) (min (θ k N δ / 4) (δ / 6)) -/-- The error tolerance is monotone in the density parameter. -/ -lemma η_mono {k : ℕ} (hk : 2 ≤ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : η k δ ≤ η k ρ := by +/-- The error tolerance is monotone in the density. -/ +lemma η_mono (k N : ℕ) {δ ρ : ℝ} (hδ : 0 < δ) (hδρ : δ ≤ ρ) : η k N δ ≤ η k N ρ := by unfold η refine min_le_min ?_ (min_le_min ?_ ?_) · apply div_le_div_of_nonneg_right - · exact mul_le_mul hδρ (θ_mono hk hδ hδρ) (θ_pos hk hδ).le - (hδ.trans_le hδρ).le + · exact mul_le_mul hδρ (θ_mono k N hδρ) (θ_pos k N hδ).le (hδ.trans_le hδρ).le · norm_num - · exact div_le_div_of_nonneg_right (θ_mono hk hδ hδρ) (by norm_num) + · exact div_le_div_of_nonneg_right (θ_mono k N hδρ) (by norm_num) · exact div_le_div_of_nonneg_right hδρ (by norm_num) -lemma η_pos {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : 0 < η k δ := by +lemma η_pos (k N : ℕ) {δ : ℝ} (hδ : 0 < δ) : 0 < η k N δ := by unfold η apply lt_min - · positivity [θ_pos hk hδ] + · positivity [θ_pos k N hδ] · apply lt_min - · positivity [θ_pos hk hδ] + · positivity [θ_pos k N hδ] · positivity -/-- The density increment attached to an alphabet size and density. -/ -noncomputable def γ (k : ℕ) (δ : ℝ) : ℝ := - min (δ * η k δ ^ 2 / k) (min (η k δ ^ 2 / 2) (3 * η k δ)) +/-- The density increment for `k` letters and density `δ`. -/ +noncomputable def γ (k N : ℕ) (δ : ℝ) : ℝ := + min (δ * η k N δ ^ 2 / k) (min (η k N δ ^ 2 / 2) (3 * η k N δ)) -/-- The increment is monotone in the density parameter. -/ -lemma γ_mono {k : ℕ} (hk : 2 ≤ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : γ k δ ≤ γ k ρ := by +/-- The increment is monotone in the density. -/ +lemma γ_mono (k N : ℕ) {δ ρ : ℝ} (hδ : 0 < δ) (hδρ : δ ≤ ρ) : γ k N δ ≤ γ k N ρ := by + have hη := η_mono k N hδ hδρ + have hηsq : η k N δ ^ 2 ≤ η k N ρ ^ 2 := pow_le_pow_left₀ (η_pos k N hδ).le hη 2 unfold γ refine min_le_min ?_ (min_le_min ?_ ?_) · apply div_le_div_of_nonneg_right - · apply mul_le_mul hδρ - · exact (sq_le_sq₀ (η_pos hk hδ).le - (η_pos hk (hδ.trans_le hδρ)).le).mpr (η_mono hk hδ hδρ) - · positivity - · exact (hδ.trans_le hδρ).le + · exact mul_le_mul hδρ hηsq (by positivity) (hδ.trans_le hδρ).le · positivity - · apply div_le_div_of_nonneg_right - · exact (sq_le_sq₀ (η_pos hk hδ).le - (η_pos hk (hδ.trans_le hδρ)).le).mpr (η_mono hk hδ hδρ) - · norm_num - · exact mul_le_mul_of_nonneg_left (η_mono hk hδ hδρ) (by norm_num) + · exact div_le_div_of_nonneg_right hηsq (by norm_num) + · exact mul_le_mul_of_nonneg_left hη (by norm_num) -lemma γ_pos {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : 0 < γ k δ := by +lemma γ_pos {k : ℕ} (hk : 2 ≤ k) (N : ℕ) {δ : ℝ} (hδ : 0 < δ) : 0 < γ k N δ := by + have hkpos : (0 : ℝ) < k := by exact_mod_cast (by omega : 0 < k) unfold γ - positivity [η_pos hk hδ] + positivity [η_pos k N hδ] -lemma η_lt_θ_div_two {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : - η k δ < θ k δ / 2 := by +lemma η_lt_θ_div_two (k N : ℕ) {δ : ℝ} (hδ : 0 < δ) : η k N δ < θ k N δ / 2 := by unfold η apply lt_of_le_of_lt ((min_le_right _ _).trans (min_le_left _ _)) - linarith [θ_pos hk hδ] + linarith [θ_pos k N hδ] -lemma η_le_δ_div_six (k : ℕ) (δ : ℝ) : η k δ ≤ δ / 6 := by +lemma η_le_δ_div_six (k N : ℕ) (δ : ℝ) : η k N δ ≤ δ / 6 := by unfold η exact (min_le_right _ _).trans (min_le_right _ _) -lemma γ_le_η_sq_div_two (k : ℕ) (δ : ℝ) : γ k δ ≤ η k δ ^ 2 / 2 := by +lemma γ_le_η_sq_div_two (k N : ℕ) (δ : ℝ) : γ k N δ ≤ η k N δ ^ 2 / 2 := by unfold γ exact (min_le_right _ _).trans (min_le_left _ _) -lemma γ_le_three_mul_η (k : ℕ) (δ : ℝ) : γ k δ ≤ 3 * η k δ := by +lemma γ_le_three_mul_η (k N : ℕ) (δ : ℝ) : γ k N δ ≤ 3 * η k N δ := by unfold γ exact (min_le_right _ _).trans (min_le_right _ _) -/-- The increment parameters can be chosen uniformly above a fixed positive density floor. -/ -lemma γ_mono_lowerBound {k : ℕ} (hk : 2 ≤ k) {δ₀ : ℝ} (hδ₀ : 0 < δ₀) : - 0 < γ k δ₀ ∧ ∀ ρ, δ₀ ≤ ρ → γ k δ₀ ≤ γ k ρ := by - constructor - · exact γ_pos hk hδ₀ - · intro ρ hδρ - exact γ_mono hk hδ₀ hδρ - /-- The correlated-fiber threshold is at most one in the admissible parameter range. -/ -lemma θ_le_one {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ₁ : δ ≤ 1) : - θ k δ ≤ 1 := by +lemma θ_le_one (k N : ℕ) {δ : ℝ} (hδ₁ : δ ≤ 1) : θ k N δ ≤ 1 := by unfold θ - have hden_pos : 0 < ((k + 1 : ℕ) : ℝ) ^ m₀ k δ - (k : ℝ) ^ m₀ k δ := - θ_denominator_pos hk δ - have h_one_le_diff : 1 ≤ ((k + 1 : ℕ) : ℝ) ^ m₀ k δ - (k : ℝ) ^ m₀ k δ := by - have h1 : ((k + 1 : ℕ) : ℝ) ^ 1 - (k : ℝ) ^ 1 = (1 : ℝ) := by norm_num - simpa [h1] using power_difference_mono k (Nat.succ_le_of_lt (m₀_pos k δ)) - apply (div_le_one hden_pos).mpr - linarith [hδ₁, h_one_le_diff] + rw [div_le_one (Nat.cast_pos.2 (θ_denominator_pos k N))] + exact (by linarith : δ / 4 ≤ 1).trans (Nat.one_le_cast.2 (θ_denominator_pos k N)) /-- The numerical parameters turn the absolute density left outside a large intersection into the required relative density gain. -/ -lemma large_intersection_complement_gain {k : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) : - (δ + 6 * η k δ) * (1 - θ k δ / 4) ≤ δ - 3 * η k δ := by - have hη : η k δ ≤ δ * θ k δ / 48 := - min_le_left (δ * θ k δ / 48) (min (θ k δ / 4) (δ / 6)) - nlinarith [hη, θ_pos hk hδ₀, η_pos hk hδ₀, - mul_nonneg hδ₀.le (θ_pos hk hδ₀).le, - mul_nonneg (η_pos hk hδ₀).le (θ_pos hk hδ₀).le] +lemma mul_one_sub_θ_div_four_le (k N : ℕ) {δ : ℝ} (hδ₀ : 0 < δ) : + (δ + 6 * η k N δ) * (1 - θ k N δ / 4) ≤ δ - 3 * η k N δ := by + have hη : η k N δ ≤ δ * θ k N δ / 48 := + min_le_left (δ * θ k N δ / 48) (min (θ k N δ / 4) (δ / 6)) + nlinarith [hη, θ_pos k N hδ₀, η_pos k N hδ₀, + mul_nonneg hδ₀.le (θ_pos k N hδ₀).le, + mul_nonneg (η_pos k N hδ₀).le (θ_pos k N hδ₀).le] + +/-- On a set of density at least `δ / 2`, the gain `6 * η` absorbs `k` increments `γ`. -/ +lemma add_γ_mul_add_mul_γ_le {k : ℕ} (hk : 0 < k) (N : ℕ) {δ c : ℝ} (hδ₀ : 0 < δ) + (hδ₁ : δ ≤ 1) (hc : δ / 2 ≤ c) : + (δ + γ k N δ) * c + k * γ k N δ ≤ (δ + 6 * η k N δ) * c := by + have hγ : k * γ k N δ ≤ δ * η k N δ ^ 2 := + (le_div_iff₀' (by positivity)).1 (min_le_left _ _) + have hη := η_le_δ_div_six k N δ + nlinarith [mul_nonneg (sub_nonneg.2 (γ_le_three_mul_η k N δ)) (by linarith : 0 ≤ c), + mul_le_mul_of_nonneg_left hc (η_pos k N hδ₀).le, + mul_le_mul_of_nonneg_left (hη.trans (by linarith) : η k N δ ≤ 1 / 6) + (mul_pos hδ₀ (η_pos k N hδ₀)).le] end Parameters diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean index 62da56ecf9..488c331daa 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean @@ -6,15 +6,18 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive import Mathlib.Algebra.BigOperators.Field -import Mathlib.Algebra.Order.Archimedean.Real.Basic +import Mathlib.Algebra.Order.Ring.Pow import Mathlib.Data.NNRat.BigOperators +import Mathlib.Algebra.Order.BigOperators.Expect /-! # Structured correlation with insensitive intersections Endpoint families turn many complete restricted-alphabet lines into a large intersection of -insensitive families, and the first-failure partition upgrades that intersection into a family +insensitive families. Its complement is partitioned into the pieces +`P_i = (C_i)ᶜ ∩ C_1 ∩ ⋯ ∩ C_(i-1)`, and one of them is an intersection of insensitive families correlated with the ambient word family. -/ @@ -26,31 +29,20 @@ open scoped BigOperators namespace DensityHalesJewett -/-- A power of the restricted-alphabet proportion eventually falls below the error tolerance. -/ -lemma exists_restrictedParameterWords_decay {k : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) : - ∃ m : ℕ, ((k : ℝ) / (k + 1)) ^ m < Parameters.η k δ := by - apply exists_pow_lt_of_lt_one (Parameters.η_pos hk hδ₀) - apply (div_lt_one (by positivity : 0 < (k + 1 : ℝ))).mpr - norm_num - -/-- A parameter-cube dimension sufficient for the insensitive-intersection construction. -/ -noncomputable def insensitiveIntersectionDimension (k : ℕ) (δ : ℝ) : ℕ := by - classical - exact if h : 2 ≤ k ∧ 0 < δ then - Nat.find (exists_restrictedParameterWords_decay h.1 h.2) - else 0 - -/-- Above the selected dimension, the restricted-alphabet proportion is at most the error -tolerance. -/ -lemma insensitiveIntersectionDimension_spec {k m : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) (hm : insensitiveIntersectionDimension k δ ≤ m) : - ((k : ℝ) / (k + 1)) ^ m ≤ Parameters.η k δ := by - classical - rw [insensitiveIntersectionDimension, dite_eq_left ⟨hk, hδ₀⟩] at hm - refine (pow_le_pow_of_le_one (by positivity) ?_ hm).trans ?_ - · exact (div_le_one (by positivity : 0 < (k + 1 : ℝ))).mpr (by norm_num) - · exact (Nat.find_spec (exists_restrictedParameterWords_decay hk hδ₀)).le +variable {N : ℕ} + +/-- `(k / (k + 1)) ^ m ≤ η` for every `m ≥ ⌈k / η⌉₊`, by Bernoulli's inequality +`(k / (k + 1)) ^ m ≤ k / (k + m)`. -/ +lemma div_add_one_pow_le {k m : ℕ} (hk : 0 < k) {η : ℝ} (hη : 0 < η) + (hm : ⌈(k : ℝ) / η⌉₊ ≤ m) : ((k : ℝ) / (k + 1)) ^ m ≤ η := by + have hk : (0 : ℝ) < k := mod_cast hk + rw [Nat.ceil_le, div_le_iff₀ hη] at hm + rw [(by field_simp : (k : ℝ) / (k + 1) = (1 + 1 / (k : ℝ))⁻¹), inv_pow, + inv_le_comm₀ (by positivity) hη] + refine le_trans ?_ (one_add_mul_le_pow (by linarith [one_div_pos.2 hk]) m) + rw [inv_le_iff_one_le_mul₀ hη] + field_simp + linarith [mul_pos hk hη] /-- Replace every occurrence of the final alphabet letter by a fixed restricted-alphabet letter. -/ @@ -63,38 +55,19 @@ def endpointFamily {k m n : ℕ} (A : Finset (Fin n → Fin (k + 1))) (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) (i : Fin k) : Finset (Fin m → Fin (k + 1)) := - Finset.univ.filter fun x ↦ V (replaceLastLetter i x) ∈ A + univ.filter fun x ↦ V (replaceLastLetter i x) ∈ A /-- Parameter words which avoid the final alphabet letter. -/ def restrictedParameterWords (k m : ℕ) : Finset (Fin m → Fin (k + 1)) := - Finset.univ.filter fun x ↦ ∀ c, x c ≠ Fin.last k + Fintype.piFinset fun _ ↦ {Fin.last k}ᶜ -/-- The restricted parameter words are exactly the pointwise images of `Fin k`-valued words. -/ -lemma restrictedParameterWords_eq_map (k m : ℕ) : - restrictedParameterWords k m = - Finset.univ.map (Function.Embedding.piCongrRight fun _ : Fin m ↦ - (Fin.castSuccEmb : Fin k ↪ Fin (k + 1))) := by - classical - ext x - simp only [restrictedParameterWords, Finset.mem_filter, Finset.mem_univ, true_and, - Finset.mem_map] - constructor - · intro hx - let y : Fin m → Fin k := fun c ↦ (x c).castPred (hx c) - refine ⟨y, ?_⟩ - funext c - exact Fin.castSucc_castPred (x c) (hx c) - · rintro ⟨y, rfl⟩ c - exact Fin.castSucc_ne_last (y c) +lemma card_restrictedParameterWords (k m : ℕ) : + (restrictedParameterWords k m).card = k ^ m := by + simp [restrictedParameterWords, card_compl] -/-- The density of restricted parameter words is the expected power of the alphabet ratio. -/ -lemma restrictedParameterWords_density (k m : ℕ) : +lemma dens_restrictedParameterWords (k m : ℕ) : ((restrictedParameterWords k m).dens : ℝ) = ((k : ℝ) / (k + 1)) ^ m := by - rw [restrictedParameterWords_eq_map, Finset.nnratCast_dens, Finset.card_map, - Finset.card_univ, Fintype.card_pi_const, Fintype.card_fin, - Fintype.card_pi_const, Fintype.card_fin] - rw [div_pow] - simp only [Nat.cast_pow, Nat.cast_add, Nat.cast_one] + simp [nnratCast_dens, card_restrictedParameterWords, div_pow] /-- Each endpoint family is insensitive to interchanging its selected letter with the final letter. -/ @@ -107,7 +80,7 @@ lemma endpointFamily_isInsensitive {k m n : ℕ} funext c by_cases hxi : x c = i.castSucc <;> by_cases hyi : y c = i.castSucc <;> grind [replaceLastLetter, hxy (x c), hxy (y c)] - simp only [endpointFamily, Finset.mem_filter, Finset.mem_univ, true_and] + simp only [endpointFamily, mem_filter, mem_univ, true_and] rw [hreplace] /-- Encode a restricted-alphabet line by the word using the final letter on its wildcard @@ -130,102 +103,57 @@ private lemma lineEndpoint_injective {k m : ℕ} : cases hfc : f c <;> cases hgc : g c <;> simp_all [lineEndpoint, Fin.castSucc_ne_last, eq_comm (a := Fin.last k)] -/-- Complete restricted-alphabet parameter lines inject into the intersection of the endpoint -families, giving the required density lower bound. -/ -lemma endpointFamily_intersection_dense {k m n : ℕ} (hk : 2 ≤ k) +private lemma replaceLastLetter_lineEndpoint {k m : ℕ} (i : Fin k) + (l : Combinatorics.Line (Fin k) (Fin m)) : + replaceLastLetter i (lineEndpoint l) = Fin.castSucc ∘ l i := by + funext c + cases hc : l.idxFun c <;> + simp [lineEndpoint, replaceLastLetter, Combinatorics.Line.coe_apply, hc, Fin.castSucc_ne_last] + +/-- Encoding lines by their endpoint words scales densities by the proportion of words using the +final letter. -/ +private lemma dens_map_lineEndpoint {k m : ℕ} (hk : 0 < k) [Fintype (Combinatorics.Line (Fin k) (Fin m))] - {δ : ℝ} (hδ₀ : 0 < δ) - (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) + (s : Finset (Combinatorics.Line (Fin k) (Fin m))) : + ((s.map ⟨lineEndpoint, lineEndpoint_injective⟩).dens : ℝ) = + s.dens * (1 - (restrictedParameterWords k m).dens) := by + rw [nnratCast_dens, card_map, ← nnratCast_dens_mul_natCast_card s, Subspace.card_line m hk, + Nat.cast_sub (Nat.pow_le_pow_left k.le_succ m), dens_restrictedParameterWords, div_pow] + simp only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow, Nat.cast_succ] + field_simp + +/-- The endpoint words of the restricted-alphabet lines whose points `V` maps into `A` lie in +every endpoint family, so many such lines give a dense intersection of endpoint families. -/ +lemma endpointFamily_intersection_dense {k m n : ℕ} (hk : 0 < k) + [Fintype (Combinatorics.Line (Fin k) (Fin m))] {θ : ℝ} + {A : Finset (Fin n → Fin (k + 1))} + {V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)} (hrestricted : ((restrictedParameterWords k m).dens : ℝ) ≤ 1 / 2) - (hlines : Parameters.θ k δ / 2 ≤ - ((Finset.univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + (hlines : θ / 2 ≤ + ((univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ ∀ a, V (Fin.castSucc ∘ l a) ∈ A).dens : ℝ)) : - Parameters.θ k δ / 4 ≤ - ((IsInsensitive.intersection (endpointFamily A V)).dens : ℝ) := by + θ / 4 ≤ ((IsInsensitive.intersection (endpointFamily A V)).dens : ℝ) := by classical - let good := Finset.univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + set s := univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ ∀ a, V (Fin.castSucc ∘ l a) ∈ A - let endpointEmbedding : - Combinatorics.Line (Fin k) (Fin m) ↪ (Fin m → Fin (k + 1)) := - ⟨lineEndpoint, lineEndpoint_injective⟩ - have hsubset : - good.map endpointEmbedding ⊆ IsInsensitive.intersection (endpointFamily A V) := by - intro x hx - obtain ⟨l, hl, rfl⟩ := Finset.mem_map.mp hx - apply IsInsensitive.mem_intersection.mpr - intro i - simp only [endpointFamily, Finset.mem_filter, Finset.mem_univ, true_and] - have hgood : - ∀ a, V (Fin.castSucc ∘ l a) ∈ A := by - simpa only [good, Finset.mem_filter, Finset.mem_univ, true_and] using hl - have heval : - replaceLastLetter i (lineEndpoint l) = Fin.castSucc ∘ l i := by - funext c - cases hc : l.idxFun c with - | none => - simp [lineEndpoint, replaceLastLetter, Combinatorics.Line.coe_apply, hc] - | some a => - simp [lineEndpoint, replaceLastLetter, Combinatorics.Line.coe_apply, hc, - Fin.castSucc_ne_last] - change V (replaceLastLetter i (lineEndpoint l)) ∈ A - rw [heval] - exact hgood i - have hmono : - ((good.map endpointEmbedding).dens : ℝ) ≤ - ((IsInsensitive.intersection (endpointFamily A V)).dens : ℝ) := by - exact_mod_cast Finset.dens_le_dens hsubset - refine (le_trans ?_ hmono) - have hgood : - Parameters.θ k δ / 2 ≤ (good.dens : ℝ) := by - simpa only [good] using hlines - have hlinepos : - 0 < (Fintype.card (Combinatorics.Line (Fin k) (Fin m)) : ℝ) := by - have hgoodpos : 0 < (good.dens : ℝ) := - (div_pos (Parameters.θ_pos hk hδ₀) (by norm_num)).trans_le hgood - have hgne : good.Nonempty := Finset.dens_pos.mp (by exact_mod_cast hgoodpos) - let : Nonempty (Combinatorics.Line (Fin k) (Fin m)) := ⟨hgne.choose⟩ - exact_mod_cast Fintype.card_pos - rw [Finset.nnratCast_dens, Finset.card_map] - rw [Finset.nnratCast_dens] at hgood hrestricted - have hlinecard : - (Fintype.card (Combinatorics.Line (Fin k) (Fin m)) : ℝ) = - ((k + 1 : ℕ) : ℝ) ^ m - (k : ℝ) ^ m := by - rw [Subspace.card_line k m (by omega), Nat.cast_sub] - · simp only [Nat.cast_pow, Nat.cast_add, Nat.cast_one] - · exact Nat.pow_le_pow_left (Nat.le_succ k) m - have hwordcard : - (Fintype.card (Fin m → Fin (k + 1)) : ℝ) = - ((k + 1 : ℕ) : ℝ) ^ m := by - simp only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow] - have hrestrictedcard : - (restrictedParameterWords k m).card = k ^ m := by - rw [restrictedParameterWords_eq_map, Finset.card_map, Finset.card_univ, - Fintype.card_pi_const, Fintype.card_fin] - rw [hlinecard] at hgood hlinepos - rw [hwordcard] at ⊢ - rw [hrestrictedcard, Nat.cast_pow, hwordcard] at hrestricted - have hwordpos : 0 < ((k + 1 : ℕ) : ℝ) ^ m := by positivity - have hhalf : - ((k + 1 : ℕ) : ℝ) ^ m / 2 ≤ - ((k + 1 : ℕ) : ℝ) ^ m - (k : ℝ) ^ m := by - apply (div_le_iff₀ hwordpos).mp at hrestricted - nlinarith - rw [le_div_iff₀ hlinepos] at hgood - rw [le_div_iff₀ hwordpos] - nlinarith [hhalf, hgood, Parameters.θ_pos hk hδ₀] + calc θ / 4 ≤ (s.dens : ℝ) * (1 - (restrictedParameterWords k m).dens) := by + nlinarith [(by positivity : (0 : ℝ) ≤ s.dens)] + _ = ((s.map ⟨lineEndpoint, lineEndpoint_injective⟩).dens : ℝ) := + (dens_map_lineEndpoint hk s).symm + _ ≤ _ := mod_cast dens_le_dens <| map_subset_iff_subset_preimage.2 fun l hl ↦ by + simpa [s, endpointFamily, replaceLastLetter_lineEndpoint] using hl /-- In a line-free ambient family, a word lying both in its pullback and in every endpoint family cannot use the final alphabet letter. -/ lemma pullback_inter_endpointFamily_subset_restricted {k m n : ℕ} - (A : Finset (Fin n → Fin (k + 1))) + {A : Finset (Fin n → Fin (k + 1))} (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) (hfree : IsLineFree A) : pullback V A ∩ IsInsensitive.intersection (endpointFamily A V) ⊆ restrictedParameterWords k m := by intro x hx - obtain ⟨hxpull, hxinter⟩ := Finset.mem_inter.mp hx - simp only [restrictedParameterWords, Finset.mem_filter, Finset.mem_univ, true_and] + obtain ⟨hxpull, hxinter⟩ := mem_inter.mp hx + simp only [restrictedParameterWords, Fintype.mem_piFinset, mem_compl, mem_singleton] intro c hc let p : Combinatorics.Line (Fin (k + 1)) (Fin m) := { idxFun := fun i ↦ if x i = Fin.last k then none else some (x i) @@ -233,65 +161,46 @@ lemma pullback_inter_endpointFamily_subset_restricted {k m n : ℕ} } have hp_last : p (Fin.last k) = x := by funext i - by_cases hi : x i = Fin.last k <;> - simp only [p, Combinatorics.Line.coe_apply, hi, ↓reduceIte, Option.getD_none, - Option.getD_some] + by_cases hi : x i = Fin.last k <;> simp [p, Combinatorics.Line.coe_apply, hi] have hp_cast (i : Fin k) : p i.castSucc = replaceLastLetter i x := by funext j - by_cases hj : x j = Fin.last k <;> - simp only [p, replaceLastLetter, Combinatorics.Line.coe_apply, hj, ↓reduceIte, - Option.getD_none, Option.getD_some] + by_cases hj : x j = Fin.last k <;> simp [p, replaceLastLetter, Combinatorics.Line.coe_apply, hj] obtain ⟨a, ha⟩ := hfree (Subspace.composeLine V p) apply ha rw [Subspace.composeLine_apply] obtain ⟨i, rfl⟩ | rfl := Fin.eq_castSucc_or_eq_last a · rw [hp_cast] - have hi := IsInsensitive.mem_intersection.mp hxinter i - simpa only [endpointFamily, Finset.mem_filter, Finset.mem_univ, true_and] using hi + simpa [endpointFamily] using IsInsensitive.mem_intersection.mp hxinter i · rw [hp_last] - simpa only [pullback, parameterPreimage, Finset.mem_filter, - Finset.mem_univ, true_and] using hxpull - -/-- In a sufficiently large parameter cube, words avoiding the final letter have density at most -`η`. -/ -lemma restrictedParameterWords_density_le_eta {k m : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) - (hm_large : insensitiveIntersectionDimension k δ ≤ m) : - ((restrictedParameterWords k m).dens : ℝ) ≤ Parameters.η k δ := by - rw [restrictedParameterWords_density] - exact insensitiveIntersectionDimension_spec hk hδ₀ hm_large + simpa [pullback, parameterPreimage] using hxpull /-- Many complete restricted-alphabet lines yield a large insensitive intersection whose part -inside a line-free family is small. This packages the endpoint construction, its injective -line count, the identification of the intersection, and the geometric-decay estimate. -/ +inside a line-free family is small. -/ lemma exists_endpoint_insensitive_intersection {k m n : ℕ} (hk : 2 ≤ k) - [Fintype (Combinatorics.Line (Fin k) (Fin m))] - (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hm_large : insensitiveIntersectionDimension k δ ≤ m) - (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) + [Fintype (Combinatorics.Line (Fin k) (Fin m))] {δ : ℝ} (hδ₁ : δ ≤ 1) + (hm_large : ((k : ℝ) / (k + 1)) ^ m ≤ Parameters.η k N δ) + {A : Finset (Fin n → Fin (k + 1))} + {V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)} (hfree : IsLineFree A) - (hlines : Parameters.θ k δ / 2 ≤ - ((Finset.univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + (hlines : Parameters.θ k N δ / 2 ≤ + ((univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ ∀ a, V (Fin.castSucc ∘ l a) ∈ A).dens : ℝ)) : ∃ C : Fin k → Finset (Fin m → Fin (k + 1)), (∀ i, IsInsensitive i.castSucc (Fin.last k) (C i)) ∧ - Parameters.θ k δ / 4 ≤ ((IsInsensitive.intersection C).dens : ℝ) ∧ + Parameters.θ k N δ / 4 ≤ ((IsInsensitive.intersection C).dens : ℝ) ∧ ((pullback V A ∩ IsInsensitive.intersection C).dens : ℝ) ≤ - Parameters.η k δ := by + Parameters.η k N δ := by + rw [← dens_restrictedParameterWords] at hm_large refine ⟨endpointFamily A V, endpointFamily_isInsensitive A V, ?_, ?_⟩ - · refine endpointFamily_intersection_dense hk hδ₀ A V ?_ hlines - apply (restrictedParameterWords_density_le_eta hk hδ₀ hm_large).trans - exact (Parameters.η_le_δ_div_six k δ).trans (by linarith) - · refine le_trans ?_ <| - restrictedParameterWords_density_le_eta hk hδ₀ hm_large - exact_mod_cast Finset.dens_mono <| - pullback_inter_endpointFamily_subset_restricted A V hfree + · refine endpointFamily_intersection_dense (by omega) ?_ hlines + linarith [Parameters.η_le_δ_div_six k N δ] + · exact le_trans (mod_cast dens_mono <| + pullback_inter_endpointFamily_subset_restricted V hfree) hm_large /-- Removing an intersection of density at least `θ / 4`, while losing at most `η` of a family of density `δ - 2η`, gives the two complement estimates used below. -/ lemma density_complement_bounds {X : Type*} [Fintype X] [Nonempty X] - [DecidableEq X] (A C : Finset X) (δ η θ : ℝ) + [DecidableEq X] {A C : Finset X} {δ η θ : ℝ} (hδ₀ : 0 ≤ δ) (hη₀ : 0 ≤ η) (hA : δ - 2 * η ≤ (A.dens : ℝ)) (hC : θ / 4 ≤ (C.dens : ℝ)) (hAC : ((A ∩ C).dens : ℝ) ≤ η) @@ -300,355 +209,170 @@ lemma density_complement_bounds {X : Type*} [Fintype X] [Nonempty X] δ - 3 * η ≤ ((A ∩ Cᶜ).dens : ℝ) := by have hsplitA : ((A ∩ C).dens : ℝ) + ((A ∩ Cᶜ).dens : ℝ) = (A.dens : ℝ) := by norm_cast - simpa only [sdiff_eq_inter_compl] using Finset.dens_inter_add_dens_sdiff A C + simpa [sdiff_eq_inter_compl] using dens_inter_add_dens_sdiff A C have hsplitC : ((Cᶜ).dens : ℝ) + (C.dens : ℝ) = 1 := by norm_cast - simpa only [← compl_eq_univ_sdiff, Finset.dens_univ] using - Finset.dens_sdiff_add_dens_eq_dens C.subset_univ - have houtside : δ - 3 * η ≤ ((A ∩ Cᶜ).dens : ℝ) := by - linarith [hsplitA, hA, hAC] - constructor - · refine (mul_le_mul_of_nonneg_left ?_ ?_).trans (hgain.trans houtside) - · linarith [hsplitC, hC] - · linarith [hδ₀, hη₀] - · exact houtside - -/-- An intersection of insensitive families with a density gain on its complement. -/ -lemma exists_large_insensitive_intersection {k : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) (m n : ℕ) (hm : 1 ≤ m) - [Nonempty (Combinatorics.Line (Fin k) (Fin m))] - (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hm_large : insensitiveIntersectionDimension k δ ≤ m) - (hn : manyLinesBound k m δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) - (hfree : IsLineFree A) - (hsmall : ∀ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - (Subspace.relativeDensity V A : ℝ) < δ + Parameters.η k δ ^ 2 / 2) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - ∃ C : Fin k → Finset (Fin m → Fin (k + 1)), - (∀ i, IsInsensitive i.castSucc (Fin.last k) (C i)) ∧ - (δ + 6 * Parameters.η k δ) * - ((IsInsensitive.intersection C)ᶜ.dens : ℝ) ≤ - ((pullback V A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) ∧ - δ - 3 * Parameters.η k δ ≤ - ((pullback V A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) := by - classical - let : Fintype (Combinatorics.Line (Fin k) (Fin m)) := - Fintype.ofInjective (fun l ↦ l.idxFun) fun _ _ h ↦ Combinatorics.Line.ext h - obtain ⟨V, hV⟩ | ⟨V, hV, hlines⟩ := - exists_subspace_many_lines hk hDHJ m hm δ hδ₀ hδ₁ n hn A hA - · exact ((not_lt_of_ge hV) (hsmall V)).elim - obtain ⟨C, hC, hCdense, hAC⟩ := - exists_endpoint_insensitive_intersection hk δ hδ₀ hδ₁ hm_large A V hfree hlines - refine ⟨V, C, hC, ?_⟩ - apply density_complement_bounds - · exact hδ₀.le - · exact (Parameters.η_pos hk hδ₀).le - · simpa only [dens_pullback] using hV - · exact hCdense - · exact hAC - · exact Parameters.large_intersection_complement_gain hk hδ₀ - -/-- The part of the complement of an indexed intersection at which membership first fails. -/ -def firstFailurePiece {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + simpa [← compl_eq_univ_sdiff] using dens_sdiff_add_dens_eq_dens C.subset_univ + exact ⟨(mul_le_mul_of_nonneg_left (by linarith) (by linarith)).trans + (hgain.trans (by linarith)), by linarith⟩ + +/-- The piece `P_i = (C_i)ᶜ ∩ C_1 ∩ ⋯ ∩ C_(i-1)` of the partition of the complement of +`C_1 ∩ ⋯ ∩ C_k`. -/ +def complPiece {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (C : Fin k → Finset X) (i : Fin k) : Finset X := - (C i)ᶜ ∩ Finset.univ.filter fun x ↦ ∀ j, j < i → x ∈ C j + univ.filter fun x ↦ x ∉ C i ∧ ∀ j < i, x ∈ C j + +@[simp] +lemma mem_complPiece {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + {C : Fin k → Finset X} {i : Fin k} {x : X} : + x ∈ complPiece C i ↔ x ∉ C i ∧ ∀ j < i, x ∈ C j := by + simp [complPiece] -/-- Replace the first failed set by its complement, retain the preceding sets, and make all -subsequent constraints vacuous. -/ -def firstFailureFamily {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] +/-- The family `D` with `D_j = C_j` for `j < i`, `D_i = (C_i)ᶜ` and `D_j = univ` for `j > i`, whose +intersection is the piece `P_i`. -/ +def complPieceFamily {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (C : Fin k → Finset X) (i : Fin k) : Fin k → Finset X := - fun j ↦ if j < i then C j else if j = i then (C j)ᶜ else Finset.univ + fun j ↦ if j < i then C j else if j = i then (C j)ᶜ else univ -/-- Every member of the first-failure family has the required sensitivity pair. -/ -lemma firstFailureFamily_isInsensitive {k : ℕ} {ι : Type*} +/-- Every member of the family has the required sensitivity pair. -/ +lemma complPieceFamily_isInsensitive {k : ℕ} {ι : Type*} [Fintype (ι → Fin (k + 1))] [DecidableEq (ι → Fin (k + 1))] - (C : Fin k → Finset (ι → Fin (k + 1))) - (hC : ∀ i, IsInsensitive i.castSucc (Fin.last k) (C i)) (i : Fin k) : - ∀ j, IsInsensitive j.castSucc (Fin.last k) (firstFailureFamily C i j) := by - intro j - dsimp [firstFailureFamily] - by_cases hij : j < i - · simp [hij, hC j] - · by_cases hej : j = i - · rw [hej] - simpa using (hC i).compl - · simp [hij, hej, IsInsensitive] - -/-- Intersecting the first-failure family recovers its selected piece. -/ -lemma firstFailureFamily_intersection {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + {C : Fin k → Finset (ι → Fin (k + 1))} + (hC : ∀ i, IsInsensitive i.castSucc (Fin.last k) (C i)) (i j : Fin k) : + IsInsensitive j.castSucc (Fin.last k) (complPieceFamily C i j) := by + unfold complPieceFamily + split_ifs + · exact hC j + · exact (hC j).compl + · simp [IsInsensitive] + +/-- The intersection of the family is the piece `P_i`. -/ +lemma complPieceFamily_intersection {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (C : Fin k → Finset X) (i : Fin k) : - IsInsensitive.intersection (firstFailureFamily C i) = firstFailurePiece C i := by + IsInsensitive.intersection (complPieceFamily C i) = complPiece C i := by ext x - simp only [IsInsensitive.mem_intersection, firstFailureFamily, firstFailurePiece, - Finset.mem_inter, Finset.mem_compl, Finset.mem_filter, Finset.mem_univ, true_and] - constructor - · intro hx - constructor - · have hxi := hx i - simp only [lt_self_iff_false, ↓reduceIte, Finset.mem_compl] at hxi - exact hxi - · intro j hij - simpa only [ite_eq_left hij] using hx j - · rintro ⟨hnot, hbefore⟩ j - by_cases hij : j < i - · simpa only [ite_eq_left hij] using hbefore j hij - · by_cases hji : j = i - · subst j - simpa only [lt_self_iff_false, ↓reduceIte, Finset.mem_compl] using hnot - · simp only [ite_eq_right hij, ite_eq_right hji, Finset.mem_univ] - -/-- The first-failure pieces cover the complement of the original intersection. -/ -lemma firstFailurePiece_biUnion {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + simp only [IsInsensitive.mem_intersection, mem_complPiece, complPieceFamily] + refine ⟨fun h ↦ ⟨by simpa using h i, fun j hj ↦ by simpa [hj] using h j⟩, ?_⟩ + rintro ⟨hi, hlt⟩ j + obtain hj | rfl | hj := lt_trichotomy j i + · simpa [hj] using hlt j hj + · simpa + · simp [hj.not_gt, hj.ne'] + +/-- The pieces cover the complement of the intersection. -/ +lemma complPiece_biUnion {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (C : Fin k → Finset X) : - Finset.univ.biUnion (firstFailurePiece C) = (IsInsensitive.intersection C)ᶜ := by - classical + univ.biUnion (complPiece C) = (IsInsensitive.intersection C)ᶜ := by ext x - constructor - · intro hx - rw [Finset.mem_biUnion] at hx - obtain ⟨i, _, hi⟩ := hx - rw [firstFailurePiece, Finset.mem_inter, Finset.mem_compl] at hi - rw [Finset.mem_compl] - intro hinter - exact hi.1 (IsInsensitive.mem_intersection.mp hinter i) - · rw [Finset.mem_compl] - intro hx - have hfailed : ∃ i, x ∉ C i := by - by_contra! h - exact hx <| IsInsensitive.mem_intersection.mpr h - let I := Finset.univ.filter fun i : Fin k ↦ x ∉ C i - have hI : I.Nonempty := by - obtain ⟨i, hi⟩ := hfailed - exact ⟨i, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hi⟩⟩ - let i := I.min' hI - rw [Finset.mem_biUnion] - refine ⟨i, Finset.mem_univ _, ?_⟩ - rw [firstFailurePiece, Finset.mem_inter, Finset.mem_compl] - constructor - · exact (Finset.mem_filter.mp (I.min'_mem hI)).2 - · simp only [Finset.mem_filter, Finset.mem_univ, true_and] - intro j hij - by_contra hj - have hjI : j ∈ I := Finset.mem_filter.mpr ⟨Finset.mem_univ _, hj⟩ - exact (not_lt_of_ge (I.min'_le j hjI)) hij - -/-- A first-failure piece is disjoint from every piece at a later index. -/ -lemma firstFailurePiece_disjoint_of_lt {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] - (C : Fin k → Finset X) {i j : Fin k} (hij : i < j) : - Disjoint (firstFailurePiece C i : Set X) (firstFailurePiece C j : Set X) := by - dsimp only [Disjoint] - intro x hxi hxj - simp only [firstFailurePiece, coe_inter, coe_compl, coe_filter, mem_univ, true_and, - Set.subset_inter_iff] at * - simp only [Set.bot_eq_empty, Set.subset_empty_iff] - apply Set.eq_empty_of_forall_notMem - intro y hy - exact (hxi.1 hy) (hxj.2 hy i hij) - -/-- Distinct first-failure pieces are pairwise disjoint. -/ -lemma firstFailurePiece_pairwiseDisjoint {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + simp only [mem_biUnion, mem_univ, true_and, mem_complPiece, mem_compl, + IsInsensitive.mem_intersection, not_forall] + refine ⟨fun ⟨i, hi, _⟩ ↦ ⟨i, hi⟩, ?_⟩ + rintro ⟨j, hj⟩ + obtain ⟨i, hi, hmin⟩ := wellFounded_lt.has_min {i | x ∉ C i} ⟨j, hj⟩ + exact ⟨i, hi, fun j hji ↦ not_not.1 fun hj ↦ hmin j hj hji⟩ + +/-- Distinct pieces are disjoint. -/ +lemma complPiece_pairwiseDisjoint {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (C : Fin k → Finset X) : - (Set.univ : Set (Fin k)).PairwiseDisjoint fun i ↦ (firstFailurePiece C i : Set X) := by + ((univ : Finset (Fin k)) : Set (Fin k)).PairwiseDisjoint (complPiece C) := by intro i _ j _ hij - obtain hij | hji := lt_or_gt_of_ne hij - · exact firstFailurePiece_disjoint_of_lt C hij - · exact (firstFailurePiece_disjoint_of_lt C hji).symm + rw [Function.onFun, disjoint_left] + intro x hxi hxj + rw [mem_complPiece] at hxi hxj + obtain hij | hji := hij.lt_or_gt + · exact hxi.1 (hxj.2 i hij) + · exact hxj.1 (hxi.2 j hji) -/-- The first-failure partition converts the densities of its pieces, and of their intersections -with `A`, into sums. -/ -lemma firstFailurePiece_density_sums {k : ℕ} - {X : Type*} [Fintype X] [DecidableEq X] +/-- The pieces split the part of `A` outside the intersection. -/ +lemma sum_dens_inter_complPiece {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] (A : Finset X) (C : Fin k → Finset X) : - (∑ i, ((firstFailurePiece C i).dens : ℝ)) = - (((IsInsensitive.intersection C)ᶜ).dens : ℝ) ∧ - (∑ i, ((A ∩ firstFailurePiece C i).dens : ℝ)) = - ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) := by - constructor - · have h := Finset.dens_biUnion (s := Finset.univ) (t := firstFailurePiece C) <| - Finset.pairwiseDisjoint_coe.mp <| by - simpa only [Finset.coe_univ] using firstFailurePiece_pairwiseDisjoint C - rw [firstFailurePiece_biUnion] at h - rw [← NNRat.cast_sum] - exact congrArg (fun q : ℚ≥0 ↦ (q : ℝ)) h.symm - · have hpairwise : - (Set.univ : Set (Fin k)).PairwiseDisjoint fun i ↦ - (A ∩ firstFailurePiece C i : Set X) := - (firstFailurePiece_pairwiseDisjoint C).mono_on fun _ _ ↦ - Set.inter_subset_right - have h := Finset.dens_biUnion (s := Finset.univ) - (t := fun i ↦ A ∩ firstFailurePiece C i) <| - Finset.pairwiseDisjoint_coe.mp <| by - simpa only [Finset.coe_univ, Finset.coe_inter] using hpairwise - rw [← Finset.inter_biUnion, firstFailurePiece_biUnion] at h - rw [← NNRat.cast_sum] - exact congrArg (fun q : ℚ≥0 ↦ (q : ℝ)) h.symm - -/-- The quantitative hypotheses and the first-failure density sums force one piece to be both -large and relatively dense in `A`. -/ -lemma exists_dense_firstFailurePiece_of_density_sums {k : ℕ} (hk : 2 ≤ k) - {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - {X : Type*} [Fintype X] [DecidableEq X] - (A : Finset X) (C : Fin k → Finset X) - (hweighted : (δ + 6 * Parameters.η k δ) * - ((IsInsensitive.intersection C)ᶜ.dens : ℝ) ≤ - ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) - (hlarge : δ - 3 * Parameters.η k δ ≤ - ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) - (hsumPieces : (∑ i, ((firstFailurePiece C i).dens : ℝ)) = - (((IsInsensitive.intersection C)ᶜ).dens : ℝ)) - (hsumIntersections : (∑ i, ((A ∩ firstFailurePiece C i).dens : ℝ)) = - ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) : - ∃ i : Fin k, - Parameters.γ k δ ≤ ((firstFailurePiece C i).dens : ℝ) ∧ - (δ + Parameters.γ k δ) * ((firstFailurePiece C i).dens : ℝ) ≤ - ((A ∩ firstFailurePiece C i).dens : ℝ) := by - by_contra! h - let g := Parameters.γ k δ - let e := Parameters.η k δ - let c := (((IsInsensitive.intersection C)ᶜ).dens : ℝ) - let a := ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) - let : Nonempty (Fin k) := ⟨⟨0, lt_of_lt_of_le Nat.zero_lt_two hk⟩⟩ - have hg₀ : 0 < g := Parameters.γ_pos hk hδ₀ - have he₀ : 0 < e := Parameters.η_pos hk hδ₀ - have hsum_lt : - ∑ i, ((A ∩ firstFailurePiece C i).dens : ℝ) < - ∑ i, ((δ + g) * ((firstFailurePiece C i).dens : ℝ) + g) := by - apply Finset.sum_lt_sum_of_nonempty Finset.univ_nonempty - intro i _ - by_cases hi : g ≤ ((firstFailurePiece C i).dens : ℝ) - · linarith [h i (by simpa only [g] using hi)] - · have hinter : - ((A ∩ firstFailurePiece C i).dens : ℝ) ≤ ((firstFailurePiece C i).dens : ℝ) := by - exact_mod_cast Finset.dens_le_dens Finset.inter_subset_right - have hcoefficient : 0 ≤ δ + g := by linarith - nlinarith [mul_nonneg hcoefficient - (by positivity : 0 ≤ ((firstFailurePiece C i).dens : ℝ))] - have hupper : a < (δ + g) * c + (k : ℝ) * g := by - rw [Finset.sum_add_distrib, ← Finset.mul_sum] at hsum_lt - simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, - nsmul_eq_mul] at hsum_lt - rwa [hsumPieces, hsumIntersections] at hsum_lt - have hac : a ≤ c := by - dsimp only [a, c] - exact_mod_cast Finset.dens_le_dens Finset.inter_subset_right - have hc : δ / 2 ≤ c := by - dsimp only [a, c] at hlarge hac - linarith [Parameters.η_le_δ_div_six k δ] - have hcoef : 3 * e ≤ 6 * e - g := by - dsimp only [e, g] - linarith [Parameters.γ_le_three_mul_η k δ] - have hleft : - 3 * e * (δ / 2) ≤ (6 * e - g) * c := - mul_le_mul hcoef hc (by positivity) (by linarith) - have hk_real : 0 < (k : ℝ) := by exact_mod_cast lt_of_lt_of_le Nat.zero_lt_two hk - have hright : (k : ℝ) * g ≤ δ * e ^ 2 := by - have hdiv : g ≤ δ * e ^ 2 / (k : ℝ) := by - dsimp only [g, e] - unfold Parameters.γ - exact min_le_left _ _ - simpa only [mul_comm] using (le_div_iff₀ hk_real).mp hdiv - have hstrict : δ * e ^ 2 < 3 * e * (δ / 2) := by - dsimp only [e] - nlinarith [Parameters.η_le_δ_div_six k δ] - have hgap : (6 * e - g) * c < (k : ℝ) * g := by - dsimp only [a, c, e, g] at hweighted hupper - nlinarith - exact (not_lt_of_ge hleft) (hgap.trans_le hright |>.trans hstrict) - -/-- The first-failure partition and its quantitative weighted averaging. - -The complement of `intersection C` is partitioned by `firstFailurePiece C i`. The two global -density estimates ensure that one piece is both large enough and has the required relative -`A`-density. -/ -lemma exists_dense_firstFailurePiece {k : ℕ} (hk : 2 ≤ k) + ∑ i, ((A ∩ complPiece C i).dens : ℝ) = + ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) := by + rw [← complPiece_biUnion, inter_biUnion, + dens_biUnion ((complPiece_pairwiseDisjoint C).mono fun _ ↦ inter_subset_right), + NNRat.cast_sum] + +/-- The pieces partition the complement of the intersection. -/ +lemma sum_dens_complPiece {k : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + (C : Fin k → Finset X) : + ∑ i, ((complPiece C i).dens : ℝ) = ((IsInsensitive.intersection C)ᶜ.dens : ℝ) := by + simpa using sum_dens_inter_complPiece univ C + +/-- If `a ≤ c` pointwise and `ε * ∑ i, c i + card ι * γ ≤ ∑ i, a i`, then some `i` has +`γ ≤ c i` and `ε * c i ≤ a i`. -/ +lemma exists_le_and_mul_le_of_sum_le {ι : Type*} [Fintype ι] [Nonempty ι] {a c : ι → ℝ} + {ε γ : ℝ} (hε : 0 ≤ ε) (hγ : 0 ≤ γ) (hc : ∀ i, 0 ≤ c i) (hac : ∀ i, a i ≤ c i) + (h : ε * ∑ i, c i + Fintype.card ι * γ ≤ ∑ i, a i) : + ∃ i, γ ≤ c i ∧ ε * c i ≤ a i := by + by_contra! hlt + have hlt' (i : ι) : a i < ε * c i + γ := by + by_cases hi : γ ≤ c i + · linarith [hlt i hi] + · nlinarith [hac i, mul_nonneg hε (hc i)] + have hsum := sum_lt_sum_of_nonempty univ_nonempty fun i _ ↦ hlt' i + simp only [sum_add_distrib, ← mul_sum, sum_const, card_univ, nsmul_eq_mul] at hsum + linarith + +/-- Two global density estimates on the complement of `intersection C` make one piece +both large and relatively dense in `A`. -/ +lemma exists_dense_complPiece {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) {X : Type*} [Fintype X] [DecidableEq X] - (A : Finset X) (C : Fin k → Finset X) - (hweighted : (δ + 6 * Parameters.η k δ) * + {A : Finset X} {C : Fin k → Finset X} + (hweighted : (δ + 6 * Parameters.η k N δ) * ((IsInsensitive.intersection C)ᶜ.dens : ℝ) ≤ ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) - (hlarge : δ - 3 * Parameters.η k δ ≤ + (hlarge : δ - 3 * Parameters.η k N δ ≤ ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) : ∃ i : Fin k, - Parameters.γ k δ ≤ ((firstFailurePiece C i).dens : ℝ) ∧ - (δ + Parameters.γ k δ) * ((firstFailurePiece C i).dens : ℝ) ≤ - ((A ∩ firstFailurePiece C i).dens : ℝ) := by - obtain ⟨hsumPieces, hsumIntersections⟩ := - firstFailurePiece_density_sums A C - exact exists_dense_firstFailurePiece_of_density_sums hk hδ₀ hδ₁ A C hweighted - hlarge hsumPieces hsumIntersections - -/-- The Boolean reconstruction of a first-failure piece as an insensitive intersection. - -Complement closure preserves the sensitivity pair at the failure index, while the universal -sets after that index impose no constraints. -/ -lemma firstFailureFamily_facts {k : ℕ} {ι : Type*} - [Fintype (ι → Fin (k + 1))] [DecidableEq (ι → Fin (k + 1))] - (C : Fin k → Finset (ι → Fin (k + 1))) - (hC : ∀ i, IsInsensitive i.castSucc (Fin.last k) (C i)) (i : Fin k) : - (∀ j, IsInsensitive j.castSucc (Fin.last k) (firstFailureFamily C i j)) ∧ - IsInsensitive.intersection (firstFailureFamily C i) = firstFailurePiece C i ∧ - Finset.univ.biUnion (firstFailurePiece C) = (IsInsensitive.intersection C)ᶜ ∧ - (Set.univ : Set (Fin k)).PairwiseDisjoint fun j ↦ - (firstFailurePiece C j : Set (ι → Fin (k + 1))) := - ⟨firstFailureFamily_isInsensitive C hC i, - firstFailureFamily_intersection C i, firstFailurePiece_biUnion C, - firstFailurePiece_pairwiseDisjoint C⟩ + Parameters.γ k N δ ≤ ((complPiece C i).dens : ℝ) ∧ + (δ + Parameters.γ k N δ) * ((complPiece C i).dens : ℝ) ≤ + ((A ∩ complPiece C i).dens : ℝ) := by + have : Nonempty (Fin k) := ⟨⟨0, by omega⟩⟩ + have hc : ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ) ≤ + ((IsInsensitive.intersection C)ᶜ.dens : ℝ) := mod_cast dens_le_dens inter_subset_right + have hγ := Parameters.γ_pos hk N hδ₀ + refine exists_le_and_mul_le_of_sum_le (by positivity) hγ.le (fun _ ↦ by positivity) + (fun _ ↦ mod_cast dens_le_dens inter_subset_right) ?_ + rw [sum_dens_inter_complPiece, sum_dens_complPiece, Fintype.card_fin] + linarith [Parameters.add_γ_mul_add_mul_γ_le (by omega : 0 < k) N hδ₀ hδ₁ + (c := ((IsInsensitive.intersection C)ᶜ.dens : ℝ)) + (by linarith [Parameters.η_le_δ_div_six k N δ])] /-- Correlation with a positive-density intersection of insensitive families. -/ lemma exists_structured_correlation {k : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) (m n : ℕ) (hm : 1 ≤ m) + {m n : ℕ} (hm : 1 ≤ m) [Nonempty (Combinatorics.Line (Fin k) (Fin m))] - (δ : ℝ) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hm_large : insensitiveIntersectionDimension k δ ≤ m) - (hn : manyLinesBound k m δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) + {δ : ℝ} (hN : IsDHJDimension k (δ / 4) (N + 1)) (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) + (hm_large : ((k : ℝ) / (k + 1)) ^ m ≤ Parameters.η k N δ) + (hn : manyLinesBound k N m δ ≤ n) + {A : Finset (Fin n → Fin (k + 1))} (hA : δ ≤ (A.dens : ℝ)) (hfree : IsLineFree A) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), ∃ D : Fin k → Finset (Fin m → Fin (k + 1)), (∀ i, IsInsensitive i.castSucc (Fin.last k) (D i)) ∧ - Parameters.γ k δ ≤ ((IsInsensitive.intersection D).dens : ℝ) ∧ - (δ + Parameters.γ k δ) * ((IsInsensitive.intersection D).dens : ℝ) ≤ + Parameters.γ k N δ ≤ ((IsInsensitive.intersection D).dens : ℝ) ∧ + (δ + Parameters.γ k N δ) * ((IsInsensitive.intersection D).dens : ℝ) ≤ ((pullback V A ∩ IsInsensitive.intersection D).dens : ℝ) := by classical - by_cases hlarge : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - δ + Parameters.η k δ ^ 2 / 2 ≤ (Subspace.relativeDensity V A : ℝ) - · obtain ⟨V, hV⟩ := hlarge - let : Nonempty (Fin k) := ⟨⟨0, by omega⟩⟩ - let : DecidableEq (Fin m → Fin (k + 1)) := Classical.decEq _ - let D := fun _ : Fin k ↦ (Finset.univ : Finset (Fin m → Fin (k + 1))) - have hD : IsInsensitive.intersection D = Finset.univ := by - simpa only [IsInsensitive.intersection, D] using - (Finset.inf_const (s := (Finset.univ : Finset (Fin k))) Finset.univ_nonempty - (Finset.univ : Finset (Fin m → Fin (k + 1)))) - refine ⟨V, D, ?_, ?_, ?_⟩ - · intro i x y _ - simp only [D, Finset.mem_univ] - · rw [hD] - norm_num - nlinarith [Parameters.η_le_δ_div_six k δ, - Parameters.γ_le_η_sq_div_two k δ, Parameters.η_pos hk hδ₀, - sq_nonneg (1 - Parameters.η k δ)] - · rw [hD] - norm_num - rw [dens_pullback] - linarith [Parameters.γ_le_η_sq_div_two k δ] - · have hsmall : ∀ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - (Subspace.relativeDensity V A : ℝ) < δ + Parameters.η k δ ^ 2 / 2 := by - intro V - exact lt_of_not_ge fun hV ↦ hlarge ⟨V, hV⟩ - obtain ⟨V, C, hC, hweighted, houtside⟩ := - exists_large_insensitive_intersection hk hDHJ m n hm δ hδ₀ hδ₁ hm_large hn A hA - hfree hsmall - obtain ⟨i, hidense, hicorrelation⟩ := - exists_dense_firstFailurePiece hk hδ₀ hδ₁ (pullback V A) C hweighted - houtside - obtain ⟨hD, hintersection, _, _⟩ := firstFailureFamily_facts C hC i - refine ⟨V, firstFailureFamily C i, hD, ?_, ?_⟩ - · rw [hintersection] - exact hidense - · rw [hintersection] - exact hicorrelation + let : Fintype (Combinatorics.Line (Fin k) (Fin m)) := + Fintype.ofInjective (fun l ↦ l.idxFun) fun _ _ h ↦ Combinatorics.Line.ext h + obtain ⟨V, hV⟩ | ⟨V, hV, hlines⟩ := exists_subspace_many_lines hk hm hN hδ₀ hδ₁ hn hA + · refine ⟨V, fun _ ↦ univ, fun _ ↦ by simp [IsInsensitive], ?_⟩ + have hη := Parameters.η_le_δ_div_six k N δ + have hγ := Parameters.γ_le_η_sq_div_two k N δ + rw [(by ext; simp : IsInsensitive.intersection + (fun _ : Fin k ↦ (univ : Finset (Fin m → Fin (k + 1)))) = univ), dens_univ, inter_univ, + NNRat.cast_one, mul_one] + rw [← dens_pullback] at hV + exact ⟨by nlinarith [Parameters.η_pos k N hδ₀], by linarith⟩ + obtain ⟨C, hC, hCdense, hAC⟩ := + exists_endpoint_insensitive_intersection hk hδ₁ hm_large hfree hlines + obtain ⟨hweighted, hlarge⟩ := density_complement_bounds (A := pullback V A) hδ₀.le + (Parameters.η_pos k N hδ₀).le (by rwa [dens_pullback]) hCdense hAC + (Parameters.mul_one_sub_θ_div_four_le k N hδ₀) + obtain ⟨i, hi⟩ := exists_dense_complPiece hk hδ₀ hδ₁ hweighted hlarge + refine ⟨V, complPieceFamily C i, complPieceFamily_isInsensitive hC i, ?_⟩ + rwa [complPieceFamily_intersection] end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean index e9921e2cc4..0ac8f52ace 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean @@ -5,178 +5,207 @@ Authors: Gabriel Dahia -/ module -public import Mathlib.Combinatorics.HalesJewett -public import Mathlib.Combinatorics.Pigeonhole -public import Mathlib.Data.Finset.Sort +public import Mathlib.Data.Finset.Max +public import LeanPool.ShelahHalesJewett.HalesJewett +import LeanPool.DensityHalesJewett.DensityHalesJewett.HalesJewett +import Mathlib.Combinatorics.Pigeonhole +import Mathlib.Data.Finset.Sort /-! # Finite unions of disjoint sets from the multidimensional Hales--Jewett theorem For a colouring of the subsets of a large finite index set we produce pairwise disjoint nonempty -blocks all of whose nonempty unions receive the same colour. The argument follows the finite -unions section of `graham_rothschild_lines_from_mhj.tex`: the multidimensional Hales--Jewett +blocks all of whose nonempty unions receive the same colour. The multidimensional Hales--Jewett theorem over the alphabet `Bool` gives a translated combinatorial cube of sets, iterating it canonizes the colour of a union in terms of its least block, and the pigeonhole principle extracts a monochromatic family. + +Every step is carried out in an explicit dimension, written in terms of Shelah's bound +`Combinatorics.Line.shelahBound` for the Hales--Jewett numbers. -/ @[expose] public section -open Finset +open Finset Function open Combinatorics namespace DensityHalesJewett namespace FiniteUnions -/-- A translated combinatorial cube of sets: a base block `E` and wildcard blocks `G` such that -every union of `E` with a subfamily of the `G` has the same colour. -/ -lemma exists_translatedCube (C : Type*) [Finite C] (n : ℕ) : - ∃ M : ℕ, ∀ d : Finset (Fin M) → C, - ∃ (E : Finset (Fin M)) (G : Fin n → Finset (Fin M)), - E.Nonempty ∧ (∀ i, (G i).Nonempty) ∧ (∀ i, Disjoint E (G i)) ∧ - (∀ i j, i ≠ j → Disjoint (G i) (G j)) ∧ - ∃ c, ∀ I : Finset (Fin n), d (E ∪ I.biUnion G) = c := by +variable {κ : Type*} [Fintype κ] + +/-- The multidimensional Hales--Jewett theorem over the alphabet `Bool`, read as a statement about +sets of coordinates: a base set `S` and pairwise disjoint nonempty blocks `X` such that every +union of `S` with a subfamily of the `X` has the same colour. -/ +private lemma exists_mono_blocks {ι η : Type*} [Fintype ι] [DecidableEq ι] [Fintype η] + (h : Fintype.card ι = Line.shelahBound (2 ^ Fintype.card η) (Fintype.card κ) * Fintype.card η) + (C : Finset ι → κ) : + ∃ (S : Finset ι) (X : η → Finset ι), (∀ j, (X j).Nonempty) ∧ (∀ j, Disjoint S (X j)) ∧ + Pairwise (Disjoint on X) ∧ ∃ c, ∀ J : Finset η, C (S ∪ J.biUnion X) = c := by classical - obtain ⟨M, hM⟩ := Combinatorics.Subspace.exists_mono_in_high_dimension_fin Bool C (Fin (n + 1)) - refine ⟨M, ?_⟩ - intro d - obtain ⟨W, c, hc⟩ := hM fun x ↦ d {i | x i} - set S : Finset (Fin M) := {i | W.idxFun i = Sum.inl true} with hS - set X : Fin (n + 1) → Finset (Fin M) := fun j ↦ {i | W.idxFun i = Sum.inr j} with hX - have hXne : ∀ j, (X j).Nonempty := by - intro j + obtain ⟨W, c, hc⟩ := + Subspace.exists_mono_of_card_eq (α := Bool) (by simpa using h) fun x ↦ C {i | x i} + refine ⟨univ.filter fun i ↦ W.idxFun i = .inl true, + fun j ↦ univ.filter fun i ↦ W.idxFun i = .inr j, ?_, ?_, ?_, c, ?_⟩ + · intro j obtain ⟨i, hi⟩ := W.proper j - exact ⟨i, by simp [hX, hi]⟩ - have hXX : ∀ j j', j ≠ j' → Disjoint (X j) (X j') := by - simp only [Finset.disjoint_left, hX, Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨i, by simp [hi]⟩ + · intro j + simp only [disjoint_left, mem_filter, mem_univ, true_and] grind - have hSX : ∀ j, Disjoint S (X j) := by - simp only [Finset.disjoint_left, hS, hX, Finset.mem_filter, Finset.mem_univ, true_and] + · intro j j' hjj' + simp only [onFun, disjoint_left, mem_filter, mem_univ, true_and] grind - have key : ∀ J : Finset (Fin (n + 1)), d (S ∪ J.biUnion X) = c := by - intro J + · intro J rw [← hc fun j ↦ decide (j ∈ J)] congr 1 ext i - simp only [hS, hX, Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_union, - Finset.mem_biUnion] - rw [Combinatorics.Subspace.coe_apply] + simp only [mem_union, mem_biUnion, mem_filter, mem_univ, true_and] + rw [Subspace.coe_apply] cases h : W.idxFun i with | inl b => cases b <;> simp | inr j => simp - refine ⟨S ∪ X 0, fun i ↦ X i.succ, (hXne 0).mono Finset.subset_union_right, - fun i ↦ hXne _, ?_, fun i j hij ↦ hXX _ _ fun h ↦ hij (Fin.succ_injective _ h), - c, ?_⟩ - · intro i - exact Finset.disjoint_union_left.2 ⟨hSX _, hXX _ _ (Fin.succ_ne_zero i).symm⟩ - · intro I - convert key (insert 0 (I.image Fin.succ)) using 2 + +/-- A dimension in which every colouring with `c` colours has a translated combinatorial cube of +`n` wildcard blocks. -/ +def translatedCubeBound (c n : ℕ) : ℕ := + Line.shelahBound (2 ^ (n + 1)) c * (n + 1) + +/-- A translated combinatorial cube of sets: a base block `E` and wildcard blocks `G` such that +every union of `E` with a subfamily of the `G` has the same colour. -/ +lemma exists_translatedCube {n : ℕ} + (C : Finset (Fin (translatedCubeBound (Fintype.card κ) n)) → κ) : + ∃ (E : Finset (Fin (translatedCubeBound (Fintype.card κ) n))) + (G : Fin n → Finset (Fin (translatedCubeBound (Fintype.card κ) n))), + E.Nonempty ∧ (∀ i, (G i).Nonempty) ∧ (∀ i, Disjoint E (G i)) ∧ Pairwise (Disjoint on G) ∧ + ∃ c, ∀ I : Finset (Fin n), C (E ∪ I.biUnion G) = c := by + classical + obtain ⟨S, X, hX, hSX, hXX, c, hc⟩ := + exists_mono_blocks (η := Fin (n + 1)) + (by rw [Fintype.card_fin, Fintype.card_fin, translatedCubeBound]) C + refine ⟨S ∪ X 0, fun i ↦ X i.succ, (hX 0).mono subset_union_right, fun i ↦ hX _, + fun i ↦ disjoint_union_left.2 ⟨hSX _, hXX (Fin.succ_ne_zero i).symm⟩, + fun i j hij ↦ hXX fun h ↦ hij (Fin.succ_injective _ h), c, ?_⟩ + intro I + convert hc (insert 0 (I.image Fin.succ)) using 2 + simp [union_assoc, image_biUnion] + +/-- A dimension in which the colour of a union of `t` blocks is canonized by its least block: +the translated cube iterated `t` times. -/ +def minCanonicalBound (c : ℕ) : ℕ → ℕ + | 0 => 0 + | t + 1 => translatedCubeBound c (minCanonicalBound c t) + +/-- A block disjoint from pairwise disjoint blocks can be prepended to them. -/ +private lemma pairwise_disjoint_cons {ι : Type*} {t : ℕ} {E₀ : Finset ι} {F : Fin t → Finset ι} + (h₀ : ∀ j, Disjoint E₀ (F j)) (hF : Pairwise (Disjoint on F)) : + Pairwise (Disjoint on (Fin.cons E₀ F : Fin (t + 1) → Finset ι)) := by + intro i j hij + induction i using Fin.cases <;> induction j using Fin.cases + · exact absurd rfl hij + · simpa [onFun] using h₀ _ + · simpa [onFun] using (h₀ _).symm + · simpa [onFun] using hF fun h ↦ hij (congrArg Fin.succ h) + +/-- Unions of pairwise disjoint blocks over pairwise disjoint index sets are pairwise disjoint. -/ +private lemma pairwise_disjoint_biUnion {ι : Type*} [DecidableEq ι] {t n : ℕ} + {I : Fin t → Finset (Fin n)} {G : Fin n → Finset ι} (hI : Pairwise (Disjoint on I)) + (hG : Pairwise (Disjoint on G)) : Pairwise (Disjoint on fun j ↦ (I j).biUnion G) := by + intro i j hij + simp only [onFun, disjoint_biUnion_left, disjoint_biUnion_right] + intro b hb a ha + exact hG fun h ↦ disjoint_left.1 (hI hij) ha (by rwa [h]) + +/-- A set of indices in `Fin (t + 1)` is the image of a set of indices in `Fin t`, with or without +`0`. -/ +private lemma eq_image_succ_or_insert_zero {t : ℕ} (J : Finset (Fin (t + 1))) : + ∃ K : Finset (Fin t), J = K.image Fin.succ ∨ J = insert 0 (K.image Fin.succ) := by + refine ⟨univ.filter fun j ↦ j.succ ∈ J, ?_⟩ + by_cases h0 : 0 ∈ J + · right ext i - simp only [Finset.mem_union, Finset.mem_biUnion, Finset.mem_insert, Finset.mem_image] - grind + induction i using Fin.cases <;> simp [h0, Fin.succ_ne_zero] + · left + ext i + induction i using Fin.cases <;> simp [h0, Fin.succ_ne_zero] + +private lemma min'_image_succ {t : ℕ} {K : Finset (Fin t)} (hK : K.Nonempty) : + (K.image Fin.succ).min' (hK.image _) = (K.min' hK).succ := + min'_image (fun _ _ h ↦ Fin.succ_le_succ_iff.2 h) K _ + +private lemma min'_insert_zero {t : ℕ} (s : Finset (Fin (t + 1))) : + (insert 0 s).min' (insert_nonempty 0 s) = 0 := + le_antisymm (min'_le _ _ (mem_insert_self 0 s)) (Fin.zero_le _) /-- Iterating the translated cube canonizes the colour of a union of blocks in terms of the least block that it contains. -/ -lemma exists_minCanonical (C : Type*) [Finite C] (t : ℕ) : - ∃ D : ℕ, ∀ d : Finset (Fin D) → C, ∃ E : Fin t → Finset (Fin D), - (∀ i, (E i).Nonempty) ∧ (∀ i j, i ≠ j → Disjoint (E i) (E j)) ∧ - ∃ f : Fin t → C, ∀ (J : Finset (Fin t)) (hJ : J.Nonempty), - d (J.biUnion E) = f (J.min' hJ) := by +lemma exists_minCanonical {t : ℕ} : + ∀ C : Finset (Fin (minCanonicalBound (Fintype.card κ) t)) → κ, + ∃ E : Fin t → Finset (Fin (minCanonicalBound (Fintype.card κ) t)), + (∀ i, (E i).Nonempty) ∧ Pairwise (Disjoint on E) ∧ + ∃ f : Fin t → κ, ∀ (J : Finset (Fin t)) (hJ : J.Nonempty), + C (J.biUnion E) = f (J.min' hJ) := by classical induction t with | zero => - refine ⟨0, ?_⟩ - intro d + intro C refine ⟨Fin.elim0, fun i ↦ i.elim0, fun i ↦ i.elim0, Fin.elim0, ?_⟩ intro J hJ - simp [Finset.eq_empty_of_isEmpty J] at hJ + simp [eq_empty_of_isEmpty J] at hJ | succ t ih => - obtain ⟨D, hD⟩ := ih - obtain ⟨M, hM⟩ := exists_translatedCube C D - refine ⟨M, ?_⟩ - intro d - obtain ⟨E₀, G, hE₀, hG, hE₀G, hGG, c, hc⟩ := hM d - obtain ⟨I, hI, hII, f, hf⟩ := hD fun K ↦ d (K.biUnion G) - refine ⟨Fin.cons E₀ fun j ↦ (I j).biUnion G, ?_, ?_, Fin.cons c f, ?_⟩ + rw [minCanonicalBound] + intro C + obtain ⟨E₀, G, hE₀, hG, hE₀G, hGG, c, hc⟩ := exists_translatedCube C + obtain ⟨I, hI, hII, f, hf⟩ := ih fun K ↦ C (K.biUnion G) + refine ⟨Fin.cons E₀ fun j ↦ (I j).biUnion G, ?_, + pairwise_disjoint_cons ?_ (pairwise_disjoint_biUnion hII hGG), Fin.cons c f, ?_⟩ · intro i induction i using Fin.cases with | zero => simpa using hE₀ | succ j => simpa using (hI j).biUnion fun g _ ↦ hG g - · intro i j hij - induction i using Fin.cases with - | zero => - induction j using Fin.cases with - | zero => exact absurd rfl hij - | succ j => - simpa using (Finset.disjoint_biUnion_right _ _ _).2 fun g _ ↦ hE₀G g - | succ i => - induction j using Fin.cases with - | zero => - simpa using - (Finset.disjoint_biUnion_left _ _ _).2 fun g _ ↦ (hE₀G g).symm - | succ j => - simp only [Fin.cons_succ, Finset.disjoint_biUnion_left, Finset.disjoint_biUnion_right] - intro g hg g' hg' - apply hGG g' g - intro hgg' - refine (hII i j ?_).notMem_of_mem_left_finset hg' (hgg' ▸ hg) - intro h - exact hij (congrArg Fin.succ h) + · intro j + exact (disjoint_biUnion_right _ _ _).2 fun g _ ↦ hE₀G g · intro J hJ - set K : Finset (Fin t) := {j | j.succ ∈ J} with hK - have himage : J.erase 0 = K.image Fin.succ := by - ext i - induction i using Fin.cases with - | zero => simp - | succ j => simp [hK, Fin.succ_ne_zero] - have hbiUnion : (J.erase 0).biUnion (Fin.cons E₀ fun j ↦ (I j).biUnion G) - = (K.biUnion I).biUnion G := by - simp [himage, Finset.image_biUnion, Finset.biUnion_biUnion] - by_cases h0 : (0 : Fin (t + 1)) ∈ J - · have hmin : J.min' hJ = 0 := le_antisymm (Finset.min'_le _ _ h0) (Fin.zero_le _) - rw [hmin, ← Finset.insert_erase h0, Finset.biUnion_insert, hbiUnion] - simpa using hc _ - · have hKne : K.Nonempty := by - obtain ⟨i, hi⟩ := hJ - induction i using Fin.cases with - | zero => exact absurd hi h0 - | succ j => exact ⟨j, by simpa [hK] using hi⟩ - have hJK : J = K.image Fin.succ := by rw [← himage, Finset.erase_eq_of_notMem h0] - have hmin : J.min' hJ = (K.min' hKne).succ := by - simp_rw [hJK] - exact Finset.min'_image (fun _ _ h ↦ Fin.succ_le_succ_iff.2 h) K _ - rw [hmin, ← Finset.erase_eq_of_notMem h0, hbiUnion] - simpa using hf K hKne + obtain ⟨K, rfl | rfl⟩ := eq_image_succ_or_insert_zero J + · obtain hK := image_nonempty.1 hJ + rw [min'_image_succ hK, Fin.cons_succ, image_biUnion] + simpa [biUnion_biUnion] using hf K hK + · rw [min'_insert_zero, Fin.cons_zero, biUnion_insert, image_biUnion] + simpa [biUnion_biUnion] using hc (K.biUnion I) + +/-- A dimension for the finite disjoint unions theorem with `c` colours and `m` blocks: by the +pigeonhole principle, `m * c + 1` canonized blocks contain `m + 1` whose colours agree. -/ +def monochromaticUnionsBound (c : ℕ) : ℕ → ℕ + | 0 => 0 + | m + 1 => minCanonicalBound c (m * c + 1) /-- The finite disjoint unions theorem: for every colouring of the subsets of a large enough finite index set there are `m` pairwise disjoint nonempty blocks all of whose nonempty unions receive the same colour. -/ -lemma exists_monochromaticUnions (C : Type*) [Finite C] (m : ℕ) : - ∃ D : ℕ, ∀ d : Finset (Fin D) → C, ∃ E : Fin m → Finset (Fin D), - (∀ i, (E i).Nonempty) ∧ (∀ i j, i ≠ j → Disjoint (E i) (E j)) ∧ - ∃ c, ∀ J : Finset (Fin m), J.Nonempty → d (J.biUnion E) = c := by +lemma exists_monochromaticUnions {m : ℕ} : + ∀ C : Finset (Fin (monochromaticUnionsBound (Fintype.card κ) m)) → κ, + ∃ E : Fin m → Finset (Fin (monochromaticUnionsBound (Fintype.card κ) m)), + (∀ i, (E i).Nonempty) ∧ Pairwise (Disjoint on E) ∧ + ∃ c, ∀ J : Finset (Fin m), J.Nonempty → C (J.biUnion E) = c := by classical - let _ := Fintype.ofFinite C - obtain ⟨D, hD⟩ := exists_minCanonical C ((m - 1) * Fintype.card C + 1) - refine ⟨D, ?_⟩ - intro d - obtain ⟨E, hE, hEE, f, hf⟩ := hD d - obtain ⟨c, -, hcard⟩ := - Finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to (s := Finset.univ) - (t := (Finset.univ : Finset C)) (f := f) (n := m - 1) (fun a _ ↦ Finset.mem_univ _) (by - simp only [Finset.card_univ, Fintype.card_fin] - rw [Nat.mul_comm] - omega) - obtain ⟨T, hTsub, hTcard⟩ := - Finset.exists_subset_card_eq (s := {i | f i = c}) (n := m) (by omega) + obtain _ | m := m + · intro C + refine ⟨Fin.elim0, fun i ↦ i.elim0, fun i ↦ i.elim0, C ∅, ?_⟩ + intro J hJ + simp [eq_empty_of_isEmpty J] at hJ + rw [monochromaticUnionsBound] + intro C + obtain ⟨E, hE, hEE, f, hf⟩ := exists_minCanonical C + obtain ⟨c, -, hc⟩ := exists_lt_card_fiber_of_mul_lt_card_of_maps_to (s := univ) + (t := (univ : Finset κ)) (f := f) (n := m) (fun _ _ ↦ mem_univ _) (by simp [mul_comm]) + obtain ⟨T, hT, hTcard⟩ := exists_subset_card_eq (s := {i | f i = c}) (n := m + 1) hc refine ⟨fun j ↦ E (T.orderEmbOfFin hTcard j), fun j ↦ hE _, - fun i j hij ↦ hEE _ _ fun h ↦ hij ((T.orderEmbOfFin hTcard).injective h), c, ?_⟩ + fun i j hij ↦ hEE fun h ↦ hij ((T.orderEmbOfFin hTcard).injective h), c, ?_⟩ intro J hJ - rw [← Finset.image_biUnion, hf _ (hJ.image _)] - obtain ⟨j, -, hj⟩ := - Finset.mem_image.1 (Finset.min'_mem _ (hJ.image (T.orderEmbOfFin hTcard))) + rw [← image_biUnion, hf _ (hJ.image _)] + obtain ⟨j, -, hj⟩ := mem_image.1 (min'_mem _ (hJ.image (T.orderEmbOfFin hTcard))) rw [← hj] - simpa using hTsub (T.orderEmbOfFin_mem hTcard j) + simpa using hT (T.orderEmbOfFin_mem hTcard j) end FiniteUnions end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean index 45e45ef255..91b910f10d 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean @@ -7,34 +7,28 @@ module public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace -public import Mathlib.Order.Lattice.Nat -import Mathlib.Combinatorics.Pigeonhole - -import Mathlib.Data.Finset.Sort -import Mathlib.Logic.Equiv.Fin.Basic /-! # The Graham--Rothschild theorem for combinatorial lines -The finite-unions focusing argument, block canonization, and the line-coloring form of the +The finite-unions focusing argument, block canonization, and the line-colouring form of the Graham--Rothschild theorem needed by the density proof. -Following `graham_rothschild_lines_from_mhj.tex`, the support canonization lemma -`Canonization.exists_canonical_of_le` reduces the colour of a line of a large subspace to the -support of its parameter word, and `FiniteUnions.exists_monochromaticUnions` produces pairwise -disjoint blocks of parameters all of whose nonempty unions are equally coloured. Reading those -blocks as the variable directions of a subspace proves the theorem. +The support canonization lemma `Canonization.exists_canonical_of_le` reduces the colour of a line of +a large subspace to the support of its parameter word, and `FiniteUnions.exists_monochromaticUnions` +produces pairwise disjoint blocks of parameters all of whose nonempty unions are equally coloured. +Reading those blocks as the variable directions of a subspace proves the theorem, in the dimension +`GrahamRothschild.bound`, an explicit expression in the bound for the Hales--Jewett numbers. Mathlib's `Combinatorics.Subspace` indexes variable directions by an arbitrary function on -coordinates rather than by consecutive blocks of coordinates, so the block convention of the -write-up, and with it the finite Ramsey theorem used to arrange the blocks in increasing order, -is not needed here: pairwise disjoint blocks already describe a subspace. +coordinates rather than by consecutive blocks of coordinates. Pairwise disjoint blocks therefore +already describe a subspace, and the finite Ramsey theorem that would arrange them in increasing +order is not needed. -/ @[expose] public section -open Finset +open Finset Function open Combinatorics namespace DensityHalesJewett @@ -43,165 +37,104 @@ namespace GrahamRothschild open Subspace -variable {α ι C : Type*} [DecidableEq ι] {m n : ℕ} +/-- A coordinate lies in at most one of pairwise disjoint blocks. -/ +private lemma choose_eq {ι : Type*} {m : ℕ} {E : Fin m → Finset ι} + (hEE : Pairwise (Disjoint on E)) {i : ι} {j : Fin m} (hij : i ∈ E j) (h : ∃ j, i ∈ E j) : + h.choose = j := + by_contra fun hne ↦ disjoint_left.1 (hEE hne) h.choose_spec hij + +variable {α ι κ : Type*} [DecidableEq ι] {m n : ℕ} /-- The subspace whose variable directions are pairwise disjoint nonempty blocks of coordinates, -all remaining coordinates carrying a fixed letter. -/ +with a fixed letter on all remaining coordinates. -/ noncomputable def ofBlocks (a₀ : α) (E : Fin m → Finset ι) (hE : ∀ j, (E j).Nonempty) - (hEE : ∀ i j, i ≠ j → Disjoint (E i) (E j)) : Combinatorics.Subspace (Fin m) α ι where + (hEE : Pairwise (Disjoint on E)) : Combinatorics.Subspace (Fin m) α ι where idxFun i := if h : ∃ j, i ∈ E j then Sum.inr h.choose else Sum.inl a₀ proper e := by obtain ⟨i, hi⟩ := hE e - refine ⟨i, ?_⟩ - rw [dite_eq_left ⟨e, hi⟩] - apply congrArg Sum.inr - by_contra hne - exact Finset.disjoint_left.1 (hEE _ _ hne) (Exists.choose_spec (⟨e, hi⟩ : ∃ j, i ∈ E j)) hi + exact ⟨i, by rw [dite_eq_left ⟨e, hi⟩, choose_eq hEE hi]⟩ variable {a₀ : α} {E : Fin m → Finset ι} {hE : ∀ j, (E j).Nonempty} - {hEE : ∀ i j, i ≠ j → Disjoint (E i) (E j)} + {hEE : Pairwise (Disjoint on E)} lemma ofBlocks_idxFun_of_mem {i : ι} {j : Fin m} (hij : i ∈ E j) : (ofBlocks a₀ E hE hEE).idxFun i = Sum.inr j := by simp only [ofBlocks] - rw [dite_eq_left ⟨j, hij⟩] - apply congrArg Sum.inr - by_contra hne - exact Finset.disjoint_left.1 (hEE _ _ hne) (Exists.choose_spec (⟨j, hij⟩ : ∃ j, i ∈ E j)) hij + rw [dite_eq_left ⟨j, hij⟩, choose_eq hEE hij] lemma ofBlocks_idxFun_of_notMem {i : ι} (hi : ∀ j, i ∉ E j) : - (ofBlocks a₀ E hE hEE).idxFun i = Sum.inl a₀ := by - simp only [ofBlocks] - rw [dite_eq_right (by simpa using hi)] + (ofBlocks a₀ E hE hEE).idxFun i = Sum.inl a₀ := + dite_eq_right (by simpa using hi) /-- The support of a word substituted into `ofBlocks` is the union of the blocks indexed by the support of that word. -/ -lemma sameSupport_wordMap_ofBlocks (x : Fin m → Option α) (J : Finset (Fin m)) +lemma sameSupport_wordMap_ofBlocks {x : Fin m → Option α} {J : Finset (Fin m)} (hJ : ∀ j, j ∈ J ↔ x j = none) : SameSupport (wordMap (ofBlocks a₀ E hE hEE) x) fun i ↦ if i ∈ J.biUnion E then none else some a₀ := by - have hite : ∀ i : ι, ((if i ∈ J.biUnion E then none else some a₀ : Option α) = none) - ↔ i ∈ J.biUnion E := by - intro i - split <;> simp [*] intro i - rw [wordMap] + have hite : (if i ∈ J.biUnion E then none else some a₀ : Option α) = none ↔ + i ∈ J.biUnion E := by + split <;> simp [*] + rw [wordMap, hite, mem_biUnion] by_cases h : ∃ j, i ∈ E j · obtain ⟨j, hj⟩ := h - rw [ofBlocks_idxFun_of_mem hj, Sum.elim_inr, ← hJ j, hite i, Finset.mem_biUnion] - constructor - · intro hjJ - exact ⟨j, hjJ, hj⟩ - · rintro ⟨j', hj'J, hij'⟩ - by_contra hne - refine Finset.disjoint_left.1 (hEE j j' ?_) hj hij' - intro hjj' - apply hne - rw [hjj'] - exact hj'J + rw [ofBlocks_idxFun_of_mem hj, Sum.elim_inr, ← hJ j] + refine ⟨fun hjJ ↦ ⟨j, hjJ, hj⟩, ?_⟩ + rintro ⟨j', hj'J, hij'⟩ + by_contra hjJ + exact disjoint_left.1 (hEE fun h : j = j' ↦ hjJ (h ▸ hj'J)) hj hij' · rw [not_exists] at h - rw [ofBlocks_idxFun_of_notMem h, Sum.elim_inl, hite i] - simp [Finset.mem_biUnion, h] + rw [ofBlocks_idxFun_of_notMem h] + simp [h] /-- Extend a colouring of the lines of a cube to a colouring of all words over `Option α`. -/ -private noncomputable def extend [Nonempty C] (χ : Combinatorics.Line α (Fin n) → C) - (w : Fin n → Option α) : C := - if h : ∃ i, w i = none then χ ⟨w, h⟩ else Classical.arbitrary C +private noncomputable def extend [Nonempty κ] (C : Combinatorics.Line α (Fin n) → κ) + (w : Fin n → Option α) : κ := + if h : ∃ i, w i = none then C ⟨w, h⟩ else Classical.arbitrary κ -private lemma extend_idxFun [Nonempty C] (χ : Combinatorics.Line α (Fin n) → C) - (l : Combinatorics.Line α (Fin n)) : extend χ l.idxFun = χ l := +private lemma extend_idxFun [Nonempty κ] (C : Combinatorics.Line α (Fin n) → κ) + (l : Combinatorics.Line α (Fin n)) : extend C l.idxFun = C l := dite_eq_left l.proper +/-- A sufficient dimension for Graham--Rothschild for lines with `k` letters, `r` colours and +subspace dimension `m`, as an explicit expression in Shelah's bound +`Combinatorics.Line.shelahBound` for the Hales--Jewett numbers. -/ +def bound (k r m : ℕ) : ℕ := + Canonization.bound k r (FiniteUnions.monochromaticUnionsBound r m) 0 0 + /-- **Graham--Rothschild for lines**: beyond a dimension depending only on the alphabet, the number of colours and `m`, every colouring of the lines of a cube is constant on the lines of some `m`-dimensional combinatorial subspace. -/ -lemma exists_lines (α : Type*) [Finite α] [Nonempty α] (C : Type*) [Finite C] [Nonempty C] - (m : ℕ) : ∃ N : ℕ, ∀ n, N ≤ n → ∀ χ : Combinatorics.Line α (Fin n) → C, - ∃ V : Combinatorics.Subspace (Fin m) α (Fin n), - ∃ c, ∀ l : Combinatorics.Line α (Fin m), χ (composeLine V l) = c := by +theorem exists_mapLine_eq {α κ : Type*} [Fintype α] [Nonempty α] [Fintype κ] [Nonempty κ] + {m n : ℕ} (hn : bound (Fintype.card α) (Fintype.card κ) m ≤ n) + (C : Combinatorics.Line α (Fin n) → κ) : + ∃ V : Combinatorics.Subspace (Fin m) α (Fin n), + ∃ c, ∀ l : Combinatorics.Line α (Fin m), C (mapLine V l) = c := by classical - obtain ⟨L, hL⟩ := FiniteUnions.exists_monochromaticUnions C m - obtain ⟨N, hN⟩ := Canonization.exists_canonical_of_le α C L - refine ⟨N, ?_⟩ - intro n hn χ - obtain ⟨V, hV⟩ := hN n hn (extend χ) - obtain ⟨E, hE, hEE, c, hc⟩ := hL fun I ↦ - extend χ (wordMap V fun i ↦ if i ∈ I then none else some (Classical.arbitrary α)) + obtain ⟨V, hV⟩ := Canonization.exists_canonical_of_le hn (extend C) + obtain ⟨E, hE, hEE, c, hc⟩ := FiniteUnions.exists_monochromaticUnions fun I ↦ + extend C (wordMap V fun i ↦ if i ∈ I then none else some (Classical.arbitrary α)) refine ⟨compose V (ofBlocks (Classical.arbitrary α) E hE hEE), c, ?_⟩ intro l - rw [← extend_idxFun χ, composeLine_idxFun, wordMap_compose, - hV _ _ (sameSupport_wordMap_ofBlocks l.idxFun {j | l.idxFun j = none} fun j ↦ by simp)] - apply hc + rw [mapLine_eq_composeLine, ← extend_idxFun C, composeLine_idxFun, wordMap_compose, + hV _ _ (sameSupport_wordMap_ofBlocks (J := {j | l.idxFun j = none}) fun j ↦ by simp)] obtain ⟨j, hj⟩ := l.proper - exact ⟨j, by simpa using hj⟩ - -/-- The Graham--Rothschild property for `k` letters, `r` colours and dimension `m`, in a cube of -dimension `N`. -/ -def IsLineBound (k r m N : ℕ) : Prop := - ∀ χ : Combinatorics.Line (Fin k) (Fin N) → Fin r, - ∃ V : Combinatorics.Subspace (Fin m) (Fin k) (Fin N), - ∃ c, ∀ l : Combinatorics.Line (Fin k) (Fin m), χ (composeLine V l) = c - -/-- A Graham--Rothschild dimension for colorings of combinatorial lines. -/ -noncomputable def bound (alphabet colors dimension : ℕ) : ℕ := - sInf {N | ∀ n, N ≤ n → IsLineBound alphabet colors dimension n} - -private lemma isLineBound_of_bound_le {k r m : ℕ} (hk : 1 ≤ k) (hr : 1 ≤ r) (n : ℕ) - (hn : bound k r m ≤ n) : IsLineBound k r m n := by - have : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ - have : Nonempty (Fin r) := ⟨⟨0, hr⟩⟩ - exact Nat.sInf_mem (exists_lines (Fin k) (Fin r) m) n hn - -/-- Transporting a subspace along an alphabet equivalence transports the lines it carries. -/ -private lemma composeLine_reindex {β : Type*} (e : α ≃ β) - (V : Combinatorics.Subspace (Fin m) β (Fin n)) (l : Combinatorics.Line α (Fin m)) : - composeLine (V.reindex (Equiv.refl _) e.symm (Equiv.refl _)) l - = Combinatorics.Line.map e.symm (composeLine V (l.map e)) := by - apply Combinatorics.Line.ext - funext i - cases h : V.idxFun i <;> - simp [composeLine, Combinatorics.Subspace.reindex, Combinatorics.Line.map, h] - -/-- The line case of the Graham--Rothschild theorem. -/ -lemma lines (α C : Type*) [Fintype α] [Nontrivial α] [Fintype C] [Nonempty C] - (m n : ℕ) - (hn : bound (Fintype.card α) (Fintype.card C) m ≤ n) - (χ : Combinatorics.Line α (Fin n) → C) : - ∃ V : Combinatorics.Subspace (Fin m) α (Fin n), - ∃ c, ∀ l : Combinatorics.Line α (Fin m), χ (Subspace.mapLine V l) = c := by - classical - obtain ⟨V, c, hc⟩ := - isLineBound_of_bound_le (k := Fintype.card α) (r := Fintype.card C) (m := m) - (le_trans one_le_two Fintype.one_lt_card) Fintype.card_pos n hn - fun l ↦ Fintype.equivFin C (χ (l.map (Fintype.equivFin α).symm)) - refine ⟨V.reindex (Equiv.refl _) (Fintype.equivFin α).symm (Equiv.refl _), - (Fintype.equivFin C).symm c, ?_⟩ - intro l - rw [Subspace.mapLine_eq_composeLine, composeLine_reindex, ← hc (l.map (Fintype.equivFin α)), - Equiv.symm_apply_apply] - -/-- The two-color form of Graham--Rothschild used by the density argument. -/ -lemma lines_twoColor (α : Type*) [Fintype α] [Nontrivial α] - (m n : ℕ) - (hn : bound (Fintype.card α) 2 m ≤ n) - (L : Finset (Combinatorics.Line α (Fin n))) : + exact hc _ ⟨j, by simpa using hj⟩ + +/-- The two-colour form of Graham--Rothschild used by the density argument: some `m`-dimensional +subspace has all of its lines in a given set of lines, or none of them. -/ +lemma exists_mapLine_mem_or_notMem {α : Type*} [Fintype α] [Nonempty α] {m n : ℕ} + (hn : bound (Fintype.card α) 2 m ≤ n) (L : Finset (Combinatorics.Line α (Fin n))) : ∃ V : Combinatorics.Subspace (Fin m) α (Fin n), - (∀ l : Combinatorics.Line α (Fin m), Subspace.mapLine V l ∈ L) ∨ - (∀ l : Combinatorics.Line α (Fin m), Subspace.mapLine V l ∉ L) := by + (∀ l : Combinatorics.Line α (Fin m), mapLine V l ∈ L) ∨ + (∀ l : Combinatorics.Line α (Fin m), mapLine V l ∉ L) := by classical - obtain ⟨V, c, hc⟩ := - lines α (Fin 2) m n hn fun l ↦ if l ∈ L then 0 else 1 - obtain rfl | ⟨c, rfl⟩ := c.eq_zero_or_eq_succ - · refine ⟨V, ?_⟩ - left - intro l - by_contra h - simpa [h] using hc l - · refine ⟨V, ?_⟩ - right - rw [Fin.eq_zero c] at hc - intro l h - simpa [h] using hc l + obtain ⟨V, c, hc⟩ := exists_mapLine_eq (κ := Bool) hn fun l ↦ decide (l ∈ L) + use V + cases c + · exact .inr fun l ↦ by simpa using hc l + · exact .inl fun l ↦ by simpa using hc l end GrahamRothschild end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/HalesJewett.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/HalesJewett.lean new file mode 100644 index 0000000000..9d0bc570e2 --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/HalesJewett.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import LeanPool.ShelahHalesJewett.HalesJewett + +/-! +# The multidimensional Hales--Jewett theorem with Shelah's bound + +`Combinatorics.Line.exists_mono_of_card_eq_shelahBound`, from the `ShelahHalesJewett` project, is +the Hales--Jewett theorem in a dimension of cardinality `Combinatorics.Line.shelahBound`. Here it +is applied to the alphabet `η → α` to find a monochromatic subspace of dimension `η` over `α`. +-/ + +@[expose] public section + +namespace Combinatorics.Subspace + +/-- The multidimensional Hales--Jewett theorem with an explicit dimension: a subspace of dimension +`η` over `α` is a line over the alphabet `η → α`. -/ +theorem exists_mono_of_card_eq {α κ η ι : Type*} [Fintype α] [Fintype κ] [Fintype η] [Fintype ι] + (h : Fintype.card ι = + Line.shelahBound (Fintype.card α ^ Fintype.card η) (Fintype.card κ) * Fintype.card η) + (C : (ι → α) → κ) : ∃ V : Subspace η α ι, V.IsMono C := by + classical + set N := Line.shelahBound (Fintype.card α ^ Fintype.card η) (Fintype.card κ) with hN + let e : Fin N × η ≃ ι := Fintype.equivOfCardEq (by simp [h]) + obtain ⟨l, hl⟩ := Line.exists_mono_of_card_eq_shelahBound (α := η → α) (ι := Fin N) + (by simp [hN]) fun x ↦ C fun i ↦ x (e.symm i).1 (e.symm i).2 + refine ⟨l.toSubspace.reindex (Equiv.refl _) (Equiv.refl _) e, ?_⟩ + rw [reindex_isMono, Line.toSubspace_isMono] + exact hl + +end Combinatorics.Subspace diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean new file mode 100644 index 0000000000..8d438b017e --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement +public import Mathlib.Analysis.Real.Sqrt +public import Mathlib.Data.Nat.Choose.Central +import Mathlib.Tactic.LinearCombination +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Combinatorics.SetFamily.LYM + +/-! +# Density Hales--Jewett: the base case and the inductive step + +The binary base case, by Sperner's theorem, and the step from `k` to `k + 1` letters, by iterating +the density increment. + +Both carry an explicit bound. For two letters it is `2 * ⌈1 / δ ^ 2⌉₊`. Passing from `k` to +`k + 1` letters with a bound `F` for `k` letters, `stepBound k F` iterates the dimension +`incrementBound k F` of one density increment once for each increment that fits below density +one. Shelah's bound `Combinatorics.Line.shelahBound` for the Hales--Jewett numbers enters it +through the Graham--Rothschild bound. + +The induction is run in `DensityHalesJewett.isDHJBound_ack`, which bounds its result by the +Ackermann function. +-/ + +@[expose] public section + +open Finset +open Combinatorics + +namespace DensityHalesJewett + +/-- Identify a binary word with the coordinates on which it equals `1`. -/ +def binarySupport {ι : Type*} [Fintype ι] (w : ι → Fin 2) : Finset ι := + univ.filter fun i ↦ w i = 1 + +@[simp] +lemma mem_binarySupport {ι : Type*} [Fintype ι] {w : ι → Fin 2} {i : ι} : + i ∈ binarySupport w ↔ w i = 1 := by + simp [binarySupport] + +/-- Two binary words are the ordered points of a combinatorial line exactly when their supports +are strictly comparable. -/ +lemma binary_line_iff_ssubset {ι : Type*} [Fintype ι] (x y : ι → Fin 2) : + (∃ l : Combinatorics.Line (Fin 2) ι, l 0 = x ∧ l 1 = y) ↔ + binarySupport x ⊂ binarySupport y := by + constructor + · rintro ⟨l, rfl, rfl⟩ + obtain ⟨i, hi⟩ := l.proper + refine (ssubset_iff_of_subset ?_).2 ⟨i, by simp [hi], by simp [hi]⟩ + intro j hj + cases hj' : l.idxFun j <;> simp_all + · intro h + obtain ⟨i, hiy, hix⟩ := exists_of_ssubset h + rw [mem_binarySupport] at hiy hix + have hsub (j : ι) (hj : x j = 1) : y j = 1 := by simpa using h.1 (mem_binarySupport.2 hj) + clear h + refine ⟨⟨fun j ↦ if x j = y j then some (x j) else none, i, by grind⟩, ?_, ?_⟩ <;> + funext j <;> grind [Combinatorics.Line.coe_apply] + +/-- A binary word is determined by its support. -/ +lemma binarySupport_injective {ι : Type*} [Fintype ι] : + Function.Injective (binarySupport : (ι → Fin 2) → Finset ι) := by + intro x y hxy + funext i + have hi : x i = 1 ↔ y i = 1 := by simpa using Finset.ext_iff.mp hxy i + grind + +/-- A squared elementary upper bound for the normalized central binomial coefficient. -/ +lemma centralBinom_ratio_sq_mul_le (m : ℕ) : + ((Nat.centralBinom m : ℝ) / 4 ^ m) ^ 2 * (3 * m + 1) ≤ 1 := by + induction m with + | zero => norm_num [Nat.centralBinom] + | succ m ih => + have hrec : ((m + 1 : ℕ) : ℝ) * Nat.centralBinom (m + 1) = + 2 * (2 * m + 1) * Nat.centralBinom m := by + exact_mod_cast Nat.succ_mul_centralBinom_succ m + have hratio : (Nat.centralBinom (m + 1) : ℝ) / 4 ^ (m + 1) = + ((Nat.centralBinom m : ℝ) / 4 ^ m) * + ((2 * m + 1 : ℝ) / (2 * (m + 1))) := by + rw [pow_succ] + field_simp + push_cast at hrec ⊢ + linear_combination 2 * hrec + rw [hratio, mul_pow, mul_assoc] + refine le_trans (mul_le_mul_of_nonneg_left ?_ (sq_nonneg _)) ih + rw [div_pow, div_mul_eq_mul_div] + apply (div_le_iff₀ (sq_pos_of_pos (by positivity))).mpr + push_cast + ring_nf + nlinarith + +/-- The middle binomial coefficient is at most the reciprocal square-root proportion of the +Boolean cube. -/ +lemma centralBinom_ratio_le_inv_sqrt (m : ℕ) : + (Nat.centralBinom m : ℝ) / 4 ^ m ≤ (√(3 * m + 1))⁻¹ := by + rw [inv_eq_one_div, le_div_iff₀ (Real.sqrt_pos.2 (by positivity)), + ← sq_le_sq₀ (by positivity) (by positivity), mul_pow, Real.sq_sqrt (by positivity)] + simpa [one_pow] using centralBinom_ratio_sq_mul_le m + +/-- The two normalizations of the binomial denominator, one per half-dimension and one per +dimension, agree. -/ +private lemma two_pow_two_mul (m : ℕ) : (2 : ℝ) ^ (2 * m) = 4 ^ m := by + rw [pow_mul] + norm_num + +/-- Reduce the normalized middle binomial coefficient in any dimension to the central coefficient +in half that dimension. -/ +lemma middleBinomial_ratio_le_central (n : ℕ) : + (n.choose (n / 2) : ℝ) / 2 ^ n ≤ + (Nat.centralBinom (n / 2) : ℝ) / 4 ^ (n / 2) := by + obtain ⟨m, hm | hm⟩ := Nat.even_or_odd' n + · subst n + rw [Nat.mul_div_cancel_left m two_pos, Nat.centralBinom, two_pow_two_mul] + · subst n + rw [(by omega : (2 * m + 1) / 2 = m), Nat.centralBinom] + cases m with + | zero => norm_num + | succ m => + have hchoose : (2 * (m + 1) + 1).choose (m + 1) ≤ + 2 * Nat.centralBinom (m + 1) := by + rw [Nat.choose_succ_left (2 * (m + 1)) (m + 1) (by grind)] + simpa [Nat.add_sub_cancel, two_mul] using + add_le_add (Nat.choose_le_centralBinom m (m + 1)) + (Nat.choose_le_centralBinom (m + 1) (m + 1)) + rw [pow_succ, two_pow_two_mul, mul_comm (4 ^ (m + 1) : ℝ) 2] + apply le_trans (b := (2 * Nat.centralBinom (m + 1) : ℝ) / + (2 * 4 ^ (m + 1))) + · exact (div_le_div_iff_of_pos_right + (by positivity : (0 : ℝ) < 2 * 4 ^ (m + 1))).mpr <| by + exact_mod_cast hchoose + · field_simp + rfl + +/-- Beyond an explicit dimension the middle layer occupies less than any prescribed positive +proportion of the Boolean cube. -/ +lemma middleBinomial_lt {δ : ℝ} (hδ : 0 < δ) {n : ℕ} (hn : 2 * ⌈1 / δ ^ 2⌉₊ ≤ n) : + (n.choose (n / 2) : ℝ) < δ * 2 ^ n := by + have hMn : ⌈1 / δ ^ 2⌉₊ ≤ n / 2 := (Nat.le_div_iff_mul_le (by norm_num)).mpr (by grind) + have hsq : 1 / δ ^ 2 < 3 * ((n / 2 : ℕ) : ℝ) + 1 := by + have hceil : 1 / δ ^ 2 ≤ ((n / 2 : ℕ) : ℝ) := (Nat.le_ceil _).trans (by exact_mod_cast hMn) + linarith [(Nat.cast_nonneg (n / 2) : (0 : ℝ) ≤ ((n / 2 : ℕ) : ℝ))] + apply (div_lt_iff₀ (by positivity : (0 : ℝ) < 2 ^ n)).mp + apply (middleBinomial_ratio_le_central n).trans_lt + apply (centralBinom_ratio_le_inv_sqrt (n / 2)).trans_lt + rw [inv_lt_comm₀ (Real.sqrt_pos.2 (by positivity)) hδ] + apply Real.lt_sqrt_of_sq_lt + rwa [inv_pow, ← one_div] + +/-- Density Hales--Jewett for the binary alphabet, beyond an explicit dimension. -/ +lemma exists_line_of_binary_density {δ : ℝ} (hδ : 0 < δ) {n : ℕ} (hn : 2 * ⌈1 / δ ^ 2⌉₊ ≤ n) + {A : Finset (Fin n → Fin 2)} (hA : δ * (2 : ℝ) ^ n ≤ #A) : + ∃ l : Combinatorics.Line (Fin 2) (Fin n), ∀ a, l a ∈ A := by + by_contra hline + have hB : IsAntichain (· ⊆ ·) (A.image binarySupport : Set (Finset (Fin n))) := by + intro s hs t ht hst hsub + obtain ⟨x, hx, rfl⟩ := mem_image.mp hs + obtain ⟨y, hy, rfl⟩ := mem_image.mp ht + obtain ⟨l, rfl, rfl⟩ := + (binary_line_iff_ssubset x y).2 (Finset.ssubset_iff_subset_ne.2 ⟨hsub, hst⟩) + exact hline ⟨l, Fin.forall_fin_two.2 ⟨hx, hy⟩⟩ + have hcard : #A ≤ n.choose (n / 2) := by + rw [← card_image_of_injective A binarySupport_injective] + simpa using hB.sperner + exact (not_lt_of_ge (hA.trans <| by exact_mod_cast hcard)) (middleBinomial_lt hδ hn) + +/-- The explicit bound for the binary alphabet. -/ +lemma isDHJBound_two : IsDHJBound 2 fun δ ↦ 2 * ⌈1 / δ ^ 2⌉₊ := + fun δ hδ n hn A hA ↦ exists_line_of_binary_density hδ hn (by exact_mod_cast hA) + +/-- The coordinate subspace obtained by fixing every coordinate after the first `m`. -/ +def prefixCoordinateSubspace {α : Type*} {m n : ℕ} (hmn : m ≤ n) + (y : Fin (n - m) → α) : Combinatorics.Subspace (Fin m) α (Fin n) where + idxFun i := ((Subspace.cutEquiv (Nat.add_sub_of_le hmn)).symm i).elim Sum.inr (Sum.inl ∘ y) + proper e := ⟨Subspace.cutEquiv (Nat.add_sub_of_le hmn) (Sum.inl e), by simp⟩ + +@[simp] +lemma prefixCoordinateSubspace_apply {α : Type*} {m n : ℕ} (hmn : m ≤ n) + (y : Fin (n - m) → α) (x : Fin m → α) : + prefixCoordinateSubspace hmn y x = + Sum.elim x y ∘ (Subspace.cutEquiv (Nat.add_sub_of_le hmn)).symm := by + funext i + cases h : (Subspace.cutEquiv (Nat.add_sub_of_le hmn)).symm i <;> + simp [prefixCoordinateSubspace, Combinatorics.Subspace.coe_apply, h] + +/-- A coordinate subspace of any prescribed smaller dimension has relative density at least the +ambient density. -/ +lemma exists_density_preserving_subspace_of_le {k m n : ℕ} (hmn : m ≤ n) + (A : Finset (Fin n → Fin (k + 1))) : + ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), + (A.dens : ℝ) ≤ (Subspace.relativeDensity V A : ℝ) := by + let e := (Equiv.sumComm _ _).trans (Subspace.cutEquiv (Nat.add_sub_of_le hmn)) + obtain ⟨y, -, hy⟩ := exists_le_of_le_expect + (f := fun y ↦ ((fiber (Subspace.splitWords e A) y).dens : ℝ)) univ_nonempty + (by rw [average_density_fiber, Subspace.dens_splitWords]) + refine ⟨prefixCoordinateSubspace hmn y, hy.trans_eq ?_⟩ + congr 2 + ext x + simp [e, ← Function.comp_assoc, Sum.elim_swap] + +/-- One stage of the schedule: a subspace of dimension `d j` and relative density at least +`δ + j * (γ / 2)` gives a line or a subspace of dimension `d (j + 1)` and relative density at +least `δ + (j + 1) * (γ / 2)`, where `γ` is the increment at density `δ`. -/ +lemma density_increment_chain_step {k R n j : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} + (hF : IsDHJBound k F) {δ : ℝ} (hδ : 0 < δ) + {d : ℕ → ℕ} (hd : ∀ t, t ≤ R → 1 ≤ d t) + (hstep : ∀ t, t < R → incrementBound k F (d (t + 1)) δ ≤ d t) + (hj : j < R) {A : Finset (Fin n → Fin (k + 1))} + {V : Combinatorics.Subspace (Fin (d j)) (Fin (k + 1)) (Fin n)} + (hV : δ + (j : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) ≤ + (Subspace.relativeDensity V A : ℝ)) : + (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ + ∃ W : Combinatorics.Subspace (Fin (d (j + 1))) (Fin (k + 1)) (Fin n), + δ + ((j + 1 : ℕ) : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) ≤ + (Subspace.relativeDensity W A : ℝ) := by + have hγ := Parameters.γ_pos hk (F (δ / 4)) hδ + have hδρ : δ ≤ δ + (j : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) := + le_add_of_nonneg_right (by positivity) + obtain ⟨l, hl⟩ | ⟨U, hU⟩ := density_increment hk hF + (hd (j + 1) (Nat.succ_le_of_lt hj)) hδ hδρ + (hV.trans (by rw [← dens_pullback]; exact_mod_cast dens_le_one (s := pullback V A))) + (hstep j hj) + (A := pullback V A) (by simpa [dens_pullback] using hV) + · left + use Subspace.mapLine V l + intro a + simpa [Subspace.mapLine_apply, pullback, parameterPreimage] using hl a + · right + use Subspace.compose V U + rw [Subspace.relativeDensity_compose] + push_cast + linarith + +/-- Iterating the one-step lemma along the schedule either finds a line or reaches the last +scheduled subspace with the accumulated density lower bound. -/ +lemma line_or_density_increment_chain {k R n : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} + (hF : IsDHJBound k F) {δ : ℝ} (hδ : 0 < δ) + {d : ℕ → ℕ} (hd : ∀ j, j ≤ R → 1 ≤ d j) + (hstep : ∀ j, j < R → incrementBound k F (d (j + 1)) δ ≤ d j) + {A : Finset (Fin n → Fin (k + 1))} + {V₀ : Combinatorics.Subspace (Fin (d 0)) (Fin (k + 1)) (Fin n)} + (hV₀ : δ ≤ (Subspace.relativeDensity V₀ A : ℝ)) : + (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ + ∃ V : Combinatorics.Subspace (Fin (d R)) (Fin (k + 1)) (Fin n), + δ + (R : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) ≤ + (Subspace.relativeDensity V A : ℝ) := by + suffices ∀ j, j ≤ R → + (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ + ∃ V : Combinatorics.Subspace (Fin (d j)) (Fin (k + 1)) (Fin n), + δ + (j : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) ≤ + (Subspace.relativeDensity V A : ℝ) by + exact this R le_rfl + intro j hj + induction j with + | zero => + right + exact ⟨V₀, by simpa using hV₀⟩ + | succ j ih => + obtain hline | ⟨V, hV⟩ := ih (Nat.le_of_succ_le hj) + · left + exact hline + · exact density_increment_chain_step hk hF hδ hd hstep (Nat.lt_of_succ_le hj) hV + +/-- Along a schedule of dimensions, a family of density at least `δ` contains a line or +`δ + R * (γ / 2) ≤ 1`, where `γ` is the increment at density `δ`. + +Each increment is applied to the pullback of the family to the current subspace, and the subspaces +are composed. A line in a parameter cube gives a line of the family. Otherwise the relative +density rises by at least `γ / 2` per stage, and it is at most one. -/ +lemma line_or_iterated_density_le_one {k R n : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} + (hF : IsDHJBound k F) {δ : ℝ} (hδ : 0 < δ) {d : ℕ → ℕ} + (hd : ∀ j, j ≤ R → 1 ≤ d j) + (hstep : ∀ j, j < R → incrementBound k F (d (j + 1)) δ ≤ d j) + (hn : d 0 ≤ n) {A : Finset (Fin n → Fin (k + 1))} (hA : δ ≤ (A.dens : ℝ)) : + (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ + δ + (R : ℝ) * (Parameters.γ k (F (δ / 4)) δ / 2) ≤ 1 := by + obtain ⟨V₀, hV₀⟩ := exists_density_preserving_subspace_of_le hn A + obtain hline | ⟨V, hV⟩ := line_or_density_increment_chain hk hF hδ hd hstep (hA.trans hV₀) + · left + exact hline + · right + apply hV.trans + rw [← dens_pullback] + exact_mod_cast dens_le_one (s := pullback V A) + +/-- Every iterate of `max 1 ∘ f` from `1` is at least one. -/ +lemma one_le_iterate_max_one (f : ℕ → ℕ) (t : ℕ) : 1 ≤ (fun d ↦ max 1 (f d))^[t] 1 := by + cases t with + | zero => rfl + | succ t => + rw [Function.iterate_succ_apply'] + exact le_max_left _ _ + +/-- Along the backward schedule `j ↦ (max 1 ∘ f)^[R - j] 1`, each dimension bounds `f` of the +next. -/ +lemma le_iterate_max_one_sub (f : ℕ → ℕ) {R j : ℕ} (hj : j < R) : + f ((fun d ↦ max 1 (f d))^[R - (j + 1)] 1) ≤ (fun d ↦ max 1 (f d))^[R - j] 1 := by + rw [(by omega : R - j = R - (j + 1) + 1), Function.iterate_succ_apply'] + exact le_max_right _ _ + +/-- The density Hales--Jewett bound for `k + 1` letters obtained from a bound `F` for `k` letters: +one density increment for each of the `⌈2 / γ⌉ + 1` stages, with the dimensions chosen backwards +from dimension one. -/ +noncomputable def stepBound (k : ℕ) (F : ℝ → ℕ) (δ : ℝ) : ℕ := + (fun d ↦ max 1 (incrementBound k F d δ))^[⌈2 / Parameters.γ k (F (δ / 4)) δ⌉₊ + 1] 1 + +/-- A bound for `k` letters gives the bound `stepBound k F` for `k + 1` letters: run the density +increment along the backward schedule of dimensions until the density would exceed one. -/ +lemma IsDHJBound.step {k : ℕ} (hk : 2 ≤ k) {F : ℝ → ℕ} (hF : IsDHJBound k F) : + IsDHJBound (k + 1) (stepBound k F) := by + intro δ hδ n hn A hA + let R := ⌈2 / Parameters.γ k (F (δ / 4)) δ⌉₊ + 1 + refine (line_or_iterated_density_le_one hk hF hδ (R := R) + (d := fun j ↦ (fun d ↦ max 1 (incrementBound k F d δ))^[R - j] 1) + (fun _ _ ↦ one_le_iterate_max_one _ _) + (fun _ ↦ le_iterate_max_one_sub (fun d ↦ incrementBound k F d δ)) hn + (Subspace.density_le_of_card_le (Nat.zero_lt_succ k) (mod_cast hA))).resolve_right ?_ + intro h + have hγ := Parameters.γ_pos hk (F (δ / 4)) hδ + have hceil := (div_le_iff₀ hγ).1 (Nat.le_ceil (2 / Parameters.γ k (F (δ / 4)) δ)) + simp only [R, Nat.cast_add_one] at h + nlinarith + +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean index 81ab82410c..b79fcc6fb0 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean @@ -7,10 +7,9 @@ module public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers import Mathlib.Algebra.BigOperators.Field -import Mathlib.Algebra.Order.Archimedean.Real.Basic -import Mathlib.Tactic.FieldSimp -import Mathlib.Tactic.Linarith -import Mathlib.Order.Preorder.Finite +import Mathlib.Data.Set.Finite.Lattice +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Data.NNRat.BigOperators /-! # Insensitive word families and tilings @@ -44,13 +43,28 @@ def transportWords {α ι ι' : Type*} lemma mem_transportWords {α ι ι' : Type*} {e : ι ≃ ι'} {D : Finset (ι → α)} {w : ι' → α} : w ∈ transportWords e D ↔ w ∘ e ∈ D := by - rw [transportWords, Finset.mem_map_equiv] + rw [transportWords, mem_map_equiv] rfl @[simp] lemma dens_transportWords {α ι ι' : Type*} [Fintype (ι → α)] [Fintype (ι' → α)] (e : ι ≃ ι') (D : Finset (ι → α)) : (transportWords e D).dens = D.dens := by - rw [transportWords, Finset.dens_map_equiv] + rw [transportWords, dens_map_equiv] + +/-- Intersecting a family with a subspace range factors its ambient density into relative density +and range density. -/ +lemma Subspace.dens_inter_range {η α ι : Type*} [Fintype (η → α)] [Fintype (ι → α)] + [DecidableEq (ι → α)] (W : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : + ((A ∩ range W).dens : ℝ) = (relativeDensity W A : ℝ) * ((range W).dens : ℝ) := by + classical + have hA : A ∩ range W = (univ.filter fun x ↦ W x ∈ A).image W := by + ext w + simp only [range, mem_inter, mem_image, mem_filter, mem_univ, true_and] + grind + rw [hA, relativeDensity, nnratCast_dens (range W), range, + card_image_of_injective _ (Subspace.injective W), card_univ, ← mul_div_assoc, + nnratCast_dens_mul_natCast_card, nnratCast_dens, + card_image_of_injective _ (Subspace.injective W)] namespace IsInsensitive @@ -90,28 +104,124 @@ noncomputable def uncovered {η α ι : Type*} [Fintype (η → α)] classical exact D.filter fun w ↦ ∀ V ∈ 𝒱, w ∉ Subspace.range V +@[simp] +lemma mem_uncovered {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] + {D : Finset (ι → α)} {𝒱 : Set (Combinatorics.Subspace η α ι)} {w : ι → α} : + w ∈ uncovered D 𝒱 ↔ w ∈ D ∧ ∀ V ∈ 𝒱, w ∉ Subspace.range V := by + simp [uncovered] + +@[simp] +lemma uncovered_empty {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] + (D : Finset (ι → α)) : + uncovered D (∅ : Set (Combinatorics.Subspace η α ι)) = D := by + ext w + simp + +/-- Placing two sets of subspaces one after the other leaves the same part uncovered as placing +both at once. -/ +lemma uncovered_union {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] + (D : Finset (ι → α)) (𝒱 𝒲 : Set (Combinatorics.Subspace η α ι)) : + uncovered D (𝒱 ∪ 𝒲) = uncovered (uncovered D 𝒱) 𝒲 := by + ext w + simp [or_imp, forall_and, and_assoc] + /-- The intersection of a finite indexed family of finite sets. -/ noncomputable def intersection {r : ℕ} {X : Type*} [Fintype X] (D : Fin r → Finset X) : Finset X := by classical - exact Finset.univ.inf D + exact univ.inf D @[simp] lemma mem_intersection {r : ℕ} {X : Type*} [Fintype X] {D : Fin r → Finset X} {x : X} : x ∈ intersection D ↔ ∀ i, x ∈ D i := by - simp [intersection, ← Finset.singleton_subset_iff, Finset.le_inf_iff] + simp [intersection, ← singleton_subset_iff, Finset.le_inf_iff] -/-- An ambient dimension is sufficient for tiling every dense one-pair insensitive family. -/ +/-- Splitting off the last family of an intersection. -/ +lemma intersection_eq_inter_last {r : ℕ} {X : Type*} [Fintype X] [DecidableEq X] + (D : Fin (r + 1) → Finset X) : + intersection D = intersection (fun i ↦ D i.castSucc) ∩ D (Fin.last r) := by + ext x + simp [Fin.forall_fin_succ'] + +/-- `𝒱` is a tiling of part of `D`: a finite family of pairwise disjoint subspaces, all contained +in `D`. -/ +structure IsTiling {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] + (𝒱 : Set (Combinatorics.Subspace η α ι)) (D : Finset (ι → α)) : Prop where + finite : 𝒱.Finite + isContained : ∀ V ∈ 𝒱, Subspace.IsContained V D + pairwiseDisjoint : 𝒱.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (ι → α)) + +namespace IsTiling + +variable {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] {D : Finset (ι → α)} + {𝒱 𝒲 : Set (Combinatorics.Subspace η α ι)} + +lemma empty : IsTiling (∅ : Set (Combinatorics.Subspace η α ι)) D := + ⟨Set.finite_empty, by simp, Set.pairwiseDisjoint_empty⟩ + +/-- A tiling of part of `D`, together with a tiling of part of what it leaves uncovered, is a +tiling of part of `D`. -/ +lemma union (h𝒱 : IsTiling 𝒱 D) (h𝒲 : IsTiling 𝒲 (uncovered D 𝒱)) : + IsTiling (𝒱 ∪ 𝒲) D where + finite := h𝒱.finite.union h𝒲.finite + isContained := by + rintro V (hV | hV) x + · exact h𝒱.isContained V hV x + · exact (mem_uncovered.1 (h𝒲.isContained V hV x)).1 + pairwiseDisjoint := by + refine h𝒱.pairwiseDisjoint.union h𝒲.pairwiseDisjoint ?_ + intro V hV W hW _ + rw [Set.disjoint_left] + intro w hwV hwW + obtain ⟨x, rfl⟩ := Subspace.mem_range.1 hwW + exact (mem_uncovered.1 (h𝒲.isContained W hW x)).2 V hV hwV + +/-- The part of `D` covered by a tiling is the union of its subspaces. -/ +lemma sdiff_uncovered_eq_biUnion (h : IsTiling 𝒱 D) : + D \ uncovered D 𝒱 = h.finite.toFinset.biUnion Subspace.range := by + ext x + simp only [mem_sdiff, mem_uncovered, mem_biUnion, Set.Finite.mem_toFinset, Subspace.mem_range, + not_and, not_forall, not_not, exists_prop] + constructor + · rintro ⟨hx, hcovered⟩ + exact hcovered hx + · rintro ⟨V, hV, y, rfl⟩ + exact ⟨h.isContained V hV y, fun _ ↦ ⟨V, hV, y, rfl⟩⟩ + +/-- The subspaces of a tiling split every family along the part of `D` they cover. -/ +lemma sum_dens_inter_range [Fintype (ι → α)] (h : IsTiling 𝒱 D) (B : Finset (ι → α)) : + ∑ W ∈ h.finite.toFinset, ((B ∩ Subspace.range W).dens : ℝ) = + ((B ∩ (D \ uncovered D 𝒱)).dens : ℝ) := by + rw [h.sdiff_uncovered_eq_biUnion, inter_biUnion, dens_biUnion, NNRat.cast_sum] + intro V hV W hW hVW + exact (disjoint_coe.1 (h.pairwiseDisjoint (by simpa using hV) (by simpa using hW) hVW)).mono + inter_subset_right inter_subset_right + +/-- If `A` has density at least `ε` relative to the nonempty part of `D` covered by a tiling, then +it has relative density at least `ε` in one of its subspaces. -/ +lemma exists_le_relativeDensity [Fintype (ι → α)] [Nonempty α] (h : IsTiling 𝒱 D) + {A : Finset (ι → α)} {ε : ℝ} + (hne : (D \ uncovered D 𝒱).Nonempty) + (hA : ε * ((D \ uncovered D 𝒱).dens : ℝ) ≤ ((A ∩ (D \ uncovered D 𝒱)).dens : ℝ)) : + ∃ W ∈ 𝒱, ε ≤ (Subspace.relativeDensity W A : ℝ) := by + have hD := h.sum_dens_inter_range univ + simp only [univ_inter] at hD + rw [← hD, ← h.sum_dens_inter_range A, mul_sum] at hA + obtain ⟨V, hV, -⟩ := biUnion_nonempty.1 (h.sdiff_uncovered_eq_biUnion ▸ hne) + obtain ⟨W, hW, hle⟩ := exists_le_of_sum_le ⟨V, hV⟩ hA + rw [Subspace.dens_inter_range] at hle + exact ⟨W, by simpa using hW, le_of_mul_le_mul_right hle + (mod_cast dens_pos.2 ⟨_, Subspace.mem_range.2 ⟨Classical.arbitrary _, rfl⟩⟩)⟩ + +end IsTiling + +/-- An ambient dimension is sufficient for tiling one-pair insensitive families: each of them has a +tiling by `m`-dimensional subspaces leaving density less than `2 * β` uncovered. -/ def TilingSufficient (k m : ℕ) (β : ℝ) (n : ℕ) : Prop := - ∀ i : Fin k, ∀ D : Finset (Fin n → Fin (k + 1)), - IsInsensitive i.castSucc (Fin.last k) D → - 2 * β ≤ (D.dens : ℝ) → + ∀ i : Fin k, ∀ D : Finset (Fin n → Fin (k + 1)), IsInsensitive i.castSucc (Fin.last k) D → ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)), - 𝒱.Finite ∧ - (∀ V ∈ 𝒱, Subspace.IsContained V D) ∧ - (𝒱.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (Fin n → Fin (k + 1)))) ∧ - ((uncovered D 𝒱).dens : ℝ) < 2 * β + IsTiling 𝒱 D ∧ ((uncovered D 𝒱).dens : ℝ) < 2 * β /-- Differences preserve insensitivity. -/ lemma sdiff {α ι : Type*} [DecidableEq (ι → α)] @@ -135,44 +245,45 @@ lemma fiber_congr {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ end IsInsensitive -/-- Regrouping the coordinates of a word with a fixed prefix and a split tail. -/ -private lemma concat_comp_regroup {α ω ν ν₁ ν₂ : Type*} (s : ν ≃ ν₁ ⊕ ν₂) +/-- Regroup the coordinates `ω ⊕ ν` as `(ω ⊕ ν₁) ⊕ ν₂` along a splitting `s : ν ≃ ν₁ ⊕ ν₂`. -/ +private def regroup {ι ω ν ν₁ ν₂ : Type*} (e : ι ≃ ω ⊕ ν) (s : ν ≃ ν₁ ⊕ ν₂) : + ι ≃ (ω ⊕ ν₁) ⊕ ν₂ := + e.trans (((Equiv.refl ω).sumCongr s).trans (Equiv.sumAssoc ω ν₁ ν₂).symm) + +private lemma concat_comp_regroup {α ι ω ν ν₁ ν₂ : Type*} (e : ι ≃ ω ⊕ ν) (s : ν ≃ ν₁ ⊕ ν₂) (u : ω → α) (r : ν₁ → α) (x : ν₂ → α) : - Sum.elim (Sum.elim u r) x ∘ - (((Equiv.refl ω).sumCongr s).trans (Equiv.sumAssoc ω ν₁ ν₂).symm) = - Sum.elim u (Sum.elim r x ∘ s) := by + Sum.elim (Sum.elim u r) x ∘ regroup e s = Sum.elim u (Sum.elim r x ∘ s) ∘ e := by funext c - cases c with + simp only [regroup, Function.comp_apply, Equiv.trans_apply] + cases e c with | inl a => simp [Equiv.sumAssoc] | inr n => cases hn : s n <;> simp [Equiv.sumAssoc, hn] -/-- The same regrouping stated after a coordinate splitting of the ambient type. -/ -private lemma concat_comp_regroup_trans {α ι ω ν ν₁ ν₂ : Type*} (e : ι ≃ ω ⊕ ν) - (s : ν ≃ ν₁ ⊕ ν₂) (u : ω → α) (r : ν₁ → α) (x : ν₂ → α) : - Sum.elim (Sum.elim u r) x ∘ - (e.trans (((Equiv.refl ω).sumCongr s).trans (Equiv.sumAssoc ω ν₁ ν₂).symm)) = - Sum.elim u (Sum.elim r x ∘ s) ∘ e := by - rw [← concat_comp_regroup s u r x] - rfl - -/-- Sections over the last block of a split tail are sections of sections. -/ +/-- Sections over the outer coordinates and a first block are sections of sections. -/ private lemma fiber_transportWords_regroup {α ι ω ν ν₁ ν₂ : Type*} [Fintype α] [DecidableEq α] [Fintype ω] [Fintype ν] [DecidableEq ν] [Fintype ν₁] [Fintype ν₂] [DecidableEq ν₂] (e : ι ≃ ω ⊕ ν) (s : ν ≃ ν₁ ⊕ ν₂) (U : Finset (ι → α)) (u : ω → α) (r : ν₁ → α) : - DensityHalesJewett.fiber - (transportWords (e.trans (((Equiv.refl ω).sumCongr s).trans - (Equiv.sumAssoc ω ν₁ ν₂).symm)) U) (Sum.elim u r) = + DensityHalesJewett.fiber (transportWords (regroup e s) U) (Sum.elim u r) = DensityHalesJewett.fiber (transportWords s (DensityHalesJewett.fiber (transportWords e U) u)) r := by ext x - simp only [mem_fiber, mem_transportWords, concat_comp_regroup_trans] - -/-- A word is the concatenation of its parts along a coordinate splitting. -/ -private lemma eq_concat_parts {α ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (w : ι → α) : - Sum.elim (fun a ↦ w (e.symm (Sum.inl a))) - (fun n ↦ w (e.symm (Sum.inr n))) ∘ e = w := by - simpa [Function.comp_def] using congrArg (· ∘ e) (Sum.elim_comp_inl_inr (w ∘ e.symm)) + simp only [mem_fiber, mem_transportWords, concat_comp_regroup] + +/-- Moving the last block into the outer coordinates exchanges the roles of the two blocks. -/ +private lemma mem_fiber_regroup_sumComm {α ι ω ν ν₁ ν₂ : Type*} + [Fintype α] [DecidableEq α] [Fintype ω] [Fintype ν₁] [DecidableEq ν₁] [Fintype ν₂] + [DecidableEq ν₂] + (e : ι ≃ ω ⊕ ν) (s : ν ≃ ν₁ ⊕ ν₂) (X : Finset (ι → α)) (u : ω → α) (y : ν₁ → α) + (x : ν₂ → α) : + y ∈ DensityHalesJewett.fiber + (transportWords (regroup e (s.trans (Equiv.sumComm ν₁ ν₂))) X) (Sum.elim u x) ↔ + x ∈ DensityHalesJewett.fiber (transportWords (regroup e s) X) (Sum.elim u y) := by + have hswap : Sum.elim x y ∘ s.trans (Equiv.sumComm ν₁ ν₂) = Sum.elim y x ∘ s := by + funext c + simp only [Function.comp_apply, Equiv.trans_apply] + cases s c <;> rfl + simp only [mem_fiber, mem_transportWords, concat_comp_regroup, hswap] /-- Sections commute with set difference. -/ private lemma fiber_transportWords_sdiff {α ι ω ν : Type*} @@ -183,37 +294,38 @@ private lemma fiber_transportWords_sdiff {α ι ω ν : Type*} DensityHalesJewett.fiber (transportWords e A) v \ DensityHalesJewett.fiber (transportWords e B) v := by ext y - simp only [Finset.mem_sdiff, mem_fiber, mem_transportWords] + simp only [mem_sdiff, mem_fiber, mem_transportWords] /-- Removing a subset from a family subtracts its density. -/ private lemma dens_sdiff_of_subset {X : Type*} [Fintype X] [DecidableEq X] {A B : Finset X} (h : B ⊆ A) : (((A \ B).dens : ℝ)) = (A.dens : ℝ) - (B.dens : ℝ) := by - push_cast [← Finset.dens_sdiff_add_dens_eq_dens h] + push_cast [← dens_sdiff_add_dens_eq_dens h] ring /-- A nonempty family occupies at least one point of the ambient cube. -/ private lemma one_div_card_le_dens {X : Type*} [Fintype X] {A : Finset X} (h : A.Nonempty) : 1 / (Fintype.card X : ℝ) ≤ (A.dens : ℝ) := by - rw [Finset.nnratCast_dens] + rw [nnratCast_dens] gcongr exact_mod_cast h.card_pos /-- An insensitive family that is dense in a large enough block contains a full subspace: the -restricted-alphabet subspace lemma supplies the `Fin k`-restricted range, and insensitivity -upgrades containment to the whole parameter cube. -/ -lemma exists_isContained_of_insensitive {k m b : ℕ} (hDHJ : HasDensityHJ k) (hm : 1 ≤ m) - (i : Fin k) {β : ℝ} (hβ : 0 < β) (hb : Subspace.restrictAlphabetBound k m β ≤ b) - (E : Finset (Fin b → Fin (k + 1))) +restricted-alphabet subspace lemma gives the `Fin k`-restricted range, and insensitivity +extends containment to the whole parameter cube. -/ +lemma exists_isContained_of_insensitive {k m b : ℕ} {F : ℝ → ℕ} (hF : IsDHJBound k F) + (hm : 1 ≤ m) {i : Fin k} {β : ℝ} (hβ : 0 < β) + (hb : Subspace.restrictAlphabetBound k F m β ≤ b) + {E : Finset (Fin b → Fin (k + 1))} (hE : IsInsensitive i.castSucc (Fin.last k) E) (hdens : β ≤ (E.dens : ℝ)) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), Subspace.IsContained V E := by obtain ⟨V, hV⟩ := - Subspace.exists_restrictAlphabet_subset hDHJ m hm β hβ b hb E - (by exact_mod_cast Subspace.card_le_of_density_le (k := k + 1) (Nat.succ_pos k) β E hdens) - refine ⟨V, ?_⟩ + Subspace.exists_restrictAlphabet_subset i.pos hF hm hβ hb + (by exact_mod_cast Subspace.card_le_of_density_le (Nat.succ_pos k) hdens) + use V intro x refine (hE ?_).mpr - (hV (Finset.mem_image.mpr ⟨fun e ↦ if h : x e = Fin.last k then i else (x e).castPred h, - Finset.mem_univ _, rfl⟩)) + (hV (mem_image.mpr ⟨fun e ↦ if h : x e = Fin.last k then i else (x e).castPred h, + mem_univ _, rfl⟩)) intro a hai hal c cases hc : V.idxFun c with | inl t => simp only [V.apply_inl hc] @@ -228,19 +340,6 @@ lemma exists_isContained_of_insensitive {k m b : ℕ} (hDHJ : HasDensityHJ k) (h exact hai h.symm · rw [dite_eq_right hx, Fin.castSuccEmb_apply, Fin.castSucc_castPred] -/-- The two block orders describe the same ambient word. -/ -private lemma concat_comp_swap {α ι ω ν ν₁ ν₂ : Type*} (e : ι ≃ ω ⊕ ν) (s : ν ≃ ν₁ ⊕ ν₂) - (u : ω → α) (y : ν₁ → α) (x : ν₂ → α) : - Sum.elim (Sum.elim u y) x ∘ - (e.trans (((Equiv.refl ω).sumCongr s).trans (Equiv.sumAssoc ω ν₁ ν₂).symm)) = - Sum.elim (Sum.elim u x) y ∘ - (e.trans (((Equiv.refl ω).sumCongr (s.trans (Equiv.sumComm ν₁ ν₂))).trans - (Equiv.sumAssoc ω ν₂ ν₁).symm)) := by - rw [concat_comp_regroup_trans, concat_comp_regroup_trans] - refine congrArg (· ∘ e) (congrArg (Sum.elim u) ?_) - funext n - cases hn : s n <;> simp [hn] - /-- A canonical subspace contained in a family, depending on nothing but the family. -/ noncomputable def pickSubspace {k m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) (E : Finset (Fin b → Fin (k + 1))) : @@ -261,224 +360,92 @@ lemma pickSubspace_isContained {k m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) namespace IsInsensitive -/-- Nothing is covered by an empty family of subspaces. -/ -@[simp] -private lemma uncovered_empty {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] - (D : Finset (ι → α)) : - uncovered D (∅ : Set (Combinatorics.Subspace η α ι)) = D := by - simp only [uncovered, Set.mem_empty_iff_false, false_implies, implies_true, - Finset.filter_true_of_mem] - -/-- Fix an initial coordinate block and place a subspace on the remaining coordinates. -/ -private def padExtraSubspace {α η : Type*} {r N n : ℕ} - (e : Fin r ⊕ Fin N ≃ Fin n) (z : Fin r → α) - (V : Combinatorics.Subspace η α (Fin N)) : - Combinatorics.Subspace η α (Fin n) := - transportSubspace e.symm z V - -@[simp] -private lemma padExtraSubspace_apply {α η : Type*} {r N n : ℕ} - (e : Fin r ⊕ Fin N ≃ Fin n) (z : Fin r → α) - (V : Combinatorics.Subspace η α (Fin N)) (x : η → α) : - padExtraSubspace e z V x = - Sum.elim z (V x) ∘ e.symm := - transportSubspace_apply e.symm z V x - -/-- Fiberwise tiles remain finite, contained, and disjoint after their fixed prefixes are padded -back into the ambient cube. -/ -private lemma padded_tiles_facts {α η : Type*} [Fintype α] [Fintype (η → α)] - [DecidableEq α] {r N n : ℕ} - (e : Fin r ⊕ Fin N ≃ Fin n) (D : Finset (Fin n → α)) - (tiles : (Fin r → α) → Set (Combinatorics.Subspace η α (Fin N))) - (hfinite : ∀ z, (tiles z).Finite) - (hcontained : ∀ z V, V ∈ tiles z → - Subspace.IsContained V (fiber (D.map - (e.arrowCongr (Equiv.refl α)).symm.toEmbedding) z)) - (hpairwise : ∀ z, (tiles z).PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (Fin N → α))) : - let global : Set (Combinatorics.Subspace η α (Fin n)) := - ⋃ z, padExtraSubspace e z '' tiles z - global.Finite ∧ - (∀ V ∈ global, Subspace.IsContained V D) ∧ - (global.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (Fin n → α))) := by - classical - dsimp only - refine ⟨Set.finite_iUnion fun z ↦ (hfinite z).image (padExtraSubspace e z), ?_, ?_⟩ - · intro U hU x - simp only [Set.mem_iUnion, Set.mem_image] at hU - obtain ⟨z, V, hV, rfl⟩ := hU - have hx := hcontained z V hV x - simp only [mem_fiber, Finset.mem_map_equiv, Equiv.symm_symm] at hx - simpa [padExtraSubspace_apply, Equiv.arrowCongr] using hx - · rw [Set.pairwiseDisjoint_iff] - intro U hU U' hU' hcommon - simp only [Set.mem_iUnion, Set.mem_image] at hU hU' - obtain ⟨z, V, hV, rfl⟩ := hU - obtain ⟨z', V', hV', rfl⟩ := hU' - obtain ⟨w, hw, hw'⟩ := hcommon - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hw - obtain ⟨x', hx'⟩ := Subspace.mem_range.mp hw' - have hzx : Sum.elim z (V x) = Sum.elim z' (V' x') := by - funext c - simpa only [padExtraSubspace_apply, Function.comp_apply, Equiv.symm_apply_apply] using - congrFun (hx.trans hx'.symm) (e c) - have hzz : z = z' := funext fun j ↦ congrFun hzx (Sum.inl j) - subst z' - apply congrArg (padExtraSubspace e z) - apply Set.pairwiseDisjoint_iff.mp (hpairwise z) hV hV' - refine ⟨V x, Subspace.mem_range.mpr ⟨x, rfl⟩, - Subspace.mem_range.mpr ⟨x', ?_⟩⟩ - exact funext fun j ↦ (congrFun hzx (Sum.inr j)).symm - -/-- After padding fiberwise tiles, the uncovered part of each fiber is exactly the uncovered part -of the corresponding local family. -/ -private lemma fiber_uncovered_padded {α η : Type*} [Fintype α] [Fintype (η → α)] - [DecidableEq α] {r N n : ℕ} - (e : Fin r ⊕ Fin N ≃ Fin n) (D : Finset (Fin n → α)) - (tiles : (Fin r → α) → Set (Combinatorics.Subspace η α (Fin N))) - (z : Fin r → α) : - let wordEquiv := e.arrowCongr (Equiv.refl α) - let global : Set (Combinatorics.Subspace η α (Fin n)) := - ⋃ z, padExtraSubspace e z '' tiles z - fiber ((uncovered D global).map wordEquiv.symm.toEmbedding) z = - uncovered (fiber (D.map wordEquiv.symm.toEmbedding) z) (tiles z) := by - classical - dsimp only +/-- Place, over each word `z` on the outer coordinates, the subspaces `tiles z` of the block +coordinates. -/ +def placeTiles {α η ι ζ ν : Type*} (e : ι ≃ ζ ⊕ ν) + (tiles : (ζ → α) → Set (Combinatorics.Subspace η α ν)) : + Set (Combinatorics.Subspace η α ι) := + ⋃ z, transportSubspace e z '' tiles z + +private lemma elim_comp_eq_elim_comp_iff {α ι ζ ν : Type*} {e : ι ≃ ζ ⊕ ν} {a a' : ζ → α} + {b b' : ν → α} : Sum.elim a b ∘ e = Sum.elim a' b' ∘ e ↔ a = a' ∧ b = b' := by + rw [e.surjective.injective_comp_right.eq_iff] + constructor + · intro h + exact ⟨funext fun c ↦ congrFun h (.inl c), funext fun c ↦ congrFun h (.inr c)⟩ + · rintro ⟨rfl, rfl⟩ + rfl + +variable {k m : ℕ} + +/-- Tilings of the sections over the outer coordinates, placed over their outer words, form a +tiling of the whole family. -/ +lemma IsTiling.placeTiles {ι ζ ν : Type*} [Fintype ι] [Fintype ζ] [Fintype ν] [DecidableEq ν] + {e : ι ≃ ζ ⊕ ν} {D : Finset (ι → Fin (k + 1))} + {tiles : (ζ → Fin (k + 1)) → Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ν)} + (h : ∀ z, IsTiling (tiles z) (fiber (transportWords e D) z)) : + IsTiling (placeTiles e tiles) D where + finite := Set.finite_iUnion fun z ↦ (h z).finite.image _ + isContained := by + simp only [IsInsensitive.placeTiles, Set.mem_iUnion, Set.mem_image] + rintro _ ⟨z, W, hW, rfl⟩ x + simpa using (h z).isContained W hW x + pairwiseDisjoint := by + rw [Set.pairwiseDisjoint_iff] + simp only [IsInsensitive.placeTiles, Set.mem_iUnion, Set.mem_image] + rintro _ ⟨z, W, hW, rfl⟩ _ ⟨z', W', hW', rfl⟩ ⟨w, hw, hw'⟩ + obtain ⟨x, rfl⟩ := Subspace.mem_range.1 hw + obtain ⟨x', hx'⟩ := Subspace.mem_range.1 hw' + rw [transportSubspace_apply, transportSubspace_apply, elim_comp_eq_elim_comp_iff] at hx' + obtain ⟨rfl, hx'⟩ := hx' + rw [Set.pairwiseDisjoint_iff.1 (h z').pairwiseDisjoint hW hW' + ⟨W x, Subspace.mem_range.2 ⟨x, rfl⟩, Subspace.mem_range.2 ⟨x', hx'⟩⟩] + +/-- The section of the uncovered part over an outer word is the part of the section that its own +tiles leave uncovered. -/ +lemma fiber_uncovered_placeTiles {ι ζ ν : Type*} [Fintype ι] [Fintype ζ] [Fintype ν] + [DecidableEq ν] (e : ι ≃ ζ ⊕ ν) (D : Finset (ι → Fin (k + 1))) + (tiles : (ζ → Fin (k + 1)) → Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ν)) + (z : ζ → Fin (k + 1)) : + fiber (transportWords e (uncovered D (placeTiles e tiles))) z = + uncovered (fiber (transportWords e D) z) (tiles z) := by ext y - simp only [mem_fiber, Finset.mem_map_equiv, uncovered, Finset.mem_filter] + simp only [mem_fiber, mem_transportWords, mem_uncovered, IsInsensitive.placeTiles, + Set.mem_iUnion, Set.mem_image, forall_exists_index, and_imp] + rw [and_congr_right_iff] + intro _ constructor - · rintro ⟨hyD, hyfree⟩ - refine ⟨hyD, ?_⟩ - intro V hV hyV - apply hyfree (padExtraSubspace e z V) - · exact Set.mem_iUnion_of_mem z <| Set.mem_image_of_mem _ hV - · obtain ⟨x, hx⟩ := Subspace.mem_range.mp hyV - exact Subspace.mem_range.mpr ⟨x, by - simp [padExtraSubspace_apply, Equiv.arrowCongr, hx]⟩ - · rintro ⟨hyD, hyfree⟩ - refine ⟨hyD, ?_⟩ - intro U hU hyU - simp only [Set.mem_iUnion, Set.mem_image] at hU - obtain ⟨z', V, hV, rfl⟩ := hU - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hyU - have hconcat : Sum.elim z y = Sum.elim z' (V x) := by - apply (e.arrowCongr (Equiv.refl α)).injective - simpa [padExtraSubspace_apply, Equiv.arrowCongr] using hx.symm - have hzz : z = z' := funext fun j ↦ congrFun hconcat (Sum.inl j) - subst z' - apply hyfree V hV - refine Subspace.mem_range.mpr ⟨x, funext ?_⟩ - intro j - exact (congrFun hconcat (Sum.inr j)).symm - -/-- Merge the tiles removed at one packing stage with a recursive tiling of the remainder. -/ -private lemma combine_tiling_stage {ι : Type*} [Fintype ι] [DecidableEq ι] - {k m S : ℕ} {β c : ℝ} - (U R : Finset (ι → Fin (k + 1))) - (newTiles oldTiles : Set - (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι)) - (hnewfinite : newTiles.Finite) (holdfinite : oldTiles.Finite) - (hRU : R ⊆ U) - (hnewcontained : ∀ V ∈ newTiles, Subspace.IsContained V R) - (hRcovered : ∀ w ∈ R, ∃ V ∈ newTiles, w ∈ Subspace.range V) - (hnewdisjoint : newTiles.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (ι → Fin (k + 1)))) - (holdcontained : ∀ V ∈ oldTiles, Subspace.IsContained V (U \ R)) - (holddisjoint : oldTiles.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (ι → Fin (k + 1)))) - (hRdens : c ≤ (R.dens : ℝ)) - (holdconclusion : ((uncovered (U \ R) oldTiles).dens : ℝ) < 2 * β ∨ - ((uncovered (U \ R) oldTiles).dens : ℝ) + S * c ≤ ((U \ R).dens : ℝ)) : - let allTiles := newTiles ∪ oldTiles - allTiles.Finite ∧ - (∀ V ∈ allTiles, Subspace.IsContained V U) ∧ - (allTiles.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (ι → Fin (k + 1)))) ∧ - (((uncovered U allTiles).dens : ℝ) < 2 * β ∨ - ((uncovered U allTiles).dens : ℝ) + (S + 1) * c ≤ (U.dens : ℝ)) := by + · intro h W hW hyW + obtain ⟨x, rfl⟩ := Subspace.mem_range.1 hyW + exact h _ z W hW rfl (Subspace.mem_range.2 ⟨x, by simp⟩) + · rintro h _ z' W hW rfl hyW + obtain ⟨x, hx⟩ := Subspace.mem_range.1 hyW + rw [transportSubspace_apply, elim_comp_eq_elim_comp_iff] at hx + obtain ⟨rfl, rfl⟩ := hx + exact h W hW (Subspace.mem_range.2 ⟨x, rfl⟩) + +/-- Tilings of the sections over the outer coordinates, each leaving density less than `c` +uncovered, give a tiling of the whole family leaving density less than `c` uncovered. -/ +private lemma exists_tiling_of_sections {ι ζ ν : Type*} [Fintype ι] [DecidableEq ι] [Fintype ζ] + [Fintype ν] [DecidableEq ν] {e : ι ≃ ζ ⊕ ν} {D : Finset (ι → Fin (k + 1))} {c : ℝ} + (h : ∀ z, ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ν), + IsTiling 𝒱 (fiber (transportWords e D) z) ∧ + ((uncovered (fiber (transportWords e D) z) 𝒱).dens : ℝ) < c) : + ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι), + IsTiling 𝒱 D ∧ ((uncovered D 𝒱).dens : ℝ) < c := by classical - dsimp only - refine ⟨hnewfinite.union holdfinite, ?_, ?_, ?_⟩ - · intro V hV - rcases hV with hV | hV - · intro x - exact hRU (hnewcontained V hV x) - · intro x - exact (Finset.mem_sdiff.mp (holdcontained V hV x)).1 - · apply Set.PairwiseDisjoint.union hnewdisjoint holddisjoint - intro V hV V' hV' _ - rw [Set.disjoint_left] - intro w hw hw' - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hw - obtain ⟨x', hx'⟩ := Subspace.mem_range.mp hw' - exact (Finset.mem_sdiff.mp (hx' ▸ holdcontained V' hV' x')).2 - (hx ▸ hnewcontained V hV x) - · have huncovered : uncovered U (newTiles ∪ oldTiles) = - uncovered (U \ R) oldTiles := by - ext w - simp only [uncovered, Finset.mem_filter, Finset.mem_sdiff, Set.mem_union] - grind [Subspace.mem_range, Subspace.IsContained] - rw [huncovered] - rcases holdconclusion with hlt | hle - · left - exact hlt - · right - rw [dens_sdiff_of_subset hRU] at hle - nlinarith - -/-- The canonical tile in each good fiber lies in the filtered region, and these tiles cover that -region. -/ -private lemma canonical_tiles_cover {k m b : ℕ} {ι ζ : Type*} - [Fintype ι] [Fintype ζ] - [DecidableEq (ζ → Fin (k + 1))] - (hm : 1 ≤ m) (hmb : m ≤ b) (e : ι ≃ ζ ⊕ Fin b) - (U : Finset (ι → Fin (k + 1))) - (B : (ζ → Fin (k + 1)) → Finset (Fin b → Fin (k + 1))) - (hB : B = fun z ↦ fiber (transportWords e U) z) - (good : Finset (ζ → Fin (k + 1))) - (tile : (ζ → Fin (k + 1)) → - Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) - (htile : tile = fun z ↦ transportSubspace e z (pickSubspace hm hmb (B z))) - (hpick : ∀ z ∈ good, Subspace.IsContained (pickSubspace hm hmb (B z)) (B z)) - (R : Finset (ι → Fin (k + 1))) - (hR : R = U.filter fun w ↦ - (fun a ↦ w (e.symm (Sum.inl a))) ∈ good ∧ - (fun j ↦ w (e.symm (Sum.inr j))) ∈ - Subspace.range (pickSubspace hm hmb (B (fun a ↦ w (e.symm (Sum.inl a)))))) : - (∀ z ∈ good, Subspace.IsContained (tile z) R) ∧ - (∀ w ∈ R, ∃ z ∈ good, w ∈ Subspace.range (tile z)) := by - classical - subst B - constructor - · intro z hz x - have hmemU : tile z x ∈ U := by - simpa only [htile, transportSubspace_apply, mem_fiber, mem_transportWords] using - hpick z hz x - have hparts : (fun a ↦ tile z x (e.symm (Sum.inl a))) = z := by - funext a - simp only [htile, transportSubspace_apply, Function.comp_apply, - Equiv.apply_symm_apply, Sum.elim_inl] - rw [hR, Finset.mem_filter] - refine ⟨hmemU, hparts.symm ▸ hz, ?_⟩ - rw [hparts] - refine Subspace.mem_range.mpr ⟨x, ?_⟩ - funext j - simp only [htile, transportSubspace_apply, Function.comp_apply, - Equiv.apply_symm_apply, Sum.elim_inr] - · intro w hw - rw [hR, Finset.mem_filter] at hw - obtain ⟨_, hz, hrange⟩ := hw - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hrange - refine ⟨_, hz, Subspace.mem_range.mpr ⟨x, ?_⟩⟩ - rw [htile, transportSubspace_apply, hx] - exact eq_concat_parts e w + choose tiles htiles hc using h + refine ⟨placeTiles e tiles, .placeTiles htiles, ?_⟩ + rw [← dens_transportWords e, ← average_density_fiber] + simp_rw [fiber_uncovered_placeTiles] + exact expect_lt (fun z _ ↦ (hc z).le) ⟨fun _ ↦ 0, mem_univ _, hc _⟩ /-- A positive-density set of nonempty fibers gives a proportional ambient density lower bound. -/ private lemma density_of_nonempty_fibers {k b : ℕ} {ι ζ : Type*} [Fintype ι] [DecidableEq ι] [Fintype ζ] [Fintype (ζ → Fin (k + 1))] - (e : ι ≃ ζ ⊕ Fin b) (R : Finset (ι → Fin (k + 1))) - (good : Finset (ζ → Fin (k + 1))) {β : ℝ} + {e : ι ≃ ζ ⊕ Fin b} {R : Finset (ι → Fin (k + 1))} + {good : Finset (ζ → Fin (k + 1))} {β : ℝ} (hgood : β ≤ (good.dens : ℝ)) (hnonempty : ∀ z ∈ good, (fiber (transportWords e R) z).Nonempty) : β / ((k : ℝ) + 1) ^ b ≤ (R.dens : ℝ) := by @@ -495,339 +462,176 @@ private lemma density_of_nonempty_fibers {k b : ℕ} {ι ζ : Type*} rw [average_density_fiber, dens_transportWords] rw [haverage, div_eq_mul_inv, mul_comm β (((k : ℝ) + 1) ^ b)⁻¹, ← one_div] apply le_trans (mul_le_mul_of_nonneg_left hgood (by positivity)) - rw [← Finset.expect_indicator_one (s := good), Finset.mul_expect] - apply Finset.expect_le_expect + rw [← expect_indicator_one (s := good), mul_expect] + apply expect_le_expect intro z _ by_cases hz : z ∈ good · rw [Set.indicator_of_mem (by simpa using hz)] - simpa only [Pi.one_apply, mul_one] using hfiber z hz + simpa [Pi.one_apply, mul_one] using hfiber z hz · rw [Set.indicator_of_notMem (by simpa using hz), mul_zero] positivity -/-- Removing the canonical tiles chosen in one fresh block preserves insensitivity in every -section over the blocks that remain. -/ -private lemma canonical_remainder_sections_insensitive {k m S b : ℕ} (i : Fin k) - {ι ω : Type*} [Fintype ι] [Fintype ω] - (hm : 1 ≤ m) (hmb : m ≤ b) - (e₁ : ι ≃ (ω ⊕ Fin (S * b)) ⊕ Fin b) - (e₂ : ι ≃ (ω ⊕ Fin b) ⊕ Fin (S * b)) - (U : Finset (ι → Fin (k + 1))) - (B : (ω ⊕ Fin (S * b) → Fin (k + 1)) → Finset (Fin b → Fin (k + 1))) - (good : Finset (ω ⊕ Fin (S * b) → Fin (k + 1))) - (R : Finset (ι → Fin (k + 1))) - (hR : R = U.filter fun w ↦ - (fun a ↦ w (e₁.symm (Sum.inl a))) ∈ good ∧ - (fun j ↦ w (e₁.symm (Sum.inr j))) ∈ - Subspace.range (pickSubspace hm hmb (B (fun a ↦ w (e₁.symm (Sum.inl a)))))) - (hU : ∀ v, IsInsensitive i.castSucc (Fin.last k) (fiber (transportWords e₂ U) v)) - (hBcongr : ∀ u y y', InsensitiveEquiv i.castSucc (Fin.last k) y y' → - B (Sum.elim u y) = B (Sum.elim u y')) - (hgood : ∀ u y y', B (Sum.elim u y) = B (Sum.elim u y') → - (Sum.elim u y ∈ good ↔ Sum.elim u y' ∈ good)) - (hswap : ∀ (v : ω ⊕ Fin b → Fin (k + 1)) y, - Sum.elim v y ∘ e₂ = - Sum.elim (Sum.elim (fun a ↦ v (Sum.inl a)) y) - (fun j ↦ v (Sum.inr j)) ∘ e₁) : - ∀ v, IsInsensitive i.castSucc (Fin.last k) (fiber (transportWords e₂ (U \ R)) v) := by +/-- The subspace chosen by `pickSubspace` in a family of density at least `β`, as a set of tiles +with at most one element. -/ +noncomputable def pickTiles {b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) (β : ℝ) + (E : Finset (Fin b → Fin (k + 1))) : + Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b)) := + {V | β ≤ (E.dens : ℝ) ∧ V = pickSubspace hm hmb E} + +private lemma isTiling_pickTiles {b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) {β : ℝ} + {E : Finset (Fin b → Fin (k + 1))} + (hE : β ≤ (E.dens : ℝ) → + ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), Subspace.IsContained V E) : + IsTiling (pickTiles hm hmb β E) E where + finite := (Set.finite_singleton (pickSubspace hm hmb E)).subset fun _ hV ↦ hV.2 + isContained := by + rintro _ ⟨hβ, rfl⟩ + exact pickSubspace_isContained hm hmb (hE hβ) + pairwiseDisjoint := + (Set.subsingleton_singleton.anti fun _ hV ↦ hV.2 : + (pickTiles hm hmb β E).Subsingleton).pairwise _ + +/-- One stage of the tiling of a family of density at least `2 * β`: the tiles `pickTiles` +chooses in the sections over a block of `b` coordinates cover density at least +`β / (k + 1) ^ b`. -/ +private lemma dens_uncovered_pickTiles_add_le {b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) {β : ℝ} + (hβ₀ : 0 < β) (hβ₁ : β < 1) {ι ζ : Type*} [Fintype ι] [DecidableEq ι] [Fintype ζ] + {e : ι ≃ ζ ⊕ Fin b} {U : Finset (ι → Fin (k + 1))} + (hU : 2 * β ≤ (U.dens : ℝ)) + (htiles : ∀ z, IsTiling (pickTiles hm hmb β (fiber (transportWords e U) z)) + (fiber (transportWords e U) z)) : + ((uncovered U (placeTiles e fun z ↦ pickTiles hm hmb β (fiber (transportWords e U) z))).dens + : ℝ) + β / ((k : ℝ) + 1) ^ b ≤ (U.dens : ℝ) := by classical - intro v - rw [fiber_transportWords_sdiff] - let u : ω → Fin (k + 1) := fun a ↦ v (Sum.inl a) - let x : Fin b → Fin (k + 1) := fun j ↦ v (Sum.inr j) - have hv : v = Sum.elim u x := (Sum.elim_comp_inl_inr v).symm - have hword (y : Fin (S * b) → Fin (k + 1)) : - Sum.elim v y ∘ e₂ = Sum.elim (Sum.elim u y) x ∘ e₁ := by - simpa only [u, x] using hswap v y - have hUpart := hU v - apply sdiff hUpart + set 𝒱 := placeTiles e fun z ↦ pickTiles hm hmb β (fiber (transportWords e U) z) + have hgood : β ≤ ((univ.filter fun z ↦ + β ≤ ((fiber (transportWords e U) z).dens : ℝ)).dens : ℝ) := by + refine le_trans ?_ (density_ge_threshold (fun z ↦ by exact_mod_cast dens_le_one) + (by linarith : β < 2 * β) (by rwa [average_density_fiber, dens_transportWords])) + rw [le_div_iff₀ (by linarith)] + nlinarith + have hcovered := density_of_nonempty_fibers (e := e) (R := U \ uncovered U 𝒱) hgood + fun z hz ↦ by + rw [fiber_transportWords_sdiff, fiber_uncovered_placeTiles] + have hpick : pickSubspace hm hmb (fiber (transportWords e U) z) ∈ + pickTiles hm hmb β (fiber (transportWords e U) z) := ⟨(mem_filter.1 hz).2, rfl⟩ + exact ⟨_, mem_sdiff.2 ⟨(htiles z).isContained _ hpick (fun _ ↦ 0), + fun h ↦ (mem_uncovered.1 h).2 _ hpick (Subspace.mem_range.2 ⟨_, rfl⟩)⟩⟩ + rw [dens_sdiff_of_subset fun _ hw ↦ (mem_uncovered.1 hw).1] at hcovered + linarith + +/-- After one stage, the sections of the uncovered part over the remaining blocks are still +insensitive: whether a word is covered depends on its outer coordinates only through the section +of the family over them, which is the same for insensitive-equivalent words. -/ +private lemma isInsensitive_fiber_uncovered_pickTiles {b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) + {β : ℝ} {i j : Fin (k + 1)} {ι ω ν ν₁ : Type*} [Fintype ι] [Fintype ω] [Fintype ν] + [DecidableEq ν] [Fintype ν₁] [DecidableEq ν₁] {e : ι ≃ ω ⊕ ν} (s : ν ≃ ν₁ ⊕ Fin b) + {U : Finset (ι → Fin (k + 1))} + (hU : ∀ u, IsInsensitive i j (fiber (transportWords e U) u)) (v : ω ⊕ Fin b → Fin (k + 1)) : + IsInsensitive i j (fiber (transportWords (regroup e (s.trans (Equiv.sumComm ν₁ (Fin b)))) + (uncovered U (placeTiles (regroup e s) + fun z ↦ pickTiles hm hmb β (fiber (transportWords (regroup e s) U) z)))) v) := by + rw [← Sum.elim_comp_inl_inr v] intro y y' hyy' - have hsection : B (Sum.elim u y) = B (Sum.elim u y') := hBcongr u y y' hyy' - have hmemU : Sum.elim v y ∘ e₂ ∈ U ↔ Sum.elim v y' ∘ e₂ ∈ U := by - simpa only [mem_fiber, mem_transportWords] using hUpart (x := y) (y := y') hyy' - have hout (z : Fin (S * b) → Fin (k + 1)) : - (fun a ↦ (Sum.elim v z ∘ e₂) (e₁.symm (Sum.inl a))) = Sum.elim u z := by - rw [hword z] - funext a - simp only [Function.comp_apply, Equiv.apply_symm_apply, Sum.elim_inl] - have hblock (z : Fin (S * b) → Fin (k + 1)) : - (fun j ↦ (Sum.elim v z ∘ e₂) (e₁.symm (Sum.inr j))) = x := by - rw [hword z] - funext j - simp only [Function.comp_apply, Equiv.apply_symm_apply, Sum.elim_inr] - have hmemR (z : Fin (S * b) → Fin (k + 1)) : - z ∈ fiber (transportWords e₂ R) v ↔ - Sum.elim v z ∘ e₂ ∈ U ∧ Sum.elim u z ∈ good ∧ - x ∈ Subspace.range (pickSubspace hm hmb (B (Sum.elim u z))) := by - rw [mem_fiber, mem_transportWords, hR, Finset.mem_filter, hout z, hblock z] - rw [hmemR y, hmemR y', hsection, hmemU, hgood u y y' hsection] + rw [mem_fiber_regroup_sumComm, mem_fiber_regroup_sumComm, fiber_uncovered_placeTiles, + fiber_uncovered_placeTiles, fiber_transportWords_regroup, fiber_transportWords_regroup, + fiber_congr ((hU _).reindex s) hyy'] + +/-- The sections of a family over the outer coordinates and a first block are insensitive when +its sections over the outer coordinates are. -/ +private lemma isInsensitive_fiber_regroup {i j : Fin (k + 1)} {ι ω ν ν₁ ν₂ : Type*} [Fintype ω] + [Fintype ν] [DecidableEq ν] [Fintype ν₁] [Fintype ν₂] [DecidableEq ν₂] {e : ι ≃ ω ⊕ ν} + (s : ν ≃ ν₁ ⊕ ν₂) + {U : Finset (ι → Fin (k + 1))} (hU : ∀ u, IsInsensitive i j (fiber (transportWords e U) u)) + (z : ω ⊕ ν₁ → Fin (k + 1)) : + IsInsensitive i j (fiber (transportWords (regroup e s) U) z) := by + rw [← Sum.elim_comp_inl_inr z, fiber_transportWords_regroup] + exact ((hU _).reindex s).fiberSection _ /-- The block density-increment tiling of paper Lemma 12. -The coordinates are split into an already consumed part `ω` and `T` fresh blocks of size `b`. The -invariant is that all sections of the working family over the fresh blocks stay insensitive; each -stage either has already reached uncovered density below `2 * β` or removes disjoint tiles of total -density at least `β / (k + 1) ^ b`, and choosing the local subspace canonically from the section -keeps the invariant for the later blocks. -/ -private lemma exists_tiling_of_insensitive_sections {k : ℕ} (i : Fin k) (hDHJ : HasDensityHJ k) - {m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) {β : ℝ} (hβ₀ : 0 < β) (hβ₁ : β < 1) - (hb : Subspace.restrictAlphabetBound k m β ≤ b) : - ∀ T : ℕ, ∀ ι ω : Type, ∀ [Fintype ι] [DecidableEq ι] [Fintype ω], - ∀ e : ι ≃ ω ⊕ Fin (T * b), ∀ U : Finset (ι → Fin (k + 1)), - (∀ v : ω → Fin (k + 1), - IsInsensitive i.castSucc (Fin.last k) (fiber (transportWords e U) v)) → - ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι), - 𝒱.Finite ∧ (∀ V ∈ 𝒱, Subspace.IsContained V U) ∧ - (𝒱.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (ι → Fin (k + 1)))) ∧ - (((uncovered U 𝒱).dens : ℝ) < 2 * β ∨ - ((uncovered U 𝒱).dens : ℝ) + T * (β / ((k : ℝ) + 1) ^ b) ≤ (U.dens : ℝ)) := by - classical - intro T - induction T with - | zero => - intro ι ω _ _ _ e U _ - refine ⟨∅, Set.finite_empty, by simp, Set.pairwiseDisjoint_empty, ?_⟩ - right - simp only [uncovered_empty, Nat.cast_zero, zero_mul, add_zero, le_refl] +The coordinates are split into an already consumed part `ω` and `T` fresh blocks of size `b`, and +the sections of the family over `ω` are insensitive. Each stage either finds that less than +`2 * β` of the density is left, or places the tiles of `pickTiles` in the sections over the first +fresh block, which cover density at least `β / (k + 1) ^ b`, and moves that block into `ω`. +Because those tiles are chosen from the sections alone, the sections of what is left over the new +`ω` are still insensitive. -/ +private lemma exists_tiling_of_insensitive_sections {k : ℕ} (i : Fin k) {F : ℝ → ℕ} + (hF : IsDHJBound k F) {m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) {β : ℝ} (hβ₀ : 0 < β) + (hβ₁ : β < 1) (hb : Subspace.restrictAlphabetBound k F m β ≤ b) (T : ℕ) {ι ω : Type} + [Fintype ι] [DecidableEq ι] [Fintype ω] (e : ι ≃ ω ⊕ Fin (T * b)) + (U : Finset (ι → Fin (k + 1))) + (hU : ∀ v, IsInsensitive i.castSucc (Fin.last k) (fiber (transportWords e U) v)) : + ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι), IsTiling 𝒱 U ∧ + (((uncovered U 𝒱).dens : ℝ) < 2 * β ∨ + ((uncovered U 𝒱).dens : ℝ) + T * (β / ((k : ℝ) + 1) ^ b) ≤ (U.dens : ℝ)) := by + induction T generalizing ω U with + | zero => exact ⟨∅, .empty, .inr (by simp)⟩ | succ S ih => - intro ι ω _ _ _ e U hins - by_cases hU : (U.dens : ℝ) < 2 * β - · exact ⟨∅, Set.finite_empty, by simp, Set.pairwiseDisjoint_empty, Or.inl (by simpa using hU)⟩ - push Not at hU - have hsplit : S * b + b = (S + 1) * b := by ring - set s : Fin ((S + 1) * b) ≃ Fin (S * b) ⊕ Fin b := - (finSumFinEquiv.trans (finCongr hsplit)).symm with hs - set e₁ : ι ≃ (ω ⊕ Fin (S * b)) ⊕ Fin b := - e.trans (((Equiv.refl ω).sumCongr s).trans - (Equiv.sumAssoc ω (Fin (S * b)) (Fin b)).symm) with he₁ - set e₂ : ι ≃ (ω ⊕ Fin b) ⊕ Fin (S * b) := - e.trans (((Equiv.refl ω).sumCongr (s.trans (Equiv.sumComm (Fin (S * b)) (Fin b)))).trans - (Equiv.sumAssoc ω (Fin b) (Fin (S * b))).symm) with he₂ - set B : (ω ⊕ Fin (S * b) → Fin (k + 1)) → Finset (Fin b → Fin (k + 1)) := - fun z ↦ fiber (transportWords e₁ U) z with hBdef - have hB (u : ω → Fin (k + 1)) (r : Fin (S * b) → Fin (k + 1)) : - B (Sum.elim u r) = fiber (transportWords s (fiber (transportWords e U) u)) r := - fiber_transportWords_regroup e s U u r - have hBins (z : ω ⊕ Fin (S * b) → Fin (k + 1)) : - IsInsensitive i.castSucc (Fin.last k) (B z) := by - rw [← Sum.elim_comp_inl_inr z, hB] - exact fiberSection (reindex s (hins _)) _ - have havg : (𝔼 z : (ω ⊕ Fin (S * b) → Fin (k + 1)), ((B z).dens : ℝ)) = (U.dens : ℝ) := by - simp only [hBdef] - rw [average_density_fiber, dens_transportWords] - have hgood : - β ≤ ((Finset.univ.filter fun z : ω ⊕ Fin (S * b) → Fin (k + 1) ↦ - β ≤ ((B z).dens : ℝ)).dens : ℝ) := by - refine le_trans ?_ (density_ge_threshold (fun z ↦ ((B z).dens : ℝ)) (2 * β) β - (fun z ↦ by exact_mod_cast Finset.dens_le_one (s := B z)) - (by linarith) (by rw [havg]; exact hU)) - rw [le_div_iff₀ (by linarith)] - nlinarith - set good : Finset (ω ⊕ Fin (S * b) → Fin (k + 1)) := - Finset.univ.filter fun z ↦ β ≤ ((B z).dens : ℝ) with hgooddef - set tile : (ω ⊕ Fin (S * b) → Fin (k + 1)) → - Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι := - fun z ↦ transportSubspace e₁ z (pickSubspace hm hmb (B z)) with htiledef - have hpick (z : ω ⊕ Fin (S * b) → Fin (k + 1)) (hz : z ∈ good) : - Subspace.IsContained (pickSubspace hm hmb (B z)) (B z) := - pickSubspace_isContained hm hmb - (exists_isContained_of_insensitive hDHJ hm i hβ₀ hb (B z) (hBins z) - (by simpa only [hgooddef, Finset.mem_filter, Finset.mem_univ, true_and] using hz)) - set R : Finset (ι → Fin (k + 1)) := U.filter (fun w ↦ - (fun a ↦ w (e₁.symm (Sum.inl a))) ∈ good ∧ - (fun j ↦ w (e₁.symm (Sum.inr j))) ∈ - Subspace.range (pickSubspace hm hmb (B (fun a ↦ w (e₁.symm (Sum.inl a)))))) - with hRdef - have hRU : R ⊆ U := Finset.filter_subset _ _ - obtain ⟨htileR, hRtile⟩ := - canonical_tiles_cover hm hmb e₁ U B hBdef good tile htiledef hpick R hRdef - have hdensR : β / ((k : ℝ) + 1) ^ b ≤ (R.dens : ℝ) := by - apply density_of_nonempty_fibers e₁ R good - (by simpa only [hgooddef] using hgood) - intro z hz - refine ⟨pickSubspace hm hmb (B z) (fun _ ↦ 0), ?_⟩ - rw [mem_fiber, mem_transportWords] - simpa only [htiledef, transportSubspace_apply] using htileR z hz (fun _ ↦ 0) - have hins' : ∀ v : ω ⊕ Fin b → Fin (k + 1), - IsInsensitive i.castSucc (Fin.last k) (fiber (transportWords e₂ (U \ R)) v) := by - apply canonical_remainder_sections_insensitive i hm hmb e₁ e₂ U B good R hRdef - · intro v - let u : ω → Fin (k + 1) := fun a ↦ v (Sum.inl a) - let x : Fin b → Fin (k + 1) := fun j ↦ v (Sum.inr j) - have hv : v = Sum.elim u x := (Sum.elim_comp_inl_inr v).symm - rw [hv, he₂, - fiber_transportWords_regroup e - (s.trans (Equiv.sumComm (Fin (S * b)) (Fin b))) U u x] - exact fiberSection (reindex _ (hins _)) _ - · intro u y y' hyy' - rw [hB, hB] - exact fiber_congr (reindex s (hins u)) hyy' - · intro u y y' hsection - simp only [hgooddef, Finset.mem_filter, Finset.mem_univ, true_and] - rw [hsection] - · intro v y - let u : ω → Fin (k + 1) := fun a ↦ v (Sum.inl a) - let x : Fin b → Fin (k + 1) := fun j ↦ v (Sum.inr j) - have hv : v = Sum.elim u x := (Sum.elim_comp_inl_inr v).symm - rw [hv, he₁, he₂] - exact (concat_comp_swap e s u y x).symm - obtain ⟨𝒲, hfin', hcont', hdisj', hdens'⟩ := ih ι (ω ⊕ Fin b) e₂ (U \ R) hins' - let newTiles := tile '' (good : Set (ω ⊕ Fin (S * b) → Fin (k + 1))) - have hnewdisjoint : newTiles.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (ι → Fin (k + 1))) := by - rw [Set.pairwiseDisjoint_iff] - intro V hV V' hV' hmeet - obtain ⟨z, hz, rfl⟩ := hV - obtain ⟨z', hz', rfl⟩ := hV' - obtain ⟨w, hw, hw'⟩ := hmeet - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hw - obtain ⟨x', hx'⟩ := Subspace.mem_range.mp hw' - have hzz : z = z' := by - funext a - simpa only [htiledef, transportSubspace_apply, Function.comp_apply, - Equiv.apply_symm_apply, Sum.elim_inl] using - congrFun (hx.trans hx'.symm) (e₁.symm (Sum.inl a)) - rw [hzz] - obtain ⟨hfinite, hcontained, hdisjoint, hdensity⟩ := - combine_tiling_stage U R newTiles 𝒲 - (good.finite_toSet.image tile) hfin' hRU - (fun _ hV ↦ by obtain ⟨z, hz, rfl⟩ := hV; exact htileR z hz) - (fun w hw ↦ by - obtain ⟨z, hz, hmem⟩ := hRtile w hw - exact ⟨tile z, ⟨z, hz, rfl⟩, hmem⟩) - hnewdisjoint hcont' hdisj' hdensR hdens' - refine ⟨newTiles ∪ 𝒲, hfinite, hcontained, hdisjoint, ?_⟩ - simpa only [Nat.cast_add, Nat.cast_one] using hdensity - -/-- Finite-stage block packing gives one exact sufficient dimension for one-family tiling. -/ -lemma exists_tilingSufficient_dimension (k m : ℕ) (hDHJ : HasDensityHJ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) : - ∃ N, TilingSufficient k m β N := by - by_cases hβ : β < 1 - · set b := max m (Subspace.restrictAlphabetBound k m β) with hbdef - have hc : 0 < β / ((k : ℝ) + 1) ^ b := by positivity - obtain ⟨T, hT⟩ := exists_nat_gt (1 / (β / ((k : ℝ) + 1) ^ b)) - rw [div_lt_iff₀ hc] at hT - refine ⟨T * b, ?_⟩ - intro i D hD hDβ - have hsections : ∀ v : Fin 0 → Fin (k + 1), - IsInsensitive i.castSucc (Fin.last k) - (fiber (transportWords (Equiv.emptySum (Fin 0) (Fin (T * b))).symm D) v) := by - intro v x y hxy - simp only [mem_fiber, mem_transportWords] - apply hD - intro a hai hal c - simpa only [Function.comp_apply, Equiv.emptySum_symm_apply, Sum.elim_inr] using - hxy a hai hal c - obtain ⟨𝒱, hfinite, hcontained, hpairwise, hconclusion⟩ := - exists_tiling_of_insensitive_sections i hDHJ hm (le_max_left _ _) hβ₀ hβ - (le_max_right _ _) T (Fin (T * b)) (Fin 0) - (Equiv.emptySum (Fin 0) (Fin (T * b))).symm D hsections - refine ⟨𝒱, hfinite, hcontained, hpairwise, ?_⟩ - rcases hconclusion with hlt | hle - · exact hlt - · exfalso - have hD₁ : (D.dens : ℝ) ≤ 1 := by exact_mod_cast Finset.dens_le_one (s := D) - have hnonneg : (0 : ℝ) ≤ ((uncovered D 𝒱).dens : ℝ) := by positivity - linarith - · refine ⟨m, ?_⟩ - intro _i D _hD hDβ - have hD₁ : (D.dens : ℝ) ≤ 1 := by exact_mod_cast Finset.dens_le_one (s := D) + obtain hlt | hle := lt_or_ge (U.dens : ℝ) (2 * β) + · exact ⟨∅, .empty, .inl (by simpa using hlt)⟩ + let s : Fin ((S + 1) * b) ≃ Fin (S * b) ⊕ Fin b := + (finSumFinEquiv.trans (finCongr (by ring))).symm + have htiles (z : ω ⊕ Fin (S * b) → Fin (k + 1)) := + isTiling_pickTiles hm hmb (β := β) fun hz ↦ + exists_isContained_of_insensitive hF hm hβ₀ hb (isInsensitive_fiber_regroup s hU z) hz + obtain ⟨𝒲, h𝒲, hsmall⟩ := ih _ _ (isInsensitive_fiber_uncovered_pickTiles hm hmb s hU) + refine ⟨_ ∪ 𝒲, (IsTiling.placeTiles htiles).union h𝒲, ?_⟩ + have hstage := dens_uncovered_pickTiles_add_le hm hmb hβ₀ hβ₁ hle htiles + rw [uncovered_union, Nat.cast_add_one] + refine hsmall.imp_right ?_ + intro h linarith -/-- A tiling in every fixed extra-coordinate section combines to a tiling of the full cube. -/ +/-- The tiling procedure tiles one insensitive family in `T` stages, over blocks of any size `b` +that supports the restricted-alphabet subspace lemma, once `T` exceeds the number of possible +density increments. -/ +lemma tilingSufficient_mul {k m : ℕ} {F : ℝ → ℕ} (hF : IsDHJBound k F) (hm : 1 ≤ m) + {β : ℝ} (hβ₀ : 0 < β) {b : ℕ} (hmb : m ≤ b) + (hb : Subspace.restrictAlphabetBound k F m β ≤ b) {T : ℕ} + (hT : 1 / (β / ((k : ℝ) + 1) ^ b) < T) : + TilingSufficient k m β (T * b) := by + intro i D hD + have hD₁ : (D.dens : ℝ) ≤ 1 := by exact_mod_cast dens_le_one + obtain hβ | hβ := lt_or_ge β 1 + · obtain ⟨𝒱, h𝒱, hsmall⟩ := exists_tiling_of_insensitive_sections i hF hm hmb hβ₀ hβ hb T + (Equiv.emptySum (Fin 0) (Fin (T * b))).symm D fun v ↦ (hD.reindex _).fiberSection v + refine ⟨𝒱, h𝒱, hsmall.resolve_right ?_⟩ + rw [div_lt_iff₀ (by positivity)] at hT + intro h + linarith [(by positivity : (0 : ℝ) ≤ (uncovered D 𝒱).dens)] + · exact ⟨∅, .empty, by simp; linarith⟩ + +/-- A tiling of every section over some extra coordinates gives a tiling of the whole cube. -/ private lemma tilingSufficient_mono {k m N n : ℕ} {β : ℝ} (hN : TilingSufficient k m β N) (hNn : N ≤ n) : TilingSufficient k m β n := by - classical - intro i D hD hDβ - let r := n - N - have hNr : N + r = n := Nat.add_sub_of_le hNn - let e : Fin r ⊕ Fin N ≃ Fin n := - (Equiv.sumComm (Fin r) (Fin N)).trans <| finSumFinEquiv.trans (finCongr hNr) - let wordEquiv := - e.arrowCongr (Equiv.refl (Fin (k + 1))) - let D' := D.map wordEquiv.symm.toEmbedding - let slice := fun z : Fin r → Fin (k + 1) ↦ fiber D' z - have hslice (z : Fin r → Fin (k + 1)) : - IsInsensitive i.castSucc (Fin.last k) (slice z) := by - intro x y hxy - simp only [slice, mem_fiber, D', Finset.mem_map_equiv] - apply hD - intro a hai hal c - cases hc : e.symm c with - | inl j => simp [wordEquiv, Equiv.arrowCongr, hc] - | inr j => simpa [wordEquiv, Equiv.arrowCongr, hc] using hxy a hai hal j - have existsLocal (z : Fin r → Fin (k + 1)) : - ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin N)), - 𝒱.Finite ∧ - (∀ V ∈ 𝒱, Subspace.IsContained V (slice z)) ∧ - (𝒱.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (Fin N → Fin (k + 1)))) ∧ - ((uncovered (slice z) 𝒱).dens : ℝ) < 2 * β := by - by_cases hz : 2 * β ≤ ((slice z).dens : ℝ) - · exact hN i (slice z) (hslice z) hz - · exact ⟨∅, Set.finite_empty, by simp, Set.pairwiseDisjoint_empty, - by simpa using lt_of_not_ge hz⟩ - choose tiles hlocalFinite hlocalContained hlocalDisjoint hlocalDensity using existsLocal - let global : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) := - ⋃ z, padExtraSubspace e z '' tiles z - obtain ⟨hglobalFinite, hglobalContained, hglobalDisjoint⟩ := padded_tiles_facts e D tiles - hlocalFinite - (fun z V hV ↦ by simpa only [slice, D'] using hlocalContained z V hV) - hlocalDisjoint - refine ⟨global, hglobalFinite, hglobalContained, hglobalDisjoint, ?_⟩ - · let E := (uncovered D global).map wordEquiv.symm.toEmbedding - have hfiber (z : Fin r → Fin (k + 1)) : - fiber E z = uncovered (slice z) (tiles z) := by - simpa only [E, global, slice, D', wordEquiv] using - fiber_uncovered_padded e D tiles z - have hEdens : - (E.dens : ℝ) = ((uncovered D global).dens : ℝ) := by - simp only [E, Finset.dens_map_equiv] - rw [← hEdens, ← average_density_fiber] - apply Finset.expect_lt - · intro z _ - rw [hfiber] - exact (hlocalDensity z).le - · let z : Fin r → Fin (k + 1) := fun _ ↦ 0 - refine ⟨z, Finset.mem_univ z, ?_⟩ - rw [hfiber] - exact hlocalDensity z - -/-- One-family tiling sufficiency is upward closed after padding with unused final coordinates. -/ -lemma exists_eventually_tilingSufficient (k m : ℕ) (hDHJ : HasDensityHJ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) : - ∃ N, ∀ n ≥ N, TilingSufficient k m β n := by - obtain ⟨N, hN⟩ := exists_tilingSufficient_dimension k m hDHJ hm hβ₀ - refine ⟨N, ?_⟩ - intro _n hn - exact tilingSufficient_mono hN hn - -/-- A sufficient ambient dimension for tiling one insensitive family. The tiling argument needs -density Hales--Jewett for the smaller alphabet, so the witness is selected under -`HasDensityHJ k`. -/ -noncomputable def tilingBound (k m : ℕ) (β : ℝ) : ℕ := by - classical - exact if h : HasDensityHJ k ∧ 1 ≤ m ∧ 0 < β then - Nat.find (exists_eventually_tilingSufficient k m h.1 h.2.1 h.2.2) - else 0 - -/-- The selected one-family tiling bound satisfies the tiling predicate in every larger -dimension. -/ -lemma tilingBound_spec (k m n : ℕ) (hDHJ : HasDensityHJ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) - (hn : tilingBound k m β ≤ n) : TilingSufficient k m β n := by - classical - rw [tilingBound, dite_eq_left ⟨hDHJ, hm, hβ₀⟩] at hn - exact Nat.find_spec (exists_eventually_tilingSufficient k m hDHJ hm hβ₀) n hn + intro i D hD + exact exists_tiling_of_sections (e := (Subspace.cutEquiv (Nat.sub_add_cancel hNn)).symm) + fun z ↦ hN i _ ((hD.reindex _).fiberSection z) + +/-- A dimension sufficient for tiling one insensitive family by `m`-dimensional subspaces with +tolerance `β`: blocks whose size supports the restricted-alphabet subspace lemma, one more than the +number of possible density increments. -/ +noncomputable def tilingBound (k : ℕ) (F : ℝ → ℕ) (m : ℕ) (β : ℝ) : ℕ := + (⌊((k : ℝ) + 1) ^ max m (Subspace.restrictAlphabetBound k F m β) / β⌋₊ + 1) * + max m (Subspace.restrictAlphabetBound k F m β) + +/-- `TilingSufficient k m β n` holds for every `n ≥ tilingBound k F m β`. -/ +lemma tilingSufficient_of_le {k m n : ℕ} {F : ℝ → ℕ} (hF : IsDHJBound k F) (hm : 1 ≤ m) + {β : ℝ} (hβ₀ : 0 < β) (hn : tilingBound k F m β ≤ n) : TilingSufficient k m β n := by + refine tilingSufficient_mono + (tilingSufficient_mul hF hm hβ₀ (le_max_left _ _) (le_max_right _ _) ?_) hn + rw [one_div_div, Nat.cast_add, Nat.cast_one] + exact Nat.lt_floor_add_one _ /-- Pulling an insensitive family back through a subspace preserves its sensitivity pair. -/ lemma parameterPreimage_isInsensitive {α η ι : Type*} - [Fintype (η → α)] {a b : α} (V : Combinatorics.Subspace η α ι) (D : Finset (ι → α)) + [Fintype (η → α)] {a b : α} (V : Combinatorics.Subspace η α ι) {D : Finset (ι → α)} (hD : IsInsensitive a b D) : IsInsensitive a b (parameterPreimage V D) := by classical intro x y hxy - simp only [parameterPreimage, Finset.mem_filter, Finset.mem_univ, true_and] + simp only [parameterPreimage, mem_filter, mem_univ, true_and] apply hD intro c hca hcb i cases hi : V.idxFun i with @@ -836,41 +640,41 @@ lemma parameterPreimage_isInsensitive {α η ι : Type*} rw [V.apply_inr hi, V.apply_inr hi] exact hxy c hca hcb e -/-- Composing a finite disjoint family of inner tiles with one outer tile preserves finiteness, -containment, and pairwise-disjointness. -/ -lemma composed_inner_tiles_facts {k d M n : ℕ} - (D : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n)) - (𝒲 : Set (Combinatorics.Subspace (Fin d) (Fin (k + 1)) (Fin M))) - (h𝒲 : 𝒲.Finite) - (hcontained : ∀ W ∈ 𝒲, Subspace.IsContained W (parameterPreimage V D)) - (hpairwise : 𝒲.PairwiseDisjoint fun W ↦ - (Subspace.range W : Set (Fin M → Fin (k + 1)))) : - let 𝒰 := Subspace.compose V '' 𝒲 - 𝒰.Finite ∧ - (∀ U ∈ 𝒰, Subspace.IsContained U D) ∧ - (𝒰.PairwiseDisjoint fun U ↦ - (Subspace.range U : Set (Fin n → Fin (k + 1)))) := by - classical - refine ⟨h𝒲.image (Subspace.compose V), ?_, ?_⟩ - · intro U hU x - obtain ⟨W, hW, rfl⟩ := hU - simp only [Subspace.compose_apply] - simpa only [parameterPreimage, Finset.mem_filter, Finset.mem_univ, true_and] using - hcontained W hW x - · rw [Set.pairwiseDisjoint_iff] - intro U hU U' hU' hcommon - obtain ⟨W, hW, rfl⟩ := hU - obtain ⟨W', hW', rfl⟩ := hU' - apply congrArg (Subspace.compose V) - apply Set.pairwiseDisjoint_iff.mp hpairwise hW hW' - obtain ⟨z, hz, hz'⟩ := hcommon - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hz - obtain ⟨y, hy⟩ := Subspace.mem_range.mp hz' - refine ⟨W x, Subspace.mem_range.mpr ⟨x, rfl⟩, - Subspace.mem_range.mpr ⟨y, ?_⟩⟩ - apply Subspace.injective V - simpa only [Subspace.compose_apply] using hy.trans hx.symm +/-- Inside each subspace `V ∈ 𝒱`, the subspaces `tiles V` of its parameter cube, composed with +`V`. -/ +def composeTiles {α η θ ι : Type*} (𝒱 : Set (Combinatorics.Subspace θ α ι)) + (tiles : Combinatorics.Subspace θ α ι → Set (Combinatorics.Subspace η α θ)) : + Set (Combinatorics.Subspace η α ι) := + ⋃ V ∈ 𝒱, Subspace.compose V '' tiles V + +variable {M n : ℕ} {A E : Finset (Fin n → Fin (k + 1))} + {𝒱 : Set (Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n))} + {tiles : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) → + Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin M))} + +/-- Tilings of the parameter preimages of `E` inside the subspaces of a tiling of `A`, composed +with those subspaces, form a tiling of `A ∩ E`. -/ +lemma IsTiling.composeTiles (h𝒱 : IsTiling 𝒱 A) + (htiles : ∀ V ∈ 𝒱, IsTiling (tiles V) (parameterPreimage V E)) : + IsTiling (composeTiles 𝒱 tiles) (A ∩ E) where + finite := h𝒱.finite.biUnion fun V hV ↦ (htiles V hV).finite.image _ + isContained := by + simp only [IsInsensitive.composeTiles, Set.mem_iUnion, Set.mem_image] + rintro _ ⟨V, hV, W, hW, rfl⟩ x + have hx := (htiles V hV).isContained W hW x + simp only [parameterPreimage, mem_filter, mem_univ, true_and] at hx + simpa using ⟨h𝒱.isContained V hV (W x), hx⟩ + pairwiseDisjoint := by + rw [Set.pairwiseDisjoint_iff] + simp only [IsInsensitive.composeTiles, Set.mem_iUnion, Set.mem_image] + rintro _ ⟨V, hV, W, hW, rfl⟩ _ ⟨V', hV', W', hW', rfl⟩ ⟨w, hw, hw'⟩ + obtain ⟨x, rfl⟩ := Subspace.mem_range.1 hw + obtain ⟨x', hx'⟩ := Subspace.mem_range.1 hw' + simp only [Subspace.compose_apply] at hx' + obtain rfl := Set.pairwiseDisjoint_iff.1 h𝒱.pairwiseDisjoint hV hV' + ⟨V (W x), Subspace.mem_range.2 ⟨W x, rfl⟩, Subspace.mem_range.2 ⟨W' x', hx'⟩⟩ + rw [Set.pairwiseDisjoint_iff.1 (htiles V hV).pairwiseDisjoint hW hW' + ⟨W x, Subspace.mem_range.2 ⟨x, rfl⟩, Subspace.mem_range.2 ⟨x', Subspace.injective V hx'⟩⟩] /-- Mapping a parameter-cube family into a subspace scales its ambient density by the density of the whole subspace range. -/ @@ -879,435 +683,151 @@ private lemma dens_map_subspace_eq_mul_range {α η ι : Type*} (V : Combinatorics.Subspace η α ι) (A : Finset (η → α)) : ((A.map ⟨V, Subspace.injective V⟩).dens : ℝ) = (A.dens : ℝ) * ((Subspace.range V).dens : ℝ) := by - simp only [Finset.nnratCast_dens, Subspace.range, Finset.card_map] - rw [Finset.card_image_iff.mpr (Subspace.injective V).injOn] + simp only [nnratCast_dens, Subspace.range, card_map] + rw [card_image_iff.mpr (Subspace.injective V).injOn] by_cases h : Fintype.card (η → α) = 0 · let : IsEmpty (η → α) := Fintype.card_eq_zero_iff.mp h have hA : A = ∅ := Subsingleton.elim _ _ rw [hA] simp · field_simp - simp only [Finset.card_univ] - -/-- An ambient dimension is sufficient for tiling every dense intersection of `r` insensitive -families. -/ + simp only [card_univ] + +/-- Families of relative density at most `ε` inside the subspaces of a tiling have total density +at most `ε`. -/ +private lemma dens_biUnion_map_le (h𝒱 : IsTiling 𝒱 A) + {L : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) → Finset (Fin M → Fin (k + 1))} + {ε : ℝ} (hε₀ : 0 ≤ ε) (hL : ∀ V ∈ 𝒱, ((L V).dens : ℝ) ≤ ε) : + ((h𝒱.finite.toFinset.biUnion fun V ↦ (L V).map ⟨V, Subspace.injective V⟩).dens : ℝ) ≤ ε := by + have hdisjoint : (h𝒱.finite.toFinset : Set _).PairwiseDisjoint + fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ Subspace.range V := by + simpa [← pairwiseDisjoint_coe] using h𝒱.pairwiseDisjoint + calc ((h𝒱.finite.toFinset.biUnion fun V ↦ (L V).map ⟨V, Subspace.injective V⟩).dens : ℝ) + ≤ ∑ V ∈ h𝒱.finite.toFinset, ((L V).dens : ℝ) * ((Subspace.range V).dens : ℝ) := by + simp_rw [← dens_map_subspace_eq_mul_range, ← NNRat.cast_sum] + exact_mod_cast dens_biUnion_le + _ ≤ ∑ V ∈ h𝒱.finite.toFinset, ε * ((Subspace.range V).dens : ℝ) := by + gcongr with V hV + exact hL V (by simpa using hV) + _ = ε * ((h𝒱.finite.toFinset.biUnion Subspace.range).dens : ℝ) := by + rw [dens_biUnion hdisjoint, NNRat.cast_sum, mul_sum] + _ ≤ ε := mul_le_of_le_one_right hε₀ (by exact_mod_cast dens_le_one) + +/-- A word of `A ∩ E` missed by all composed tiles is missed by all subspaces of `𝒱`, or lies in +the image of the part of the preimage of `E` that the tiles inside its subspace leave uncovered. -/ +private lemma uncovered_composeTiles_subset (h𝒱 : 𝒱.Finite) : + uncovered (A ∩ E) (composeTiles 𝒱 tiles) ⊆ uncovered A 𝒱 ∪ + h𝒱.toFinset.biUnion fun V ↦ + (uncovered (parameterPreimage V E) (tiles V)).map ⟨V, Subspace.injective V⟩ := by + intro w hw + rw [mem_uncovered, mem_inter] at hw + rw [mem_union, mem_uncovered] + by_cases h : ∃ V ∈ 𝒱, w ∈ Subspace.range V + · right + obtain ⟨V, hV, hwV⟩ := h + obtain ⟨x, rfl⟩ := Subspace.mem_range.1 hwV + refine mem_biUnion.2 ⟨V, by simpa using hV, mem_map.2 ⟨x, ?_, rfl⟩⟩ + rw [mem_uncovered] + refine ⟨by simpa [parameterPreimage] using hw.1.2, ?_⟩ + intro W hW hxW + obtain ⟨y, rfl⟩ := Subspace.mem_range.1 hxW + exact hw.2 _ (Set.mem_biUnion hV (Set.mem_image_of_mem _ hW)) + (Subspace.mem_range.2 ⟨y, by simp⟩) + · exact .inl ⟨hw.1.1, fun V hV hwV ↦ h ⟨V, hV, hwV⟩⟩ + +/-- Composing tilings that leave relative density at most `ε` of the preimages of `E` uncovered +leaves at most `ε` more of `A ∩ E` uncovered than `𝒱` leaves of `A`. -/ +private lemma dens_uncovered_composeTiles_le (h𝒱 : IsTiling 𝒱 A) {ε : ℝ} (hε₀ : 0 ≤ ε) + (hε : ∀ V ∈ 𝒱, ((uncovered (parameterPreimage V E) (tiles V)).dens : ℝ) ≤ ε) : + ((uncovered (A ∩ E) (composeTiles 𝒱 tiles)).dens : ℝ) ≤ (uncovered A 𝒱).dens + ε := by + have h := (NNRat.cast_le (K := ℝ)).2 ((dens_mono (uncovered_composeTiles_subset + (A := A) (E := E) (tiles := tiles) h𝒱.finite)).trans (dens_union_le _ _)) + rw [NNRat.cast_add] at h + linarith [dens_biUnion_map_le h𝒱 hε₀ hε] + +/-- An ambient dimension is sufficient for tiling intersections of `r` insensitive families: each +of them has a tiling by `m`-dimensional subspaces leaving density less than `2 * r * β` +uncovered. -/ def IntersectionTilingSufficient (k r m : ℕ) (β : ℝ) (n : ℕ) : Prop := - ∀ (_ : 1 ≤ r), ∀ hrk : r ≤ k, - ∀ D : Fin r → Finset (Fin n → Fin (k + 1)), + ∀ hrk : r ≤ k, ∀ D : Fin r → Finset (Fin n → Fin (k + 1)), (∀ i, IsInsensitive (Fin.castLE hrk i).castSucc (Fin.last k) (D i)) → - 2 * r * β ≤ ((intersection D).dens : ℝ) → ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)), - 𝒱.Finite ∧ - (∀ V ∈ 𝒱, Subspace.IsContained V (intersection D)) ∧ - (𝒱.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (Fin n → Fin (k + 1)))) ∧ - ((uncovered (intersection D) 𝒱).dens : ℝ) < 2 * r * β + IsTiling 𝒱 (intersection D) ∧ ((uncovered (intersection D) 𝒱).dens : ℝ) < 2 * r * β /-- One indexed insensitive family is exactly the one-family tiling statement. -/ -private lemma intersectionTilingSufficient_one {k m n : ℕ} {β : ℝ} - (h : TilingSufficient k m β n) : +private lemma intersectionTilingSufficient_one {β : ℝ} (h : TilingSufficient k m β n) : IntersectionTilingSufficient k 1 m β n := by - intro _ hrk D hD hDβ - have hintersection : intersection D = D 0 := by + intro hrk D hD + have hD₀ : intersection D = D 0 := by ext x simp [Fin.forall_fin_one] - obtain ⟨𝒱, hfinite, hcontained, hpairwise, huncovered⟩ := - h (Fin.castLE hrk 0) (D 0) (hD 0) (by - rw [hintersection] at hDβ - norm_num at hDβ ⊢ - exact hDβ) - refine ⟨𝒱, hfinite, ?_, hpairwise, ?_⟩ - · simpa only [hintersection] using hcontained - · rw [hintersection] - norm_num - exact huncovered - -/-- Errors inside pairwise-disjoint outer tiles have total ambient density at most their common -relative-density bound. -/ -private lemma mapped_inner_errors_density_le {k M n : ℕ} {β : ℝ} (hβ₀ : 0 < β) - (𝒱 : Set (Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n))) - (hfinite : 𝒱.Finite) - (hpairwise : 𝒱.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (Fin n → Fin (k + 1)))) - (localError : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) → - Finset (Fin M → Fin (k + 1))) - (hlocal : ∀ V, ((localError V).dens : ℝ) ≤ 2 * β) : - let outer := hfinite.toFinset - let errors := outer.biUnion fun V ↦ - (localError V).map ⟨V, Subspace.injective V⟩ - (errors.dens : ℝ) ≤ 2 * β := by - classical - dsimp only - let outer := hfinite.toFinset - let innerError := fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - (localError V).map ⟨V, Subspace.injective V⟩ - have herror_pairwise : (outer : Set _).PairwiseDisjoint innerError := by - intro V hV V' hV' hVV - change Disjoint (innerError V) (innerError V') - rw [Finset.disjoint_left] - intro w hw hw' - apply Set.disjoint_left.mp (hpairwise - (by simpa [outer] using hV) (by simpa [outer] using hV') hVV) - · obtain ⟨x, _hx, hxw⟩ := Finset.mem_map.mp hw - exact Subspace.mem_range.mpr ⟨x, hxw⟩ - · obtain ⟨x', _hx', hx'w⟩ := Finset.mem_map.mp hw' - exact Subspace.mem_range.mpr ⟨x', hx'w⟩ - rw [Finset.dens_biUnion herror_pairwise] - change (NNRat.castHom ℝ) (∑ V ∈ outer, (innerError V).dens) ≤ 2 * β - rw [map_sum (NNRat.castHom ℝ)] - have hsummand (V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n)) : - ((innerError V).dens : ℝ) ≤ 2 * β * ((Subspace.range V).dens : ℝ) := by - dsimp only [innerError] - rw [dens_map_subspace_eq_mul_range] - exact mul_le_mul_of_nonneg_right (hlocal V) (by positivity) - apply (Finset.sum_le_sum fun V _ ↦ hsummand V).trans - rw [← Finset.mul_sum] - have hranges_pairwise : (outer : Set _).PairwiseDisjoint - (fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - Subspace.range V) := by - intro V hV V' hV' hVV - change Disjoint (Subspace.range V) (Subspace.range V') - rw [Finset.disjoint_left] - intro w hw hw' - exact Set.disjoint_left.mp (hpairwise - (by simpa [outer] using hV) (by simpa [outer] using hV') hVV) hw hw' - have hsum : (∑ V ∈ outer, ((Subspace.range V).dens : ℝ)) ≤ 1 := by - have hdens_ranges : (((outer.biUnion Subspace.range).dens : ℚ≥0) : ℝ) = - ∑ V ∈ outer, ((Subspace.range V).dens : ℝ) := by - rw [Finset.dens_biUnion hranges_pairwise] - change (NNRat.castHom ℝ) (∑ V ∈ outer, (Subspace.range V).dens) = _ - rw [map_sum (NNRat.castHom ℝ)] - rfl - rw [← hdens_ranges] - exact_mod_cast Finset.dens_le_one (s := outer.biUnion Subspace.range) - simpa only [mul_one] using - mul_le_mul_of_nonneg_left hsum (mul_nonneg (by norm_num) hβ₀.le) - -/-- A point missed by all composed tiles is either missed by all outer tiles, or belongs to the -uncovered inner error inside the unique outer tile containing it. -/ -private lemma uncovered_composed_tiles_subset {k r m M n : ℕ} - (D : Fin r.succ → Finset (Fin n → Fin (k + 1))) - (D₀ : Fin r → Finset (Fin n → Fin (k + 1))) - (hsubset : intersection D ⊆ intersection D₀) - (𝒱 : Set (Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n))) - (hfinite : 𝒱.Finite) - (tiles : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) → - Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin M))) : - let pullback := fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - parameterPreimage V (D (Fin.last r)) - let global := ⋃ V : 𝒱, Subspace.compose V.val '' tiles V - let errors := hfinite.toFinset.biUnion fun V ↦ - (uncovered (pullback V) (tiles V)).map ⟨V, Subspace.injective V⟩ - uncovered (intersection D) global ⊆ uncovered (intersection D₀) 𝒱 ∪ errors := by - classical - dsimp only - intro w hw - simp only [uncovered, Finset.mem_filter] at hw - simp only [uncovered, Finset.mem_filter, Finset.mem_union] - by_cases hparent : ∃ V ∈ 𝒱, w ∈ Subspace.range V - · right - obtain ⟨V, hV, hwV⟩ := hparent - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hwV - refine Finset.mem_biUnion.mpr ⟨V, by simpa using hV, ?_⟩ - apply Finset.mem_map.mpr - refine ⟨x, ?_, hx⟩ - simp only [Finset.mem_filter] - constructor - · simp only [parameterPreimage, Finset.mem_filter, Finset.mem_univ, true_and] - exact hx ▸ (mem_intersection.mp hw.1 (Fin.last r)) - · intro W hW hxW - apply hw.2 (Subspace.compose V W) - · exact Set.mem_iUnion_of_mem ⟨V, hV⟩ <| - Set.mem_image_of_mem (Subspace.compose V) hW - · obtain ⟨y, hy⟩ := Subspace.mem_range.mp hxW - exact Subspace.mem_range.mpr ⟨y, by rw [Subspace.compose_apply, hy, hx]⟩ - · left - refine ⟨hsubset hw.1, ?_⟩ - intro V hV hwV - exact hparent ⟨V, hV, hwV⟩ - -/-- Composing the inner tilings with a disjoint outer tiling preserves all packing properties and -adds the final insensitive family to the containment statement. -/ -private lemma composed_outer_tiles_facts {k r m M n : ℕ} - (D : Fin (r + 1) → Finset (Fin n → Fin (k + 1))) - (D₀ : Fin r → Finset (Fin n → Fin (k + 1))) - (hD₀ : ∀ i, D₀ i = D (Fin.castSucc i)) - (𝒱 : Set (Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n))) - (hfinite : 𝒱.Finite) - (hcontained : ∀ V ∈ 𝒱, Subspace.IsContained V (intersection D₀)) - (hpairwise : 𝒱.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (Fin n → Fin (k + 1)))) - (tiles : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) → - Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin M))) - (hinner : ∀ V, - (Subspace.compose V '' tiles V).Finite ∧ - (∀ U ∈ Subspace.compose V '' tiles V, - Subspace.IsContained U (D (Fin.last r))) ∧ - ((Subspace.compose V '' tiles V).PairwiseDisjoint fun U ↦ - (Subspace.range U : Set (Fin n → Fin (k + 1))))) : - let global := ⋃ V : 𝒱, Subspace.compose V.val '' tiles V - global.Finite ∧ - (∀ U ∈ global, Subspace.IsContained U (intersection D)) ∧ - (global.PairwiseDisjoint fun U ↦ - (Subspace.range U : Set (Fin n → Fin (k + 1)))) := by - classical - let : Finite 𝒱 := hfinite - dsimp only - refine ⟨Set.finite_iUnion fun V ↦ (hinner V).1, ?_, ?_⟩ - · intro U hU x - simp only [Set.mem_iUnion] at hU - obtain ⟨V, W, hW, rfl⟩ := hU - rw [mem_intersection] - intro i - refine Fin.lastCases ?_ ?_ i - · exact (hinner V).2.1 (Subspace.compose V W) - (Set.mem_image_of_mem (Subspace.compose V.val) hW) x - · intro j - simpa only [Subspace.compose_apply, hD₀ j] using - mem_intersection.mp (hcontained V V.prop (W x)) j - · rw [Set.pairwiseDisjoint_iff] - intro U hU U' hU' hcommon - simp only [Set.mem_iUnion] at hU hU' - obtain ⟨V, hU⟩ := hU - obtain ⟨V', hU'⟩ := hU' - have hVV : V = V' := by - refine Subtype.ext (Set.pairwiseDisjoint_iff.mp hpairwise V.prop V'.prop ?_) - obtain ⟨w, hw, hw'⟩ := hcommon - obtain ⟨x, hx⟩ := Subspace.mem_range.mp hw - obtain ⟨x', hx'⟩ := Subspace.mem_range.mp hw' - obtain ⟨W, hW, rfl⟩ := hU - obtain ⟨W', hW', rfl⟩ := hU' - refine ⟨V.val (W x), Subspace.mem_range.mpr ⟨W x, rfl⟩, - Subspace.mem_range.mpr ⟨W' x', ?_⟩⟩ - simpa only [Subspace.compose_apply] using hx'.trans hx.symm - subst V' - exact Set.pairwiseDisjoint_iff.mp (hinner V).2.2 hU hU' hcommon - -/-- The two-stage outer/inner packing step for adding one insensitive family. -/ -private lemma extend_intersection_tiling {k r m M n : ℕ} - (hr₀ : 1 ≤ r) (hrk : r + 1 ≤ k) {β : ℝ} (hβ₀ : 0 < β) - (houter : IntersectionTilingSufficient k r M β n) - (hinner : TilingSufficient k m β M) : + simpa [hD₀] using h _ (D 0) (hD 0) + +/-- Tiling the intersection of the first `r` families by `M`-dimensional subspaces, and the +preimage of the last family inside each of them by `m`-dimensional subspaces, tiles the +intersection of all `r + 1`. -/ +private lemma extend_intersection_tiling {r : ℕ} {β : ℝ} (hβ₀ : 0 < β) + (houter : IntersectionTilingSufficient k r M β n) (hinner : TilingSufficient k m β M) : IntersectionTilingSufficient k (r + 1) m β n := by - intro _ hrk' D hD hDβ - let D₀ : Fin r → Finset (Fin n → Fin (k + 1)) := fun i ↦ - D (Fin.castSucc i) - have hsubset : intersection D ⊆ intersection D₀ := by grind [mem_intersection] - have hD₀ (i : Fin r) : - IsInsensitive (Fin.castLE (by omega) i).castSucc (Fin.last k) (D₀ i) := by - have hindex : Fin.castLE hrk' (Fin.castSucc i) = Fin.castLE (by omega) i := Fin.ext rfl - rw [← hindex] - simpa only [D₀] using hD (Fin.castSucc i) - obtain ⟨𝒱, hfinite, hcontained, hpairwise, huncovered⟩ := - houter hr₀ (by omega) D₀ hD₀ (by - apply le_trans (b := 2 * ((r : ℝ) + 1) * β) - · nlinarith - · have hdens : ((intersection D).dens : ℝ) ≤ ((intersection D₀).dens : ℝ) := by - exact_mod_cast Finset.dens_mono hsubset - convert hDβ.trans hdens using 1 - norm_num) - let iLast : Fin k := ⟨r, by omega⟩ - let DLast := D (Fin.last r) - have hLast : IsInsensitive iLast.castSucc (Fin.last k) DLast := by - convert hD (Fin.last r) using 1 - simp only [iLast, Fin.castLE, Fin.last, Fin.castSucc] - let pullback := fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - parameterPreimage V DLast - have hPullback (V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n)) : - IsInsensitive iLast.castSucc (Fin.last k) (pullback V) := - parameterPreimage_isInsensitive V DLast hLast - have existsInner (V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n)) : - ∃ 𝒲 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin M)), - 𝒲.Finite ∧ - (∀ W ∈ 𝒲, Subspace.IsContained W (pullback V)) ∧ - (𝒲.PairwiseDisjoint fun W ↦ - (Subspace.range W : Set (Fin M → Fin (k + 1)))) ∧ - ((uncovered (pullback V) 𝒲).dens : ℝ) < 2 * β := by - by_cases hV : 2 * β ≤ ((pullback V).dens : ℝ) - · exact hinner iLast (pullback V) (hPullback V) hV - · exact ⟨∅, Set.finite_empty, by simp, Set.pairwiseDisjoint_empty, - by simpa using lt_of_not_ge hV⟩ - choose tiles htilesFinite htilesContained htilesDisjoint htilesDensity using existsInner - let composed := fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - Subspace.compose V '' tiles V - have hcomposed (V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n)) : - (composed V).Finite ∧ - (∀ U ∈ composed V, Subspace.IsContained U DLast) ∧ - ((composed V).PairwiseDisjoint fun U ↦ - (Subspace.range U : Set (Fin n → Fin (k + 1)))) := - composed_inner_tiles_facts DLast V (tiles V) - (htilesFinite V) (htilesContained V) (htilesDisjoint V) - let global : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) := - ⋃ V : 𝒱, composed V - obtain ⟨hglobalFinite, hglobalContained, hglobalDisjoint⟩ := - composed_outer_tiles_facts D D₀ (fun _ ↦ rfl) 𝒱 hfinite - hcontained hpairwise tiles (fun V ↦ by simpa only [composed] using hcomposed V) - refine ⟨global, ?_, ?_, ?_, ?_⟩ - · simpa only [global, composed] using hglobalFinite - · simpa only [global, composed] using hglobalContained - · simpa only [global, composed] using hglobalDisjoint - · let outer := hfinite.toFinset - let innerError := fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ - (uncovered (pullback V) (tiles V)).map ⟨V, Subspace.injective V⟩ - let errors := outer.biUnion innerError - have herrors : (errors.dens : ℝ) ≤ 2 * β := by - simpa only [errors, outer, innerError] using - mapped_inner_errors_density_le hβ₀ 𝒱 hfinite hpairwise - (fun V ↦ uncovered (pullback V) (tiles V)) - (fun V ↦ (htilesDensity V).le) - have huncovered_subset : - uncovered (intersection D) global ⊆ - uncovered (intersection D₀) 𝒱 ∪ errors := by - simpa only [global, composed, errors, outer, innerError, pullback, DLast] using - uncovered_composed_tiles_subset D D₀ hsubset 𝒱 hfinite tiles - have hdens : - ((uncovered (intersection D) global).dens : ℝ) ≤ - ((uncovered (intersection D₀) 𝒱 ∪ errors).dens : ℝ) := by - exact_mod_cast Finset.dens_mono huncovered_subset - have hdens_union : - ((uncovered (intersection D₀) 𝒱 ∪ errors).dens : ℝ) ≤ - ((uncovered (intersection D₀) 𝒱).dens : ℝ) + (errors.dens : ℝ) := by - exact_mod_cast Finset.dens_union_le (uncovered (intersection D₀) 𝒱) errors - refine hdens.trans_lt (hdens_union.trans_lt ?_) - convert add_lt_add_of_lt_of_le huncovered herrors using 1 - push_cast - ring - -/-- Induction on the number of insensitive families gives one exact sufficient intersection-tiling -dimension. -/ -lemma exists_intersectionTilingSufficient_dimension (k r m : ℕ) (hDHJ : HasDensityHJ k) - (hr₀ : 1 ≤ r) (hrk : r ≤ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) : - ∃ N, IntersectionTilingSufficient k r m β N := by - induction r using Nat.strong_induction_on generalizing m with - | h r ih => - obtain rfl | hr := r - · omega - obtain rfl | s := hr - · obtain ⟨N, hN⟩ := exists_tilingSufficient_dimension k m hDHJ hm hβ₀ - exact ⟨N, intersectionTilingSufficient_one hN⟩ - · let M := max 1 (tilingBound k m β) - have hM : 1 ≤ M := le_max_left _ _ - obtain ⟨N, houter⟩ := - ih (s + 1) (by omega) M (by omega) (by omega) hM - have hinner : TilingSufficient k m β M := - tilingBound_spec k m M hDHJ hm hβ₀ (le_max_right _ _) - exact ⟨N, extend_intersection_tiling (by omega) (by omega) hβ₀ houter hinner⟩ - -/-- Exact intersection-tiling sufficiency transports to every larger coordinate dimension. -/ -private lemma intersectionTilingSufficient_mono {k r m N n : ℕ} {β : ℝ} + intro hrk D hD + obtain ⟨𝒱, h𝒱, houter⟩ := houter (by omega) _ fun i ↦ hD i.castSucc + choose tiles htiles hinner using fun V : Combinatorics.Subspace (Fin M) (Fin (k + 1)) (Fin n) ↦ + hinner _ _ (parameterPreimage_isInsensitive V (hD (Fin.last r))) + refine ⟨composeTiles 𝒱 tiles, ?_, ?_⟩ + · rw [intersection_eq_inter_last] + exact h𝒱.composeTiles fun V _ ↦ htiles V + · rw [intersection_eq_inter_last] + have h := dens_uncovered_composeTiles_le h𝒱 (by positivity) fun V _ ↦ (hinner V).le + rw [Nat.cast_add_one] + linarith + +/-- Intersection-tiling sufficiency in one dimension gives it in every larger one. -/ +private lemma intersectionTilingSufficient_mono {r N : ℕ} {β : ℝ} (hN : IntersectionTilingSufficient k r m β N) (hNn : N ≤ n) : IntersectionTilingSufficient k r m β n := by - classical - intro hr₀ hrk D hD hDβ - let q := n - N - have hNq : N + q = n := Nat.add_sub_of_le hNn - let e : Fin q ⊕ Fin N ≃ Fin n := - (Equiv.sumComm (Fin q) (Fin N)).trans <| finSumFinEquiv.trans (finCongr hNq) - let wordEquiv := e.arrowCongr (Equiv.refl (Fin (k + 1))) - let D' := fun i ↦ (D i).map wordEquiv.symm.toEmbedding - let slice := fun z : Fin q → Fin (k + 1) ↦ fun i ↦ fiber (D' i) z - have hslice (z : Fin q → Fin (k + 1)) (i : Fin r) : - IsInsensitive (Fin.castLE hrk i).castSucc (Fin.last k) (slice z i) := by - intro x y hxy - simp only [slice, mem_fiber, D', Finset.mem_map_equiv] - apply hD i - intro a hai hal c - cases hc : e.symm c with - | inl j => simp [wordEquiv, Equiv.arrowCongr, hc] - | inr j => simpa [wordEquiv, Equiv.arrowCongr, hc] using hxy a hai hal j - let I := intersection D - let I' := I.map wordEquiv.symm.toEmbedding - have hIdens : (I'.dens : ℝ) = (I.dens : ℝ) := by - simp only [I', Finset.dens_map_equiv] - have hfiberI (z : Fin q → Fin (k + 1)) : - fiber I' z = intersection (slice z) := by + intro hrk D hD + refine exists_tiling_of_sections (e := (Subspace.cutEquiv (Nat.sub_add_cancel hNn)).symm) ?_ + intro z + have hz : fiber (transportWords (Subspace.cutEquiv (Nat.sub_add_cancel hNn)).symm + (intersection D)) z = intersection fun i ↦ + fiber (transportWords (Subspace.cutEquiv (Nat.sub_add_cancel hNn)).symm (D i)) z := by ext y - simp only [mem_fiber, Finset.mem_map_equiv, I', I, mem_intersection, slice, D', - Equiv.symm_symm] - have existsLocal (z : Fin q → Fin (k + 1)) : - ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin N)), - 𝒱.Finite ∧ - (∀ V ∈ 𝒱, Subspace.IsContained V (intersection (slice z))) ∧ - (𝒱.PairwiseDisjoint fun V ↦ - (Subspace.range V : Set (Fin N → Fin (k + 1)))) ∧ - ((uncovered (intersection (slice z)) 𝒱).dens : ℝ) < 2 * r * β := by - by_cases hz : 2 * r * β ≤ ((intersection (slice z)).dens : ℝ) - · exact hN hr₀ hrk (slice z) (hslice z) hz - · exact ⟨∅, Set.finite_empty, by simp, Set.pairwiseDisjoint_empty, - by simpa using lt_of_not_ge hz⟩ - choose tiles hlocalFinite hlocalContained hlocalDisjoint hlocalDensity using existsLocal - let global : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) := - ⋃ z, padExtraSubspace e z '' tiles z - obtain ⟨hglobalFinite, hglobalContained, hglobalDisjoint⟩ := padded_tiles_facts e I tiles - hlocalFinite - (fun z V hV ↦ by simpa only [I', ← hfiberI z] using hlocalContained z V hV) - hlocalDisjoint - refine ⟨global, hglobalFinite, ?_, hglobalDisjoint, ?_⟩ - · simpa only [I, mem_intersection] using hglobalContained - · let E := (uncovered I global).map wordEquiv.symm.toEmbedding - have hfiber (z : Fin q → Fin (k + 1)) : - fiber E z = uncovered (intersection (slice z)) (tiles z) := by - rw [← hfiberI z] - simpa only [E, global, I', wordEquiv] using fiber_uncovered_padded e I tiles z - have hEdens : - (E.dens : ℝ) = ((uncovered I global).dens : ℝ) := by - simp only [E, Finset.dens_map_equiv] - rw [← hEdens, ← average_density_fiber] - apply Finset.expect_lt - · intro z _ - rw [hfiber] - exact (hlocalDensity z).le - · let z : Fin q → Fin (k + 1) := fun _ ↦ 0 - refine ⟨z, Finset.mem_univ z, ?_⟩ - rw [hfiber] - exact hlocalDensity z - -/-- Intersection-tiling sufficiency is upward closed after padding with unused final -coordinates. -/ -lemma exists_eventually_intersectionTilingSufficient (k r m : ℕ) (hDHJ : HasDensityHJ k) - (hr₀ : 1 ≤ r) (hrk : r ≤ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) : - ∃ N, ∀ n ≥ N, IntersectionTilingSufficient k r m β n := by - obtain ⟨N, hN⟩ := - exists_intersectionTilingSufficient_dimension k r m hDHJ hr₀ hrk hm hβ₀ - exact ⟨N, fun _n hn ↦ intersectionTilingSufficient_mono hN hn⟩ - -/-- A sufficient ambient dimension for tiling an intersection of insensitive families, again -selected under `HasDensityHJ k`. -/ -noncomputable def intersectionTilingBound (k r m : ℕ) (β : ℝ) : ℕ := by - classical - exact if h : HasDensityHJ k ∧ 1 ≤ r ∧ r ≤ k ∧ 1 ≤ m ∧ 0 < β then - Nat.find (exists_eventually_intersectionTilingSufficient - k r m h.1 h.2.1 h.2.2.1 h.2.2.2.1 h.2.2.2.2) - else 0 - -/-- The selected intersection-tiling bound satisfies the tiling predicate in every larger -dimension. -/ -lemma intersectionTilingBound_spec (k r m n : ℕ) (hDHJ : HasDensityHJ k) - (hr₀ : 1 ≤ r) (hrk : r ≤ k) (hm : 1 ≤ m) - {β : ℝ} (hβ₀ : 0 < β) - (hn : intersectionTilingBound k r m β ≤ n) : + simp + rw [hz] + exact hN hrk _ fun i ↦ ((hD i).reindex _).fiberSection z + +/-- A dimension sufficient for tiling an intersection of `r` insensitive families by +`m`-dimensional subspaces with tolerance `β`, by induction on `r`: tile the first `r - 1` families +by subspaces large enough to tile the last one. -/ +noncomputable def intersectionTilingBound (k : ℕ) (F : ℝ → ℕ) : ℕ → ℕ → ℝ → ℕ + | 0, _, _ => 0 + | 1, m, β => tilingBound k F m β + | r + 2, m, β => intersectionTilingBound k F (r + 1) (max 1 (tilingBound k F m β)) β + +/-- `IntersectionTilingSufficient k r m β n` holds for every +`n ≥ intersectionTilingBound k F r m β`. -/ +lemma intersectionTilingSufficient_of_le {r : ℕ} {F : ℝ → ℕ} (hF : IsDHJBound k F) + (hr₀ : 1 ≤ r) (hm : 1 ≤ m) {β : ℝ} (hβ₀ : 0 < β) + (hn : intersectionTilingBound k F r m β ≤ n) : IntersectionTilingSufficient k r m β n := by - classical - rw [intersectionTilingBound, - dite_eq_left ⟨hDHJ, hr₀, hrk, hm, hβ₀⟩] at hn - exact Nat.find_spec - (exists_eventually_intersectionTilingSufficient k r m hDHJ hr₀ hrk hm hβ₀) n hn + refine intersectionTilingSufficient_mono ?_ hn + clear hn + induction r using Nat.strong_induction_on generalizing m with + | h r ih => + obtain _ | _ | r := r + · omega + · exact intersectionTilingSufficient_one (tilingSufficient_of_le hF hm hβ₀ le_rfl) + · exact extend_intersection_tiling hβ₀ (ih (r + 1) (by omega) (by omega) (le_max_left _ _)) + (tilingSufficient_of_le hF hm hβ₀ (le_max_right _ _)) /-- An intersection of insensitive families can be tiled by disjoint subspaces. -/ -lemma exists_disjoint_subspaces_iInter {k : ℕ} (r m n : ℕ) (hDHJ : HasDensityHJ k) - (hr₀ : 1 ≤ r) (hrk : r ≤ k) (hm : 1 ≤ m) - (β : ℝ) (hβ₀ : 0 < β) - (hn : intersectionTilingBound k r m β ≤ n) - (D : Fin r → Finset (Fin n → Fin (k + 1))) - (hD : ∀ i, IsInsensitive (Fin.castLE hrk i).castSucc (Fin.last k) (D i)) - (hDβ : 2 * r * β ≤ ((intersection D).dens : ℝ)) : +lemma exists_disjoint_subspaces_iInter {r : ℕ} {F : ℝ → ℕ} (hF : IsDHJBound k F) + (hr₀ : 1 ≤ r) (hrk : r ≤ k) (hm : 1 ≤ m) {β : ℝ} (hβ₀ : 0 < β) + (hn : intersectionTilingBound k F r m β ≤ n) {D : Fin r → Finset (Fin n → Fin (k + 1))} + (hD : ∀ i, IsInsensitive (Fin.castLE hrk i).castSucc (Fin.last k) (D i)) : ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)), - 𝒱.Finite ∧ - (∀ V ∈ 𝒱, Subspace.IsContained V (intersection D)) ∧ - (𝒱.PairwiseDisjoint fun V ↦ (Subspace.range V : Set (Fin n → Fin (k + 1)))) ∧ - ((uncovered (intersection D) 𝒱).dens : ℝ) < 2 * r * β := - intersectionTilingBound_spec k r m n hDHJ hr₀ hrk hm hβ₀ hn hr₀ hrk D hD hDβ + IsTiling 𝒱 (intersection D) ∧ ((uncovered (intersection D) 𝒱).dens : ℝ) < 2 * r * β := + intersectionTilingSufficient_of_le hF hr₀ hm hβ₀ hn hrk D hD end IsInsensitive end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean index 41b46ddd6c..ebabfda975 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean @@ -5,17 +5,30 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement -public import Mathlib.Combinatorics.SetFamily.LYM -public import Mathlib.Analysis.Real.Sqrt -import Mathlib.Analysis.SpecificLimits.Basic -public import Mathlib.Data.Nat.Choose.Central -import Mathlib.Tactic.LinearCombination +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides +public import Mathlib.Computability.Ackermann +public import Mathlib.Order.Lattice.Nat +import LeanPool.DensityHalesJewett.DensityHalesJewett.Ackermann +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Analysis.Real.Sqrt /-! -# Density Hales--Jewett - -The binary base case and induction on the alphabet size. +# The density theorems + +The density Hales--Jewett theorem, Szemerédi's theorem and Varnavides' theorem, each with the +Ackermann function as the bound. + +* `Combinatorics.Line.exists_of_density`: over `k` letters, in every dimension + `n ≥ ack (4 * k) (k + ⌈1 / δ⌉₊)`, every set of words of density `δ` contains a combinatorial + line. +* `Combinatorics.ArithmeticProgression.exists_of_density_nat`: for + `n ≥ ack (4 * k + 1) (k + ⌈1 / δ⌉₊)`, every subset of `range n` of density `δ` contains an + arithmetic progression of length `k`. +* `Combinatorics.ArithmeticProgression.exists_many_of_density_nat`: for the same `n`, it contains + at least `n ^ 2 / ack (4 * k + 1) (k + ⌈1 / δ⌉₊)` of them. + +The least threshold for the first theorem is the density Hales--Jewett number +`Combinatorics.Line.dhjNumber k δ`, so it is at most `ack (4 * k) (k + ⌈1 / δ⌉₊)`. -/ @[expose] public section @@ -23,456 +36,135 @@ The binary base case and induction on the alphabet size. open Finset open Combinatorics -namespace DensityHalesJewett - -/-- Identify a binary word with the coordinates on which it equals `1`. -/ -def binarySupport {ι : Type*} [Fintype ι] (w : ι → Fin 2) : Finset ι := - Finset.univ.filter fun i ↦ w i = 1 - -/-- Two binary words are the ordered points of a combinatorial line exactly when their supports -are strictly comparable. -/ -lemma binary_line_iff_ssubset {ι : Type*} [Fintype ι] (x y : ι → Fin 2) : - (∃ l : Combinatorics.Line (Fin 2) ι, l 0 = x ∧ l 1 = y) ↔ - binarySupport x ⊂ binarySupport y := by - have hmem : ∀ (w : ι → Fin 2) (j : ι), j ∈ binarySupport w ↔ w j = 1 := by simp [binarySupport] - constructor - · rintro ⟨l, rfl, rfl⟩ - obtain ⟨i, hi⟩ := l.proper - refine (ssubset_iff_of_subset ?_).2 ⟨i, by simp [hmem, hi], by simp [hmem, hi]⟩ - intro j hj - cases hj' : l.idxFun j <;> simp_all - · intro h - obtain ⟨i, hiy, hix⟩ := exists_of_ssubset h - have hsub : ∀ j, x j = 1 → y j = 1 := by - intro j hj - exact (hmem y j).1 (h.1 ((hmem x j).2 hj)) - refine ⟨⟨fun j ↦ if x j = y j then some (x j) else none, i, by grind⟩, ?_, ?_⟩ <;> - funext j <;> grind [Combinatorics.Line.coe_apply] - -/-- Binary support faithfully records a binary word. -/ -lemma binarySupport_injective {ι : Type*} [Fintype ι] : - Function.Injective (binarySupport : (ι → Fin 2) → Finset ι) := by - intro x y hxy - funext i - apply Fin.ext - have hi : x i = 1 ↔ y i = 1 := by - simpa only [binarySupport, mem_filter, mem_univ, true_and] using Finset.ext_iff.mp hxy i - grind - -/-- A squared elementary upper bound for the normalized central binomial coefficient. -/ -lemma centralBinom_ratio_sq_mul_le (m : ℕ) : - ((Nat.centralBinom m : ℝ) / 4 ^ m) ^ 2 * (3 * m + 1) ≤ 1 := by - induction m with - | zero => norm_num [Nat.centralBinom] - | succ m ih => - have hrec : ((m + 1 : ℕ) : ℝ) * Nat.centralBinom (m + 1) = - 2 * (2 * m + 1) * Nat.centralBinom m := by - exact_mod_cast Nat.succ_mul_centralBinom_succ m - have hratio : (Nat.centralBinom (m + 1) : ℝ) / 4 ^ (m + 1) = - ((Nat.centralBinom m : ℝ) / 4 ^ m) * - ((2 * m + 1 : ℝ) / (2 * (m + 1))) := by - rw [pow_succ] - field_simp - push_cast at hrec ⊢ - linear_combination 2 * hrec - rw [hratio, mul_pow, mul_assoc] - refine le_trans (mul_le_mul_of_nonneg_left ?_ (sq_nonneg _)) ih - rw [div_pow, div_mul_eq_mul_div] - apply (div_le_iff₀ (sq_pos_of_pos (by positivity))).mpr - push_cast - ring_nf - nlinarith - -/-- The middle binomial coefficient is at most the reciprocal square-root proportion of the -Boolean cube. -/ -lemma centralBinom_ratio_le_inv_sqrt (m : ℕ) : - (Nat.centralBinom m : ℝ) / 4 ^ m ≤ (√(3 * m + 1))⁻¹ := by - rw [inv_eq_one_div, le_div_iff₀ (Real.sqrt_pos.2 (by positivity)), - ← sq_le_sq₀ (by positivity) (by positivity), mul_pow, Real.sq_sqrt (by positivity)] - simpa only [one_pow] using centralBinom_ratio_sq_mul_le m - -/-- The two normalizations of the binomial denominator, one per half-dimension and one per -dimension, agree. -/ -private lemma two_pow_two_mul (m : ℕ) : (2 : ℝ) ^ (2 * m) = 4 ^ m := by - rw [pow_mul] - norm_num - -/-- Reduce the normalized middle binomial coefficient in any dimension to the central coefficient -in half that dimension. -/ -lemma middleBinomial_ratio_le_central (n : ℕ) : - (n.choose (n / 2) : ℝ) / 2 ^ n ≤ - (Nat.centralBinom (n / 2) : ℝ) / 4 ^ (n / 2) := by - obtain ⟨m, hm | hm⟩ := Nat.even_or_odd' n - · subst n - have hdiv : 2 * m / 2 = m := by grind - rw [hdiv, Nat.centralBinom, two_pow_two_mul] - · subst n - have hdiv : (2 * m + 1) / 2 = m := by grind - rw [hdiv, Nat.centralBinom] - cases m with - | zero => norm_num - | succ m => - have hchoose : (2 * (m + 1) + 1).choose (m + 1) ≤ - 2 * Nat.centralBinom (m + 1) := by - rw [Nat.choose_succ_left (2 * (m + 1)) (m + 1) (by grind)] - simpa only [Nat.add_sub_cancel, two_mul] using - add_le_add (Nat.choose_le_centralBinom m (m + 1)) - (Nat.choose_le_centralBinom (m + 1) (m + 1)) - rw [pow_succ, two_pow_two_mul, mul_comm (4 ^ (m + 1) : ℝ) 2] - apply le_trans (b := (2 * Nat.centralBinom (m + 1) : ℝ) / - (2 * 4 ^ (m + 1))) - · exact (div_le_div_iff_of_pos_right - (by positivity : (0 : ℝ) < 2 * 4 ^ (m + 1))).mpr <| by - exact_mod_cast hchoose - · field_simp - rfl - -/-- Eventually the middle layer occupies less than any prescribed positive proportion of the -Boolean cube. -/ -lemma exists_middleBinomial_lt (δ : ℝ) (hδ : 0 < δ) : - ∃ N, ∀ n, N ≤ n → (n.choose (n / 2) : ℝ) < δ * 2 ^ n := by - have ht : Filter.Tendsto (fun m : ℕ ↦ (√(3 * (m : ℝ) + 1))⁻¹) - Filter.atTop (nhds 0) := by - apply tendsto_inv_atTop_zero.comp - apply Real.tendsto_sqrt_atTop.comp - simpa only [add_comm] using - tendsto_const_nhds.add_atTop - ((tendsto_natCast_atTop_atTop : Filter.Tendsto (fun m : ℕ ↦ (m : ℝ)) - Filter.atTop Filter.atTop).const_mul_atTop (by norm_num : (0 : ℝ) < 3)) - obtain ⟨M, hM⟩ := Filter.eventually_atTop.mp (ht.eventually_lt_const hδ) - refine ⟨2 * M, ?_⟩ - intro n hn - have hMn : M ≤ n / 2 := (Nat.le_div_iff_mul_le (by norm_num)).mpr (by grind) - apply (div_lt_iff₀ (by positivity : (0 : ℝ) < 2 ^ n)).mp - apply (middleBinomial_ratio_le_central n).trans_lt - apply (centralBinom_ratio_le_inv_sqrt (n / 2)).trans_lt - exact hM (n / 2) hMn - -/-- Density Hales--Jewett for the binary alphabet. -/ -lemma dhj_two : HasDensityHJ 2 := by - intro δ hδ - obtain ⟨N, hN⟩ := exists_middleBinomial_lt δ hδ - refine ⟨N, ?_⟩ - intro n hn A hA - by_contra hline - let B := A.image binarySupport - have hB : IsAntichain (· ⊆ ·) (B : Set (Finset (Fin n))) := by - intro s hs t ht hst hsub - change s ∈ B at hs - change t ∈ B at ht - obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hs - obtain ⟨y, hy, rfl⟩ := Finset.mem_image.mp ht - apply hline - obtain ⟨l, hlx, hly⟩ := (binary_line_iff_ssubset x y).2 <| - Finset.ssubset_iff_subset_ne.2 ⟨hsub, hst⟩ - refine ⟨l, ?_⟩ - intro a - obtain rfl | ⟨i, rfl⟩ := a.eq_zero_or_eq_succ - · rw [hlx] - exact hx - · simp only [Fin.eq_zero i] - change l 1 ∈ A - rwa [hly] - have hcard : #A ≤ n.choose (n / 2) := by - rw [← Finset.card_image_of_injective A binarySupport_injective] - simpa only [B, Fintype.card_fin] using hB.sperner - exact (not_lt_of_ge (hA.trans <| by exact_mod_cast hcard)) (hN n hn) - -/-- A positive uniform increment eventually raises the density floor above one. -/ -lemma exists_density_increment_steps {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : - ∃ R : ℕ, 1 < δ + (R : ℝ) * (Parameters.γ k δ / 2) := by - refine ⟨⌈2 / (Parameters.γ k δ)⌉₊ + 1, ?_⟩ - refine lt_trans (?_) (lt_add_of_pos_left _ hδ) - simp only [Nat.cast_add, Nat.cast_one] - rw [← mul_div_assoc] - apply (lt_div_iff₀ zero_lt_two).2 - simp only [one_mul] - apply (div_lt_iff₀ (Parameters.γ_pos hk hδ)).1 - apply lt_of_le_of_lt (Nat.ceil_le.mp le_rfl) (by grind) - -/-- Choose the dimensions for a finite density-increment iteration backwards. - -The last parameter cube has dimension one. At stage `j`, the preceding dimension is large enough -to apply `density_increment` with density floor `δ + j * (γ k δ / 2)` and target dimension -`d (j + 1)`. -/ -lemma exists_density_increment_schedule (k R : ℕ) (δ : ℝ) : - ∃ d : ℕ → ℕ, - d R = 1 ∧ - (∀ j, j ≤ R → 1 ≤ d j) ∧ - ∀ j, j < R → - incrementBound k (d (j + 1)) (δ + (j : ℝ) * (Parameters.γ k δ / 2)) ≤ d j := by - let γ := Parameters.γ k δ - let d_aux : ℕ → ℕ := - Nat.rec 1 (fun t d_t => max 1 (incrementBound k d_t (δ + ((R - (t + 1) : ℕ) : ℝ) * (γ / 2)))) - let d : ℕ → ℕ := fun j => d_aux (R - j) - have h_aux_succ (t : ℕ) : d_aux (t + 1) = - max 1 (incrementBound k (d_aux t) (δ + ((R - (t + 1) : ℕ) : ℝ) * (γ / 2))) := rfl - have h_aux_one (t : ℕ) : 1 ≤ d_aux t := by - induction t with - | zero => simp [d_aux] - | succ t ih => rw [h_aux_succ t]; exact le_max_left _ _ - have h_d_R : d R = 1 := by - dsimp [d, d_aux] - simp - have h_d_one (j : ℕ) (hj : j ≤ R) : 1 ≤ d j := by - dsimp [d] - exact h_aux_one (R - j) - have h_d_step (j : ℕ) (hj : j < R) : - incrementBound k (d (j + 1)) (δ + (j : ℝ) * (γ / 2)) ≤ d j := by - have h_sub : R - j = (R - (j + 1)) + 1 := by omega - have h_index : (R - ((R - (j + 1) : ℕ) + 1) : ℕ) = j := by omega - dsimp [d] - rw [h_sub, h_aux_succ (R - (j + 1)), h_index] - exact le_max_right _ _ - exact ⟨d, h_d_R, h_d_one, h_d_step⟩ - -/-- Split the first `m` coordinates from the remaining coordinates of `Fin n`. -/ -def prefixCoordinateEquiv {m n : ℕ} (hmn : m ≤ n) : Fin m ⊕ Fin (n - m) ≃ Fin n := - finSumFinEquiv.trans (finCongr (Nat.add_sub_of_le hmn)) - -/-- Assemble a word from its first `m` coordinates and a fixed remaining suffix. -/ -def prefixCoordinateWord {α : Type*} {m n : ℕ} (hmn : m ≤ n) - (x : Fin m → α) (y : Fin (n - m) → α) : Fin n → α := - Sum.elim x y ∘ (prefixCoordinateEquiv hmn).symm - -/-- The coordinate subspace obtained by fixing every coordinate after the first `m`. -/ -def prefixCoordinateSubspace {α : Type*} {m n : ℕ} (hmn : m ≤ n) - (y : Fin (n - m) → α) : Combinatorics.Subspace (Fin m) α (Fin n) where - idxFun i := ((prefixCoordinateEquiv hmn).symm i).elim Sum.inr (Sum.inl ∘ y) - proper e := by - refine ⟨prefixCoordinateEquiv hmn (Sum.inl e), ?_⟩ - simp only [Equiv.symm_apply_apply, Sum.elim_inl] - -@[simp] -lemma prefixCoordinateSubspace_apply {α : Type*} {m n : ℕ} (hmn : m ≤ n) - (y : Fin (n - m) → α) (x : Fin m → α) : - prefixCoordinateSubspace hmn y x = prefixCoordinateWord hmn x y := by - funext i - change (((prefixCoordinateEquiv hmn).symm i).elim Sum.inr (Sum.inl ∘ y)).elim id x = - Sum.elim x y ((prefixCoordinateEquiv hmn).symm i) - cases (prefixCoordinateEquiv hmn).symm i <;> rfl - -/-- Some fixed suffix leaves a first-coordinate fiber at least as dense as the ambient family. -/ -lemma exists_dense_prefixCoordinateWord {k m n : ℕ} (hmn : m ≤ n) - (A : Finset (Fin n → Fin (k + 1))) : - ∃ y : Fin (n - m) → Fin (k + 1), - (A.dens : ℝ) ≤ - ((Finset.univ.filter fun x : Fin m → Fin (k + 1) ↦ - prefixCoordinateWord hmn x y ∈ A).dens : ℝ) := by - let eCoord := (Equiv.sumComm (Fin (n - m)) (Fin m)).trans (prefixCoordinateEquiv hmn) - let eWord := eCoord.arrowCongr (Equiv.refl (Fin (k + 1))) - let A' := A.map eWord.symm.toEmbedding - have hA' : (A'.dens : ℝ) = (A.dens : ℝ) := by - simp only [A', Finset.dens_map_equiv] - have havg : - (A.dens : ℝ) ≤ Finset.expect Finset.univ (fun y : Fin (n - m) → Fin (k + 1) ↦ - ((fiber A' y).dens : ℝ)) := by - rw [average_density_fiber, hA'] - obtain ⟨y, _, hy⟩ := Finset.exists_le_of_le_expect Finset.univ_nonempty havg - refine ⟨y, ?_⟩ - have hword (x : Fin m → Fin (k + 1)) : - eWord (Sum.elim y x) = prefixCoordinateWord hmn x y := by - funext i - cases h : (prefixCoordinateEquiv hmn).symm i <;> - simp [eWord, eCoord, prefixCoordinateWord, Equiv.arrowCongr, Sum.elim, h, - Function.comp_apply] - have hfiber : fiber A' y = Finset.univ.filter fun x : Fin m → Fin (k + 1) ↦ - prefixCoordinateWord hmn x y ∈ A := by - ext x - simp only [mem_fiber, Finset.mem_filter, Finset.mem_univ, true_and, A', - Finset.mem_map_equiv, Equiv.symm_symm] - rw [hword] - rwa [← hfiber] - -/-- A coordinate fiber of any prescribed smaller dimension has relative density at least the -ambient density. -/ -lemma exists_density_preserving_subspace_of_le {k m n : ℕ} (hmn : m ≤ n) - (A : Finset (Fin n → Fin (k + 1))) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - (A.dens : ℝ) ≤ (Subspace.relativeDensity V A : ℝ) := by - obtain ⟨y, hy⟩ := exists_dense_prefixCoordinateWord hmn A - refine ⟨prefixCoordinateSubspace hmn y, ?_⟩ - simpa only [Subspace.relativeDensity, prefixCoordinateSubspace_apply] using hy - -/-- One scheduled density-increment stage either produces an ambient line or advances the nested -subspace while preserving the quantitative density invariant. -/ -lemma density_increment_chain_step {k R n j : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) {δ : ℝ} (hδ : 0 < δ) - (d : ℕ → ℕ) (hd : ∀ t, t ≤ R → 1 ≤ d t) - (hstep : ∀ t, t < R → - incrementBound k (d (t + 1)) - (δ + (t : ℝ) * (Parameters.γ k δ / 2)) ≤ d t) - (hj : j < R) (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin (d j)) (Fin (k + 1)) (Fin n)) - (hV : δ + (j : ℝ) * (Parameters.γ k δ / 2) ≤ - (Subspace.relativeDensity V A : ℝ)) : - (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ - ∃ W : Combinatorics.Subspace (Fin (d (j + 1))) (Fin (k + 1)) (Fin n), - δ + ((j + 1 : ℕ) : ℝ) * (Parameters.γ k δ / 2) ≤ - (Subspace.relativeDensity W A : ℝ) := by - let ρ := δ + (j : ℝ) * (Parameters.γ k δ / 2) - have hγ := Parameters.γ_mono_lowerBound hk hδ - have hρ₀ : 0 < ρ := by - dsimp only [ρ] - nlinarith [hγ.1, (Nat.cast_nonneg j : (0 : ℝ) ≤ (j : ℝ))] - have hρ₁ : ρ ≤ 1 := hV.trans (by - rw [← dens_pullback] - exact_mod_cast Finset.dens_le_one (s := pullback V A)) - have hinc := density_increment hk hDHJ (d (j + 1)) - (hd (j + 1) (Nat.succ_le_of_lt hj)) ρ hρ₀ hρ₁ (d j) (hstep j hj) - (pullback V A) (by - simpa only [ρ, dens_pullback] using hV) - obtain ⟨l, hl⟩ | ⟨U, hU⟩ := hinc - · left - use Subspace.mapLine V l - intro a - simpa only [Subspace.mapLine_apply, pullback, parameterPreimage, - Finset.mem_filter, Finset.mem_univ, true_and] using hl a - · right - use Subspace.compose V U - rw [Subspace.relativeDensity_compose] - dsimp only [ρ] at hU - have hδρ : δ ≤ δ + (j : ℝ) * (Parameters.γ k δ / 2) := by - nlinarith [hγ.1, (Nat.cast_nonneg j : (0 : ℝ) ≤ (j : ℝ))] - norm_num [Nat.cast_add, Nat.cast_one] - linarith [hγ.2 _ hδρ] - -/-- Iterating the one-step lemma along the schedule either finds a line or reaches the last -scheduled subspace with the accumulated density lower bound. -/ -lemma line_or_density_increment_chain {k R n : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) {δ : ℝ} (hδ : 0 < δ) - (d : ℕ → ℕ) (hd : ∀ j, j ≤ R → 1 ≤ d j) - (hstep : ∀ j, j < R → - incrementBound k (d (j + 1)) - (δ + (j : ℝ) * (Parameters.γ k δ / 2)) ≤ d j) - (A : Finset (Fin n → Fin (k + 1))) - (V₀ : Combinatorics.Subspace (Fin (d 0)) (Fin (k + 1)) (Fin n)) - (hV₀ : δ ≤ (Subspace.relativeDensity V₀ A : ℝ)) : - (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ - ∃ V : Combinatorics.Subspace (Fin (d R)) (Fin (k + 1)) (Fin n), - δ + (R : ℝ) * (Parameters.γ k δ / 2) ≤ - (Subspace.relativeDensity V A : ℝ) := by - suffices ∀ j, j ≤ R → - (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ - ∃ V : Combinatorics.Subspace (Fin (d j)) (Fin (k + 1)) (Fin n), - δ + (j : ℝ) * (Parameters.γ k δ / 2) ≤ - (Subspace.relativeDensity V A : ℝ) by - exact this R le_rfl - intro j hj - induction j with - | zero => - right - exact ⟨V₀, by simpa only [Nat.cast_zero, zero_mul, add_zero] using hV₀⟩ - | succ j ih => - obtain hline | ⟨V, hV⟩ := ih (Nat.le_of_succ_le hj) - · left - exact hline - · exact density_increment_chain_step hk hDHJ hδ d hd hstep - (Nat.lt_of_succ_le hj) A V hV - -/-- Iterate the density-increment dichotomy along a backward dimension schedule. - -Pull back the family after each increment and compose the resulting nested subspaces. A line in -any parameter cube gives a line in the original family. Otherwise monotonicity of `Parameters.γ` -raises the density by at least `Parameters.γ k δ / 2` at every stage, and the final relative -density is at most one. -/ -lemma line_or_iterated_density_le_one {k R n : ℕ} (hk : 2 ≤ k) (hDHJ : HasDensityHJ k) - {δ : ℝ} (hδ : 0 < δ) (d : ℕ → ℕ) - (hd : ∀ j, j ≤ R → 1 ≤ d j) - (hstep : ∀ j, j < R → - incrementBound k (d (j + 1)) (δ + (j : ℝ) * (Parameters.γ k δ / 2)) ≤ d j) - (hn : d 0 ≤ n) (A : Finset (Fin n → Fin (k + 1))) (hA : δ ≤ (A.dens : ℝ)) : - (∃ l : Combinatorics.Line (Fin (k + 1)) (Fin n), ∀ a, l a ∈ A) ∨ - δ + (R : ℝ) * (Parameters.γ k δ / 2) ≤ 1 := by - obtain ⟨V₀, hV₀⟩ := - exists_density_preserving_subspace_of_le hn A - obtain hline | ⟨V, hV⟩ := - line_or_density_increment_chain hk hDHJ hδ d hd hstep A V₀ (hA.trans hV₀) - · left - exact hline - · right - apply hV.trans - rw [← dens_pullback] - exact_mod_cast Finset.dens_le_one (s := pullback V A) - -/-- Density Hales--Jewett for every finite alphabet of cardinality at least two. -/ -lemma density_hales_jewett_fin (k : ℕ) (hk : 2 ≤ k) : HasDensityHJ k := by - induction k, hk using Nat.le_induction with - | base => exact dhj_two - | succ k hk hDHJ => - intro δ hδ - obtain ⟨R, hR⟩ := exists_density_increment_steps hk hδ - obtain ⟨d, _, hd, hstep⟩ := exists_density_increment_schedule k R δ - refine ⟨d 0, ?_⟩ - intro n hn A hA - refine (line_or_iterated_density_le_one hk hDHJ hδ d hd hstep hn A ?_).resolve_right ?_ - · exact Subspace.density_le_of_card_le (Nat.zero_lt_succ k) δ A hA - · exact not_le_of_gt hR - -end DensityHalesJewett - namespace Combinatorics.Line -/-- A threshold for the density Hales--Jewett theorem over an alphabet of size `k`. -/ -noncomputable def densityTheoremBound (k : ℕ) (δ : ℝ) : ℕ := - if 2 ≤ k then DensityHalesJewett.Subspace.densityOneBound k δ else 1 - /-- The density theorem for alphabets with at most one letter. -/ -lemma exists_of_density_card_le_one (α : Type*) [Fintype α] - (hα : Fintype.card α ≤ 1) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : 1 ≤ n) (A : Finset (Fin n → α)) +lemma exists_of_density_card_le_one {α : Type*} [Fintype α] + (hα : Fintype.card α ≤ 1) {δ : ℝ} (hδ : 0 < δ) + {n : ℕ} (hn : 1 ≤ n) {A : Finset (Fin n → α)} (hAδ : δ * (Fintype.card α : ℝ) ^ n ≤ #A) : ∃ l : Line α (Fin n), ∀ x : α, l x ∈ A := by classical let : Subsingleton α := Fintype.card_le_one_iff_subsingleton.mp hα let : Nonempty (Fin n) := ⟨⟨0, hn⟩⟩ - refine ⟨Line.diagonal α (Fin n), ?_⟩ + use Line.diagonal α (Fin n) intro x have hcard : Fintype.card α = 1 := Fintype.card_eq_one_of_forall_eq fun y ↦ Subsingleton.elim y x rw [hcard] at hAδ norm_num at hAδ - obtain ⟨w, hw⟩ : A.Nonempty := Finset.card_pos.mp <| by + obtain ⟨w, hw⟩ : A.Nonempty := card_pos.mp <| by exact_mod_cast hδ.trans_le hAδ - simpa only [Subsingleton.elim (Line.diagonal α (Fin n) x) w] using hw + simpa [Subsingleton.elim (Line.diagonal α (Fin n) x) w] using hw /-- Transport the finite-alphabet density theorem across the canonical alphabet equivalence. -/ -lemma exists_of_density_card_ge_two (α : Type*) [Fintype α] - (hα : 2 ≤ Fintype.card α) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : DensityHalesJewett.Subspace.densityOneBound (Fintype.card α) δ ≤ n) - (A : Finset (Fin n → α)) (hAδ : δ * (Fintype.card α : ℝ) ^ n ≤ #A) : +lemma exists_of_density_card_ge_two {α : Type*} [Fintype α] + (hα : 2 ≤ Fintype.card α) {δ : ℝ} (hδ : 0 < δ) + {n : ℕ} (hn : ack (4 * Fintype.card α) (Fintype.card α + ⌈1 / δ⌉₊) ≤ n) + {A : Finset (Fin n → α)} (hAδ : δ * (Fintype.card α : ℝ) ^ n ≤ #A) : ∃ l : Line α (Fin n), ∀ x : α, l x ∈ A := by classical let e := Fintype.equivFin α let wordEquiv : (Fin n → α) ≃ (Fin n → Fin (Fintype.card α)) := (Equiv.refl (Fin n)).arrowCongr e let B := A.map wordEquiv.toEmbedding - have hB : δ * (Fintype.card α : ℝ) ^ n ≤ #B := by - simpa only [B, Finset.card_map] using hAδ - obtain ⟨l, hl⟩ := DensityHalesJewett.Subspace.densityOneBound_spec - (DensityHalesJewett.density_hales_jewett_fin (Fintype.card α) hα) - δ hδ n hn B hB - refine ⟨l.map e.symm, ?_⟩ + obtain ⟨l, hl⟩ := DensityHalesJewett.isDHJBound_ack hα δ hδ n hn B (by grind) + use l.map e.symm intro x specialize hl (e x) - rw [Finset.mem_map_equiv] at hl + rw [mem_map_equiv] at hl change (e.symm ∘ l (e x)) ∈ A at hl rwa [← e.symm_apply_apply x, Combinatorics.Line.map_apply] -lemma densityTheoremBound_spec (α : Type*) [Fintype α] (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityTheoremBound (Fintype.card α) δ ≤ n) +/-- The **density Hales--Jewett theorem**: over a finite alphabet `α` of `k` letters, in every +dimension `n ≥ ack (4 * k) (k + ⌈1 / δ⌉₊)`, every set of at least a `δ` fraction of the words +contains a combinatorial line. -/ +theorem exists_of_density {α : Type*} [Fintype α] {δ : ℝ} (hδ : 0 < δ) + {n : ℕ} (hn : ack (4 * Fintype.card α) (Fintype.card α + ⌈1 / δ⌉₊) ≤ n) (A : Finset (Fin n → α)) (hAδ : δ * (Fintype.card α : ℝ) ^ n ≤ #A) : ∃ l : Line α (Fin n), ∀ x : α, l x ∈ A := by by_cases hα : 2 ≤ Fintype.card α - · refine exists_of_density_card_ge_two α hα δ hδ n ?_ A hAδ - simpa only [densityTheoremBound, ite_eq_left hα] using hn - · refine exists_of_density_card_le_one α (by grind) δ hδ n ?_ A hAδ - simpa only [densityTheoremBound, ite_eq_right hα] using hn - -theorem exists_of_density (α : Type*) [Fintype α] (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityTheoremBound (Fintype.card α) δ ≤ n) - (A : Finset (Fin n → α)) (hAδ : δ * (Fintype.card α : ℝ) ^ n ≤ #A) : - ∃ l : Line α (Fin n), ∀ x : α, l x ∈ A := - densityTheoremBound_spec α δ hδ n hn A hAδ + · exact exists_of_density_card_ge_two hα hδ hn hAδ + · exact exists_of_density_card_le_one (by grind) hδ ((ack_pos _ _).trans_le hn) hAδ + +/-- The **density Hales--Jewett number** of `k` letters and density `δ`: the least `N` such that +density Hales--Jewett holds for `k` letters and density `δ` in every dimension `n ≥ N`. If there is +no such `N`, it is `0`, the value of `sInf ∅`; by `dhjNumber_le_ack` this can only happen for +`δ ≤ 0`. -/ +noncomputable def dhjNumber (k : ℕ) (δ : ℝ) : ℕ := + sInf {N | ∀ n, N ≤ n → DensityHalesJewett.IsDHJDimension k δ n} + +private lemma ack_mem (k : ℕ) {δ : ℝ} (hδ : 0 < δ) : + ack (4 * k) (k + ⌈1 / δ⌉₊) ∈ {N | ∀ n, N ≤ n → DensityHalesJewett.IsDHJDimension k δ n} := + fun n hn A hA ↦ exists_of_density hδ (by simpa using hn) A (by simpa using hA) + +/-- The density Hales--Jewett number is below the Ackermann function at level `4 * k`. -/ +theorem dhjNumber_le_ack (k : ℕ) {δ : ℝ} (hδ : 0 < δ) : + dhjNumber k δ ≤ ack (4 * k) (k + ⌈1 / δ⌉₊) := + Nat.sInf_le (ack_mem k hδ) + +/-- In every dimension `n ≥ dhjNumber k δ`, every set of at least `δ * k ^ n` words of length `n` +over `k` letters contains a combinatorial line. -/ +theorem exists_of_dhjNumber_le {k : ℕ} {δ : ℝ} (hδ : 0 < δ) {n : ℕ} + (hn : dhjNumber k δ ≤ n) (A : Finset (Fin n → Fin k)) (hA : δ * (k : ℝ) ^ n ≤ #A) : + ∃ l : Line (Fin k) (Fin n), ∀ x, l x ∈ A := + Nat.sInf_mem ⟨_, ack_mem k hδ⟩ n hn A hA end Combinatorics.Line + +namespace Combinatorics.ArithmeticProgression + +open DensityHalesJewett AckBounded + +/-- A threshold for Szemerédi's theorem for progressions of length `k + 2`, a fixed number of +applications of `ack (4 * k + 5)` above a bound `N` for `1 / δ`. -/ +private lemma exists_threshold (k : ℕ) {δ : ℝ} (hδ : 0 < δ) {s c N : ℕ} (hs : k + 4 ≤ s) + (hN : AckBounded (4 * k + 5) s c N) (hδN : 1 / δ ≤ N) : + ∃ m, AckBounded (4 * k + 5) s (max 1 c + 5) m ∧ + ∀ n, m ≤ n → ∀ A : Finset ℕ, A ⊆ range n → δ * n ≤ #A → + ∃ P : ArithmeticProgression ℕ (k + 2), P.IsSubset A := by + have hM : 5 ≤ 4 * k + 5 := by omega + obtain ⟨d, hd, hdb⟩ := exists_isDHJDimension_ackBounded k (half_pos hδ) le_rfl hs + ((num hM 2).mul hM hN) (one_div_half_le hδN) + refine ⟨2 * (k + 2) ^ d * N, ?_, ?_⟩ + · exact (((num hM 2).mul hM ((of_le (by omega : k + 2 ≤ s)).pow hM hdb)).mul hM hN).mono + (by omega) + · intro n hn A hAn hA + refine exists_of_isDHJDimension (by omega) hδ hd ?_ A hAn hA + calc 2 * ((k + 2 : ℕ) : ℝ) ^ d / δ = 2 * ((k + 2 : ℕ) : ℝ) ^ d * (1 / δ) := by ring + _ ≤ 2 * ((k + 2 : ℕ) : ℝ) ^ d * N := by gcongr + _ ≤ n := by exact_mod_cast hn + +/-- **Szemerédi's theorem**: for `k ≥ 3` and `n ≥ ack (4 * k + 1) (k + ⌈1 / δ⌉₊)`, every subset of +`range n` with at least `δ * n` elements contains an arithmetic progression of length `k`. -/ +theorem exists_of_density_nat {k : ℕ} (hk : 3 ≤ k) {δ : ℝ} (hδ : 0 < δ) {n : ℕ} + (hn : ack (4 * k + 1) (k + ⌈1 / δ⌉₊) ≤ n) (A : Finset ℕ) (hAn : A ⊆ range n) + (hAδ : δ * n ≤ #A) : ∃ P : ArithmeticProgression ℕ k, P.IsSubset A := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le' (by omega : 2 ≤ k) + obtain ⟨m, hm, h⟩ := exists_threshold k hδ (le_max_left _ ⌈1 / δ⌉₊) (of_le (le_max_right _ _)) + (Nat.le_ceil _) + refine h n (le_trans ?_ hn) A hAn hAδ + exact (hm.le_ack (by omega) (by norm_num) (by omega)).trans + (ack_max_le (Nat.ceil_pos.2 (by positivity))) + +/-- **Varnavides' theorem**: for `k ≥ 3` and `n ≥ ack (4 * k + 1) (k + ⌈1 / δ⌉₊)`, every subset of +`range n` with at least `δ * n` elements contains at least +`n ^ 2 / ack (4 * k + 1) (k + ⌈1 / δ⌉₊)` arithmetic progressions of length `k`. -/ +theorem exists_many_of_density_nat {k : ℕ} (hk : 3 ≤ k) {δ : ℝ} (hδ : 0 < δ) {n : ℕ} + (hn : ack (4 * k + 1) (k + ⌈1 / δ⌉₊) ≤ n) (A : Finset ℕ) (hAn : A ⊆ range n) + (hA : δ * n ≤ #A) : + (n : ℝ) ^ 2 / ack (4 * k + 1) (k + ⌈1 / δ⌉₊) ≤ #(containedProgressions k n A) := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le' (by grind : 2 ≤ k) + set N := ⌈1 / δ⌉₊ + have hM : 5 ≤ 4 * k + 5 := by grind + have hs := of_le (M := 4 * k + 5) (le_max_right (k + 4) N) + obtain ⟨m, hm, hS⟩ := exists_threshold k (half_pos hδ) (le_max_left _ N) + ((num hM 2).mul hM hs) (one_div_half_le (Nat.le_ceil _)) + have hm' : AckBounded (4 * k + 5) (max (k + 4) N) 8 (m + 1) := + (hm.add hM (num hM 1)).mono (by grind) + refine sq_div_le_card_containedProgressions (by grind) hδ m.succ_pos + (fun B ↦ hS _ m.le_succ B) (Nat.le_ceil _) ?_ hn A hAn hA + exact ((((num hM 128).mul hM (hm'.pow hM (num hM 3))).mul hM (hs.pow hM (num hM 2))).le_ack + (by grind) (by grind) (by grind)).trans (ack_max_le (Nat.ceil_pos.2 (by positivity))) + +end Combinatorics.ArithmeticProgression diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean index ac3f714f17..3d6f97e1c6 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean @@ -5,13 +5,14 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word -public import Mathlib.Logic.Equiv.Fin.Basic +public import Mathlib.Combinatorics.HalesJewett +public import Mathlib.Data.Finset.Density +public import LeanPool.ShelahHalesJewett.Line /-! # Combinatorial subspaces -Ranges, containment, relative density, alphabet restriction, and lines inside mathlib's +Ranges, containment, relative density, alphabet restriction, and lines inside Mathlib's `Combinatorics.Subspace`. -/ @@ -31,12 +32,12 @@ lemma injective (V : Combinatorics.Subspace η α ι) : intro x y hxy funext e obtain ⟨i, hi⟩ := V.proper e - simpa only [V.apply_inr hi] using congrFun hxy i + simpa [V.apply_inr hi] using congrFun hxy i /-- The finite range of a combinatorial subspace. -/ def range [Fintype (η → α)] [DecidableEq (ι → α)] (V : Combinatorics.Subspace η α ι) : Finset (ι → α) := - Finset.univ.image V + univ.image V @[simp] lemma mem_range [Fintype (η → α)] [DecidableEq (ι → α)] @@ -74,7 +75,7 @@ def repeatInitial {m M : ℕ} (α : Type*) (hm : 1 ≤ m) (hmM : m ≤ M) : simp only [Fin.castLE, e.isLt, ↓reduceDIte] @[simp] -lemma repeatInitial_map {β : Type*} {m M : ℕ} (α : Type*) (hm : 1 ≤ m) (hmM : m ≤ M) +lemma repeatInitial_map {β : Type*} {m M : ℕ} {α : Type*} (hm : 1 ≤ m) (hmM : m ≤ M) (f : β → α) (x : Fin m → β) : repeatInitial α hm hmM (f ∘ x) = f ∘ repeatInitial β hm hmM x := by funext i @@ -121,29 +122,23 @@ lemma lineToSubspaceFinOne_apply (l : Combinatorics.Line α ι) (x : Fin 1 → /-- Relative density on a subspace, defined on its parameter cube. -/ def relativeDensity [Fintype (η → α)] [DecidableEq (ι → α)] (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : ℚ≥0 := - (Finset.univ.filter fun x ↦ V x ∈ A).dens + (univ.filter fun x ↦ V x ∈ A).dens /-- Ambient line structures whose evaluations are contained in a subspace. -/ def Lines [Fintype (η → α)] [DecidableEq (ι → α)] (V : Combinatorics.Subspace η α ι) := {l : Combinatorics.Line α ι // ∀ a, l a ∈ range V} -/-- Compose a parameter-cube line with a combinatorial subspace. -/ +/-- Compose a parameter-cube line with a combinatorial subspace: an alias of +`Combinatorics.Subspace.compLine`. -/ def composeLine (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : - Combinatorics.Line α ι where - idxFun i := (V.idxFun i).elim some l.idxFun - proper := by - obtain ⟨e, he⟩ := l.proper - obtain ⟨i, hi⟩ := V.proper e - refine ⟨i, ?_⟩ - simp only [hi, Sum.elim_inr, he] + Combinatorics.Line α ι := + V.compLine l @[simp] lemma composeLine_apply (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) - (a : α) : composeLine V l a = V (l a) := by - funext i - cases hi : V.idxFun i <;> - simp [composeLine, Combinatorics.Line.coe_apply, Combinatorics.Subspace.coe_apply, hi] + (a : α) : composeLine V l a = V (l a) := + V.compLine_apply l a /-- Regard the composite of a parameter line with a subspace as a line in that subspace. -/ def composeLineToLines [Fintype (η → α)] [DecidableEq (ι → α)] @@ -156,7 +151,7 @@ noncomputable def parameterWord [Fintype (η → α)] [DecidableEq (ι → α)] Classical.choose <| mem_range.mp (q.2 a) lemma parameterWord_apply [Fintype (η → α)] [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (q : Lines V) (a : α) : + {V : Combinatorics.Subspace η α ι} (q : Lines V) (a : α) : V (parameterWord V q a) = q.1 a := Classical.choose_spec <| mem_range.mp (q.2 a) @@ -178,7 +173,7 @@ noncomputable def uncomposeLine [Fintype (η → α)] [DecidableEq (ι → α)] | inl b => obtain ⟨a, hab⟩ := exists_ne b refine absurd ?_ hab - rw [← q.1.apply_none a j hj, ← parameterWord_apply V q a] + rw [← q.1.apply_none a j hj, ← parameterWord_apply q a] exact V.apply_inl hVj | inr e => cases hq : q.1.idxFun (properCoordinate V e) with @@ -186,19 +181,19 @@ noncomputable def uncomposeLine [Fintype (η → α)] [DecidableEq (ι → α)] | some c => obtain ⟨a, hac⟩ := exists_ne c exact absurd (by rw [← q.1.apply_none a j hj, ← q.1.apply_some hq, - ← parameterWord_apply V q a, V.apply_inr (properCoordinate_spec V e), + ← parameterWord_apply q a, V.apply_inr (properCoordinate_spec V e), V.apply_inr hVj]) hac lemma uncomposeLine_apply [Fintype (η → α)] [DecidableEq (ι → α)] [Nontrivial α] - (V : Combinatorics.Subspace η α ι) (q : Lines V) (a : α) : + {V : Combinatorics.Subspace η α ι} (q : Lines V) (a : α) : V (uncomposeLine V q a) = q.1 a := by funext i cases hi : V.idxFun i with - | inl b => rw [V.apply_inl hi, ← parameterWord_apply V q a, V.apply_inl hi] + | inl b => rw [V.apply_inl hi, ← parameterWord_apply q a, V.apply_inl hi] | inr e => rw [V.apply_inr hi] change q.1 a (properCoordinate V e) = q.1 a i - rw [← parameterWord_apply V q a, V.apply_inr (properCoordinate_spec V e), V.apply_inr hi] + rw [← parameterWord_apply q a, V.apply_inr (properCoordinate_spec V e), V.apply_inr hi] /-- Composition with a subspace identifies parameter-cube lines with ambient lines contained in the subspace. -/ @@ -221,7 +216,7 @@ noncomputable def linesEquiv [Fintype (η → α)] [DecidableEq (ι → α)] apply Combinatorics.Line.coe_injective funext a rw [composeLine_apply] - exact uncomposeLine_apply V q a + exact uncomposeLine_apply q a /-- Map a parameter-cube line to the corresponding ambient line in a subspace. -/ def mapLine (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : @@ -240,7 +235,46 @@ lemma mapLine_apply (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Lin /-- Restrict the variable letters of a subspace along an alphabet embedding. -/ def restrictAlphabet {β : Type*} [Fintype (η → β)] [DecidableEq (ι → α)] (V : Combinatorics.Subspace η α ι) (e : β ↪ α) : Finset (ι → α) := - Finset.univ.image fun x ↦ V (e ∘ x) + univ.image fun x ↦ V (e ∘ x) + +/-- Apply a map to the fixed letters of a subspace. -/ +def map {β : Type*} (f : α → β) (V : Combinatorics.Subspace η α ι) : + Combinatorics.Subspace η β ι where + idxFun i := (V.idxFun i).map f id + proper e := by + obtain ⟨i, hi⟩ := V.proper e + exact ⟨i, by simp [hi]⟩ + +@[simp] +lemma map_apply {β : Type*} (f : α → β) (V : Combinatorics.Subspace η α ι) (x : η → α) : + map f V (f ∘ x) = f ∘ V x := by + funext i + cases hi : V.idxFun i <;> simp [map, Combinatorics.Subspace.coe_apply, hi] + +/-- Fix suffix coordinates of a subspace. -/ +def fixSuffix {κ : Type*} (V : Combinatorics.Subspace η α ι) (y : κ → α) : + Combinatorics.Subspace η α (ι ⊕ κ) where + idxFun := Sum.elim V.idxFun (Sum.inl ∘ y) + proper e := by + obtain ⟨i, hi⟩ := V.proper e + exact ⟨Sum.inl i, hi⟩ + +@[simp] +lemma fixSuffix_apply {κ : Type*} (V : Combinatorics.Subspace η α ι) (y : κ → α) (x : η → α) : + fixSuffix V y x = Sum.elim (V x) y := by + funext i + cases i <;> simp [fixSuffix, Combinatorics.Subspace.coe_apply] + +/-- Fix suffix coordinates and transport the ambient coordinates along an equivalence. -/ +def fixSuffixReindex {κ ζ : Type*} (e : ι ⊕ κ ≃ ζ) (V : Combinatorics.Subspace η α ι) + (y : κ → α) : Combinatorics.Subspace η α ζ := + (fixSuffix V y).reindex (Equiv.refl _) (Equiv.refl _) e + +@[simp] +lemma fixSuffixReindex_apply {κ ζ : Type*} (e : ι ⊕ κ ≃ ζ) (V : Combinatorics.Subspace η α ι) + (y : κ → α) (x : η → α) : fixSuffixReindex e V y x = Sum.elim (V x) y ∘ e.symm := by + funext i + simp [fixSuffixReindex, Combinatorics.Subspace.reindex_apply] end Subspace @@ -264,7 +298,7 @@ lemma transportSubspace_apply {α η ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (z noncomputable def parameterPreimage {η α ι : Type*} [Fintype (η → α)] (V : Combinatorics.Subspace η α ι) (D : Finset (ι → α)) : Finset (η → α) := by classical - apply Finset.univ.filter + apply univ.filter intro x exact V x ∈ D diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean index e0ecae227f..28b25f403d 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean @@ -6,15 +6,18 @@ Authors: Gabriel Dahia module public import Mathlib.Algebra.BigOperators.Fin -public import Mathlib.Algebra.Order.Archimedean.Real.Basic -public import Mathlib.Combinatorics.Pigeonhole -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Algebra.Order.Interval.Finset.Basic +import Mathlib.Combinatorics.Pigeonhole /-! # Arithmetic progressions from combinatorial lines -The digital transfer from density Hales--Jewett to Szemeredi's theorem on finite intervals, using -mathlib's fixed-length base encoding `finFunctionFinEquiv`. +The digital transfer from density Hales--Jewett to Szemerédi's theorem on finite intervals, using +Mathlib's fixed-length base encoding `finFunctionFinEquiv`. It turns a dimension `m` in which +density Hales--Jewett holds for `k` letters into the threshold `2 * k ^ m / δ` for progressions of +length `k`. -/ @[expose] public section @@ -40,9 +43,10 @@ def term {α : Type*} [AddMonoid α] {k : ℕ} (P : ArithmeticProgression α k) (i : Fin k) : α := P.start + (i : ℕ) • P.diff -/-- The proposition that every term of `P` belongs to `s`. -/ -def IsSubset {α : Type*} [AddMonoid α] {k : ℕ} (P : ArithmeticProgression α k) - (s : Set α) : Prop := +/-- The proposition that every term of `P` belongs to `s`, for `s` of any type with a membership +relation, such as `Set α` or `Finset α`. -/ +def IsSubset {α S : Type*} [AddMonoid α] [Membership α S] {k : ℕ} (P : ArithmeticProgression α k) + (s : S) : Prop := ∀ i, P.term i ∈ s end ArithmeticProgression @@ -53,7 +57,7 @@ namespace DensityHalesJewett namespace Line /-- A base-encoded combinatorial line gives an arithmetic progression with nonzero common -difference. The encoding is mathlib's `finFunctionFinEquiv`, which reads a word as the base-`k` +difference. The encoding is Mathlib's `finFunctionFinEquiv`, which reads a word as the base-`k` digits of a natural number. -/ lemma baseEncode_isArithmeticProgression {k m : ℕ} (hk : 1 ≤ k) (l : Combinatorics.Line (Fin k) (Fin m)) : @@ -64,158 +68,94 @@ lemma baseEncode_isArithmeticProgression {k m : ℕ} (hk : 1 ≤ k) { start := (finFunctionFinEquiv (l ⟨0, hk⟩) : ℕ) diff := d diff_ne_zero := ?_ }, ?_⟩ - · refine Nat.ne_of_gt (Finset.sum_pos' ?_ ?_) - · intro i _ - exact Nat.zero_le _ - · obtain ⟨i, hi⟩ := l.proper - exact ⟨i, Finset.mem_univ i, by simp [hi, Nat.zero_lt_of_lt hk]⟩ + · obtain ⟨i, hi⟩ := l.proper + exact Nat.ne_of_gt (sum_pos' (fun _ _ ↦ Nat.zero_le _) + ⟨i, mem_univ i, by simp [hi, Nat.zero_lt_of_lt hk]⟩) · intro a change (finFunctionFinEquiv (l ⟨0, hk⟩) : ℕ) + (a : ℕ) • d = (finFunctionFinEquiv (l a) : ℕ) simp only [finFunctionFinEquiv_apply] - rw [nsmul_eq_mul, Finset.mul_sum, ← Finset.sum_add_distrib] - apply Finset.sum_congr rfl + rw [nsmul_eq_mul, mul_sum, ← sum_add_distrib] + apply sum_congr rfl intro i _ cases hli : l.idxFun i <;> simp [Combinatorics.Line.coe_apply, hli] end Line -/-- A sufficiently dense initial interval has a complete digit block with at least half the -ambient density. -/ -lemma exists_dense_digitBlock {K : ℕ} (hK : 1 ≤ K) {δ : ℝ} (hδ : 0 < δ) - {N : ℕ} (hN : 2 * K / δ ≤ N) (A : Finset ℕ) (hAN : A ⊆ Finset.range N) +/-- Fewer than `K` elements of `A ⊆ range N` lie beyond the last complete block of length `K`. -/ +lemma card_sdiff_range_div_mul_lt {K N : ℕ} (hK : 0 < K) {A : Finset ℕ} (hAN : A ⊆ range N) : + #(A \ range (N / K * K)) < K := by + have h : A \ range (N / K * K) ⊆ Ico (N / K * K) N := fun x hx ↦ by + rw [mem_sdiff, mem_range] at hx + exact mem_Ico.2 ⟨not_lt.1 hx.2, mem_range.1 (hAN hx.1)⟩ + refine (card_le_card h).trans_lt ?_ + rw [Nat.card_Ico] + have := Nat.mod_add_div' N K + have := Nat.mod_lt N hK + omega + +/-- The elements of `A` below `Q * K` with quotient `q < Q` by `K` form the block of `A` between +`q * K` and `q * K + K`. -/ +lemma filter_inter_range_div_eq {K Q q : ℕ} (hK : 0 < K) (A : Finset ℕ) (hq : q < Q) : + {x ∈ A ∩ range (Q * K) | x / K = q} = A ∩ Ico (q * K) (q * K + K) := by + have := Nat.mul_le_mul_right K hq + rw [Nat.succ_mul] at this + ext x + have hx : x / K = q ↔ q * K ≤ x ∧ x < q * K + K := by + rw [Nat.div_eq_iff hK] + omega + simp only [mem_filter, mem_inter, mem_range, mem_Ico, hx] + exact ⟨fun h ↦ ⟨h.1.1, h.2⟩, fun h ↦ ⟨⟨h.1, by omega⟩, h.2⟩⟩ + +/-- A sufficiently dense initial interval has a block of `K` consecutive numbers with at least +half the ambient density. -/ +lemma exists_dense_digitBlock {K : ℕ} (hK : 0 < K) {δ : ℝ} (hδ : 0 < δ) + {N : ℕ} (hN : 2 * K / δ ≤ N) {A : Finset ℕ} (hAN : A ⊆ range N) (hA : δ * N ≤ #A) : - ∃ q : ℕ, (q + 1) * K ≤ N ∧ - δ / 2 * K ≤ #(A ∩ Finset.Ico (q * K) ((q + 1) * K)) := by - let Q := N / K - let S := A ∩ Finset.range (Q * K) - have htail : (#(A \ Finset.range (Q * K)) : ℝ) < K := by - norm_cast - refine (Finset.card_le_card (t := Finset.Ico (Q * K) N) ?_).trans_lt ?_ - · intro x hx - rw [Finset.mem_Ico] - rw [Finset.mem_sdiff, Finset.mem_range] at hx - exact ⟨Nat.le_of_not_gt hx.2, Finset.mem_range.mp (hAN hx.1)⟩ - · rw [Nat.card_Ico] - simpa only [Q, Nat.mod_eq_sub_mul_div, Nat.mul_comm] using - Nat.mod_lt N (Nat.zero_lt_of_lt hK) - have hS : δ / 2 * N ≤ (#S : ℝ) := by - rw [← Finset.card_inter_add_card_sdiff A (Finset.range (Q * K))] at hA + ∃ q : ℕ, δ / 2 * K ≤ #(A ∩ Ico (q * K) (q * K + K)) := by + have hS : δ / 2 * N ≤ #(A ∩ range (N / K * K)) := by + rw [← card_inter_add_card_sdiff A (range (N / K * K))] at hA push_cast at hA - dsimp only [S] - nlinarith [htail, (div_le_iff₀ hδ).mp hN] - have hmap : ∀ x ∈ S, x / K ∈ Finset.range Q := by - intro x hx - rw [Finset.mem_inter, Finset.mem_range] at hx - exact Finset.mem_range.mpr ((Nat.div_lt_iff_lt_mul (Nat.zero_lt_of_lt hK)).2 hx.2) - obtain ⟨q, hqQ, hq⟩ : ∃ q ∈ Finset.range Q, - δ / 2 * K ≤ ∑ x ∈ S with x / K = q, (1 : ℝ) := by - apply Finset.exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum - (M := ℝ) (s := S) (t := Finset.range Q) (f := fun x ↦ x / K) - (w := fun _ ↦ 1) (b := δ / 2 * K) hmap - · obtain ⟨x, hx⟩ : S.Nonempty := by - rw [Finset.nonempty_iff_ne_empty] - intro hSempty - rw [hSempty, Finset.card_empty, Nat.cast_zero] at hS - exact not_lt_of_ge hS (mul_pos (by positivity) (lt_of_lt_of_le (by positivity) hN)) - exact ⟨x / K, hmap x hx⟩ - · simp only [Finset.card_range, nsmul_eq_mul, Finset.sum_const, mul_one] - refine le_trans ?_ hS - rw [← mul_assoc, mul_comm (Q : ℝ) (δ / 2), mul_assoc] - exact mul_le_mul_of_nonneg_left (by exact_mod_cast Nat.div_mul_le_self N K) (by positivity) - refine ⟨q, ?_, ?_⟩ - · exact (Nat.mul_le_mul_right K (Nat.succ_le_iff.mp (Finset.mem_range.mp hqQ))).trans - (Nat.div_mul_le_self N K) - · convert hq using 1 - norm_cast - simp only [Finset.sum_const, nsmul_eq_mul, mul_one] - congr 1 - ext x - dsimp only [S] - simp only [Finset.mem_filter, Finset.mem_inter, Finset.mem_range, Finset.mem_Ico] - constructor - · rintro ⟨hxA, hxlo, hxhi⟩ - refine ⟨⟨hxA, hxhi.trans_le ?_⟩, ?_⟩ - · exact Nat.mul_le_mul_right K - (Nat.succ_le_iff.mp (Finset.mem_range.mp hqQ)) - · apply Nat.le_antisymm - · exact Nat.lt_succ_iff.mp - ((Nat.div_lt_iff_lt_mul (Nat.zero_lt_of_lt hK)).2 hxhi) - · exact (Nat.le_div_iff_mul_le (Nat.zero_lt_of_lt hK)).2 hxlo - · rintro ⟨⟨hxA, _⟩, hxq⟩ - refine ⟨hxA, ?_, ?_⟩ - · rw [← hxq] - simpa [Nat.mul_comm] using Nat.mul_div_le x K - · rw [← hxq] - exact (Nat.div_lt_iff_lt_mul (Nat.zero_lt_of_lt hK)).mp (Nat.lt_succ_self _) + nlinarith [(div_le_iff₀ hδ).1 hN, (Nat.cast_lt (α := ℝ)).2 (card_sdiff_range_div_mul_lt hK hAN)] + have hmaps (x) (hx : x ∈ A ∩ range (N / K * K)) : x / K ∈ range (N / K) := + mem_range.2 ((Nat.div_lt_iff_lt_mul hK).2 (mem_range.1 (mem_inter.1 hx).2)) + obtain ⟨x, hx⟩ : (A ∩ range (N / K * K)).Nonempty := card_pos.1 <| mod_cast + (mul_pos (half_pos hδ) ((div_pos (by positivity) hδ).trans_le hN)).trans_le hS + obtain ⟨q, hq, hcard⟩ := exists_le_card_fiber_of_nsmul_le_card_of_maps_to hmaps ⟨_, hmaps x hx⟩ + (b := δ / 2 * K) (by + rw [card_range, nsmul_eq_mul] + nlinarith [mul_le_mul_of_nonneg_left + (by exact_mod_cast Nat.div_mul_le_self N K : ((N / K : ℕ) : ℝ) * K ≤ N) (half_pos hδ).le]) + exact ⟨q, hcard.trans_eq (by rw [filter_inter_range_div_eq hK A (mem_range.1 hq)])⟩ end DensityHalesJewett namespace Combinatorics.ArithmeticProgression -/-- A threshold for the density theorem for arithmetic progressions of length `k`. -/ -noncomputable def densityTheoremBound (k : ℕ) (δ : ℝ) : ℕ := - ⌈2 * (k ^ Combinatorics.Line.densityTheoremBound k (δ / 2) : ℕ) / δ⌉₊ - -theorem exists_of_density_nat (k : ℕ) (hk : 3 ≤ k) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityTheoremBound k δ ≤ n) (A : Finset ℕ) - (hAn : A ⊆ range n) (hAδ : δ * n ≤ #A) : - ∃ P : ArithmeticProgression ℕ k, P.IsSubset (A : Set ℕ) := by +/-- The digital transfer from density Hales--Jewett to Szemerédi's theorem: if density +Hales--Jewett holds for `k` letters and density `δ / 2` in dimension `m`, then for +`n ≥ 2 * k ^ m / δ` every subset of `range n` with at least `δ * n` elements contains an +arithmetic progression of length `k`. -/ +theorem exists_of_isDHJDimension {k m : ℕ} (hk : 1 ≤ k) {δ : ℝ} (hδ : 0 < δ) + (hm : DensityHalesJewett.IsDHJDimension k (δ / 2) m) {n : ℕ} (hn : 2 * (k : ℝ) ^ m / δ ≤ n) + (A : Finset ℕ) (hAn : A ⊆ range n) (hAδ : δ * n ≤ #A) : + ∃ P : ArithmeticProgression ℕ k, P.IsSubset A := by classical - have hk_one : 1 ≤ k := by grind - let m := Combinatorics.Line.densityTheoremBound k (δ / 2) - let K := k ^ m - obtain ⟨q, _, hqA⟩ : ∃ q : ℕ, (q + 1) * K ≤ n ∧ - δ / 2 * K ≤ #(A ∩ Finset.Ico (q * K) ((q + 1) * K)) := by - refine DensityHalesJewett.exists_dense_digitBlock (one_le_pow₀ hk_one) hδ ?_ A hAn hAδ - · apply Nat.le_of_ceil_le - simpa only [densityTheoremBound, m, K] using hn - let encode (x : Fin m → Fin k) := q * K + (finFunctionFinEquiv x : ℕ) - let B := Finset.univ.filter fun x : Fin m → Fin k ↦ encode x ∈ A - let encodeOnB (x : Fin m → Fin k) (_ : x ∈ B) := encode x - have hBcard : #B = #(A ∩ Finset.Ico (q * K) ((q + 1) * K)) := by - apply Finset.card_bij encodeOnB - · intro x hx - dsimp only [encodeOnB, encode] - rw [Finset.mem_filter] at hx - refine Finset.mem_inter.mpr ⟨hx.2, Finset.mem_Ico.mpr ⟨Nat.le_add_right _ _, ?_⟩⟩ - rw [add_mul, one_mul] - apply Nat.add_lt_add_left - exact (finFunctionFinEquiv x).isLt - · intro x _ y _ hxy - dsimp only [encodeOnB, encode] at hxy - exact finFunctionFinEquiv.injective (Fin.ext (Nat.add_left_cancel hxy)) - · intro y hy - rw [Finset.mem_inter, Finset.mem_Ico] at hy - have hz : y - q * K < K := by - rw [Nat.sub_lt_iff_lt_add hy.2.1] - simpa only [add_mul, one_mul, Nat.add_comm] using hy.2.2 - let z : Fin K := ⟨y - q * K, hz⟩ - let x := finFunctionFinEquiv.symm z - have hxencode : (finFunctionFinEquiv x : ℕ) = y - q * K := - congrArg Fin.val (Equiv.apply_symm_apply finFunctionFinEquiv z) - dsimp only [encodeOnB, encode] - refine ⟨x, Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩, ?_⟩ - · dsimp only [encode] - rw [hxencode, Nat.add_sub_of_le hy.2.1] - exact hy.1 - · rw [hxencode, Nat.add_sub_of_le hy.2.1] - obtain ⟨l, hl⟩ : ∃ l : Combinatorics.Line (Fin k) (Fin m), ∀ x : Fin k, l x ∈ B := by - apply Combinatorics.Line.exists_of_density (Fin k) (δ / 2) - · positivity - · simp [m] - · rw [Fintype.card_fin, hBcard] - simpa only [K, Nat.cast_pow] using hqA - obtain ⟨P, hP⟩ := DensityHalesJewett.Line.baseEncode_isArithmeticProgression hk_one l - refine ⟨ - { start := q * K + P.start - diff := P.diff - diff_ne_zero := P.diff_ne_zero }, ?_⟩ + obtain ⟨q, hq⟩ := DensityHalesJewett.exists_dense_digitBlock (pow_pos hk m) hδ + (by simpa using hn) hAn hAδ + let e : (Fin m → Fin k) ↪ ℕ := + finFunctionFinEquiv.toEmbedding.trans (Fin.valEmbedding.trans (addLeftEmbedding (q * k ^ m))) + have he : univ.map e = Ico (q * k ^ m) (q * k ^ m + k ^ m) := by + rw [← map_map, ← map_map, map_univ_equiv, Fin.map_valEmbedding_univ, Nat.Iio_eq_range, + ← Nat.Ico_zero_eq_range, map_add_left_Ico, add_zero] + obtain ⟨l, hl⟩ := hm (univ.filter ((· ∈ A) ∘ e)) <| by + rwa [← card_map e, ← filter_map, he, filter_mem_eq_inter, inter_comm, ← Nat.cast_pow] + obtain ⟨P, hP⟩ := DensityHalesJewett.Line.baseEncode_isArithmeticProgression hk l + refine ⟨⟨q * k ^ m + P.start, P.diff, P.diff_ne_zero⟩, ?_⟩ intro a - change (q * K + P.start) + (a : ℕ) • P.diff ∈ A - rw [add_assoc] - change q * K + P.term a ∈ A - rw [hP] - exact (Finset.mem_filter.mp (hl a)).2 + have h := (mem_filter.1 (hl a)).2 + simp only [e, Function.comp_apply, Function.Embedding.trans_apply, Equiv.coe_toEmbedding, + Fin.valEmbedding_apply, addLeftEmbedding_apply, ← hP] at h + simpa [term, add_assoc] using h end Combinatorics.ArithmeticProgression diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean index 02f0c1c5d0..97860a82a1 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean @@ -5,16 +5,21 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild -import Mathlib.Algebra.Order.Archimedean.Real.Basic +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word +public import Mathlib.Algebra.Order.Archimedean.Real.Basic import Mathlib.Combinatorics.Pigeonhole -import Mathlib.Tactic.Linarith +public import Mathlib.Logic.Equiv.Fin.Basic +import Mathlib.Algebra.Order.BigOperators.Expect /-! # Preliminary density lemmas Multidimensional density Hales--Jewett, uniform fibers, and the restricted-alphabet subspace -lemma. All subspaces below are mathlib's `Combinatorics.Subspace`. +lemma. All subspaces below are Mathlib's `Combinatorics.Subspace`. + +Lemmas that use density Hales--Jewett over `k` letters take a bound `F` for it, `IsDHJBound k F`, +and their dimensions are explicit in `F`. -/ @[expose] public section @@ -25,50 +30,40 @@ open scoped BigOperators namespace DensityHalesJewett -/-- The density Hales--Jewett assertion for the alphabet `Fin k`. -/ -def HasDensityHJ (k : ℕ) : Prop := - ∀ δ : ℝ, 0 < δ → ∃ N, ∀ n, N ≤ n → ∀ A : Finset (Fin n → Fin k), - δ * (k : ℝ) ^ n ≤ #A → ∃ l : Combinatorics.Line (Fin k) (Fin n), ∀ a, l a ∈ A +/-- `n` is a dimension in which density Hales--Jewett holds for `k` letters and density `δ`: every +set of at least `δ * k ^ n` words of length `n` over `k` letters contains a combinatorial line. -/ +def IsDHJDimension (k : ℕ) (δ : ℝ) (n : ℕ) : Prop := + ∀ A : Finset (Fin n → Fin k), δ * (k : ℝ) ^ n ≤ #A → + ∃ l : Combinatorics.Line (Fin k) (Fin n), ∀ a, l a ∈ A -namespace Subspace +/-- A dimension in which density Hales--Jewett holds for a density also works for every larger +density. -/ +lemma IsDHJDimension.mono {k n : ℕ} {δ ρ : ℝ} (h : IsDHJDimension k δ n) (hδρ : δ ≤ ρ) : + IsDHJDimension k ρ n := + fun A hA ↦ h A ((mul_le_mul_of_nonneg_right hδρ (by positivity)).trans hA) -/-- A one-dimensional density Hales--Jewett threshold selected from `HasDensityHJ`. -/ -noncomputable def densityOneBound (k : ℕ) (δ : ℝ) : ℕ := by - classical - exact if h : 0 < δ ∧ HasDensityHJ k then - Nat.find (h.2 δ h.1) - else 0 - -lemma densityOneBound_spec {k : ℕ} (hDHJ : HasDensityHJ k) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityOneBound k δ ≤ n) (A : Finset (Fin n → Fin k)) - (hA : δ * (k : ℝ) ^ n ≤ #A) : - ∃ l : Combinatorics.Line (Fin k) (Fin n), ∀ a, l a ∈ A := by - classical - rw [densityOneBound, dite_eq_left ⟨hδ, hDHJ⟩] at hn - exact Nat.find_spec (hDHJ δ hδ) n hn A hA +/-- `F` is a bound for density Hales--Jewett over `k` letters: for every density `δ > 0`, it holds +in every dimension `n ≥ F δ`. -/ +def IsDHJBound (k : ℕ) (F : ℝ → ℕ) : Prop := + ∀ δ : ℝ, 0 < δ → ∀ n, F δ ≤ n → IsDHJDimension k δ n + +namespace Subspace /-- The one-dimensional case of multidimensional density Hales--Jewett. -/ -lemma exists_one_of_density {k : ℕ} (hDHJ : HasDensityHJ k) - (δ : ℝ) (hδ : 0 < δ) (n : ℕ) (hn : densityOneBound k δ ≤ n) - (A : Finset (Fin n → Fin k)) (hA : δ * (k : ℝ) ^ n ≤ #A) : +lemma exists_one_of_density {k n : ℕ} {δ : ℝ} (h : IsDHJDimension k δ n) + {A : Finset (Fin n → Fin k)} (hA : δ * (k : ℝ) ^ n ≤ #A) : ∃ V : Combinatorics.Subspace (Fin 1) (Fin k) (Fin n), IsContained V A := by - obtain ⟨l, hl⟩ := densityOneBound_spec hDHJ δ hδ n hn A hA + obtain ⟨l, hl⟩ := h A hA refine ⟨lineToSubspaceFinOne l, ?_⟩ intro x - rw [lineToSubspaceFinOne_apply] - exact hl _ + simpa using hl (x 0) /-- A line is equivalently an `Option`-valued index word with at least one variable coordinate. -/ private noncomputable def lineIndexEquiv (α ι : Type*) : Combinatorics.Line α ι ≃ {f : ι → Option α // ¬ ∀ i, f i ≠ none} where - toFun l := by - refine ⟨l.idxFun, ?_⟩ - intro h - apply l.proper.elim - intro i hi - exact h i hi + toFun l := ⟨l.idxFun, by simpa using l.proper⟩ invFun f := ⟨f, by simpa using f.property⟩ left_inv l := by cases l; rfl right_inv _ := Subtype.ext rfl @@ -77,10 +72,7 @@ private noncomputable def lineIndexEquiv (α ι : Type*) : private noncomputable def fixedIndexWordEquiv (α ι : Type*) [Nonempty α] : {f : ι → Option α // ∀ i, f i ≠ none} ≃ (ι → α) where toFun f i := (f.1 i).getD (Classical.arbitrary α) - invFun x := by - refine ⟨some ∘ x, ?_⟩ - intro i - exact Option.some_ne_none (x i) + invFun x := ⟨some ∘ x, by simp⟩ left_inv f := by refine Subtype.ext (funext ?_) intro i @@ -90,7 +82,7 @@ private noncomputable def fixedIndexWordEquiv (α ι : Type*) [Nonempty α] : right_inv x := by simp /-- The exact number of combinatorial line structures in a nonempty finite-alphabet word cube. -/ -lemma card_line (k m : ℕ) (hk : 0 < k) +lemma card_line {k : ℕ} (m : ℕ) (hk : 0 < k) [Fintype (Combinatorics.Line (Fin k) (Fin m))] : Fintype.card (Combinatorics.Line (Fin k) (Fin m)) = (k + 1) ^ m - k ^ m := by let : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ @@ -115,230 +107,87 @@ def emptyAlphabetSubspace {m n : ℕ} (hm : 1 ≤ m) (hmn : m ≤ n) : idxFun i := Sum.inr ⟨i.val % m, Nat.mod_lt _ (Nat.zero_lt_of_lt hm)⟩ proper e := ⟨Fin.castLE hmn e, by simp [Nat.mod_eq_of_lt e.isLt]⟩ -/-- Every empty-alphabet subspace is contained in every word family. -/ -lemma emptyAlphabetSubspace_isContained {m n : ℕ} (hm : 1 ≤ m) (hmn : m ≤ n) - (A : Finset (Fin n → Fin 0)) : IsContained (emptyAlphabetSubspace hm hmn) A := by - intro x - exact Fin.elim0 (x ⟨0, Nat.zero_lt_of_lt hm⟩) - /-- Convert the cardinal density hypothesis to the normalized finite-set density inequality. -/ -lemma density_le_of_card_le {k n : ℕ} (hk : 0 < k) (δ : ℝ) - (A : Finset (Fin n → Fin k)) (hA : δ * (k : ℝ) ^ n ≤ #A) : +lemma density_le_of_card_le {k n : ℕ} (hk : 0 < k) {δ : ℝ} + {A : Finset (Fin n → Fin k)} (hA : δ * (k : ℝ) ^ n ≤ #A) : δ ≤ (A.dens : ℝ) := by - rw [Finset.nnratCast_dens] - refine (le_div_iff₀ ?_).mpr ?_ - · simp only [Fintype.card_pi_const, Fintype.card_fin] - exact_mod_cast pow_pos hk n - · simpa only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow] using hA + rw [nnratCast_dens, le_div_iff₀ (by simp [hk])] + simpa using hA /-- Convert a normalized density lower bound back to the cardinal form used by the density Hales--Jewett assertion. -/ -lemma card_le_of_density_le {k n : ℕ} (hk : 0 < k) (δ : ℝ) - (A : Finset (Fin n → Fin k)) (hA : δ ≤ (A.dens : ℝ)) : +lemma card_le_of_density_le {k n : ℕ} (hk : 0 < k) {δ : ℝ} + {A : Finset (Fin n → Fin k)} (hA : δ ≤ (A.dens : ℝ)) : δ * (k : ℝ) ^ n ≤ #A := by - rw [Finset.nnratCast_dens] at hA - have hpos : 0 < (Fintype.card (Fin n → Fin k) : ℝ) := by - rw [Fintype.card_pi_const, Fintype.card_fin] - exact_mod_cast pow_pos hk n - simpa only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow] using - (le_div_iff₀ hpos).mp hA + rw [nnratCast_dens, le_div_iff₀ (by simp [hk])] at hA + simpa using hA /-- One fiber of a map to a finite nonempty type has at least the average relative density. -/ lemma exists_fiber_density {X Y : Type*} [Fintype X] [Fintype Y] [Nonempty Y] [DecidableEq Y] (s : Finset X) (f : X → Y) : ∃ y, (s.filter fun x ↦ f x = y).dens ≥ (s.dens : ℝ) / Fintype.card Y := by - classical - let b : ℝ := #s / Fintype.card Y - have hb : (#(Finset.univ : Finset Y) : ℕ) • b ≤ ∑ _x ∈ s, (1 : ℝ) := by - simp only [Finset.card_univ, nsmul_eq_mul, b] - rw [Finset.sum_const, nsmul_eq_mul, mul_one, mul_div_cancel₀] - exact_mod_cast Fintype.card_ne_zero - obtain ⟨y, _, hy⟩ := - Finset.exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (s := s) (t := Finset.univ) - (f := f) (w := fun _ ↦ (1 : ℝ)) (fun _ _ ↦ Finset.mem_univ _) - Finset.univ_nonempty hb + obtain ⟨y, -, hy⟩ := exists_le_card_fiber_of_nsmul_le_card_of_maps_to (fun _ _ ↦ mem_univ _) + univ_nonempty (s := s) (f := f) (b := (#s : ℝ) / Fintype.card Y) (by simp [mul_div_cancel₀]) refine ⟨y, ?_⟩ - rw [Finset.nnratCast_dens, Finset.nnratCast_dens] - change (#s : ℝ) / Fintype.card Y ≤ ∑ x ∈ s with f x = y, (1 : ℝ) at hy - simp only [Finset.sum_const, nsmul_eq_mul, mul_one] at hy - rw [ge_iff_le] - simpa only [div_div, nsmul_eq_mul, mul_comm, mul_left_comm, mul_assoc, mul_one] using - div_le_div_of_nonneg_right hy (by positivity : 0 ≤ (Fintype.card X : ℝ)) + rw [ge_iff_le, nnratCast_dens, nnratCast_dens, div_right_comm] + gcongr /-- At least half the ambient density lies on prefixes with fiber density at least half as large. -/ -lemma half_density_prefixes {k p q : ℕ} (hk : 0 < k) (δ : ℝ) (hδ : 0 < δ) - (A : Finset (Fin p ⊕ Fin q → Fin k)) (hA : δ ≤ (A.dens : ℝ)) : +lemma half_density_prefixes {k p q : ℕ} (hk : 0 < k) {δ : ℝ} (hδ : 0 < δ) + {A : Finset (Fin p ⊕ Fin q → Fin k)} (hA : δ ≤ (A.dens : ℝ)) : δ / 2 ≤ - ((Finset.univ.filter fun x : Fin p → Fin k ↦ δ / 2 ≤ ((fiber A x).dens : ℝ)).dens : ℝ) := by + ((univ.filter fun x : Fin p → Fin k ↦ δ / 2 ≤ ((fiber A x).dens : ℝ)).dens : ℝ) := by let : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ - let : Nonempty (Fin p → Fin k) := Pi.instNonempty - have hδ₁ : δ ≤ 1 := hA.trans (by exact_mod_cast Finset.dens_le_one (s := A)) - have hthreshold := density_ge_threshold (fun x : Fin p → Fin k ↦ ((fiber A x).dens : ℝ)) - δ (δ / 2) - (fun x ↦ by exact_mod_cast Finset.dens_le_one (s := fiber A x)) - (by linarith) (by simpa only [average_density_fiber] using hA) - refine le_trans ?_ hthreshold - refine (le_div_iff₀ ?_).mpr ?_ - · linarith - · nlinarith + have hδ₁ : δ ≤ 1 := hA.trans (by exact_mod_cast dens_le_one) + refine le_trans ?_ (density_ge_threshold (fun x ↦ by exact_mod_cast dens_le_one) + (by linarith : δ / 2 < δ) (by rwa [average_density_fiber])) + rw [le_div_iff₀ (by linarith)] + nlinarith /-- A dense suffix fiber contains a line whose points remain in the ambient family. -/ -lemma exists_line_of_fiber_density {k p q : ℕ} (hk : 0 < k) (hDHJ : HasDensityHJ k) - (δ : ℝ) (hδ : 0 < δ) (hq : densityOneBound k δ ≤ q) - (A : Finset (Fin p ⊕ Fin q → Fin k)) (x : Fin p → Fin k) +lemma exists_line_of_fiber_density {k p q : ℕ} (hk : 0 < k) {δ : ℝ} + (hq : IsDHJDimension k δ q) + {A : Finset (Fin p ⊕ Fin q → Fin k)} {x : Fin p → Fin k} (hx : δ ≤ ((fiber A x).dens : ℝ)) : ∃ l : Combinatorics.Line (Fin k) (Fin q), ∀ a, Sum.elim x (l a) ∈ A := by - obtain ⟨l, hl⟩ := - densityOneBound_spec hDHJ δ hδ q hq (fiber A x) - (card_le_of_density_le hk δ (fiber A x) hx) - refine ⟨l, ?_⟩ - intro a - exact mem_fiber.mp (hl a) - -/-- One suffix line is complete above a positive-density family of prefixes. -/ -lemma exists_common_dense_line {k p q : ℕ} (hk : 0 < k) (hDHJ : HasDensityHJ k) - (δ : ℝ) (hδ : 0 < δ) (hq : densityOneBound k (δ / 2) ≤ q) - (A : Finset (Fin p ⊕ Fin q → Fin k)) (hA : δ ≤ (A.dens : ℝ)) : - letI := lineFintype k q + obtain ⟨l, hl⟩ := hq (fiber A x) (card_le_of_density_le hk hx) + exact ⟨l, fun a ↦ mem_fiber.mp (hl a)⟩ + +/-- Density Hales--Jewett in many slices, followed by pigeonhole on lines: if a set `B` of indices +of density at least `ρ > 0` has slices of density at least `δ`, in a dimension `q` where density +Hales--Jewett holds at density `δ`, then one line lies in the slices over a set of indices of +density at least `ρ` divided by the number of lines. -/ +lemma exists_line_forall_mem_slices {P : Type*} [Fintype P] {k q : ℕ} (hk : 0 < k) {δ ρ : ℝ} + (hq : IsDHJDimension k δ q) (S : P → Finset (Fin q → Fin k)) {B : Finset P} (hρ : 0 < ρ) + (hB : ρ ≤ (B.dens : ℝ)) (hS : ∀ y ∈ B, δ ≤ ((S y).dens : ℝ)) : ∃ l : Combinatorics.Line (Fin k) (Fin q), - δ / (2 * Fintype.card (Combinatorics.Line (Fin k) (Fin q))) ≤ - ((Finset.univ.filter fun x : Fin p → Fin k ↦ - ∀ a, Sum.elim x (l a) ∈ A).dens : ℝ) := by + ρ / ((k + 1) ^ q - k ^ q : ℕ) ≤ ((univ.filter fun y ↦ ∀ a, l a ∈ S y).dens : ℝ) := by classical let := lineFintype k q - let B := Finset.univ.filter fun x : Fin p → Fin k ↦ - δ / 2 ≤ ((fiber A x).dens : ℝ) - have hB : δ / 2 ≤ (B.dens : ℝ) := half_density_prefixes hk δ hδ A hA - have hBne : B.Nonempty := by - by_contra h - rw [Finset.not_nonempty_iff_eq_empty.mp h, Finset.dens_empty] at hB - simp only [NNRat.cast_zero] at hB - linarith - have existsLine (x : {x // x ∈ B}) : ∃ l : Combinatorics.Line (Fin k) (Fin q), - ∀ a, Sum.elim x (l a) ∈ A := - exists_line_of_fiber_density hk hDHJ (δ / 2) (by linarith) hq A x - (by simpa only [B, Finset.mem_filter, Finset.mem_univ, true_and] using x.2) - choose lineAt hlineAt using existsLine - let l₀ := lineAt ⟨hBne.choose, hBne.choose_spec⟩ - let : Nonempty (Combinatorics.Line (Fin k) (Fin q)) := ⟨l₀⟩ - let f : (Fin p → Fin k) → Combinatorics.Line (Fin k) (Fin q) := fun x ↦ - if hx : x ∈ B then lineAt ⟨x, hx⟩ else l₀ - obtain ⟨l, hl⟩ := exists_fiber_density B f - refine ⟨l, le_trans ?_ (le_trans hl ?_)⟩ - · simpa only [div_div] using - div_le_div_of_nonneg_right hB - (by positivity : 0 ≤ (Fintype.card (Combinatorics.Line (Fin k) (Fin q)) : ℝ)) - · exact_mod_cast Finset.dens_le_dens <| by - intro x hx - simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hx ⊢ - have hfl : lineAt ⟨x, hx.1⟩ = l := by - simpa only [f, dite_eq_left hx.1] using hx.2 - intro a - rw [← hfl] - exact hlineAt ⟨x, hx.1⟩ a - -/-- Every positive target density eventually forces a subspace of any fixed positive -dimension. -/ -lemma exists_eventually_of_density {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) : - ∃ N, ∀ n, N ≤ n → ∀ A : Finset (Fin n → Fin k), - δ * (k : ℝ) ^ n ≤ #A → - ∃ V : Combinatorics.Subspace (Fin m) (Fin k) (Fin n), IsContained V A := by - classical - by_cases hk₀ : k = 0 - · subst k - refine ⟨m, ?_⟩ - intro n hmn A _ - exact ⟨emptyAlphabetSubspace hm hmn, emptyAlphabetSubspace_isContained hm hmn A⟩ - have hk : 0 < k := Nat.pos_of_ne_zero hk₀ - induction m, hm using Nat.le_induction generalizing δ with - | base => - exact ⟨densityOneBound k δ, fun n hn A hA ↦ - exists_one_of_density hDHJ δ hδ n hn A hA⟩ - | succ m hm ih => - let q := max 1 (densityOneBound k (δ / 2)) - have hqpos : 0 < q := lt_of_lt_of_le Nat.zero_lt_one (le_max_left _ _) - have hq : densityOneBound k (δ / 2) ≤ q := le_max_right _ _ - let : Nonempty (Fin q) := ⟨⟨0, hqpos⟩⟩ - let := lineFintype k q - let ε := δ / (2 * Fintype.card (Combinatorics.Line (Fin k) (Fin q))) - have hε : 0 < ε := by - have hlinecard : 0 < Fintype.card (Combinatorics.Line (Fin k) (Fin q)) := - Fintype.card_pos - dsimp only [ε] - exact div_pos hδ (by exact_mod_cast mul_pos (by norm_num : 0 < (2 : ℕ)) hlinecard) - obtain ⟨P, hP⟩ := ih ε hε - refine ⟨P + q, ?_⟩ - intro n hn A hA - let p := n - q - have hqn : q ≤ n := by omega - have hpq : p + q = n := Nat.sub_add_cancel hqn - have hPp : P ≤ p := by omega - let e : Fin p ⊕ Fin q ≃ Fin n := finSumFinEquiv.trans (finCongr hpq) - let wordEquiv : (Fin p ⊕ Fin q → Fin k) ≃ (Fin n → Fin k) := - e.arrowCongr (Equiv.refl _) - let A' := A.map wordEquiv.symm.toEmbedding - have hA' : δ ≤ (A'.dens : ℝ) := by - simpa only [A', Finset.dens_map_equiv] using density_le_of_card_le hk δ A hA - obtain ⟨l, hl⟩ := exists_common_dense_line hk hDHJ δ hδ hq A' hA' - let C := Finset.univ.filter fun x : Fin p → Fin k ↦ - ∀ a, Sum.elim x (l a) ∈ A' - have hC : ε ≤ (C.dens : ℝ) := by - simpa only [ε, C] using hl - obtain ⟨V, hV⟩ := hP p hPp C (card_le_of_density_le hk ε C hC) - let W₀ : Combinatorics.Subspace (Fin (m + 1)) (Fin k) (Fin p ⊕ Fin q) := - (Subspace.concat V (lineToSubspaceFinOne l)).reindex finSumFinEquiv - (Equiv.refl _) (Equiv.refl _) - let W : Combinatorics.Subspace (Fin (m + 1)) (Fin k) (Fin n) := - W₀.reindex (Equiv.refl _) (Equiv.refl _) e - refine ⟨W, ?_⟩ - intro z - let x : Fin m → Fin k := fun i ↦ z (finSumFinEquiv (Sum.inl i)) - let a : Fin k := z (finSumFinEquiv (Sum.inr 0)) - have hx : Sum.elim (V x) (l a) ∈ A' := by - have hxC : ∀ b, Sum.elim (V x) (l b) ∈ A' := by - simpa only [C, Finset.mem_filter, Finset.mem_univ, true_and] using hV x - exact hxC a - rw [Finset.mem_map_equiv] at hx - simp only [Equiv.symm_symm] at hx - convert hx using 1 - funext i - simp only [W, W₀, Combinatorics.Subspace.reindex_apply, Equiv.refl_apply, - Equiv.refl_symm] - change (Subspace.concat V (lineToSubspaceFinOne l)) (z ∘ finSumFinEquiv) (e.symm i) = - wordEquiv (Sum.elim (V x) (l a)) i - have hz : z ∘ finSumFinEquiv = - Sum.elim x (fun _ : Fin 1 ↦ a) := by - funext j - cases j with - | inl j => rfl - | inr j => exact congrArg z (congrArg finSumFinEquiv (congrArg Sum.inr (Fin.eq_zero j))) - rw [hz, Subspace.concat_apply, lineToSubspaceFinOne_apply] - rfl - -/-- A bound for multidimensional density Hales--Jewett. -/ -noncomputable def densityBound (k m : ℕ) (δ : ℝ) : ℕ := by - classical - exact if h : 1 ≤ m ∧ 0 < δ ∧ HasDensityHJ k then - Nat.find (exists_eventually_of_density h.2.2 m h.1 δ h.2.1) - else 0 - -lemma densityBound_spec {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityBound k m δ ≤ n) (A : Finset (Fin n → Fin k)) - (hA : δ * (k : ℝ) ^ n ≤ #A) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin k) (Fin n), IsContained V A := by - classical - rw [densityBound, dite_eq_left ⟨hm, hδ, hDHJ⟩] at hn - exact Nat.find_spec (exists_eventually_of_density hDHJ m hm δ hδ) n hn A hA + have hline (y : P) (hy : y ∈ B) : ∃ l : Combinatorics.Line (Fin k) (Fin q), ∀ a, l a ∈ S y := + hq (S y) (card_le_of_density_le hk (hS y hy)) + obtain ⟨y₀, hy₀⟩ := (dens_pos (s := B)).1 (by exact_mod_cast hρ.trans_le hB) + have : Nonempty (Combinatorics.Line (Fin k) (Fin q)) := ⟨(hline y₀ hy₀).choose⟩ + choose! lineAt hlineAt using hline + obtain ⟨l, hl⟩ := exists_fiber_density B lineAt + refine ⟨l, le_trans ?_ (hl.trans ?_)⟩ + · rw [← card_line q hk] + gcongr + · refine mod_cast dens_le_dens ?_ + intro y hy + obtain ⟨hyB, rfl⟩ := mem_filter.1 hy + simpa using hlineAt y hyB -/-- Multidimensional density Hales--Jewett follows from the one-dimensional assertion. -/ -lemma exists_of_density {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : densityBound k m δ ≤ n) (A : Finset (Fin n → Fin k)) - (hA : δ * (k : ℝ) ^ n ≤ #A) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin k) (Fin n), IsContained V A := - densityBound_spec hDHJ m hm δ hδ n hn A hA +/-- One suffix line is complete above a positive-density family of prefixes. -/ +lemma exists_common_dense_line {k p q : ℕ} (hk : 0 < k) + {δ : ℝ} (hδ : 0 < δ) (hq : IsDHJDimension k (δ / 2) q) + {A : Finset (Fin p ⊕ Fin q → Fin k)} (hA : δ ≤ (A.dens : ℝ)) : + ∃ l : Combinatorics.Line (Fin k) (Fin q), + δ / (2 * ((k + 1) ^ q - k ^ q : ℕ)) ≤ + ((univ.filter fun x : Fin p → Fin k ↦ ∀ a, Sum.elim x (l a) ∈ A).dens : ℝ) := by + obtain ⟨l, hl⟩ := exists_line_forall_mem_slices hk hq (fiber A) (half_pos hδ) + (half_density_prefixes hk hδ hA) fun x hx ↦ (mem_filter.1 hx).2 + exact ⟨l, by simpa [div_div] using hl⟩ /-- Split the coordinates of a word family into a prefix and a suffix along a cut equivalence. -/ def splitWords {alphabet p q n : ℕ} (e : Fin p ⊕ Fin q ≃ Fin n) @@ -349,18 +198,74 @@ def splitWords {alphabet p q n : ℕ} (e : Fin p ⊕ Fin q ≃ Fin n) lemma mem_splitWords {alphabet p q n : ℕ} {e : Fin p ⊕ Fin q ≃ Fin n} {A : Finset (Fin n → Fin alphabet)} {w : Fin p ⊕ Fin q → Fin alphabet} : w ∈ splitWords e A ↔ w ∘ e.symm ∈ A := by - rw [splitWords, Finset.mem_map_equiv, Equiv.symm_symm] + rw [splitWords, mem_map_equiv, Equiv.symm_symm] rfl @[simp] lemma dens_splitWords {alphabet p q n : ℕ} (e : Fin p ⊕ Fin q ≃ Fin n) (A : Finset (Fin n → Fin alphabet)) : (splitWords e A).dens = A.dens := by - rw [splitWords, Finset.dens_map_equiv] + rw [splitWords, dens_map_equiv] /-- The canonical cut equivalence associated with a decomposition of the ambient dimension. -/ def cutEquiv {p q n : ℕ} (h : p + q = n) : Fin p ⊕ Fin q ≃ Fin n := finSumFinEquiv.trans (finCongr h) +/-- A dimension for multidimensional density Hales--Jewett over `k` letters, by induction on the +dimension `m` of the subspace sought, given a bound `F` for density Hales--Jewett over `k` +letters. -/ +noncomputable def densityBound (k : ℕ) (F : ℝ → ℕ) : ℕ → ℝ → ℕ + | 0, _ => 0 + | 1, δ => F δ + | m + 2, δ => + densityBound k F (m + 1) + (δ / (2 * ((k + 1) ^ max 1 (F (δ / 2)) - k ^ max 1 (F (δ / 2)) : ℕ))) + + max 1 (F (δ / 2)) + +lemma densityBound_succ (k : ℕ) (F : ℝ → ℕ) {m : ℕ} (hm : 1 ≤ m) (δ : ℝ) : + densityBound k F (m + 1) δ = + densityBound k F m + (δ / (2 * ((k + 1) ^ max 1 (F (δ / 2)) - k ^ max 1 (F (δ / 2)) : ℕ))) + + max 1 (F (δ / 2)) := by + obtain ⟨m, rfl⟩ : ∃ m', m = m' + 1 := ⟨m - 1, by omega⟩ + rfl + +/-- An `m`-dimensional subspace of the prefix coordinates and a line of the suffix coordinates +whose concatenations all lie in a family give an `(m + 1)`-dimensional subspace in it. -/ +private lemma exists_isContained_of_concat_mem {k m p q n : ℕ} {e : Fin p ⊕ Fin q ≃ Fin n} + {A : Finset (Fin n → Fin k)} {V : Combinatorics.Subspace (Fin m) (Fin k) (Fin p)} + {l : Combinatorics.Line (Fin k) (Fin q)} (h : ∀ x a, Sum.elim (V x) (l a) ∈ splitWords e A) : + ∃ W : Combinatorics.Subspace (Fin (m + 1)) (Fin k) (Fin n), IsContained W A := by + refine ⟨(concat V (lineToSubspaceFinOne l)).reindex finSumFinEquiv (Equiv.refl _) e, ?_⟩ + intro z + have hz : z ∘ finSumFinEquiv = Sum.elim (fun i ↦ z (Fin.castAdd 1 i)) fun _ ↦ z (Fin.last m) := by + funext i + cases i with + | inl i => rfl + | inr i => rw [Fin.eq_zero i]; rfl + convert mem_splitWords.1 (h (fun i ↦ z (Fin.castAdd 1 i)) (z (Fin.last m))) using 1 + funext i + simp [Combinatorics.Subspace.reindex_apply, hz] + +/-- Multidimensional density Hales--Jewett: in every dimension `n ≥ densityBound k F m δ`, a family +of density `δ` over `k` letters contains an `m`-dimensional subspace. -/ +lemma exists_of_density {k : ℕ} (hk : 0 < k) {F : ℝ → ℕ} (hF : IsDHJBound k F) + {m : ℕ} (hm : 1 ≤ m) {δ : ℝ} (hδ : 0 < δ) {n : ℕ} (hn : densityBound k F m δ ≤ n) + {A : Finset (Fin n → Fin k)} (hA : δ * (k : ℝ) ^ n ≤ #A) : + ∃ V : Combinatorics.Subspace (Fin m) (Fin k) (Fin n), IsContained V A := by + classical + induction m, hm using Nat.le_induction generalizing δ n with + | base => exact exists_one_of_density (hF δ hδ n hn) hA + | succ m hm ih => + rw [densityBound_succ k F hm] at hn + set q := max 1 (F (δ / 2)) + have hpq : n - q + q = n := Nat.sub_add_cancel (by omega) + obtain ⟨l, hl⟩ := exists_common_dense_line (A := splitWords (cutEquiv hpq) A) hk hδ + (hF _ (half_pos hδ) q (le_max_right _ _)) (by simpa using density_le_of_card_le hk hA) + obtain ⟨V, hV⟩ := ih (div_pos hδ (mul_pos two_pos (Nat.cast_pos.2 (Nat.sub_pos_of_lt + (Nat.pow_lt_pow_left (lt_add_one k) (by positivity)))))) (by omega) + (card_le_of_density_le hk hl) + exact exists_isContained_of_concat_mem fun x ↦ (mem_filter.1 (hV x)).2 + /-- The subspace of a coordinate block whose parameter directions are all of its coordinates. -/ def blockSubspace (α : Type*) (m : ℕ) : Combinatorics.Subspace (Fin m) α (Fin m) where idxFun i := Sum.inr i @@ -431,123 +336,110 @@ lemma fiber_splitWords_prependCut {alphabet η m p q r n : ℕ} (h : m + r = n) /-- A prefix fiber sparser than the ambient density by `ε` forces another prefix fiber denser than the ambient density by a fixed amount. -/ lemma exists_denser_fiber {alphabet m q : ℕ} (halphabet : 0 < alphabet) {ε : ℝ} (hε : 0 < ε) - (A : Finset (Fin m ⊕ Fin q → Fin alphabet)) (u₀ : Fin m → Fin alphabet) + {A : Finset (Fin m ⊕ Fin q → Fin alphabet)} {u₀ : Fin m → Fin alphabet} (hu₀ : ((fiber A u₀).dens : ℝ) < (A.dens : ℝ) - ε) : ∃ u, (A.dens : ℝ) + ε / (alphabet : ℝ) ^ m ≤ ((fiber A u).dens : ℝ) := by - classical - by_contra! hcon - have halphabetR : (0 : ℝ) < (alphabet : ℝ) := by exact_mod_cast halphabet - have hpow : (0 : ℝ) < (alphabet : ℝ) ^ m := pow_pos halphabetR m - have hcard : (Fintype.card (Fin m → Fin alphabet) : ℝ) = (alphabet : ℝ) ^ m := by + by_contra! h + have hpow : (0 : ℝ) < (alphabet : ℝ) ^ m := pow_pos (Nat.cast_pos.2 halphabet) m + have hsum : ∑ u : Fin m → Fin alphabet, + ((A.dens : ℝ) + ε / (alphabet : ℝ) ^ m - (fiber A u).dens) = ε := by + rw [sum_sub_distrib, sum_const, ← card_mul_expect, average_density_fiber, card_univ, + nsmul_eq_mul] simp only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow] - have hsum : ∑ u : Fin m → Fin alphabet, ((fiber A u).dens : ℝ) = - (alphabet : ℝ) ^ m * (A.dens : ℝ) := by - rw [← average_density_fiber A, ← hcard, ← Finset.card_univ, Finset.card_mul_expect] - have hle : ∑ u : Fin m → Fin alphabet, ((fiber A u).dens : ℝ) ≤ - ∑ u : Fin m → Fin alphabet, (((A.dens : ℝ) + ε / (alphabet : ℝ) ^ m) + - if u = u₀ then -(ε + ε / (alphabet : ℝ) ^ m) else 0) := by - apply Finset.sum_le_sum - intro u _ - by_cases hu : u = u₀ - · rw [hu, ite_eq_left rfl] - linarith - · rw [ite_eq_right hu, add_zero] - linarith [hcon u] - rw [Finset.sum_add_distrib, Finset.sum_const, Finset.sum_ite_eq' Finset.univ u₀, - ite_eq_left (Finset.mem_univ u₀), Finset.card_univ, nsmul_eq_mul, hcard, hsum, mul_add, - mul_div_cancel₀ ε hpow.ne'] at hle - linarith [div_pos hε hpow] - -/-- Every ambient dimension admits a cut into a prefix carrying a subspace and a nonempty suffix -above which all fibers are almost as dense as the whole family. -/ + rw [mul_add, mul_div_cancel₀ _ hpow.ne'] + ring + linarith [(single_le_sum (fun u _ ↦ sub_nonneg.2 (h u).le) (mem_univ u₀)).trans_eq hsum, + div_pos hε hpow] + +/-- Every word family in dimension `n` has a cut into a prefix and a nonempty suffix, and a subspace +of the prefix above which all fibers are almost as dense as the whole family. -/ def VariableCutFibersSufficient (alphabet dimension : ℕ) (ε : ℝ) (n : ℕ) : Prop := ∀ A : Finset (Fin n → Fin alphabet), ∃ p q : ℕ, ∃ e : Fin p ⊕ Fin q ≃ Fin n, 0 < q ∧ ∃ V : Combinatorics.Subspace (Fin dimension) (Fin alphabet) (Fin p), ∀ x, (A.dens : ℝ) - ε ≤ ((fiber (splitWords e A) (V x)).dens : ℝ) -/-- The block density-increment argument: one coordinate block either uniformizes all suffix -fibers or increases the working density by a fixed amount, and the density upper bound bounds the -number of increments. -/ -private lemma exists_variableCut_of_fuel (alphabet dimension : ℕ) (halphabet : 0 < alphabet) - {ε : ℝ} (hε : 0 < ε) : - ∀ t n : ℕ, dimension * (t + 1) < n → ∀ A : Finset (Fin n → Fin alphabet), - 1 ≤ (A.dens : ℝ) + t * (ε / (alphabet : ℝ) ^ dimension) → - ∃ p q : ℕ, ∃ e : Fin p ⊕ Fin q ≃ Fin n, 0 < q ∧ - ∃ V : Combinatorics.Subspace (Fin dimension) (Fin alphabet) (Fin p), - ∀ x, (A.dens : ℝ) - ε ≤ ((fiber (splitWords e A) (V x)).dens : ℝ) := by - intro t - induction t using Nat.strong_induction_on with +/-- Cutting off a first block of coordinates either leaves every suffix fiber almost as dense as the +family, or gives a suffix fiber denser than the family by `ε / alphabet ^ dimension`. -/ +private lemma forall_or_exists_denser_fiber {alphabet dimension r n : ℕ} (halphabet : 0 < alphabet) + {ε : ℝ} (hε : 0 < ε) (hd : dimension + r = n) (A : Finset (Fin n → Fin alphabet)) : + (∀ u, (A.dens : ℝ) - ε ≤ ((fiber (splitWords (cutEquiv hd) A) u).dens : ℝ)) ∨ + ∃ u, (A.dens : ℝ) + ε / (alphabet : ℝ) ^ dimension ≤ + ((fiber (splitWords (cutEquiv hd) A) u).dens : ℝ) := by + rw [or_iff_not_imp_left, not_forall] + rintro ⟨u₀, hu₀⟩ + simpa using exists_denser_fiber halphabet hε (A := splitWords (cutEquiv hd) A) (u₀ := u₀) + (by rw [dens_splitWords]; exact not_le.1 hu₀) + +/-- The variable-cut lemma by density increments: as long as at most `t` increments of +`ε / alphabet ^ dimension` fit below density one, `t + 1` blocks of `dimension` coordinates +suffice. Each block either leaves all suffix fibers almost as dense as the family, or passes to a +denser suffix fiber. -/ +private lemma exists_variableCut_of_one_le_add_mul {alphabet dimension : ℕ} + (halphabet : 0 < alphabet) {ε : ℝ} (hε : 0 < ε) (t : ℕ) {n : ℕ} + (hn : dimension * (t + 1) < n) (A : Finset (Fin n → Fin alphabet)) + (hA : 1 ≤ (A.dens : ℝ) + t * (ε / (alphabet : ℝ) ^ dimension)) : + ∃ p q : ℕ, ∃ e : Fin p ⊕ Fin q ≃ Fin n, 0 < q ∧ + ∃ V : Combinatorics.Subspace (Fin dimension) (Fin alphabet) (Fin p), + ∀ x, (A.dens : ℝ) - ε ≤ ((fiber (splitWords e A) (V x)).dens : ℝ) := by + induction t using Nat.strong_induction_on generalizing n A with | _ t ih => - intro n hn A hfuel - have hblock : dimension ≤ dimension * (t + 1) := - Nat.le_mul_of_pos_right dimension (Nat.succ_pos t) - have hd : dimension + (n - dimension) = n := by omega - have hεpos : 0 < ε / (alphabet : ℝ) ^ dimension := - div_pos hε (pow_pos (by exact_mod_cast halphabet) dimension) - by_cases hsucc : - ∀ u, (A.dens : ℝ) - ε ≤ ((fiber (splitWords (cutEquiv hd) A) u).dens : ℝ) - · exact ⟨dimension, n - dimension, cutEquiv hd, by omega, - blockSubspace (Fin alphabet) dimension, by simpa only [blockSubspace_apply] using hsucc⟩ - push Not at hsucc - obtain ⟨u₀, hu₀⟩ := hsucc - obtain ⟨u, hu⟩ := exists_denser_fiber halphabet hε (splitWords (cutEquiv hd) A) u₀ - (by rwa [dens_splitWords]) - rw [dens_splitWords] at hu - have hu₁ : ((fiber (splitWords (cutEquiv hd) A) u).dens : ℝ) ≤ 1 := by - exact_mod_cast Finset.dens_le_one (s := fiber (splitWords (cutEquiv hd) A) u) - have htR : (1 : ℝ) ≤ (t : ℝ) := by - nlinarith [mul_pos hεpos hεpos] - obtain ⟨s, rfl⟩ : ∃ s, t = s + 1 := ⟨t - 1, by - have : 1 ≤ t := by exact_mod_cast htR - omega⟩ - have hstep : dimension * (s + 1 + 1) = dimension * (s + 1) + dimension := by ring - obtain ⟨p, q, e, hq, V, hV⟩ := ih s (by omega) (n - dimension) (by omega) - (fiber (splitWords (cutEquiv hd) A) u) - (by rw [Nat.cast_add, Nat.cast_one, add_mul, one_mul] at hfuel; linarith) - refine ⟨dimension + p, q, prependCut hd e, hq, prependFixed u V, ?_⟩ - intro x - rw [fiber_splitWords_prependCut] - linarith [hV x] - -/-- Every sufficiently large ambient dimension is sufficient for variable-cut uniform fibers. -/ -lemma exists_eventually_variableCutFibersSufficient (alphabet dimension : ℕ) - (hdimension : 1 ≤ dimension) {ε : ℝ} (hε : 0 < ε) : - ∃ N, ∀ n ≥ N, VariableCutFibersSufficient alphabet dimension ε n := by - classical - by_cases halphabet : alphabet = 0 - · subst alphabet - refine ⟨dimension + 1, ?_⟩ - intro n hn A - refine ⟨dimension, n - dimension, cutEquiv (by omega), by omega, - emptyAlphabetSubspace hdimension le_rfl, ?_⟩ + have hdn : dimension < n := (Nat.le_mul_of_pos_right _ t.succ_pos).trans_lt hn + have hd : dimension + (n - dimension) = n := by omega + obtain h | ⟨u, hu⟩ := forall_or_exists_denser_fiber halphabet hε hd A + · exact ⟨dimension, n - dimension, cutEquiv hd, by omega, blockSubspace _ dimension, + by simpa using h⟩ + have hε' := div_pos hε (pow_pos (Nat.cast_pos.2 halphabet) dimension) + obtain _ | t := t + · rw [Nat.cast_zero, zero_mul, add_zero] at hA + linarith [hu.trans (by exact_mod_cast dens_le_one : _ ≤ (1 : ℝ))] + obtain ⟨p, q, e, hq, V, hV⟩ := ih t (lt_add_one t) + (Nat.lt_sub_of_add_lt (by rwa [mul_add_one] at hn)) (fiber (splitWords (cutEquiv hd) A) u) + (by rw [Nat.cast_add_one] at hA; linarith) + refine ⟨dimension + p, q, prependCut hd e, hq, prependFixed u V, ?_⟩ intro x - exact Fin.elim0 (x ⟨0, hdimension⟩) - have halphabet₀ : 0 < alphabet := Nat.pos_of_ne_zero halphabet - have hεpos : 0 < ε / (alphabet : ℝ) ^ dimension := - div_pos hε (pow_pos (by exact_mod_cast halphabet₀) dimension) - obtain ⟨t, ht⟩ := exists_nat_gt (1 / (ε / (alphabet : ℝ) ^ dimension)) - refine ⟨dimension * (t + 1) + 1, ?_⟩ - intro n hn A - apply exists_variableCut_of_fuel alphabet dimension halphabet₀ hε t n (by omega) A - rw [div_lt_iff₀ hεpos] at ht - linarith [NNRat.cast_nonneg (α := ℝ) A.dens] - -/-- A sufficient ambient dimension for the variable-cut uniform-fibers lemma. -/ -noncomputable def variableCutFibersBound (alphabet dimension : ℕ) (ε : ℝ) : ℕ := by - classical - exact if h : 1 ≤ dimension ∧ 0 < ε then - Nat.find (exists_eventually_variableCutFibersSufficient alphabet dimension h.1 h.2) - else 0 - -/-- The selected variable-cut bound is sufficient in every larger ambient dimension. -/ -lemma variableCutFibersBound_spec (alphabet dimension n : ℕ) (hdimension : 1 ≤ dimension) - {ε : ℝ} (hε : 0 < ε) (hn : variableCutFibersBound alphabet dimension ε ≤ n) : + rw [fiber_splitWords_prependCut] + linarith [hV x] + +/-- An ambient dimension sufficient for the variable-cut uniform-fibers lemma: one coordinate block +for each possible density increment, and one more coordinate. -/ +noncomputable def variableCutFibersBound (alphabet dimension : ℕ) (ε : ℝ) : ℕ := + dimension * (⌊(alphabet : ℝ) ^ dimension / ε⌋₊ + 1 + 1) + 1 + +/-- `VariableCutFibersSufficient alphabet dimension ε n` holds for every +`n ≥ variableCutFibersBound alphabet dimension ε`. -/ +lemma variableCutFibersSufficient_of_le {alphabet dimension : ℕ} + (hdimension : 1 ≤ dimension) {ε : ℝ} (hε : 0 < ε) {n : ℕ} + (hn : variableCutFibersBound alphabet dimension ε ≤ n) : VariableCutFibersSufficient alphabet dimension ε n := by - classical - rw [variableCutFibersBound, dite_eq_left ⟨hdimension, hε⟩] at hn - exact Nat.find_spec - (exists_eventually_variableCutFibersSufficient alphabet dimension hdimension hε) n hn + rw [variableCutFibersBound] at hn + intro A + obtain rfl | halphabet := Nat.eq_zero_or_pos alphabet + · have hdn : dimension < n := (Nat.le_mul_of_pos_right _ (by omega)).trans_lt hn + exact ⟨dimension, n - dimension, cutEquiv (by omega), by omega, + emptyAlphabetSubspace hdimension le_rfl, fun x ↦ (x ⟨0, hdimension⟩).elim0⟩ + refine exists_variableCut_of_one_le_add_mul halphabet hε _ hn A + (le_add_of_nonneg_of_le (by positivity) ?_) + rw [mul_div_assoc', ← div_div_eq_mul_div, one_le_div (by positivity)] + exact_mod_cast (Nat.lt_floor_add_one _).le + +/-- The variable-cut dimension is monotone in the dimension of the subspace and antitone in the +tolerance. -/ +lemma variableCutFibersBound_mono {a d d' : ℕ} {ε ε' : ℝ} (ha : 1 ≤ a) (hd : d ≤ d') + (hε' : 0 < ε') (hε : ε' ≤ ε) : + variableCutFibersBound a d ε ≤ variableCutFibersBound a d' ε' := by + unfold variableCutFibersBound + gcongr + exact_mod_cast ha + +/-- Double counting: for a relation between two finite types, the average density of the sets +of related elements is the same from either side. -/ +lemma expect_dens_filter_comm {X Y : Type*} [Fintype X] [Fintype Y] (P : X → Y → Prop) + [∀ x y, Decidable (P x y)] : + 𝔼 x, ((univ.filter (P x)).dens : ℝ) = 𝔼 y, ((univ.filter fun x ↦ P x y).dens : ℝ) := by + simp_rw [← expect_indicator_one] + rw [expect_comm] + simp [Set.indicator_apply] /-- Averaging restricted-parameter slice densities over suffixes equals averaging their ambient fiber densities over restricted parameter words. -/ @@ -556,168 +448,71 @@ lemma average_restrictedParameterSlice {k M : ℕ} [DecidableEq (ι ⊕ κ → Fin (k + 1))] (A : Finset (ι ⊕ κ → Fin (k + 1))) (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) : - Finset.expect Finset.univ (fun y : κ → Fin (k + 1) ↦ - ((Finset.univ.filter fun x : Fin M → Fin k ↦ + expect univ (fun y : κ → Fin (k + 1) ↦ + ((univ.filter fun x : Fin M → Fin k ↦ Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ)) = - Finset.expect Finset.univ (fun x : Fin M → Fin k ↦ - ((fiber A (W (Fin.castSucc ∘ x))).dens : ℝ)) := by - simp_rw [← Finset.expect_indicator_one] - rw [Finset.expect_comm] - apply Finset.expect_congr rfl - intro x _ - apply Finset.expect_congr rfl - intro y _ - by_cases h : Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A <;> simp [h] + expect univ (fun x : Fin M → Fin k ↦ + ((fiber A (W (Fin.castSucc ∘ x))).dens : ℝ)) := + (expect_dens_filter_comm fun x y ↦ Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).symm /-- Averaging a pointwise-dense family of suffix fibers produces one suffix above which the restricted parameter family is dense. -/ -lemma exists_dense_suffix_of_restricted_fibers {k M : ℕ} (hk : 0 < k) (δ : ℝ) +lemma exists_dense_suffix_of_restricted_fibers {k M : ℕ} (hk : 0 < k) {δ : ℝ} {ι κ : Type*} [Fintype (κ → Fin (k + 1))] [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (A : Finset (ι ⊕ κ → Fin (k + 1))) - (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) + {A : Finset (ι ⊕ κ → Fin (k + 1))} + {W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι} (hW : ∀ x : Fin M → Fin k, δ / 2 ≤ ((fiber A (W (Fin.castSucc ∘ x))).dens : ℝ)) : ∃ y : κ → Fin (k + 1), δ / 2 ≤ - ((Finset.univ.filter fun x : Fin M → Fin k ↦ + ((univ.filter fun x : Fin M → Fin k ↦ Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ) := by let : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ - have havg : δ / 2 ≤ - Finset.expect Finset.univ (fun y : κ → Fin (k + 1) ↦ - ((Finset.univ.filter fun x : Fin M → Fin k ↦ - Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ)) := by - rw [average_restrictedParameterSlice] - exact Finset.le_expect Finset.univ_nonempty fun x _ ↦ hW x - by_contra! h - apply (not_lt_of_ge havg) - apply Finset.expect_lt - · intro y _ - exact (h y).le - · exact ⟨fun _ ↦ 0, Finset.mem_univ _, h (fun _ ↦ 0)⟩ + obtain ⟨y, -, hy⟩ := exists_le_of_le_expect univ_nonempty + ((le_expect univ_nonempty fun x _ ↦ hW x).trans_eq (average_restrictedParameterSlice A W).symm) + exact ⟨y, hy⟩ /-- Extend a restricted parameter subspace to the full alphabet, attach a fixed suffix, and transport the resulting subspace along an equivalence of ambient coordinates. -/ lemma extend_restricted_subspace {k m M : ℕ} {ι κ ζ : Type*} - [DecidableEq (ζ → Fin (k + 1))] (e : ι ⊕ κ ≃ ζ) - (A : Finset (ζ → Fin (k + 1))) - (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) (y : κ → Fin (k + 1)) - (S : Combinatorics.Subspace (Fin m) (Fin k) (Fin M)) + [DecidableEq (ζ → Fin (k + 1))] {e : ι ⊕ κ ≃ ζ} + {A : Finset (ζ → Fin (k + 1))} + {W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι} {y : κ → Fin (k + 1)} + {S : Combinatorics.Subspace (Fin m) (Fin k) (Fin M)} (hS : ∀ x, (Sum.elim (W (Fin.castSucc ∘ S x)) y) ∘ e.symm ∈ A) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ζ, restrictAlphabet V Fin.castSuccEmb ⊆ A := by - let lift_S : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin M) := - { idxFun := fun i ↦ (S.idxFun i).map (Fin.castSuccEmb : Fin k → Fin (k + 1)) id - proper := fun e ↦ by - obtain ⟨i, hi⟩ := S.proper e - refine ⟨i, ?_⟩ - simp [hi] } - have h_lift_eval (x : Fin m → Fin k) : lift_S (Fin.castSuccEmb ∘ x) = Fin.castSucc ∘ S x := by - ext i - cases hi : S.idxFun i <;> simp [lift_S, Combinatorics.Subspace.coe_apply, hi] - let concat_suffix : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ζ := - { idxFun := fun c ↦ - match e.symm c with - | Sum.inl i => W.idxFun i - | Sum.inr j => Sum.inl (y j) - proper := fun e' ↦ by - obtain ⟨i, hi⟩ := W.proper e' - refine ⟨e (Sum.inl i), ?_⟩ - simp [hi] } - have h_concat_suffix_eval (z : Fin M → Fin (k + 1)) : - concat_suffix z = (Sum.elim (W z) y) ∘ e.symm := by - ext c - simp only [Subspace.coe_apply, Function.comp_apply, concat_suffix] - cases e.symm c <;> simp [Combinatorics.Subspace.coe_apply] - let V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ζ := - compose concat_suffix lift_S - refine ⟨V, ?_⟩ + use compose (fixSuffixReindex e W y) (map Fin.castSucc S) intro w hw - rw [restrictAlphabet, Finset.mem_image] at hw - rcases hw with ⟨x, _, rfl⟩ - rw [compose_apply, h_lift_eval x, h_concat_suffix_eval (Fin.castSucc ∘ S x)] - exact hS x - -/-- For the empty restricted alphabet, the restricted range is empty as soon as the parameter -dimension is positive. -/ -lemma exists_empty_restrictAlphabet_subset {m n : ℕ} (hm : 1 ≤ m) (hmn : m ≤ n) - (A : Finset (Fin n → Fin 1)) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin 1) (Fin n), - restrictAlphabet V Fin.castSuccEmb ⊆ A := by - let V : Combinatorics.Subspace (Fin m) (Fin 1) (Fin n) := - { idxFun := fun i ↦ if hi : i.val < m then Sum.inr ⟨i.val, hi⟩ else Sum.inl 0 - proper := fun e ↦ by - refine ⟨Fin.castLE hmn e, ?_⟩ - simp only [Fin.castLE, e.isLt, ↓reduceDIte] } - refine ⟨V, ?_⟩ - intro w hw - simp only [restrictAlphabet, Finset.mem_image, Finset.mem_univ, true_and] at hw - obtain ⟨x, _⟩ := hw - exact Fin.elim0 (x ⟨0, Nat.zero_lt_of_lt hm⟩) - -/-- The restricted-alphabet conclusion holds in every sufficiently large dimension. -/ -lemma exists_eventually_restrictAlphabet_subset {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) : - ∃ N, ∀ n, N ≤ n → ∀ A : Finset (Fin n → Fin (k + 1)), - δ * (k + 1 : ℝ) ^ n ≤ #A → - ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - restrictAlphabet V Fin.castSuccEmb ⊆ A := by - classical - by_cases hk₀ : k = 0 - · subst k - refine ⟨m, ?_⟩ - intro n hmn A _ - exact exists_empty_restrictAlphabet_subset hm hmn A - have hk : 0 < k := Nat.pos_of_ne_zero hk₀ - let M := max 1 (densityBound k m (δ / 2)) - refine ⟨variableCutFibersBound (k + 1) M (δ / 2), ?_⟩ - intro n hn A hA - have hM : 1 ≤ M := le_max_left _ _ - have hA' : δ ≤ (A.dens : ℝ) := by - apply density_le_of_card_le (Nat.zero_lt_succ k) δ A - convert hA using 1 - norm_num - obtain ⟨p, q, e, _hq, W, hW⟩ := - variableCutFibersBound_spec (k + 1) M n hM (by linarith) hn A - obtain ⟨y, hy⟩ := - exists_dense_suffix_of_restricted_fibers hk δ (splitWords e A) W fun x ↦ by - linarith [hW (Fin.castSucc ∘ x)] - let B := Finset.univ.filter fun x : Fin M → Fin k ↦ - Sum.elim (W (Fin.castSucc ∘ x)) y ∈ splitWords e A - obtain ⟨S, hS⟩ := - exists_of_density hDHJ m hm (δ / 2) (by linarith) M (le_max_right _ _) B - (card_le_of_density_le hk (δ / 2) B (by simpa only [B] using hy)) - apply extend_restricted_subspace e A W y S - intro x - rw [← mem_splitWords] - simpa only [B, Finset.mem_filter, Finset.mem_univ, true_and] using hS x - -/-- A bound for the restricted-alphabet subspace lemma. -/ -noncomputable def restrictAlphabetBound (k m : ℕ) (δ : ℝ) : ℕ := by - classical - exact if h : 1 ≤ m ∧ 0 < δ ∧ HasDensityHJ k then - Nat.find (exists_eventually_restrictAlphabet_subset h.2.2 m h.1 δ h.2.1) - else 0 - -lemma restrictAlphabetBound_spec {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : restrictAlphabetBound k m δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) (hA : δ * (k + 1 : ℝ) ^ n ≤ #A) : + obtain ⟨x, -, rfl⟩ := mem_image.1 hw + simpa using hS x + +/-- A dimension in which every family of density `δ` over `k + 1` letters contains the `Fin k` +restriction of an `m`-dimensional subspace, given a bound `F` for density Hales--Jewett over `k` +letters. -/ +noncomputable def restrictAlphabetBound (k : ℕ) (F : ℝ → ℕ) (m : ℕ) (δ : ℝ) : ℕ := + variableCutFibersBound (k + 1) (max 1 (densityBound k F m (δ / 2))) (δ / 2) + +/-- In every dimension `n ≥ restrictAlphabetBound k F m δ`, a family of density `δ` over `k + 1` +letters contains the `Fin k` restriction of an `m`-dimensional subspace. -/ +lemma exists_restrictAlphabet_subset {k : ℕ} (hk : 0 < k) {F : ℝ → ℕ} (hF : IsDHJBound k F) + {m : ℕ} (hm : 1 ≤ m) {δ : ℝ} (hδ : 0 < δ) + {n : ℕ} (hn : restrictAlphabetBound k F m δ ≤ n) + {A : Finset (Fin n → Fin (k + 1))} (hA : δ * (k + 1 : ℝ) ^ n ≤ #A) : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), restrictAlphabet V Fin.castSuccEmb ⊆ A := by classical - rw [restrictAlphabetBound, dite_eq_left ⟨hm, hδ, hDHJ⟩] at hn - exact Nat.find_spec (exists_eventually_restrictAlphabet_subset hDHJ m hm δ hδ) n hn A hA - -/-- A dense family over `Fin (k+1)` contains the `Fin k` restriction of a subspace. -/ -lemma exists_restrictAlphabet_subset {k : ℕ} (hDHJ : HasDensityHJ k) - (m : ℕ) (hm : 1 ≤ m) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : restrictAlphabetBound k m δ ≤ n) - (A : Finset (Fin n → Fin (k + 1))) - (hA : δ * (k + 1 : ℝ) ^ n ≤ #A) : - ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - restrictAlphabet V Fin.castSuccEmb ⊆ A := - restrictAlphabetBound_spec hDHJ m hm δ hδ n hn A hA + have hA' := density_le_of_card_le k.succ_pos (A := A) (δ := δ) (by exact_mod_cast hA) + obtain ⟨p, q, e, -, W, hW⟩ := + variableCutFibersSufficient_of_le (le_max_left _ _) (half_pos hδ) hn A + obtain ⟨y, hy⟩ := exists_dense_suffix_of_restricted_fibers hk (δ := δ) (A := splitWords e A) + (W := W) fun x ↦ by linarith [hW (Fin.castSucc ∘ x)] + obtain ⟨S, hS⟩ := exists_of_density hk hF hm (half_pos hδ) (le_max_right 1 _) + (card_le_of_density_le hk hy) + refine extend_restricted_subspace (e := e) (W := W) (y := y) (S := S) ?_ + intro x + simpa using hS x end Subspace end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean index b22dc815ae..e2a5a59230 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean @@ -6,12 +6,15 @@ Authors: Gabriel Dahia module public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi +import Mathlib.Algebra.Order.BigOperators.Expect /-! # Many arithmetic progressions in dense sets -Varnavides' averaging argument upgrades Szemerédi's theorem from the existence of one arithmetic -progression in a dense set to a quadratic lower bound on the number of such progressions. +Varnavides' averaging argument turns Szemerédi's theorem, the existence of one arithmetic +progression in a dense set, into a quadratic lower bound on the number of such progressions. The +bound is explicit in a threshold `m` for Szemerédi's theorem at half the density and a natural +bound `N` for `1 / δ`. -/ @[expose] public section @@ -23,318 +26,223 @@ namespace Combinatorics.ArithmeticProgression /-- The pairs `(a, d)` that parametrize nonconstant `k`-term arithmetic progressions contained in `A`. -/ def containedProgressions (k n : ℕ) (A : Finset ℕ) : Finset (ℕ × ℕ) := - (range n ×ˢ range n).filter fun p ↦ - p.2 ≠ 0 ∧ ∀ i : Fin k, p.1 + (i : ℕ) * p.2 ∈ A + (range n ×ˢ range n).filter fun (a, d) ↦ d ≠ 0 ∧ ∀ i : Fin k, a + i * d ∈ A -/-- The indices at which the finite progression parametrized by `p` meets `A`. -/ -def indicesIn (m : ℕ) (A : Finset ℕ) (p : ℕ × ℕ) : Finset ℕ := - (range m).filter fun i ↦ p.1 + i * p.2 ∈ A +/-- The indices at which the finite progression parametrized by `(a, d)` meets `A`. -/ +def indicesIn (m : ℕ) (A : Finset ℕ) : ℕ × ℕ → Finset ℕ + | (a, d) => (range m).filter fun i ↦ a + i * d ∈ A /-- Finite progressions of length `m`, positive difference at most `D`, and lying in `range n`. We use the slightly stronger endpoint condition `a + m * d ≤ n`. -/ def grids (m n D : ℕ) : Finset (ℕ × ℕ) := - (range n ×ˢ Icc 1 D).filter fun p ↦ p.1 + m * p.2 ≤ n + (range n ×ˢ Icc 1 D).filter fun (a, d) ↦ a + m * d ≤ n /-- Incidences between a grid and one of its indices whose image lies in `A`. -/ def gridIncidences (m n D : ℕ) (A : Finset ℕ) : Finset ((ℕ × ℕ) × ℕ) := - (grids m n D ×ˢ range m).filter fun gi ↦ - gi.1.1 + gi.2 * gi.1.2 ∈ A + (grids m n D ×ˢ range m).filter fun ((a, d), i) ↦ a + i * d ∈ A lemma card_gridIncidences (m n D : ℕ) (A : Finset ℕ) : - #(gridIncidences m n D A) = - ∑ p ∈ grids m n D, #(indicesIn m A p) := by - classical - simp only [gridIncidences, indicesIn, Finset.card_eq_sum_ones] - rw [Finset.sum_filter, Finset.sum_product] - simp_rw [Finset.sum_filter] + #(gridIncidences m n D A) = ∑ p ∈ grids m n D, #(indicesIn m A p) := by + simp only [gridIncidences, indicesIn, card_filter, sum_product] /-- The grids on which `A` has density at least `δ`. -/ noncomputable def denseGrids (δ : ℝ) (m n D : ℕ) (A : Finset ℕ) : Finset (ℕ × ℕ) := (grids m n D).filter fun p ↦ δ * m ≤ #(indicesIn m A p) -lemma card_grids_le (m n D : ℕ) : - #(grids m n D) ≤ n * D := by - apply (Finset.card_le_card (Finset.filter_subset _ _)).trans - simp [Nat.card_Icc] +lemma card_grids_le (m n D : ℕ) : #(grids m n D) ≤ n * D := + (card_filter_le _ _).trans_eq (by simp) -lemma card_gridIncidences_upper_bound (δ : ℝ) (hδ : 0 ≤ δ) (m n D : ℕ) - (A : Finset ℕ) : - (#(gridIncidences m n D A) : ℝ) ≤ - δ * m * #(grids m n D) + m * #(denseGrids δ m n D A) := by +/-- A grid that is not dense has fewer than `δ * m` incidences, and a dense one has at most +`m`. -/ +lemma card_gridIncidences_le {δ : ℝ} (hδ : 0 ≤ δ) (m n D : ℕ) (A : Finset ℕ) : + (#(gridIncidences m n D A) : ℝ) ≤ δ * m * #(grids m n D) + m * #(denseGrids δ m n D A) := by rw [card_gridIncidences, Nat.cast_sum] - calc - _ ≤ ∑ p ∈ grids m n D, - (δ * m + if p ∈ denseGrids δ m n D A then (m : ℝ) else 0) := by - apply Finset.sum_le_sum - intro p hp - by_cases hpdense : p ∈ denseGrids δ m n D A - · rw [ite_eq_left hpdense] - apply le_add_of_nonneg_of_le (by positivity) - change ((#((range m).filter fun i ↦ p.1 + i * p.2 ∈ A) : ℕ) : ℝ) ≤ m - exact_mod_cast (Finset.card_filter_le _ _).trans_eq (Finset.card_range m) - · simp only [ite_eq_right hpdense, add_zero] - rw [denseGrids, Finset.mem_filter] at hpdense - exact le_of_lt (not_le.mp fun h ↦ hpdense ⟨hp, h⟩) + calc ∑ p ∈ grids m n D, (#(indicesIn m A p) : ℝ) + ≤ ∑ p ∈ grids m n D, (δ * m + if δ * m ≤ #(indicesIn m A p) then (m : ℝ) else 0) := by + gcongr with p + have hm : (#(indicesIn m A p) : ℝ) ≤ m := + mod_cast (card_filter_le _ _).trans_eq (card_range m) + split_ifs with h + · linarith [mul_nonneg hδ (Nat.cast_nonneg m)] + · linarith _ = δ * m * #(grids m n D) + m * #(denseGrids δ m n D A) := by - rw [Finset.sum_add_distrib, Finset.sum_const, nsmul_eq_mul, Finset.sum_ite_mem, denseGrids, - Finset.inter_eq_right.mpr (Finset.filter_subset _ _), Finset.sum_const, nsmul_eq_mul] - ring - -lemma card_gridIncidences_lower_bound (m n D W : ℕ) (hW : m * D ≤ W) - (A : Finset ℕ) (hAn : A ⊆ range n) : - #(A ∩ Icc W (n - W)) * D * m ≤ #(gridIncidences m n D A) := by - let domain := ((A ∩ Icc W (n - W)) ×ˢ Icc 1 D) ×ˢ range m - let f : ((ℕ × ℕ) × ℕ) → ((ℕ × ℕ) × ℕ) := - fun x ↦ ((x.1.1 - x.2 * x.1.2, x.1.2), x.2) - have hdomaincard : - #domain = #(A ∩ Icc W (n - W)) * D * m := by - simp [domain, Nat.card_Icc] - rw [← hdomaincard] - change #domain ≤ #(gridIncidences m n D A) - apply Finset.card_le_card_of_injOn f - · intro x hx - change x ∈ domain at hx - dsimp only [domain] at hx - rw [Finset.mem_product, Finset.mem_product] at hx - change f x ∈ gridIncidences m n D A - rw [gridIncidences, Finset.mem_filter, Finset.mem_product, grids, - Finset.mem_filter, Finset.mem_product] - rcases hx with ⟨⟨hxA, hxd⟩, hxi⟩ - rw [Finset.mem_inter, Finset.mem_Icc] at hxA - rw [Finset.mem_Icc] at hxd - rw [Finset.mem_range] at hxi - have hidW : x.2 * x.1.2 ≤ W := (Nat.mul_le_mul hxi.le hxd.2).trans hW - have hidX : x.2 * x.1.2 ≤ x.1.1 := hidW.trans hxA.2.1 - constructor - · refine ⟨?_, Finset.mem_range.mpr hxi⟩ - refine ⟨⟨Finset.mem_range.mpr ?_, Finset.mem_Icc.mpr hxd⟩, ?_⟩ - · exact (Nat.sub_le _ _).trans_lt (Finset.mem_range.mp (hAn hxA.1)) - · dsimp only [f, Prod.fst, Prod.snd] - have : m * x.1.2 ≤ W := (Nat.mul_le_mul_left m hxd.2).trans hW - omega - · dsimp only [f, Prod.fst, Prod.snd] - rw [Nat.sub_add_cancel hidX] - exact hxA.1 - · intro x hx y hy hxy - simp only [f, Prod.mk.injEq] at hxy - change x ∈ domain at hx - change y ∈ domain at hy - dsimp only [domain] at hx hy - rw [Finset.mem_product, Finset.mem_product] at hx hy - rcases hx with ⟨⟨hxA, hxd⟩, hxi⟩ - rcases hy with ⟨⟨hyA, hyd⟩, hyi⟩ - rw [Finset.mem_inter, Finset.mem_Icc] at hxA hyA - rw [Finset.mem_Icc] at hxd hyd - rw [Finset.mem_range] at hxi hyi - have hxsub : x.2 * x.1.2 ≤ x.1.1 := - (Nat.mul_le_mul hxi.le hxd.2).trans hW |>.trans hxA.2.1 - have hysub : y.2 * y.1.2 ≤ y.1.1 := - (Nat.mul_le_mul hyi.le hyd.2).trans hW |>.trans hyA.2.1 - apply Prod.ext - · apply Prod.ext - · rw [← Nat.sub_add_cancel hxsub, ← Nat.sub_add_cancel hysub, hxy.1.1, - hxy.1.2, hxy.2] - · exact hxy.1.2 - · exact hxy.2 + simp [sum_add_distrib, sum_ite, denseGrids, mul_comm] + +/-- Every point `a` of `A` at distance at least `W ≥ m * D` from the ends of `range n` lies on +the grid with difference `d` at index `i`, for each `d ≤ D` and `i < m`. -/ +lemma le_card_gridIncidences {m n D W : ℕ} (hW : m * D ≤ W) {A : Finset ℕ} + (hAn : A ⊆ range n) : #(A ∩ Icc W (n - W)) * D * m ≤ #(gridIncidences m n D A) := by + have hcard : #(((A ∩ Icc W (n - W)) ×ˢ Icc 1 D) ×ˢ range m) = #(A ∩ Icc W (n - W)) * D * m := by + simp + rw [← hcard] + refine card_le_card_of_injOn (fun ((a, d), i) ↦ ((a - i * d, d), i)) ?_ ?_ + · rintro ⟨⟨a, d⟩, i⟩ hx + simp only [mem_coe, mem_product, mem_inter, mem_Icc, mem_range] at hx + obtain ⟨⟨⟨haA, haW, han⟩, hd, hdD⟩, hi⟩ := hx + obtain ⟨hid, hmd⟩ : i * d ≤ W ∧ m * d ≤ W := + ⟨(Nat.mul_le_mul hi.le hdD).trans hW, (Nat.mul_le_mul_left m hdD).trans hW⟩ + simp only [gridIncidences, grids, mem_coe, mem_filter, mem_product, mem_range, mem_Icc] + refine ⟨⟨⟨⟨(Nat.sub_le _ _).trans_lt (mem_range.1 (hAn haA)), hd, hdD⟩, by omega⟩, hi⟩, ?_⟩ + rwa [Nat.sub_add_cancel (hid.trans haW)] + · rintro ⟨⟨a, d⟩, i⟩ hx ⟨⟨a', d'⟩, i'⟩ hy h + simp only [mem_coe, mem_product, mem_inter, mem_Icc, mem_range] at hx hy + simp only [Prod.mk.injEq] at h + obtain ⟨⟨h, rfl⟩, rfl⟩ := h + have hid : i * d ≤ W := (Nat.mul_le_mul hx.2.le hx.1.2.2).trans hW + simp only [Prod.mk.injEq, and_true] + omega -lemma card_inter_interior (n W : ℕ) (A : Finset ℕ) (hAn : A ⊆ range n) : +lemma card_le_card_inter_Icc_add {n : ℕ} (W : ℕ) {A : Finset ℕ} (hAn : A ⊆ range n) : #A ≤ #(A ∩ Icc W (n - W)) + 2 * W := by - have houtside : - A \ Icc W (n - W) ⊆ range W ∪ Ico (n - W) n := by + have h : A \ Icc W (n - W) ⊆ range W ∪ Ico (n - W) n := by intro x hx - rw [Finset.mem_sdiff, Finset.mem_Icc] at hx - rw [Finset.mem_union, Finset.mem_range, Finset.mem_Ico] - have := Finset.mem_range.mp (hAn hx.1) - omega - have : #(A \ Icc W (n - W)) ≤ 2 * W := by - apply (Finset.card_le_card houtside).trans - apply (Finset.card_union_le _ _).trans - rw [Finset.card_range, Nat.card_Ico] + have := mem_range.1 (hAn (mem_sdiff.1 hx).1) + simp only [mem_sdiff, mem_Icc, mem_union, mem_range, mem_Ico] at hx ⊢ omega - rw [← Finset.card_inter_add_card_sdiff A (Icc W (n - W))] + have := (card_le_card h).trans (card_union_le _ _) + rw [card_range, Nat.card_Ico] at this + rw [← card_inter_add_card_sdiff A (Icc W (n - W))] omega -lemma denseGrids_card_lower_bound (δ : ℝ) (hδ : 0 < δ) (m n D W : ℕ) - (hm : 0 < m) (hW : m * D ≤ W) (hWsmall : 8 * W ≤ δ * n) - (A : Finset ℕ) (hAn : A ⊆ range n) (hA : δ * n ≤ #A) : +/-- Double counting the incidences: a positive proportion of the grids are dense. -/ +lemma le_card_denseGrids {δ : ℝ} (hδ : 0 < δ) {m n D W : ℕ} (hm : 0 < m) (hW : m * D ≤ W) + (hWn : 8 * W ≤ δ * n) {A : Finset ℕ} (hAn : A ⊆ range n) (hA : δ * n ≤ #A) : δ / 4 * n * D ≤ #(denseGrids (δ / 2) m n D A) := by - have hinter : δ * n - 2 * W ≤ (#(A ∩ Icc W (n - W)) : ℝ) := by - have hcast : (#A : ℝ) ≤ #(A ∩ Icc W (n - W)) + 2 * W := by - exact_mod_cast card_inter_interior n W A hAn - linarith - have hchain : - (δ * n - 2 * W) * D * m ≤ - δ / 2 * m * ((n : ℝ) * D) + m * #(denseGrids (δ / 2) m n D A) := by - refine le_trans ?_ - ((card_gridIncidences_upper_bound (δ / 2) (by positivity) m n D A).trans - (add_le_add ?_ le_rfl)) - · refine le_trans (mul_le_mul_of_nonneg_right (mul_le_mul_of_nonneg_right hinter ?_) ?_) ?_ - · positivity - · positivity - · exact_mod_cast card_gridIncidences_lower_bound m n D W hW A hAn - · refine mul_le_mul_of_nonneg_left ?_ (by positivity) - exact_mod_cast card_grids_le m n D - nlinarith [hchain, (by positivity : (0 : ℝ) ≤ (D : ℝ) * m), - (by exact_mod_cast hm : (0 : ℝ) < m)] - -lemma exists_containedProgression_of_dense_indices (k : ℕ) (hk : 3 ≤ k) - (δ : ℝ) (hδ : 0 < δ) (m n : ℕ) (hm : densityTheoremBound k δ ≤ m) - (A : Finset ℕ) (hAn : A ⊆ range n) (p : ℕ × ℕ) (hp : p.2 ≠ 0) - (hdense : δ * m ≤ #(indicesIn m A p)) : - ∃ q ∈ containedProgressions k n A, - ∃ P : ArithmeticProgression ℕ k, - P.start < m ∧ P.diff < m ∧ - q = (p.1 + P.start * p.2, P.diff * p.2) := by - obtain ⟨P, hP⟩ := exists_of_density_nat k hk δ hδ m hm (indicesIn m A p) - (by simp [indicesIn]) hdense - have hPzero := hP ⟨0, by omega⟩ - have hPone := hP ⟨1, by omega⟩ - change P.term ⟨0, by omega⟩ ∈ indicesIn m A p at hPzero - change P.term ⟨1, by omega⟩ ∈ indicesIn m A p at hPone - rw [indicesIn, Finset.mem_filter] at hPzero hPone - refine ⟨(p.1 + P.start * p.2, P.diff * p.2), ?_, P, ?_, ?_, rfl⟩ - · rw [containedProgressions, Finset.mem_filter, Finset.mem_product] - refine ⟨⟨Finset.mem_range.mpr ?_, Finset.mem_range.mpr ?_⟩, ?_, ?_⟩ - · unfold ArithmeticProgression.term at hPzero - simpa only [Nat.zero_eq, zero_nsmul, Nat.add_zero] using - Finset.mem_range.mp (hAn hPzero.2) - · unfold ArithmeticProgression.term at hPone - rw [one_nsmul] at hPone - have := Finset.mem_range.mp (hAn hPone.2) - exact lt_of_le_of_lt - (Nat.mul_le_mul_right p.2 (Nat.le_add_left P.diff P.start)) - ((Nat.le_add_left _ p.1).trans_lt this) - · exact mul_ne_zero P.diff_ne_zero hp - · intro i - have hi := hP i - change P.term i ∈ indicesIn m A p at hi - rw [indicesIn, Finset.mem_filter] at hi - unfold ArithmeticProgression.term at hi - rw [nsmul_eq_mul] at hi - change P.start + i.val * P.diff ∈ range m ∧ - p.1 + (P.start + i.val * P.diff) * p.2 ∈ A at hi - change p.1 + P.start * p.2 + i.val * (P.diff * p.2) ∈ A - ring_nf at hi ⊢ - exact hi.2 - · unfold ArithmeticProgression.term at hPzero - simpa only [Nat.zero_eq, zero_nsmul, Nat.add_zero] using - Finset.mem_range.mp hPzero.1 - · unfold ArithmeticProgression.term at hPone - rw [one_nsmul] at hPone - have := Finset.mem_range.mp hPone.1 + have hm' : (0 : ℝ) < m := mod_cast hm + have hcard : (#A : ℝ) ≤ #(A ∩ Icc W (n - W)) + 2 * W := + mod_cast card_le_card_inter_Icc_add W hAn + have h : (δ * n - 2 * W) * D * m ≤ + δ / 2 * m * (n * D) + m * #(denseGrids (δ / 2) m n D A) := + calc (δ * n - 2 * W) * D * m + ≤ #(A ∩ Icc W (n - W)) * D * m := by + gcongr + linarith + _ ≤ #(gridIncidences m n D A) := mod_cast le_card_gridIncidences hW hAn + _ ≤ δ / 2 * m * #(grids m n D) + m * #(denseGrids (δ / 2) m n D A) := + card_gridIncidences_le (half_pos hδ).le m n D A + _ ≤ δ / 2 * m * (n * D) + m * #(denseGrids (δ / 2) m n D A) := by + gcongr + exact mod_cast card_grids_le m n D + refine le_of_mul_le_mul_left ?_ hm' + nlinarith [mul_nonneg (mul_nonneg (Nat.cast_nonneg (α := ℝ) D) hm'.le) (sub_nonneg.2 hWn)] + +/-- A progression among the indices at which a dense grid meets `A` gives a progression in +`A`. -/ +lemma exists_mem_containedProgressions {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} {m n D : ℕ} + (hS : ∀ B : Finset ℕ, B ⊆ range m → δ * m ≤ #B → + ∃ P : ArithmeticProgression ℕ k, P.IsSubset B) + {A : Finset ℕ} (hAn : A ⊆ range n) {a d : ℕ} (hp : (a, d) ∈ denseGrids δ m n D A) : + ∃ P : ArithmeticProgression ℕ k, P.start < m ∧ P.diff < m ∧ + (a + P.start * d, P.diff * d) ∈ containedProgressions k n A := by + simp only [denseGrids, grids, mem_filter, mem_product, mem_Icc] at hp + obtain ⟨⟨⟨-, hd, -⟩, -⟩, hdense⟩ := hp + obtain ⟨P, hP⟩ := hS (indicesIn m A (a, d)) (filter_subset _ _) hdense + have h (i : Fin k) : P.start + i * P.diff < m ∧ a + (P.start + i * P.diff) * d ∈ A := by + simpa [indicesIn, term] using hP i + have h₀ := h ⟨0, by omega⟩ + have h₁ := h ⟨1, by omega⟩ + simp only [zero_mul, add_zero, one_mul] at h₀ h₁ + refine ⟨P, h₀.1, by omega, ?_⟩ + simp only [containedProgressions, mem_filter, mem_product, mem_range] + refine ⟨⟨mem_range.1 (hAn h₀.2), ?_⟩, mul_ne_zero P.diff_ne_zero (by omega), ?_⟩ + · have := mem_range.1 (hAn h₁.2) + rw [add_mul] at this omega - -lemma denseGrids_card_le_containedProgressions_mul (k : ℕ) (hk : 3 ≤ k) - (δ : ℝ) (hδ : 0 < δ) (m n D : ℕ) (hm : densityTheoremBound k δ ≤ m) - (A : Finset ℕ) (hAn : A ⊆ range n) : + · intro i + convert (h i).2 using 1 + ring + +/-- A pair is the image of at most `m ^ 2` pairs `(a, d)` under +`(a, d) ↦ (a + (P a d).start * d, (P a d).diff * d)`, when the first terms and the differences of +the progressions `P a d` are below `m`. -/ +private lemma card_filter_eq_le {k m : ℕ} {S : Finset (ℕ × ℕ)} + {P : ℕ → ℕ → ArithmeticProgression ℕ k} {f : ℕ × ℕ → ℕ × ℕ} + (hf : ∀ a d, f (a, d) = (a + (P a d).start * d, (P a d).diff * d)) + (hP : ∀ a d, (a, d) ∈ S → (P a d).start < m ∧ (P a d).diff < m) (y : ℕ × ℕ) : + #(S.filter fun p ↦ f p = y) ≤ m ^ 2 := by + refine (card_le_card_of_injOn (t := range m ×ˢ range m) + (fun (a, d) ↦ ((P a d).start, (P a d).diff)) ?_ ?_).trans_eq (by simp [sq]) + · rintro ⟨a, d⟩ hp + obtain ⟨hstart, hdiff⟩ := hP a d (mem_filter.1 hp).1 + simp [hstart, hdiff] + · rintro ⟨a, d⟩ hp ⟨a', d'⟩ hr h + simp only [mem_coe, mem_filter, hf] at hp hr + obtain ⟨hstart, hdiff⟩ := Prod.mk.inj h + obtain ⟨ha, hd⟩ := Prod.mk.inj (hp.2.trans hr.2.symm) + rw [hstart] at ha + rw [hdiff] at hd + obtain rfl : d = d' := + Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero (P a' d').diff_ne_zero) hd + rw [Nat.add_right_cancel ha] + +/-- Each dense grid contains a progression, and a progression lies on at most `m ^ 2` grids. -/ +lemma card_denseGrids_le {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} {m n : ℕ} (D : ℕ) + (hS : ∀ B : Finset ℕ, B ⊆ range m → δ * m ≤ #B → + ∃ P : ArithmeticProgression ℕ k, P.IsSubset B) + {A : Finset ℕ} (hAn : A ⊆ range n) : #(denseGrids δ m n D A) ≤ #(containedProgressions k n A) * m ^ 2 := by - classical - let S := denseGrids δ m n D A - have hex (p : ↥S) : - ∃ q ∈ containedProgressions k n A, - ∃ P : ArithmeticProgression ℕ k, - P.start < m ∧ P.diff < m ∧ - q = (p.1.1 + P.start * p.1.2, P.diff * p.1.2) := by - have hp := p.2 - dsimp only [S] at hp - change p.1 ∈ (grids m n D).filter - (fun r ↦ δ * m ≤ #(indicesIn m A r)) at hp - rw [Finset.mem_filter] at hp - refine exists_containedProgression_of_dense_indices k hk δ hδ m n hm A hAn p.1 ?_ hp.2 - rw [grids, Finset.mem_filter, Finset.mem_product] at hp - exact ne_of_gt (Finset.mem_Icc.mp hp.1.1.2).1 - choose q hq P hP using hex - have hfiber (y : ℕ × ℕ) : - #{p ∈ (Finset.univ : Finset ↥S) | q p = y} ≤ m ^ 2 := by - rw [pow_two, ← Finset.card_range (n := m), ← Finset.card_product] - apply Finset.card_le_card_of_injOn (fun p ↦ ((P p).start, (P p).diff)) - · intro p hp - change ((P p).start, (P p).diff) ∈ range m ×ˢ range m - rw [Finset.mem_product, Finset.mem_range, Finset.mem_range] - exact ⟨(hP p).1, (hP p).2.1⟩ - · intro p hp r hr hpr - change p ∈ (Finset.univ : Finset ↥S).filter (fun p ↦ q p = y) at hp - change r ∈ (Finset.univ : Finset ↥S).filter (fun p ↦ q p = y) at hr - rw [Finset.mem_filter] at hp hr - have hprstart : (P p).start = (P r).start := by simpa using congrArg Prod.fst hpr - have hprdiff : (P p).diff = (P r).diff := by simpa using congrArg Prod.snd hpr - have hqeq : q p = q r := hp.2.trans hr.2.symm - rw [(hP p).2.2, (hP r).2.2, hprstart, hprdiff] at hqeq - have hdiff : p.1.2 = r.1.2 := - Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero (P r).diff_ne_zero) (congrArg Prod.snd hqeq) - refine Subtype.ext (Prod.ext ?_ hdiff) - have hqstart := congrArg Prod.fst hqeq - rw [hdiff] at hqstart - exact Nat.add_right_cancel hqstart - calc - #S = ∑ y ∈ (Finset.univ.image q), - #{p ∈ (Finset.univ : Finset ↥S) | q p = y} := by - rw [← Finset.card_eq_sum_card_image] - simp - _ ≤ ∑ _y ∈ (Finset.univ.image q), m ^ 2 := Finset.sum_le_sum fun y _ ↦ hfiber y - _ = #(Finset.univ.image q) * m ^ 2 := by simp - _ ≤ #(containedProgressions k n A) * m ^ 2 := by - refine Nat.mul_le_mul_right _ (Finset.card_le_card ?_) - intro y hy - obtain ⟨p, _, rfl⟩ := Finset.mem_image.mp hy - exact hq p - -/-- The positive proportion of progressions supplied by Varnavides' argument. -/ -noncomputable def supersaturationConstant (k : ℕ) (δ : ℝ) : ℝ := - let m := densityTheoremBound k (δ / 2) + 1 - let C := ⌈16 * (m : ℝ) / δ⌉₊ - δ / (8 * C * m ^ 2) - -/-- A threshold above which Varnavides' quadratic progression count holds. -/ -noncomputable def supersaturationBound (k : ℕ) (δ : ℝ) : ℕ := - let m := densityTheoremBound k (δ / 2) + 1 - 2 * ⌈16 * (m : ℝ) / δ⌉₊ - -/-- Varnavides' supersaturation consequence of Szemerédi's theorem: a dense subset of -`range n` contains a positive proportion of all pairs parametrizing `k`-term arithmetic -progressions. -/ -theorem exists_many_of_density_nat (k : ℕ) (hk : 3 ≤ k) (δ : ℝ) (hδ : 0 < δ) - (n : ℕ) (hn : supersaturationBound k δ ≤ n) (A : Finset ℕ) - (hAn : A ⊆ range n) (hA : δ * n ≤ #A) : - supersaturationConstant k δ * n ^ 2 ≤ #(containedProgressions k n A) := by - let m := densityTheoremBound k (δ / 2) + 1 - let C := ⌈16 * (m : ℝ) / δ⌉₊ - change 2 * C ≤ n at hn - change δ / (8 * C * m ^ 2) * n ^ 2 ≤ #(containedProgressions k n A) - let D := n / C - let W := m * D - have hm : 0 < m := by simp [m] - have hC : 0 < C := Nat.one_le_ceil_iff.mpr (by positivity) - have hCn : C ≤ n := by omega - have hD : 0 < D := Nat.div_pos hCn hC - have hCD : C * D ≤ n := by - simpa only [D, Nat.mul_comm] using Nat.div_mul_le_self n C - have hCbound : (16 : ℝ) * m ≤ δ * C := by - have hceil : (16 : ℝ) * m / δ ≤ C := by - simpa only [C] using Nat.le_ceil (16 * (m : ℝ) / δ) - linarith [(div_le_iff₀ hδ).mp hceil] - have hWsmall : (8 : ℝ) * W ≤ δ * n := by - dsimp only [W] - push_cast - nlinarith [mul_le_mul_of_nonneg_right hCbound (Nat.cast_nonneg (α := ℝ) D), - mul_le_mul_of_nonneg_left (by exact_mod_cast hCD : (C : ℝ) * D ≤ n) hδ.le, - Nat.cast_nonneg (α := ℝ) (m * D)] - have hgood := denseGrids_card_lower_bound δ hδ m n D W hm (by simp [W]) - hWsmall A hAn hA - have hmany := denseGrids_card_le_containedProgressions_mul k hk (δ / 2) - (by positivity) m n D (by simp [m]) A hAn - have hAPreal : δ / 4 * n * D ≤ (#(containedProgressions k n A) : ℝ) * m ^ 2 := - hgood.trans (by exact_mod_cast hmany) - have hnCD : (n : ℝ) ≤ 2 * C * D := by - have hnle : n ≤ C * (D + 1) := by - have : C * D + n % C = n := Nat.div_add_mod n C - have := Nat.mod_lt n hC - rw [Nat.mul_add, Nat.mul_one] - omega - nlinarith [(by exact_mod_cast hnle : (n : ℝ) ≤ C * (D + 1)), - (by exact_mod_cast hD : (1 : ℝ) ≤ D), Nat.cast_nonneg (α := ℝ) C] - rw [div_mul_eq_mul_div, div_le_iff₀ (by positivity)] - linarith [mul_le_mul_of_nonneg_left hAPreal (by positivity : (0 : ℝ) ≤ 8 * (C : ℝ)), - mul_le_mul_of_nonneg_left hnCD (mul_nonneg hδ.le (Nat.cast_nonneg (α := ℝ) n))] + have : Nonempty (ArithmeticProgression ℕ k) := ⟨⟨0, 1, one_ne_zero⟩⟩ + choose! P hP using fun a d ↦ + exists_mem_containedProgressions (a := a) (d := d) (D := D) hk hS hAn + let f : ℕ × ℕ → ℕ × ℕ := fun (a, d) ↦ (a + (P a d).start * d, (P a d).diff * d) + calc #(denseGrids δ m n D A) + ≤ m ^ 2 * #((denseGrids δ m n D A).image f) := + card_le_mul_card_image _ _ fun y _ ↦ + card_filter_eq_le (fun _ _ ↦ rfl) (fun a d hp ↦ ⟨(hP a d hp).1, (hP a d hp).2.1⟩) y + _ ≤ m ^ 2 * #(containedProgressions k n A) := by + gcongr + exact image_subset_iff.2 fun (a, d) hp ↦ (hP a d hp).2.2 + _ = #(containedProgressions k n A) * m ^ 2 := mul_comm _ _ + +/-- Varnavides' averaging argument over grids of difference at most `D`: if every subset of +`range m` with at least `δ / 2 * m` elements contains an arithmetic progression of length `k` +and `8 * (m * D) ≤ δ * n`, then a subset of `range n` with at least `δ * n` elements contains at +least `δ / 4 * n * D / m ^ 2` such progressions. -/ +lemma le_card_containedProgressions_mul {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) {m n D : ℕ} + (hm : 0 < m) + (hS : ∀ B : Finset ℕ, B ⊆ range m → δ / 2 * m ≤ #B → + ∃ P : ArithmeticProgression ℕ k, P.IsSubset B) + (hD : 8 * ((m * D : ℕ) : ℝ) ≤ δ * n) {A : Finset ℕ} (hAn : A ⊆ range n) (hA : δ * n ≤ #A) : + δ / 4 * n * D ≤ #(containedProgressions k n A) * m ^ 2 := + (le_card_denseGrids hδ hm le_rfl hD hAn hA).trans (mod_cast card_denseGrids_le hk D hS hAn) + +private lemma exists_mul_le_lt {C n : ℕ} (hC : 0 < C) (hn : C ≤ n) : + ∃ D : ℕ, (1 : ℝ) ≤ D ∧ (C : ℝ) * D ≤ n ∧ (n : ℝ) < C * (D + 1) := + ⟨n / C, mod_cast Nat.div_pos hn hC, mod_cast Nat.mul_div_le n C, + mod_cast Nat.lt_mul_div_succ n hC⟩ + +/-- Varnavides' averaging argument: if every subset of `range m` with at least `δ / 2 * m` +elements contains an arithmetic progression of length `k`, and `N` is a natural bound for +`1 / δ`, then for `n ≥ T ≥ 128 * m ^ 3 * N ^ 2` a subset of `range n` with at least `δ * n` +elements contains at least `n ^ 2 / T` such progressions. -/ +theorem sq_div_le_card_containedProgressions {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) {m : ℕ} + (hm : 0 < m) + (hS : ∀ B : Finset ℕ, B ⊆ range m → δ / 2 * m ≤ #B → + ∃ P : ArithmeticProgression ℕ k, P.IsSubset B) + {N : ℕ} (hN : 1 / δ ≤ N) {T n : ℕ} (hT : 128 * m ^ 3 * N ^ 2 ≤ T) (hn : T ≤ n) + (A : Finset ℕ) (hAn : A ⊆ range n) (hA : δ * n ≤ #A) : + (n : ℝ) ^ 2 / T ≤ #(containedProgressions k n A) := by + have hδN : 1 ≤ δ * N := by rwa [div_le_iff₀' hδ] at hN + have hN₀ : 0 < N := by exact_mod_cast (one_div_pos.2 hδ).trans_le hN + have hCT : 16 * m * N ≤ 128 * m ^ 3 * N ^ 2 := + calc 16 * m * N = 16 * (m * N) := by ring + _ ≤ 128 * (m ^ 3 * N ^ 2) := Nat.mul_le_mul (by norm_num) + (Nat.mul_le_mul (Nat.le_self_pow three_ne_zero m) (Nat.le_self_pow two_ne_zero N)) + _ = 128 * m ^ 3 * N ^ 2 := by ring + obtain ⟨D, hD, hCD, hnCD⟩ := + exists_mul_le_lt (C := 16 * m * N) (by positivity) (hCT.trans (hT.trans hn)) + push_cast at hCD hnCD + have h := le_card_containedProgressions_mul hk hδ hm hS (D := D) (by push_cast; nlinarith) + hAn hA + rw [div_le_iff₀ (by exact_mod_cast (by positivity : 0 < 128 * m ^ 3 * N ^ 2).trans_le hT)] + calc (n : ℝ) ^ 2 ≤ n * (2 * (16 * m * N) * D) := by + rw [sq] + gcongr + nlinarith [mul_le_mul_of_nonneg_left hD (by positivity : (0 : ℝ) ≤ 16 * m * N)] + _ ≤ n * (2 * (16 * m * N) * D) * (δ * N) := le_mul_of_one_le_right (by positivity) hδN + _ = δ / 4 * n * D * (128 * m * N ^ 2) := by ring + _ ≤ #(containedProgressions k n A) * m ^ 2 * (128 * m * N ^ 2) := by gcongr + _ = #(containedProgressions k n A) * ((128 * m ^ 3 * N ^ 2 : ℕ) : ℝ) := by push_cast; ring + _ ≤ #(containedProgressions k n A) * T := by gcongr end Combinatorics.ArithmeticProgression diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean index e207f218b6..4035a1ec3f 100644 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean @@ -6,18 +6,18 @@ Authors: Gabriel Dahia module public import Mathlib.Algebra.BigOperators.Expect -public import Mathlib.Algebra.Order.BigOperators.Expect -public import Mathlib.Combinatorics.HalesJewett -public import Mathlib.Data.Finset.Density public import Mathlib.Basic.Real.Basic -import Mathlib.Tactic.Linarith -import Mathlib.Tactic.Ring +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Tactic.Linarith.Frontend +import Mathlib.Tactic.NormNum.Abs +import Mathlib.Tactic.NormNum.DivMod +import Mathlib.Tactic.NormNum.OfScientific /-! # Finite word spaces Uniform density, fibers, and elementary averaging results used in the density Hales--Jewett -argument. We use `Finset.dens` for uniform density, `Sum.elim` to concatenate words on disjoint +argument. We use `Finset.dens` for uniform density, `Sum.elim` to concatenate words on disjoint coordinate types, and `Equiv.sumArrowEquivProdArrow` for the underlying decomposition of a word on a sum of coordinate types. -/ @@ -29,11 +29,11 @@ open scoped BigOperators namespace DensityHalesJewett -/-- The fiber of a word family above a fixed prefix. Words on a sum of coordinate types are +/-- The fiber of a word family above a fixed prefix. Words on a sum of coordinate types are concatenations `Sum.elim x y` of their two parts. -/ def fiber {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] (A : Finset (ι ⊕ κ → α)) (x : ι → α) : Finset (κ → α) := - Finset.univ.filter fun y ↦ Sum.elim x y ∈ A + univ.filter fun y ↦ Sum.elim x y ∈ A @[simp] lemma mem_fiber {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] @@ -47,34 +47,34 @@ lemma average_density_fiber {α ι κ : Type*} [Fintype (ι → α)] [Fintype ( (A : Finset (ι ⊕ κ → α)) : (𝔼 x : ι → α, ((fiber A x).dens : ℝ)) = (A.dens : ℝ) := by classical - simp_rw [← Finset.expect_indicator_one] - rw [← Finset.expect_product'] - apply Finset.expect_equiv (Equiv.sumArrowEquivProdArrow ι κ α).symm + simp_rw [← expect_indicator_one] + rw [← expect_product'] + apply expect_equiv (Equiv.sumArrowEquivProdArrow ι κ α).symm · simp · rintro ⟨x, y⟩ - simp [Set.indicator_apply, Equiv.sumArrowEquivProdArrow] -/-- A bounded function with large average exceeds a lower threshold on a quantitatively large -set. -/ +/-- A function bounded above by one with average at least `a` is at least `b < a` on a set of +density at least `(a - b) / (1 - b)`. -/ lemma density_ge_threshold {X : Type*} [Fintype X] [Nonempty X] - (f : X → ℝ) (a b : ℝ) (hf₁ : ∀ x, f x ≤ 1) + {f : X → ℝ} {a b : ℝ} (hf₁ : ∀ x, f x ≤ 1) (hba : b < a) (havg : a ≤ 𝔼 x : X, f x) : (a - b) / (1 - b) ≤ - ((Finset.univ.filter fun x ↦ b ≤ f x).dens : ℝ) := by + ((univ.filter fun x ↦ b ≤ f x).dens : ℝ) := by classical - let H := Finset.univ.filter fun x ↦ b ≤ f x + let H := univ.filter fun x ↦ b ≤ f x change (a - b) / (1 - b) ≤ (H.dens : ℝ) have h1b : 0 < 1 - b := by rw [sub_pos] exact hba.trans_le <| havg.trans <| - Finset.expect_le Finset.univ_nonempty fun x _ ↦ hf₁ x + expect_le univ_nonempty fun x _ ↦ hf₁ x rw [div_le_iff₀ h1b, sub_le_iff_le_add] apply havg.trans - convert Finset.expect_le_expect (s := Finset.univ) (f := f) + convert expect_le_expect (s := univ) (f := f) (g := fun x ↦ b + (1 - b) * Set.indicator (H : Set X) 1 x) ?_ using 1 · symm - rw [Finset.expect_add_distrib] - simp only [Fintype.expect_const, ← Finset.mul_expect, Finset.expect_indicator_one] + rw [expect_add_distrib] + simp only [Fintype.expect_const, ← mul_expect, expect_indicator_one] ring · intro x _ by_cases hx : b ≤ f x <;> simp [H, hx] <;> linarith [hf₁ x] diff --git a/LeanPool/DensityHalesJewett/Imports.lean b/LeanPool/DensityHalesJewett/Imports.lean index 33d6ab318d..52a18dbf6f 100644 --- a/LeanPool/DensityHalesJewett/Imports.lean +++ b/LeanPool/DensityHalesJewett/Imports.lean @@ -8,6 +8,7 @@ module -- shake: keep-all --deprecated_module: ignore -- Generated project imports; run `lake exe mk_all`. public import LeanPool.DensityHalesJewett public import LeanPool.DensityHalesJewett.DensityHalesJewett +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Ackermann public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers @@ -15,6 +16,8 @@ public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Pa public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.DensityHalesJewett.HalesJewett +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Induction public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace diff --git a/LeanPool/DensityHalesJewett/Solution.lean b/LeanPool/DensityHalesJewett/Solution.lean index 663dd60f40..6e469c078d 100644 --- a/LeanPool/DensityHalesJewett/Solution.lean +++ b/LeanPool/DensityHalesJewett/Solution.lean @@ -5,7 +5,8 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main +public import Mathlib.Order.Filter.AtTopBot.Basic /-! # Proofs of the asymptotic forms of the density theorems @@ -34,9 +35,9 @@ over `α` contains a combinatorial line. -/ theorem exists_of_density_atTop (α : Type*) [Fintype α] (δ : ℝ) (hδ : 0 < δ) : ∀ᶠ n in atTop, ∀ A : Finset (Fin n → α), δ * (Fintype.card α : ℝ) ^ n ≤ #A → ∃ l : Line α (Fin n), ∀ x : α, l x ∈ A := by - refine eventually_atTop.2 ⟨densityTheoremBound (Fintype.card α) δ, ?_⟩ + refine eventually_atTop.2 ⟨ack (4 * Fintype.card α) (Fintype.card α + ⌈1 / δ⌉₊), ?_⟩ intro n hn A hAδ - exact exists_of_density α δ hδ n hn A hAδ + exact exists_of_density hδ hn A hAδ end Combinatorics.Line @@ -48,9 +49,9 @@ of length `k`, i.e. `k` terms `a, a + d, a + 2 * d, …` with `d ≠ 0`. -/ theorem exists_of_density_nat_atTop (k : ℕ) (hk : 3 ≤ k) (δ : ℝ) (hδ : 0 < δ) : ∀ᶠ n in atTop, ∀ A : Finset ℕ, A ⊆ range n → δ * n ≤ #A → ∃ a d : ℕ, d ≠ 0 ∧ ∀ i : Fin k, a + i * d ∈ A := by - refine eventually_atTop.2 ⟨densityTheoremBound k δ, ?_⟩ + refine eventually_atTop.2 ⟨ack (4 * k + 1) (k + ⌈1 / δ⌉₊), ?_⟩ intro n hn A hAn hAδ - obtain ⟨P, hP⟩ := exists_of_density_nat k hk δ hδ n hn A hAn hAδ + obtain ⟨P, hP⟩ := exists_of_density_nat hk hδ hn A hAn hAδ refine ⟨P.start, P.diff, P.diff_ne_zero, ?_⟩ intro i simpa [term, nsmul_eq_mul] using hP i diff --git a/LeanPool/ShelahHalesJewett.lean b/LeanPool/ShelahHalesJewett.lean new file mode 100644 index 0000000000..7340e76847 --- /dev/null +++ b/LeanPool/ShelahHalesJewett.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import LeanPool.ShelahHalesJewett.Ackermann + +/-! +# Shelah's bound for the Hales–Jewett numbers + +Source: doi:10.1090/S0894-0347-1988-0929498-X, url:https://github.com/gdahia/ShelahHalesJewett/tree/8a91fc0e8a9617f8ade16ccb3b56e543990c9f45 +Authors: Gabriel Dahia +Status: verified +Main declarations: `Combinatorics.Line.exists_mono_of_shelahBound_le`, + `Combinatorics.Line.shelahBound_lt_ack`, `Combinatorics.Line.exists_mono_of_ack_le` +Tags: combinatorics, ramsey-theory, hales-jewett, ackermann-function +MSC: 05D10, 03D20 +-/ + +/-! +## Upstream attribution + +Adapted for Lean Pool from upstream commit `8a91fc0e8a9617f8ade16ccb3b56e543990c9f45` by +moving the library under `LeanPool.ShelahHalesJewett`. The upstream Palomar `Challenge` and +`Solution` modules are omitted: `Solution` only restates +`Combinatorics.Line.exists_mono_of_ack_le` for words indexed by `Fin n` under a primed name. +-/ diff --git a/LeanPool/ShelahHalesJewett/Ackermann.lean b/LeanPool/ShelahHalesJewett/Ackermann.lean new file mode 100644 index 0000000000..6e15a35381 --- /dev/null +++ b/LeanPool/ShelahHalesJewett/Ackermann.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import Mathlib.Computability.Ackermann +public import LeanPool.ShelahHalesJewett.HalesJewett + +/-! +# Shelah's bound is below the fifth level of the Ackermann function + +The recursion `Combinatorics.Subspace.insensitiveBound` replaces `r` colors by `r ^ k` colors, so +after `j` steps the number of colors is `r ^ k ^ j`. Each step adds a term that is doubly +exponential in the earlier ones, so `insensitiveBound k n r` is at most `ack 4` at a linear +function of `n`. Shelah's bound applies `insensitiveBound` once for each letter, so it is below +`ack 5` at a linear function of the number of letters and of colors. + +## Main results + +* `Combinatorics.Subspace.insensitiveBound_le_ack`: + `insensitiveBound k n r ≤ ack 4 (5 * n + k + r + 2)`. +* `Combinatorics.Line.shelahBound_lt_ack`: `shelahBound k r < ack 5 (2 * k + r)`. +* `Combinatorics.Line.exists_mono_of_ack_le`: the Hales--Jewett theorem in every dimension at + least `ack 5 (2 * k + r)`, for `k` letters and `r` colors. +-/ + +@[expose] public section + +namespace Combinatorics + +private lemma pow_le_two_pow_ack_three {b x : ℕ} (hx : b ≤ x) : b ^ x ≤ 2 ^ ack 3 x := by + apply (Nat.pow_le_pow_left (hx.trans Nat.lt_two_pow_self.le) x).trans + rw [← pow_mul, ← sq] + apply Nat.pow_le_pow_right two_pos + exact (Nat.pow_le_pow_left (by grind [ack_zero]) 2).trans (ack_add_one_sq_lt_ack_add_three 0 x) + +private lemma add_pow_le_ack_three {b x : ℕ} (hx : b ≤ x) : x + b ^ x ≤ ack 3 (ack 3 x) := by + grind [pow_le_two_pow_ack_three hx, ack_three (ack 3 x), Nat.lt_two_pow_self (n := ack 3 x), + lt_ack_right 3 x] + +private lemma add_pow_pow_le_ack_four {b m : ℕ} (hb : 2 ≤ b) (hm : b ≤ ack 4 m) : + ack 4 m + b ^ b ^ ack 4 m ≤ ack 4 (m + 4) := by + rw [ack_succ_succ, ack_succ_succ, ack_succ_succ, ack_succ_succ] + apply (ack_mono_right 3 (ack_mono_right 3 (add_pow_le_ack_three hm))).trans' + apply (add_pow_le_ack_three (b := b) (x := ack 4 m + b ^ ack 4 m) (by grind)).trans' + gcongr ?_ + b ^ ?_ <;> grind + +namespace Subspace + +private lemma insensitiveBound_pow_add_le_ack (k r i j : ℕ) : + insensitiveBound k i (r ^ k ^ j) + j + i ≤ ack 4 (5 * i + j + k + r + 2) := by + induction i generalizing j with + | zero => grind [insensitiveBound, lt_ack_right 4 (5 * 0 + j + k + r + 2)] + | succ i ih => + rw [insensitiveBound, ← pow_mul r, ← pow_succ, ← pow_mul, ← pow_add, + (by grind : 5 * (i + 1) + j + k + r + 2 = 5 * i + (j + 1) + k + r + 2 + 4)] + have h : r ^ k ^ (j + insensitiveBound k i (r ^ k ^ (j + 1))) ≤ + (k + r + 2) ^ (k + r + 2) ^ ack 4 (5 * i + (j + 1) + k + r + 2) := by + gcongr <;> grind + grind [add_pow_pow_le_ack_four (b := k + r + 2) (m := 5 * i + (j + 1) + k + r + 2) (by grind) + (by grind [lt_ack_right 4 (5 * i + (j + 1) + k + r + 2)])] + +/-- The dimension `insensitiveBound k n r` is at most the fourth level of the Ackermann function +at a linear function of `n`. -/ +theorem insensitiveBound_le_ack (k n r : ℕ) : + insensitiveBound k n r ≤ ack 4 (5 * n + k + r + 2) := by + grind [insensitiveBound_pow_add_le_ack k r n 0] + +end Subspace + +namespace Line + +private lemma shelahBound_succ_le_ack (j r : ℕ) : shelahBound (j + 1) r ≤ ack 5 (2 * j + r) := by + induction j with + | zero => grind [shelahBound, ack_pos 5 r] + | succ j ih => + rw [shelahBound, (by grind : 2 * (j + 1) + r = 2 * j + r + 1 + 1), ack_succ_succ, + ack_succ_succ] + apply (Subspace.insensitiveBound_le_ack _ _ _).trans + apply ack_mono_right 4 + grind [add_lt_ack 5 (2 * j + r), ack_three (ack 5 (2 * j + r)), + Nat.lt_two_pow_self (n := ack 5 (2 * j + r)), + ack_le_ack (by grind : 3 ≤ 4) (le_refl (ack 5 (2 * j + r)))] + +/-- Shelah's bound is below the fifth level of the Ackermann function. -/ +theorem shelahBound_lt_ack (k r : ℕ) : shelahBound k r < ack 5 (2 * k + r) := by + rcases k with _ | j + · grind [shelahBound, one_lt_ack_succ_left 4 r] + · exact (shelahBound_succ_le_ack j r).trans_lt (ack_strictMono_right 5 (by grind)) + +variable {α κ ι : Type*} [Fintype α] [Fintype κ] [Fintype ι] + +/-- The **Hales--Jewett theorem** with the Ackermann function as the bound: over a nonempty +alphabet `α`, every coloring of the words indexed by `ι` has a monochromatic line if `card ι` is +at least `ack 5 (2 * card α + card κ)`. -/ +theorem exists_mono_of_ack_le [Nonempty α] + (h : ack 5 (2 * Fintype.card α + Fintype.card κ) ≤ Fintype.card ι) (C : (ι → α) → κ) : + ∃ l : Line α ι, l.IsMono C := + exists_mono_of_shelahBound_le ((shelahBound_lt_ack _ _).le.trans h) C + +end Line + +end Combinatorics diff --git a/LeanPool/ShelahHalesJewett/HalesJewett.lean b/LeanPool/ShelahHalesJewett/HalesJewett.lean new file mode 100644 index 0000000000..6bd1388b09 --- /dev/null +++ b/LeanPool/ShelahHalesJewett/HalesJewett.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import Mathlib.Combinatorics.HalesJewett +public import Mathlib.SetTheory.Cardinal.Finite +import Mathlib.SetTheory.Cardinal.NatCard +import LeanPool.ShelahHalesJewett.Line + +/-! +# Shelah's bound for the Hales--Jewett numbers + +Shelah's proof of the Hales--Jewett theorem, by induction on the alphabet. + +To pass from `α` to `Option α`, fix a letter `a₀` of `α`. +`Combinatorics.Subspace.exists_insensitive` gives a subspace on which the color of a word does not +change when a `none` is replaced by `some a₀`. On this subspace the coloring is determined by the +words over `α`, so a monochromatic line over `α` in its parameter cube is also monochromatic at +`none`. + +The subspace is built dimension by dimension. Each dimension is a line in a block of new +coordinates, given by `Combinatorics.Line.exists_map_eq_of_card_le`, whose points at the two +letters have the same color for every choice of the other coordinates. + +## Main definitions + +* `Combinatorics.Subspace.insensitiveBound`: the dimension of the cube in + `Combinatorics.Subspace.exists_insensitive`. +* `Combinatorics.Line.shelahBound`: Shelah's bound for the Hales--Jewett numbers. + +## Main results + +* `Combinatorics.Subspace.exists_insensitive`: in a cube of dimension `insensitiveBound`, every + coloring is insensitive to two given letters on a subspace. +* `Combinatorics.Line.exists_mono_of_card_eq_shelahBound`: the Hales--Jewett theorem in dimension + `shelahBound`. +* `Combinatorics.Line.exists_mono_of_shelahBound_le`: the Hales--Jewett theorem in every dimension + at least `shelahBound`, over a nonempty alphabet. + +## References + +* S. Shelah, *Primitive recursive bounds for van der Waerden numbers*, J. Amer. Math. Soc. 1 + (1988), 683--697. +-/ + +@[expose] public section + +namespace Combinatorics + +namespace Subspace + +/-- A dimension in which every coloring with `r` colors of the words over `k` letters is +insensitive to two given letters on an `n`-dimensional subspace. Each dimension of the subspace +takes a block of as many coordinates as there are colorings of the words on the earlier blocks. -/ +def insensitiveBound (k : ℕ) : ℕ → ℕ → ℕ + | 0, _ => 0 + | n + 1, r => insensitiveBound k n (r ^ k) + r ^ k ^ insensitiveBound k n (r ^ k) + +/-- In a cube of dimension `insensitiveBound`, every coloring is insensitive to the letters `a` +and `b` on some `η`-dimensional subspace: replacing `a` by `b` in any coordinates of a point of +the subspace does not change its color. -/ +theorem exists_insensitive (α : Type) [Finite α] (a b : α) (η : Type) [Finite η] + (κ : Type) [Finite κ] : + ∃ (ι : Type) (_ : Fintype ι), + Fintype.card ι = insensitiveBound (Nat.card α) (Nat.card η) (Nat.card κ) ∧ + ∀ C : (ι → α) → κ, ∃ V : Subspace η α ι, + ∀ x y : η → α, (∀ e, x e = y e ∨ x e = a ∧ y e = b) → C (V x) = C (V y) := by + induction η using Finite.induction_empty_option generalizing κ with + | @of_equiv η η' e ih => + obtain ⟨ι, _, hι, h⟩ := ih κ + refine ⟨ι, ‹_›, Nat.card_congr e ▸ hι, ?_⟩ + intro C + obtain ⟨V, hV⟩ := h C + refine ⟨V.reindex e (.refl α) (.refl ι), ?_⟩ + intro x y hxy + have key (z : η' → α) : V.reindex e (.refl α) (.refl ι) z = V (z ∘ e) := by + ext + simp + rw [key, key] + apply hV + intro e' + exact hxy (e e') + | h_empty => + refine ⟨Empty, inferInstance, by simp [insensitiveBound], ?_⟩ + intro C + refine ⟨⟨fun i ↦ i.elim, fun e ↦ e.elim⟩, ?_⟩ + intro x y _ + rw [Subsingleton.elim x y] + | h_option ih => + obtain ⟨ι, _, hι, h⟩ := ih (α → κ) + refine ⟨ι ⊕ Fin (Nat.card ((ι → α) → κ)), inferInstance, + by simp [insensitiveBound, Nat.card_fun, hι], ?_⟩ + intro C + obtain ⟨l, hl⟩ := Line.exists_map_eq_of_card_le le_rfl a b + fun (u : Fin (Nat.card ((ι → α) → κ)) → α) (w : ι → α) ↦ C (Sum.elim w u) + obtain ⟨V, hV⟩ := h fun w x ↦ C (Sum.elim w (l x)) + refine ⟨V.prodLine l, ?_⟩ + intro x y hxy + rw [prodLine_apply, prodLine_apply] + apply (congrFun (hV (x ∘ some) (y ∘ some) fun e ↦ hxy (some e)) (x none)).trans + grind [congrFun hl (V (y ∘ some))] + +end Subspace + +namespace Line + +/-- Shelah's bound for the Hales--Jewett number of `k` letters and `r` colors: the dimension of a +cube in which every coloring is insensitive to two letters on a subspace whose dimension is the +bound for `k - 1` letters. -/ +def shelahBound : ℕ → ℕ → ℕ + | 0, r => min r 1 + | 1, _ => 1 + | k + 2, r => Subspace.insensitiveBound (k + 2) (shelahBound (k + 1) r) r + +/-- The Hales--Jewett theorem with Shelah's bound, for some index type of cardinality +`shelahBound`. See `exists_mono_of_card_eq_shelahBound`. -/ +private lemma exists_mono_shelahBound' (α : Type) [Finite α] (κ : Type) [Finite κ] : + ∃ (ι : Type) (_ : Fintype ι), Fintype.card ι = shelahBound (Nat.card α) (Nat.card κ) ∧ + ∀ C : (ι → α) → κ, ∃ l : Line α ι, l.IsMono C := by + induction α using Finite.induction_empty_option generalizing κ with + | @of_equiv α α' e ih => + obtain ⟨ι, _, hι, h⟩ := ih κ + refine ⟨ι, ‹_›, Nat.card_congr e ▸ hι, ?_⟩ + intro C + obtain ⟨l, c, hc⟩ := h fun v ↦ C (e ∘ v) + refine ⟨l.map e, c, ?_⟩ + intro x + rw [← e.apply_symm_apply x, map_apply] + exact hc _ + | h_empty => + rcases isEmpty_or_nonempty κ with hκ | hκ + · refine ⟨Empty, inferInstance, by simp [shelahBound], ?_⟩ + intro C + exact isEmptyElim (C isEmptyElim) + · refine ⟨Unit, inferInstance, by simp [shelahBound, Nat.succ_le_iff], ?_⟩ + intro C + exact ⟨default, Classical.arbitrary κ, isEmptyElim⟩ + | @h_option α _ ih => + rcases isEmpty_or_nonempty α with hα | hα + · refine ⟨Unit, inferInstance, by simp [shelahBound], ?_⟩ + intro C + refine ⟨diagonal _ Unit, C (diagonal _ Unit none), ?_⟩ + intro x + rw [Subsingleton.elim x none] + obtain ⟨ι', _, hι', h'⟩ := ih κ + obtain ⟨ι, _, hι, h⟩ := + Subspace.exists_insensitive (Option α) none (some (Classical.arbitrary α)) ι' κ + refine ⟨ι, ‹_›, ?_, ?_⟩ + · obtain ⟨k, hk⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.card_pos (α := α)).ne' + rw [hι, Finite.card_option, hk, shelahBound, Nat.card_eq_fintype_card (α := ι'), hι', hk] + intro C + obtain ⟨V, hV⟩ := h C + obtain ⟨l, c, hc⟩ := h' fun w ↦ C (V (some ∘ w)) + refine ⟨V.compLine (l.map some), c, ?_⟩ + intro x + rw [Subspace.compLine_apply] + have hsome (x' : α) : C (V (l.map some (some x'))) = c := by simpa using hc x' + rcases x with _ | x + · rw [← hsome (Classical.arbitrary α)] + apply hV + intro e + cases he : l.idxFun e <;> simp [map, he] + · exact hsome x + +variable {α κ ι : Type*} [Fintype α] [Fintype κ] [Fintype ι] + +/-- The **Hales--Jewett theorem** with Shelah's bound: every coloring of the words over `α` indexed +by a type of cardinality `shelahBound (card α) (card κ)` has a monochromatic line. -/ +theorem exists_mono_of_card_eq_shelahBound + (h : Fintype.card ι = shelahBound (Fintype.card α) (Fintype.card κ)) (C : (ι → α) → κ) : + ∃ l : Line α ι, l.IsMono C := by + obtain ⟨ι₀, _, hι₀, h₀⟩ := + exists_mono_shelahBound' (Fin (Fintype.card α)) (Fin (Fintype.card κ)) + rw [Nat.card_fin, Nat.card_fin, ← h] at hι₀ + let eα := Fintype.equivFin α + let eκ := Fintype.equivFin κ + let eι := Fintype.equivOfCardEq hι₀ + obtain ⟨l, c, hc⟩ := h₀ fun v ↦ eκ (C (eα.symm ∘ v ∘ eι.symm)) + refine ⟨(l.map eα.symm).reindex eι, eκ.symm c, ?_⟩ + intro x + rw [reindex_apply, ← eα.symm_apply_apply x, map_apply] + exact eκ.eq_symm_apply.2 (hc (eα x)) + +/-- The **Hales--Jewett theorem** with Shelah's bound: over a nonempty alphabet `α`, every coloring +of the words indexed by a type of cardinality at least `shelahBound (card α) (card κ)` has a +monochromatic line. -/ +theorem exists_mono_of_shelahBound_le [Nonempty α] + (h : shelahBound (Fintype.card α) (Fintype.card κ) ≤ Fintype.card ι) (C : (ι → α) → κ) : + ∃ l : Line α ι, l.IsMono C := by + let e : Fin (shelahBound (Fintype.card α) (Fintype.card κ)) ⊕ + Fin (Fintype.card ι - shelahBound (Fintype.card α) (Fintype.card κ)) ≃ ι := + Fintype.equivOfCardEq (by simp [Nat.add_sub_cancel' h]) + let a : α := Classical.arbitrary α + obtain ⟨l, c, hc⟩ := exists_mono_of_card_eq_shelahBound (by simp) + fun v : Fin (shelahBound (Fintype.card α) (Fintype.card κ)) → α ↦ + C (Sum.elim v (fun _ ↦ a) ∘ e.symm) + refine ⟨(l.horizontal fun _ ↦ a).reindex e, c, ?_⟩ + intro x + rw [reindex_apply, horizontal_apply] + exact hc x + +end Line + +end Combinatorics diff --git a/LeanPool/ShelahHalesJewett/Imports.lean b/LeanPool/ShelahHalesJewett/Imports.lean new file mode 100644 index 0000000000..33a982ea09 --- /dev/null +++ b/LeanPool/ShelahHalesJewett/Imports.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Lean Pool contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Lean Pool contributors +-/ +module -- shake: keep-all --deprecated_module: ignore + +-- Generated project imports; run `lake exe mk_all`. +public import LeanPool.ShelahHalesJewett +public import LeanPool.ShelahHalesJewett.Ackermann +public import LeanPool.ShelahHalesJewett.HalesJewett +public import LeanPool.ShelahHalesJewett.Line diff --git a/LeanPool/ShelahHalesJewett/Line.lean b/LeanPool/ShelahHalesJewett/Line.lean new file mode 100644 index 0000000000..f644ee3807 --- /dev/null +++ b/LeanPool/ShelahHalesJewett/Line.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Gabriel Dahia. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Dahia +-/ +module + +public import Mathlib.Combinatorics.HalesJewett +public import Mathlib.SetTheory.Cardinal.Finite +import Mathlib.Data.Fintype.Pigeonhole + +/-! +# Lines and subspaces + +Constructions on Mathlib's `Combinatorics.Line` and `Combinatorics.Subspace` used in Shelah's proof +of the Hales--Jewett theorem. + +## Main definitions + +* `Combinatorics.Line.reindex`: change the index type of a line. +* `Combinatorics.Subspace.prodLine`: the subspace spanned by a subspace and a line on disjoint sets + of coordinates. +* `Combinatorics.Subspace.compLine`: a line of the parameter cube of a subspace, as a line of the + ambient cube. + +## Main results + +* `Combinatorics.Line.exists_map_eq_of_card_le`: in a cube of dimension `N` colored with at most + `N` colors, some line has the same color at two given letters. +-/ + +@[expose] public section + +namespace Combinatorics + +variable {η α ι ι' κ : Type*} + +namespace Line + +/-- Change the index type of a line. -/ +def reindex (l : Line α ι) (e : ι ≃ ι') : Line α ι' where + idxFun := l.idxFun ∘ e.symm + proper := let ⟨i, hi⟩ := l.proper; ⟨e i, by simp [hi]⟩ + +@[simp] +lemma reindex_apply (l : Line α ι) (e : ι ≃ ι') (x : α) : l.reindex e x = l x ∘ e.symm := rfl + +/-- If a cube of dimension `N` is colored with at most `N` colors, then for any two letters `a` and +`b` some line has the same color at `a` and at `b`. + +The `N + 1` words that are `a` on an initial segment of the coordinates and `b` afterwards cannot +have distinct colors. Two of them with the same color are the points at `a` and at `b` of the line +whose wildcards are the coordinates on which they differ. -/ +theorem exists_map_eq_of_card_le [Finite κ] {N : ℕ} (hN : Nat.card κ ≤ N) (a b : α) + (C : (Fin N → α) → κ) : ∃ l : Line α (Fin N), C (l a) = C (l b) := by + cases nonempty_fintype κ + let u (j : Fin (N + 1)) (p : Fin N) : α := if (p : ℕ) < j then a else b + obtain ⟨j, j', hne, h⟩ := Fintype.exists_ne_map_eq_of_card_lt (fun j ↦ C (u j)) + (by simpa [Nat.card_eq_fintype_card] using Nat.lt_succ_of_le hN) + wlog hlt : (j : ℕ) < j' generalizing j j' + · exact this j' j hne.symm h.symm (by grind) + let l : Line α (Fin N) := + ⟨fun p ↦ if (p : ℕ) < j then some a else if (p : ℕ) < j' then none else some b, + ⟨⟨j, by grind⟩, by simp [hlt]⟩⟩ + refine ⟨l, ?_⟩ + convert h.symm using 2 <;> ext p <;> grind [coe_apply] + +end Line + +namespace Subspace + +/-- A subspace of `ι → α` and a line of `ι' → α` span a subspace of `ι ⊕ ι' → α` with one more +dimension, `none`, along the line. -/ +def prodLine (V : Subspace η α ι) (l : Line α ι') : Subspace (Option η) α (ι ⊕ ι') where + idxFun := Sum.elim (fun i ↦ (V.idxFun i).map id some) fun i ↦ (l.idxFun i).elim (.inr none) .inl + proper + | none => let ⟨i, hi⟩ := l.proper; ⟨.inr i, by simp [hi]⟩ + | some e => let ⟨i, hi⟩ := V.proper e; ⟨.inl i, by simp [hi]⟩ + +@[simp] +lemma prodLine_apply (V : Subspace η α ι) (l : Line α ι') (x : Option η → α) : + V.prodLine l x = Sum.elim (V (x ∘ some)) (l (x none)) := by + funext i + cases i with + | inl i => cases h : V.idxFun i <;> simp [prodLine, coe_apply, h] + | inr i => cases h : l.idxFun i <;> simp [prodLine, coe_apply, h] + +/-- A line of the parameter cube of a subspace, as a line of the ambient cube. -/ +def compLine (V : Subspace η α ι) (l : Line α η) : Line α ι where + idxFun i := (V.idxFun i).elim some l.idxFun + proper := let ⟨e, he⟩ := l.proper; let ⟨i, hi⟩ := V.proper e; ⟨i, by simp [hi, he]⟩ + +@[simp] +lemma compLine_apply (V : Subspace η α ι) (l : Line α η) (x : α) : V.compLine l x = V (l x) := by + funext i + cases h : V.idxFun i <;> simp [compLine, coe_apply, h] + +end Subspace + +end Combinatorics diff --git a/LeanPool/projects/densityhalesjewett.yaml b/LeanPool/projects/densityhalesjewett.yaml index 064b3f9adb..ede2f31045 100644 --- a/LeanPool/projects/densityhalesjewett.yaml +++ b/LeanPool/projects/densityhalesjewett.yaml @@ -7,7 +7,11 @@ summary: 'A Lean 4 formalization of the density Hales–Jewett theorem: for ever and Tyros. As a consequence, we also formalize Szemerédi''s theorem on the integers: for every k ≥ 3 and δ > 0, the following holds for all sufficiently large n. Any subset of {0, …, n−1} of size at least δ·n contains a nonconstant arithmetic progression - of length k.' + of length k. The thresholds are explicit: the density Hales–Jewett theorem holds for + n ≥ A(4|α|, |α| + ⌈1/δ⌉) and Szemerédi''s theorem for n ≥ A(4k + 1, k + ⌈1/δ⌉), where A + is the Ackermann function, built on Shelah''s bound for the Hales–Jewett numbers from the + ShelahHalesJewett project. Varnavides'' theorem gives at least n²/A(4k + 1, k + ⌈1/δ⌉) + such progressions.' branch: combinatorics entry_module: LeanPool.DensityHalesJewett authors: @@ -15,11 +19,13 @@ authors: source: url: https://github.com/gdahia/densityhalesjewett github_repo: gdahia/densityhalesjewett - commit: 1c2f5aa1b99caa8e2a87beacf80f07f066c309d3 + commit: 478533c44dbfbb286362cb37e19b0ba53fdc5120 license: Apache-2.0 status: verified main_declarations: - Combinatorics.Line.exists_of_density_atTop +- Combinatorics.Line.exists_of_density +- Combinatorics.ArithmeticProgression.exists_of_density_nat main_results: - declaration: Combinatorics.Line.exists_of_density_atTop informal: Every positive-density subset of sufficiently long words over a finite @@ -28,6 +34,19 @@ main_results: informal: Every positive-density subset of a sufficiently long initial interval of the natural numbers contains an arithmetic progression of any prescribed length at least three with nonzero common difference. +- declaration: Combinatorics.Line.exists_of_density + informal: For a finite alphabet α of k letters, δ > 0 and n ≥ A(4k, k + ⌈1/δ⌉), every + set of at least δ·k^n words of length n over α contains a combinatorial line. +- declaration: Combinatorics.Line.dhjNumber_le_ack + informal: For δ > 0, the density Hales–Jewett number of k letters and density δ is + at most A(4k, k + ⌈1/δ⌉). +- declaration: Combinatorics.ArithmeticProgression.exists_of_density_nat + informal: For k ≥ 3, δ > 0 and n ≥ A(4k + 1, k + ⌈1/δ⌉), every subset of + {0, …, n − 1} with at least δn elements contains a nonconstant arithmetic + progression of length k. +- declaration: Combinatorics.ArithmeticProgression.exists_many_of_density_nat + informal: Under the same hypotheses, the subset contains at least + n²/A(4k + 1, k + ⌈1/δ⌉) arithmetic progressions of length k. tags: - combinatorics msc: diff --git a/LeanPool/projects/shelah-hales-jewett.yaml b/LeanPool/projects/shelah-hales-jewett.yaml new file mode 100644 index 0000000000..b6d86c9b30 --- /dev/null +++ b/LeanPool/projects/shelah-hales-jewett.yaml @@ -0,0 +1,52 @@ +slug: shelah-hales-jewett +title: Shelah's bound for the Hales–Jewett numbers +summary: Proves the Hales–Jewett theorem with Shelah's primitive recursive bound. The + proof is by induction on the alphabet; to add a letter it finds a subspace on which + the coloring is insensitive to replacing the new letter by an old one, building each + dimension of the subspace from a line given by the pigeonhole principle. This gives an + explicit recursion shelahBound k r for the dimension, which is proved to be below the + fifth level of the Ackermann function, so every r-coloring of the words of length + n ≥ A(5, 2k + r) over k ≥ 1 letters has a monochromatic combinatorial line. +branch: combinatorics +entry_module: LeanPool.ShelahHalesJewett +authors: +- Gabriel Dahia +source: + title: Primitive recursive bounds for van der Waerden numbers + authors: + - Saharon Shelah + doi: 10.1090/S0894-0347-1988-0929498-X + url: https://github.com/gdahia/ShelahHalesJewett/tree/8a91fc0e8a9617f8ade16ccb3b56e543990c9f45 + github_repo: gdahia/ShelahHalesJewett + commit: 8a91fc0e8a9617f8ade16ccb3b56e543990c9f45 +license: Apache-2.0 +status: verified +provenance: AI +main_declarations: +- Combinatorics.Line.exists_mono_of_shelahBound_le +- Combinatorics.Line.shelahBound_lt_ack +- Combinatorics.Line.exists_mono_of_ack_le +main_results: +- declaration: Combinatorics.Line.exists_mono_of_shelahBound_le + informal: Over a nonempty finite alphabet α, every coloring with κ colors of the + words indexed by a finite type ι has a monochromatic combinatorial line when + |ι| ≥ shelahBound |α| |κ|. + source_ref: The Hales–Jewett theorem with Shelah's bound. +- declaration: Combinatorics.Subspace.exists_insensitive + informal: For letters a and b and a finite type η, in a cube of dimension + insensitiveBound every coloring has an η-dimensional subspace on which replacing + a by b in any coordinates does not change the color. + source_ref: Shelah's insensitivity lemma. +- declaration: Combinatorics.Line.shelahBound_lt_ack + informal: shelahBound k r < A(5, 2k + r), where A is the Ackermann function. +- declaration: Combinatorics.Line.exists_mono_of_ack_le + informal: Over a nonempty finite alphabet of k letters, every coloring with r colors + of the words of length n ≥ A(5, 2k + r) has a monochromatic combinatorial line. +tags: +- combinatorics +- ramsey-theory +- hales-jewett +- ackermann-function +msc: +- 05D10 +- 03D20