From 005379c5c8234867e5cab368fe5fd18bbf207e97 Mon Sep 17 00:00:00 2001 From: Gabriel Dahia Date: Sun, 8 Nov 2026 22:05:38 +0100 Subject: [PATCH 1/3] =?UTF-8?q?Import=20Shelah's=20bound=20for=20the=20Hal?= =?UTF-8?q?es=E2=80=93Jewett=20numbers?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Import the formalization of Shelah's proof of the Hales–Jewett theorem from "Primitive recursive bounds for van der Waerden numbers" (J. Amer. Math. Soc. 1 (1988), doi:10.1090/S0894-0347-1988-0929498-X), from gdahia/ShelahHalesJewett at 8a91fc0: the insensitive subspace, the Hales–Jewett theorem in dimension shelahBound, and the bound shelahBound k r < ack 5 (2k + r). The library moves under LeanPool.ShelahHalesJewett with its imports rewritten. The Palomar Challenge and Solution modules are left out, since Solution only restates the library theorem. Co-Authored-By: Claude Opus 5.5 --- .../DensityHalesJewett.lean | 21 - .../DensityHalesJewett/Canonization.lean | 195 --- .../DensityHalesJewett/DensityIncrement.lean | 335 ----- .../DensityIncrement/CorrelatedFibers.lean | 698 --------- .../DensityIncrement/Parameters.lean | 210 --- .../StructuredCorrelation.lean | 654 -------- .../DensityHalesJewett/FiniteUnions.lean | 182 --- .../DensityHalesJewett/GrahamRothschild.lean | 207 --- .../DensityHalesJewett/Insensitive.lean | 1313 ----------------- .../DensityHalesJewett/Main.lean | 478 ------ .../DensityHalesJewett/Subspace.lean | 271 ---- .../DensityHalesJewett/Szemeredi.lean | 221 --- .../DensityHalesJewett/UniformFibers.lean | 723 --------- .../DensityHalesJewett/Varnavides.lean | 340 ----- .../DensityHalesJewett/Word.lean | 82 - LeanPool/DensityHalesJewett/Imports.lean | 25 - LeanPool/DensityHalesJewett/Solution.lean | 58 - LeanPool/ShelahHalesJewett.lean | 29 + LeanPool/ShelahHalesJewett/Ackermann.lean | 105 ++ LeanPool/ShelahHalesJewett/HalesJewett.lean | 207 +++ LeanPool/ShelahHalesJewett/Imports.lean | 12 + LeanPool/ShelahHalesJewett/Line.lean | 100 ++ LeanPool/projects/shelah-hales-jewett.yaml | 52 + 23 files changed, 505 insertions(+), 6013 deletions(-) delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean delete mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean delete mode 100644 LeanPool/DensityHalesJewett/Imports.lean delete mode 100644 LeanPool/DensityHalesJewett/Solution.lean create mode 100644 LeanPool/ShelahHalesJewett.lean create mode 100644 LeanPool/ShelahHalesJewett/Ackermann.lean create mode 100644 LeanPool/ShelahHalesJewett/HalesJewett.lean create mode 100644 LeanPool/ShelahHalesJewett/Imports.lean create mode 100644 LeanPool/ShelahHalesJewett/Line.lean create mode 100644 LeanPool/projects/shelah-hales-jewett.yaml diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett.lean deleted file mode 100644 index d8ecec276c..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett.lean +++ /dev/null @@ -1,21 +0,0 @@ -/- -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.Canonization -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation -public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions -public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi -public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean deleted file mode 100644 index ac90832154..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean +++ /dev/null @@ -1,195 +0,0 @@ -/- -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.Subspace -import Mathlib.Basic.Finite.Prod -import Mathlib.Basic.Finite.Sum - -/-! -# 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 -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. --/ - -@[expose] public section - -open Finset -open Combinatorics - -namespace DensityHalesJewett - -/-- Two words over `Option α` have the same support when their variable positions agree. -/ -def SameSupport {α ι : Type*} (x y : ι → Option α) : Prop := ∀ i, x i = none ↔ y i = none - -namespace Line - -variable {α ι : Type*} - -/-- The word obtained from a line by substituting a letter, or the variable itself, at its -variable positions. -/ -def fillOption (l : Combinatorics.Line α ι) (v : Option α) : ι → Option α := - fun i ↦ (l.idxFun i).elim v some - -@[simp] -lemma fillOption_some (l : Combinatorics.Line α ι) (a : α) : - fillOption l (some a) = some ∘ l a := by - funext i - cases h : l.idxFun i <;> simp [fillOption, Combinatorics.Line.coe_apply, h] - -end Line - -namespace Subspace - -variable {α η θ ι : Type*} - -/-- Substitute a word over `Option α` into a combinatorial subspace, marking variable positions -of the parameter word by `none`. -/ -def wordMap (V : Combinatorics.Subspace η α ι) (x : η → Option α) : ι → Option α := - fun i ↦ Sum.elim some x (V.idxFun i) - -lemma wordMap_compose (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) - (x : θ → Option α) : wordMap (compose V W) x = wordMap V (wordMap W x) := by - funext i - cases h : V.idxFun i <;> simp [wordMap, compose, h] - -lemma composeLine_idxFun (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : - (composeLine V l).idxFun = wordMap V l.idxFun := - rfl - -/-- Prepend a new variable direction, realized by a line on a fresh block of coordinates, to the -directions of a subspace. -/ -def consLine {ℓ : ℕ} {B B' : Type*} (V : Combinatorics.Subspace (Fin ℓ) α B) - (l : Combinatorics.Line α B') : Combinatorics.Subspace (Fin (ℓ + 1)) α (B ⊕ B') where - idxFun := Sum.elim (fun b ↦ (V.idxFun b).map id Fin.succ) - fun i ↦ (l.idxFun i).elim (Sum.inr 0) Sum.inl - proper e := by - induction e using Fin.cases with - | zero => - obtain ⟨i, hi⟩ := l.proper - exact ⟨Sum.inr i, by simp [hi]⟩ - | succ j => - obtain ⟨b, hb⟩ := V.proper j - exact ⟨Sum.inl b, by simp [hb]⟩ - -lemma wordMap_consLine {ℓ : ℕ} {B B' : Type*} (V : Combinatorics.Subspace (Fin ℓ) α B) - (l : Combinatorics.Line α B') (x : Fin (ℓ + 1) → Option α) : - wordMap (consLine V l) x - = Sum.elim (wordMap V fun i ↦ x i.succ) (Line.fillOption l (x 0)) := by - funext i - cases i with - | inl b => cases h : V.idxFun b <;> simp [wordMap, consLine, h] - | inr i => cases h : l.idxFun i <;> simp [wordMap, consLine, Line.fillOption, 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) : - Combinatorics.Subspace (Fin N) α (Fin n) where - idxFun i := if hi : i.val < N then Sum.inr ⟨i.val, hi⟩ else Sum.inl (Classical.arbitrary α) - proper e := ⟨Fin.castLE h e, by simp [Fin.castLE, e.isLt]⟩ - -end Subspace - -namespace Canonization - -variable {α : Type*} - -open Subspace - -/-- 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 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, - ∃ 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 - 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) - | 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 ⟨V, hV⟩ := hB fun p b q ↦ - χ 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) - 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] - -/-- **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), ?_⟩ - intro x y hxy - rw [hw x, hw y] - 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) - refine ⟨compose (padInitial α hn) V, ?_⟩ - intro x y hxy - rw [wordMap_compose, wordMap_compose] - exact hV x y hxy - -end Canonization -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean deleted file mode 100644 index e92c8e3e13..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean +++ /dev/null @@ -1,335 +0,0 @@ -/- -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.StructuredCorrelation -import Mathlib.Algebra.BigOperators.Field -import Mathlib.Algebra.Order.Archimedean.Real.Basic -import Mathlib.Data.NNRat.BigOperators - -/-! -# 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. --/ - -@[expose] public section - -open Finset -open Combinatorics -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] - -/-- Relative density in a composite subspace is relative density in the inner subspace of the -outer pullback. -/ -lemma Subspace.relativeDensity_compose {α η ζ ι : Type*} - [Fintype (η → α)] [Fintype (ζ → α)] [DecidableEq (η → α)] - [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace ζ α η) - (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, - 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))) - (hD : ∀ i, IsInsensitive i.castSucc (Fin.last k) (D i)) - (hDdense : Parameters.γ k δ ≤ ((IsInsensitive.intersection D).dens : ℝ)) - (hcorrelation : (δ + Parameters.γ k δ) * - ((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 : ℝ)) : - (∃ 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 - 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 - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean deleted file mode 100644 index 72a20aac06..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean +++ /dev/null @@ -1,698 +0,0 @@ -/- -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.Parameters -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive -import Mathlib.Tactic.Linarith - -/-! -# 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. --/ - -@[expose] public section - -open Finset -open Combinatorics -open scoped BigOperators - -namespace DensityHalesJewett - -/-- A finite word family contains no complete combinatorial line. -/ -def IsLineFree {α ι : Type*} (A : Finset (ι → α)) : Prop := - ∀ l : Combinatorics.Line α ι, ∃ a, l a ∉ A - -/-- Pull a word family back to the parameter cube of a subspace. -/ -noncomputable def pullback {η α ι : Type*} [Fintype (η → α)] - (V : Combinatorics.Subspace η α ι) - (A : Finset (ι → α)) : Finset (η → α) := - parameterPreimage V A - -/-- Pullback density agrees with the subspace-relative density. -/ -lemma dens_pullback {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : - (pullback V A).dens = Subspace.relativeDensity V A := by - 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 : ℝ)) : - ∃ 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), - Parameters.θ k δ ≤ - ((Finset.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 ↦ - ∀ 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 - -/-- 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)) ι) - (hfibers : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) - (hlines : ∀ l : Combinatorics.Line (Fin k) (Fin M), - Parameters.θ k δ ≤ - ((Finset.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 : ℝ)) ∧ - ∀ 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 : ℝ) := 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) - · intro l - let Rk := Subspace.repeatInitial (Fin k) hm hmM - simpa only [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)) ι) - (hfibers : ∀ x, - δ - Parameters.η k δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : - δ / 4 ≤ - ((Finset.univ.filter fun y : κ → Fin (k + 1) ↦ - δ / 4 ≤ - ((Finset.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. -/ -lemma exists_popular_line_of_dense_suffixes {k M : ℕ} (hk : 2 ≤ k) - (hDHJ : HasDensityHJ k) {δ : ℝ} (hδ₀ : 0 < δ) (hδ₁ : δ ≤ 1) - (hM : Parameters.m₀ k δ ≤ M) - {ι κ : Type*} [Fintype (κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → 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 : ℝ)) : - ∃ l : Combinatorics.Line (Fin k) (Fin M), - Parameters.θ k δ ≤ - ((Finset.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. -/ -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) - (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 : ℝ) := - (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) - -/-- 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 - -/-- The parameter lines whose first-`k` points belong to a word family at a fixed suffix. -/ -def suffixLines {k m : ℕ} {ι κ : Type*} - [Fintype (Combinatorics.Line (Fin k) (Fin m))] - [DecidableEq (ι ⊕ κ → Fin (k + 1))] - (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 - -/-- Pointwise fiber lower bounds imply the corresponding average lower bound for fixed-suffix -pullbacks. This is a finite double-counting argument. -/ -lemma average_suffixPullback_lower {α η ι κ : Type*} [Nonempty α] [Fintype (η → α)] - [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] - (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 - -/-- 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 < η) - (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] - -/-- 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. -/ -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))) (θ : ℝ) - (hV : ∀ 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 - 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 - -/-- 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) - (hf₁ : ∀ x, f x ≤ 1) (havg : θ ≤ 𝔼 x : X, f x) : - θ / 2 ≤ ((Finset.univ.filter fun x ↦ θ / 2 ≤ f x).dens : ℝ) := by - refine le_trans ?_ - (density_ge_threshold f θ (θ / 2) 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) (η θ : ℝ) - (hS : 1 - η ≤ (S.dens : ℝ)) (hT : θ / 2 ≤ (T.dens : ℝ)) - (hηθ : η < θ / 2) : ∃ x, x ∈ S ∧ x ∈ T := by - classical - 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] - -/-- 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) - [Fintype (Combinatorics.Line (Fin k) (Fin m))] - [Nonempty (Combinatorics.Line (Fin k) (Fin m))] - (δ : ℝ) (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 : ℝ)) - (hlines : ∀ 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 : ℝ)) : - (∃ y, δ + Parameters.η k δ ^ 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 δ - -/-- 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))] - [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 : ℝ)) : - (∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), - δ + Parameters.η k δ ^ 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) ↦ - ∀ 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 - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean deleted file mode 100644 index 95381329d3..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean +++ /dev/null @@ -1,210 +0,0 @@ -/- -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.UniformFibers -import Mathlib.Tactic.Linarith - -/-! -# Numerical parameters of the density increment - -The thresholds `θ`, `η`, and `γ` attached to an alphabet size and a density, together with their -monotonicity and positivity properties. --/ - -@[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 - 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 - unfold θ - exact div_pos (by positivity) (θ_denominator_pos hk δ) - -/-- The error tolerance attached to an alphabet size and density. -/ -noncomputable def η (k : ℕ) (δ : ℝ) : ℝ := - min (δ * θ k δ / 48) (min (θ k δ / 4) (δ / 6)) - -/-- The error tolerance is monotone in the density parameter. -/ -lemma η_mono {k : ℕ} (hk : 2 ≤ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : η k δ ≤ η k ρ := 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 - · norm_num - · exact div_le_div_of_nonneg_right (θ_mono hk hδ 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 - unfold η - apply lt_min - · positivity [θ_pos hk hδ] - · apply lt_min - · positivity [θ_pos hk 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 increment is monotone in the density parameter. -/ -lemma γ_mono {k : ℕ} (hk : 2 ≤ k) {δ ρ : ℝ} - (hδ : 0 < δ) (hδρ : δ ≤ ρ) : γ k δ ≤ γ k ρ := by - 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 - · 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) - -lemma γ_pos {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : 0 < γ k δ := by - unfold γ - positivity [η_pos hk hδ] - -lemma η_lt_θ_div_two {k : ℕ} (hk : 2 ≤ k) {δ : ℝ} (hδ : 0 < δ) : - η k δ < θ k δ / 2 := by - unfold η - apply lt_of_le_of_lt ((min_le_right _ _).trans (min_le_left _ _)) - linarith [θ_pos hk hδ] - -lemma η_le_δ_div_six (k : ℕ) (δ : ℝ) : η k δ ≤ δ / 6 := by - unfold η - exact (min_le_right _ _).trans (min_le_right _ _) - -lemma γ_le_η_sq_div_two (k : ℕ) (δ : ℝ) : γ k δ ≤ η k δ ^ 2 / 2 := by - unfold γ - exact (min_le_right _ _).trans (min_le_left _ _) - -lemma γ_le_three_mul_η (k : ℕ) (δ : ℝ) : γ k δ ≤ 3 * η k δ := 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 - 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] - -/-- 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] - -end Parameters - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean deleted file mode 100644 index 62da56ecf9..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean +++ /dev/null @@ -1,654 +0,0 @@ -/- -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.CorrelatedFibers -import Mathlib.Algebra.BigOperators.Field -import Mathlib.Algebra.Order.Archimedean.Real.Basic -import Mathlib.Data.NNRat.BigOperators - -/-! -# 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 -correlated with the ambient word family. --/ - -@[expose] public section - -open Finset -open Combinatorics -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 - -/-- Replace every occurrence of the final alphabet letter by a fixed restricted-alphabet -letter. -/ -def replaceLastLetter {k m : ℕ} (i : Fin k) (x : Fin m → Fin (k + 1)) : - Fin m → Fin (k + 1) := - fun c ↦ if x c = Fin.last k then i.castSucc else x c - -/-- The endpoint family associated with one restricted-alphabet letter. -/ -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 - -/-- 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 - -/-- 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) - -/-- The density of restricted parameter words is the expected power of the alphabet ratio. -/ -lemma restrictedParameterWords_density (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] - -/-- Each endpoint family is insensitive to interchanging its selected letter with the final -letter. -/ -lemma endpointFamily_isInsensitive {k m n : ℕ} - (A : Finset (Fin n → Fin (k + 1))) - (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) (i : Fin k) : - IsInsensitive i.castSucc (Fin.last k) (endpointFamily A V i) := by - intro x y hxy - have hreplace : replaceLastLetter i x = replaceLastLetter i y := by - 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] - rw [hreplace] - -/-- Encode a restricted-alphabet line by the word using the final letter on its wildcard -coordinates. -/ -private def lineEndpoint {k m : ℕ} (l : Combinatorics.Line (Fin k) (Fin m)) : - Fin m → Fin (k + 1) := - fun c ↦ - match l.idxFun c with - | none => Fin.last k - | some a => a.castSucc - -/-- The endpoint word remembers every fixed letter and every wildcard coordinate of a line. -/ -private lemma lineEndpoint_injective {k m : ℕ} : - Function.Injective (lineEndpoint : Combinatorics.Line (Fin k) (Fin m) → - (Fin m → Fin (k + 1))) := by - rintro ⟨f, hf⟩ ⟨g, hg⟩ hll - congr - funext c - have hc := congrFun hll c - 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) - [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)) - (hrestricted : ((restrictedParameterWords k m).dens : ℝ) ≤ 1 / 2) - (hlines : Parameters.θ k δ / 2 ≤ - ((Finset.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 - classical - let good := Finset.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δ₀] - -/-- 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))) - (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] - 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) - proper := ⟨c, ite_eq_left hc⟩ - } - 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] - 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] - 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 - · 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 - -/-- 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. -/ -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)) - (hfree : IsLineFree A) - (hlines : Parameters.θ k δ / 2 ≤ - ((Finset.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 : ℝ) ∧ - ((pullback V A ∩ IsInsensitive.intersection C).dens : ℝ) ≤ - Parameters.η k δ := by - 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 - -/-- 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) (δ η θ : ℝ) - (hδ₀ : 0 ≤ δ) (hη₀ : 0 ≤ η) (hA : δ - 2 * η ≤ (A.dens : ℝ)) - (hC : θ / 4 ≤ (C.dens : ℝ)) - (hAC : ((A ∩ C).dens : ℝ) ≤ η) - (hgain : (δ + 6 * η) * (1 - θ / 4) ≤ δ - 3 * η) : - (δ + 6 * η) * ((Cᶜ).dens : ℝ) ≤ ((A ∩ Cᶜ).dens : ℝ) ∧ - δ - 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 - 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] - (C : Fin k → Finset X) (i : Fin k) : Finset X := - (C i)ᶜ ∩ Finset.univ.filter fun x ↦ ∀ j, j < i → x ∈ C j - -/-- 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] - (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 - -/-- Every member of the first-failure family has the required sensitivity pair. -/ -lemma firstFailureFamily_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 X) (i : Fin k) : - IsInsensitive.intersection (firstFailureFamily C i) = firstFailurePiece 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] - (C : Fin k → Finset X) : - Finset.univ.biUnion (firstFailurePiece C) = (IsInsensitive.intersection C)ᶜ := by - classical - 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] - (C : Fin k → Finset X) : - (Set.univ : Set (Fin k)).PairwiseDisjoint fun i ↦ (firstFailurePiece C i : Set X) := 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 - -/-- 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] - (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) - {δ : ℝ} (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 : ℝ)) : - ∃ 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⟩ - -/-- 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) - [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) : - ∃ 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 : ℝ) ≤ - ((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 - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean deleted file mode 100644 index e9921e2cc4..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean +++ /dev/null @@ -1,182 +0,0 @@ -/- -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.Combinatorics.Pigeonhole -public 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 -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. --/ - -@[expose] public section - -open Finset -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 - 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 ⟨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] - grind - have hSX : ∀ j, Disjoint S (X j) := by - simp only [Finset.disjoint_left, hS, hX, Finset.mem_filter, Finset.mem_univ, true_and] - grind - have key : ∀ J : Finset (Fin (n + 1)), d (S ∪ J.biUnion X) = c := by - 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] - 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 - ext i - simp only [Finset.mem_union, Finset.mem_biUnion, Finset.mem_insert, Finset.mem_image] - grind - -/-- 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 - classical - induction t with - | zero => - refine ⟨0, ?_⟩ - intro d - 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 - | 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, ?_⟩ - · 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 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 - -/-- 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 - 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) - 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, ?_⟩ - 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 [← hj] - simpa using hTsub (T.orderEmbOfFin_mem hTcard j) - -end FiniteUnions -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean deleted file mode 100644 index 45e45ef255..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean +++ /dev/null @@ -1,207 +0,0 @@ -/- -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.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 -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. - -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. --/ - -@[expose] public section - -open Finset -open Combinatorics - -namespace DensityHalesJewett - -namespace GrahamRothschild - -open Subspace - -variable {α ι C : Type*} [DecidableEq ι] {m n : ℕ} - -/-- The subspace whose variable directions are pairwise disjoint nonempty blocks of coordinates, -all remaining coordinates carrying a fixed letter. -/ -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 - 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 - -variable {a₀ : α} {E : Fin m → Finset ι} {hE : ∀ j, (E j).Nonempty} - {hEE : ∀ i j, i ≠ j → Disjoint (E i) (E j)} - -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 - -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)] - -/-- 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)) - (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] - 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 [not_exists] at h - rw [ofBlocks_idxFun_of_notMem h, Sum.elim_inl, hite i] - simp [Finset.mem_biUnion, 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 lemma extend_idxFun [Nonempty C] (χ : Combinatorics.Line α (Fin n) → C) - (l : Combinatorics.Line α (Fin n)) : extend χ l.idxFun = χ l := - dite_eq_left l.proper - -/-- **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 - 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 α)) - 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 - 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))) : - ∃ 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 - 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 - -end GrahamRothschild -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean deleted file mode 100644 index 81ab82410c..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean +++ /dev/null @@ -1,1313 +0,0 @@ -/- -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.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 - -/-! -# Insensitive word families and tilings - -Boolean closure of insensitive families and the subspace-tiling results used in the density -increment argument. --/ - -@[expose] public section - -open Finset -open Combinatorics -open scoped BigOperators - -namespace DensityHalesJewett - -/-- Two words are equivalent after freely interchanging the letters `i` and `j`. -/ -def InsensitiveEquiv {α ι : Type*} (i j : α) (x y : ι → α) : Prop := - ∀ a, a ≠ i → a ≠ j → ∀ c, (x c = a ↔ y c = a) - -/-- Membership in an `(i,j)`-insensitive family is constant on insensitive-equivalence classes. -/ -def IsInsensitive {α ι : Type*} (i j : α) (D : Finset (ι → α)) : Prop := - ∀ ⦃x y⦄, InsensitiveEquiv i j x y → (x ∈ D ↔ y ∈ D) - -/-- Transport a word family along an equivalence of coordinate types. -/ -def transportWords {α ι ι' : Type*} - (e : ι ≃ ι') (D : Finset (ι → α)) : Finset (ι' → α) := - D.map ((e.arrowCongr (Equiv.refl α)).toEmbedding) - -@[simp] -lemma mem_transportWords {α ι ι' : Type*} - {e : ι ≃ ι'} {D : Finset (ι → α)} {w : ι' → α} : - w ∈ transportWords e D ↔ w ∘ e ∈ D := by - rw [transportWords, Finset.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] - -namespace IsInsensitive - -/-- Reindexing coordinates preserves insensitivity. -/ -lemma reindex {α ι ι' : Type*} - {i j : α} {D : Finset (ι → α)} (e : ι ≃ ι') (hD : IsInsensitive i j D) : - IsInsensitive i j (DensityHalesJewett.transportWords e D) := by - intro x y hxy - simp only [mem_transportWords] - apply hD - intro a hai haj c - exact hxy a hai haj (e c) - -/-- Fixing a prefix of coordinates preserves insensitivity of the remaining section. -/ -lemma fiberSection {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] - {i j : α} {D : Finset (ι ⊕ κ → α)} (hD : IsInsensitive i j D) (v : ι → α) : - IsInsensitive i j (DensityHalesJewett.fiber D v) := by - intro x y hxy - simp only [mem_fiber] - apply hD - intro a hai haj c - cases c with - | inl c => simp only [Sum.elim_inl] - | inr c => exact hxy a hai haj c - -/-- Complements preserve insensitivity. -/ -lemma compl {α ι : Type*} [Fintype (ι → α)] [DecidableEq (ι → α)] - {i j : α} {D : Finset (ι → α)} (hD : IsInsensitive i j D) : - IsInsensitive i j Dᶜ := by - intro x y hxy - simp only [mem_compl, hD hxy] - -/-- The part of `D` left uncovered by a set of subspaces. -/ -noncomputable def uncovered {η α ι : Type*} [Fintype (η → α)] - [DecidableEq (ι → α)] (D : Finset (ι → α)) - (𝒱 : Set (Combinatorics.Subspace η α ι)) : Finset (ι → α) := by - classical - exact D.filter fun w ↦ ∀ V ∈ 𝒱, w ∉ Subspace.range V - -/-- 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 - -@[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] - -/-- An ambient dimension is sufficient for tiling every dense one-pair insensitive family. -/ -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 : ℝ) → - ∃ 𝒱 : 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 * β - -/-- Differences preserve insensitivity. -/ -lemma sdiff {α ι : Type*} [DecidableEq (ι → α)] - {i j : α} {D E : Finset (ι → α)} (hD : IsInsensitive i j D) - (hE : IsInsensitive i j E) : IsInsensitive i j (D \ E) := by - intro x y hxy - simp [hD hxy, hE hxy] - -/-- Insensitive-equivalent prefixes have the same section. -/ -lemma fiber_congr {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] - {i j : α} {D : Finset (ι ⊕ κ → α)} (hD : IsInsensitive i j D) {v w : ι → α} - (hvw : InsensitiveEquiv i j v w) : - DensityHalesJewett.fiber D v = DensityHalesJewett.fiber D w := by - ext y - simp only [mem_fiber] - apply hD - intro a hai haj c - cases c with - | inl c => exact hvw a hai haj c - | inr c => simp only [Sum.elim_inr] - -end IsInsensitive - -/-- Regrouping the coordinates of a word with a fixed prefix and a split tail. -/ -private lemma concat_comp_regroup {α ω ν ν₁ ν₂ : Type*} (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 - funext c - cases 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. -/ -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 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)) - -/-- Sections commute with set difference. -/ -private lemma fiber_transportWords_sdiff {α ι ω ν : Type*} - [Fintype α] [DecidableEq α] [Fintype ι] [Fintype ω] - [Fintype ν] [DecidableEq ν] - (e : ι ≃ ω ⊕ ν) (A B : Finset (ι → α)) (v : ω → α) : - DensityHalesJewett.fiber (transportWords e (A \ B)) v = - DensityHalesJewett.fiber (transportWords e A) v \ - DensityHalesJewett.fiber (transportWords e B) v := by - ext y - simp only [Finset.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] - 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] - 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))) - (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, ?_⟩ - 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⟩)) - intro a hai hal c - cases hc : V.idxFun c with - | inl t => simp only [V.apply_inl hc] - | inr e => - simp only [V.apply_inr hc, Function.comp_apply] - by_cases hx : x e = Fin.last k - · rw [dite_eq_left hx, hx, Fin.castSuccEmb_apply] - apply iff_of_false - · intro h - exact hal h.symm - · intro 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))) : - Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b) := by - classical - exact if h : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), - Subspace.IsContained V E then Classical.choose h - else Subspace.repeatInitial (Fin (k + 1)) hm hmb - -lemma pickSubspace_isContained {k m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) - {E : Finset (Fin b → Fin (k + 1))} - (h : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), - Subspace.IsContained V E) : - Subspace.IsContained (pickSubspace hm hmb E) E := by - classical - rw [pickSubspace, dite_eq_left h] - exact Classical.choose_spec h - -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 - ext y - simp only [mem_fiber, Finset.mem_map_equiv, uncovered, Finset.mem_filter] - 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 - 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 - -/-- 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))) {β : ℝ} - (hgood : β ≤ (good.dens : ℝ)) - (hnonempty : ∀ z ∈ good, (fiber (transportWords e R) z).Nonempty) : - β / ((k : ℝ) + 1) ^ b ≤ (R.dens : ℝ) := by - classical - have hcard : (Fintype.card (Fin b → Fin (k + 1)) : ℝ) = ((k : ℝ) + 1) ^ b := by - simp only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow, Nat.cast_add, - Nat.cast_one] - have hfiber (z : ζ → Fin (k + 1)) (hz : z ∈ good) : - 1 / ((k : ℝ) + 1) ^ b ≤ ((fiber (transportWords e R) z).dens : ℝ) := by - rw [← hcard] - exact one_div_card_le_dens (hnonempty z hz) - have haverage : (R.dens : ℝ) = - 𝔼 z : (ζ → Fin (k + 1)), ((fiber (transportWords e R) z).dens : ℝ) := by - 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 - 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 - · 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 - 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 - 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] - -/-- 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] - | 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) - linarith - -/-- A tiling in every fixed extra-coordinate section combines to a tiling of the full 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 - -/-- Pulling an insensitive family back through a subspace preserves its sensitivity pair. -/ -lemma parameterPreimage_isInsensitive {α η ι : Type*} - [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] - apply hD - intro c hca hcb i - cases hi : V.idxFun i with - | inl d => rw [V.apply_inl hi, V.apply_inl hi] - | inr e => - 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 - -/-- Mapping a parameter-cube family into a subspace scales its ambient density by the density of -the whole subspace range. -/ -private lemma dens_map_subspace_eq_mul_range {α η ι : Type*} - [Fintype (η → α)] [Fintype (ι → α)] [DecidableEq (ι → α)] - (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] - 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. -/ -def IntersectionTilingSufficient (k r m : ℕ) (β : ℝ) (n : ℕ) : Prop := - ∀ (_ : 1 ≤ r), ∀ 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 * β - -/-- One indexed insensitive family is exactly the one-family tiling statement. -/ -private lemma intersectionTilingSufficient_one {k m n : ℕ} {β : ℝ} - (h : TilingSufficient k m β n) : - IntersectionTilingSufficient k 1 m β n := by - intro _ hrk D hD hDβ - have hintersection : 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) : - 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 : ℕ} {β : ℝ} - (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 - 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) : - 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 - -/-- 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 : ℝ)) : - ∃ 𝒱 : 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β - -end IsInsensitive -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean deleted file mode 100644 index 41b46ddd6c..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean +++ /dev/null @@ -1,478 +0,0 @@ -/- -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.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 - -/-! -# Density Hales--Jewett - -The binary base case and induction on the alphabet size. --/ - -@[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 ι := - 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 → α)) - (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), ?_⟩ - 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 - exact_mod_cast hδ.trans_le hAδ - simpa only [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) : - ∃ 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, ?_⟩ - intro x - specialize hl (e x) - rw [Finset.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) - (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δ - -end Combinatorics.Line diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean deleted file mode 100644 index ac3f714f17..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean +++ /dev/null @@ -1,271 +0,0 @@ -/- -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.Word -public import Mathlib.Logic.Equiv.Fin.Basic - -/-! -# Combinatorial subspaces - -Ranges, containment, relative density, alphabet restriction, and lines inside mathlib's -`Combinatorics.Subspace`. --/ - -@[expose] public section - -open Finset Function -open Combinatorics - -namespace DensityHalesJewett -namespace Subspace - -variable {η α ι : Type*} - -/-- Evaluation by a fixed combinatorial subspace is injective. -/ -lemma injective (V : Combinatorics.Subspace η α ι) : - Function.Injective V := by - intro x y hxy - funext e - obtain ⟨i, hi⟩ := V.proper e - simpa only [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 - -@[simp] -lemma mem_range [Fintype (η → α)] [DecidableEq (ι → α)] - {V : Combinatorics.Subspace η α ι} {w : ι → α} : - w ∈ range V ↔ ∃ x, V x = w := by - simp [range] - -/-- A subspace is contained in a finite word family when all its evaluations belong to it. -/ -def IsContained (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : Prop := - ∀ x, V x ∈ A - -/-- Compose a parameter subspace with an ambient subspace. -/ -def compose (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) : - Combinatorics.Subspace θ α ι where - idxFun i := (V.idxFun i).elim Sum.inl W.idxFun - proper e := by - obtain ⟨j, hj⟩ := W.proper e - obtain ⟨i, hi⟩ := V.proper j - refine ⟨i, ?_⟩ - simp only [hi, Sum.elim_inr, hj] - -@[simp] -lemma compose_apply (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) - (x : θ → α) : compose V W x = V (W x) := by - funext i - cases hi : V.idxFun i <;> simp [compose, Combinatorics.Subspace.coe_apply, hi] - -/-- Repeat the first `m` parameter directions to fill a larger `M`-coordinate cube. -/ -def repeatInitial {m M : ℕ} (α : Type*) (hm : 1 ≤ m) (hmM : m ≤ M) : - Combinatorics.Subspace (Fin m) α (Fin M) where - idxFun i := Sum.inr <| - if hi : i.val < m then ⟨i.val, hi⟩ else ⟨0, Nat.zero_lt_of_lt hm⟩ - proper e := by - refine ⟨Fin.castLE hmM e, ?_⟩ - simp only [Fin.castLE, e.isLt, ↓reduceDIte] - -@[simp] -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 - simp only [Function.comp_apply, (repeatInitial α hm hmM).apply_inr rfl, - (repeatInitial β hm hmM).apply_inr rfl] - -/-- Concatenate subspaces on disjoint coordinate blocks. -/ -def concat (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α κ) : - Combinatorics.Subspace (η ⊕ θ) α (ι ⊕ κ) where - idxFun := Sum.elim - (fun i ↦ (V.idxFun i).elim Sum.inl (fun e ↦ Sum.inr <| Sum.inl e)) - (fun i ↦ (W.idxFun i).elim Sum.inl (fun e ↦ Sum.inr <| Sum.inr e)) - proper e := by - cases e with - | inl e => - obtain ⟨i, hi⟩ := V.proper e - refine ⟨Sum.inl i, ?_⟩ - simp only [hi, Sum.elim_inl, Sum.elim_inr] - | inr e => - obtain ⟨i, hi⟩ := W.proper e - refine ⟨Sum.inr i, ?_⟩ - simp only [hi, Sum.elim_inr] - -@[simp] -lemma concat_apply (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α κ) - (x : η → α) (y : θ → α) : concat V W (Sum.elim x y) = - Sum.elim (V x) (W y) := by - funext i - cases i with - | inl i => cases hi : V.idxFun i <;> simp [concat, Combinatorics.Subspace.coe_apply, hi] - | inr i => cases hi : W.idxFun i <;> simp [concat, Combinatorics.Subspace.coe_apply, hi] - -/-- Regard a line as a one-dimensional subspace parameterized by `Fin 1`. -/ -def lineToSubspaceFinOne (l : Combinatorics.Line α ι) : - Combinatorics.Subspace (Fin 1) α ι := - l.toSubspaceUnit.reindex finOneEquiv.symm (Equiv.refl _) (Equiv.refl _) - -@[simp] -lemma lineToSubspaceFinOne_apply (l : Combinatorics.Line α ι) (x : Fin 1 → α) : - lineToSubspaceFinOne l x = l (x 0) := by - funext i - simp [lineToSubspaceFinOne, Fin.eq_zero] - -/-- 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 - -/-- 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. -/ -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] - -@[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] - -/-- Regard the composite of a parameter line with a subspace as a line in that subspace. -/ -def composeLineToLines [Fintype (η → α)] [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : Lines V := - ⟨composeLine V l, fun a ↦ mem_range.mpr ⟨l a, (composeLine_apply V l a).symm⟩⟩ - -/-- The canonical parameter word representing a point of a line contained in a subspace. -/ -noncomputable def parameterWord [Fintype (η → α)] [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (q : Lines V) (a : α) : η → α := - Classical.choose <| mem_range.mp (q.2 a) - -lemma parameterWord_apply [Fintype (η → α)] [DecidableEq (ι → α)] - (V : Combinatorics.Subspace η α ι) (q : Lines V) (a : α) : - V (parameterWord V q a) = q.1 a := - Classical.choose_spec <| mem_range.mp (q.2 a) - -/-- A chosen coordinate on which a subspace realizes a given parameter direction. -/ -noncomputable def properCoordinate (V : Combinatorics.Subspace η α ι) (e : η) : ι := - Classical.choose <| V.proper e - -lemma properCoordinate_spec (V : Combinatorics.Subspace η α ι) (e : η) : - V.idxFun (properCoordinate V e) = Sum.inr e := - Classical.choose_spec <| V.proper e - -/-- Recover the parameter-cube line underlying an ambient line contained in a subspace. -/ -noncomputable def uncomposeLine [Fintype (η → α)] [DecidableEq (ι → α)] [Nontrivial α] - (V : Combinatorics.Subspace η α ι) (q : Lines V) : Combinatorics.Line α η where - idxFun e := q.1.idxFun (properCoordinate V e) - proper := by - obtain ⟨j, hj⟩ := q.1.proper - cases hVj : V.idxFun j with - | inl b => - obtain ⟨a, hab⟩ := exists_ne b - refine absurd ?_ hab - rw [← q.1.apply_none a j hj, ← parameterWord_apply V q a] - exact V.apply_inl hVj - | inr e => - cases hq : q.1.idxFun (properCoordinate V e) with - | none => exact ⟨e, hq⟩ - | 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), - V.apply_inr hVj]) hac - -lemma uncomposeLine_apply [Fintype (η → α)] [DecidableEq (ι → α)] [Nontrivial α] - (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] - | 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] - -/-- Composition with a subspace identifies parameter-cube lines with ambient lines contained in -the subspace. -/ -noncomputable def linesEquiv [Fintype (η → α)] [DecidableEq (ι → α)] - [Nontrivial α] (V : Combinatorics.Subspace η α ι) : - Combinatorics.Line α η ≃ Lines V where - toFun := composeLineToLines V - invFun := uncomposeLine V - left_inv := by - intro l - apply Combinatorics.Line.coe_injective - funext a - apply injective V - rw [uncomposeLine_apply] - exact composeLine_apply V l a - right_inv := by - intro q - apply Subtype.ext - change composeLine V (uncomposeLine V q) = q.1 - apply Combinatorics.Line.coe_injective - funext a - rw [composeLine_apply] - exact uncomposeLine_apply V q a - -/-- Map a parameter-cube line to the corresponding ambient line in a subspace. -/ -def mapLine (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : - Combinatorics.Line α ι := - composeLine V l - -lemma mapLine_eq_composeLine (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : - mapLine V l = composeLine V l := - rfl - -@[simp] -lemma mapLine_apply (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) - (a : α) : mapLine V l a = V (l a) := - composeLine_apply V l a - -/-- 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) - -end Subspace - -/-- Fix the coordinates outside a designated block, keeping a subspace on the block. -/ -def transportSubspace {α η ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (z : ω → α) - (V : Combinatorics.Subspace η α ν) : Combinatorics.Subspace η α ι where - idxFun c := Sum.elim (fun a ↦ Sum.inl (z a)) V.idxFun (e c) - proper x := by - obtain ⟨c, hc⟩ := V.proper x - exact ⟨e.symm (Sum.inr c), by simp only [Equiv.apply_symm_apply, Sum.elim_inr, hc]⟩ - -@[simp] -lemma transportSubspace_apply {α η ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (z : ω → α) - (V : Combinatorics.Subspace η α ν) (x : η → α) : - transportSubspace e z V x = Sum.elim z (V x) ∘ e := by - funext c - simp only [Combinatorics.Subspace.coe_apply, transportSubspace, Function.comp_apply] - cases e c <;> simp only [Sum.elim_inl, Sum.elim_inr, id_eq, Combinatorics.Subspace.coe_apply] - -/-- The preimage of a word family in a subspace parameter cube. -/ -noncomputable def parameterPreimage {η α ι : Type*} [Fintype (η → α)] - (V : Combinatorics.Subspace η α ι) (D : Finset (ι → α)) : Finset (η → α) := by - classical - apply Finset.univ.filter - intro x - exact V x ∈ D - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean deleted file mode 100644 index e0ecae227f..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean +++ /dev/null @@ -1,221 +0,0 @@ -/- -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.Algebra.BigOperators.Fin -public import Mathlib.Algebra.Order.Archimedean.Real.Basic -public import Mathlib.Combinatorics.Pigeonhole -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main - -/-! -# 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`. --/ - -@[expose] public section - -open Finset -open Combinatorics - -namespace Combinatorics - -/-- An arithmetic progression of length `k` with nonzero common difference in an additive monoid. -/ -@[ext] -structure ArithmeticProgression (α : Type*) [AddMonoid α] (k : ℕ) where - /-- The initial term of the arithmetic progression. -/ - start : α - /-- The common difference of the arithmetic progression. -/ - diff : α - diff_ne_zero : diff ≠ 0 - -namespace ArithmeticProgression - -/-- The term of `P` indexed by `i`. -/ -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 := - ∀ i, P.term i ∈ s - -end ArithmeticProgression -end Combinatorics - -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` -digits of a natural number. -/ -lemma baseEncode_isArithmeticProgression {k m : ℕ} (hk : 1 ≤ k) - (l : Combinatorics.Line (Fin k) (Fin m)) : - ∃ P : Combinatorics.ArithmeticProgression ℕ k, - ∀ a, P.term a = (finFunctionFinEquiv (l a) : ℕ) := by - let d := ∑ i : Fin m, if l.idxFun i = none then k ^ (i : ℕ) else 0 - refine ⟨ - { 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]⟩ - · 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 - 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) - (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 - 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 _) - -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 - 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 }, ?_⟩ - 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 - -end Combinatorics.ArithmeticProgression diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean deleted file mode 100644 index 02f0c1c5d0..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean +++ /dev/null @@ -1,723 +0,0 @@ -/- -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.GrahamRothschild -import Mathlib.Algebra.Order.Archimedean.Real.Basic -import Mathlib.Combinatorics.Pigeonhole -import Mathlib.Tactic.Linarith - -/-! -# Preliminary density lemmas - -Multidimensional density Hales--Jewett, uniform fibers, and the restricted-alphabet subspace -lemma. All subspaces below are mathlib's `Combinatorics.Subspace`. --/ - -@[expose] public section - -open Finset -open Combinatorics -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 - -namespace Subspace - -/-- 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 - -/-- 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) : - ∃ V : Combinatorics.Subspace (Fin 1) (Fin k) (Fin n), IsContained V A := by - obtain ⟨l, hl⟩ := densityOneBound_spec hDHJ δ hδ n hn A hA - refine ⟨lineToSubspaceFinOne l, ?_⟩ - intro x - rw [lineToSubspaceFinOne_apply] - exact hl _ - -/-- 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 - invFun f := ⟨f, by simpa using f.property⟩ - left_inv l := by cases l; rfl - right_inv _ := Subtype.ext rfl - -/-- An index word with no variable coordinate is equivalently an ordinary alphabet word. -/ -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) - left_inv f := by - refine Subtype.ext (funext ?_) - intro i - cases hi : f.1 i with - | none => exact (f.2 i hi).elim - | some b => simp [hi] - 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) - [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⟩⟩ - rw [Fintype.card_congr (lineIndexEquiv (Fin k) (Fin m)), - Fintype.card_subtype_compl (fun f : Fin m → Option (Fin k) ↦ ∀ i, f i ≠ none), - Fintype.card_pi_const, Fintype.card_option, Fintype.card_fin, - Fintype.card_congr (fixedIndexWordEquiv (Fin k) (Fin m)), - Fintype.card_pi_const, Fintype.card_fin] - -/-- The finite enumeration of line structures induced by their index words. -/ -@[instance_reducible] -noncomputable def lineFintype (k m : ℕ) : Fintype (Combinatorics.Line (Fin k) (Fin m)) := - Fintype.ofInjective (fun l ↦ l.idxFun) fun l₁ l₂ h ↦ by - cases l₁ - cases l₂ - cases h - rfl - -/-- A subspace over the empty alphabet, obtained by repeating parameter coordinates. -/ -def emptyAlphabetSubspace {m n : ℕ} (hm : 1 ≤ m) (hmn : m ≤ n) : - Combinatorics.Subspace (Fin m) (Fin 0) (Fin n) where - 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) : - δ ≤ (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 - -/-- 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 : ℝ)) : - δ * (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 - -/-- 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 - 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 : ℝ)) - -/-- 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 : ℝ)) : - δ / 2 ≤ - ((Finset.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 - -/-- 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) - (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 - ∃ 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 - 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 - -/-- 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 - -/-- 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) - (A : Finset (Fin n → Fin alphabet)) : Finset (Fin p ⊕ Fin q → Fin alphabet) := - A.map (e.arrowCongr (Equiv.refl (Fin alphabet))).symm.toEmbedding - -@[simp] -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] - 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] - -/-- 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) - -/-- 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 - proper e := ⟨e, rfl⟩ - -@[simp] -lemma blockSubspace_apply {α : Type*} {m : ℕ} (x : Fin m → α) : blockSubspace α m x = x := by - funext i - exact (blockSubspace α m).apply_inr rfl - -/-- Prepend a fixed block of letters to the coordinates of a subspace. -/ -def prependFixed {α η : Type*} {m p : ℕ} (u : Fin m → α) - (V : Combinatorics.Subspace η α (Fin p)) : Combinatorics.Subspace η α (Fin (m + p)) := - transportSubspace finSumFinEquiv.symm u V - -@[simp] -lemma prependFixed_apply {α η : Type*} {m p : ℕ} (u : Fin m → α) - (V : Combinatorics.Subspace η α (Fin p)) (x : η → α) : - prependFixed u V x = Sum.elim u (V x) ∘ finSumFinEquiv.symm := - transportSubspace_apply finSumFinEquiv.symm u V x - -/-- Regroup a cut of the coordinates following a fixed block. -/ -def prependCoords {m p q r : ℕ} (e : Fin p ⊕ Fin q ≃ Fin r) : - Fin (m + p) ⊕ Fin q ≃ Fin m ⊕ Fin r := - ((finSumFinEquiv.symm.sumCongr (Equiv.refl (Fin q))).trans - (Equiv.sumAssoc (Fin m) (Fin p) (Fin q))).trans ((Equiv.refl (Fin m)).sumCongr e) - -/-- Prepend a fixed coordinate block to a cut of the remaining coordinates. -/ -def prependCut {m p q r n : ℕ} (h : m + r = n) (e : Fin p ⊕ Fin q ≃ Fin r) : - Fin (m + p) ⊕ Fin q ≃ Fin n := - (prependCoords e).trans (cutEquiv h) - -/-- Regrouping the coordinates identifies a prepended word with the concatenation of the fixed -block and the cut word. -/ -lemma concat_prependFixed {alphabet η m p q r : ℕ} (e : Fin p ⊕ Fin q ≃ Fin r) - (u : Fin m → Fin alphabet) (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) - (x : Fin η → Fin alphabet) (y : Fin q → Fin alphabet) : - Sum.elim (prependFixed u V x) y ∘ (prependCoords e).symm = - Sum.elim u (Sum.elim (V x) y ∘ e.symm) := by - funext s - cases s with - | inl a => simp [prependCoords] - | inr b => - cases hb : e.symm b <;> simp [prependCoords, hb] - -/-- The same identification stated for the cut of the ambient coordinates. -/ -lemma concat_prependFixed_cut {alphabet η m p q r n : ℕ} (h : m + r = n) - (e : Fin p ⊕ Fin q ≃ Fin r) (u : Fin m → Fin alphabet) - (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) - (x : Fin η → Fin alphabet) (y : Fin q → Fin alphabet) : - Sum.elim (prependFixed u V x) y ∘ (prependCut h e).symm = - Sum.elim u (Sum.elim (V x) y ∘ e.symm) ∘ - (cutEquiv h).symm := by - rw [← concat_prependFixed e u V x y] - rfl - -/-- The suffix fibers of a prepended cut are the suffix fibers of the family already restricted -to the fixed prefix block. -/ -lemma fiber_splitWords_prependCut {alphabet η m p q r n : ℕ} (h : m + r = n) - (e : Fin p ⊕ Fin q ≃ Fin r) (A : Finset (Fin n → Fin alphabet)) (u : Fin m → Fin alphabet) - (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) (x : Fin η → Fin alphabet) : - fiber (splitWords (prependCut h e) A) (prependFixed u V x) = - fiber (splitWords e (fiber (splitWords (cutEquiv h) A) u)) (V x) := by - ext y - simp only [mem_fiber, mem_splitWords] - rw [concat_prependFixed_cut] - -/-- 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) - (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 - 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. -/ -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 - | _ 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, ?_⟩ - 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) : - 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 - -/-- Averaging restricted-parameter slice densities over suffixes equals averaging their ambient -fiber densities over restricted parameter words. -/ -lemma average_restrictedParameterSlice {k M : ℕ} - {ι κ : Type*} [Fintype (κ → Fin (k + 1))] - [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 ↦ - 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] - -/-- 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) (δ : ℝ) - {ι κ : Type*} [Fintype (κ → Fin (k + 1))] - [DecidableEq (ι ⊕ κ → 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 ↦ - 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)⟩ - -/-- 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)) - (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, ?_⟩ - 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) : - ∃ 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 - -end Subspace -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean deleted file mode 100644 index b22dc815ae..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean +++ /dev/null @@ -1,340 +0,0 @@ -/- -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.Szemeredi - -/-! -# 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. --/ - -@[expose] public section - -open Finset - -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 - -/-- 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 - -/-- 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 - -/-- 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 - -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] - -/-- 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_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 - 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⟩) - _ = δ * 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 - -lemma card_inter_interior (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 - 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] - omega - rw [← Finset.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) : - δ / 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 - 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) : - #(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))] - -end Combinatorics.ArithmeticProgression diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean deleted file mode 100644 index e207f218b6..0000000000 --- a/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean +++ /dev/null @@ -1,82 +0,0 @@ -/- -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.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 - -/-! -# 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 -coordinate types, and `Equiv.sumArrowEquivProdArrow` for the underlying decomposition of a word on -a sum of coordinate types. --/ - -@[expose] public section - -open Finset -open scoped BigOperators - -namespace DensityHalesJewett - -/-- 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 - -@[simp] -lemma mem_fiber {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] - {A : Finset (ι ⊕ κ → α)} {x : ι → α} {y : κ → α} : - y ∈ fiber A x ↔ Sum.elim x y ∈ A := by - simp [fiber] - -/-- Uniform density is the average of the uniform densities of the fibers. -/ -lemma average_density_fiber {α ι κ : Type*} [Fintype (ι → α)] [Fintype (κ → α)] - [Fintype (ι ⊕ κ → α)] [DecidableEq (ι ⊕ κ → α)] - (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 - · rintro ⟨x, y⟩ - - simp [Set.indicator_apply, Equiv.sumArrowEquivProdArrow] - -/-- A bounded function with large average exceeds a lower threshold on a quantitatively large -set. -/ -lemma density_ge_threshold {X : Type*} [Fintype X] [Nonempty X] - (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 - classical - let H := Finset.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 - rw [div_le_iff₀ h1b, sub_le_iff_le_add] - apply havg.trans - convert Finset.expect_le_expect (s := Finset.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] - ring - · intro x _ - by_cases hx : b ≤ f x <;> simp [H, hx] <;> linarith [hf₁ x] - -end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/Imports.lean b/LeanPool/DensityHalesJewett/Imports.lean deleted file mode 100644 index 33d6ab318d..0000000000 --- a/LeanPool/DensityHalesJewett/Imports.lean +++ /dev/null @@ -1,25 +0,0 @@ -/- -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.DensityHalesJewett -public import LeanPool.DensityHalesJewett.DensityHalesJewett -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation -public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions -public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi -public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word -public import LeanPool.DensityHalesJewett.Solution diff --git a/LeanPool/DensityHalesJewett/Solution.lean b/LeanPool/DensityHalesJewett/Solution.lean deleted file mode 100644 index 663dd60f40..0000000000 --- a/LeanPool/DensityHalesJewett/Solution.lean +++ /dev/null @@ -1,58 +0,0 @@ -/- -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.Szemeredi - -/-! -# Proofs of the asymptotic forms of the density theorems - -This module proves the asymptotic density theorems, deriving them from the explicit -threshold forms `Combinatorics.Line.exists_of_density` and -`Combinatorics.ArithmeticProgression.exists_of_density_nat` developed in this repository. - -A *combinatorial line* in the cube of words of length `n` over a finite alphabet `α` is a family -of `#α` words, one for each letter `x : α`, obtained from a single pattern by filling every -occurrence of a wildcard with `x`; at least one coordinate must be a wildcard, so distinct -letters give distinct words. This is Mathlib's `Combinatorics.Line α (Fin n)`, and `l x` is the word -of the line indexed by the letter `x`. --/ - -@[expose] public section - -open Filter Finset -open Combinatorics - -namespace Combinatorics.Line - -/-- The **Density Hales--Jewett theorem**: for a positive density `δ`, every sufficiently long word -length `n` has the property that any set of at least a `δ` fraction of the words of length `n` -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 α) δ, ?_⟩ - intro n hn A hAδ - exact exists_of_density α δ hδ n hn A hAδ - -end Combinatorics.Line - -namespace Combinatorics.ArithmeticProgression - -/-- **Szemeredi's theorem**: for a positive density `δ`, every sufficiently large `n` has the -property that any subset of `range n` of size at least `δ * n` contains an arithmetic progression -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 δ, ?_⟩ - intro n hn A hAn hAδ - obtain ⟨P, hP⟩ := exists_of_density_nat k hk δ hδ n hn A hAn hAδ - refine ⟨P.start, P.diff, P.diff_ne_zero, ?_⟩ - intro i - simpa [term, nsmul_eq_mul] using hP i - -end Combinatorics.ArithmeticProgression 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/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 From ed0b7349d6ce4a4a5f0aee506943b4a58214221b Mon Sep 17 00:00:00 2001 From: Gabriel Dahia Date: Sun, 8 Nov 2026 22:05:39 +0100 Subject: [PATCH 2/3] =?UTF-8?q?Update=20density=20Hales=E2=80=93Jewett=20t?= =?UTF-8?q?o=20the=20explicit=20Ackermann=20bounds?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Update the density Hales–Jewett project to gdahia/DensityHalesJewett at 478533c, which states the density Hales–Jewett, Szemerédi and Varnavides theorems with thresholds given by the Ackermann function, built on Shelah's bound from LeanPool.ShelahHalesJewett. The library moves from LeanPool.DensityHalesJewett.DensityHalesJewett to LeanPool.DensityHalesJewett, and the Palomar Solution module is dropped, since it only restates the library theorems. pullback stays defined from parameterPreimage, as in the previous pool version. Co-Authored-By: Claude Opus 5.5 --- LeanPool/DensityHalesJewett.lean | 39 +- LeanPool/DensityHalesJewett/Ackermann.lean | 643 ++++++++++++++ LeanPool/DensityHalesJewett/Canonization.lean | 213 +++++ .../DensityHalesJewett/DensityIncrement.lean | 149 ++++ .../DensityIncrement/CorrelatedFibers.lean | 364 ++++++++ .../DensityIncrement/Parameters.lean | 138 +++ .../StructuredCorrelation.lean | 378 ++++++++ LeanPool/DensityHalesJewett/FiniteUnions.lean | 211 +++++ .../DensityHalesJewett/GrahamRothschild.lean | 140 +++ LeanPool/DensityHalesJewett/HalesJewett.lean | 37 + LeanPool/DensityHalesJewett/Imports.lean | 26 + LeanPool/DensityHalesJewett/Induction.lean | 329 +++++++ LeanPool/DensityHalesJewett/Insensitive.lean | 833 ++++++++++++++++++ LeanPool/DensityHalesJewett/Main.lean | 170 ++++ LeanPool/DensityHalesJewett/Subspace.lean | 310 +++++++ LeanPool/DensityHalesJewett/Szemeredi.lean | 161 ++++ .../DensityHalesJewett/UniformFibers.lean | 518 +++++++++++ LeanPool/DensityHalesJewett/Varnavides.lean | 248 ++++++ LeanPool/DensityHalesJewett/Word.lean | 82 ++ LeanPool/projects/densityhalesjewett.yaml | 65 +- 20 files changed, 5012 insertions(+), 42 deletions(-) create mode 100644 LeanPool/DensityHalesJewett/Ackermann.lean create mode 100644 LeanPool/DensityHalesJewett/Canonization.lean create mode 100644 LeanPool/DensityHalesJewett/DensityIncrement.lean create mode 100644 LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean create mode 100644 LeanPool/DensityHalesJewett/DensityIncrement/Parameters.lean create mode 100644 LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean create mode 100644 LeanPool/DensityHalesJewett/FiniteUnions.lean create mode 100644 LeanPool/DensityHalesJewett/GrahamRothschild.lean create mode 100644 LeanPool/DensityHalesJewett/HalesJewett.lean create mode 100644 LeanPool/DensityHalesJewett/Imports.lean create mode 100644 LeanPool/DensityHalesJewett/Induction.lean create mode 100644 LeanPool/DensityHalesJewett/Insensitive.lean create mode 100644 LeanPool/DensityHalesJewett/Main.lean create mode 100644 LeanPool/DensityHalesJewett/Subspace.lean create mode 100644 LeanPool/DensityHalesJewett/Szemeredi.lean create mode 100644 LeanPool/DensityHalesJewett/UniformFibers.lean create mode 100644 LeanPool/DensityHalesJewett/Varnavides.lean create mode 100644 LeanPool/DensityHalesJewett/Word.lean diff --git a/LeanPool/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett.lean index 99960bb41b..4ffa319e7b 100644 --- a/LeanPool/DensityHalesJewett.lean +++ b/LeanPool/DensityHalesJewett.lean @@ -3,36 +3,31 @@ 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 -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation -public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions -public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Main -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi -public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides -public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word -public import LeanPool.DensityHalesJewett.Solution - +public import LeanPool.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.Main /-! # The density Hales–Jewett theorem and Szemerédi's theorem -Source: url:https://github.com/gdahia/densityhalesjewett +Source: arxiv:1209.4986, doi:10.1093/imrn/rnt041, url:https://github.com/gdahia/DensityHalesJewett/tree/478533c44dbfbb286362cb37e19b0ba53fdc5120 Authors: Gabriel Dahia Status: verified -Main declarations: `Combinatorics.Line.exists_of_density_atTop` -Tags: combinatorics +Main declarations: `Combinatorics.Line.exists_of_density`, `Combinatorics.Line.dhjNumber_le_ack`, + `Combinatorics.ArithmeticProgression.exists_of_density_nat`, + `Combinatorics.ArithmeticProgression.exists_many_of_density_nat` +Tags: combinatorics, ramsey-theory, hales-jewett, szemeredi-theorem, density-increment MSC: 05D10, 05A05, 11B75, 68R15 -/ -@[expose] public section +/-! +## Upstream attribution + +Adapted for Lean Pool from upstream commit `478533c44dbfbb286362cb37e19b0ba53fdc5120` by moving +the library under `LeanPool.DensityHalesJewett` and importing Shelah's bound from +`LeanPool.ShelahHalesJewett`. `pullback` is defined from `parameterPreimage`, as in the earlier +Lean Pool version of this project. The upstream Palomar `Challenge` and `Solution` modules are +omitted: `Solution` only restates `Combinatorics.Line.exists_of_density` and +`Combinatorics.ArithmeticProgression.exists_of_density_nat` under primed names. +-/ diff --git a/LeanPool/DensityHalesJewett/Ackermann.lean b/LeanPool/DensityHalesJewett/Ackermann.lean new file mode 100644 index 0000000000..88db583044 --- /dev/null +++ b/LeanPool/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.Insensitive +public import Mathlib.Computability.Ackermann +import LeanPool.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/Canonization.lean b/LeanPool/DensityHalesJewett/Canonization.lean new file mode 100644 index 0000000000..a2d2c0b99d --- /dev/null +++ b/LeanPool/DensityHalesJewett/Canonization.lean @@ -0,0 +1,213 @@ +/- +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.Subspace +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 +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 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 + +open Finset +open Combinatorics + +namespace DensityHalesJewett + +/-- Two words over `Option α` have the same support when their variable positions agree. -/ +def SameSupport {α ι : Type*} (x y : ι → Option α) : Prop := ∀ i, x i = none ↔ y i = none + +namespace Line + +variable {α ι : Type*} + +/-- The word obtained from a line by substituting a letter, or the variable itself, at its +variable positions. -/ +def fillOption (l : Combinatorics.Line α ι) (v : Option α) : ι → Option α := + fun i ↦ (l.idxFun i).elim v some + +@[simp] +lemma fillOption_some (l : Combinatorics.Line α ι) (a : α) : + fillOption l (some a) = some ∘ l a := by + funext i + cases h : l.idxFun i <;> simp [fillOption, Combinatorics.Line.coe_apply, h] + +end Line + +namespace Subspace + +variable {α η θ ι : Type*} + +/-- Substitute a word over `Option α` into a combinatorial subspace, marking variable positions +of the parameter word by `none`. -/ +def wordMap (V : Combinatorics.Subspace η α ι) (x : η → Option α) : ι → Option α := + fun i ↦ Sum.elim some x (V.idxFun i) + +lemma wordMap_compose (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) + (x : θ → Option α) : wordMap (compose V W) x = wordMap V (wordMap W x) := by + funext i + cases h : V.idxFun i <;> simp [wordMap, compose, h] + +lemma composeLine_idxFun (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : + (composeLine V l).idxFun = wordMap V l.idxFun := + rfl + +/-- Prepend a new variable direction, realized by a line on a fresh block of coordinates, to the +directions of a subspace. -/ +def consLine {ℓ : ℕ} {B B' : Type*} (V : Combinatorics.Subspace (Fin ℓ) α B) + (l : Combinatorics.Line α B') : Combinatorics.Subspace (Fin (ℓ + 1)) α (B ⊕ B') where + idxFun := Sum.elim (fun b ↦ (V.idxFun b).map id Fin.succ) + fun i ↦ (l.idxFun i).elim (Sum.inr 0) Sum.inl + proper e := by + induction e using Fin.cases with + | zero => + obtain ⟨i, hi⟩ := l.proper + exact ⟨Sum.inr i, by simp [hi]⟩ + | succ j => + obtain ⟨b, hb⟩ := V.proper j + exact ⟨Sum.inl b, by simp [hb]⟩ + +lemma wordMap_consLine {ℓ : ℕ} {B B' : Type*} (V : Combinatorics.Subspace (Fin ℓ) α B) + (l : Combinatorics.Line α B') (x : Fin (ℓ + 1) → Option α) : + wordMap (consLine V l) x + = Sum.elim (wordMap V fun i ↦ x i.succ) (Line.fillOption l (x 0)) := by + funext i + cases i with + | 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) : + Combinatorics.Subspace (Fin N) α (Fin n) where + idxFun i := if hi : i.val < N then Sum.inr ⟨i.val, hi⟩ else Sum.inl (Classical.arbitrary α) + proper e := ⟨Fin.castLE h e, by simp [Fin.castLE, e.isLt]⟩ + +end Subspace + +namespace Canonization + +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 with +`ℓ` variables on which every colouring becomes a function of the support alone. -/ +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 → C p (wordMap V x) s = C p (wordMap V y) s := by + classical + induction ℓ with + | zero => + intro P S _ _ + 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, _, 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 ↦ + 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] + 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, 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 + (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 [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 [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] + exact hV x y hxy + +end Canonization +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityIncrement.lean b/LeanPool/DensityHalesJewett/DensityIncrement.lean new file mode 100644 index 0000000000..b3cd2aac19 --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityIncrement.lean @@ -0,0 +1,149 @@ +/- +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.DensityIncrement.StructuredCorrelation +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 density increment on a subspace. +-/ + +@[expose] public section + +open Finset +open Combinatorics +open scoped BigOperators + +namespace DensityHalesJewett + +variable {N : ℕ} + +/-- Relative density in a composite subspace is relative density in the inner subspace of the +outer pullback. -/ +lemma Subspace.relativeDensity_compose {α η ζ ι : Type*} + [Fintype (η → α)] [Fintype (ζ → α)] [DecidableEq (η → α)] + [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace ζ α η) + (A : Finset (ι → α)) : + (relativeDensity (compose V W) A : ℝ) = + (relativeDensity W (pullback V A) : ℝ) := by + simp only [relativeDensity, pullback, parameterPreimage, mem_filter, mem_univ, true_and, + compose_apply] + +/-- 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 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 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 (F (δ / 4)) δ / 2 ≤ (Subspace.relativeDensity V A : ℝ) := by + by_cases hfree : IsLineFree A + · 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/DensityIncrement/CorrelatedFibers.lean b/LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean new file mode 100644 index 0000000000..e9ba2fe50b --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean @@ -0,0 +1,364 @@ +/- +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.DensityIncrement.Parameters +public import LeanPool.DensityHalesJewett.GrahamRothschild +public import LeanPool.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 with many complete restricted-alphabet lines. +-/ + +@[expose] public section + +open Finset +open Combinatorics +open scoped BigOperators + +namespace DensityHalesJewett + +/-- A finite word family contains no complete combinatorial line. -/ +def IsLineFree {α ι : Type*} (A : Finset (ι → α)) : Prop := + ∀ l : Combinatorics.Line α ι, ∃ a, l a ∉ A + +/-- Pull a word family back to the parameter cube of a subspace. -/ +noncomputable def pullback {η α ι : Type*} [Fintype (η → α)] + (V : Combinatorics.Subspace η α ι) + (A : Finset (ι → α)) : Finset (η → α) := + parameterPreimage V A + +/-- Pullback density agrees with the subspace-relative density. -/ +lemma dens_pullback {η α ι : Type*} [Fintype (η → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : + (pullback V A).dens = Subspace.relativeDensity V A := by + unfold pullback parameterPreimage Subspace.relativeDensity + congr 1 + ext x + 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 N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) ∧ + ((∀ l : Combinatorics.Line (Fin k) (Fin M), + 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), + ((univ.filter fun y ↦ + ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) < + 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)) ι} + (hfibers : ∀ x, + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) + (hlines : ∀ l : Combinatorics.Line (Fin k) (Fin M), + 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 N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ + ∀ l : Combinatorics.Line (Fin k) (Fin m), + 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 [V, Subspace.compose_apply] using hfibers (R x) + · intro l + let Rk := Subspace.repeatInitial (Fin k) hm hmM + simpa [V, R, Rk, Subspace.compose_apply, Subspace.composeLine_apply, + Subspace.repeatInitial_map] using + hlines (Subspace.composeLine Rk l) + +/-- 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)) ι} + (hfibers : ∀ x, + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : + δ / 4 ≤ + ((univ.filter fun y : κ → Fin (k + 1) ↦ + δ / 4 ≤ + ((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⟩⟩ + 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) + {δ : ℝ} (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)) ι} + (hfibers : ∀ x, + δ - Parameters.η k N δ ^ 2 / 2 ≤ ((fiber A (W x)).dens : ℝ)) : + ∃ l : Combinatorics.Line (Fin k) (Fin M), + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ + ∀ a, Sum.elim (W (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ) := by + 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) + {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))} {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 N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) ∧ + ∀ l : Combinatorics.Line (Fin k) (Fin m), + 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 (η → α) := + 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*} + [Fintype (Combinatorics.Line (Fin k) (Fin m))] + [DecidableEq (ι ⊕ κ → Fin (k + 1))] + (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) ι) + (A : Finset (ι ⊕ κ → Fin (k + 1))) (y : κ → Fin (k + 1)) : + Finset (Combinatorics.Line (Fin k) (Fin m)) := + 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, by double counting. -/ +lemma average_suffixPullback_lower {α η ι κ : Type*} [Nonempty α] [Fintype (η → α)] + [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] + {V : Combinatorics.Subspace η α ι} {A : Finset (ι ⊕ κ → α)} {r : ℝ} + (hV : ∀ x, r ≤ ((fiber A (V x)).dens : ℝ)) : + 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 < η) + (havg : δ - η ^ 2 / 2 ≤ 𝔼 x : X, f x) + (hupper : ∀ x, f x < δ + η ^ 2 / 2) : + 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, 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))} {θ : ℝ} + (hV : ∀ l : Combinatorics.Line (Fin k) (Fin m), + θ ≤ ((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 + 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) + (hf₁ : ∀ x, f x ≤ 1) (havg : θ ≤ 𝔼 x : X, f x) : + θ / 2 ≤ ((univ.filter fun x ↦ θ / 2 ≤ f x).dens : ℝ) := by + refine le_trans ?_ + (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} {η θ : ℝ} + (hS : 1 - η ≤ (S.dens : ℝ)) (hT : θ / 2 ≤ (T.dens : ℝ)) + (hηθ : η < θ / 2) : ∃ x, x ∈ S ∧ x ∈ T := by + classical + by_contra! h + have hunion : ((S ∪ T).dens : ℝ) = (S.dens : ℝ) + (T.dens : ℝ) := by + 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. + +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) + {ι κ : 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 N δ ^ 2 / 2 ≤ ((fiber A (V x)).dens : ℝ)) + (hlines : ∀ l : Combinatorics.Line (Fin k) (Fin m), + Parameters.θ k N δ ≤ + ((univ.filter fun y ↦ + ∀ a, Sum.elim (V (Fin.castSucc ∘ l a)) y ∈ A).dens : ℝ)) : + (∃ y, δ + Parameters.η k N δ ^ 2 / 2 ≤ + ((suffixPullback V A y).dens : ℝ)) ∨ + ∃ 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) + {m : ℕ} [Fintype (Combinatorics.Line (Fin k) (Fin m))] + [Nonempty (Combinatorics.Line (Fin k) (Fin m))] + (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 N δ ^ 2 / 2 ≤ (Subspace.relativeDensity V A : ℝ)) ∨ + ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n), + δ - 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 + 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/DensityIncrement/Parameters.lean b/LeanPool/DensityHalesJewett/DensityIncrement/Parameters.lean new file mode 100644 index 0000000000..f3c2b9b47a --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityIncrement/Parameters.lean @@ -0,0 +1,138 @@ +/- +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.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 `γ` 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 + +namespace DensityHalesJewett + +namespace Parameters + +/-- 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 θ + 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) (Nat.cast_pos.2 (θ_denominator_pos k N)) + +/-- 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. -/ +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 k N hδρ) (θ_pos k N hδ).le (hδ.trans_le hδρ).le + · 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 N : ℕ) {δ : ℝ} (hδ : 0 < δ) : 0 < η k N δ := by + unfold η + apply lt_min + · positivity [θ_pos k N hδ] + · apply lt_min + · positivity [θ_pos k N hδ] + · positivity + +/-- 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. -/ +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 + · exact mul_le_mul hδρ hηsq (by positivity) (hδ.trans_le hδρ).le + · positivity + · 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) (N : ℕ) {δ : ℝ} (hδ : 0 < δ) : 0 < γ k N δ := by + have hkpos : (0 : ℝ) < k := by exact_mod_cast (by omega : 0 < k) + unfold γ + positivity [η_pos k N hδ] + +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 k N hδ] + +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 N : ℕ) (δ : ℝ) : γ k N δ ≤ η k N δ ^ 2 / 2 := by + unfold γ + exact (min_le_right _ _).trans (min_le_left _ _) + +lemma γ_le_three_mul_η (k N : ℕ) (δ : ℝ) : γ k N δ ≤ 3 * η k N δ := by + unfold γ + exact (min_le_right _ _).trans (min_le_right _ _) + +/-- The correlated-fiber threshold is at most one in the admissible parameter range. -/ +lemma θ_le_one (k N : ℕ) {δ : ℝ} (hδ₁ : δ ≤ 1) : θ k N δ ≤ 1 := by + unfold θ + 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 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 + +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean b/LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean new file mode 100644 index 0000000000..e0f3e10c42 --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean @@ -0,0 +1,378 @@ +/- +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.DensityIncrement.CorrelatedFibers +public import LeanPool.DensityHalesJewett.Insensitive +import Mathlib.Algebra.BigOperators.Field +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. 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. +-/ + +@[expose] public section + +open Finset +open Combinatorics +open scoped BigOperators + +namespace DensityHalesJewett + +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. -/ +def replaceLastLetter {k m : ℕ} (i : Fin k) (x : Fin m → Fin (k + 1)) : + Fin m → Fin (k + 1) := + fun c ↦ if x c = Fin.last k then i.castSucc else x c + +/-- The endpoint family associated with one restricted-alphabet letter. -/ +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)) := + 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)) := + Fintype.piFinset fun _ ↦ {Fin.last k}ᶜ + +lemma card_restrictedParameterWords (k m : ℕ) : + (restrictedParameterWords k m).card = k ^ m := by + simp [restrictedParameterWords, card_compl] + +lemma dens_restrictedParameterWords (k m : ℕ) : + ((restrictedParameterWords k m).dens : ℝ) = ((k : ℝ) / (k + 1)) ^ m := by + simp [nnratCast_dens, card_restrictedParameterWords, div_pow] + +/-- Each endpoint family is insensitive to interchanging its selected letter with the final +letter. -/ +lemma endpointFamily_isInsensitive {k m n : ℕ} + (A : Finset (Fin n → Fin (k + 1))) + (V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)) (i : Fin k) : + IsInsensitive i.castSucc (Fin.last k) (endpointFamily A V i) := by + intro x y hxy + have hreplace : replaceLastLetter i x = replaceLastLetter i y := by + 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, mem_filter, mem_univ, true_and] + rw [hreplace] + +/-- Encode a restricted-alphabet line by the word using the final letter on its wildcard +coordinates. -/ +private def lineEndpoint {k m : ℕ} (l : Combinatorics.Line (Fin k) (Fin m)) : + Fin m → Fin (k + 1) := + fun c ↦ + match l.idxFun c with + | none => Fin.last k + | some a => a.castSucc + +/-- The endpoint word remembers every fixed letter and every wildcard coordinate of a line. -/ +private lemma lineEndpoint_injective {k m : ℕ} : + Function.Injective (lineEndpoint : Combinatorics.Line (Fin k) (Fin m) → + (Fin m → Fin (k + 1))) := by + rintro ⟨f, hf⟩ ⟨g, hg⟩ hll + congr + funext c + have hc := congrFun hll c + cases hfc : f c <;> cases hgc : g c <;> + simp_all [lineEndpoint, Fin.castSucc_ne_last, eq_comm (a := Fin.last 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))] + (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 : θ / 2 ≤ + ((univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + ∀ a, V (Fin.castSucc ∘ l a) ∈ A).dens : ℝ)) : + θ / 4 ≤ ((IsInsensitive.intersection (endpointFamily A V)).dens : ℝ) := by + classical + set s := univ.filter fun l : Combinatorics.Line (Fin k) (Fin m) ↦ + ∀ a, V (Fin.castSucc ∘ l a) ∈ A + 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))} + (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⟩ := 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) + proper := ⟨c, ite_eq_left hc⟩ + } + have hp_last : p (Fin.last k) = x := by + funext i + 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 [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] + simpa [endpointFamily] using IsInsensitive.mem_intersection.mp hxinter i + · rw [hp_last] + simpa [pullback, parameterPreimage] using hxpull + +/-- Many complete restricted-alphabet lines yield a large insensitive intersection whose part +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δ₁ : δ ≤ 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 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 N δ / 4 ≤ ((IsInsensitive.intersection C).dens : ℝ) ∧ + ((pullback V A ∩ IsInsensitive.intersection C).dens : ℝ) ≤ + Parameters.η k N δ := by + rw [← dens_restrictedParameterWords] at hm_large + refine ⟨endpointFamily A V, endpointFamily_isInsensitive A V, ?_, ?_⟩ + · 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} {δ η θ : ℝ} + (hδ₀ : 0 ≤ δ) (hη₀ : 0 ≤ η) (hA : δ - 2 * η ≤ (A.dens : ℝ)) + (hC : θ / 4 ≤ (C.dens : ℝ)) + (hAC : ((A ∩ C).dens : ℝ) ≤ η) + (hgain : (δ + 6 * η) * (1 - θ / 4) ≤ δ - 3 * η) : + (δ + 6 * η) * ((Cᶜ).dens : ℝ) ≤ ((A ∩ Cᶜ).dens : ℝ) ∧ + δ - 3 * η ≤ ((A ∩ Cᶜ).dens : ℝ) := by + have hsplitA : ((A ∩ C).dens : ℝ) + ((A ∩ Cᶜ).dens : ℝ) = (A.dens : ℝ) := by + norm_cast + simpa [sdiff_eq_inter_compl] using dens_inter_add_dens_sdiff A C + have hsplitC : ((Cᶜ).dens : ℝ) + (C.dens : ℝ) = 1 := by + norm_cast + 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 := + 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] + +/-- 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 univ + +/-- 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 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 (complPieceFamily C i) = complPiece C i := by + ext 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) : + univ.biUnion (complPiece C) = (IsInsensitive.intersection C)ᶜ := by + ext 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) : + ((univ : Finset (Fin k)) : Set (Fin k)).PairwiseDisjoint (complPiece C) := by + intro i _ j _ hij + 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 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, ((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 N δ) * + ((IsInsensitive.intersection C)ᶜ.dens : ℝ) ≤ + ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) + (hlarge : δ - 3 * Parameters.η k N δ ≤ + ((A ∩ (IsInsensitive.intersection C)ᶜ).dens : ℝ)) : + ∃ i : Fin k, + 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) + {m n : ℕ} (hm : 1 ≤ m) + [Nonempty (Combinatorics.Line (Fin k) (Fin m))] + {δ : ℝ} (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 N δ ≤ ((IsInsensitive.intersection D).dens : ℝ) ∧ + (δ + Parameters.γ k N δ) * ((IsInsensitive.intersection D).dens : ℝ) ≤ + ((pullback V A ∩ IsInsensitive.intersection D).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 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/FiniteUnions.lean b/LeanPool/DensityHalesJewett/FiniteUnions.lean new file mode 100644 index 0000000000..a6049356fb --- /dev/null +++ b/LeanPool/DensityHalesJewett/FiniteUnions.lean @@ -0,0 +1,211 @@ +/- +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.Data.Finset.Max +public import LeanPool.ShelahHalesJewett.HalesJewett +import LeanPool.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 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 Function +open Combinatorics + +namespace DensityHalesJewett +namespace FiniteUnions + +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 ⟨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 [hi]⟩ + · intro j + simp only [disjoint_left, mem_filter, mem_univ, true_and] + grind + · intro j j' hjj' + simp only [onFun, disjoint_left, mem_filter, mem_univ, true_and] + grind + · intro J + rw [← hc fun j ↦ decide (j ∈ J)] + congr 1 + ext i + 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 + +/-- 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 + 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 {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 => + intro C + refine ⟨Fin.elim0, fun i ↦ i.elim0, fun i ↦ i.elim0, Fin.elim0, ?_⟩ + intro J hJ + simp [eq_empty_of_isEmpty J] at hJ + | succ t ih => + 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 j + exact (disjoint_biUnion_right _ _ _).2 fun g _ ↦ hE₀G g + · intro J hJ + 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 {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 + 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, ?_⟩ + intro J hJ + rw [← image_biUnion, hf _ (hJ.image _)] + obtain ⟨j, -, hj⟩ := mem_image.1 (min'_mem _ (hJ.image (T.orderEmbOfFin hTcard))) + rw [← hj] + simpa using hT (T.orderEmbOfFin_mem hTcard j) + +end FiniteUnions +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/GrahamRothschild.lean b/LeanPool/DensityHalesJewett/GrahamRothschild.lean new file mode 100644 index 0000000000..6d5c271a6a --- /dev/null +++ b/LeanPool/DensityHalesJewett/GrahamRothschild.lean @@ -0,0 +1,140 @@ +/- +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.Canonization +public import LeanPool.DensityHalesJewett.FiniteUnions + +/-! +# The Graham--Rothschild theorem for combinatorial lines + +The finite-unions focusing argument, block canonization, and the line-colouring form of the +Graham--Rothschild theorem needed by the density proof. + +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. 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 Function +open Combinatorics + +namespace DensityHalesJewett + +namespace GrahamRothschild + +open Subspace + +/-- 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, +with a fixed letter on all remaining coordinates. -/ +noncomputable def ofBlocks (a₀ : α) (E : Fin m → Finset ι) (hE : ∀ j, (E j).Nonempty) + (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 + 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 : 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⟩, 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₀ := + 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)} + (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 + intro i + 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] + 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] + 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) → κ) + (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) → κ) + (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. -/ +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 ⟨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 [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 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), mapLine V l ∈ L) ∨ + (∀ l : Combinatorics.Line α (Fin m), mapLine V l ∉ L) := by + classical + 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/HalesJewett.lean b/LeanPool/DensityHalesJewett/HalesJewett.lean new file mode 100644 index 0000000000..9d0bc570e2 --- /dev/null +++ b/LeanPool/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/Imports.lean b/LeanPool/DensityHalesJewett/Imports.lean new file mode 100644 index 0000000000..9f1476a1a5 --- /dev/null +++ b/LeanPool/DensityHalesJewett/Imports.lean @@ -0,0 +1,26 @@ +/- +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.DensityHalesJewett +public import LeanPool.DensityHalesJewett.Ackermann +public import LeanPool.DensityHalesJewett.Canonization +public import LeanPool.DensityHalesJewett.DensityIncrement +public import LeanPool.DensityHalesJewett.DensityIncrement.CorrelatedFibers +public import LeanPool.DensityHalesJewett.DensityIncrement.Parameters +public import LeanPool.DensityHalesJewett.DensityIncrement.StructuredCorrelation +public import LeanPool.DensityHalesJewett.FiniteUnions +public import LeanPool.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.HalesJewett +public import LeanPool.DensityHalesJewett.Induction +public import LeanPool.DensityHalesJewett.Insensitive +public import LeanPool.DensityHalesJewett.Main +public import LeanPool.DensityHalesJewett.Subspace +public import LeanPool.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.Varnavides +public import LeanPool.DensityHalesJewett.Word diff --git a/LeanPool/DensityHalesJewett/Induction.lean b/LeanPool/DensityHalesJewett/Induction.lean new file mode 100644 index 0000000000..b549a75fcb --- /dev/null +++ b/LeanPool/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.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/Insensitive.lean b/LeanPool/DensityHalesJewett/Insensitive.lean new file mode 100644 index 0000000000..cd0540aced --- /dev/null +++ b/LeanPool/DensityHalesJewett/Insensitive.lean @@ -0,0 +1,833 @@ +/- +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.UniformFibers +import Mathlib.Algebra.BigOperators.Field +import Mathlib.Data.Set.Finite.Lattice +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Data.NNRat.BigOperators + +/-! +# Insensitive word families and tilings + +Boolean closure of insensitive families and the subspace-tiling results used in the density +increment argument. +-/ + +@[expose] public section + +open Finset +open Combinatorics +open scoped BigOperators + +namespace DensityHalesJewett + +/-- Two words are equivalent after freely interchanging the letters `i` and `j`. -/ +def InsensitiveEquiv {α ι : Type*} (i j : α) (x y : ι → α) : Prop := + ∀ a, a ≠ i → a ≠ j → ∀ c, (x c = a ↔ y c = a) + +/-- Membership in an `(i,j)`-insensitive family is constant on insensitive-equivalence classes. -/ +def IsInsensitive {α ι : Type*} (i j : α) (D : Finset (ι → α)) : Prop := + ∀ ⦃x y⦄, InsensitiveEquiv i j x y → (x ∈ D ↔ y ∈ D) + +/-- Transport a word family along an equivalence of coordinate types. -/ +def transportWords {α ι ι' : Type*} + (e : ι ≃ ι') (D : Finset (ι → α)) : Finset (ι' → α) := + D.map ((e.arrowCongr (Equiv.refl α)).toEmbedding) + +@[simp] +lemma mem_transportWords {α ι ι' : Type*} + {e : ι ≃ ι'} {D : Finset (ι → α)} {w : ι' → α} : + w ∈ transportWords e D ↔ w ∘ e ∈ D := by + 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, 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 + +/-- Reindexing coordinates preserves insensitivity. -/ +lemma reindex {α ι ι' : Type*} + {i j : α} {D : Finset (ι → α)} (e : ι ≃ ι') (hD : IsInsensitive i j D) : + IsInsensitive i j (DensityHalesJewett.transportWords e D) := by + intro x y hxy + simp only [mem_transportWords] + apply hD + intro a hai haj c + exact hxy a hai haj (e c) + +/-- Fixing a prefix of coordinates preserves insensitivity of the remaining section. -/ +lemma fiberSection {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] + {i j : α} {D : Finset (ι ⊕ κ → α)} (hD : IsInsensitive i j D) (v : ι → α) : + IsInsensitive i j (DensityHalesJewett.fiber D v) := by + intro x y hxy + simp only [mem_fiber] + apply hD + intro a hai haj c + cases c with + | inl c => simp only [Sum.elim_inl] + | inr c => exact hxy a hai haj c + +/-- Complements preserve insensitivity. -/ +lemma compl {α ι : Type*} [Fintype (ι → α)] [DecidableEq (ι → α)] + {i j : α} {D : Finset (ι → α)} (hD : IsInsensitive i j D) : + IsInsensitive i j Dᶜ := by + intro x y hxy + simp only [mem_compl, hD hxy] + +/-- The part of `D` left uncovered by a set of subspaces. -/ +noncomputable def uncovered {η α ι : Type*} [Fintype (η → α)] + [DecidableEq (ι → α)] (D : Finset (ι → α)) + (𝒱 : Set (Combinatorics.Subspace η α ι)) : Finset (ι → α) := by + 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 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, ← singleton_subset_iff, Finset.le_inf_iff] + +/-- 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 → + ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)), + IsTiling 𝒱 D ∧ ((uncovered D 𝒱).dens : ℝ) < 2 * β + +/-- Differences preserve insensitivity. -/ +lemma sdiff {α ι : Type*} [DecidableEq (ι → α)] + {i j : α} {D E : Finset (ι → α)} (hD : IsInsensitive i j D) + (hE : IsInsensitive i j E) : IsInsensitive i j (D \ E) := by + intro x y hxy + simp [hD hxy, hE hxy] + +/-- Insensitive-equivalent prefixes have the same section. -/ +lemma fiber_congr {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] + {i j : α} {D : Finset (ι ⊕ κ → α)} (hD : IsInsensitive i j D) {v w : ι → α} + (hvw : InsensitiveEquiv i j v w) : + DensityHalesJewett.fiber D v = DensityHalesJewett.fiber D w := by + ext y + simp only [mem_fiber] + apply hD + intro a hai haj c + cases c with + | inl c => exact hvw a hai haj c + | inr c => simp only [Sum.elim_inr] + +end IsInsensitive + +/-- 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 ∘ regroup e s = Sum.elim u (Sum.elim r x ∘ s) ∘ e := by + funext c + 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] + +/-- 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 (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] + +/-- 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*} + [Fintype α] [DecidableEq α] [Fintype ι] [Fintype ω] + [Fintype ν] [DecidableEq ν] + (e : ι ≃ ω ⊕ ν) (A B : Finset (ι → α)) (v : ω → α) : + DensityHalesJewett.fiber (transportWords e (A \ B)) v = + DensityHalesJewett.fiber (transportWords e A) v \ + DensityHalesJewett.fiber (transportWords e B) v := by + ext y + 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 [← 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 [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 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 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 (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] + | inr e => + simp only [V.apply_inr hc, Function.comp_apply] + by_cases hx : x e = Fin.last k + · rw [dite_eq_left hx, hx, Fin.castSuccEmb_apply] + apply iff_of_false + · intro h + exact hal h.symm + · intro h + exact hai h.symm + · rw [dite_eq_right hx, Fin.castSuccEmb_apply, Fin.castSucc_castPred] + +/-- 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))) : + Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b) := by + classical + exact if h : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), + Subspace.IsContained V E then Classical.choose h + else Subspace.repeatInitial (Fin (k + 1)) hm hmb + +lemma pickSubspace_isContained {k m b : ℕ} (hm : 1 ≤ m) (hmb : m ≤ b) + {E : Finset (Fin b → Fin (k + 1))} + (h : ∃ V : Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin b), + Subspace.IsContained V E) : + Subspace.IsContained (pickSubspace hm hmb E) E := by + classical + rw [pickSubspace, dite_eq_left h] + exact Classical.choose_spec h + +namespace IsInsensitive + +/-- 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, mem_transportWords, mem_uncovered, IsInsensitive.placeTiles, + Set.mem_iUnion, Set.mem_image, forall_exists_index, and_imp] + rw [and_congr_right_iff] + intro _ + constructor + · 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 + 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))} {β : ℝ} + (hgood : β ≤ (good.dens : ℝ)) + (hnonempty : ∀ z ∈ good, (fiber (transportWords e R) z).Nonempty) : + β / ((k : ℝ) + 1) ^ b ≤ (R.dens : ℝ) := by + classical + have hcard : (Fintype.card (Fin b → Fin (k + 1)) : ℝ) = ((k : ℝ) + 1) ^ b := by + simp only [Fintype.card_pi_const, Fintype.card_fin, Nat.cast_pow, Nat.cast_add, + Nat.cast_one] + have hfiber (z : ζ → Fin (k + 1)) (hz : z ∈ good) : + 1 / ((k : ℝ) + 1) ^ b ≤ ((fiber (transportWords e R) z).dens : ℝ) := by + rw [← hcard] + exact one_div_card_le_dens (hnonempty z hz) + have haverage : (R.dens : ℝ) = + 𝔼 z : (ζ → Fin (k + 1)), ((fiber (transportWords e R) z).dens : ℝ) := by + 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 [← 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 [Pi.one_apply, mul_one] using hfiber z hz + · rw [Set.indicator_of_notMem (by simpa using hz), mul_zero] + positivity + +/-- 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 + 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' + 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`, 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 => + 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 + +/-- 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 + 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 (ι → α)} + (hD : IsInsensitive a b D) : IsInsensitive a b (parameterPreimage V D) := by + classical + intro x y hxy + simp only [parameterPreimage, mem_filter, mem_univ, true_and] + apply hD + intro c hca hcb i + cases hi : V.idxFun i with + | inl d => rw [V.apply_inl hi, V.apply_inl hi] + | inr e => + rw [V.apply_inr hi, V.apply_inr hi] + exact hxy c hca hcb e + +/-- 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. -/ +private lemma dens_map_subspace_eq_mul_range {α η ι : Type*} + [Fintype (η → α)] [Fintype (ι → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (A : Finset (η → α)) : + ((A.map ⟨V, Subspace.injective V⟩).dens : ℝ) = + (A.dens : ℝ) * ((Subspace.range V).dens : ℝ) := by + 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 [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 := + ∀ hrk : r ≤ k, ∀ D : Fin r → Finset (Fin n → Fin (k + 1)), + (∀ i, IsInsensitive (Fin.castLE hrk i).castSucc (Fin.last k) (D i)) → + ∃ 𝒱 : Set (Combinatorics.Subspace (Fin m) (Fin (k + 1)) (Fin n)), + IsTiling 𝒱 (intersection D) ∧ ((uncovered (intersection D) 𝒱).dens : ℝ) < 2 * r * β + +/-- One indexed insensitive family is exactly the one-family tiling statement. -/ +private lemma intersectionTilingSufficient_one {β : ℝ} (h : TilingSufficient k m β n) : + IntersectionTilingSufficient k 1 m β n := by + intro hrk D hD + have hD₀ : intersection D = D 0 := by + ext x + simp [Fin.forall_fin_one] + 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 + 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 + 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 + 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 + 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 {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)), + 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/Main.lean b/LeanPool/DensityHalesJewett/Main.lean new file mode 100644 index 0000000000..eabe064d02 --- /dev/null +++ b/LeanPool/DensityHalesJewett/Main.lean @@ -0,0 +1,170 @@ +/- +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.Varnavides +public import Mathlib.Computability.Ackermann +public import Mathlib.Order.Lattice.Nat +import LeanPool.DensityHalesJewett.Ackermann +import Mathlib.Algebra.Order.BigOperators.Expect +import Mathlib.Analysis.Real.Sqrt + +/-! +# 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 + +open Finset +open Combinatorics + +namespace Combinatorics.Line + +/-- 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 → α)} + (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⟩⟩ + 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 := card_pos.mp <| by + exact_mod_cast hδ.trans_le hAδ + 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 : 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 + 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 [mem_map_equiv] at hl + change (e.symm ∘ l (e x)) ∈ A at hl + rwa [← e.symm_apply_apply x, Combinatorics.Line.map_apply] + +/-- 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 α + · 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/Subspace.lean b/LeanPool/DensityHalesJewett/Subspace.lean new file mode 100644 index 0000000000..336f72fbe7 --- /dev/null +++ b/LeanPool/DensityHalesJewett/Subspace.lean @@ -0,0 +1,310 @@ +/- +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.Data.Finset.Density + +/-! +# Combinatorial subspaces + +Ranges, containment, relative density, alphabet restriction, and lines inside Mathlib's +`Combinatorics.Subspace`. +-/ + +@[expose] public section + +open Finset Function +open Combinatorics + +namespace DensityHalesJewett +namespace Subspace + +variable {η α ι : Type*} + +/-- Evaluation by a fixed combinatorial subspace is injective. -/ +lemma injective (V : Combinatorics.Subspace η α ι) : + Function.Injective V := by + intro x y hxy + funext e + obtain ⟨i, hi⟩ := V.proper e + simpa [V.apply_inr hi] using congrFun hxy i + +/-- The finite range of a combinatorial subspace. -/ +def range [Fintype (η → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) : Finset (ι → α) := + univ.image V + +@[simp] +lemma mem_range [Fintype (η → α)] [DecidableEq (ι → α)] + {V : Combinatorics.Subspace η α ι} {w : ι → α} : + w ∈ range V ↔ ∃ x, V x = w := by + simp [range] + +/-- A subspace is contained in a finite word family when all its evaluations belong to it. -/ +def IsContained (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : Prop := + ∀ x, V x ∈ A + +/-- Compose a parameter subspace with an ambient subspace. -/ +def compose (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) : + Combinatorics.Subspace θ α ι where + idxFun i := (V.idxFun i).elim Sum.inl W.idxFun + proper e := by + obtain ⟨j, hj⟩ := W.proper e + obtain ⟨i, hi⟩ := V.proper j + refine ⟨i, ?_⟩ + simp only [hi, Sum.elim_inr, hj] + +@[simp] +lemma compose_apply (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α η) + (x : θ → α) : compose V W x = V (W x) := by + funext i + cases hi : V.idxFun i <;> simp [compose, Combinatorics.Subspace.coe_apply, hi] + +/-- Repeat the first `m` parameter directions to fill a larger `M`-coordinate cube. -/ +def repeatInitial {m M : ℕ} (α : Type*) (hm : 1 ≤ m) (hmM : m ≤ M) : + Combinatorics.Subspace (Fin m) α (Fin M) where + idxFun i := Sum.inr <| + if hi : i.val < m then ⟨i.val, hi⟩ else ⟨0, Nat.zero_lt_of_lt hm⟩ + proper e := by + refine ⟨Fin.castLE hmM e, ?_⟩ + simp only [Fin.castLE, e.isLt, ↓reduceDIte] + +@[simp] +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 + simp only [Function.comp_apply, (repeatInitial α hm hmM).apply_inr rfl, + (repeatInitial β hm hmM).apply_inr rfl] + +/-- Concatenate subspaces on disjoint coordinate blocks. -/ +def concat (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α κ) : + Combinatorics.Subspace (η ⊕ θ) α (ι ⊕ κ) where + idxFun := Sum.elim + (fun i ↦ (V.idxFun i).elim Sum.inl (fun e ↦ Sum.inr <| Sum.inl e)) + (fun i ↦ (W.idxFun i).elim Sum.inl (fun e ↦ Sum.inr <| Sum.inr e)) + proper e := by + cases e with + | inl e => + obtain ⟨i, hi⟩ := V.proper e + refine ⟨Sum.inl i, ?_⟩ + simp only [hi, Sum.elim_inl, Sum.elim_inr] + | inr e => + obtain ⟨i, hi⟩ := W.proper e + refine ⟨Sum.inr i, ?_⟩ + simp only [hi, Sum.elim_inr] + +@[simp] +lemma concat_apply (V : Combinatorics.Subspace η α ι) (W : Combinatorics.Subspace θ α κ) + (x : η → α) (y : θ → α) : concat V W (Sum.elim x y) = + Sum.elim (V x) (W y) := by + funext i + cases i with + | inl i => cases hi : V.idxFun i <;> simp [concat, Combinatorics.Subspace.coe_apply, hi] + | inr i => cases hi : W.idxFun i <;> simp [concat, Combinatorics.Subspace.coe_apply, hi] + +/-- Regard a line as a one-dimensional subspace parameterized by `Fin 1`. -/ +def lineToSubspaceFinOne (l : Combinatorics.Line α ι) : + Combinatorics.Subspace (Fin 1) α ι := + l.toSubspaceUnit.reindex finOneEquiv.symm (Equiv.refl _) (Equiv.refl _) + +@[simp] +lemma lineToSubspaceFinOne_apply (l : Combinatorics.Line α ι) (x : Fin 1 → α) : + lineToSubspaceFinOne l x = l (x 0) := by + funext i + simp [lineToSubspaceFinOne, Fin.eq_zero] + +/-- Relative density on a subspace, defined on its parameter cube. -/ +def relativeDensity [Fintype (η → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (A : Finset (ι → α)) : ℚ≥0 := + (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. -/ +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] + +@[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] + +/-- Regard the composite of a parameter line with a subspace as a line in that subspace. -/ +def composeLineToLines [Fintype (η → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : Lines V := + ⟨composeLine V l, fun a ↦ mem_range.mpr ⟨l a, (composeLine_apply V l a).symm⟩⟩ + +/-- The canonical parameter word representing a point of a line contained in a subspace. -/ +noncomputable def parameterWord [Fintype (η → α)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (q : Lines V) (a : α) : η → α := + Classical.choose <| mem_range.mp (q.2 a) + +lemma parameterWord_apply [Fintype (η → α)] [DecidableEq (ι → α)] + {V : Combinatorics.Subspace η α ι} (q : Lines V) (a : α) : + V (parameterWord V q a) = q.1 a := + Classical.choose_spec <| mem_range.mp (q.2 a) + +/-- A chosen coordinate on which a subspace realizes a given parameter direction. -/ +noncomputable def properCoordinate (V : Combinatorics.Subspace η α ι) (e : η) : ι := + Classical.choose <| V.proper e + +lemma properCoordinate_spec (V : Combinatorics.Subspace η α ι) (e : η) : + V.idxFun (properCoordinate V e) = Sum.inr e := + Classical.choose_spec <| V.proper e + +/-- Recover the parameter-cube line underlying an ambient line contained in a subspace. -/ +noncomputable def uncomposeLine [Fintype (η → α)] [DecidableEq (ι → α)] [Nontrivial α] + (V : Combinatorics.Subspace η α ι) (q : Lines V) : Combinatorics.Line α η where + idxFun e := q.1.idxFun (properCoordinate V e) + proper := by + obtain ⟨j, hj⟩ := q.1.proper + cases hVj : V.idxFun j with + | inl b => + obtain ⟨a, hab⟩ := exists_ne b + refine absurd ?_ hab + 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 + | none => exact ⟨e, hq⟩ + | 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 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 (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 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 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. -/ +noncomputable def linesEquiv [Fintype (η → α)] [DecidableEq (ι → α)] + [Nontrivial α] (V : Combinatorics.Subspace η α ι) : + Combinatorics.Line α η ≃ Lines V where + toFun := composeLineToLines V + invFun := uncomposeLine V + left_inv := by + intro l + apply Combinatorics.Line.coe_injective + funext a + apply injective V + rw [uncomposeLine_apply] + exact composeLine_apply V l a + right_inv := by + intro q + apply Subtype.ext + change composeLine V (uncomposeLine V q) = q.1 + apply Combinatorics.Line.coe_injective + funext a + rw [composeLine_apply] + 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 α η) : + Combinatorics.Line α ι := + composeLine V l + +lemma mapLine_eq_composeLine (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) : + mapLine V l = composeLine V l := + rfl + +@[simp] +lemma mapLine_apply (V : Combinatorics.Subspace η α ι) (l : Combinatorics.Line α η) + (a : α) : mapLine V l a = V (l a) := + composeLine_apply V l a + +/-- Restrict the variable letters of a subspace along an alphabet embedding. -/ +def restrictAlphabet {β : Type*} [Fintype (η → β)] [DecidableEq (ι → α)] + (V : Combinatorics.Subspace η α ι) (e : β ↪ α) : Finset (ι → α) := + 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 + +/-- Fix the coordinates outside a designated block, keeping a subspace on the block. -/ +def transportSubspace {α η ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (z : ω → α) + (V : Combinatorics.Subspace η α ν) : Combinatorics.Subspace η α ι where + idxFun c := Sum.elim (fun a ↦ Sum.inl (z a)) V.idxFun (e c) + proper x := by + obtain ⟨c, hc⟩ := V.proper x + exact ⟨e.symm (Sum.inr c), by simp only [Equiv.apply_symm_apply, Sum.elim_inr, hc]⟩ + +@[simp] +lemma transportSubspace_apply {α η ι ω ν : Type*} (e : ι ≃ ω ⊕ ν) (z : ω → α) + (V : Combinatorics.Subspace η α ν) (x : η → α) : + transportSubspace e z V x = Sum.elim z (V x) ∘ e := by + funext c + simp only [Combinatorics.Subspace.coe_apply, transportSubspace, Function.comp_apply] + cases e c <;> simp only [Sum.elim_inl, Sum.elim_inr, id_eq, Combinatorics.Subspace.coe_apply] + +/-- The preimage of a word family in a subspace parameter cube. -/ +noncomputable def parameterPreimage {η α ι : Type*} [Fintype (η → α)] + (V : Combinatorics.Subspace η α ι) (D : Finset (ι → α)) : Finset (η → α) := by + classical + apply univ.filter + intro x + exact V x ∈ D + +end DensityHalesJewett diff --git a/LeanPool/DensityHalesJewett/Szemeredi.lean b/LeanPool/DensityHalesJewett/Szemeredi.lean new file mode 100644 index 0000000000..a45e276852 --- /dev/null +++ b/LeanPool/DensityHalesJewett/Szemeredi.lean @@ -0,0 +1,161 @@ +/- +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.Algebra.BigOperators.Fin +public import LeanPool.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 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 + +open Finset +open Combinatorics + +namespace Combinatorics + +/-- An arithmetic progression of length `k` with nonzero common difference in an additive monoid. -/ +@[ext] +structure ArithmeticProgression (α : Type*) [AddMonoid α] (k : ℕ) where + /-- The initial term of the arithmetic progression. -/ + start : α + /-- The common difference of the arithmetic progression. -/ + diff : α + diff_ne_zero : diff ≠ 0 + +namespace ArithmeticProgression + +/-- The term of `P` indexed by `i`. -/ +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`, 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 +end Combinatorics + +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` +digits of a natural number. -/ +lemma baseEncode_isArithmeticProgression {k m : ℕ} (hk : 1 ≤ k) + (l : Combinatorics.Line (Fin k) (Fin m)) : + ∃ P : Combinatorics.ArithmeticProgression ℕ k, + ∀ a, P.term a = (finFunctionFinEquiv (l a) : ℕ) := by + let d := ∑ i : Fin m, if l.idxFun i = none then k ^ (i : ℕ) else 0 + refine ⟨ + { start := (finFunctionFinEquiv (l ⟨0, hk⟩) : ℕ) + diff := d + diff_ne_zero := ?_ }, ?_⟩ + · 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, mul_sum, ← sum_add_distrib] + apply sum_congr rfl + intro i _ + cases hli : l.idxFun i <;> simp [Combinatorics.Line.coe_apply, hli] + +end Line + +/-- 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 : ℕ, δ / 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 + 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 + +/-- 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 + 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 + 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/UniformFibers.lean b/LeanPool/DensityHalesJewett/UniformFibers.lean new file mode 100644 index 0000000000..4aaeb7bf6a --- /dev/null +++ b/LeanPool/DensityHalesJewett/UniformFibers.lean @@ -0,0 +1,518 @@ +/- +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.Subspace +public import LeanPool.DensityHalesJewett.Word +public import Mathlib.Algebra.Order.Archimedean.Real.Basic +import Mathlib.Combinatorics.Pigeonhole +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`. + +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 + +open Finset +open Combinatorics +open scoped BigOperators + +namespace DensityHalesJewett + +/-- `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 + +/-- 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) + +/-- `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 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⟩ := h A hA + refine ⟨lineToSubspaceFinOne l, ?_⟩ + intro x + 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 := ⟨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 + +/-- An index word with no variable coordinate is equivalently an ordinary alphabet word. -/ +private noncomputable def fixedIndexWordEquiv (α ι : Type*) [Nonempty α] : + {f : ι → Option α // ∀ i, f i ≠ none} ≃ (ι → α) where + toFun f i := (f.1 i).getD (Classical.arbitrary α) + invFun x := ⟨some ∘ x, by simp⟩ + left_inv f := by + refine Subtype.ext (funext ?_) + intro i + cases hi : f.1 i with + | none => exact (f.2 i hi).elim + | some b => simp [hi] + 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) + [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⟩⟩ + rw [Fintype.card_congr (lineIndexEquiv (Fin k) (Fin m)), + Fintype.card_subtype_compl (fun f : Fin m → Option (Fin k) ↦ ∀ i, f i ≠ none), + Fintype.card_pi_const, Fintype.card_option, Fintype.card_fin, + Fintype.card_congr (fixedIndexWordEquiv (Fin k) (Fin m)), + Fintype.card_pi_const, Fintype.card_fin] + +/-- The finite enumeration of line structures induced by their index words. -/ +@[instance_reducible] +noncomputable def lineFintype (k m : ℕ) : Fintype (Combinatorics.Line (Fin k) (Fin m)) := + Fintype.ofInjective (fun l ↦ l.idxFun) fun l₁ l₂ h ↦ by + cases l₁ + cases l₂ + cases h + rfl + +/-- A subspace over the empty alphabet, obtained by repeating parameter coordinates. -/ +def emptyAlphabetSubspace {m n : ℕ} (hm : 1 ≤ m) (hmn : m ≤ n) : + Combinatorics.Subspace (Fin m) (Fin 0) (Fin n) where + 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]⟩ + +/-- 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) : + δ ≤ (A.dens : ℝ) := by + 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 : ℝ)) : + δ * (k : ℝ) ^ n ≤ #A := by + 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 + 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 [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 : ℝ)) : + δ / 2 ≤ + ((univ.filter fun x : Fin p → Fin k ↦ δ / 2 ≤ ((fiber A x).dens : ℝ)).dens : ℝ) := by + let : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ + 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) {δ : ℝ} + (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⟩ := 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), + ρ / ((k + 1) ^ q - k ^ q : ℕ) ≤ ((univ.filter fun y ↦ ∀ a, l a ∈ S y).dens : ℝ) := by + classical + let := lineFintype k q + 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 + +/-- 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) + (A : Finset (Fin n → Fin alphabet)) : Finset (Fin p ⊕ Fin q → Fin alphabet) := + A.map (e.arrowCongr (Equiv.refl (Fin alphabet))).symm.toEmbedding + +@[simp] +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, 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, 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 + proper e := ⟨e, rfl⟩ + +@[simp] +lemma blockSubspace_apply {α : Type*} {m : ℕ} (x : Fin m → α) : blockSubspace α m x = x := by + funext i + exact (blockSubspace α m).apply_inr rfl + +/-- Prepend a fixed block of letters to the coordinates of a subspace. -/ +def prependFixed {α η : Type*} {m p : ℕ} (u : Fin m → α) + (V : Combinatorics.Subspace η α (Fin p)) : Combinatorics.Subspace η α (Fin (m + p)) := + transportSubspace finSumFinEquiv.symm u V + +@[simp] +lemma prependFixed_apply {α η : Type*} {m p : ℕ} (u : Fin m → α) + (V : Combinatorics.Subspace η α (Fin p)) (x : η → α) : + prependFixed u V x = Sum.elim u (V x) ∘ finSumFinEquiv.symm := + transportSubspace_apply finSumFinEquiv.symm u V x + +/-- Regroup a cut of the coordinates following a fixed block. -/ +def prependCoords {m p q r : ℕ} (e : Fin p ⊕ Fin q ≃ Fin r) : + Fin (m + p) ⊕ Fin q ≃ Fin m ⊕ Fin r := + ((finSumFinEquiv.symm.sumCongr (Equiv.refl (Fin q))).trans + (Equiv.sumAssoc (Fin m) (Fin p) (Fin q))).trans ((Equiv.refl (Fin m)).sumCongr e) + +/-- Prepend a fixed coordinate block to a cut of the remaining coordinates. -/ +def prependCut {m p q r n : ℕ} (h : m + r = n) (e : Fin p ⊕ Fin q ≃ Fin r) : + Fin (m + p) ⊕ Fin q ≃ Fin n := + (prependCoords e).trans (cutEquiv h) + +/-- Regrouping the coordinates identifies a prepended word with the concatenation of the fixed +block and the cut word. -/ +lemma concat_prependFixed {alphabet η m p q r : ℕ} (e : Fin p ⊕ Fin q ≃ Fin r) + (u : Fin m → Fin alphabet) (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) + (x : Fin η → Fin alphabet) (y : Fin q → Fin alphabet) : + Sum.elim (prependFixed u V x) y ∘ (prependCoords e).symm = + Sum.elim u (Sum.elim (V x) y ∘ e.symm) := by + funext s + cases s with + | inl a => simp [prependCoords] + | inr b => + cases hb : e.symm b <;> simp [prependCoords, hb] + +/-- The same identification stated for the cut of the ambient coordinates. -/ +lemma concat_prependFixed_cut {alphabet η m p q r n : ℕ} (h : m + r = n) + (e : Fin p ⊕ Fin q ≃ Fin r) (u : Fin m → Fin alphabet) + (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) + (x : Fin η → Fin alphabet) (y : Fin q → Fin alphabet) : + Sum.elim (prependFixed u V x) y ∘ (prependCut h e).symm = + Sum.elim u (Sum.elim (V x) y ∘ e.symm) ∘ + (cutEquiv h).symm := by + rw [← concat_prependFixed e u V x y] + rfl + +/-- The suffix fibers of a prepended cut are the suffix fibers of the family already restricted +to the fixed prefix block. -/ +lemma fiber_splitWords_prependCut {alphabet η m p q r n : ℕ} (h : m + r = n) + (e : Fin p ⊕ Fin q ≃ Fin r) (A : Finset (Fin n → Fin alphabet)) (u : Fin m → Fin alphabet) + (V : Combinatorics.Subspace (Fin η) (Fin alphabet) (Fin p)) (x : Fin η → Fin alphabet) : + fiber (splitWords (prependCut h e) A) (prependFixed u V x) = + fiber (splitWords e (fiber (splitWords (cutEquiv h) A) u)) (V x) := by + ext y + simp only [mem_fiber, mem_splitWords] + rw [concat_prependFixed_cut] + +/-- 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} + (hu₀ : ((fiber A u₀).dens : ℝ) < (A.dens : ℝ) - ε) : + ∃ u, (A.dens : ℝ) + ε / (alphabet : ℝ) ^ m ≤ ((fiber A u).dens : ℝ) := 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] + 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 : ℝ) + +/-- 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 => + 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 + 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 + 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. -/ +lemma average_restrictedParameterSlice {k M : ℕ} + {ι κ : Type*} [Fintype (κ → Fin (k + 1))] + [DecidableEq (ι ⊕ κ → Fin (k + 1))] + (A : Finset (ι ⊕ κ → Fin (k + 1))) + (W : Combinatorics.Subspace (Fin M) (Fin (k + 1)) ι) : + expect univ (fun y : κ → Fin (k + 1) ↦ + ((univ.filter fun x : Fin M → Fin k ↦ + Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ)) = + 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) {δ : ℝ} + {ι κ : Type*} [Fintype (κ → Fin (k + 1))] + [DecidableEq (ι ⊕ κ → 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 ≤ + ((univ.filter fun x : Fin M → Fin k ↦ + Sum.elim (W (Fin.castSucc ∘ x)) y ∈ A).dens : ℝ) := by + let : Nonempty (Fin k) := ⟨⟨0, hk⟩⟩ + 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)} + (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 + use compose (fixSuffixReindex e W y) (map Fin.castSucc S) + intro w hw + 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 + 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/Varnavides.lean b/LeanPool/DensityHalesJewett/Varnavides.lean new file mode 100644 index 0000000000..c4fe54ed52 --- /dev/null +++ b/LeanPool/DensityHalesJewett/Varnavides.lean @@ -0,0 +1,248 @@ +/- +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.Szemeredi +import Mathlib.Algebra.Order.BigOperators.Expect + +/-! +# Many arithmetic progressions in dense sets + +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 + +open Finset + +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 (a, d) ↦ d ≠ 0 ∧ ∀ i : Fin k, a + i * d ∈ 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 (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 ((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 + 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 := + (card_filter_le _ _).trans_eq (by simp) + +/-- 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, (#(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 + 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_le_card_inter_Icc_add {n : ℕ} (W : ℕ) {A : Finset ℕ} (hAn : A ⊆ range n) : + #A ≤ #(A ∩ Icc W (n - W)) + 2 * W := by + have h : A \ Icc W (n - W) ⊆ range W ∪ Ico (n - W) n := by + intro x hx + 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 + 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 + +/-- 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 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 + · 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 + 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/Word.lean b/LeanPool/DensityHalesJewett/Word.lean new file mode 100644 index 0000000000..4035a1ec3f --- /dev/null +++ b/LeanPool/DensityHalesJewett/Word.lean @@ -0,0 +1,82 @@ +/- +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.Algebra.BigOperators.Expect +public import Mathlib.Basic.Real.Basic +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 +coordinate types, and `Equiv.sumArrowEquivProdArrow` for the underlying decomposition of a word on +a sum of coordinate types. +-/ + +@[expose] public section + +open Finset +open scoped BigOperators + +namespace DensityHalesJewett + +/-- 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 (κ → α) := + univ.filter fun y ↦ Sum.elim x y ∈ A + +@[simp] +lemma mem_fiber {α ι κ : Type*} [Fintype (κ → α)] [DecidableEq (ι ⊕ κ → α)] + {A : Finset (ι ⊕ κ → α)} {x : ι → α} {y : κ → α} : + y ∈ fiber A x ↔ Sum.elim x y ∈ A := by + simp [fiber] + +/-- Uniform density is the average of the uniform densities of the fibers. -/ +lemma average_density_fiber {α ι κ : Type*} [Fintype (ι → α)] [Fintype (κ → α)] + [Fintype (ι ⊕ κ → α)] [DecidableEq (ι ⊕ κ → α)] + (A : Finset (ι ⊕ κ → α)) : + (𝔼 x : ι → α, ((fiber A x).dens : ℝ)) = (A.dens : ℝ) := by + classical + 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 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) + (hba : b < a) (havg : a ≤ 𝔼 x : X, f x) : + (a - b) / (1 - b) ≤ + ((univ.filter fun x ↦ b ≤ f x).dens : ℝ) := by + classical + 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 <| + expect_le univ_nonempty fun x _ ↦ hf₁ x + rw [div_le_iff₀ h1b, sub_le_iff_le_add] + apply havg.trans + 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 [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] + +end DensityHalesJewett diff --git a/LeanPool/projects/densityhalesjewett.yaml b/LeanPool/projects/densityhalesjewett.yaml index 064b3f9adb..e8f83f02db 100644 --- a/LeanPool/projects/densityhalesjewett.yaml +++ b/LeanPool/projects/densityhalesjewett.yaml @@ -1,38 +1,63 @@ slug: densityhalesjewett title: The density Hales–Jewett theorem and Szemerédi's theorem -summary: 'A Lean 4 formalization of the density Hales–Jewett theorem: for every finite - alphabet α and every density δ > 0, all sufficiently large n have the property that - any set of at least δ·|α|^n words of length n over α contains a combinatorial line. - The basis for the formalization is the combinatorial proof of Dodos, Kanellopoulos, - 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.' +summary: Formalizes the combinatorial proof of the density Hales–Jewett theorem by Dodos, + Kanellopoulos and Tyros, with an explicit bound. Over an alphabet of k letters and + for δ > 0, every set of at least δ·k^n words of length n ≥ A(4k, k + ⌈1/δ⌉) contains + a combinatorial line, where A is the Ackermann function. The thresholds are built on + Shelah's bound for the Hales–Jewett numbers from the ShelahHalesJewett project, + through the finite-unions theorem, block canonization and the Graham–Rothschild + theorem for lines. Derives Szemerédi's theorem on the integers by a digital transfer, + every subset of {0, …, n − 1} of size at least δn with n ≥ A(4k + 1, k + ⌈1/δ⌉) + contains a nonconstant k-term arithmetic progression, and Varnavides' theorem that it + contains at least n²/A(4k + 1, k + ⌈1/δ⌉) of them. branch: combinatorics entry_module: LeanPool.DensityHalesJewett authors: - Gabriel Dahia source: - url: https://github.com/gdahia/densityhalesjewett - github_repo: gdahia/densityhalesjewett - commit: 1c2f5aa1b99caa8e2a87beacf80f07f066c309d3 + title: A Simple Proof of the Density Hales–Jewett Theorem + authors: + - Pandelis Dodos + - Vassilis Kanellopoulos + - Konstantinos Tyros + doi: 10.1093/imrn/rnt041 + arxiv: '1209.4986' + url: https://github.com/gdahia/DensityHalesJewett/tree/478533c44dbfbb286362cb37e19b0ba53fdc5120 + github_repo: gdahia/DensityHalesJewett + commit: 478533c44dbfbb286362cb37e19b0ba53fdc5120 license: Apache-2.0 status: verified +provenance: AI main_declarations: -- Combinatorics.Line.exists_of_density_atTop +- Combinatorics.Line.exists_of_density +- Combinatorics.Line.dhjNumber_le_ack +- Combinatorics.ArithmeticProgression.exists_of_density_nat +- Combinatorics.ArithmeticProgression.exists_many_of_density_nat main_results: -- declaration: Combinatorics.Line.exists_of_density_atTop - informal: Every positive-density subset of sufficiently long words over a finite - nontrivial alphabet contains a combinatorial line. -- declaration: Combinatorics.ArithmeticProgression.exists_of_density_nat_atTop - 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. + source_ref: Theorem 1, with an explicit threshold. +- 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. + source_ref: Szemerédi's theorem, derived from Theorem 1. +- 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. + source_ref: Varnavides' theorem. tags: - combinatorics +- ramsey-theory +- hales-jewett +- szemeredi-theorem +- density-increment msc: - 05D10 - 05A05 - 11B75 - 68R15 -provenance: AI From 99835bfc8cf4fd30eb71467e105661e1094150ab Mon Sep 17 00:00:00 2001 From: Gabriel Dahia Date: Sun, 8 Nov 2026 22:17:09 +0100 Subject: [PATCH 3/3] =?UTF-8?q?Keep=20the=20Lean=20Pool=20layout=20of=20de?= =?UTF-8?q?nsity=20Hales=E2=80=93Jewett?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Restore the modules under LeanPool.DensityHalesJewett.DensityHalesJewett, the root and aggregator modules, and Solution with the asymptotic forms of the density theorems, now derived from the Ackermann thresholds. The card keeps its entries and adds the explicit theorems. Define composeLine as an alias of Combinatorics.Subspace.compLine from LeanPool.ShelahHalesJewett instead of repeating its definition. Co-Authored-By: Claude Opus 5.5 --- LeanPool/DensityHalesJewett.lean | 44 ++++++++------ .../DensityHalesJewett.lean | 24 ++++++++ .../{ => DensityHalesJewett}/Ackermann.lean | 4 +- .../Canonization.lean | 2 +- .../DensityIncrement.lean | 2 +- .../DensityIncrement/CorrelatedFibers.lean | 6 +- .../DensityIncrement/Parameters.lean | 0 .../StructuredCorrelation.lean | 4 +- .../FiniteUnions.lean | 2 +- .../GrahamRothschild.lean | 4 +- .../{ => DensityHalesJewett}/HalesJewett.lean | 0 .../{ => DensityHalesJewett}/Induction.lean | 2 +- .../{ => DensityHalesJewett}/Insensitive.lean | 2 +- .../{ => DensityHalesJewett}/Main.lean | 4 +- .../{ => DensityHalesJewett}/Subspace.lean | 19 +++--- .../{ => DensityHalesJewett}/Szemeredi.lean | 2 +- .../UniformFibers.lean | 4 +- .../{ => DensityHalesJewett}/Varnavides.lean | 2 +- .../{ => DensityHalesJewett}/Word.lean | 0 LeanPool/DensityHalesJewett/Imports.lean | 36 +++++------ LeanPool/DensityHalesJewett/Solution.lean | 59 +++++++++++++++++++ LeanPool/projects/densityhalesjewett.yaml | 52 ++++++++-------- 22 files changed, 179 insertions(+), 95 deletions(-) create mode 100644 LeanPool/DensityHalesJewett/DensityHalesJewett.lean rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Ackermann.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Canonization.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/DensityIncrement.lean (98%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/DensityIncrement/CorrelatedFibers.lean (98%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/DensityIncrement/Parameters.lean (100%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/DensityIncrement/StructuredCorrelation.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/FiniteUnions.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/GrahamRothschild.lean (97%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/HalesJewett.lean (100%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Induction.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Insensitive.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Main.lean (98%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Subspace.lean (96%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Szemeredi.lean (98%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/UniformFibers.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Varnavides.lean (99%) rename LeanPool/DensityHalesJewett/{ => DensityHalesJewett}/Word.lean (100%) create mode 100644 LeanPool/DensityHalesJewett/Solution.lean diff --git a/LeanPool/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett.lean index 4ffa319e7b..f65ad46595 100644 --- a/LeanPool/DensityHalesJewett.lean +++ b/LeanPool/DensityHalesJewett.lean @@ -3,31 +3,41 @@ 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.GrahamRothschild -public import LeanPool.DensityHalesJewett.Main +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 +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters +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 +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word +public import LeanPool.DensityHalesJewett.Solution + /-! # The density Hales–Jewett theorem and Szemerédi's theorem -Source: arxiv:1209.4986, doi:10.1093/imrn/rnt041, url:https://github.com/gdahia/DensityHalesJewett/tree/478533c44dbfbb286362cb37e19b0ba53fdc5120 +Source: url:https://github.com/gdahia/densityhalesjewett Authors: Gabriel Dahia Status: verified -Main declarations: `Combinatorics.Line.exists_of_density`, `Combinatorics.Line.dhjNumber_le_ack`, - `Combinatorics.ArithmeticProgression.exists_of_density_nat`, - `Combinatorics.ArithmeticProgression.exists_many_of_density_nat` -Tags: combinatorics, ramsey-theory, hales-jewett, szemeredi-theorem, density-increment +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 -/ -/-! -## Upstream attribution - -Adapted for Lean Pool from upstream commit `478533c44dbfbb286362cb37e19b0ba53fdc5120` by moving -the library under `LeanPool.DensityHalesJewett` and importing Shelah's bound from -`LeanPool.ShelahHalesJewett`. `pullback` is defined from `parameterPreimage`, as in the earlier -Lean Pool version of this project. The upstream Palomar `Challenge` and `Solution` modules are -omitted: `Solution` only restates `Combinatorics.Line.exists_of_density` and -`Combinatorics.ArithmeticProgression.exists_of_density_nat` under primed names. --/ +@[expose] public section diff --git a/LeanPool/DensityHalesJewett/DensityHalesJewett.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett.lean new file mode 100644 index 0000000000..75b15acbb7 --- /dev/null +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett.lean @@ -0,0 +1,24 @@ +/- +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.Ackermann +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters +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 +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word diff --git a/LeanPool/DensityHalesJewett/Ackermann.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean similarity index 99% rename from LeanPool/DensityHalesJewett/Ackermann.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean index 88db583044..b3607aad04 100644 --- a/LeanPool/DensityHalesJewett/Ackermann.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Ackermann.lean @@ -5,9 +5,9 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Insensitive +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive public import Mathlib.Computability.Ackermann -import LeanPool.DensityHalesJewett.Induction +import LeanPool.DensityHalesJewett.DensityHalesJewett.Induction import LeanPool.ShelahHalesJewett.Ackermann /-! diff --git a/LeanPool/DensityHalesJewett/Canonization.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean similarity index 99% rename from LeanPool/DensityHalesJewett/Canonization.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean index a2d2c0b99d..e3208c5fb7 100644 --- a/LeanPool/DensityHalesJewett/Canonization.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Canonization.lean @@ -5,7 +5,7 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Subspace +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace public import LeanPool.ShelahHalesJewett.HalesJewett import Mathlib.Tactic.Ring.RingNF diff --git a/LeanPool/DensityHalesJewett/DensityIncrement.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean similarity index 98% rename from LeanPool/DensityHalesJewett/DensityIncrement.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean index b3cd2aac19..9c7399dcf8 100644 --- a/LeanPool/DensityHalesJewett/DensityIncrement.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement.lean @@ -5,7 +5,7 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityIncrement.StructuredCorrelation +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.StructuredCorrelation import Mathlib.Algebra.Order.BigOperators.Expect /-! diff --git a/LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean similarity index 98% rename from LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean index e9ba2fe50b..79e4f416f4 100644 --- a/LeanPool/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/CorrelatedFibers.lean @@ -5,9 +5,9 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.GrahamRothschild -public import LeanPool.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters +public import LeanPool.DensityHalesJewett.DensityHalesJewett.GrahamRothschild +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers import Mathlib.Algebra.Order.BigOperators.Expect /-! diff --git a/LeanPool/DensityHalesJewett/DensityIncrement/Parameters.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean similarity index 100% rename from LeanPool/DensityHalesJewett/DensityIncrement/Parameters.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/Parameters.lean diff --git a/LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean similarity index 99% rename from LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean index e0f3e10c42..488c331daa 100644 --- a/LeanPool/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/DensityIncrement/StructuredCorrelation.lean @@ -5,8 +5,8 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityIncrement.CorrelatedFibers -public import LeanPool.DensityHalesJewett.Insensitive +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.CorrelatedFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Insensitive import Mathlib.Algebra.BigOperators.Field import Mathlib.Algebra.Order.Ring.Pow import Mathlib.Data.NNRat.BigOperators diff --git a/LeanPool/DensityHalesJewett/FiniteUnions.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean similarity index 99% rename from LeanPool/DensityHalesJewett/FiniteUnions.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean index a6049356fb..0ac8f52ace 100644 --- a/LeanPool/DensityHalesJewett/FiniteUnions.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/FiniteUnions.lean @@ -7,7 +7,7 @@ module public import Mathlib.Data.Finset.Max public import LeanPool.ShelahHalesJewett.HalesJewett -import LeanPool.DensityHalesJewett.HalesJewett +import LeanPool.DensityHalesJewett.DensityHalesJewett.HalesJewett import Mathlib.Combinatorics.Pigeonhole import Mathlib.Data.Finset.Sort diff --git a/LeanPool/DensityHalesJewett/GrahamRothschild.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean similarity index 97% rename from LeanPool/DensityHalesJewett/GrahamRothschild.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean index 6d5c271a6a..91b910f10d 100644 --- a/LeanPool/DensityHalesJewett/GrahamRothschild.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/GrahamRothschild.lean @@ -5,8 +5,8 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Canonization -public import LeanPool.DensityHalesJewett.FiniteUnions +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Canonization +public import LeanPool.DensityHalesJewett.DensityHalesJewett.FiniteUnions /-! # The Graham--Rothschild theorem for combinatorial lines diff --git a/LeanPool/DensityHalesJewett/HalesJewett.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/HalesJewett.lean similarity index 100% rename from LeanPool/DensityHalesJewett/HalesJewett.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/HalesJewett.lean diff --git a/LeanPool/DensityHalesJewett/Induction.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean similarity index 99% rename from LeanPool/DensityHalesJewett/Induction.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean index b549a75fcb..8d438b017e 100644 --- a/LeanPool/DensityHalesJewett/Induction.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Induction.lean @@ -5,7 +5,7 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.DensityIncrement +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement public import Mathlib.Analysis.Real.Sqrt public import Mathlib.Data.Nat.Choose.Central import Mathlib.Tactic.LinearCombination diff --git a/LeanPool/DensityHalesJewett/Insensitive.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean similarity index 99% rename from LeanPool/DensityHalesJewett/Insensitive.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean index cd0540aced..b79fcc6fb0 100644 --- a/LeanPool/DensityHalesJewett/Insensitive.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Insensitive.lean @@ -5,7 +5,7 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers import Mathlib.Algebra.BigOperators.Field import Mathlib.Data.Set.Finite.Lattice import Mathlib.Algebra.Order.BigOperators.Expect diff --git a/LeanPool/DensityHalesJewett/Main.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean similarity index 98% rename from LeanPool/DensityHalesJewett/Main.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean index eabe064d02..ebabfda975 100644 --- a/LeanPool/DensityHalesJewett/Main.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Main.lean @@ -5,10 +5,10 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Varnavides +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides public import Mathlib.Computability.Ackermann public import Mathlib.Order.Lattice.Nat -import LeanPool.DensityHalesJewett.Ackermann +import LeanPool.DensityHalesJewett.DensityHalesJewett.Ackermann import Mathlib.Algebra.Order.BigOperators.Expect import Mathlib.Analysis.Real.Sqrt diff --git a/LeanPool/DensityHalesJewett/Subspace.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean similarity index 96% rename from LeanPool/DensityHalesJewett/Subspace.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean index 336f72fbe7..3d6f97e1c6 100644 --- a/LeanPool/DensityHalesJewett/Subspace.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Subspace.lean @@ -7,6 +7,7 @@ module public import Mathlib.Combinatorics.HalesJewett public import Mathlib.Data.Finset.Density +public import LeanPool.ShelahHalesJewett.Line /-! # Combinatorial subspaces @@ -128,22 +129,16 @@ 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 (ι → α)] diff --git a/LeanPool/DensityHalesJewett/Szemeredi.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean similarity index 98% rename from LeanPool/DensityHalesJewett/Szemeredi.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean index a45e276852..28b25f403d 100644 --- a/LeanPool/DensityHalesJewett/Szemeredi.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Szemeredi.lean @@ -6,7 +6,7 @@ Authors: Gabriel Dahia module public import Mathlib.Algebra.BigOperators.Fin -public import LeanPool.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers import Mathlib.Algebra.Order.BigOperators.Expect import Mathlib.Algebra.Order.Interval.Finset.Basic import Mathlib.Combinatorics.Pigeonhole diff --git a/LeanPool/DensityHalesJewett/UniformFibers.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean similarity index 99% rename from LeanPool/DensityHalesJewett/UniformFibers.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean index 4aaeb7bf6a..97860a82a1 100644 --- a/LeanPool/DensityHalesJewett/UniformFibers.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/UniformFibers.lean @@ -5,8 +5,8 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Subspace -public import LeanPool.DensityHalesJewett.Word +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Subspace +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word public import Mathlib.Algebra.Order.Archimedean.Real.Basic import Mathlib.Combinatorics.Pigeonhole public import Mathlib.Logic.Equiv.Fin.Basic diff --git a/LeanPool/DensityHalesJewett/Varnavides.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean similarity index 99% rename from LeanPool/DensityHalesJewett/Varnavides.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean index c4fe54ed52..e2a5a59230 100644 --- a/LeanPool/DensityHalesJewett/Varnavides.lean +++ b/LeanPool/DensityHalesJewett/DensityHalesJewett/Varnavides.lean @@ -5,7 +5,7 @@ Authors: Gabriel Dahia -/ module -public import LeanPool.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi import Mathlib.Algebra.Order.BigOperators.Expect /-! diff --git a/LeanPool/DensityHalesJewett/Word.lean b/LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean similarity index 100% rename from LeanPool/DensityHalesJewett/Word.lean rename to LeanPool/DensityHalesJewett/DensityHalesJewett/Word.lean diff --git a/LeanPool/DensityHalesJewett/Imports.lean b/LeanPool/DensityHalesJewett/Imports.lean index 9f1476a1a5..52a18dbf6f 100644 --- a/LeanPool/DensityHalesJewett/Imports.lean +++ b/LeanPool/DensityHalesJewett/Imports.lean @@ -7,20 +7,22 @@ module -- shake: keep-all --deprecated_module: ignore -- Generated project imports; run `lake exe mk_all`. public import LeanPool.DensityHalesJewett -public import LeanPool.DensityHalesJewett.Ackermann -public import LeanPool.DensityHalesJewett.Canonization -public import LeanPool.DensityHalesJewett.DensityIncrement -public import LeanPool.DensityHalesJewett.DensityIncrement.CorrelatedFibers -public import LeanPool.DensityHalesJewett.DensityIncrement.Parameters -public import LeanPool.DensityHalesJewett.DensityIncrement.StructuredCorrelation -public import LeanPool.DensityHalesJewett.FiniteUnions -public import LeanPool.DensityHalesJewett.GrahamRothschild -public import LeanPool.DensityHalesJewett.HalesJewett -public import LeanPool.DensityHalesJewett.Induction -public import LeanPool.DensityHalesJewett.Insensitive -public import LeanPool.DensityHalesJewett.Main -public import LeanPool.DensityHalesJewett.Subspace -public import LeanPool.DensityHalesJewett.Szemeredi -public import LeanPool.DensityHalesJewett.UniformFibers -public import LeanPool.DensityHalesJewett.Varnavides -public import LeanPool.DensityHalesJewett.Word +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 +public import LeanPool.DensityHalesJewett.DensityHalesJewett.DensityIncrement.Parameters +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 +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Szemeredi +public import LeanPool.DensityHalesJewett.DensityHalesJewett.UniformFibers +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Varnavides +public import LeanPool.DensityHalesJewett.DensityHalesJewett.Word +public import LeanPool.DensityHalesJewett.Solution diff --git a/LeanPool/DensityHalesJewett/Solution.lean b/LeanPool/DensityHalesJewett/Solution.lean new file mode 100644 index 0000000000..6e469c078d --- /dev/null +++ b/LeanPool/DensityHalesJewett/Solution.lean @@ -0,0 +1,59 @@ +/- +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.Main +public import Mathlib.Order.Filter.AtTopBot.Basic + +/-! +# Proofs of the asymptotic forms of the density theorems + +This module proves the asymptotic density theorems, deriving them from the explicit +threshold forms `Combinatorics.Line.exists_of_density` and +`Combinatorics.ArithmeticProgression.exists_of_density_nat` developed in this repository. + +A *combinatorial line* in the cube of words of length `n` over a finite alphabet `α` is a family +of `#α` words, one for each letter `x : α`, obtained from a single pattern by filling every +occurrence of a wildcard with `x`; at least one coordinate must be a wildcard, so distinct +letters give distinct words. This is Mathlib's `Combinatorics.Line α (Fin n)`, and `l x` is the word +of the line indexed by the letter `x`. +-/ + +@[expose] public section + +open Filter Finset +open Combinatorics + +namespace Combinatorics.Line + +/-- The **Density Hales--Jewett theorem**: for a positive density `δ`, every sufficiently long word +length `n` has the property that any set of at least a `δ` fraction of the words of length `n` +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 ⟨ack (4 * Fintype.card α) (Fintype.card α + ⌈1 / δ⌉₊), ?_⟩ + intro n hn A hAδ + exact exists_of_density hδ hn A hAδ + +end Combinatorics.Line + +namespace Combinatorics.ArithmeticProgression + +/-- **Szemeredi's theorem**: for a positive density `δ`, every sufficiently large `n` has the +property that any subset of `range n` of size at least `δ * n` contains an arithmetic progression +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 ⟨ack (4 * k + 1) (k + ⌈1 / δ⌉₊), ?_⟩ + intro 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 + +end Combinatorics.ArithmeticProgression diff --git a/LeanPool/projects/densityhalesjewett.yaml b/LeanPool/projects/densityhalesjewett.yaml index e8f83f02db..ede2f31045 100644 --- a/LeanPool/projects/densityhalesjewett.yaml +++ b/LeanPool/projects/densityhalesjewett.yaml @@ -1,43 +1,42 @@ slug: densityhalesjewett title: The density Hales–Jewett theorem and Szemerédi's theorem -summary: Formalizes the combinatorial proof of the density Hales–Jewett theorem by Dodos, - Kanellopoulos and Tyros, with an explicit bound. Over an alphabet of k letters and - for δ > 0, every set of at least δ·k^n words of length n ≥ A(4k, k + ⌈1/δ⌉) contains - a combinatorial line, where A is the Ackermann function. The thresholds are built on - Shelah's bound for the Hales–Jewett numbers from the ShelahHalesJewett project, - through the finite-unions theorem, block canonization and the Graham–Rothschild - theorem for lines. Derives Szemerédi's theorem on the integers by a digital transfer, - every subset of {0, …, n − 1} of size at least δn with n ≥ A(4k + 1, k + ⌈1/δ⌉) - contains a nonconstant k-term arithmetic progression, and Varnavides' theorem that it - contains at least n²/A(4k + 1, k + ⌈1/δ⌉) of them. +summary: 'A Lean 4 formalization of the density Hales–Jewett theorem: for every finite + alphabet α and every density δ > 0, all sufficiently large n have the property that + any set of at least δ·|α|^n words of length n over α contains a combinatorial line. + The basis for the formalization is the combinatorial proof of Dodos, Kanellopoulos, + 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. 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: - Gabriel Dahia source: - title: A Simple Proof of the Density Hales–Jewett Theorem - authors: - - Pandelis Dodos - - Vassilis Kanellopoulos - - Konstantinos Tyros - doi: 10.1093/imrn/rnt041 - arxiv: '1209.4986' - url: https://github.com/gdahia/DensityHalesJewett/tree/478533c44dbfbb286362cb37e19b0ba53fdc5120 - github_repo: gdahia/DensityHalesJewett + url: https://github.com/gdahia/densityhalesjewett + github_repo: gdahia/densityhalesjewett commit: 478533c44dbfbb286362cb37e19b0ba53fdc5120 license: Apache-2.0 status: verified -provenance: AI main_declarations: +- Combinatorics.Line.exists_of_density_atTop - Combinatorics.Line.exists_of_density -- Combinatorics.Line.dhjNumber_le_ack - Combinatorics.ArithmeticProgression.exists_of_density_nat -- Combinatorics.ArithmeticProgression.exists_many_of_density_nat main_results: +- declaration: Combinatorics.Line.exists_of_density_atTop + informal: Every positive-density subset of sufficiently long words over a finite + nontrivial alphabet contains a combinatorial line. +- declaration: Combinatorics.ArithmeticProgression.exists_of_density_nat_atTop + 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. - source_ref: Theorem 1, with an explicit threshold. - 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/δ⌉). @@ -45,19 +44,14 @@ main_results: 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. - source_ref: Szemerédi's theorem, derived from Theorem 1. - 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. - source_ref: Varnavides' theorem. tags: - combinatorics -- ramsey-theory -- hales-jewett -- szemeredi-theorem -- density-increment msc: - 05D10 - 05A05 - 11B75 - 68R15 +provenance: AI