From 9d4264178cabf68e88534ac79fb0ffc16d5c9bf6 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 04:15:29 +0000 Subject: [PATCH 1/4] feat: preserve order-closure and weak Fatou formalization --- LeanPool.lean | 37 + LeanPool/OrderClosures.lean | 57 + LeanPool/OrderClosures/BanLat/Basic.lean | 589 ++++++ .../BanLat/Convergences/Order.lean | 367 ++++ LeanPool/OrderClosures/BanLat/Disjoint.lean | 632 +++++++ .../BanLat/Examples/CofK/Basic.lean | 65 + LeanPool/OrderClosures/BanLat/LLexpr.lean | 511 +++++ .../OrderClosures/BanLat/LatticeSeminorm.lean | 57 + LeanPool/OrderClosures/BanLat/Normed.lean | 404 ++++ .../OrderClosures/BanLat/Operators/Hom.lean | 606 ++++++ .../BanLat/Operators/Positive.lean | 343 ++++ .../OrderClosures/BanLat/OrderComplete.lean | 379 ++++ .../BanLat/OrderContinuous/Basic.lean | 354 ++++ .../BanLat/OrderContinuous/MeyerNieberg.lean | 909 +++++++++ .../BanLat/OrderContinuous/Nakano.lean | 226 +++ LeanPool/OrderClosures/BanLat/OrderUnit.lean | 68 + LeanPool/OrderClosures/BanLat/Pi.lean | 34 + .../BanLat/Substructures/Band/Basic.lean | 218 +++ .../Band/DisjointComplement.lean | 150 ++ .../BanLat/Substructures/Ideal.lean | 1127 +++++++++++ .../BanLat/Substructures/Sublattice.lean | 935 ++++++++++ .../OrderClosures/BanLat/Tactic/LLexpr.lean | 504 +++++ .../GaoLeungCharacterization.lean | 1039 +++++++++++ LeanPool/OrderClosures/GaoLeungProblem.lean | 22 + .../GaoLeungProblem/CNFOrder.lean | 736 ++++++++ .../GaoLeungProblem/Counterexample.lean | 526 ++++++ .../GaoLeungProblem/Iterations.lean | 760 ++++++++ .../GaoLeungProblem/OrdinalSpace.lean | 905 +++++++++ .../GaoLeungProblem/StageFormula.lean | 715 +++++++ LeanPool/OrderClosures/OrderAdherence.lean | 454 +++++ LeanPool/OrderClosures/Solovay.lean | 1660 +++++++++++++++++ LeanPool/OrderClosures/WeaklyFatou.lean | 23 + LeanPool/OrderClosures/WeaklyFatou/Bands.lean | 681 +++++++ .../OrderClosures/WeaklyFatou/FinalSpace.lean | 599 ++++++ .../OrderClosures/WeaklyFatou/FiniteTree.lean | 453 +++++ .../OrderClosures/WeaklyFatou/Moderated.lean | 459 +++++ .../OrderClosures/WeaklyFatou/Reductions.lean | 466 +++++ .../OrderClosures/WeaklyFatou/TreeNorm.lean | 690 +++++++ LeanPool/projects.yml | 77 + 39 files changed, 18837 insertions(+) create mode 100644 LeanPool/OrderClosures.lean create mode 100644 LeanPool/OrderClosures/BanLat/Basic.lean create mode 100644 LeanPool/OrderClosures/BanLat/Convergences/Order.lean create mode 100644 LeanPool/OrderClosures/BanLat/Disjoint.lean create mode 100644 LeanPool/OrderClosures/BanLat/Examples/CofK/Basic.lean create mode 100644 LeanPool/OrderClosures/BanLat/LLexpr.lean create mode 100644 LeanPool/OrderClosures/BanLat/LatticeSeminorm.lean create mode 100644 LeanPool/OrderClosures/BanLat/Normed.lean create mode 100644 LeanPool/OrderClosures/BanLat/Operators/Hom.lean create mode 100644 LeanPool/OrderClosures/BanLat/Operators/Positive.lean create mode 100644 LeanPool/OrderClosures/BanLat/OrderComplete.lean create mode 100644 LeanPool/OrderClosures/BanLat/OrderContinuous/Basic.lean create mode 100644 LeanPool/OrderClosures/BanLat/OrderContinuous/MeyerNieberg.lean create mode 100644 LeanPool/OrderClosures/BanLat/OrderContinuous/Nakano.lean create mode 100644 LeanPool/OrderClosures/BanLat/OrderUnit.lean create mode 100644 LeanPool/OrderClosures/BanLat/Pi.lean create mode 100644 LeanPool/OrderClosures/BanLat/Substructures/Band/Basic.lean create mode 100644 LeanPool/OrderClosures/BanLat/Substructures/Band/DisjointComplement.lean create mode 100644 LeanPool/OrderClosures/BanLat/Substructures/Ideal.lean create mode 100644 LeanPool/OrderClosures/BanLat/Substructures/Sublattice.lean create mode 100644 LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean create mode 100644 LeanPool/OrderClosures/GaoLeungCharacterization.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem/CNFOrder.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem/Iterations.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem/OrdinalSpace.lean create mode 100644 LeanPool/OrderClosures/GaoLeungProblem/StageFormula.lean create mode 100644 LeanPool/OrderClosures/OrderAdherence.lean create mode 100644 LeanPool/OrderClosures/Solovay.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/Bands.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/FinalSpace.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/FiniteTree.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/Moderated.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/Reductions.lean create mode 100644 LeanPool/OrderClosures/WeaklyFatou/TreeNorm.lean diff --git a/LeanPool.lean b/LeanPool.lean index f88605c236..d72f88376b 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -6555,6 +6555,43 @@ public import LeanPool.Odlyzko.TestFunction.TaylorBound public import LeanPool.Odlyzko.Theta.PoissonSummation public import LeanPool.Odlyzko.Theta.TraceDualIdeal public import LeanPool.Odlyzko.Theta.TraceDualLattice +public import LeanPool.OrderClosures +public import LeanPool.OrderClosures.BanLat.Basic +public import LeanPool.OrderClosures.BanLat.Convergences.Order +public import LeanPool.OrderClosures.BanLat.Disjoint +public import LeanPool.OrderClosures.BanLat.Examples.CofK.Basic +public import LeanPool.OrderClosures.BanLat.LLexpr +public import LeanPool.OrderClosures.BanLat.LatticeSeminorm +public import LeanPool.OrderClosures.BanLat.Normed +public import LeanPool.OrderClosures.BanLat.Operators.Hom +public import LeanPool.OrderClosures.BanLat.Operators.Positive +public import LeanPool.OrderClosures.BanLat.OrderComplete +public import LeanPool.OrderClosures.BanLat.OrderContinuous.Basic +public import LeanPool.OrderClosures.BanLat.OrderContinuous.MeyerNieberg +public import LeanPool.OrderClosures.BanLat.OrderContinuous.Nakano +public import LeanPool.OrderClosures.BanLat.OrderUnit +public import LeanPool.OrderClosures.BanLat.Pi +public import LeanPool.OrderClosures.BanLat.Substructures.Band.Basic +public import LeanPool.OrderClosures.BanLat.Substructures.Band.DisjointComplement +public import LeanPool.OrderClosures.BanLat.Substructures.Ideal +public import LeanPool.OrderClosures.BanLat.Substructures.Sublattice +public import LeanPool.OrderClosures.BanLat.Tactic.LLexpr +public import LeanPool.OrderClosures.GaoLeungCharacterization +public import LeanPool.OrderClosures.GaoLeungProblem +public import LeanPool.OrderClosures.GaoLeungProblem.CNFOrder +public import LeanPool.OrderClosures.GaoLeungProblem.Counterexample +public import LeanPool.OrderClosures.GaoLeungProblem.Iterations +public import LeanPool.OrderClosures.GaoLeungProblem.OrdinalSpace +public import LeanPool.OrderClosures.GaoLeungProblem.StageFormula +public import LeanPool.OrderClosures.OrderAdherence +public import LeanPool.OrderClosures.Solovay +public import LeanPool.OrderClosures.WeaklyFatou +public import LeanPool.OrderClosures.WeaklyFatou.Bands +public import LeanPool.OrderClosures.WeaklyFatou.FinalSpace +public import LeanPool.OrderClosures.WeaklyFatou.FiniteTree +public import LeanPool.OrderClosures.WeaklyFatou.Moderated +public import LeanPool.OrderClosures.WeaklyFatou.Reductions +public import LeanPool.OrderClosures.WeaklyFatou.TreeNorm public import LeanPool.OrderPQ public import LeanPool.OrderPQ.Basic public import LeanPool.OrderPQ.IsCyclic diff --git a/LeanPool/OrderClosures.lean b/LeanPool/OrderClosures.lean new file mode 100644 index 0000000000..fba4b39bec --- /dev/null +++ b/LeanPool/OrderClosures.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem +public import LeanPool.OrderClosures.WeaklyFatou + + +/-! +# Order closure, order adherence and Fatou norms + +Source: arxiv:2609.06689, url:https://github.com/pedrotradacete/OrderClosures/tree/6189ba7134f6975e7d8e4c8c093a9869d03a769c +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete, David Muñoz-Lahoz +Status: verified +Main declarations: `OrderClosures.exists_weaklyFatou_not_equivalent_fatou` +Tags: banach-lattices, order-convergence, fatou-norms, transfinite-constructions +MSC: 46B42, 46A40, 46A19 +-/ + +/-! +## Scope, attribution and provenance + +Imported from `pedrotradacete/OrderClosures` at +`6189ba7134f6975e7d8e4c8c093a9869d03a769c` (Apache-2.0). The public paper +[arXiv:2609.06689](https://arxiv.org/abs/2609.06689), submitted September 6, 2026, +records the completed formalization. The August 26 completion commit is +`5f6833f1934ac915302189e19bf083115f655be3`. + +The `BanLat` subtree retains the dependency closure and reusable prerequisites +from David Muñoz-Lahoz's [BanLat](https://github.com/davidmunozlahoz/banlat/tree/b00e59836016aa1099b8011add6b07385e66428e) +at `b00e59836016aa1099b8011add6b07385e66428e`, also Apache-2.0. Unused operator, +projection-band and locally-solid representation developments are omitted. +`BanLat.LatticeSeminorm` extracts the necessary seminorm interface from +`BanLat.LocallySolid.WithSeminorms`; `BanLat.Pi` retains pointwise products. + +The paper credits Jaume de Dios Pont for an earlier Lean formalization of +Section 3. It credits Michael Elliott for the unpublished weak Fatou example +previously announced by Anthony Wickstead. These mathematical and formalization +credits are retained independently of the authors of this implementation. + +The AI provenance classification is an evidence-based inference: the main +repository records phase-specific agent instructions and a completed phase-II +proof pass; BanLat explicitly describes human-directed development in which +language models write much of the Lean implementation. No particular model or +precise human/AI fraction is claimed. The Lean Pool port and proof repairs were +performed with Codex. + +`gao_counterexample` states the order-complete `C(K)` construction with a +norm-closed separable order-dense sublattice. It does not itself state the +negation of the Gao-Leung conjecture: the paper derives that consequence by a +cardinality argument. The registered informal statement describes the actual +Lean endpoint. +-/ diff --git a/LeanPool/OrderClosures/BanLat/Basic.lean b/LeanPool/OrderClosures/BanLat/Basic.lean new file mode 100644 index 0000000000..e82304c235 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Basic.lean @@ -0,0 +1,589 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import Mathlib.LinearAlgebra.Dimension.RankNullity +public import Mathlib.Algebra.Order.Archimedean.Real.Basic +public import Mathlib.LinearAlgebra.Dimension.DivisionRing +public import Mathlib.Basic.Real.Basic +public import Mathlib.Algebra.Order.Module.Defs +public import Mathlib.Algebra.Order.Monoid.Defs +public import Mathlib.Tactic.Abel +public import Mathlib.Tactic.GCongr +public import Mathlib.Tactic.Linarith +public import Mathlib.Tactic.NormNum +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.Push + + +/-! +# Lattice-ordered groups and vector lattices + +This file develops the basic order-theoretic algebra of lattice-ordered groups and vector +lattices. The first part works in the general setting of an additive commutative group with a +compatible lattice order (`IsOrderedAddMonoid`): it establishes properties of `x⁺`, `x⁻`, +and `|x|`, together with order-theoretic suprema and infima lemmas. The second part adds a +real scalar multiplication (`VectorLattice`) and proves that positive scalars distribute over +`⊔` and `⊓`, culminating in `abs_smul'`. The Archimedean case is treated at the end. +-/ + +@[expose] public section + +/-- A real vector lattice is a real module whose scalar multiplication is monotone for +non-negative scalars and is compatible with the lattice-ordered additive structure. -/ +class VectorLattice (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] extends + Module ℝ X, + PosSMulMono ℝ X + +/-- The real numbers form a vector lattice over themselves. -/ +noncomputable instance : VectorLattice ℝ where + +section LatticeOrderedGroup + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +variable (x : X) + +/-- An element of a lattice-ordered group is zero iff its absolute value is zero. +Extends `Mathlib.Algebra.Order.Module.Basic.abs_eq_zero` to the non-total-order setting. -/ +theorem abs_eq_zero_iff_zero : |x| = 0 ↔ x = 0 := by + constructor + · intro h + rw [← negPart_add_posPart, add_eq_zero_iff_eq_neg] at h + have h1 : x⁺ = 0 := by + apply le_antisymm + · rw [← neg_zero] + apply le_neg_of_le_neg + rw [← h] + exact negPart_nonneg x + · exact posPart_nonneg x + have h2 : x⁻ = 0 := by + apply le_antisymm + · rw [h] + apply neg_le_of_neg_le + rw [neg_zero] + exact posPart_nonneg x + · exact negPart_nonneg x + rw [← posPart_sub_negPart x] + rw [h1, h2] + simp + · intro h + simp [h] + +/-- If `x = u - v` with `u ⊓ v = 0`, then `u` is the positive part of `x`. -/ +theorem uniqueness_posPart {u v : X} (hdif : x = u - v) (udisv : u ⊓ v = 0) : + u = x⁺ := by + symm + calc + x⁺ = x ⊔ 0 := by rfl + _ = (u - v) ⊔ 0 := by rw [hdif] + _ = u ⊔ v + (-v) := by rw [add_comm, add_sup]; simp [sub_eq_add_neg, add_comm] + _ = u + v + (-v) := by rw [← inf_add_sup u v, udisv, zero_add] + _ = u := by simp + +/-- `x ⊔ y = x + (y - x)⁺`. -/ +theorem sup_eq_add_posPart (y : X) : x ⊔ y = x + (y - x)⁺ := by + rw [posPart_def, add_sup, add_sub_cancel, add_zero, sup_comm] + +/-- `x ⊓ y = x - (x - y)⁺`. -/ +theorem inf_eq_sub_posPart (y : X) : x ⊓ y = x - (x - y)⁺ := by + rw [posPart_def, sub_eq_add_neg, neg_sup, neg_sub, neg_zero, add_inf, add_zero, inf_comm] + congr 1; abel + +/-- `x - x ⊓ y = (x - y)⁺`. -/ +theorem sub_inf_eq_posPart (y : X) : x - x ⊓ y = (x - y)⁺ := by + rw [inf_eq_sub_posPart, sub_sub_cancel] + +/-- The positive part is subadditive: `(x + y)⁺ ≤ x⁺ + y⁺`. -/ +theorem posPart_add_le (y : X) : (x + y)⁺ ≤ x⁺ + y⁺ := + sup_le (add_le_add (le_posPart x) (le_posPart y)) + (add_nonneg (posPart_nonneg x) (posPart_nonneg y)) + +/-- The positive part is bounded by the modulus. -/ +theorem posPart_le_abs : x⁺ ≤ |x| := by + rw [posPart_def] + exact sup_le (le_abs_self x) (abs_nonneg x) + +/-- The negative part is bounded by the modulus. -/ +theorem negPart_le_abs : x⁻ ≤ |x| := by + rw [negPart_def] + exact sup_le (neg_le_abs x) (abs_nonneg x) + +/-- For non-negative `x`, `a`, `b`: `x ⊓ (a + b) ≤ x ⊓ a + x ⊓ b`. -/ +theorem inf_le_inf_add_inf_of_nonneg (a b : X) (hx : 0 ≤ x) (ha : 0 ≤ a) (hb : 0 ≤ b) : + x ⊓ (a + b) ≤ x ⊓ a + x ⊓ b := by + set c := x ⊓ (a + b) with hc_def + have hcx : c ≤ x := inf_le_left + have hcab : c ≤ a + b := inf_le_right + have hca_nn : 0 ≤ c ⊓ a := le_inf (le_inf hx (add_nonneg ha hb)) ha + have h1 : c - c ⊓ a = (c - a)⁺ := sub_inf_eq_posPart c a + have h2 : (c - a)⁺ ≤ b := by + rw [← posPart_of_nonneg hb] + exact posPart_mono (sub_le_iff_le_add.mpr (by rwa [add_comm])) + have h3 : c - c ⊓ a ≤ x := by + have := sub_le_self c hca_nn + exact this.trans hcx + have h4 : c - c ⊓ a ≤ x ⊓ b := le_inf h3 (h1 ▸ h2) + have h5 : c ⊓ a ≤ x ⊓ a := inf_le_inf_right _ hcx + have h4' : c ≤ x ⊓ b + c ⊓ a := sub_le_iff_le_add.mp h4 + calc c ≤ x ⊓ b + c ⊓ a := h4' + _ ≤ x ⊓ b + x ⊓ a := by gcongr + _ = x ⊓ a + x ⊓ b := add_comm _ _ + +/-- Translation preserves suprema: `x + sup A = sup(x + A)`. -/ +theorem isLUB_const_add {A : Set X} {a : X} (x : X) (h : IsLUB A a) : + IsLUB ((fun z => x + z) '' A) (x + a) := + (OrderIso.addLeft x).isLUB_image'.mpr h + +/-- Translation preserves infima: `x + inf A = inf(x + A)`. -/ +theorem isGLB_const_add {A : Set X} {a : X} (x : X) (h : IsGLB A a) : + IsGLB ((fun z => x + z) '' A) (x + a) := + (OrderIso.addLeft x).isGLB_image'.mpr h + +/-- Meet distributes over arbitrary suprema: `x ⊓ sup A = sup {x ⊓ a : a ∈ A}`. -/ +theorem isLUB_inf_const {A : Set X} {a : X} (x : X) (h : IsLUB A a) : + IsLUB ((fun z => x ⊓ z) '' A) (x ⊓ a) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨z, hz, rfl⟩ + exact inf_le_inf_left x (h.1 hz) + · intro u hu + have hA : ∀ z ∈ A, z ≤ u + (a - x)⁺ := by + intro z hz + have hzu : z - (z - x)⁺ ≤ u := by + rw [← inf_eq_sub_posPart, inf_comm]; exact hu ⟨z, hz, rfl⟩ + have hmono : (z - x)⁺ ≤ (a - x)⁺ := posPart_mono (sub_le_sub_right (h.1 hz) x) + have h1 : z ≤ u + (z - x)⁺ := sub_le_iff_le_add.mp hzu + exact h1.trans (by gcongr) + have key : a ≤ u + (a - x)⁺ := h.2 hA + calc x ⊓ a = a ⊓ x := inf_comm _ _ + _ = a - (a - x)⁺ := inf_eq_sub_posPart a x + _ ≤ u := sub_le_iff_le_add.mpr key + +/-- Join distributes over arbitrary infima: `x ⊔ inf A = inf {x ⊔ a : a ∈ A}`. -/ +theorem isGLB_sup_const {A : Set X} {a : X} (x : X) (h : IsGLB A a) : + IsGLB ((fun z => x ⊔ z) '' A) (x ⊔ a) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨z, hz, rfl⟩ + exact sup_le_sup_left (h.1 hz) x + · intro u hu + have hA : ∀ z ∈ A, u - (x - a)⁺ ≤ z := by + intro z hz + have hzu : u ≤ z + (x - z)⁺ := by + rw [← sup_eq_add_posPart, sup_comm]; exact hu ⟨z, hz, rfl⟩ + have hmono : (x - z)⁺ ≤ (x - a)⁺ := posPart_mono (sub_le_sub_left (h.1 hz) x) + exact sub_le_iff_le_add.mpr (hzu.trans (by gcongr)) + have key : u - (x - a)⁺ ≤ a := h.2 hA + calc u = (u - (x - a)⁺) + (x - a)⁺ := by abel + _ ≤ a + (x - a)⁺ := by gcongr + _ = a ⊔ x := (sup_eq_add_posPart a x).symm + _ = x ⊔ a := sup_comm _ _ + +/-- `inf(A + B) = inf A + inf B`. -/ +theorem isGLB_add_sets {A B : Set X} {a b : X} + (hA : IsGLB A a) (hB : IsGLB B b) : + IsGLB ((fun p : X × X => p.1 + p.2) '' (A ×ˢ B)) (a + b) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨⟨p, q⟩, ⟨hp, hq⟩, rfl⟩ + exact add_le_add (hA.1 hp) (hB.1 hq) + · intro u hu + have h1 : ∀ p ∈ A, u ≤ p + b := by + intro p hp + have hp_lb : u - p ∈ lowerBounds B := fun q hq => by + have hpq : u ≤ p + q := hu ⟨(p, q), ⟨hp, hq⟩, rfl⟩ + rw [add_comm] at hpq + exact sub_le_iff_le_add.mpr hpq + have : u ≤ b + p := sub_le_iff_le_add.mp (hB.2 hp_lb) + rwa [add_comm] at this + have h2 : u - b ∈ lowerBounds A := fun p hp => + sub_le_iff_le_add.mpr (h1 p hp) + exact sub_le_iff_le_add.mp (hA.2 h2) + +/-- `inf(A ∨ B) = inf A ∨ inf B`, where `A ∨ B = {p ⊔ q : p ∈ A, q ∈ B}`. -/ +theorem isGLB_sup_sets {A B : Set X} {a b : X} + (hA : IsGLB A a) (hB : IsGLB B b) : + IsGLB ((fun p : X × X => p.1 ⊔ p.2) '' (A ×ˢ B)) (a ⊔ b) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨⟨p, q⟩, ⟨hp, hq⟩, rfl⟩ + exact sup_le_sup (hA.1 hp) (hB.1 hq) + · intro u hu + have h1 : ∀ q ∈ B, u ≤ a ⊔ q := by + intro q hq + have hlb : u ∈ lowerBounds ((fun z => q ⊔ z) '' A) := by + rintro _ ⟨p, hp, rfl⟩ + have hpq : u ≤ p ⊔ q := hu ⟨(p, q), ⟨hp, hq⟩, rfl⟩ + rw [sup_comm] at hpq; exact hpq + have hqa : u ≤ q ⊔ a := (isGLB_sup_const q hA).2 hlb + rwa [sup_comm] at hqa + exact (isGLB_sup_const a hB).2 (by rintro _ ⟨q, hq, rfl⟩; exact h1 q hq) + +omit [AddCommGroup X] [IsOrderedAddMonoid X] in +/-- `inf(A ∪ B) = (inf A) ⊓ (inf B)`. -/ +theorem isGLB_union {A B : Set X} {a b : X} + (hA : IsGLB A a) (hB : IsGLB B b) : IsGLB (A ∪ B) (a ⊓ b) := by + refine ⟨?_, ?_⟩ + · rintro z (hz | hz) + · exact inf_le_left.trans (hA.1 hz) + · exact inf_le_right.trans (hB.1 hz) + · intro u hu + have ha : u ≤ a := hA.2 fun z hz => hu (Or.inl hz) + have hb : u ≤ b := hB.2 fun z hz => hu (Or.inr hz) + exact le_inf ha hb + +end LatticeOrderedGroup + +section VectorLattice + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +variable (x y : X) + +/-- A non-negative scalar distributes over `⊔`. -/ +theorem nonneg_smul_sup (a : ℝ) (nonneg : a ≥ 0) : + a • (x ⊔ y) = (a • x) ⊔ (a • y) := by + by_cases h : a = 0 + · subst h + simp only [zero_smul]; exact Eq.symm Std.max_self + · apply le_antisymm + · have hx : a⁻¹ • a • x ≤ a⁻¹ • (a • x ⊔ a • y) := by + exact smul_le_smul_of_nonneg_left + le_sup_left + (by norm_num [nonneg]) + have hy : a⁻¹ • a • y ≤ a⁻¹ • (a • x ⊔ a • y) := by + exact smul_le_smul_of_nonneg_left + le_sup_right + (by norm_num [nonneg]) + simp only [inv_smul_smul₀ h] at hx hy + have hxy : x ⊔ y ≤ a⁻¹ • (a • x ⊔ a • y) := + sup_le hx hy + calc + a • (x ⊔ y) ≤ a • (a⁻¹ • (a • x ⊔ a • y)) := by + exact smul_le_smul_of_nonneg_left hxy nonneg + _ = a • x ⊔ a • y := by rw [smul_smul a a⁻¹ _]; norm_num [h]; + · have hx : a • x ≤ a • (x ⊔ y) := + smul_le_smul_of_nonneg_left le_sup_left nonneg + have hy : a • y ≤ a • (x ⊔ y) := + smul_le_smul_of_nonneg_left le_sup_right nonneg + exact sup_le hx hy + +/-- A non-negative scalar commutes with the positive part. -/ +theorem posPart_smul_nonneg {a : ℝ} (ha : 0 ≤ a) (x : X) : + (a • x)⁺ = a • x⁺ := by + change (a • x) ⊔ 0 = a • (x ⊔ 0) + rw [← smul_zero a, ← nonneg_smul_sup x 0 a ha, smul_zero] + +/-- A non-negative scalar distributes over suprema: `λ • sup A = sup (λ • A)`. -/ +theorem isLUB_smul_of_nonneg {A : Set X} {a : X} {lam : ℝ} (hlam : 0 ≤ lam) + (h : IsLUB A a) : IsLUB ((fun z => lam • z) '' A) (lam • a) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨z, hz, rfl⟩ + exact smul_le_smul_of_nonneg_left (h.1 hz) hlam + · intro u hu + by_cases hl : lam = 0 + · subst hl; rw [zero_smul] + rcases A.eq_empty_or_nonempty with rfl | ⟨z, hz⟩ + · have hmin : ∀ b : X, a ≤ b := fun b => + h.2 fun x hx => (Set.notMem_empty x hx).elim + have h0a : 0 ≤ a := + (add_le_add_iff_left a).mp (by rw [add_zero]; exact hmin (a + a)) + exact h0a.trans (hmin u) + · have : (0 : ℝ) • z ≤ u := hu ⟨z, hz, rfl⟩ + rwa [zero_smul] at this + · have hlam_pos : 0 < lam := lt_of_le_of_ne hlam (Ne.symm hl) + have hinv_nn : 0 ≤ lam⁻¹ := le_of_lt (inv_pos.mpr hlam_pos) + have h_ub : lam⁻¹ • u ∈ upperBounds A := fun z hz => by + have h1 : lam⁻¹ • (lam • z) ≤ lam⁻¹ • u := + smul_le_smul_of_nonneg_left (hu ⟨z, hz, rfl⟩) hinv_nn + rwa [inv_smul_smul₀ hl] at h1 + have h4 : lam • a ≤ lam • (lam⁻¹ • u) := + smul_le_smul_of_nonneg_left (h.2 h_ub) hlam + rwa [smul_inv_smul₀ hl] at h4 + +/-- A non-negative scalar distributes over infima: `λ • inf A = inf (λ • A)`. -/ +theorem isGLB_smul_of_nonneg {A : Set X} {a : X} {lam : ℝ} (hlam : 0 ≤ lam) + (h : IsGLB A a) : IsGLB ((fun z => lam • z) '' A) (lam • a) := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨z, hz, rfl⟩ + exact smul_le_smul_of_nonneg_left (h.1 hz) hlam + · intro u hu + by_cases hl : lam = 0 + · subst hl; rw [zero_smul] + rcases A.eq_empty_or_nonempty with rfl | ⟨z, hz⟩ + · have hmax : ∀ b : X, b ≤ a := fun b => + h.2 fun x hx => (Set.notMem_empty x hx).elim + have ha0 : a ≤ 0 := + (add_le_add_iff_left a).mp (by rw [add_zero]; exact hmax (a + a)) + exact (hmax u).trans ha0 + · have : u ≤ (0 : ℝ) • z := hu ⟨z, hz, rfl⟩ + rwa [zero_smul] at this + · have hlam_pos : 0 < lam := lt_of_le_of_ne hlam (Ne.symm hl) + have hinv_nn : 0 ≤ lam⁻¹ := le_of_lt (inv_pos.mpr hlam_pos) + have h_lb : lam⁻¹ • u ∈ lowerBounds A := fun z hz => by + have h1 : lam⁻¹ • u ≤ lam⁻¹ • (lam • z) := + smul_le_smul_of_nonneg_left (hu ⟨z, hz, rfl⟩) hinv_nn + rwa [inv_smul_smul₀ hl] at h1 + have h4 : lam • (lam⁻¹ • u) ≤ lam • a := + smul_le_smul_of_nonneg_left (h.2 h_lb) hlam + rwa [smul_inv_smul₀ hl] at h4 + +/-- A non-negative scalar distributes over `⊓`. -/ +theorem nonneg_smul_inf (a : ℝ) (nonneg : a ≥ 0) : + a • (x ⊓ y) = (a • x) ⊓ (a • y) := by + calc + a • (x ⊓ y) = (-1) • a • (- (x ⊓ y)) := by simp + _ = (-1) • a • ((-x) ⊔ (-y)) := by rw [neg_inf] + _ = (-1) • ((a • -x) ⊔ (a • -y)) := by rw [nonneg_smul_sup (-x) (-y) a nonneg] + _ = - ((-a • x) ⊔ (-a • y)) := by simp + _ = (a • x) ⊓ (a • y) := by rw [neg_sup]; simp + +/-- Scalar `sup` distributes over a non-negative element. -/ +theorem sup_smul_nonneg (a b : ℝ) (h : 0 ≤ x) : + (a ⊔ b) • x = (a • x) ⊔ (b • x) := by + apply le_antisymm + · cases max_choice a b with + | inl h => rw [h]; exact le_sup_left + | inr h => rw [h]; exact le_sup_right + · apply sup_le + · exact smul_le_smul_of_nonneg_right le_sup_left h + · exact smul_le_smul_of_nonneg_right le_sup_right h + +/-- Scalar `inf` distributes over a non-negative element. -/ +theorem inf_smul_nonneg (a b : ℝ) (h : 0 ≤ x) : + (a ⊓ b) • x = (a • x) ⊓ (b • x) := by + apply le_antisymm + · apply le_inf + · exact smul_le_smul_of_nonneg_right inf_le_left h + · exact smul_le_smul_of_nonneg_right inf_le_right h + · cases min_choice a b with + | inl h => rw [h]; exact inf_le_left + | inr h => rw [h]; exact inf_le_right + +/-- `|a • x| = |a| • |x|` in a vector lattice. +Extends the Mathlib result of the same name from total orders to lattice orders. -/ +theorem abs_smul' (a : ℝ) : |a • x| = |a| • |x| := by + by_cases ha : a ≥ 0 + · rw [abs_of_nonneg ha] + rw [abs, abs] + rw [nonneg_smul_sup x (-x) a ha] + simp + · have hna : a < 0 := by linarith + rw [abs_of_neg hna] + rw [abs, abs] + rw [nonneg_smul_sup x (-x) (-a) (by linarith)] + simp [sup_comm] + +section Archimedean + +/-- A lattice-ordered group is **Archimedean** (in the vector-lattice sense) when the only +non-negative element all of whose multiples are bounded is zero: `0 ≤ x` and `∀ n, n • x ≤ y` +imply `x = 0`. This is the standard Archimedean property for partially ordered groups; it is +weaker than Mathlib's `Archimedean` class, which is stated for linearly ordered monoids. -/ +class IsVLArchimedean (X : Type*) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] : Prop where + le_zero_of_forall_nsmul_le {x y : X} : + (∀ n : ℕ, n • x ≤ y) → x ≤ 0 + +private lemma nsmul_posPart_le_of_forall_nsmul_le {Y : Type*} [AddCommGroup Y] [Lattice Y] + [IsOrderedAddMonoid Y] (x : Y) : + ∀ (n : ℕ) (v : Y), (∀ k : ℕ, k ≤ n → k • x ≤ v) → n • (x ⊔ 0) ≤ v := by + intro n + induction n with + | zero => + intro v h + simpa using h 0 (le_refl 0) + | succ n ih => + intro v h + rw [succ_nsmul, add_sup, add_zero] + refine sup_le ?_ (ih v fun k hk => h k (hk.trans (Nat.le_succ n))) + rw [← le_sub_iff_add_le] + refine ih (v - x) fun k hk => ?_ + rw [le_sub_iff_add_le, ← succ_nsmul] + exact h (k + 1) (Nat.succ_le_succ hk) + +omit [VectorLattice X] in +/-- Constructor from the non-negative formulation of the Archimedean property. -/ +theorem isVLArchimedean_of_eq_zero_of_nonneg_of_forall_nsmul_le + (H : ∀ {x y : X}, 0 ≤ x → (∀ n : ℕ, n • x ≤ y) → x = 0) : + IsVLArchimedean X := by + refine ⟨fun {x y} h => ?_⟩ + have hsup : x ⊔ 0 = 0 := + H le_sup_right + (fun n => nsmul_posPart_le_of_forall_nsmul_le x n y fun k _ => h k) + exact sup_eq_right.mp hsup + +omit [VectorLattice X] in +/-- In a vector lattice, being Archimedean is equivalent to the condition that +`n • x ≤ y` for all `n : ℕ` implies `x ≤ 0`. -/ +theorem isVLArchimedean_iff_le_zero_of_forall_nsmul_le : + IsVLArchimedean X ↔ ∀ {x y : X}, (∀ n : ℕ, n • x ≤ y) → x ≤ 0 := by + exact ⟨fun hArch _ _ h => hArch.le_zero_of_forall_nsmul_le h, + fun H => ⟨fun {x y} h => H h⟩⟩ + +namespace IsVLArchimedean + +omit [VectorLattice X] in +/-- Non-negative form of the Archimedean property. -/ +theorem eq_zero_of_nonneg_of_forall_nsmul_le [IsVLArchimedean X] {x y : X} + (hx : 0 ≤ x) (h : ∀ n : ℕ, n • x ≤ y) : x = 0 := + le_antisymm (IsVLArchimedean.le_zero_of_forall_nsmul_le h) hx + +end IsVLArchimedean + +/-- A vector lattice is Archimedean iff for every positive `u`, the infimum of +`(1/n) • u` over `n ≥ 1` equals `0`. -/ +theorem isVLArchimedean_iff_isGLB_inv_smul : + IsVLArchimedean X ↔ + ∀ u : X, 0 ≤ u → + IsGLB {v : X | ∃ n : ℕ, 0 < n ∧ v = (n : ℝ)⁻¹ • u} 0 := by + constructor + · intro hArch u hu + refine ⟨?_, ?_⟩ + · rintro _ ⟨n, _, rfl⟩ + exact smul_nonneg (by positivity) hu + · intro w hw + apply isVLArchimedean_iff_le_zero_of_forall_nsmul_le.mp hArch (y := u) + intro n + rcases Nat.eq_zero_or_pos n with rfl | hnpos + · simpa using hu + · have hwn : w ≤ (n : ℝ)⁻¹ • u := hw ⟨n, hnpos, rfl⟩ + have hn_nn : (0 : ℝ) ≤ (n : ℝ) := Nat.cast_nonneg n + have h1 : (n : ℝ) • w ≤ (n : ℝ) • ((n : ℝ)⁻¹ • u) := + smul_le_smul_of_nonneg_left hwn hn_nn + rw [smul_inv_smul₀ (Nat.cast_ne_zero.mpr hnpos.ne')] at h1 + rwa [Nat.cast_smul_eq_nsmul] at h1 + · intro H + apply isVLArchimedean_of_eq_zero_of_nonneg_of_forall_nsmul_le + intro x y hx h + set u := y ⊔ 0 with hu_def + have hu : 0 ≤ u := le_sup_right + have hx_lb : x ∈ lowerBounds {v : X | ∃ n : ℕ, 0 < n ∧ v = (n : ℝ)⁻¹ • u} := by + rintro _ ⟨n, hnpos, rfl⟩ + have h1 : (n : ℝ) • x ≤ u := by + rw [Nat.cast_smul_eq_nsmul] + exact (h n).trans le_sup_left + have hn_pos : (0 : ℝ) < n := Nat.cast_pos.mpr hnpos + have h2 : (n : ℝ)⁻¹ • ((n : ℝ) • x) ≤ (n : ℝ)⁻¹ • u := + smul_le_smul_of_nonneg_left h1 (le_of_lt (inv_pos.mpr hn_pos)) + rwa [inv_smul_smul₀ hn_pos.ne'] at h2 + exact le_antisymm ((H u hu).2 hx_lb) hx + +variable [IsVLArchimedean X] + +omit [VectorLattice X] in +/-- An element whose absolute-value multiples are bounded must be zero. -/ +theorem infinitesimal_eq_zero {x y : X} + (h : ∀ n : ℕ, n • |x| ≤ y) : x = 0 := by + have hab : |x| = 0 := + IsVLArchimedean.eq_zero_of_nonneg_of_forall_nsmul_le (abs_nonneg x) h + exact (abs_eq_zero_iff_zero x).mp hab + +private lemma exists_real_eq_smul_of_linear_comparable + (hcon : ∀ z : X, 0 ≤ z ∨ z ≤ 0) + {u v : X} (hu : 0 ≤ u) (hu0 : u ≠ 0) (hv : 0 ≤ v) : + ∃ r : ℝ, v = r • u := by + let S : Set ℝ := {r | r • u ≤ v} + have hS_ne : S.Nonempty := ⟨0, by simp [S, hv]⟩ + have hN : ∃ n : ℕ, ¬ (n : ℝ) • u ≤ v := by + by_contra hna + push Not at hna + exact hu0 <| le_antisymm + (isVLArchimedean_iff_le_zero_of_forall_nsmul_le.mp inferInstance + (fun n => (Nat.cast_smul_eq_nsmul ℝ n u) ▸ hna n)) hu + obtain ⟨N, hNp⟩ := hN + have hS_bdd : BddAbove S := ⟨(N : ℝ), fun r hr => by + by_contra hlt; push Not at hlt + exact hNp ((smul_le_smul_of_nonneg_right hlt.le hu).trans hr)⟩ + set lam := sSup S with hlam_def + refine ⟨lam, ?_⟩ + have heq : v - lam • u = 0 := by + refine infinitesimal_eq_zero (y := u) fun m => ?_ + rcases Nat.eq_zero_or_pos m with rfl | hm_pos + · simpa using hu + have hm_real_pos : (0 : ℝ) < m := by exact_mod_cast hm_pos + have hm_inv_pos : (0 : ℝ) < (m : ℝ)⁻¹ := inv_pos.mpr hm_real_pos + have hUp : v - lam • u ≤ (m : ℝ)⁻¹ • u := by + have h_not : ¬ (lam + (m : ℝ)⁻¹) • u ≤ v := fun hle => + (lt_add_of_pos_right lam hm_inv_pos).not_ge (le_csSup hS_bdd hle) + have hvle : v ≤ (lam + (m : ℝ)⁻¹) • u := by + rcases hcon (v - (lam + (m : ℝ)⁻¹) • u) with hnn | hnp + · exact absurd (sub_nonneg.mp hnn) h_not + · exact sub_nonpos.mp hnp + rw [add_smul] at hvle + exact sub_le_iff_le_add.mpr (by rwa [add_comm]) + have hLo : -((m : ℝ)⁻¹ • u) ≤ v - lam • u := by + obtain ⟨r, hrS, hr⟩ : ∃ r ∈ S, lam - (m : ℝ)⁻¹ < r := + exists_lt_of_lt_csSup hS_ne (sub_lt_self lam hm_inv_pos) + have h2 : (lam - (m : ℝ)⁻¹) • u ≤ v := + (smul_le_smul_of_nonneg_right hr.le hu).trans hrS + rw [sub_smul] at h2 + rw [neg_le, neg_sub] + have h3 : lam • u ≤ v + (m : ℝ)⁻¹ • u := sub_le_iff_le_add.mp h2 + rw [add_comm] at h3 + exact sub_le_iff_le_add.mpr h3 + have habs : |v - lam • u| ≤ (m : ℝ)⁻¹ • u := + abs_le'.mpr ⟨hUp, neg_le.mp hLo⟩ + have hm_nn : (0 : ℝ) ≤ m := hm_real_pos.le + have hmabs : (m : ℝ) • |v - lam • u| ≤ (m : ℝ) • ((m : ℝ)⁻¹ • u) := + smul_le_smul_of_nonneg_left habs hm_nn + rw [smul_inv_smul₀ hm_real_pos.ne'] at hmabs + rwa [Nat.cast_smul_eq_nsmul] at hmabs + exact sub_eq_zero.mp heq + +/-- If `X` is an Archimedean vector lattice with more than one dimension, then +there exists a vector in `X` which is neither positive nor negative. -/ +theorem exists_not_nonneg_not_nonpos_of_one_lt_rank + (h : 1 < Module.rank ℝ X) : ∃ x : X, ¬ 0 ≤ x ∧ ¬ x ≤ 0 := by + by_contra hcon + push Not at hcon + have hcon' : ∀ x : X, 0 ≤ x ∨ x ≤ 0 := + fun x => (Classical.or_iff_not_imp_left).mpr (hcon x) + have hnt : Nontrivial X := + (rank_pos_iff_nontrivial (R := ℝ) (M := X)).mp (lt_of_le_of_lt zero_le_one h) + obtain ⟨x0, hx0⟩ : ∃ x : X, x ≠ 0 := exists_ne 0 + obtain ⟨y0, hxy⟩ := exists_linearIndependent_pair_of_one_lt_rank h hx0 + have hy0 : y0 ≠ 0 := by + have := hxy.ne_zero 1 + simpa [Matrix.cons_val_one, Matrix.head_cons] using this + obtain ⟨u, hu_eq, hu_pos, hu_nz⟩ : ∃ u : X, (u = x0 ∨ u = -x0) ∧ 0 ≤ u ∧ u ≠ 0 := by + rcases hcon' x0 with hp | hp + · exact ⟨x0, Or.inl rfl, hp, hx0⟩ + · exact ⟨-x0, Or.inr rfl, neg_nonneg.mpr hp, neg_ne_zero.mpr hx0⟩ + obtain ⟨v, hv_eq, hv_pos, _⟩ : ∃ v : X, (v = y0 ∨ v = -y0) ∧ 0 ≤ v ∧ v ≠ 0 := by + rcases hcon' y0 with hp | hp + · exact ⟨y0, Or.inl rfl, hp, hy0⟩ + · exact ⟨-y0, Or.inr rfl, neg_nonneg.mpr hp, neg_ne_zero.mpr hy0⟩ + obtain ⟨r, hr⟩ := exists_real_eq_smul_of_linear_comparable hcon' hu_pos hu_nz hv_pos + have hxy_dep : ∃ s : ℝ, y0 = s • x0 := by + obtain (hu1 : u = x0) | (hu1 : u = -x0) := hu_eq + · obtain (hv1 : v = y0) | (hv1 : v = -y0) := hv_eq + · rw [hu1, hv1] at hr; exact ⟨r, hr⟩ + · rw [hu1, hv1] at hr + refine ⟨-r, ?_⟩ + have h1 : y0 = -(r • x0) := by rw [← hr, neg_neg] + rw [h1, neg_smul] + · obtain (hv1 : v = y0) | (hv1 : v = -y0) := hv_eq + · rw [hu1, hv1] at hr + refine ⟨-r, ?_⟩ + rw [hr, smul_neg, ← neg_smul] + · rw [hu1, hv1] at hr + refine ⟨r, ?_⟩ + rw [smul_neg] at hr + rw [← neg_neg y0, hr, neg_neg] + obtain ⟨s, hs⟩ := hxy_dep + let g : Fin 2 → ℝ := ![s, -1] + have key : ∑ i : Fin 2, g i • ![x0, y0] i = 0 := by + change ∑ i : Fin 2, (![s, -1] : Fin 2 → ℝ) i • ![x0, y0] i = 0 + rw [Fin.sum_univ_two] + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] + rw [hs, neg_one_smul] + abel + have h_false : g 1 = 0 := Fintype.linearIndependent_iff.mp hxy g key 1 + simp [g] at h_false + +end Archimedean + +end VectorLattice diff --git a/LeanPool/OrderClosures/BanLat/Convergences/Order.lean b/LeanPool/OrderClosures/BanLat/Convergences/Order.lean new file mode 100644 index 0000000000..517ec59474 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Convergences/Order.lean @@ -0,0 +1,367 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Basic + + +/-! +# Order convergence + +This file introduces order convergence of nets in a vector lattice. The definition uses a +separate directed regulator net decreasing to zero, so the regulator need not have the same +index set as the net being controlled. +-/ + +@[expose] public section + +universe u v + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +/-- A net `u` **order converges** to `x` if its tails are eventually controlled +by a separate decreasing regulator net with greatest lower bound zero. -/ +def OrderConvergesTo {ι : Type v} [Preorder ι] (u : ι → X) (x : X) : Prop := + ∃ (κ : Type u) (_ : Preorder κ) (_ : IsDirected κ (· ≤ ·)) (_ : Nonempty κ), + ∃ r : κ → X, + Antitone r ∧ + (∀ k, 0 ≤ r k) ∧ + IsGLB (Set.range r) 0 ∧ + ∀ k, ∀ᶠ i in Filter.atTop, |u i - x| ≤ r k + +/-- A constant net order converges to its constant value. -/ +theorem orderConvergesTo_const {ι : Type v} [Preorder ι] + (x : X) : + OrderConvergesTo (fun _ : ι => x) x := by + refine ⟨ULift.{u} PUnit, inferInstance, inferInstance, inferInstance, + fun _ => 0, ?_, ?_, ?_, ?_⟩ + · intro _ _ _ + exact le_rfl + · intro _ + exact le_rfl + · simp + · intro _ + filter_upwards with i + simp + +omit [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] in +private theorem isDirected_prod {κ τ : Type u} [Preorder κ] [Preorder τ] + [IsDirected κ (· ≤ ·)] [IsDirected τ (· ≤ ·)] : + IsDirected (κ × τ) (· ≤ ·) := by + refine ⟨fun a b => ?_⟩ + obtain ⟨k, hak, hbk⟩ := directed_of (· ≤ ·) a.1 b.1 + obtain ⟨l, hal, hbl⟩ := directed_of (· ≤ ·) a.2 b.2 + exact ⟨(k, l), ⟨hak, hal⟩, ⟨hbk, hbl⟩⟩ + +private theorem isGLB_range_add {κ τ : Type u} (r : κ → X) (s : τ → X) + (hr : IsGLB (Set.range r) 0) (hs : IsGLB (Set.range s) 0) : + IsGLB (Set.range (fun p : κ × τ => r p.1 + s p.2)) 0 := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨⟨k, l⟩, rfl⟩ + exact add_nonneg (hr.1 ⟨k, rfl⟩) (hs.1 ⟨l, rfl⟩) + · intro w hw + have hw_s : w ∈ lowerBounds (Set.range s) := by + rintro _ ⟨l, rfl⟩ + have hw_r : w - s l ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + exact sub_le_iff_le_add.mpr (by simpa [add_comm] using hw ⟨(k, l), rfl⟩) + exact sub_nonpos.mp (hr.2 hw_r) + exact hs.2 hw_s + +private theorem abs_sup_sub_sup_le_add (a b c d : X) : + |(a ⊔ b) - (c ⊔ d)| ≤ |a - c| + |b - d| := by + calc + |(a ⊔ b) - (c ⊔ d)| + = |((a ⊔ b) - (c ⊔ b)) + ((c ⊔ b) - (c ⊔ d))| := by + congr 1 + abel + _ ≤ |(a ⊔ b) - (c ⊔ b)| + |(c ⊔ b) - (c ⊔ d)| := abs_add_le _ _ + _ ≤ |a - c| + |b - d| := by + exact add_le_add (abs_sup_sub_sup_le_abs a c b) (by + rw [sup_comm c b, sup_comm c d] + exact abs_sup_sub_sup_le_abs b d c) + +private theorem abs_inf_sub_inf_le_add (a b c d : X) : + |(a ⊓ b) - (c ⊓ d)| ≤ |a - c| + |b - d| := by + calc + |(a ⊓ b) - (c ⊓ d)| + = |((a ⊓ b) - (c ⊓ b)) + ((c ⊓ b) - (c ⊓ d))| := by + congr 1 + abel + _ ≤ |(a ⊓ b) - (c ⊓ b)| + |(c ⊓ b) - (c ⊓ d)| := abs_add_le _ _ + _ ≤ |a - c| + |b - d| := by + exact add_le_add (abs_inf_sub_inf_le_abs a c b) (by + rw [inf_comm c b, inf_comm c d] + exact abs_inf_sub_inf_le_abs b d c) + +omit [AddCommGroup X] [IsOrderedAddMonoid X] in +private theorem isDirected_range_monotone {ι : Type v} [Preorder ι] + [IsDirected ι (· ≤ ·)] {u : ι → X} (hmono : Monotone u) : + IsDirected (Set.range u) (· ≤ ·) := by + refine ⟨fun a b => ?_⟩ + rcases a.2 with ⟨i, hi⟩ + rcases b.2 with ⟨j, hj⟩ + obtain ⟨k, hik, hjk⟩ := directed_of (· ≤ ·) i j + exact ⟨⟨u k, ⟨k, rfl⟩⟩, by + change (a : X) ≤ u k + simpa [← hi] using hmono hik, by + change (b : X) ≤ u k + simpa [← hj] using hmono hjk⟩ + +omit [AddCommGroup X] [IsOrderedAddMonoid X] in +private theorem isDirected_orderDual_range_antitone {ι : Type v} [Preorder ι] + [IsDirected ι (· ≤ ·)] {u : ι → X} (hanti : Antitone u) : + IsDirected (OrderDual (Set.range u)) (· ≤ ·) := by + refine ⟨fun a b => ?_⟩ + rcases (OrderDual.ofDual a : Set.range u).2 with ⟨i, hi⟩ + rcases (OrderDual.ofDual b : Set.range u).2 with ⟨j, hj⟩ + obtain ⟨k, hik, hjk⟩ := directed_of (· ≤ ·) i j + refine ⟨OrderDual.toDual (⟨u k, ⟨k, rfl⟩⟩ : Set.range u), ?_, ?_⟩ + · change (⟨u k, ⟨k, rfl⟩⟩ : Set.range u) ≤ OrderDual.ofDual a + change u k ≤ (OrderDual.ofDual a : Set.range u) + simpa [hi] using hanti hik + · change (⟨u k, ⟨k, rfl⟩⟩ : Set.range u) ≤ OrderDual.ofDual b + change u k ≤ (OrderDual.ofDual b : Set.range u) + simpa [hj] using hanti hjk + +/-- An increasing net order converges to its least upper bound. -/ +theorem orderConvergesTo_of_monotone_isLUB {ι : Type v} [Preorder ι] + [IsDirected ι (· ≤ ·)] [Nonempty ι] {u : ι → X} {x : X} + (hmono : Monotone u) (hlub : IsLUB (Set.range u) x) : + OrderConvergesTo u x := by + let : Nonempty (Set.range u) := by + obtain ⟨i⟩ := (inferInstance : Nonempty ι) + exact ⟨⟨u i, ⟨i, rfl⟩⟩⟩ + refine ⟨Set.range u, inferInstance, isDirected_range_monotone hmono, inferInstance, + fun y => x - y.1, ?_, ?_, ?_, ?_⟩ + · intro a b h + exact sub_le_sub_left (show (a : X) ≤ (b : X) from h) x + · rintro ⟨_, i, rfl⟩ + exact sub_nonneg.mpr (hlub.1 ⟨i, rfl⟩) + · refine ⟨?_, ?_⟩ + · rintro _ ⟨⟨_, i, rfl⟩, rfl⟩ + exact sub_nonneg.mpr (hlub.1 ⟨i, rfl⟩) + · intro w hw + have hlb : ∀ y ∈ Set.range u, y ≤ x - w := by + rintro _ ⟨i, rfl⟩ + exact le_sub_comm.mp (hw ⟨⟨u i, ⟨i, rfl⟩⟩, rfl⟩) + have h := hlub.2 hlb + rwa [le_sub_iff_add_le, add_comm, add_le_iff_nonpos_left] at h + · intro k + rcases k.2 with ⟨j, hj⟩ + refine Filter.eventually_atTop.mpr ⟨j, fun i hij => ?_⟩ + have hix : u i ≤ x := hlub.1 ⟨i, rfl⟩ + rw [abs_of_nonpos (sub_nonpos.mpr hix), neg_sub] + simpa [hj] using sub_le_sub_left (hmono hij) x + +/-- A decreasing net order converges to its greatest lower bound. -/ +theorem orderConvergesTo_of_antitone_isGLB {ι : Type v} [Preorder ι] + [IsDirected ι (· ≤ ·)] [Nonempty ι] {u : ι → X} {x : X} + (hanti : Antitone u) (hglb : IsGLB (Set.range u) x) : + OrderConvergesTo u x := by + let : IsDirected (OrderDual (Set.range u)) (· ≤ ·) := + isDirected_orderDual_range_antitone hanti + let : Nonempty (OrderDual (Set.range u)) := by + obtain ⟨i⟩ := (inferInstance : Nonempty ι) + exact ⟨OrderDual.toDual (⟨u i, ⟨i, rfl⟩⟩ : Set.range u)⟩ + refine ⟨OrderDual (Set.range u), inferInstance, inferInstance, inferInstance, + fun y => ((OrderDual.ofDual y : Set.range u) : X) - x, ?_, ?_, ?_, ?_⟩ + · intro a b hab + exact sub_le_sub_right (show ((OrderDual.ofDual b : Set.range u) : X) ≤ + ((OrderDual.ofDual a : Set.range u) : X) from hab) x + · intro y + exact sub_nonneg.mpr (hglb.1 (OrderDual.ofDual y).2) + · refine ⟨?_, ?_⟩ + · rintro _ ⟨y, rfl⟩ + exact sub_nonneg.mpr (hglb.1 (OrderDual.ofDual y).2) + · intro w hw + have hlb : ∀ y ∈ Set.range u, w + x ≤ y := by + rintro _ ⟨i, rfl⟩ + exact add_le_of_le_sub_right + (hw ⟨OrderDual.toDual (⟨u i, ⟨i, rfl⟩⟩ : Set.range u), rfl⟩) + have h := hglb.2 hlb + rwa [add_le_iff_nonpos_left] at h + · intro y + rcases (OrderDual.ofDual y : Set.range u).2 with ⟨j, hj⟩ + refine Filter.eventually_atTop.mpr ⟨j, fun i hij => ?_⟩ + have hxi : x ≤ u i := hglb.1 ⟨i, rfl⟩ + rw [abs_of_nonneg (sub_nonneg.mpr hxi)] + simpa [hj] using sub_le_sub_right (hanti hij) x + +namespace OrderConvergesTo + +/-- The positive cone is order closed: a pointwise non-negative order-convergent net has a +non-negative limit. -/ +theorem nonneg {ι : Type v} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X} {x : X} (hu : OrderConvergesTo u x) (hnn : ∀ i, 0 ≤ u i) : + 0 ≤ x := by + rcases hu with ⟨κ, hκpre, hκdir, hκnon, r, _hranti, _hrnn, hrglb, hrevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + have hlb : -x ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + rcases (hrevent k).exists with ⟨i, hi⟩ + have hx_le : -x ≤ u i - x := by + simpa [zero_sub] using sub_le_sub_right (hnn i) x + exact hx_le.trans ((le_abs_self (u i - x)).trans hi) + exact neg_nonpos.mp (hrglb.2 hlb) + +/-- Addition is order continuous. -/ +theorem add {ι : Type v} [Preorder ι] + {u v : ι → X} {x y : X} (hu : OrderConvergesTo u x) + (hv : OrderConvergesTo v y) : + OrderConvergesTo (fun i => u i + v i) (x + y) := by + rcases hu with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnn, hrglb, hrevent⟩ + rcases hv with ⟨τ, hτpre, hτdir, hτnon, s, hsanti, hsnn, hsglb, hsevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + let : Preorder τ := hτpre + let : IsDirected τ (· ≤ ·) := hτdir + let : Nonempty τ := hτnon + let : IsDirected (κ × τ) (· ≤ ·) := isDirected_prod + refine ⟨κ × τ, inferInstance, inferInstance, inferInstance, + fun p => r p.1 + s p.2, ?_, ?_, ?_, ?_⟩ + · intro p q hpq + exact add_le_add (hranti hpq.1) (hsanti hpq.2) + · exact fun p => add_nonneg (hrnn p.1) (hsnn p.2) + · exact isGLB_range_add r s hrglb hsglb + · intro p + exact ((hrevent p.1).and (hsevent p.2)).mono fun i hi => by + calc + |u i + v i - (x + y)| = |(u i - x) + (v i - y)| := by + congr 1 + abel + _ ≤ |u i - x| + |v i - y| := abs_add_le _ _ + _ ≤ r p.1 + s p.2 := add_le_add hi.1 hi.2 + +omit [IsOrderedAddMonoid X] in +/-- Negation is order continuous. -/ +theorem neg {ι : Type v} [Preorder ι] + {u : ι → X} {x : X} (hu : OrderConvergesTo u x) : + OrderConvergesTo (fun i => -u i) (-x) := by + rcases hu with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnn, hrglb, hrevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + refine ⟨κ, inferInstance, inferInstance, inferInstance, r, hranti, hrnn, hrglb, ?_⟩ + intro k + exact (hrevent k).mono fun i hi => by + calc + |-u i - -x| = |-(u i - x)| := by + congr 1 + abel + _ = |u i - x| := abs_neg _ + _ ≤ r k := hi + +/-- Subtraction is order continuous. -/ +theorem sub {ι : Type v} [Preorder ι] + {u v : ι → X} {x y : X} (hu : OrderConvergesTo u x) + (hv : OrderConvergesTo v y) : + OrderConvergesTo (fun i => u i - v i) (x - y) := by + simpa [sub_eq_add_neg] using hu.add hv.neg + +/-- Order limits respect pointwise order between two nets with the same index set. -/ +theorem le {ι : Type v} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u v : ι → X} {x y : X} (hu : OrderConvergesTo u x) + (hv : OrderConvergesTo v y) (hle : ∀ i, u i ≤ v i) : + x ≤ y := by + have hsub : OrderConvergesTo (fun i => v i - u i) (y - x) := hv.sub hu + exact sub_nonneg.mp (hsub.nonneg fun i => sub_nonneg.mpr (hle i)) + +/-- If an order-convergent net is pointwise bounded above, then its limit is bounded above by +the same bound. -/ +theorem le_of_forall_le {ι : Type v} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X} {x b : X} (hu : OrderConvergesTo u x) (hub : ∀ i, u i ≤ b) : + x ≤ b := + hu.le (orderConvergesTo_const b) hub + +/-- If an order-convergent net is pointwise bounded below, then its limit is bounded below by +the same bound. -/ +theorem forall_le {ι : Type v} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X} {a x : X} (hu : OrderConvergesTo u x) (hau : ∀ i, a ≤ u i) : + a ≤ x := + (orderConvergesTo_const a).le hu hau + +/-- Scalar multiplication is order continuous. -/ +theorem smul [VectorLattice X] (a : ℝ) {ι : Type v} [Preorder ι] + {u : ι → X} {x : X} + (hu : OrderConvergesTo u x) : + OrderConvergesTo (fun i => a • u i) (a • x) := by + rcases hu with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnn, hrglb, hrevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + refine ⟨κ, inferInstance, inferInstance, inferInstance, fun k => |a| • r k, ?_, ?_, ?_, ?_⟩ + · intro k l hkl + exact smul_le_smul_of_nonneg_left (hranti hkl) (abs_nonneg a) + · exact fun k => smul_nonneg (abs_nonneg a) (hrnn k) + · have h := isGLB_smul_of_nonneg (X := X) (lam := |a|) (abs_nonneg a) hrglb + have hset : + Set.range (fun k => |a| • r k) = (fun z => |a| • z) '' Set.range r := by + ext z + constructor + · rintro ⟨k, rfl⟩ + exact ⟨r k, ⟨k, rfl⟩, rfl⟩ + · rintro ⟨_, ⟨k, rfl⟩, rfl⟩ + exact ⟨k, rfl⟩ + simpa [hset] using h + · intro k + exact (hrevent k).mono fun i hi => by + calc + |a • u i - a • x| = |a • (u i - x)| := by + rw [smul_sub] + _ = |a| • |u i - x| := abs_smul' (X := X) (x := u i - x) a + _ ≤ |a| • r k := smul_le_smul_of_nonneg_left hi (abs_nonneg a) + +/-- Supremum is order continuous. -/ +theorem sup {ι : Type v} [Preorder ι] + {u v : ι → X} {x y : X} (hu : OrderConvergesTo u x) + (hv : OrderConvergesTo v y) : + OrderConvergesTo (fun i => u i ⊔ v i) (x ⊔ y) := by + rcases hu with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnn, hrglb, hrevent⟩ + rcases hv with ⟨τ, hτpre, hτdir, hτnon, s, hsanti, hsnn, hsglb, hsevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + let : Preorder τ := hτpre + let : IsDirected τ (· ≤ ·) := hτdir + let : Nonempty τ := hτnon + let : IsDirected (κ × τ) (· ≤ ·) := isDirected_prod + refine ⟨κ × τ, inferInstance, inferInstance, inferInstance, + fun p => r p.1 + s p.2, ?_, ?_, ?_, ?_⟩ + · intro p q hpq + exact add_le_add (hranti hpq.1) (hsanti hpq.2) + · exact fun p => add_nonneg (hrnn p.1) (hsnn p.2) + · exact isGLB_range_add r s hrglb hsglb + · intro p + exact ((hrevent p.1).and (hsevent p.2)).mono fun i hi => by + exact (abs_sup_sub_sup_le_add (u i) (v i) x y).trans (add_le_add hi.1 hi.2) + +/-- Infimum is order continuous. -/ +theorem inf {ι : Type v} [Preorder ι] + {u v : ι → X} {x y : X} (hu : OrderConvergesTo u x) + (hv : OrderConvergesTo v y) : + OrderConvergesTo (fun i => u i ⊓ v i) (x ⊓ y) := by + simpa [neg_sup] using (hu.neg.sup hv.neg).neg + +/-- Absolute value is order continuous. -/ +theorem abs {ι : Type v} [Preorder ι] + {u : ι → X} {x : X} (hu : OrderConvergesTo u x) : + OrderConvergesTo (fun i => |u i|) |x| := by + simpa only [_root_.abs] using hu.sup hu.neg + +end OrderConvergesTo + +/-- If an order-convergent net is pointwise bounded above, then its limit is bounded above by +the same bound. -/ +theorem le_of_orderConvergesTo_of_forall_le {ι : Type v} [Preorder ι] + [IsDirected ι (· ≤ ·)] [Nonempty ι] {u : ι → X} {x b : X} + (hu : OrderConvergesTo u x) (hub : ∀ i, u i ≤ b) : + x ≤ b := + hu.le_of_forall_le hub diff --git a/LeanPool/OrderClosures/BanLat/Disjoint.lean b/LeanPool/OrderClosures/BanLat/Disjoint.lean new file mode 100644 index 0000000000..5a59eac715 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Disjoint.lean @@ -0,0 +1,632 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Normed + + +/-! +# Disjointness in vector lattices + +Two elements `x`, `y` of a lattice-ordered group are **disjoint** when +`|x| ⊓ |y| = 0`, written `IsVLDisjoint x y`. This file collects the basic +theory: the symmetry and zero rules, the Birkhoff identity +`|x + y| = |x| + |y|`, the uniqueness of the positive/negative decomposition, +compatibility with scalar multiplication, monotonicity under absolute value, +closure under finite suprema and sums, and the finite-family identity +`|∑ i, α i • x i| = ∑ i, |α i| • |x i|` for pairwise-disjoint families. From +the last, a pairwise-disjoint family of non-zero vectors is linearly +independent over `ℝ`. Finally, in a normed vector lattice, a limit of a +pairwise-disjoint sequence is forced to be zero. +-/ + +@[expose] public section + +open scoped Topology +open Filter Finset + +section LatticeOrdered + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +/-! ### Definition and elementary lemmas -/ + +/-- Two elements of a lattice-ordered group are **disjoint** when +`|x| ⊓ |y| = 0`. -/ +def IsVLDisjoint (x y : X) : Prop := |x| ⊓ |y| = 0 + +omit [IsOrderedAddMonoid X] in +theorem isVLDisjoint_comm {x y : X} : + IsVLDisjoint x y ↔ IsVLDisjoint y x := by + unfold IsVLDisjoint; rw [inf_comm] + +/-- Zero is disjoint from every element. -/ +theorem isVLDisjoint_zero_left (x : X) : IsVLDisjoint 0 x := by + unfold IsVLDisjoint; simp [abs_zero] + +/-- Every element is disjoint from zero. -/ +theorem isVLDisjoint_zero_right (x : X) : IsVLDisjoint x 0 := + isVLDisjoint_comm.mpr (isVLDisjoint_zero_left x) + +/-- Disjoint positive elements satisfy `x ⊓ y = 0`. -/ +theorem inf_eq_zero_of_isVLDisjoint {x y : X} (hx : 0 ≤ x) (hy : 0 ≤ y) + (h : IsVLDisjoint x y) : x ⊓ y = 0 := by + unfold IsVLDisjoint at h; rwa [abs_of_nonneg hx, abs_of_nonneg hy] at h + +/-- If `x ⊓ y = 0` then `x` and `y` are disjoint. -/ +theorem isVLDisjoint_of_inf_eq_zero {x y : X} + (h : x ⊓ y = 0) : IsVLDisjoint x y := by + have hx : 0 ≤ x := h ▸ inf_le_left + have hy : 0 ≤ y := h ▸ inf_le_right + unfold IsVLDisjoint; rwa [abs_of_nonneg hx, abs_of_nonneg hy] + +/-- Disjoint decomposition is unique: if `x = u₁ - v₁ = u₂ - v₂` with +`u₁ ⊥ v₁` and `u₂ ⊥ v₂` (all non-negative), then `u₁ = u₂` and +`v₁ = v₂`. -/ +theorem isVLDisjoint_decomposition_unique {u₁ v₁ u₂ v₂ : X} + (hu₁ : 0 ≤ u₁) (hv₁ : 0 ≤ v₁) (hu₂ : 0 ≤ u₂) (hv₂ : 0 ≤ v₂) + (hd₁ : IsVLDisjoint u₁ v₁) (hd₂ : IsVLDisjoint u₂ v₂) + (h : u₁ - v₁ = u₂ - v₂) : u₁ = u₂ ∧ v₁ = v₂ := by + have h1 := inf_eq_zero_of_isVLDisjoint hu₁ hv₁ hd₁ + have h2 := inf_eq_zero_of_isVLDisjoint hu₂ hv₂ hd₂ + have eq1 : u₁ = (u₁ - v₁)⁺ := + uniqueness_posPart (u₁ - v₁) rfl h1 + have eq2 : u₂ = (u₂ - v₂)⁺ := + uniqueness_posPart (u₂ - v₂) rfl h2 + have hu : u₁ = u₂ := by rw [eq1, h, ← eq2] + refine ⟨hu, ?_⟩ + have := h; rw [hu, sub_eq_add_neg, sub_eq_add_neg] at this + exact neg_injective (add_left_cancel this) + +omit [IsOrderedAddMonoid X] in +private theorem inf_eq_zero_of_le_disjoint {a b c d : X} + (ha : 0 ≤ a) (hb : 0 ≤ b) (hac : a ≤ c) (hbd : b ≤ d) + (hcd : c ⊓ d = 0) : a ⊓ b = 0 := + le_antisymm (hcd ▸ inf_le_inf hac hbd) (le_inf ha hb) + +/-- If `x ⊥ y` then `|x + y| = |x| + |y|` (Birkhoff identity). -/ +theorem abs_add_of_isVLDisjoint {x y : X} (h : IsVLDisjoint x y) : + |x + y| = |x| + |y| := by + have hd : |x| ⊓ |y| = 0 := h + have hxp_yp : x⁺ ⊓ y⁺ = 0 := inf_eq_zero_of_le_disjoint + (posPart_nonneg x) (posPart_nonneg y) + (sup_le (le_abs_self x) (abs_nonneg x)) + (sup_le (le_abs_self y) (abs_nonneg y)) hd + have hxp_yn : x⁺ ⊓ y⁻ = 0 := inf_eq_zero_of_le_disjoint + (posPart_nonneg x) (negPart_nonneg y) + (sup_le (le_abs_self x) (abs_nonneg x)) + (sup_le (neg_le_abs y) (abs_nonneg y)) hd + have hxn_yp : x⁻ ⊓ y⁺ = 0 := inf_eq_zero_of_le_disjoint + (negPart_nonneg x) (posPart_nonneg y) + (sup_le (neg_le_abs x) (abs_nonneg x)) + (sup_le (le_abs_self y) (abs_nonneg y)) hd + have hxn_yn : x⁻ ⊓ y⁻ = 0 := inf_eq_zero_of_le_disjoint + (negPart_nonneg x) (negPart_nonneg y) + (sup_le (neg_le_abs x) (abs_nonneg x)) + (sup_le (neg_le_abs y) (abs_nonneg y)) hd + have hxn_xp : x⁻ ⊓ x⁺ = 0 := by + rw [inf_comm]; exact posPart_inf_negPart_eq_zero x + have hyn_yp : y⁻ ⊓ y⁺ = 0 := by + rw [inf_comm]; exact posPart_inf_negPart_eq_zero y + have term1 : (x⁺ + y⁺) ⊓ x⁻ = 0 := by + apply le_antisymm _ (le_inf (add_nonneg (posPart_nonneg x) (posPart_nonneg y)) + (negPart_nonneg x)) + rw [inf_comm] + calc x⁻ ⊓ (x⁺ + y⁺) + ≤ x⁻ ⊓ x⁺ + x⁻ ⊓ y⁺ := inf_le_inf_add_inf_of_nonneg x⁻ x⁺ y⁺ + (negPart_nonneg x) (posPart_nonneg x) (posPart_nonneg y) + _ = 0 := by rw [hxn_xp, hxn_yp, add_zero] + have term2 : (x⁺ + y⁺) ⊓ y⁻ = 0 := by + apply le_antisymm _ (le_inf (add_nonneg (posPart_nonneg x) (posPart_nonneg y)) + (negPart_nonneg y)) + rw [inf_comm] + calc y⁻ ⊓ (x⁺ + y⁺) + ≤ y⁻ ⊓ x⁺ + y⁻ ⊓ y⁺ := inf_le_inf_add_inf_of_nonneg y⁻ x⁺ y⁺ + (negPart_nonneg y) (posPart_nonneg x) (posPart_nonneg y) + _ = 0 := by rw [inf_comm y⁻ x⁺, hxp_yn, hyn_yp, add_zero] + have sum_disj : (x⁺ + y⁺) ⊓ (x⁻ + y⁻) = 0 := by + apply le_antisymm _ (le_inf (add_nonneg (posPart_nonneg x) (posPart_nonneg y)) + (add_nonneg (negPart_nonneg x) (negPart_nonneg y))) + calc (x⁺ + y⁺) ⊓ (x⁻ + y⁻) + ≤ (x⁺ + y⁺) ⊓ x⁻ + (x⁺ + y⁺) ⊓ y⁻ := + inf_le_inf_add_inf_of_nonneg (x⁺ + y⁺) x⁻ y⁻ + (add_nonneg (posPart_nonneg x) (posPart_nonneg y)) + (negPart_nonneg x) (negPart_nonneg y) + _ = 0 := by rw [term1, term2, add_zero] + have hdec : x + y = (x⁺ + y⁺) - (x⁻ + y⁻) := by + calc x + y = (x⁺ - x⁻) + (y⁺ - y⁻) := by + rw [posPart_sub_negPart, posPart_sub_negPart] + _ = (x⁺ + y⁺) - (x⁻ + y⁻) := by abel + have hup := uniqueness_posPart (x + y) hdec sum_disj + have hun : (x + y)⁻ = x⁻ + y⁻ := by + have h3 := posPart_sub_negPart (x + y) + rw [← hup] at h3 + have h4 : x⁺ + y⁺ - (x + y)⁻ = x⁺ + y⁺ - (x⁻ + y⁻) := by + rw [h3, hdec] + exact sub_right_injective h4 + calc |x + y| = (x + y)⁺ + (x + y)⁻ := (posPart_add_negPart (x + y)).symm + _ = (x⁺ + y⁺) + (x⁻ + y⁻) := by rw [← hup, hun] + _ = (x⁺ + x⁻) + (y⁺ + y⁻) := by abel + _ = |x| + |y| := by rw [posPart_add_negPart, posPart_add_negPart] + +/-- If `x, y ≥ 0` and `x ⊥ y` then `|x ⊔ y| = |x| ⊔ |y|`. -/ +theorem abs_sup_of_isVLDisjoint {x y : X} (hx : 0 ≤ x) (hy : 0 ≤ y) + (_ : IsVLDisjoint x y) : |x ⊔ y| = |x| ⊔ |y| := by + rw [abs_of_nonneg (le_sup_of_le_left hx), abs_of_nonneg hx, abs_of_nonneg hy] + +/-- The positive and negative parts of an element are disjoint. -/ +theorem isVLDisjoint_posPart_negPart (x : X) : IsVLDisjoint x⁺ x⁻ := + isVLDisjoint_of_inf_eq_zero (posPart_inf_negPart_eq_zero x) + +/-- If `|z| ≤ |y|` and `x ⊥ y` then `x ⊥ z`. -/ +theorem IsVLDisjoint.mono_right {x y z : X} (h : IsVLDisjoint x y) + (hzy : |z| ≤ |y|) : IsVLDisjoint x z := by + refine le_antisymm ?_ (le_inf (abs_nonneg _) (abs_nonneg _)) + calc |x| ⊓ |z| ≤ |x| ⊓ |y| := inf_le_inf_left _ hzy + _ = 0 := h + +/-- If `|z| ≤ |x|` and `x ⊥ y` then `z ⊥ y`. -/ +theorem IsVLDisjoint.mono_left {x y z : X} (h : IsVLDisjoint x y) + (hzx : |z| ≤ |x|) : IsVLDisjoint z y := + isVLDisjoint_comm.mp ((isVLDisjoint_comm.mp h).mono_right hzx) + +/-! ### Sum of non-negative disjoint elements equals their supremum -/ + +/-- For non-negative disjoint elements, `x + y = x ⊔ y`. -/ +theorem add_eq_sup_of_isVLDisjoint_of_nonneg {x y : X} + (hx : 0 ≤ x) (hy : 0 ≤ y) (h : IsVLDisjoint x y) : x + y = x ⊔ y := by + have hinf : x ⊓ y = 0 := inf_eq_zero_of_isVLDisjoint hx hy h + have := inf_add_sup x y + rw [hinf, zero_add] at this + exact this.symm + +/-- If a non-negative element is written as a sum of two disjoint elements, +then both summands are non-negative. -/ +theorem nonneg_and_nonneg_of_isVLDisjoint_add_eq_of_nonneg + {x y z : X} (hx : 0 ≤ x) (hyz : IsVLDisjoint y z) (hadd : y + z = x) : + 0 ≤ y ∧ 0 ≤ z := by + have hsub : |y| + |z| - (y + z) = 0 := by + calc + |y| + |z| - (y + z) = |y + z| - (y + z) := by + rw [abs_add_of_isVLDisjoint hyz] + _ = |x| - x := by rw [hadd] + _ = 0 := by rw [abs_of_nonneg hx, sub_self] + have hy0 : |y| - y = 0 := by + have hle : |y| - y ≤ |y| + |z| - (y + z) := by + calc + |y| - y ≤ (|y| - y) + (|z| - z) := + le_add_of_nonneg_right (sub_nonneg.mpr (le_abs_self z)) + _ = |y| + |z| - (y + z) := by abel + exact le_antisymm (by rwa [hsub] at hle) (sub_nonneg.mpr (le_abs_self y)) + have hz0 : |z| - z = 0 := by + calc + |z| - z = 0 + (|z| - z) := by rw [zero_add] + _ = (|y| - y) + (|z| - z) := by rw [hy0] + _ = |y| + |z| - (y + z) := by abel + _ = 0 := hsub + constructor + · rw [← sub_eq_zero.mp hy0] + exact abs_nonneg y + · rw [← sub_eq_zero.mp hz0] + exact abs_nonneg z + +/-- If `x ⊥ y` then `|x| ⊔ |y| = |x| + |y|`. -/ +theorem sup_abs_eq_add_abs_of_isVLDisjoint {x y : X} + (h : IsVLDisjoint x y) : |x| ⊔ |y| = |x| + |y| := by + have := inf_add_sup |x| |y| + rw [show |x| ⊓ |y| = 0 from h, zero_add] at this + exact this + +/-- If `x ⊥ y` then `|x + y| = |x| ⊔ |y|`. -/ +theorem abs_add_eq_sup_abs_of_isVLDisjoint {x y : X} + (h : IsVLDisjoint x y) : |x + y| = |x| ⊔ |y| := by + rw [abs_add_of_isVLDisjoint h, sup_abs_eq_add_abs_of_isVLDisjoint h] + +/-! ### Disjointness with sups and sums on the right -/ + +/-- If `x ⊥ y` and `x ⊥ z` then `x ⊥ y ⊔ z`. -/ +theorem IsVLDisjoint.sup_right {x y z : X} + (hy : IsVLDisjoint x y) (hz : IsVLDisjoint x z) : + IsVLDisjoint x (y ⊔ z) := by + have habs : |y ⊔ z| ≤ |y| + |z| := by + rw [abs] + refine sup_le ?_ ?_ + · exact sup_le ((le_abs_self y).trans + (le_add_of_nonneg_right (abs_nonneg _))) + ((le_abs_self z).trans (le_add_of_nonneg_left (abs_nonneg _))) + · rw [neg_sup] + exact inf_le_left.trans ((neg_le_abs y).trans + (le_add_of_nonneg_right (abs_nonneg _))) + refine le_antisymm ?_ (le_inf (abs_nonneg _) (abs_nonneg _)) + calc |x| ⊓ |y ⊔ z| ≤ |x| ⊓ (|y| + |z|) := inf_le_inf_left _ habs + _ ≤ |x| ⊓ |y| + |x| ⊓ |z| := inf_le_inf_add_inf_of_nonneg _ _ _ + (abs_nonneg _) (abs_nonneg _) (abs_nonneg _) + _ = 0 := by rw [hy, hz, add_zero] + +/-- If `x ⊥ y` and `x ⊥ z` then `x ⊥ y + z`. -/ +theorem IsVLDisjoint.add_right {x y z : X} + (hy : IsVLDisjoint x y) (hz : IsVLDisjoint x z) : + IsVLDisjoint x (y + z) := by + refine le_antisymm ?_ (le_inf (abs_nonneg _) (abs_nonneg _)) + calc |x| ⊓ |y + z| ≤ |x| ⊓ (|y| + |z|) := inf_le_inf_left _ (abs_add_le y z) + _ ≤ |x| ⊓ |y| + |x| ⊓ |z| := inf_le_inf_add_inf_of_nonneg _ _ _ + (abs_nonneg _) (abs_nonneg _) (abs_nonneg _) + _ = 0 := by rw [hy, hz, add_zero] + +/-- If `x ⊥ z` and `y ⊥ z` then `x ⊔ y ⊥ z`. -/ +theorem IsVLDisjoint.sup_left {x y z : X} + (hx : IsVLDisjoint x z) (hy : IsVLDisjoint y z) : + IsVLDisjoint (x ⊔ y) z := + isVLDisjoint_comm.mp + (IsVLDisjoint.sup_right (isVLDisjoint_comm.mp hx) (isVLDisjoint_comm.mp hy)) + +/-- If `x ⊥ z` and `y ⊥ z` then `x + y ⊥ z`. -/ +theorem IsVLDisjoint.add_left {x y z : X} + (hx : IsVLDisjoint x z) (hy : IsVLDisjoint y z) : + IsVLDisjoint (x + y) z := + isVLDisjoint_comm.mp + (IsVLDisjoint.add_right (isVLDisjoint_comm.mp hx) (isVLDisjoint_comm.mp hy)) + +/-! ### Disjoint pieces of an infimum -/ + +/-- For any `x, y`, the elements `x - x ⊓ y` and `y - x ⊓ y` are non-negative +and disjoint. -/ +theorem isVLDisjoint_sub_inf (x y : X) : + IsVLDisjoint (x - x ⊓ y) (y - x ⊓ y) := by + have h1 : x - x ⊓ y = (x - y)⁺ := sub_inf_eq_posPart x y + have h2 : y - x ⊓ y = (x - y)⁻ := by + rw [inf_comm, sub_inf_eq_posPart, negPart_def, neg_sub, posPart_def] + rw [h1, h2] + exact isVLDisjoint_posPart_negPart (x - y) + +/-! ### Finite disjoint sums -/ + +private lemma isVLDisjoint_finset_sum {ι : Type*} {s : Finset ι} {x : X} {f : ι → X} + (h : ∀ i ∈ s, IsVLDisjoint x (f i)) : IsVLDisjoint x (∑ i ∈ s, f i) := by + classical + induction s using Finset.induction_on with + | empty => simpa using isVLDisjoint_zero_right x + | insert a s ha ih => + rw [Finset.sum_insert ha] + refine (h a (Finset.mem_insert_self a s)).add_right ?_ + exact ih (fun i hi => h i (Finset.mem_insert_of_mem hi)) + +private lemma sum_eq_sup'_aux {ι : Type*} {s : Finset ι} (hs : s.Nonempty) (f : ι → X) + (hnn : ∀ i ∈ s, 0 ≤ f i) + (hdisj : (s : Set ι).Pairwise fun i j => IsVLDisjoint (f i) (f j)) : + ∑ i ∈ s, f i = s.sup' hs f := by + classical + induction hs using Finset.Nonempty.cons_induction with + | singleton a => simp + | cons a s ha hs ih => + rw [Finset.sum_cons, Finset.sup'_cons hs f] + have mem_cons_of : ∀ i ∈ s, i ∈ Finset.cons a s ha := + fun i hi => Finset.mem_cons.mpr (Or.inr hi) + have hnn_s : ∀ i ∈ s, 0 ≤ f i := fun i hi => hnn i (mem_cons_of i hi) + have hnn_a : 0 ≤ f a := hnn a (Finset.mem_cons.mpr (Or.inl rfl)) + have hdisj_s : (s : Set ι).Pairwise fun i j => IsVLDisjoint (f i) (f j) := by + intro i hi j hj hij + exact hdisj (mem_cons_of i hi) (mem_cons_of j hj) hij + rw [← ih hnn_s hdisj_s] + have hsum_nn : 0 ≤ ∑ i ∈ s, f i := Finset.sum_nonneg hnn_s + have hdisj_sum : IsVLDisjoint (f a) (∑ i ∈ s, f i) := by + apply isVLDisjoint_finset_sum + intro i hi + have hne_ai : a ≠ i := fun h => ha (h ▸ hi) + exact hdisj (Finset.mem_cons.mpr (Or.inl rfl)) (mem_cons_of i hi) hne_ai + exact add_eq_sup_of_isVLDisjoint_of_nonneg hnn_a hsum_nn hdisj_sum + +/-- For a pairwise-disjoint family of non-negative elements, the finite sum +equals the supremum. -/ +theorem sum_eq_sup_of_pairwise_isVLDisjoint_of_nonneg {n : ℕ} {f : Fin n → X} + (hne : 0 < n) (hnn : ∀ i, 0 ≤ f i) + (hdisj : Pairwise fun i j => IsVLDisjoint (f i) (f j)) : + ∑ i, f i = Finset.univ.sup' (Finset.univ_nonempty_iff.mpr + ⟨⟨0, hne⟩⟩) f := by + apply sum_eq_sup'_aux + · intro i _; exact hnn i + · intro i _ j _ hij; exact hdisj hij + +end LatticeOrdered + +section VectorLattice + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-! ### Scalar multiples preserve disjointness -/ + +/-- Scaling a non-negative disjoint pair preserves disjointness. -/ +private lemma disjoint_smul_nonneg {x y : X} (a : ℝ) (nonneg : 0 ≤ a) + (h : x ⊓ y = 0) : (a • x) ⊓ y = 0 := by + let aux (x y : X) (h : x ⊓ y = 0) (a : ℝ) + (nonneg : 0 ≤ a) (hone : a ≤ 1) : (a • x) ⊓ y = 0 := by + have xnonneg : 0 ≤ x := by rw [← h]; exact inf_le_left + have ynonneg : 0 ≤ y := by rw [← h]; exact inf_le_right + apply le_antisymm + · calc + a • x ⊓ y ≤ (1 : ℝ) • x ⊓ y := by + apply inf_le_inf + · exact smul_le_smul_of_nonneg_right hone xnonneg + · exact le_refl y + _ = 0 := by simp [h] + · exact le_inf (smul_nonneg nonneg xnonneg) ynonneg + have hbig (hone : ¬ a ≤ 1) : (a • x) ⊓ y = 0 := by + push Not at hone + suffices hsuf : x ⊓ (a⁻¹ • y) = 0 from by + symm + calc + 0 = a • ( x ⊓ (a⁻¹ • y) ):= by rw [hsuf, smul_zero] + _ = (a • x ⊓ a • a⁻¹ • y) := nonneg_smul_inf x (a⁻¹ • y) a nonneg + _ = (a • x) ⊓ y := by rw [smul_smul]; field_simp [hone]; simp + rw [inf_comm]; rw [inf_comm] at h + refine aux y x h a⁻¹ ?_ ?_ + · exact inv_nonneg.mpr nonneg + · field_simp; exact le_of_lt hone + by_cases hone : a ≤ 1 + · exact aux x y h a nonneg hone + · exact hbig hone + +/-- Scalar multiplication on the left preserves disjointness. -/ +theorem IsVLDisjoint.smul_left {x y : X} (h : IsVLDisjoint x y) (a : ℝ) : + IsVLDisjoint (a • x) y := by + change |a • x| ⊓ |y| = 0 + rw [abs_smul'] + exact disjoint_smul_nonneg (|a| : ℝ) (abs_nonneg a) h + +/-- Scalar multiplication on the right preserves disjointness. -/ +theorem IsVLDisjoint.smul_right {x y : X} (h : IsVLDisjoint x y) (a : ℝ) : + IsVLDisjoint x (a • y) := + isVLDisjoint_comm.mp ((isVLDisjoint_comm.mp h).smul_left a) + +/-- Two non-zero disjoint vectors exist in any Archimedean vector lattice of +`ℝ`-rank greater than one. -/ +theorem exists_pair_ne_zero_isVLDisjoint [IsVLArchimedean X] + (h : 1 < Module.rank ℝ X) : + ∃ u v : X, u ≠ 0 ∧ v ≠ 0 ∧ IsVLDisjoint u v := by + obtain ⟨x, hxp, hxn⟩ := exists_not_nonneg_not_nonpos_of_one_lt_rank h + refine ⟨x⁺, x⁻, ?_, ?_, isVLDisjoint_posPart_negPart x⟩ + · exact fun h => hxn (posPart_eq_zero.mp h) + · exact fun h => hxp (negPart_eq_zero.mp h) + +/-! ### Disjoint positive parts from scalar multiples -/ + +/-- For any `x, y` and `λ > 0`, the positive parts `(x - λ • y)⁺` and +`(y - λ⁻¹ • x)⁺` are disjoint. -/ +theorem isVLDisjoint_posPart_sub_smul (x y : X) {lam : ℝ} (hlam : 0 < lam) : + IsVLDisjoint (x - lam • y)⁺ (y - lam⁻¹ • x)⁺ := by + have hne : lam ≠ 0 := ne_of_gt hlam + have hinv : (0 : ℝ) ≤ lam⁻¹ := le_of_lt (inv_pos.mpr hlam) + have heq : (y - lam⁻¹ • x)⁺ = lam⁻¹ • (x - lam • y)⁻ := by + rw [negPart_def, nonneg_smul_sup _ _ _ hinv, smul_zero, posPart_def, + neg_sub, smul_sub, smul_smul, inv_mul_cancel₀ hne, one_smul] + rw [heq] + exact (isVLDisjoint_posPart_negPart (x - lam • y)).smul_right lam⁻¹ + +/-! ### Finite disjoint families with scalars -/ + +private lemma abs_sum_finset {ι : Type*} (s : Finset ι) (x : ι → X) (α : ι → ℝ) + (hdisj : (s : Set ι).Pairwise fun i j => IsVLDisjoint (x i) (x j)) : + |∑ i ∈ s, α i • x i| = ∑ i ∈ s, |α i| • |x i| := by + classical + induction s using Finset.induction_on with + | empty => simp + | insert a s ha ih => + have hdisj_s : (s : Set ι).Pairwise fun i j => IsVLDisjoint (x i) (x j) := by + intro i hi j hj hij + exact hdisj (Finset.mem_insert_of_mem hi) (Finset.mem_insert_of_mem hj) hij + rw [Finset.sum_insert ha, Finset.sum_insert ha] + have hdisj_head : IsVLDisjoint (α a • x a) (∑ i ∈ s, α i • x i) := by + apply isVLDisjoint_finset_sum + intro i hi + have hne_ai : a ≠ i := fun h => ha (h ▸ hi) + exact ((hdisj (Finset.mem_insert_self a s) + (Finset.mem_insert_of_mem hi) hne_ai).smul_left (α a)).smul_right (α i) + rw [abs_add_of_isVLDisjoint hdisj_head, abs_smul', ih hdisj_s] + +/-- For a pairwise-disjoint family and arbitrary scalars, +`|∑ i, α i • x i| = ∑ i, |α i| • |x i|`. -/ +theorem abs_sum_of_pairwise_isVLDisjoint {n : ℕ} {x : Fin n → X} {α : Fin n → ℝ} + (hdisj : Pairwise fun i j => IsVLDisjoint (x i) (x j)) : + |∑ i, α i • x i| = ∑ i, |α i| • |x i| := + abs_sum_finset Finset.univ x α (fun _ _ _ _ hij => hdisj hij) + +/-- For a pairwise-disjoint family of non-negative elements and non-negative +scalars, `∑ i, α i • x i = ⨆ i, α i • x i` (with the sup taken over a +non-empty index). -/ +theorem sup_smul_eq_sum_of_pairwise_isVLDisjoint_of_nonneg {n : ℕ} + {x : Fin n → X} {α : Fin n → ℝ} (hne : 0 < n) + (hnn : ∀ i, 0 ≤ x i) (hα : ∀ i, 0 ≤ α i) + (hdisj : Pairwise fun i j => IsVLDisjoint (x i) (x j)) : + ∑ i, α i • x i = Finset.univ.sup' (Finset.univ_nonempty_iff.mpr + ⟨⟨0, hne⟩⟩) (fun i => α i • x i) := by + refine sum_eq_sup_of_pairwise_isVLDisjoint_of_nonneg hne + (fun i => smul_nonneg (hα i) (hnn i)) ?_ + intro i j hij + exact ((hdisj hij).smul_left (α i)).smul_right (α j) + +/-- A pairwise-disjoint family of non-zero vectors is linearly independent +over `ℝ`. -/ +theorem linearIndependent_of_pairwise_isVLDisjoint {n : ℕ} {x : Fin n → X} + (hne : ∀ i, x i ≠ 0) + (hdisj : Pairwise fun i j => IsVLDisjoint (x i) (x j)) : + LinearIndependent ℝ x := by + rw [Fintype.linearIndependent_iff] + intro α hsum i + have habs : |∑ i, α i • x i| = ∑ i, |α i| • |x i| := + abs_sum_of_pairwise_isVLDisjoint hdisj + rw [hsum, abs_zero] at habs + have hnn : ∀ j ∈ (Finset.univ : Finset (Fin n)), 0 ≤ |α j| • |x j| := + fun j _ => smul_nonneg (abs_nonneg _) (abs_nonneg _) + have hzero : |α i| • |x i| = 0 := + (Finset.sum_eq_zero_iff_of_nonneg hnn).mp habs.symm i (Finset.mem_univ i) + by_contra hα + have habs_ne : |α i| ≠ 0 := fun h => hα (abs_eq_zero.mp h) + have hxi : |x i| = 0 := by + have h2 : |α i|⁻¹ • (|α i| • |x i|) = |α i|⁻¹ • (0 : X) := by rw [hzero] + rwa [smul_smul, inv_mul_cancel₀ habs_ne, one_smul, smul_zero] at h2 + exact hne i ((abs_eq_zero_iff_zero (x i)).mp hxi) + +/-! ### Pairwise disjoint families and maximality + +A subset of a vector lattice is **pairwise disjoint** when distinct members +are vector-lattice disjoint, and **maximal** when it is not properly +contained in any strictly larger pairwise disjoint subset. Every vector +lattice admits a maximal disjoint family consisting of strictly positive +vectors, by Zorn's lemma. -/ + +/-- A subset of `X` is **pairwise disjoint** when it does not contain `0` +and distinct members are vector-lattice disjoint. -/ +def IsDisjointSet (Λ : Set X) : Prop := + 0 ∉ Λ ∧ ∀ ⦃a⦄, a ∈ Λ → ∀ ⦃b⦄, b ∈ Λ → a ≠ b → IsVLDisjoint a b + +/-- A **maximal disjoint family** in `X` is a pairwise disjoint set that is +not properly contained in any strictly larger pairwise disjoint subset of +`X`. The order is by inclusion (not refinement). -/ +def IsMaximalDisjoint (Λ : Set X) : Prop := + Maximal IsDisjointSet Λ + +omit [VectorLattice X] in +/-- A pairwise disjoint family of strictly positive elements is maximal iff +the only element disjoint from every member of the family is `0`. -/ +theorem isMaximalDisjoint_iff_forall_eq_zero {Λ : Set X} + (_hpos : ∀ x ∈ Λ, 0 < x) (hdis : IsDisjointSet Λ) : + IsMaximalDisjoint Λ ↔ ∀ x : X, (∀ a ∈ Λ, IsVLDisjoint x a) → x = 0 := by + refine ⟨?_, ?_⟩ + · intro hmax x hx + by_contra hxne + have habs_ne : |x| ≠ 0 := fun h => hxne ((abs_eq_zero_iff_zero x).mp h) + have habs_pos : 0 < |x| := lt_of_le_of_ne (abs_nonneg x) (Ne.symm habs_ne) + have habs_disj : ∀ a ∈ Λ, IsVLDisjoint |x| a := fun a ha => + (hx a ha).mono_left (abs_of_nonneg (abs_nonneg x)).le + set Λ' : Set X := insert |x| Λ with hΛ'_def + have hΛ'_dis : IsDisjointSet Λ' := by + refine ⟨?_, ?_⟩ + · rintro (h0 | h0) + · exact habs_ne h0.symm + · exact hdis.1 h0 + · intro a ha b hb hab + rcases ha with rfl | ha + · rcases hb with rfl | hb + · exact (hab rfl).elim + · exact habs_disj b hb + · rcases hb with rfl | hb + · exact isVLDisjoint_comm.mp (habs_disj a ha) + · exact hdis.2 ha hb hab + have hsub : Λ ⊆ Λ' := Set.subset_insert _ _ + have hsub' : Λ' ⊆ Λ := hmax.2 hΛ'_dis hsub + have hxinΛ : |x| ∈ Λ := hsub' (Set.mem_insert _ _) + have hself : |x| ⊓ |(|x|)| = 0 := hx |x| hxinΛ + rw [abs_of_nonneg (abs_nonneg x), inf_idem] at hself + exact habs_ne hself + · intro hyp + refine ⟨hdis, ?_⟩ + intro Λ' hΛ' hsub y hy + by_contra hyΛ + have hyΛ : y ∉ Λ := hyΛ + have hy_disj : ∀ a ∈ Λ, IsVLDisjoint y a := by + intro a ha + have hane : y ≠ a := fun h => hyΛ (h.symm ▸ ha) + exact hΛ'.2 hy (hsub ha) hane + have hy0 : y = 0 := hyp y hy_disj + exact hΛ'.1 (hy0 ▸ hy) + +/-- **Existence of a maximal disjoint family of positive vectors.** Every +vector lattice admits a maximal disjoint family whose elements are all +strictly positive. -/ +theorem exists_isMaximalDisjoint_pos (X : Type*) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] : + ∃ Λ : Set X, IsMaximalDisjoint Λ ∧ ∀ x ∈ Λ, 0 < x := by + let 𝒞 : Set (Set X) := {S | IsDisjointSet S ∧ ∀ x ∈ S, 0 < x} + have hZorn : ∀ c ⊆ 𝒞, IsChain (· ⊆ ·) c → ∃ ub ∈ 𝒞, ∀ s ∈ c, s ⊆ ub := by + intro c hc hchain + refine ⟨⋃₀ c, ⟨⟨?_, ?_⟩, ?_⟩, fun s hs => Set.subset_sUnion_of_mem hs⟩ + · rintro ⟨S, hS, h0⟩ + exact (hc hS).1.1 h0 + · intro a ha b hb hab + obtain ⟨Sa, hSa, haSa⟩ := ha + obtain ⟨Sb, hSb, hbSb⟩ := hb + rcases hchain.total hSa hSb with hSab | hSab + · exact (hc hSb).1.2 (hSab haSa) hbSb hab + · exact (hc hSa).1.2 haSa (hSab hbSb) hab + · rintro x ⟨S, hS, hxS⟩ + exact (hc hS).2 x hxS + obtain ⟨Λ, hΛ⟩ := zorn_subset 𝒞 hZorn + refine ⟨Λ, ⟨hΛ.prop.1, ?_⟩, hΛ.prop.2⟩ + intro Λ' hΛ' hsub y hy + by_contra hyΛ + have hyΛ : y ∉ Λ := hyΛ + have hy_ne : y ≠ 0 := fun h => hΛ'.1 (h ▸ hy) + have habsy_ne : |y| ≠ 0 := fun h => hy_ne ((abs_eq_zero_iff_zero y).mp h) + have habsy_pos : 0 < |y| := lt_of_le_of_ne (abs_nonneg y) (Ne.symm habsy_ne) + have hy_disj : ∀ a ∈ Λ, IsVLDisjoint y a := by + intro a ha + have hane : y ≠ a := fun h => hyΛ (h.symm ▸ ha) + exact hΛ'.2 hy (hsub ha) hane + set Λ'' : Set X := insert |y| Λ + have hΛ''_in : Λ'' ∈ 𝒞 := by + refine ⟨⟨?_, ?_⟩, ?_⟩ + · rintro (h0 | h0) + · exact habsy_ne h0.symm + · exact hΛ.prop.1.1 h0 + · intro a ha b hb hab + rcases ha with rfl | ha + · rcases hb with rfl | hb + · exact (hab rfl).elim + · exact (hy_disj b hb).mono_left (abs_of_nonneg (abs_nonneg y)).le + · rcases hb with rfl | hb + · exact isVLDisjoint_comm.mp + ((hy_disj a ha).mono_left (abs_of_nonneg (abs_nonneg y)).le) + · exact hΛ.prop.1.2 ha hb hab + · rintro x (rfl | hx) + · exact habsy_pos + · exact hΛ.prop.2 x hx + have hsub'' : Λ ⊆ Λ'' := Set.subset_insert _ _ + have hsub''' : Λ'' ⊆ Λ := hΛ.2 hΛ''_in hsub'' + have habs_in : |y| ∈ Λ := hsub''' (Set.mem_insert _ _) + by_cases hyabs : y = |y| + · exact hyΛ (hyabs ▸ habs_in) + · have hd : |y| ⊓ |(|y|)| = 0 := hΛ'.2 hy (hsub habs_in) hyabs + rw [abs_of_nonneg (abs_nonneg y), inf_idem] at hd + exact habsy_ne hd + +end VectorLattice + +/-! ### Disjoint sequences in normed vector lattices -/ + +/-- In a normed vector lattice, a limit of a pairwise-disjoint sequence is +zero. -/ +theorem eq_zero_of_pairwise_isVLDisjoint_tendsto {Y : Type*} + [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] {u : ℕ → Y} {x : Y} + (hdisj : Pairwise fun i j => IsVLDisjoint (u i) (u j)) + (hlim : Tendsto u atTop (𝓝 x)) : x = 0 := by + have habs_bound : ∀ n m, n ≠ m → |u n| ≤ |u n - u m| := by + intro n m hnm + have hdnm : IsVLDisjoint (u n) (-u m) := by + change |u n| ⊓ |-u m| = 0 + rw [abs_neg]; exact hdisj hnm + rw [sub_eq_add_neg, abs_add_of_isVLDisjoint hdnm, abs_neg] + exact le_add_of_nonneg_right (abs_nonneg _) + have hnorm_bound : ∀ n m, n ≠ m → ‖u n‖ ≤ ‖u n - u m‖ := + fun n m hnm => norm_le_norm_of_abs_le_abs (habs_bound n m hnm) + have hnorm_limit : ∀ n, ‖u n‖ ≤ ‖u n - x‖ := by + intro n + have hrhs : Tendsto (fun m => ‖u n - u m‖) atTop (𝓝 ‖u n - x‖) := + (continuous_norm.tendsto _).comp (hlim.const_sub _) + refine ge_of_tendsto hrhs ?_ + filter_upwards [eventually_ne_atTop n] with m hm + exact hnorm_bound n m hm.symm + have hlhs_tendsto : Tendsto (fun n => ‖u n‖) atTop (𝓝 ‖x‖) := + (continuous_norm.tendsto _).comp hlim + have hrhs_zero : Tendsto (fun n => ‖u n - x‖) atTop (𝓝 0) := by + have h1 : Tendsto (fun n => u n - x) atTop (𝓝 0) := by + simpa using hlim.sub_const x + simpa only [Function.comp_def, norm_zero] using (continuous_norm.tendsto (0 : Y)).comp h1 + have hxnn : ‖x‖ ≤ 0 := + le_of_tendsto_of_tendsto' hlhs_tendsto hrhs_zero hnorm_limit + exact norm_le_zero_iff.mp hxnn diff --git a/LeanPool/OrderClosures/BanLat/Examples/CofK/Basic.lean b/LeanPool/OrderClosures/BanLat/Examples/CofK/Basic.lean new file mode 100644 index 0000000000..60a9aea2eb --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Examples/CofK/Basic.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Normed +public import Mathlib.Topology.ContinuousMap.Compact +public import Mathlib.Topology.ContinuousMap.Lattice + + +/-! +# `C(K, ℝ)` as a Banach lattice + +For a compact topological space `K`, the space `C(K, ℝ)` of continuous +real-valued functions equipped with the supremum norm and the pointwise order +is a Banach lattice. +-/ + +@[expose] public section + +variable {K : Type*} [TopologicalSpace K] [CompactSpace K] + +/-! ### Lattice and order structure + +Mathlib provides `Lattice C(K, ℝ)` (pointwise, via +`ContinuousMap.instLatticeOfTopologicalLattice`) and `IsOrderedAddMonoid C(K, ℝ)` +(via `ContinuousMap.instIsOrderedAddMonoid`). The norm comes from +`ContinuousMap.instNormedAddCommGroup`. +-/ + +/-! ### Vector lattice -/ + +/-- `C(K, ℝ)` is a vector lattice: a real module whose positive cone is closed +under scalar multiplication by non-negative reals. -/ +noncomputable instance instVectorLatticeCofK : VectorLattice C(K, ℝ) where + smul_le_smul_of_nonneg_left {a} ha {b₁ b₂} hb := by + rw [ContinuousMap.le_def] at hb ⊢ + intro x; simp only [ContinuousMap.smul_apply] + exact smul_le_smul_of_nonneg_left (hb x) ha + +/-! ### Normed vector lattice -/ + +/-- The sup norm on `C(K, ℝ)` is solid: `|f| ≤ |g|` pointwise implies +`‖f‖ ≤ ‖g‖`. -/ +instance instHasSolidNormCofK : HasSolidNorm C(K, ℝ) where + solid {f g} h := by + simp only [ContinuousMap.norm_eq_iSup_norm] + apply ciSup_mono ⟨‖g‖, Set.forall_mem_range.mpr + (fun x => ContinuousMap.norm_coe_le_norm g x)⟩ + intro x + have := ContinuousMap.le_def.mp h x + rw [ContinuousMap.abs_apply, ContinuousMap.abs_apply] at this + exact HasSolidNorm.solid this + +/-- `C(K, ℝ)` is a normed vector lattice. -/ +noncomputable instance instNormedVectorLatticeCofK : + NormedVectorLattice C(K, ℝ) where + +/-! ### Banach lattice -/ + +/-- `C(K, ℝ)` is a Banach lattice: a complete normed vector lattice. -/ +noncomputable instance instBanachLatticeCofK : BanachLattice C(K, ℝ) where diff --git a/LeanPool/OrderClosures/BanLat/LLexpr.lean b/LeanPool/OrderClosures/BanLat/LLexpr.lean new file mode 100644 index 0000000000..4a15c556ab --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/LLexpr.lean @@ -0,0 +1,511 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Basic +public import Mathlib.Analysis.Convex.Topology +public import Mathlib.Analysis.LocallyConvex.Separation +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination + + +/-! +# Formal lattice-linear expressions + +This file defines formal lattice-linear expressions in finitely many variables +and their evaluation in an arbitrary real vector lattice. It also develops a +normal-form API: every expression is converted to a signed difference of finite +suprema of real linear combinations, with evaluation preserved in every vector +lattice. + +The main application is the Yudin theorem: a lattice-linear identity between +formal expressions holds in every vector lattice as soon as it holds on `ℝ`. +-/ + +@[expose] public section + +/-- A formal lattice-linear expression in `n` variables, built from the +variables by addition, real scalar multiplication, and the binary lattice +operations `⊔` and `⊓`. -/ +inductive LLexpr (n : ℕ) where + | zero : LLexpr n + | var : Fin n → LLexpr n + | add : LLexpr n → LLexpr n → LLexpr n + | smul : ℝ → LLexpr n → LLexpr n + | sup : LLexpr n → LLexpr n → LLexpr n + | inf : LLexpr n → LLexpr n → LLexpr n + +namespace LLexpr + +open scoped BigOperators + +variable {n : ℕ} + +/-- Evaluation of a formal lattice-linear expression at an `n`-tuple of vectors +in a vector lattice. -/ +def eval {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] (x : Fin n → X) : LLexpr n → X + | .zero => 0 + | .var i => x i + | .add e₁ e₂ => eval x e₁ + eval x e₂ + | .smul r e => r • eval x e + | .sup e₁ e₂ => eval x e₁ ⊔ eval x e₂ + | .inf e₁ e₂ => eval x e₁ ⊓ eval x e₂ + +/-- Rename the variables of an expression along `f`. + +This is used when two expressions depending on different finite tuples are +viewed as expressions in one concatenated tuple, and when a tuple is compressed +to the distinct elements in its range. -/ +def reindexExpr {m n : ℕ} (f : Fin n → Fin m) : LLexpr n → LLexpr m + | .zero => .zero + | .var i => .var (f i) + | .add e₁ e₂ => .add (reindexExpr f e₁) (reindexExpr f e₂) + | .smul r e => .smul r (reindexExpr f e) + | .sup e₁ e₂ => .sup (reindexExpr f e₁) (reindexExpr f e₂) + | .inf e₁ e₂ => .inf (reindexExpr f e₁) (reindexExpr f e₂) + +section Evaluation + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +@[simp] theorem eval_zero (x : Fin n → X) : eval x .zero = 0 := rfl + +@[simp] theorem eval_var (x : Fin n → X) (i : Fin n) : eval x (.var i) = x i := + rfl + +@[simp] theorem eval_add (x : Fin n → X) (e₁ e₂ : LLexpr n) : + eval x (.add e₁ e₂) = eval x e₁ + eval x e₂ := rfl + +@[simp] theorem eval_smul (x : Fin n → X) (r : ℝ) (e : LLexpr n) : + eval x (.smul r e) = r • eval x e := rfl + +@[simp] theorem eval_sup (x : Fin n → X) (e₁ e₂ : LLexpr n) : + eval x (.sup e₁ e₂) = eval x e₁ ⊔ eval x e₂ := rfl + +@[simp] theorem eval_inf (x : Fin n → X) (e₁ e₂ : LLexpr n) : + eval x (.inf e₁ e₂) = eval x e₁ ⊓ eval x e₂ := rfl + +@[simp] +theorem eval_reindexExpr {m n : ℕ} (x : Fin m → X) + (f : Fin n → Fin m) (e : LLexpr n) : + eval x (reindexExpr f e) = eval (fun i => x (f i)) e := by + induction e <;> simp [reindexExpr, *] + +/-- Any finite family factors through an injective finite family listing its range. + +The map `f` records, for each original index, the corresponding index in the +range listing. This is useful when reducing an arbitrary finite tuple to a +tuple of distinct entries. -/ +theorem exists_injective_reindex {ι : Type*} {n : ℕ} (a : Fin n → ι) : + ∃ (m : ℕ) (b : Fin m → ι) (_ : Function.Injective b) (f : Fin n → Fin m), + ∀ i, b (f i) = a i := by + classical + let s : Set ι := Set.range a + have hs : s.Finite := Set.finite_range a + let : Fintype s := hs.fintype + let e : s ≃ Fin (Fintype.card s) := Fintype.equivFin s + refine ⟨Fintype.card s, fun j => (e.symm j).1, ?_, fun i => e ⟨a i, ⟨i, rfl⟩⟩, ?_⟩ + · intro i j hij + exact e.symm.injective (Subtype.ext hij) + · intro i + simp + +end Evaluation + +/-! ### Lattice-linear combinations of a tuple -/ + +section Combinations + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- The set of lattice-linear combinations of a tuple `x : Fin n → X`, i.e. the +image of `LLexpr n` under evaluation at `x`. -/ +def combinations (x : Fin n → X) : Set X := + Set.range (eval x) + +end Combinations + +/-! ### Yudin's theorem -/ + +/-- A formal lattice-linear expression *vanishes* on a vector lattice `X` if its +evaluation is zero for every substitution by vectors of `X`. -/ +def Vanishes (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] (e : LLexpr n) : Prop := + ∀ x : Fin n → X, eval x e = 0 + +private theorem sup'_add_right {ι X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] (s : Finset ι) (hs : s.Nonempty) (f : ι → X) (a : X) : + s.sup' hs f + a = s.sup' hs (fun i => f i + a) := + map_finset_sup' (OrderIso.addRight a) hs f + +private theorem add_left_sup' {ι X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] (s : Finset ι) (hs : s.Nonempty) (f : ι → X) (a : X) : + a + s.sup' hs f = s.sup' hs (fun i => a + f i) := + map_finset_sup' (OrderIso.addLeft a) hs f + +/-- Non-negative scalar multiplication as a `SupHom`. This packages +`nonneg_smul_sup` so finite suprema can be mapped through scalar +multiplication by `map_finset_sup'`. -/ +private def smulSupHom {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (r : ℝ) (hr : 0 ≤ r) : SupHom X X where + toFun := fun z => r • z + map_sup' := fun a b => nonneg_smul_sup a b r hr + +/-- A finite nonempty supremum of real linear combinations in `n` variables. + +A value `A : SupLinearCombination n` stores a finite nonempty set of coefficient +vectors. Evaluating it at `x : Fin n → X` gives the supremum of the corresponding +linear combinations of the entries of `x`. -/ +structure SupLinearCombination (n : ℕ) where + /-- The finite set of coefficient vectors. -/ + coeffs : Finset (Fin n → ℝ) + /-- Nonemptiness of the coefficient set, avoiding any ambient completeness assumption. -/ + nonempty : coeffs.Nonempty + +namespace SupLinearCombination + +/-- Evaluate a finite supremum of linear combinations at a tuple in a vector lattice. -/ +noncomputable def eval {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (A : SupLinearCombination n) + (x : Fin n → X) : X := + A.coeffs.sup' A.nonempty (Fintype.linearCombination ℝ x) + +@[simp] private theorem linearCombination_zero_coeff {X : Type*} [AddCommGroup X] + [Module ℝ X] (x : Fin n → X) : + Fintype.linearCombination ℝ x (fun _ : Fin n => 0) = 0 := by + change Fintype.linearCombination ℝ x (0 : Fin n → ℝ) = 0 + exact map_zero (Fintype.linearCombination ℝ x) + +/-- The supremum consisting of a single linear combination with coefficient vector `a`. -/ +noncomputable def singleton (a : Fin n → ℝ) : SupLinearCombination n := + { coeffs := {a} + nonempty := Finset.singleton_nonempty a } + +/-- Evaluating a singleton supremum gives the corresponding linear combination. -/ +@[simp] theorem eval_singleton {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (a : Fin n → ℝ) (x : Fin n → X) : + (singleton a).eval x = Fintype.linearCombination ℝ x a := by + simp [eval, singleton] + +/-- Add two finite suprema by adding each coefficient vector from the first to +each coefficient vector from the second. -/ +noncomputable def add (A B : SupLinearCombination n) : SupLinearCombination n := by + classical + exact + { coeffs := A.coeffs.image₂ (fun a b => a + b) B.coeffs + nonempty := A.nonempty.image₂ B.nonempty } + +/-- Evaluation turns addition of finite suprema into addition in the vector lattice. -/ +@[simp] theorem eval_add {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (A B : SupLinearCombination n) + (x : Fin n → X) : + (A.add B).eval x = A.eval x + B.eval x := by + classical + unfold eval add + rw [Finset.sup'_image₂_left] + simp only [map_add] + simp_rw [← add_left_sup' B.coeffs B.nonempty (fun b => Fintype.linearCombination ℝ x b)] + rw [← sup'_add_right A.coeffs A.nonempty (fun a => Fintype.linearCombination ℝ x a)] + +/-- The pointwise supremum of two finite suprema, obtained by taking the union +of their coefficient sets. -/ +noncomputable def sup (A B : SupLinearCombination n) : SupLinearCombination n := + { coeffs := A.coeffs ∪ B.coeffs + nonempty := A.nonempty.mono Finset.subset_union_left } + +/-- Evaluation turns `SupLinearCombination.sup` into lattice supremum. -/ +@[simp] theorem eval_sup {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (A B : SupLinearCombination n) + (x : Fin n → X) : + (A.sup B).eval x = A.eval x ⊔ B.eval x := by + classical + unfold eval sup + rw [Finset.sup'_union] + +/-- Scale every coefficient vector in a finite supremum by the scalar `r`. -/ +noncomputable def smul (r : ℝ) (A : SupLinearCombination n) : + SupLinearCombination n := by + classical + exact + { coeffs := A.coeffs.image fun a => r • a + nonempty := A.nonempty.image _ } + +/-- For non-negative scalars, evaluation turns coefficient scaling into scalar multiplication. -/ +@[simp] theorem eval_smul {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] {r : ℝ} (hr : 0 ≤ r) + (A : SupLinearCombination n) (x : Fin n → X) : + (A.smul r).eval x = r • A.eval x := by + classical + unfold eval smul + rw [Finset.sup'_image] + change A.coeffs.sup' A.nonempty (fun a => Fintype.linearCombination ℝ x (r • a)) = + r • A.coeffs.sup' A.nonempty (fun a => Fintype.linearCombination ℝ x a) + simp_rw [map_smul] + exact (map_finset_sup' (smulSupHom r hr) A.nonempty + (fun a => Fintype.linearCombination ℝ x a)).symm + +private theorem continuousLinearMap_apply_eq_linearCombination (f : StrongDual ℝ (Fin n → ℝ)) + (a : Fin n → ℝ) : + f a = Fintype.linearCombination ℝ + (fun i => f (Pi.single i (1 : ℝ) : Fin n → ℝ)) a := by + classical + have ha : a = ∑ i, a i • (Pi.single i (1 : ℝ) : Fin n → ℝ) := by + funext j + simp [Pi.single_apply, Finset.sum_apply] + calc + f a = f (∑ i, a i • (Pi.single i (1 : ℝ) : Fin n → ℝ)) := by rw [← ha] + _ = ∑ i, f (a i • (Pi.single i (1 : ℝ) : Fin n → ℝ)) := by rw [map_sum] + _ = ∑ i, a i * f (Pi.single i (1 : ℝ) : Fin n → ℝ) := by simp + _ = Fintype.linearCombination ℝ + (fun i => f (Pi.single i (1 : ℝ) : Fin n → ℝ)) a := by + simp [Fintype.linearCombination_apply, smul_eq_mul] + +/-- A finite-dimensional support-function criterion for membership in the +convex hull of `S`. + +If every real linear functional takes value on `p` no larger than its supremum +over `S`, then `p` belongs to the convex hull of `S`. -/ +private theorem mem_convexHull_of_forall_le_sup (p : Fin n → ℝ) + (S : Finset (Fin n → ℝ)) (hS : S.Nonempty) + (h : ∀ r : Fin n → ℝ, + Fintype.linearCombination ℝ r p ≤ S.sup' hS (Fintype.linearCombination ℝ r)) : + p ∈ convexHull ℝ (S : Set (Fin n → ℝ)) := by + classical + by_contra hp + obtain ⟨f, u, hfp, hsep⟩ := _root_.geometric_hahn_banach_point_closed + (E := Fin n → ℝ) + (convex_convexHull ℝ (S : Set (Fin n → ℝ))) (S.finite_toSet.isClosed_convexHull ℝ) hp + let c : Fin n → ℝ := fun i => f (Pi.single i (1 : ℝ) : Fin n → ℝ) + let r : Fin n → ℝ := fun i => -c i + have hf_eval : ∀ a : Fin n → ℝ, f a = Fintype.linearCombination ℝ c a := fun a => + continuousLinearMap_apply_eq_linearCombination f a + have hsup_lt : + S.sup' hS (Fintype.linearCombination ℝ r) < Fintype.linearCombination ℝ r p := by + rw [Finset.sup'_lt_iff] + intro q hq + have hqconv : q ∈ convexHull ℝ (S : Set (Fin n → ℝ)) := + subset_convexHull ℝ (S : Set (Fin n → ℝ)) hq + have hqsep := hsep q hqconv + have : -f q < -f p := by + simpa using neg_lt_neg (hfp.trans hqsep) + have hq_eval : Fintype.linearCombination ℝ r q = -f q := by + rw [hf_eval q] + simp [Fintype.linearCombination_apply, r, c, Finset.sum_neg_distrib, smul_eq_mul] + have hp_eval : Fintype.linearCombination ℝ r p = -f p := by + rw [hf_eval p] + simp [Fintype.linearCombination_apply, r, c, Finset.sum_neg_distrib, smul_eq_mul] + simpa [hq_eval, hp_eval] using this + exact (not_lt_of_ge (h r)) hsup_lt + +/-- If the coefficient vector `p` is a convex combination of the coefficient +vectors in `B`, then its linear evaluation is bounded by the supremum `B.eval`. + +This is the vector-lattice step: the scalar convex-combination coefficients are +non-negative, so the pointwise order bound can be summed. -/ +private theorem linearCombination_le_eval_of_mem_convexHull {X : Type*} [AddCommGroup X] + [Lattice X] [IsOrderedAddMonoid X] [VectorLattice X] (B : SupLinearCombination n) + {p : Fin n → ℝ} (hp : p ∈ convexHull ℝ (B.coeffs : Set (Fin n → ℝ))) + (x : Fin n → X) : + Fintype.linearCombination ℝ x p ≤ B.eval x := by + classical + rw [Finset.mem_convexHull'] at hp + obtain ⟨w, hw_nonneg, hw_sum, hw_eq⟩ := hp + calc + Fintype.linearCombination ℝ x p = + Fintype.linearCombination ℝ x (∑ q ∈ B.coeffs, w q • q) := by + rw [hw_eq] + _ = ∑ q ∈ B.coeffs, w q • Fintype.linearCombination ℝ x q := by + simp + _ ≤ ∑ q ∈ B.coeffs, w q • B.eval x := by + refine Finset.sum_le_sum fun q hq => ?_ + exact smul_le_smul_of_nonneg_left + (Finset.le_sup' (Fintype.linearCombination ℝ x) hq) (hw_nonneg q hq) + _ = B.eval x := by + rw [← Finset.sum_smul, hw_sum, one_smul] + +/-- If one finite supremum of linear combinations is pointwise below another on +`ℝ^n`, then the same inequality holds after evaluation in any vector lattice. -/ +theorem eval_le_of_forall_real_le {X : Type*} [AddCommGroup X] + [Lattice X] [IsOrderedAddMonoid X] [VectorLattice X] (A B : SupLinearCombination n) + (h : ∀ r : Fin n → ℝ, A.eval r ≤ B.eval r) (x : Fin n → X) : + A.eval x ≤ B.eval x := by + classical + unfold eval + refine Finset.sup'_le A.nonempty (Fintype.linearCombination ℝ x) fun p hp => ?_ + exact linearCombination_le_eval_of_mem_convexHull B + (mem_convexHull_of_forall_le_sup p B.coeffs B.nonempty fun r => + (Finset.le_sup' (Fintype.linearCombination ℝ r) hp).trans (h r)) x + +/-- If two finite suprema of linear combinations agree pointwise on `ℝ^n`, then +they agree after evaluation in any vector lattice. -/ +theorem eval_eq_of_forall_real_eq {X : Type*} [AddCommGroup X] + [Lattice X] [IsOrderedAddMonoid X] [VectorLattice X] (A B : SupLinearCombination n) + (h : ∀ r : Fin n → ℝ, A.eval r = B.eval r) (x : Fin n → X) : + A.eval x = B.eval x := + le_antisymm (eval_le_of_forall_real_le A B (fun r => (h r).le) x) + (eval_le_of_forall_real_le B A (fun r => (h r).ge) x) + +end SupLinearCombination + +/-- A signed normal form `pos - neg`, where both sides are finite suprema of +linear combinations. -/ +structure NormalForm (n : ℕ) where + /-- The positive finite supremum in the signed representation. -/ + pos : SupLinearCombination n + /-- The negative finite supremum in the signed representation. -/ + neg : SupLinearCombination n + +namespace NormalForm + +/-- Evaluate a signed normal form at a tuple in a vector lattice. -/ +noncomputable def eval {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (N : NormalForm n) (x : Fin n → X) : X := + N.pos.eval x - N.neg.eval x + +/-- The zero normal form. -/ +noncomputable def zero : NormalForm n := + { pos := SupLinearCombination.singleton (fun _ : Fin n => 0) + neg := SupLinearCombination.singleton (fun _ : Fin n => 0) } + +/-- The normal form for the `i`-th variable. -/ +noncomputable def var (i : Fin n) : NormalForm n := + { pos := SupLinearCombination.singleton (Pi.single i (1 : ℝ) : Fin n → ℝ) + neg := SupLinearCombination.singleton (fun _ : Fin n => 0) } + +/-- Add two signed normal forms. -/ +noncomputable def add (N M : NormalForm n) : NormalForm n := + { pos := N.pos.add M.pos + neg := N.neg.add M.neg } + +/-- Negate a signed normal form by swapping its positive and negative parts. -/ +noncomputable def negate (N : NormalForm n) : NormalForm n := + { pos := N.neg + neg := N.pos } + +/-- Scalar multiplication of signed normal forms. -/ +noncomputable def smul (r : ℝ) (N : NormalForm n) : NormalForm n := + if 0 ≤ r then + { pos := N.pos.smul r + neg := N.neg.smul r } + else + { pos := N.neg.smul (-r) + neg := N.pos.smul (-r) } + +/-- The lattice supremum of two signed normal forms. -/ +noncomputable def sup (N M : NormalForm n) : NormalForm n := + { pos := (N.pos.add M.neg).sup (M.pos.add N.neg) + neg := N.neg.add M.neg } + +/-- The lattice infimum of two signed normal forms. -/ +noncomputable def inf (N M : NormalForm n) : NormalForm n := + negate (sup (negate N) (negate M)) + +private theorem sup_sub_identity {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] (a b c d : X) : + ((a + d) ⊔ (b + c)) - (c + d) = (a - c) ⊔ (b - d) := by + have h : ((a - c) ⊔ (b - d)) + (c + d) = (a + d) ⊔ (b + c) := by + rw [sup_add] + congr 1 <;> abel + rw [← h] + abel + +/-- Evaluating the zero normal form gives zero. -/ +@[simp] theorem eval_zero {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (x : Fin n → X) : + (zero : NormalForm n).eval x = 0 := by + simp [eval, zero] + +/-- Evaluating a variable normal form gives the corresponding tuple entry. -/ +@[simp] theorem eval_var {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (i : Fin n) (x : Fin n → X) : + (var i).eval x = x i := by + simp [eval, var] + +/-- Evaluation turns addition of normal forms into addition. -/ +@[simp] theorem eval_add {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (N M : NormalForm n) (x : Fin n → X) : + (add N M).eval x = N.eval x + M.eval x := by + simp [eval, add] + abel + +/-- Evaluation turns negation of normal forms into negation. -/ +@[simp] theorem eval_negate {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (N : NormalForm n) + (x : Fin n → X) : + (negate N).eval x = -N.eval x := by + simp [eval, negate] + +/-- Evaluation turns scalar multiplication of normal forms into scalar multiplication. -/ +@[simp] theorem eval_smul {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (r : ℝ) (N : NormalForm n) + (x : Fin n → X) : + (smul r N).eval x = r • N.eval x := by + by_cases hr : 0 ≤ r + · simp [smul, hr, eval, smul_sub] + · have hneg : 0 ≤ -r := by linarith + simp [smul, hr, hneg, eval, smul_sub] + abel + +/-- Evaluation turns supremum of normal forms into lattice supremum. -/ +@[simp] theorem eval_sup {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (N M : NormalForm n) (x : Fin n → X) : + (sup N M).eval x = N.eval x ⊔ M.eval x := by + simp [eval, sup, sup_sub_identity] + +/-- Evaluation turns infimum of normal forms into lattice infimum. -/ +@[simp] theorem eval_inf {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (N M : NormalForm n) (x : Fin n → X) : + (inf N M).eval x = N.eval x ⊓ M.eval x := by + simp [inf, neg_sup] + +end NormalForm + +/-- Convert an arbitrary lattice-linear expression into a signed supremum of +linear combinations, preserving evaluation in every vector lattice. -/ +noncomputable def normalize : LLexpr n → NormalForm n + | .zero => NormalForm.zero + | .var i => NormalForm.var i + | .add e₁ e₂ => NormalForm.add (normalize e₁) (normalize e₂) + | .smul r e => NormalForm.smul r (normalize e) + | .sup e₁ e₂ => NormalForm.sup (normalize e₁) (normalize e₂) + | .inf e₁ e₂ => NormalForm.inf (normalize e₁) (normalize e₂) + +/-- The normal form of an expression has the same evaluation as the expression. -/ +@[simp] theorem normalize_eval {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (x : Fin n → X) (e : LLexpr n) : + (normalize e).eval x = eval x e := by + induction e <;> simp [normalize, *] + +/-- Yudin's theorem: a formal lattice-linear expression that vanishes on `ℝ` +vanishes on every vector lattice. -/ +theorem vanishes_of_vanishes_real (e : LLexpr n) (h : Vanishes ℝ e) + (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] : Vanishes X e := by + intro x + have hreal : ∀ r : Fin n → ℝ, (normalize e).pos.eval r = (normalize e).neg.eval r := by + intro r + have hr := h r + rw [← normalize_eval r e, NormalForm.eval] at hr + exact sub_eq_zero.mp hr + have hx := + SupLinearCombination.eval_eq_of_forall_real_eq (normalize e).pos (normalize e).neg hreal x + rw [← normalize_eval x e, NormalForm.eval, hx, sub_self] + +/-- If the difference of two formal expressions vanishes on the reals, their +evaluations agree in every vector lattice. -/ +theorem eval_eq_of_vanishes_real {X : Type*} [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] (x : Fin n → X) (e₁ e₂ : LLexpr n) + (h : Vanishes ℝ (add e₁ (smul (-1) e₂))) : + eval x e₁ = eval x e₂ := by + have hX : eval x e₁ + (-1 : ℝ) • eval x e₂ = 0 := + (vanishes_of_vanishes_real (add e₁ (smul (-1) e₂)) h X) x + apply sub_eq_zero.mp + simpa [sub_eq_add_neg] using hX + +end LLexpr diff --git a/LeanPool/OrderClosures/BanLat/LatticeSeminorm.lean b/LeanPool/OrderClosures/BanLat/LatticeSeminorm.lean new file mode 100644 index 0000000000..23e90ba9d1 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/LatticeSeminorm.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Basic +public import Mathlib.Analysis.LocallyConvex.WithSeminorms + + +/-! +# Lattice seminorms + +A seminorm monotone with respect to absolute value, together with its solid balls. +Extracted from BanLat `LocallySolid/WithSeminorms.lean` at +`b00e59836016aa1099b8011add6b07385e66428e`. +-/ + +@[expose] public section + +open scoped Topology Pointwise + +universe u v + +/-- A lattice seminorm on a vector lattice is a seminorm that is monotone with respect to the +lattice absolute value. -/ +structure LatticeSeminorm (E : Type u) [AddCommGroup E] [Lattice E] + [IsOrderedAddMonoid E] [VectorLattice E] extends Seminorm ℝ E where + /-- Monotonicity with respect to the lattice absolute value. -/ + monotone_abs' : ∀ {x y : E}, |x| ≤ |y| → toSeminorm x ≤ toSeminorm y + +namespace LatticeSeminorm + +variable {E : Type u} [AddCommGroup E] [Lattice E] [IsOrderedAddMonoid E] [VectorLattice E] + +/-- The underlying seminorm family of a lattice seminorm family. -/ +abbrev toSeminormFamily {ι : Type v} (p : ι → LatticeSeminorm E) : SeminormFamily ℝ E ι := + fun i => (p i).toSeminorm + +private lemma finset_sup_mono_abs {ι : Type v} (p : ι → LatticeSeminorm E) (I : Finset ι) + {x y : E} (hxy : |x| ≤ |y|) : + I.sup (toSeminormFamily p) x ≤ I.sup (toSeminormFamily p) y := by + refine Seminorm.finset_sup_apply_le (apply_nonneg _ _) fun i hi => ?_ + exact (p i).monotone_abs' hxy |>.trans + (Seminorm.le_finset_sup_apply (p := toSeminormFamily p) (s := I) (x := y) hi) + +/-- Every basis set of the seminorm family associated to a family of lattice seminorms is solid. -/ +theorem isSolid_of_mem_basisSets {ι : Type v} (p : ι → LatticeSeminorm E) {s : Set E} + (hs : s ∈ (toSeminormFamily p).basisSets) : LatticeOrderedAddCommGroup.IsSolid s := by + rcases (SeminormFamily.basisSets_iff (p := toSeminormFamily p)).mp hs with ⟨I, r, hr, rfl⟩ + intro x hx y hy + rw [Seminorm.mem_ball_zero] at hx ⊢ + exact (finset_sup_mono_abs p I hy).trans_lt hx + +end LatticeSeminorm diff --git a/LeanPool/OrderClosures/BanLat/Normed.lean b/LeanPool/OrderClosures/BanLat/Normed.lean new file mode 100644 index 0000000000..5a843b1bb5 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Normed.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Basic +public import Mathlib.Analysis.Normed.Order.Lattice +public import Mathlib.Analysis.Normed.Module.Completion +public import Mathlib.Topology.Order.MonotoneConvergence + + +/-! +# Normed vector lattices and Banach lattices + +A **normed vector lattice** is a real vector lattice whose norm satisfies the solid +axiom: `|x| ≤ |y|` implies `‖x‖ ≤ ‖y‖`. This single condition encodes compatibility +between the norm and the lattice structure. A **Banach lattice** is a normed vector +lattice whose norm is complete. This file develops the basic topology of normed +vector lattices, including continuity of lattice operations, closedness of the +positive cone, boundedness of order intervals, and monotone convergence facts. +-/ + +@[expose] public section + +/-- A normed vector lattice is a real vector lattice equipped with a lattice norm: +a norm satisfying `|x| ≤ |y| → ‖x‖ ≤ ‖y‖`. -/ +class NormedVectorLattice (X : Type*) [NormedAddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] extends VectorLattice X, HasSolidNorm X, NormSMulClass ℝ X + +namespace NormedVectorLattice + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +/-- A normed vector lattice is a normed space over `ℝ`. -/ +instance instNormedSpace : NormedSpace ℝ X where + norm_smul_le a x := (norm_smul a x).le + +/-! ### Continuity of lattice operations -/ + +/-- Supremum is jointly norm-continuous. -/ +theorem continuous_sup : Continuous (fun p : X × X => p.1 ⊔ p.2) := + ContinuousSup.continuous_sup + +/-- Infimum is jointly norm-continuous. -/ +theorem continuous_inf : Continuous (fun p : X × X => p.1 ⊓ p.2) := + ContinuousInf.continuous_inf + +/-- The absolute value map is Lipschitz with constant 1; in particular it is continuous. -/ +theorem lipschitzWith_abs : LipschitzWith 1 (|·| : X → X) := + LipschitzWith.of_dist_le_mul fun a b => by + simp only [NNReal.coe_one, one_mul, dist_eq_norm] + exact norm_abs_sub_abs a b + +/-- The norm of the positive part is bounded by the norm. -/ +theorem norm_posPart_le (x : X) : ‖x⁺‖ ≤ ‖x‖ := by + refine norm_le_norm_of_abs_le_abs ?_ + rw [abs_of_nonneg (posPart_nonneg x)] + exact posPart_le_abs x + +/-! ### Archimedean property -/ + +/-- Every normed vector lattice is Archimedean in the vector-lattice sense: the only +non-negative element all of whose multiples are bounded is zero. -/ +instance instIsVLArchimedean : IsVLArchimedean X := by + apply isVLArchimedean_of_eq_zero_of_nonneg_of_forall_nsmul_le + intro x y hx h + by_contra hne + have hxpos : (0 : ℝ) < ‖x‖ := norm_pos_iff.mpr hne + obtain ⟨n, hn⟩ := exists_lt_nsmul hxpos ‖y‖ + have h1 : ‖n • x‖ ≤ ‖y‖ := by + apply norm_le_norm_of_abs_le_abs + calc |n • x| = n • x := abs_of_nonneg (nsmul_nonneg hx n) + _ ≤ y := h n + _ ≤ |y| := le_abs_self y + rw [show (n • x : X) = (↑n : ℝ) • x from (Nat.cast_smul_eq_nsmul ℝ n x).symm, + norm_smul, Real.norm_natCast] at h1 + simp only [nsmul_eq_mul] at hn + linarith + +/-! ### Closed positive cone and order topology -/ + +/-- The order relation is closed in a normed vector lattice. -/ +instance instOrderClosedTopology : OrderClosedTopology X := + HasSolidNorm.orderClosedTopology + +/-- The positive cone `{x | 0 ≤ x}` is norm-closed. -/ +theorem isClosed_nonneg_cone : IsClosed {x : X | 0 ≤ x} := isClosed_nonneg + +/-- Inequalities are preserved under norm limits: if `u n ≤ v n` for all `n`, and +`u n → a`, `v n → b` in norm, then `a ≤ b`. -/ +theorem le_of_tendsto_of_tendsto {u v : ℕ → X} {a b : X} + (hu : Filter.Tendsto u Filter.atTop (nhds a)) + (hv : Filter.Tendsto v Filter.atTop (nhds b)) + (h : ∀ n, u n ≤ v n) : a ≤ b := + le_of_tendsto_of_tendsto' hu hv h + +/-! ### Monotone Convergence Lemma -/ + +/-- Monotone Convergence Lemma: an increasing sequence converging in norm is a least +upper bound for its range. -/ +theorem isLUB_of_monotone_tendsto {u : ℕ → X} {l : X} + (hmono : Monotone u) (hlim : Filter.Tendsto u Filter.atTop (nhds l)) : + IsLUB (Set.range u) l := + isLUB_of_tendsto_atTop hmono hlim + +/-- Antitone Convergence Lemma: a decreasing sequence converging in norm is a greatest +lower bound for its range. -/ +theorem isGLB_of_antitone_tendsto {u : ℕ → X} {l : X} + (hanti : Antitone u) (hlim : Filter.Tendsto u Filter.atTop (nhds l)) : + IsGLB (Set.range u) l := + isGLB_of_tendsto_atTop hanti hlim + +/-! ### Closed and bounded intervals -/ + +/-- Order intervals are norm-closed. -/ +theorem isClosed_interval (a b : X) : IsClosed (Set.Icc a b) := isClosed_Icc + +/-- Every element `x ∈ [a, b]` satisfies `‖x‖ ≤ ‖|a| ⊔ |b|‖`. In particular, every +order interval is norm-bounded. -/ +theorem norm_le_norm_abs_sup_abs_of_mem_Icc {a b x : X} (hx : x ∈ Set.Icc a b) : + ‖x‖ ≤ ‖|a| ⊔ |b|‖ := by + rw [← norm_abs_eq_norm x] + apply norm_le_norm_of_abs_le_abs + rw [abs_of_nonneg (le_sup_of_le_left (abs_nonneg a))] + rw [abs] + apply sup_le + · rw [abs] + apply sup_le + · exact le_trans hx.2 (le_trans (le_abs_self b) le_sup_right) + · exact le_trans (neg_le_neg hx.1) (le_trans (neg_le_abs a) le_sup_left) + · exact le_trans (neg_nonpos_of_nonneg (abs_nonneg x)) + (le_sup_of_le_left (abs_nonneg a)) + +/-- Order-bounded sets are norm-bounded. -/ +theorem isBounded_of_bddBelow_bddAbove {s : Set X} + (hl : BddBelow s) (hu : BddAbove s) : Bornology.IsBounded s := by + obtain ⟨a, ha⟩ := hl + obtain ⟨b, hb⟩ := hu + rw [Metric.isBounded_iff_subset_closedBall (0 : X)] + exact ⟨‖|a| ⊔ |b|‖, fun x hx => by + simp only [Metric.mem_closedBall, dist_zero_right] + exact norm_le_norm_abs_sup_abs_of_mem_Icc ⟨ha hx, hb hx⟩⟩ + +end NormedVectorLattice + +/-! +## Banach lattices +-/ + +/-- A Banach lattice is a normed vector lattice with a complete norm. -/ +class BanachLattice (X : Type*) [NormedAddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] extends NormedVectorLattice X, CompleteSpace X + +/-- The real numbers form a normed vector lattice over themselves. -/ +noncomputable instance : NormedVectorLattice ℝ where + +/-- The real numbers form a Banach lattice over themselves. -/ +noncomputable instance : BanachLattice ℝ where + +/-! +## Completion of a normed vector lattice + +The metric completion of a normed vector lattice carries a compatible lattice structure +making it again a normed vector lattice; being complete, it is a Banach lattice. +-/ + +section Completion + +open UniformSpace + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +private lemma uniformContinuous₂_sup_completion : + UniformContinuous fun p : X × X => p.1 ⊔ p.2 := by + have h : (fun p : X × X => p.1 ⊔ p.2) = fun p : X × X => p.1 + (p.2 - p.1)⁺ := by + funext p + exact sup_eq_add_posPart p.1 p.2 + rw [h] + exact uniformContinuous_fst.add + (lipschitzWith_posPart.uniformContinuous.comp (uniformContinuous_snd.sub uniformContinuous_fst)) + +private lemma uniformContinuous₂_inf_completion : + UniformContinuous fun p : X × X => p.1 ⊓ p.2 := by + have h : (fun p : X × X => p.1 ⊓ p.2) = fun p : X × X => -((-p.1) ⊔ (-p.2)) := by + funext p + rw [neg_sup, neg_neg, neg_neg] + rw [h] + exact (uniformContinuous₂_sup_completion.comp + (uniformContinuous_fst.neg.prodMk uniformContinuous_snd.neg)).neg + +/-- The completion of a normed vector lattice is a lattice. -/ +noncomputable instance instLatticeCompletion : Lattice (Completion X) := by + letI : Max (Completion X) := ⟨Completion.map₂ (fun x y : X => x ⊔ y)⟩ + letI : Min (Completion X) := ⟨Completion.map₂ (fun x y : X => x ⊓ y)⟩ + have coe_sup : ∀ x y : X, ((x ⊔ y : X) : Completion X) = + (x : Completion X) ⊔ (y : Completion X) := fun x y => by + rw [show (x : Completion X) ⊔ (y : Completion X) = + Completion.map₂ (fun x y : X => x ⊔ y) x y from rfl, + Completion.map₂_coe_coe x y (fun x y : X => x ⊔ y) uniformContinuous₂_sup_completion] + have coe_inf : ∀ x y : X, ((x ⊓ y : X) : Completion X) = + (x : Completion X) ⊓ (y : Completion X) := fun x y => by + rw [show (x : Completion X) ⊓ (y : Completion X) = + Completion.map₂ (fun x y : X => x ⊓ y) x y from rfl, + Completion.map₂_coe_coe x y (fun x y : X => x ⊓ y) uniformContinuous₂_inf_completion] + refine Lattice.mk' ?sup_comm ?sup_assoc ?inf_comm ?inf_assoc ?sup_inf_self ?inf_sup_self + · intro x y + refine Completion.induction_on₂ x y ?_ ?_ + · exact isClosed_eq (Completion.continuous_map₂ continuous_fst continuous_snd) + (Completion.continuous_map₂ continuous_snd continuous_fst) + · intro x y + rw [← coe_sup, ← coe_sup, sup_comm] + · intro x y z + refine Completion.induction_on₃ x y z ?_ ?_ + · exact isClosed_eq + (Completion.continuous_map₂ + (Completion.continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd)) + (continuous_snd.comp continuous_snd)) + (Completion.continuous_map₂ continuous_fst + (Completion.continuous_map₂ (continuous_fst.comp continuous_snd) + (continuous_snd.comp continuous_snd))) + · intro x y z + rw [← coe_sup, ← coe_sup, ← coe_sup, ← coe_sup, sup_assoc] + · intro x y + refine Completion.induction_on₂ x y ?_ ?_ + · exact isClosed_eq (Completion.continuous_map₂ continuous_fst continuous_snd) + (Completion.continuous_map₂ continuous_snd continuous_fst) + · intro x y + rw [← coe_inf, ← coe_inf, inf_comm] + · intro x y z + refine Completion.induction_on₃ x y z ?_ ?_ + · exact isClosed_eq + (Completion.continuous_map₂ + (Completion.continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd)) + (continuous_snd.comp continuous_snd)) + (Completion.continuous_map₂ continuous_fst + (Completion.continuous_map₂ (continuous_fst.comp continuous_snd) + (continuous_snd.comp continuous_snd))) + · intro x y z + rw [← coe_inf, ← coe_inf, ← coe_inf, ← coe_inf, inf_assoc] + · intro x y + refine Completion.induction_on₂ x y ?_ ?_ + · exact isClosed_eq + (Completion.continuous_map₂ continuous_fst + (Completion.continuous_map₂ continuous_fst continuous_snd)) + continuous_fst + · intro x y + rw [← coe_inf, ← coe_sup, sup_inf_self] + · intro x y + refine Completion.induction_on₂ x y ?_ ?_ + · exact isClosed_eq + (Completion.continuous_map₂ continuous_fst + (Completion.continuous_map₂ continuous_fst continuous_snd)) + continuous_fst + · intro x y + rw [← coe_sup, ← coe_inf, inf_sup_self] + +/-- The inclusion of a normed vector lattice into its completion preserves suprema. -/ +@[norm_cast] +theorem coe_sup_completion (x y : X) : + ((x ⊔ y : X) : Completion X) = (x : Completion X) ⊔ (y : Completion X) := by + rw [show (x : Completion X) ⊔ (y : Completion X) = + Completion.map₂ (fun x y : X => x ⊔ y) x y from rfl, + Completion.map₂_coe_coe x y (fun x y : X => x ⊔ y) uniformContinuous₂_sup_completion] + +/-- The inclusion of a normed vector lattice into its completion preserves infima. -/ +@[norm_cast] +theorem coe_inf_completion (x y : X) : + ((x ⊓ y : X) : Completion X) = (x : Completion X) ⊓ (y : Completion X) := by + rw [show (x : Completion X) ⊓ (y : Completion X) = + Completion.map₂ (fun x y : X => x ⊓ y) x y from rfl, + Completion.map₂_coe_coe x y (fun x y : X => x ⊓ y) uniformContinuous₂_inf_completion] + +/-- The inclusion of a normed vector lattice into its completion preserves absolute values. -/ +@[norm_cast] +theorem coe_abs_completion (x : X) : + ((|x| : X) : Completion X) = |(x : Completion X)| := by + rw [abs, abs, ← Completion.coe_neg, ← coe_sup_completion] + +private theorem completion_sup_add (x y z : Completion X) : + (x + z) ⊔ (y + z) = (x ⊔ y) + z := by + refine Completion.induction_on₃ x y z ?_ ?_ + · exact isClosed_eq + (Completion.continuous_map₂ + (Completion.continuous_map₂ continuous_fst (continuous_snd.comp continuous_snd)) + (Completion.continuous_map₂ (continuous_fst.comp continuous_snd) + (continuous_snd.comp continuous_snd))) + (Completion.continuous_map₂ + (Completion.continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd)) + (continuous_snd.comp continuous_snd)) + · intro x y z + rw [← Completion.coe_add, ← Completion.coe_add, ← coe_sup_completion, + ← coe_sup_completion, ← Completion.coe_add, add_comm x z, add_comm y z, + add_comm (x ⊔ y) z, ← add_sup] + +/-- The order on the completion of a normed vector lattice is compatible with addition. -/ +noncomputable instance instIsOrderedAddMonoidCompletion : + IsOrderedAddMonoid (Completion X) := by + refine + { add_le_add_left := fun x y hxy z => ?_ + add_le_add_right := fun x y hxy z => ?_ } + · rw [← sup_eq_right] at hxy ⊢ + rw [completion_sup_add, hxy] + · rw [← sup_eq_right] at hxy ⊢ + rw [add_comm z x, add_comm z y, completion_sup_add, hxy] + +private theorem completion_smul_sup_of_nonneg {r : ℝ} (hr : 0 ≤ r) + (x y : Completion X) : r • (x ⊔ y) = r • x ⊔ r • y := by + refine Completion.induction_on₂ x y ?_ ?_ + · exact isClosed_eq + ((Completion.continuous_map₂ continuous_fst continuous_snd).const_smul r) + (Completion.continuous_map₂ (continuous_fst.const_smul r) (continuous_snd.const_smul r)) + · intro x y + rw [← coe_sup_completion, ← Completion.coe_smul, ← Completion.coe_smul, + ← Completion.coe_smul, ← coe_sup_completion, nonneg_smul_sup x y r hr] + +noncomputable instance instVectorLatticeCompletion : VectorLattice (Completion X) where + smul_le_smul_of_nonneg_left := by + intro r hr x y hxy + rw [← sup_eq_right] at hxy ⊢ + rw [← completion_smul_sup_of_nonneg hr, hxy] + +private theorem continuous_sup_completion : + Continuous fun p : Completion X × Completion X => p.1 ⊔ p.2 := + Completion.continuous_map₂ continuous_fst continuous_snd + +private theorem continuous_inf_completion : + Continuous fun p : Completion X × Completion X => p.1 ⊓ p.2 := + Completion.continuous_map₂ continuous_fst continuous_snd + +private theorem continuous_abs_completion : + Continuous (|·| : Completion X → Completion X) := by + change Continuous fun x : Completion X => x ⊔ -x + exact continuous_sup_completion.comp (continuous_id.prodMk continuous_neg) + +omit [Lattice X] [IsOrderedAddMonoid X] [NormedVectorLattice X] in +private lemma exists_seq_coe_tendsto (a : Completion X) : + ∃ u : ℕ → X, Filter.Tendsto (fun n => ((u n : Completion X))) Filter.atTop (nhds a) := by + have ha : a ∈ closure (Set.range ((↑) : X → Completion X)) := by + rw [(Completion.denseRange_coe (α := X)).closure_range] + exact Set.mem_univ a + obtain ⟨x, hxr, hxl⟩ := mem_closure_iff_seq_limit.mp ha + choose u hu using hxr + exact ⟨u, by simpa only [hu] using hxl⟩ + +/-- The completion of a normed vector lattice has a solid norm. -/ +noncomputable instance instHasSolidNormCompletion : HasSolidNorm (Completion X) where + solid := by + intro a b hab + have ha_le : a ≤ |b| := (abs_le'.mp hab).1 + have ha_ge : -|b| ≤ a := neg_le.mp (abs_le'.mp hab).2 + obtain ⟨u, hu⟩ := exists_seq_coe_tendsto a + obtain ⟨v, hv⟩ := exists_seq_coe_tendsto b + have hclampcont : Continuous fun p : Completion X × Completion X => + (p.1 ⊔ -|p.2|) ⊓ |p.2| := by + have habs2 : Continuous fun p : Completion X × Completion X => |p.2| := + continuous_abs_completion.comp continuous_snd + have hsup : Continuous fun p : Completion X × Completion X => p.1 ⊔ -|p.2| := + continuous_sup_completion.comp (continuous_fst.prodMk habs2.neg) + exact continuous_inf_completion.comp (hsup.prodMk habs2) + have hcoe : ∀ n, ((((u n ⊔ -|v n|) ⊓ |v n| : X)) : Completion X) + = (↑(u n) ⊔ -|↑(v n)|) ⊓ |↑(v n)| := fun n => by + rw [coe_inf_completion, coe_sup_completion, Completion.coe_neg, coe_abs_completion] + have hprod : Filter.Tendsto (fun n => ((↑(u n), ↑(v n)) : Completion X × Completion X)) + Filter.atTop (nhds (a, b)) := hu.prodMk_nhds hv + have hclamp := (hclampcont.tendsto (a, b)).comp hprod + change Filter.Tendsto (fun n => (↑(u n) ⊔ -|↑(v n)|) ⊓ |↑(v n)|) + Filter.atTop (nhds ((a ⊔ -|b|) ⊓ |b|)) at hclamp + rw [sup_eq_left.mpr ha_ge, inf_eq_left.mpr ha_le] at hclamp + have hwlim : Filter.Tendsto + (fun n => (((u n ⊔ -|v n|) ⊓ |v n| : X) : Completion X)) Filter.atTop (nhds a) := by + simpa only [hcoe] using hclamp + have hnorm_w : Filter.Tendsto + (fun n => ‖(((u n ⊔ -|v n|) ⊓ |v n| : X) : Completion X)‖) Filter.atTop (nhds ‖a‖) := + (continuous_norm.tendsto a).comp hwlim + have hnorm_v : Filter.Tendsto (fun n => ‖((v n : Completion X))‖) Filter.atTop (nhds ‖b‖) := + (continuous_norm.tendsto b).comp hv + refine le_of_tendsto_of_tendsto' hnorm_w hnorm_v (fun n => ?_) + rw [Completion.norm_coe, Completion.norm_coe] + refine HasSolidNorm.solid ?_ + have hc_le : (u n ⊔ -|v n|) ⊓ |v n| ≤ |v n| := inf_le_right + have hneg_le : -|v n| ≤ (u n ⊔ -|v n|) ⊓ |v n| := + le_inf le_sup_right (le_trans (neg_nonpos_of_nonneg (abs_nonneg (v n))) (abs_nonneg (v n))) + rw [abs_le'] + exact ⟨hc_le, by rwa [neg_le]⟩ + +/-- The completion of a normed vector lattice is a normed vector lattice. -/ +noncomputable instance instNormedVectorLatticeCompletion : + NormedVectorLattice (Completion X) where + +/-- **The completion of a normed vector lattice is a Banach lattice.** -/ +noncomputable instance instBanachLatticeCompletion : BanachLattice (Completion X) where + +/-- The canonical inclusion into the completion preserves the isometry to `toComplₗᵢ`; it is +an isometry from `X` into its completion. -/ +theorem isometry_coe_completion : Isometry ((↑) : X → Completion X) := by + rw [← Completion.coe_toComplₗᵢ (𝕜 := ℝ)] + exact (Completion.toComplₗᵢ (𝕜 := ℝ)).isometry + +end Completion diff --git a/LeanPool/OrderClosures/BanLat/Operators/Hom.lean b/LeanPool/OrderClosures/BanLat/Operators/Hom.lean new file mode 100644 index 0000000000..ba584c38cb --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Operators/Hom.lean @@ -0,0 +1,606 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Operators.Positive +public import LeanPool.OrderClosures.BanLat.LLexpr +public import Mathlib.Analysis.Normed.Operator.LinearIsometry + + +/-! +# Morphisms of vector lattices + +This file defines `VecLatHom`, the type of vector lattice homomorphisms — maps that are +simultaneously real-linear and lattice homomorphisms — together with the +proposition-valued predicate `IsVecLatHom` characterising such maps. Key results include +the characterisation of vector lattice homomorphisms by their behaviour on absolute +values (`VecLatHom.ofAbs`) and the fact that every vector lattice homomorphism is monotone. + +The second section develops `VecLatEquiv`, the type of vector lattice isomorphisms. It +packages `Positive.extensionEquiv`, which extends an additive bijection between positive +cones to a vector lattice isomorphism, and `toContinuousLinearEquiv`, which turns a +vector lattice isomorphism between Banach lattices into a continuous linear equivalence. + +The final section introduces `BanachLatEquiv`, the type of Banach lattice isometries: +real linear isometric equivalences that also preserve `⊔` and `⊓`. +-/ + +@[expose] public section + +/-! ## Vector lattice homomorphisms -/ + +/-- A vector lattice homomorphism from `X` to `Y`: a real-linear map that also preserves +`⊔` and `⊓`. -/ +structure VecLatHom (X : Type*) (Y : Type*) [AddCommGroup X] [AddCommGroup Y] + [Lattice X] [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [VectorLattice X] [VectorLattice Y] extends X →ₗ[ℝ] Y, LatticeHom X Y + +attribute [inherit_doc LatticeHom] VecLatHom.toLatticeHom + +variable {X : Type*} {Y : Type*} [AddCommGroup X] [AddCommGroup Y] + [Lattice X] [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [VectorLattice X] [VectorLattice Y] + +/-- Predicate form of `VecLatHom`: a map is a vector lattice homomorphism if it is linear +and preserves `⊔` and `⊓`. -/ +structure IsVecLatHom (f : X → Y) extends IsLinearMap ℝ f where + map_sup' : ∀ x y : X, f (x ⊔ y) = (f x) ⊔ (f y) + map_inf' : ∀ x y : X, f (x ⊓ y) = (f x) ⊓ (f y) + +namespace VecLatHom + +/-- The canonical `FunLike` instance, making `VecLatHom X Y` a type of functions `X → Y`. -/ +instance instFunLike : FunLike (VecLatHom X Y) X Y where + coe f := f.toFun + coe_injective f g h := by + dsimp at h + cases f + cases g + congr + exact LinearMap.ext_iff.mpr (congrFun h) + +/-- Every `VecLatHom` satisfies the `IsVecLatHom` predicate. -/ +theorem isVecLatHom (f : VecLatHom X Y) : IsVecLatHom f where + map_add := f.toLinearMap.map_add + map_smul := f.toLinearMap.map_smul + map_sup' := f.toLatticeHom.map_sup' + map_inf' := f.toLatticeHom.map_inf' + +/-- Construct a `VecLatHom` from a proof that a function satisfies `IsVecLatHom`. -/ +def ofIsVecLatHom (f : X → Y) (h : IsVecLatHom f) : VecLatHom X Y where + toFun := f + map_add' := h.map_add + map_smul' := h.map_smul + map_sup' := h.map_sup' + map_inf' := h.map_inf' + +/-- `VecLatHom X Y` is a `LatticeHomClass`. -/ +instance instLatticeHomClass : LatticeHomClass (VecLatHom X Y) X Y where + map_inf := by + intro f a b + exact f.toLatticeHom.map_inf' a b + map_sup := by + intro f a b + exact f.toLatticeHom.map_sup' a b + +/-- `VecLatHom X Y` is a `LinearMapClass`. -/ +instance instLinearMapClass : LinearMapClass (VecLatHom X Y) ℝ X Y where + map_add := by + intro f a b + exact f.toLinearMap.map_add a b + map_smulₛₗ := by + intro f c x + simp only [RingHom.id_apply] + exact f.toLinearMap.map_smul c x + +/-- The underlying function of a `VecLatHom` equals its coercion to `X → Y`. -/ +theorem toFun_eq_coe {f : VecLatHom X Y} : f.toFun = (f : X → Y) := rfl + +/-- A vector lattice homomorphism preserves absolute values. -/ +theorem map_abs (f : VecLatHom X Y) (x : X) : f |x| = |f x| := by + rw [abs, abs, map_sup, map_neg] + +/-- Every vector lattice homomorphism is monotone. -/ +theorem monotone (f : VecLatHom X Y) : Monotone f := by + intro x y hxy + have : x ⊔ y = y := by simp [hxy] + rw [← sup_eq_right, ← map_sup f x y, this] + +/-- A vector lattice homomorphism maps nonneg elements to nonneg elements. -/ +theorem map_nonneg (f : VecLatHom X Y) {x : X} (hx : 0 ≤ x) : 0 ≤ f x := by + have h := f.monotone hx; rwa [map_zero] at h + +/-- An injective vector lattice homomorphism reflects the order: if `f a ≤ f b` then +`a ≤ b`. Together with `monotone`, an injective vector lattice homomorphism is an order +embedding. -/ +theorem le_of_map_le (f : VecLatHom X Y) (hf : Function.Injective f) {a b : X} + (hab : f a ≤ f b) : a ≤ b := + sup_eq_right.mp (hf (by rw [map_sup f a b]; exact sup_eq_right.mpr hab)) + +/-- A vector lattice homomorphism preserves positive parts: `f x⁺ = (f x)⁺`. -/ +theorem map_posPart (f : VecLatHom X Y) (x : X) : f x⁺ = (f x)⁺ := by + rw [posPart_def, map_sup, map_zero, posPart_def] + +/-- A vector lattice homomorphism preserves negative parts: `f x⁻ = (f x)⁻`. -/ +theorem map_negPart (f : VecLatHom X Y) (x : X) : f x⁻ = (f x)⁻ := by + rw [negPart_def, map_sup, map_neg, map_zero, negPart_def] + +/-- A vector lattice homomorphism preserves disjointness: `x ⊓ y = 0 → f x ⊓ f y = 0`. -/ +theorem map_disjoint (f : VecLatHom X Y) {x y : X} (h : x ⊓ y = 0) : f x ⊓ f y = 0 := by + rw [← map_inf, h, map_zero] + +/-- The identity vector lattice homomorphism. -/ +def id : VecLatHom X X := + { LinearMap.id with + map_sup' := fun _ _ => rfl + map_inf' := fun _ _ => rfl } + +/-- Construct a `VecLatHom` from a linear map that preserves absolute values. -/ +def ofAbs (f : X →ₗ[ℝ] Y) (abs : ∀ x : X, f |x| = |f x|) : VecLatHom X Y := + { f with + map_sup' := fun a b => by + change f (a ⊔ b) = f a ⊔ f b + rw [sup_eq_half_smul_add_add_abs_sub' ℝ, map_smul, map_add, map_add, + abs (b - a), map_sub, ← sup_eq_half_smul_add_add_abs_sub' ℝ] + map_inf' := fun a b => by + change f (a ⊓ b) = f a ⊓ f b + rw [inf_eq_half_smul_add_sub_abs_sub' ℝ, map_smul, map_sub, map_add, + abs (b - a), map_sub, ← inf_eq_half_smul_add_sub_abs_sub' ℝ] } + +/-- Composition of two vector lattice homomorphisms. -/ +def comp {Z : Type*} [AddCommGroup Z] [Lattice Z] [IsOrderedAddMonoid Z] + [VectorLattice Z] (g : VecLatHom Y Z) (f : VecLatHom X Y) : + VecLatHom X Z := + {LinearMap.comp g.toLinearMap f.toLinearMap with + map_sup' := by + intro x y + simp only [AddHom.toFun_eq_coe, LinearMap.coe_toAddHom, LinearMap.coe_comp, + Function.comp_apply] + change g ( f (x ⊔ y) ) = (g (f x)) ⊔ (g (f y)) + simp only [map_sup] + map_inf' := by + intro x y + simp only [AddHom.toFun_eq_coe, LinearMap.coe_toAddHom, LinearMap.coe_comp, + Function.comp_apply] + change g ( f (x ⊓ y) ) = (g (f x)) ⊓ (g (f y)) + simp only [map_inf] + } + +/-- Evaluation of a composed `VecLatHom`. -/ +theorem comp_apply {Z : Type*} [AddCommGroup Z] [Lattice Z] + [IsOrderedAddMonoid Z] [VectorLattice Z] (g : VecLatHom Y Z) + (f : VecLatHom X Y) (x : X) : g.comp f x = g (f x) := by + rw [comp] + change (LinearMap.comp g.toLinearMap f.toLinearMap) x = g (f x) + simp + rfl + +/-- The inverse of a bijective vector lattice homomorphism is again a vector lattice +homomorphism. -/ +noncomputable def symm (f : VecLatHom X Y) (h : Function.Bijective f) : VecLatHom Y X := + {(LinearEquiv.ofBijective f.toLinearMap h).symm with + map_sup' := by + intro a b + change + (LinearEquiv.ofBijective f.toLinearMap h).symm (a ⊔ b) = + (LinearEquiv.ofBijective f.toLinearMap h).symm a ⊔ + (LinearEquiv.ofBijective f.toLinearMap h).symm b + rw [LinearEquiv.symm_apply_eq] + change + a ⊔ b = f ( (LinearEquiv.ofBijective f.toLinearMap h).symm a ⊔ + (LinearEquiv.ofBijective f.toLinearMap h).symm b) + rw [map_sup] + change + a ⊔ b = LinearEquiv.ofBijective f.toLinearMap h + ((LinearEquiv.ofBijective f.toLinearMap h).symm a) ⊔ + LinearEquiv.ofBijective f.toLinearMap h + ((LinearEquiv.ofBijective f.toLinearMap h).symm b) + rw [LinearEquiv.apply_symm_apply, LinearEquiv.apply_symm_apply] + map_inf' := by + intro a b + change + (LinearEquiv.ofBijective f.toLinearMap h).symm (a ⊓ b) = + (LinearEquiv.ofBijective f.toLinearMap h).symm a ⊓ + (LinearEquiv.ofBijective f.toLinearMap h).symm b + rw [LinearEquiv.symm_apply_eq] + change + a ⊓ b = f ( (LinearEquiv.ofBijective f.toLinearMap h).symm a ⊓ + (LinearEquiv.ofBijective f.toLinearMap h).symm b) + rw [map_inf] + change + a ⊓ b = LinearEquiv.ofBijective f.toLinearMap h + ((LinearEquiv.ofBijective f.toLinearMap h).symm a) ⊓ + LinearEquiv.ofBijective f.toLinearMap h + ((LinearEquiv.ofBijective f.toLinearMap h).symm b) + rw [LinearEquiv.apply_symm_apply, LinearEquiv.apply_symm_apply] + } + +/-- The inverse bijection from `symm`: `(f.symm h) y = x ↔ y = f x`. -/ +theorem symm_apply (f : VecLatHom X Y) (h : Function.Bijective f) + (x : X) (y : Y) : (f.symm h) y = x ↔ y = f x := by + let lineq := LinearEquiv.ofBijective f.toLinearMap h + change lineq.symm y = x ↔ y = f x + apply LinearEquiv.symm_apply_eq + +end VecLatHom + +namespace LLexpr + +variable {n : ℕ} + +/-- A vector lattice homomorphism commutes with evaluation of lattice-linear expressions. -/ +theorem map_eval {Y Z : Type*} + [AddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] [VectorLattice Y] + [AddCommGroup Z] [Lattice Z] [IsOrderedAddMonoid Z] [VectorLattice Z] + (T : VecLatHom Y Z) (y : Fin n → Y) (e : LLexpr n) : + T (eval y e) = eval (fun i => T (y i)) e := by + induction e with + | zero => simp [eval] + | var i => simp [eval] + | add e₁ e₂ h₁ h₂ => simp [eval, h₁, h₂] + | smul r e h => simp [eval, h] + | sup e₁ e₂ h₁ h₂ => simp [eval, h₁, h₂, map_sup] + | inf e₁ e₂ h₁ h₂ => simp [eval, h₁, h₂, map_inf] + +end LLexpr + +namespace IsVecLatHom + +/-- Bundle an `IsVecLatHom` proof into a `VecLatHom`. -/ +def mk' (f : X → Y) (vlh : IsVecLatHom f) : VecLatHom X Y where + toFun := f + map_add' := vlh.map_add + map_smul' := vlh.map_smul + map_sup' := vlh.map_sup' + map_inf' := vlh.map_inf' + +/-- Evaluation of `mk'` agrees with the underlying function. -/ +@[simp] +theorem mk'_apply {f : X → Y} (vlh : IsVecLatHom f) (x : X) : + mk' f vlh x = f x := rfl + +/-- A linear map that preserves absolute values satisfies `IsVecLatHom`. -/ +theorem of_abs {f : X → Y} (lin : IsLinearMap ℝ f) (abs : ∀ x : X, f |x| + = |f x|) : IsVecLatHom f := + VecLatHom.isVecLatHom (VecLatHom.ofAbs (IsLinearMap.mk' f lin) abs) + +/-- A positive linear map that preserves disjointness is a vector lattice homomorphism. -/ +theorem of_disjoint {f : X → Y} (lin : IsLinearMap ℝ f) + (_pos : ∀ x : X, 0 ≤ x → 0 ≤ f x) + (disj : ∀ x y : X, x ⊓ y = 0 → f x ⊓ f y = 0) : IsVecLatHom f := by + have fNeg : ∀ x : X, f (-x) = -f x := fun x => by + have h := lin.map_smul (-1 : ℝ) x; rwa [neg_one_smul, neg_one_smul] at h + have fSub : ∀ x y : X, f (x - y) = f x - f y := fun x y => by + rw [sub_eq_add_neg, lin.map_add, fNeg, ← sub_eq_add_neg] + have fPosPart : ∀ c : X, f c⁺ = (f c)⁺ := fun c => + uniqueness_posPart (f c) (by rw [← fSub, posPart_sub_negPart]) + (disj c⁺ c⁻ (posPart_inf_negPart_eq_zero c)) + have fSup : ∀ a b : X, f (a ⊔ b) = f a ⊔ f b := fun a b => by + rw [sup_eq_add_posPart_sub, lin.map_add, fPosPart, fSub, ← sup_eq_add_posPart_sub] + exact { lin with + map_sup' := fSup + map_inf' := fun a b => by + have h := fSup (-a) (-b) + rw [← neg_inf] at h + rw [fNeg, fNeg a, fNeg b, ← neg_inf] at h + exact neg_inj.mp h } + +end IsVecLatHom + +/-! ## Vector lattice isomorphisms -/ + +/-- A vector lattice isomorphism: a real-linear equivalence that also preserves `⊔` and `⊓`. -/ +structure VecLatEquiv (X : Type*) (Y : Type*) [AddCommGroup X] [AddCommGroup Y] + [Lattice X] [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [VectorLattice X] [VectorLattice Y] extends X ≃ₗ[ℝ] Y, LatticeHom X Y + +attribute [inherit_doc LatticeHom] VecLatEquiv.toLatticeHom + +namespace VecLatEquiv + +/-- The canonical `FunLike` instance, making `VecLatEquiv X Y` a type of functions `X → Y`. -/ +instance instFunLike : FunLike (VecLatEquiv X Y) X Y where + coe e := e.toFun + coe_injective := by + intro f g h + cases f; cases g + congr 1 + exact LinearEquiv.ext (congrFun h) + +/-- Coerce a `VecLatEquiv` to a `VecLatHom`. -/ +def toVecLatHom (e : VecLatEquiv X Y) : VecLatHom X Y := + { e.toLinearMap with + map_sup' := e.map_sup' + map_inf' := e.map_inf' } + +/-- The identity vector lattice isomorphism. -/ +def refl : VecLatEquiv X X := + { LinearEquiv.refl ℝ X with + map_sup' := fun _ _ => rfl + map_inf' := fun _ _ => rfl } + +/-- The inverse of a vector lattice isomorphism. -/ +def symm (e : VecLatEquiv X Y) : VecLatEquiv Y X := + { e.toLinearEquiv.symm with + map_sup' := fun a b => by + have h := e.map_sup' (e.toLinearEquiv.symm a) (e.toLinearEquiv.symm b) + simp only [AddHom.toFun_eq_coe, LinearMap.coe_toAddHom, LinearEquiv.coe_coe, + LinearEquiv.apply_symm_apply] at h + change e.toLinearEquiv.symm (a ⊔ b) = e.toLinearEquiv.symm a ⊔ e.toLinearEquiv.symm b + exact e.toLinearEquiv.injective (by rw [LinearEquiv.apply_symm_apply]; exact h.symm) + map_inf' := fun a b => by + have h := e.map_inf' (e.toLinearEquiv.symm a) (e.toLinearEquiv.symm b) + simp only [AddHom.toFun_eq_coe, LinearMap.coe_toAddHom, LinearEquiv.coe_coe, + LinearEquiv.apply_symm_apply] at h + change e.toLinearEquiv.symm (a ⊓ b) = e.toLinearEquiv.symm a ⊓ e.toLinearEquiv.symm b + exact e.toLinearEquiv.injective (by rw [LinearEquiv.apply_symm_apply]; exact h.symm) } + +/-- Composition of vector lattice isomorphisms. -/ +def trans {Z : Type*} [AddCommGroup Z] [Lattice Z] [IsOrderedAddMonoid Z] [VectorLattice Z] + (e₁ : VecLatEquiv X Y) (e₂ : VecLatEquiv Y Z) : VecLatEquiv X Z := + { e₁.toLinearEquiv.trans e₂.toLinearEquiv with + map_sup' := fun a b => by + change e₂.toFun (e₁.toFun (a ⊔ b)) = e₂.toFun (e₁.toFun a) ⊔ e₂.toFun (e₁.toFun b) + rw [e₁.map_sup', e₂.map_sup'] + map_inf' := fun a b => by + change e₂.toFun (e₁.toFun (a ⊓ b)) = e₂.toFun (e₁.toFun a) ⊓ e₂.toFun (e₁.toFun b) + rw [e₁.map_inf', e₂.map_inf'] } + +end VecLatEquiv + +/-! ### Extension from the positive cone -/ + +namespace Positive + +variable {X Y : Type*} [AddCommGroup X] [AddCommGroup Y] [Lattice X] [Lattice Y] + [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] [VectorLattice X] [VectorLattice Y] + [IsVLArchimedean Y] {τ : X → Y} + (hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + +/-- An additive bijection between positive cones extends to a vector lattice +isomorphism when the codomain is Archimedean. -/ +noncomputable def extensionEquiv + (hτ_inj : ∀ x y, 0 ≤ x → 0 ≤ y → τ x = τ y → x = y) + (hτ_surj : ∀ y, 0 ≤ y → ∃ x, 0 ≤ x ∧ τ x = y) : + VecLatEquiv X Y := by + set T := extension hτ_nn hτ_add + have hT_inj : Function.Injective T := by + intro a b hab + have h : T (a - b) = 0 := by + rw [map_sub]; exact sub_eq_zero.mpr hab + rw [extension_apply] at h + have heq : (a - b)⁺ = (a - b)⁻ := + hτ_inj _ _ (posPart_nonneg _) (negPart_nonneg _) (sub_eq_zero.mp h) + have hsub := posPart_sub_negPart (a - b) + rw [heq, sub_self] at hsub + exact sub_eq_zero.mp hsub.symm + have hT_surj : Function.Surjective T := by + intro y + obtain ⟨a, ha, haτ⟩ := hτ_surj y⁺ (posPart_nonneg y) + obtain ⟨b, hb, hbτ⟩ := hτ_surj y⁻ (negPart_nonneg y) + exact ⟨a - b, by + rw [map_sub, extension_nonneg hτ_nn hτ_add ha, + extension_nonneg hτ_nn hτ_add hb, haτ, hbτ, + posPart_sub_negPart]⟩ + -- T is order-reflecting: 0 ≤ Tx → 0 ≤ x + have hT_bipos : ∀ x, 0 ≤ T x → 0 ≤ x := by + intro x hTx + rw [extension_apply] at hTx + have hτle : τ x⁻ ≤ τ x⁺ := sub_nonneg.mp hTx + obtain ⟨c, hc, hcτ⟩ := hτ_surj _ hTx + have hsum : τ (x⁻ + c) = τ x⁺ := by + rw [hτ_add _ _ (negPart_nonneg _) hc, hcτ, add_sub_cancel] + have heq : x⁻ + c = x⁺ := + hτ_inj _ _ (add_nonneg (negPart_nonneg _) hc) (posPart_nonneg _) hsum + have hle : x⁻ ≤ x⁺ := heq ▸ le_add_of_nonneg_right hc + have : x⁻ = 0 := (inf_eq_left.mpr hle).symm.trans + ((inf_comm x⁻ x⁺).trans (posPart_inf_negPart_eq_zero x)) + rw [← posPart_sub_negPart x, this, sub_zero] + exact posPart_nonneg _ + -- T⁻¹ is monotone (from bipositivity + positivity) + have hT_inv_mono : ∀ a b, T a ≤ T b → a ≤ b := by + intro a b hab + have : 0 ≤ T (b - a) := by rw [map_sub]; exact sub_nonneg.mpr hab + exact sub_nonneg.mp (hT_bipos _ this) + have hT_mono : Monotone T := monotone_iff.mpr (extension_positive hτ_nn hτ_add) + -- T preserves ⊔ + have hT_sup : ∀ a b, T (a ⊔ b) = T a ⊔ T b := by + intro a b + apply le_antisymm + · obtain ⟨c, hc⟩ := hT_surj (T a ⊔ T b) + have hca : a ≤ c := hT_inv_mono _ _ (hc ▸ le_sup_left) + have hcb : b ≤ c := hT_inv_mono _ _ (hc ▸ le_sup_right) + rw [← hc]; exact hT_mono (sup_le hca hcb) + · exact sup_le (hT_mono le_sup_left) (hT_mono le_sup_right) + -- T preserves ⊓ + have hT_inf : ∀ a b, T (a ⊓ b) = T a ⊓ T b := by + intro a b + apply le_antisymm + · exact le_inf (hT_mono inf_le_left) (hT_mono inf_le_right) + · obtain ⟨c, hc⟩ := hT_surj (T a ⊓ T b) + have hca : c ≤ a := hT_inv_mono _ _ (hc ▸ inf_le_left) + have hcb : c ≤ b := hT_inv_mono _ _ (hc ▸ inf_le_right) + rw [← hc]; exact hT_mono (le_inf hca hcb) + exact + { (LinearEquiv.ofBijective T ⟨hT_inj, hT_surj⟩) with + map_sup' := hT_sup + map_inf' := hT_inf } + +end Positive + +/-! ### Continuous linear equivalence between Banach lattices -/ + +namespace VecLatEquiv + +variable {X Y : Type*} [NormedAddCommGroup X] [NormedAddCommGroup Y] + [Lattice X] [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [BanachLattice X] [BanachLattice Y] + +/-- A vector lattice isomorphism between Banach lattices extends to a continuous linear +equivalence. -/ +noncomputable def toContinuousLinearEquiv (e : VecLatEquiv X Y) : X ≃L[ℝ] Y := + ContinuousLinearEquiv.mk e.toLinearEquiv + (Positive.continuous (Positive.monotone_iff.mp e.toVecLatHom.monotone)) + (Positive.continuous (Positive.monotone_iff.mp e.symm.toVecLatHom.monotone)) + +end VecLatEquiv + +/-! ## Banach lattice isometries -/ + +/-- A **Banach lattice isometry** between two Banach lattices: a real linear +isometric equivalence that also preserves the lattice operations `⊔` and `⊓`. +Such a map is automatically an order isomorphism. -/ +structure BanachLatEquiv (X Y : Type*) + [NormedAddCommGroup X] [NormedAddCommGroup Y] + [Lattice X] [Lattice Y] + [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [BanachLattice X] [BanachLattice Y] + extends X ≃ₗᵢ[ℝ] Y, LatticeHom X Y + +attribute [inherit_doc LatticeHom] BanachLatEquiv.toLatticeHom + +namespace BanachLatEquiv + +variable {X Y : Type*} + [NormedAddCommGroup X] [NormedAddCommGroup Y] + [Lattice X] [Lattice Y] + [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [BanachLattice X] [BanachLattice Y] + +/-- The canonical `FunLike` instance, making `BanachLatEquiv X Y` a type of +functions `X → Y`. -/ +instance instFunLike : FunLike (BanachLatEquiv X Y) X Y where + coe e := e.toFun + coe_injective := by + intro f g h + cases f; cases g + congr 1 + exact LinearIsometryEquiv.toLinearEquiv_injective + (LinearEquiv.toEquiv_injective (Equiv.coe_inj.mp h)) + +/-- Coerce a `BanachLatEquiv` to a continuous linear equivalence. -/ +noncomputable def toContinuousLinearEquiv (e : BanachLatEquiv X Y) : X ≃L[ℝ] Y := + e.toLinearIsometryEquiv.toContinuousLinearEquiv + +/-- Coerce a `BanachLatEquiv` to a `VecLatEquiv`. -/ +def toVecLatEquiv (e : BanachLatEquiv X Y) : VecLatEquiv X Y := + { e.toLinearIsometryEquiv.toLinearEquiv with + map_sup' := e.map_sup' + map_inf' := e.map_inf' } + +/-- The inverse of a Banach lattice isometry. -/ +def symm (e : BanachLatEquiv X Y) : BanachLatEquiv Y X where + toLinearIsometryEquiv := e.toLinearIsometryEquiv.symm + map_sup' := e.toVecLatEquiv.symm.map_sup' + map_inf' := e.toVecLatEquiv.symm.map_inf' + +/-- The identity Banach lattice isometry. -/ +def refl (X : Type*) [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [BanachLattice X] : BanachLatEquiv X X where + toLinearIsometryEquiv := LinearIsometryEquiv.refl ℝ X + map_sup' := fun _ _ => rfl + map_inf' := fun _ _ => rfl + +/-- The composition of two Banach lattice isometries. -/ +def trans {Z : Type*} [NormedAddCommGroup Z] [Lattice Z] [IsOrderedAddMonoid Z] + [BanachLattice Z] (e₁ : BanachLatEquiv X Y) (e₂ : BanachLatEquiv Y Z) : + BanachLatEquiv X Z where + toLinearIsometryEquiv := e₁.toLinearIsometryEquiv.trans e₂.toLinearIsometryEquiv + map_sup' := (e₁.toVecLatEquiv.trans e₂.toVecLatEquiv).map_sup' + map_inf' := (e₁.toVecLatEquiv.trans e₂.toVecLatEquiv).map_inf' + +end BanachLatEquiv + +/-! ## Inclusion into the completion -/ + +section Completion + +open UniformSpace + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +/-- The canonical inclusion of a normed vector lattice into its completion, as a vector +lattice homomorphism. -/ +noncomputable def toCompletionVecLatHom : VecLatHom X (Completion X) where + toFun := ((↑) : X → Completion X) + map_add' := Completion.coe_add + map_smul' := Completion.coe_smul + map_sup' := coe_sup_completion + map_inf' := coe_inf_completion + +@[simp] +theorem coe_toCompletionVecLatHom : + ⇑(toCompletionVecLatHom : VecLatHom X (Completion X)) = ((↑) : X → Completion X) := + rfl + +/-- The canonical inclusion of a normed vector lattice into its completion is an isometry; +together with `toCompletionVecLatHom` this exhibits the inclusion as a lattice isometry. -/ +theorem isometry_toCompletionVecLatHom : + Isometry (toCompletionVecLatHom : X → Completion X) := by + rw [coe_toCompletionVecLatHom] + exact isometry_coe_completion + +/-- A norm-preserving vector lattice homomorphism `T : X → Y` with dense range into a Banach +lattice `Y` extends to a Banach lattice isometry from the completion of `X` onto `Y`. -/ +noncomputable def banachLatEquivCompletionOfDenseIsometry + {Y : Type*} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] [BanachLattice Y] + (T : VecLatHom X Y) (hT_norm : ∀ x, ‖T x‖ = ‖x‖) (hT_dense : DenseRange ⇑T) : + BanachLatEquiv (Completion X) Y := by + let Tli : X →ₗᵢ[ℝ] Y := { toLinearMap := T.toLinearMap, norm_map' := hT_norm } + have huc : UniformContinuous ⇑Tli := Tli.isometry.uniformContinuous + let Tc : Completion X →ₗᵢ[ℝ] Y := + { toFun := Completion.extension Tli + map_add' := fun z w => by + refine Completion.induction_on₂ z w (isClosed_eq ?_ ?_) (fun x y => ?_) + · exact Completion.continuous_extension.comp continuous_add + · exact (Completion.continuous_extension.comp continuous_fst).add + (Completion.continuous_extension.comp continuous_snd) + · rw [← Completion.coe_add, Completion.extension_coe huc, Completion.extension_coe huc, + Completion.extension_coe huc, map_add] + map_smul' := fun r z => by + refine Completion.induction_on z (isClosed_eq ?_ ?_) (fun x => ?_) + · exact Completion.continuous_extension.comp (continuous_const_smul r) + · exact (continuous_const_smul r).comp Completion.continuous_extension + · rw [← Completion.coe_smul, Completion.extension_coe huc, Completion.extension_coe huc, + map_smul, RingHom.id_apply] + norm_map' := fun z => by + refine Completion.induction_on z (isClosed_eq ?_ ?_) (fun x => ?_) + · exact continuous_norm.comp Completion.continuous_extension + · exact continuous_norm + · change ‖Completion.extension (⇑Tli) (x : Completion X)‖ = ‖(x : Completion X)‖ + rw [Completion.extension_coe huc, Tli.norm_map, Completion.norm_coe] } + have hTc_coe : ∀ a : X, Tc (a : Completion X) = T a := fun a => + Completion.extension_coe huc a + have hdense : DenseRange ⇑Tc := by + refine hT_dense.mono ?_ + rintro _ ⟨x, rfl⟩ + exact ⟨(x : Completion X), hTc_coe x⟩ + have hsurj : Function.Surjective ⇑Tc := by + have hclosed : IsClosed (Set.range ⇑Tc) := Tc.isometry.isClosedEmbedding.isClosed_range + rw [← Set.range_eq_univ, ← hclosed.closure_eq, hdense.closure_range] + refine + { toLinearIsometryEquiv := LinearIsometryEquiv.ofSurjective Tc hsurj + map_sup' := fun z w => ?_ + map_inf' := fun z w => ?_ } + · change Tc (z ⊔ w) = Tc z ⊔ Tc w + refine Completion.induction_on₂ z w (isClosed_eq ?_ ?_) (fun x y => ?_) + · exact Tc.continuous.comp ContinuousSup.continuous_sup + · exact ContinuousSup.continuous_sup.comp + ((Tc.continuous.comp continuous_fst).prodMk (Tc.continuous.comp continuous_snd)) + · rw [← coe_sup_completion, hTc_coe, hTc_coe, hTc_coe] + exact T.map_sup' x y + · change Tc (z ⊓ w) = Tc z ⊓ Tc w + refine Completion.induction_on₂ z w (isClosed_eq ?_ ?_) (fun x y => ?_) + · exact Tc.continuous.comp ContinuousInf.continuous_inf + · exact ContinuousInf.continuous_inf.comp + ((Tc.continuous.comp continuous_fst).prodMk (Tc.continuous.comp continuous_snd)) + · rw [← coe_inf_completion, hTc_coe, hTc_coe, hTc_coe] + exact T.map_inf' x y + +end Completion diff --git a/LeanPool/OrderClosures/BanLat/Operators/Positive.lean b/LeanPool/OrderClosures/BanLat/Operators/Positive.lean new file mode 100644 index 0000000000..049700a17a --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Operators/Positive.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import Mathlib.Analysis.Normed.Group.InfiniteSum + +public import LeanPool.OrderClosures.BanLat.Normed +public import Mathlib.Algebra.Order.Module.Basic +public import Mathlib.Topology.Algebra.Module.Equiv + + +/-! +# Positive operators + +A linear map between vector lattices is **positive** if it sends non-negative elements to +non-negative elements. For linear maps, positivity is equivalent to monotonicity, and a +positive operator satisfies `|f x| ≤ f |x|`. + +The **extension lemma** shows that an additive map on the positive cone extends uniquely +to a positive linear operator when the codomain is Archimedean. Finally, every positive +operator from a Banach lattice to a normed vector lattice is automatically continuous. +-/ + +@[expose] public section + +/-! ## Definition and basic properties -/ + +variable {X Y : Type*} [AddCommGroup X] [AddCommGroup Y] [Lattice X] [Lattice Y] + [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] [VectorLattice X] [VectorLattice Y] + +/-- A linear map is *positive* if it sends non-negative elements to non-negative elements. -/ +def Positive (f : X →ₗ[ℝ] Y) : Prop := + ∀ x : X, 0 ≤ x → 0 ≤ f x + +namespace Positive + +/-- For a linear map between vector lattices, monotonicity and positivity are equivalent. -/ +theorem monotone_iff {f : X →ₗ[ℝ] Y} : Monotone f ↔ Positive f := by + constructor + · intro hm x hx + simpa [map_zero] using hm hx + · intro hp a b hab + have h : 0 ≤ f (b - a) := hp (b - a) (sub_nonneg.mpr hab) + rwa [map_sub, sub_nonneg] at h + +/-- A positive operator satisfies `|f x| ≤ f |x|`. -/ +theorem abs_le_map_abs {f : X →ₗ[ℝ] Y} (hf : Positive f) (x : X) : |f x| ≤ f |x| := by + rw [abs] + apply sup_le + · exact (monotone_iff.mpr hf) (by rw [abs]; exact le_sup_left) + · have h : f (-x) ≤ f |x| := (monotone_iff.mpr hf) (by rw [abs]; exact le_sup_right) + rwa [map_neg] at h + +/-! ## Order on linear operators + +The space `X →ₗ[ℝ] Y` of linear operators between vector lattices is partially +ordered by `T ≤ S ↔ Positive (S - T)`, equivalently `T x ≤ S x` for every +`0 ≤ x`. Under this order, `0 ≤ T` is the same as `Positive T`. -/ + +instance : LE (X →ₗ[ℝ] Y) where + le T S := Positive (S - T) + +theorem le_def {T S : X →ₗ[ℝ] Y} : T ≤ S ↔ Positive (S - T) := Iff.rfl + +theorem le_iff {T S : X →ₗ[ℝ] Y} : T ≤ S ↔ ∀ x, 0 ≤ x → T x ≤ S x := by + refine ⟨fun h x hx => ?_, fun h x hx => ?_⟩ + · have hxs := h x hx; rwa [LinearMap.sub_apply, sub_nonneg] at hxs + · rw [LinearMap.sub_apply, sub_nonneg]; exact h x hx + +@[simp] theorem zero_le_iff {T : X →ₗ[ℝ] Y} : 0 ≤ T ↔ Positive T := by + change Positive (T - 0) ↔ _; rw [sub_zero] + +instance : PartialOrder (X →ₗ[ℝ] Y) where + le_refl T := by + change Positive (T - T); rw [sub_self]; intro _ _; exact le_refl 0 + le_trans T S R hTS hSR := by + intro x hx + have heq : (R - T) x = (R - S) x + (S - T) x := by + simp [LinearMap.sub_apply] + rw [heq] + exact add_nonneg (hSR x hx) (hTS x hx) + le_antisymm T S hTS hST := by + ext x + have hp : T x⁺ = S x⁺ := + le_antisymm ((le_iff.mp hTS) _ (posPart_nonneg x)) + ((le_iff.mp hST) _ (posPart_nonneg x)) + have hn : T x⁻ = S x⁻ := + le_antisymm ((le_iff.mp hTS) _ (negPart_nonneg x)) + ((le_iff.mp hST) _ (negPart_nonneg x)) + rw [show x = x⁺ - x⁻ from (posPart_sub_negPart x).symm, + map_sub, map_sub, hp, hn] + +/-! ## Extension from the positive cone -/ + +section ExtensionLemma + +variable {X Y : Type*} [AddCommGroup X] [AddCommGroup Y] [Lattice X] [Lattice Y] + [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] [VectorLattice X] [VectorLattice Y] + [IsVLArchimedean Y] {τ : X → Y} + +omit [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [VectorLattice X] [VectorLattice Y] [IsVLArchimedean Y] in +private lemma tau_zero + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) : + τ 0 = 0 := by + have h := hτ_add 0 0 le_rfl le_rfl + rw [add_zero] at h + exact (add_left_cancel (show τ 0 + 0 = τ 0 + τ 0 from by + rw [add_zero]; exact h)).symm + +omit [Lattice Y] [IsOrderedAddMonoid Y] [VectorLattice X] + [VectorLattice Y] [IsVLArchimedean Y] in +private lemma tau_nsmul + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + (n : ℕ) {x : X} (hx : 0 ≤ x) : + τ (n • x) = n • τ x := by + induction n with + | zero => simp [tau_zero hτ_add] + | succ n ih => + rw [succ_nsmul, hτ_add _ _ (nsmul_nonneg hx n) hx, ih, succ_nsmul] + +omit [VectorLattice X] [VectorLattice Y] [IsVLArchimedean Y] in +private lemma tau_mono + (hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + {a b : X} (ha : 0 ≤ a) (_hb : 0 ≤ b) (hab : a ≤ b) : + τ a ≤ τ b := by + have hd : 0 ≤ b - a := sub_nonneg.mpr hab + have : τ b = τ a + τ (b - a) := by + rw [← hτ_add a (b - a) ha hd]; congr 1; abel + rw [this] + exact le_add_of_nonneg_right (hτ_nn _ hd) + +private lemma tau_real_smul + (hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + {r : ℝ} (hr : 0 ≤ r) {x : X} (hx : 0 ≤ x) : + τ (r • x) = r • τ x := by + set d := τ (r • x) - r • τ x with hd_def + suffices hd : d = 0 from sub_eq_zero.mp hd + rw [← abs_eq_zero_iff_zero] + apply IsVLArchimedean.eq_zero_of_nonneg_of_forall_nsmul_le + (y := τ x) (abs_nonneg d) + intro m + set k := Nat.floor ((m : ℝ) * r) + have hmr : 0 ≤ (m : ℝ) * r := mul_nonneg (Nat.cast_nonneg m) hr + have hk_le : (k : ℝ) ≤ (m : ℝ) * r := Nat.floor_le hmr + have hmr_lt : (m : ℝ) * r < (k : ℝ) + 1 := Nat.lt_floor_add_one _ + have hmrx : m • (r • x) = ((m : ℝ) * r) • x := by + rw [← Nat.cast_smul_eq_nsmul ℝ, smul_smul] + -- m • τ(r•x) and m • (r • τ x) both lie in [k • τ x, (k+1) • τ x] + have hlo : k • τ x ≤ m • τ (r • x) := by + rw [← tau_nsmul hτ_add m (smul_nonneg hr hx), + ← tau_nsmul hτ_add k hx] + exact tau_mono hτ_nn hτ_add (nsmul_nonneg hx k) + (nsmul_nonneg (smul_nonneg hr hx) m) <| by + rw [hmrx, ← Nat.cast_smul_eq_nsmul ℝ k x] + exact smul_le_smul_of_nonneg_right hk_le hx + have hhi : m • τ (r • x) ≤ (k + 1) • τ x := by + rw [← tau_nsmul hτ_add m (smul_nonneg hr hx), + ← tau_nsmul hτ_add (k + 1) hx] + exact tau_mono hτ_nn hτ_add + (nsmul_nonneg (smul_nonneg hr hx) m) + (nsmul_nonneg hx (k + 1)) <| by + rw [hmrx, ← Nat.cast_smul_eq_nsmul ℝ (k + 1) x] + exact smul_le_smul_of_nonneg_right (by push_cast; exact hmr_lt.le) hx + have hlo' : k • τ x ≤ m • (r • τ x) := by + rw [← Nat.cast_smul_eq_nsmul ℝ, ← Nat.cast_smul_eq_nsmul ℝ, smul_smul] + exact smul_le_smul_of_nonneg_right hk_le (hτ_nn _ hx) + have hhi' : m • (r • τ x) ≤ (k + 1) • τ x := by + rw [← Nat.cast_smul_eq_nsmul ℝ m (r • τ x), + ← Nat.cast_smul_eq_nsmul ℝ (k + 1) (τ x), smul_smul] + exact smul_le_smul_of_nonneg_right (by push_cast; exact hmr_lt.le) + (hτ_nn _ hx) + -- Both values lie in an interval of width τ x, so |m•d| ≤ τ x + have h1 : m • τ (r • x) - m • (r • τ x) ≤ τ x := + calc m • τ (r • x) - m • (r • τ x) + ≤ (k + 1) • τ x - k • τ x := sub_le_sub hhi hlo' + _ = τ x := by rw [add_nsmul, one_nsmul, add_sub_cancel_left] + have h2 : m • (r • τ x) - m • τ (r • x) ≤ τ x := + calc m • (r • τ x) - m • τ (r • x) + ≤ (k + 1) • τ x - k • τ x := sub_le_sub hhi' hlo + _ = τ x := by rw [add_nsmul, one_nsmul, add_sub_cancel_left] + -- Convert to m • |d| ≤ τ x + have habs : |m • τ (r • x) - m • (r • τ x)| ≤ τ x := + sup_le h1 (show -(m • τ (r • x) - m • (r • τ x)) ≤ τ x by rwa [neg_sub]) + have hmd : m • τ (r • x) - m • (r • τ x) = m • d := by + rw [← smul_sub] + rw [hmd] at habs + rw [← Nat.cast_smul_eq_nsmul ℝ m d] at habs + rw [abs_smul' d (↑m : ℝ), abs_of_nonneg (Nat.cast_nonneg m)] at habs + rwa [Nat.cast_smul_eq_nsmul ℝ m |d|] at habs + +private lemma posPart_smul_nonneg {r : ℝ} (hr : 0 ≤ r) (x : X) : + (r • x)⁺ = r • x⁺ := by + change (r • x) ⊔ 0 = r • (x ⊔ 0) + rw [← smul_zero r, ← nonneg_smul_sup x 0 r hr, smul_zero] + +private lemma negPart_smul_nonneg {r : ℝ} (hr : 0 ≤ r) (x : X) : + (r • x)⁻ = r • x⁻ := by + change (-(r • x)) ⊔ 0 = r • ((-x) ⊔ 0) + rw [← smul_neg, ← smul_zero r, ← nonneg_smul_sup (-x) 0 r hr, smul_zero] + +omit [IsOrderedAddMonoid Y] [VectorLattice X] [VectorLattice Y] + [IsVLArchimedean Y] in +lemma extFun_add + (_hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + (x y : X) : + τ (x + y)⁺ - τ (x + y)⁻ = (τ x⁺ - τ x⁻) + (τ y⁺ - τ y⁻) := by + have hid : (x + y)⁺ + x⁻ + y⁻ = (x + y)⁻ + x⁺ + y⁺ := by + have l1 : (x + y)⁺ = x + y + (x + y)⁻ := + eq_add_of_sub_eq (posPart_sub_negPart _) + have l2 : x⁺ = x + x⁻ := eq_add_of_sub_eq (posPart_sub_negPart x) + have l3 : y⁺ = y + y⁻ := eq_add_of_sub_eq (posPart_sub_negPart y) + rw [l1, l2, l3]; abel + have hlhs : τ ((x + y)⁺ + x⁻ + y⁻) = + τ (x + y)⁺ + τ x⁻ + τ y⁻ := by + rw [hτ_add _ _ (add_nonneg (posPart_nonneg _) (negPart_nonneg _)) + (negPart_nonneg _), + hτ_add _ _ (posPart_nonneg _) (negPart_nonneg _)] + have hrhs : τ ((x + y)⁻ + x⁺ + y⁺) = + τ (x + y)⁻ + τ x⁺ + τ y⁺ := by + rw [hτ_add _ _ (add_nonneg (negPart_nonneg _) (posPart_nonneg _)) + (posPart_nonneg _), + hτ_add _ _ (negPart_nonneg _) (posPart_nonneg _)] + have key := hlhs.symm.trans ((congrArg τ hid).trans hrhs) + calc τ (x + y)⁺ - τ (x + y)⁻ + = τ (x + y)⁺ + τ x⁻ + τ y⁻ - τ x⁻ - τ y⁻ - τ (x + y)⁻ := by + abel + _ = τ (x + y)⁻ + τ x⁺ + τ y⁺ - τ x⁻ - τ y⁻ - τ (x + y)⁻ := by + rw [key] + _ = τ x⁺ - τ x⁻ + (τ y⁺ - τ y⁻) := by abel + +private lemma extFun_smul + (hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + (r : ℝ) (x : X) : + τ (r • x)⁺ - τ (r • x)⁻ = r • (τ x⁺ - τ x⁻) := by + by_cases hr : 0 ≤ r + · rw [posPart_smul_nonneg hr, negPart_smul_nonneg hr, + tau_real_smul hτ_nn hτ_add hr (posPart_nonneg _), + tau_real_smul hτ_nn hτ_add hr (negPart_nonneg _), smul_sub] + · push Not at hr + have hnr : 0 ≤ -r := le_of_lt (neg_pos.mpr hr) + have hrx : r • x = -((-r) • x) := by rw [neg_smul, neg_neg] + have hp : (r • x)⁺ = (-r) • x⁻ := by + rw [hrx, posPart_neg, negPart_smul_nonneg hnr] + have hn : (r • x)⁻ = (-r) • x⁺ := by + rw [hrx, negPart_neg, posPart_smul_nonneg hnr] + rw [hp, hn, + tau_real_smul hτ_nn hτ_add hnr (negPart_nonneg _), + tau_real_smul hτ_nn hτ_add hnr (posPart_nonneg _)] + rw [← smul_sub (-r) (τ x⁻) (τ x⁺), + show τ x⁻ - τ x⁺ = -(τ x⁺ - τ x⁻) from (neg_sub _ _).symm, + smul_neg, neg_smul, neg_neg] + +variable + (hτ_nn : ∀ x, 0 ≤ x → 0 ≤ τ x) + (hτ_add : ∀ x y, 0 ≤ x → 0 ≤ y → τ (x + y) = τ x + τ y) + +/-- **Extension Lemma**: an additive map on the positive cone of a vector lattice +extends to a unique positive linear operator when the codomain is Archimedean. +The extension satisfies `T x = τ x⁺ − τ x⁻`. -/ +noncomputable def extension : X →ₗ[ℝ] Y := + { toFun := fun x => τ x⁺ - τ x⁻ + map_add' := extFun_add hτ_nn hτ_add + map_smul' := fun r x => by + simp only [RingHom.id_apply] + exact extFun_smul hτ_nn hτ_add r x } + +@[simp] +theorem extension_apply (x : X) : + extension hτ_nn hτ_add x = τ x⁺ - τ x⁻ := rfl + +theorem extension_nonneg {x : X} (hx : 0 ≤ x) : + extension hτ_nn hτ_add x = τ x := by + rw [extension_apply, posPart_of_nonneg hx, negPart_of_nonneg hx, + tau_zero hτ_add, sub_zero] + +theorem extension_positive : Positive (extension hτ_nn hτ_add) := + fun x hx => by + rw [extension_nonneg hτ_nn hτ_add hx]; exact hτ_nn _ hx + +/-- The positive linear extension is the unique positive operator +extending τ on nonneg elements. -/ +theorem extension_unique {f : X →ₗ[ℝ] Y} (_hf : Positive f) + (hext : ∀ x, 0 ≤ x → f x = τ x) : + f = extension hτ_nn hτ_add := by + ext x + simp only [extension_apply] + rw [← hext _ (posPart_nonneg _), ← hext _ (negPart_nonneg _), ← map_sub] + congr 1; exact (posPart_sub_negPart x).symm + +end ExtensionLemma + +/-! ## Automatic continuity on Banach lattices -/ + +variable {X Y : Type*} [NormedAddCommGroup X] [NormedAddCommGroup Y] + [Lattice X] [Lattice Y] [IsOrderedAddMonoid X] [IsOrderedAddMonoid Y] + [BanachLattice X] [NormedVectorLattice Y] + +private lemma norm_map_le_of_abs_le {f : X →ₗ[ℝ] Y} (hf : Positive f) + {x y : X} (h : |x| ≤ y) : ‖f x‖ ≤ ‖f y‖ := + norm_le_norm_of_abs_le_abs <| + (abs_le_map_abs hf x).trans <| + ((monotone_iff.mpr hf) h).trans (le_abs_self _) + +/-- Every positive linear operator from a Banach lattice to a normed vector lattice +is continuous. -/ +theorem continuous {f : X →ₗ[ℝ] Y} (hf : Positive f) : Continuous f := by + by_contra hcont + have hunb : ∀ C : ℝ, ∃ x : X, C * ‖x‖ < ‖f x‖ := by + by_contra h; push Not at h; obtain ⟨C, hC⟩ := h + exact hcont (continuous_of_linear_of_bound f.map_add f.map_smul hC) + -- For each n, find xₙ with ‖xₙ‖ ≤ (1/2)ⁿ and n < ‖f xₙ‖ + have hseq : ∀ n : ℕ, ∃ x : X, ‖x‖ ≤ (1 / 2 : ℝ) ^ n ∧ (n : ℝ) < ‖f x‖ := by + intro n + obtain ⟨z, hz⟩ := hunb ((n : ℝ) * (2 : ℝ) ^ n) + have hznz : z ≠ 0 := by intro h; simp [h] at hz + refine ⟨((2 : ℝ) ^ n * ‖z‖)⁻¹ • z, ?_, ?_⟩ + · rw [norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr (by positivity))] + rw [inv_mul_le_iff₀ (by positivity : (0 : ℝ) < 2 ^ n * ‖z‖)] + simp [one_div, mul_comm] + · rw [map_smul, norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr (by positivity))] + rw [lt_inv_mul_iff₀ (by positivity : (0 : ℝ) < 2 ^ n * ‖z‖)] + linarith [mul_comm ((n : ℝ) * (2 : ℝ) ^ n) ‖z‖] + choose x hxn hxf using hseq + have habs : Summable (fun n => |x n|) := + .of_norm_bounded (g := fun n => (1 / 2 : ℝ) ^ n) + (summable_geometric_of_lt_one (by norm_num) (by norm_num)) + (fun n => by rw [norm_abs_eq_norm]; exact hxn n) + set y := ∑' n, |x n| + have hle : ∀ n, |x n| ≤ y := fun n => habs.le_tsum n (fun j _ => abs_nonneg _) + obtain ⟨N, hN⟩ := exists_nat_gt ‖f y‖ + exact absurd (lt_of_lt_of_le (hxf N) (norm_map_le_of_abs_le hf (hle N))) + (not_lt.mpr hN.le) + +end Positive diff --git a/LeanPool/OrderClosures/BanLat/OrderComplete.lean b/LeanPool/OrderClosures/BanLat/OrderComplete.lean new file mode 100644 index 0000000000..1ebab4b84d --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/OrderComplete.lean @@ -0,0 +1,379 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import Mathlib.Algebra.Order.Group.Pointwise.Bounds +public import LeanPool.OrderClosures.BanLat.Basic +public import Mathlib.Order.ConditionallyCompleteLattice.Basic +public import Mathlib.Data.Set.Countable + + +/-! +# Sigma conditional completeness + +Mathlib's `ConditionallyCompleteLattice` records Dedekind completeness of a +lattice. This file gives vector-lattice characterisations of conditional +completeness, introduces the sequential analogue +`SigmaConditionallyCompleteLattice`, and relates these completeness notions to +the Archimedean property. +-/ + +@[expose] public section + +open Set + +universe u + +/-! ### Shared order-completeness lemmas -/ + +/-- Shift trick: in a lattice-ordered group, given a predicate `P` preserved +under pointwise transformations and a hypothesis producing a least upper bound +for `P`-sets of positive elements, the same hypothesis extends to any +`P`-set that is non-empty and bounded above. -/ +lemma exists_isLUB_of_pos_of_shift + {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + {P : Set X → Prop} + (hP_image : ∀ {S : Set X} (f : X → X), P S → P (f '' S)) + (Hpos : ∀ {S : Set X}, P S → S ⊆ {x | 0 ≤ x} → S.Nonempty → BddAbove S → + ∃ x, IsLUB S x) + {S : Set X} (hPS : P S) (hne : S.Nonempty) (hbdd : BddAbove S) : + ∃ x, IsLUB S x := by + obtain ⟨s₀, hs₀⟩ := hne + obtain ⟨c, hc⟩ := hbdd + have hcs₀ : s₀ ≤ c := hc hs₀ + set T : Set X := (fun x => (x - s₀)⁺) '' S with hT_def + have hPT : P T := hP_image _ hPS + have hTpos : T ⊆ {x | 0 ≤ x} := by + rintro _ ⟨x, _, rfl⟩; exact posPart_nonneg _ + have hTne : T.Nonempty := ⟨_, s₀, hs₀, rfl⟩ + have hTbdd : BddAbove T := ⟨c - s₀, by + rintro _ ⟨x, hx, rfl⟩ + calc (x - s₀)⁺ ≤ (c - s₀)⁺ := posPart_mono (sub_le_sub_right (hc hx) _) + _ = c - s₀ := posPart_of_nonneg (sub_nonneg.mpr hcs₀)⟩ + obtain ⟨w, hw⟩ := Hpos hPT hTpos hTne hTbdd + refine ⟨w + s₀, ?_, ?_⟩ + · intro x hx + calc x = (x - s₀) + s₀ := by abel + _ ≤ (x - s₀)⁺ + s₀ := by gcongr; exact le_posPart _ + _ ≤ w + s₀ := by gcongr; exact hw.1 ⟨x, hx, rfl⟩ + · intro c' hc' + have hcs₀' : s₀ ≤ c' := hc' hs₀ + have hubT : c' - s₀ ∈ upperBounds T := by + rintro _ ⟨x, hx, rfl⟩ + calc (x - s₀)⁺ ≤ (c' - s₀)⁺ := posPart_mono (sub_le_sub_right (hc' hx) _) + _ = c' - s₀ := posPart_of_nonneg (sub_nonneg.mpr hcs₀') + exact le_sub_iff_add_le.mp (hw.2 hubT) + +/-- Build a `ConditionallyCompleteLattice` structure from a blanket hypothesis +that every non-empty bounded above set has a least upper bound. -/ +@[reducible] +noncomputable def conditionallyCompleteLatticeOfHasLUB + {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (hLUB : ∀ {S : Set X}, S.Nonempty → BddAbove S → ∃ x, IsLUB S x) : + ConditionallyCompleteLattice X := by + classical + have hne_neg : ∀ (s : Set X), s.Nonempty → (-s).Nonempty := fun s hne => by + obtain ⟨x, hx⟩ := hne + exact ⟨-x, Set.mem_neg.mpr (by rwa [neg_neg])⟩ + let sSup_fn : Set X → X := fun S => + if h : S.Nonempty ∧ BddAbove S then Classical.choose (hLUB h.1 h.2) else 0 + exact + { (inferInstance : Lattice X) with + sSup := sSup_fn + sInf := fun S => -sSup_fn (-S) + isLUB_csSup := fun s hne hb => by + refine ⟨?_, ?_⟩ + · intro a ha + change a ≤ sSup_fn s + simp only [sSup_fn, dite_eq_left (⟨hne, hb⟩ : s.Nonempty ∧ BddAbove s)] + exact (Classical.choose_spec (hLUB hne hb)).1 ha + · intro a ha + change sSup_fn s ≤ a + simp only [sSup_fn, dite_eq_left (⟨hne, ⟨a, ha⟩⟩ : s.Nonempty ∧ BddAbove s)] + exact (Classical.choose_spec (hLUB hne ⟨a, ha⟩)).2 ha + isGLB_csInf := fun s hne hb => by + refine ⟨?_, ?_⟩ + · intro a ha + change -sSup_fn (-s) ≤ a + have hne' : (-s).Nonempty := hne_neg s hne + have hbdd' : BddAbove (-s) := bddAbove_neg.mpr hb + simp only [sSup_fn, dite_eq_left (⟨hne', hbdd'⟩ : (-s).Nonempty ∧ BddAbove (-s))] + rw [neg_le] + exact (Classical.choose_spec (hLUB hne' hbdd')).1 + (Set.mem_neg.mpr (by rwa [neg_neg])) + · intro a ha + change a ≤ -sSup_fn (-s) + have hb' : BddBelow s := ⟨a, ha⟩ + have hne' : (-s).Nonempty := hne_neg s hne + have hbdd' : BddAbove (-s) := bddAbove_neg.mpr hb' + simp only [sSup_fn, dite_eq_left (⟨hne', hbdd'⟩ : (-s).Nonempty ∧ BddAbove (-s))] + rw [le_neg] + apply (Classical.choose_spec (hLUB hne' hbdd')).2 + intro y hy + rw [Set.mem_neg] at hy + rw [le_neg] + exact ha hy } + +/-- From the existence of a least upper bound for every increasing bounded +above net of positive elements, deduce the same conclusion for any non-empty +bounded above set of positive elements. The net is obtained by indexing over +non-empty finite subsets ordered by inclusion. -/ +lemma exists_isLUB_pos_set_of_pos_net + {X : Type u} [AddCommGroup X] [Lattice X] + (H : ∀ {ι : Type u} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X}, Monotone u → (∀ i, 0 ≤ u i) → + BddAbove (range u) → ∃ x, IsLUB (range u) x) + {S : Set X} (hpos : S ⊆ {x | 0 ≤ x}) (hne : S.Nonempty) + (hbdd : BddAbove S) : ∃ x, IsLUB S x := by + classical + let ι : Type u := {F : Finset X // F.Nonempty ∧ ↑F ⊆ S} + let : Preorder ι := inferInstance + let : IsDirected ι (· ≤ ·) := ⟨fun F G => + ⟨⟨F.1 ∪ G.1, Finset.Nonempty.mono Finset.subset_union_left F.2.1, by + rw [Finset.coe_union]; exact Set.union_subset F.2.2 G.2.2⟩, + Finset.subset_union_left, Finset.subset_union_right⟩⟩ + let : Nonempty ι := by + obtain ⟨s₀, hs₀⟩ := hne + exact ⟨⟨{s₀}, Finset.singleton_nonempty _, by simpa using hs₀⟩⟩ + let u : ι → X := fun F => F.1.sup' F.2.1 id + have hmono : Monotone u := fun F G h => + Finset.sup'_mono id h F.2.1 + have hu_pos : ∀ F, 0 ≤ u F := fun F => by + obtain ⟨x, hx⟩ := F.2.1 + calc (0 : X) ≤ x := hpos (F.2.2 hx) + _ ≤ u F := Finset.le_sup' id hx + have hu_bdd : BddAbove (range u) := by + obtain ⟨c, hc⟩ := hbdd + refine ⟨c, ?_⟩ + rintro _ ⟨F, rfl⟩ + refine Finset.sup'_le F.2.1 id fun i hi => hc (F.2.2 ?_) + exact Finset.mem_coe.mpr hi + obtain ⟨w, hw⟩ := H hmono hu_pos hu_bdd + refine ⟨w, ?_, ?_⟩ + · intro x hx + have hmem : u ⟨{x}, Finset.singleton_nonempty _, by simpa using hx⟩ = x := by + simp [u, Finset.sup'_singleton] + calc x = u ⟨{x}, Finset.singleton_nonempty _, by simpa using hx⟩ := hmem.symm + _ ≤ w := hw.1 ⟨_, rfl⟩ + · intro c hc + apply hw.2 + rintro _ ⟨F, rfl⟩ + refine Finset.sup'_le F.2.1 id fun i hi => hc (F.2.2 ?_) + exact Finset.mem_coe.mpr hi + +/-! ### Characterisations of `ConditionallyCompleteLattice` -/ + +/-- On a lattice-ordered additive commutative group, a +`ConditionallyCompleteLattice` structure exists provided every increasing net +of positive elements that is bounded above has a least upper bound. The net is +indexed by a type in the same universe as the carrier. -/ +@[reducible] +noncomputable def conditionallyCompleteLatticeOfPosNet + (X : Type u) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (H : ∀ {ι : Type u} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X}, Monotone u → (∀ i, 0 ≤ u i) → + BddAbove (range u) → ∃ x, IsLUB (range u) x) : + ConditionallyCompleteLattice X := + conditionallyCompleteLatticeOfHasLUB + (exists_isLUB_of_pos_of_shift (P := fun _ => True) + (fun _ _ => trivial) + (fun _ hpos hne hbdd => exists_isLUB_pos_set_of_pos_net H hpos hne hbdd) + trivial) + +/-- On a lattice-ordered additive commutative group, a +`ConditionallyCompleteLattice` structure exists provided every non-empty +bounded above set of positive elements has a least upper bound. -/ +@[reducible] +noncomputable def conditionallyCompleteLatticeOfPosSet + (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (H : ∀ {S : Set X}, S ⊆ {x | 0 ≤ x} → S.Nonempty → BddAbove S → + ∃ x, IsLUB S x) : + ConditionallyCompleteLattice X := + conditionallyCompleteLatticeOfHasLUB + (exists_isLUB_of_pos_of_shift (P := fun _ => True) + (fun _ _ => trivial) (fun _ hpos hne hbdd => H hpos hne hbdd) trivial) + +/-! ### Sigma conditional completeness -/ + +/-- A lattice is **sigma conditionally complete** when non-empty bounded +countable subsets admit suprema and infima: for every countable set `s`, +`sSup s` is the least upper bound if `s` is bounded above, and `sInf s` is +the greatest lower bound if `s` is bounded below. -/ +class SigmaConditionallyCompleteLattice (X : Type*) + extends Lattice X, SupSet X, InfSet X where + le_csSup : ∀ (s : Set X) (a : X), s.Countable → BddAbove s → a ∈ s → a ≤ sSup s + csSup_le : ∀ (s : Set X) (a : X), s.Countable → s.Nonempty → + a ∈ upperBounds s → sSup s ≤ a + csInf_le : ∀ (s : Set X) (a : X), s.Countable → BddBelow s → a ∈ s → sInf s ≤ a + le_csInf : ∀ (s : Set X) (a : X), s.Countable → s.Nonempty → + a ∈ lowerBounds s → a ≤ sInf s + +/-- Every conditionally complete lattice is sigma conditionally complete. -/ +instance (priority := 100) ConditionallyCompleteLattice.toSigmaConditionallyCompleteLattice + {X : Type*} [ConditionallyCompleteLattice X] : + SigmaConditionallyCompleteLattice X where + le_csSup _ _ _ hb ha := _root_.le_csSup hb ha + csSup_le _ _ _ hne ha := _root_.csSup_le hne ha + csInf_le _ _ _ hb ha := _root_.csInf_le hb ha + le_csInf _ _ _ hne ha := _root_.le_csInf hne ha + +/-! ### Characterisations of sigma conditional completeness -/ + +/-- Build a `SigmaConditionallyCompleteLattice` structure from a hypothesis +that every countable non-empty bounded above set has a least upper bound. -/ +@[reducible] +noncomputable def sigmaConditionallyCompleteLatticeOfHasCountableLUB + {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (hLUB : ∀ {S : Set X}, S.Countable → S.Nonempty → BddAbove S → + ∃ x, IsLUB S x) : + SigmaConditionallyCompleteLattice X := by + classical + have hne_neg : ∀ (s : Set X), s.Nonempty → (-s).Nonempty := fun s hne => by + obtain ⟨x, hx⟩ := hne + exact ⟨-x, Set.mem_neg.mpr (by rwa [neg_neg])⟩ + have hcount_neg : ∀ (s : Set X), s.Countable → (-s).Countable := fun s hc => by + have : -s = (fun x => -x) '' s := by ext; simp [Set.mem_neg] + rw [this]; exact hc.image _ + let sSup_fn : Set X → X := fun S => + if h : S.Countable ∧ S.Nonempty ∧ BddAbove S + then Classical.choose (hLUB h.1 h.2.1 h.2.2) else 0 + exact + { (inferInstance : Lattice X) with + sSup := sSup_fn + sInf := fun S => -sSup_fn (-S) + le_csSup := fun s a hc hb ha => by + have hne : s.Nonempty := ⟨a, ha⟩ + change a ≤ sSup_fn s + simp only [sSup_fn, + dite_eq_left (⟨hc, hne, hb⟩ : s.Countable ∧ s.Nonempty ∧ BddAbove s)] + exact (Classical.choose_spec (hLUB hc hne hb)).1 ha + csSup_le := fun s a hc hne ha => by + have hb : BddAbove s := ⟨a, ha⟩ + change sSup_fn s ≤ a + simp only [sSup_fn, + dite_eq_left (⟨hc, hne, hb⟩ : s.Countable ∧ s.Nonempty ∧ BddAbove s)] + exact (Classical.choose_spec (hLUB hc hne hb)).2 ha + csInf_le := fun s a hc hb ha => by + change -sSup_fn (-s) ≤ a + have hc' : (-s).Countable := hcount_neg s hc + have hne' : (-s).Nonempty := hne_neg s ⟨a, ha⟩ + have hbdd' : BddAbove (-s) := bddAbove_neg.mpr hb + simp only [sSup_fn, + dite_eq_left (⟨hc', hne', hbdd'⟩ : (-s).Countable ∧ (-s).Nonempty ∧ BddAbove (-s))] + rw [neg_le] + exact (Classical.choose_spec (hLUB hc' hne' hbdd')).1 + (Set.mem_neg.mpr (by rwa [neg_neg])) + le_csInf := fun s a hc hne ha => by + change a ≤ -sSup_fn (-s) + have hb : BddBelow s := ⟨a, ha⟩ + have hc' : (-s).Countable := hcount_neg s hc + have hne' : (-s).Nonempty := hne_neg s hne + have hbdd' : BddAbove (-s) := bddAbove_neg.mpr hb + simp only [sSup_fn, + dite_eq_left (⟨hc', hne', hbdd'⟩ : (-s).Countable ∧ (-s).Nonempty ∧ BddAbove (-s))] + rw [le_neg] + apply (Classical.choose_spec (hLUB hc' hne' hbdd')).2 + intro y hy + rw [Set.mem_neg] at hy + rw [le_neg] + exact ha hy } + +/-- From the existence of a least upper bound for every increasing bounded +above sequence of positive elements, deduce the same conclusion for every +non-empty bounded above countable set of positive elements. The sequence is +obtained by enumerating the set and taking finite suprema. -/ +lemma exists_isLUB_pos_countable_set_of_pos_seq + {X : Type*} [AddCommGroup X] [Lattice X] + (H : ∀ {u : ℕ → X}, Monotone u → (∀ n, 0 ≤ u n) → + BddAbove (range u) → ∃ x, IsLUB (range u) x) + {S : Set X} (hpos : S ⊆ {x | 0 ≤ x}) (hcount : S.Countable) + (hne : S.Nonempty) (hbdd : BddAbove S) : ∃ x, IsLUB S x := by + classical + obtain ⟨g, hg⟩ := hcount.exists_eq_range hne + let u : ℕ → X := fun n => + (Finset.range (n + 1)).sup' Finset.nonempty_range_add_one g + have hg_pos : ∀ i, 0 ≤ g i := fun i => hpos (hg ▸ mem_range_self i) + have hg_le : ∀ i c, c ∈ upperBounds S → g i ≤ c := fun i c hc => + hc (hg ▸ mem_range_self i) + have hmono : Monotone u := fun m n hmn => + Finset.sup'_mono g (Finset.range_subset_range.mpr (Nat.succ_le_succ hmn)) + Finset.nonempty_range_add_one + have hu_pos : ∀ n, 0 ≤ u n := fun n => by + calc (0 : X) ≤ g 0 := hg_pos 0 + _ ≤ u n := Finset.le_sup' g (Finset.mem_range.mpr (Nat.succ_pos n)) + have hu_bdd : BddAbove (range u) := by + obtain ⟨c, hc⟩ := hbdd + refine ⟨c, ?_⟩ + rintro _ ⟨n, rfl⟩ + exact Finset.sup'_le _ _ fun i _ => hg_le i c hc + obtain ⟨w, hw⟩ := H hmono hu_pos hu_bdd + refine ⟨w, ?_, ?_⟩ + · intro x hx + rw [hg] at hx + obtain ⟨n, rfl⟩ := hx + exact (Finset.le_sup' g (Finset.self_mem_range_succ n)).trans (hw.1 ⟨n, rfl⟩) + · intro c hc + apply hw.2 + rintro _ ⟨n, rfl⟩ + exact Finset.sup'_le _ _ fun i _ => hg_le i c hc + +/-- On a lattice-ordered additive commutative group, a `SigmaConditionallyCompleteLattice` structure +exists provided every increasing bounded above sequence of positive elements +has a least upper bound. -/ +@[reducible] +noncomputable def sigmaConditionallyCompleteLatticeOfPosSeq + (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (H : ∀ {u : ℕ → X}, Monotone u → (∀ n, 0 ≤ u n) → + BddAbove (range u) → ∃ x, IsLUB (range u) x) : + SigmaConditionallyCompleteLattice X := + sigmaConditionallyCompleteLatticeOfHasCountableLUB + (exists_isLUB_of_pos_of_shift (P := Set.Countable) + (fun f hc => hc.image f) + (fun hc hpos hne hbdd => + exists_isLUB_pos_countable_set_of_pos_seq H hpos hc hne hbdd)) + +/-- On a lattice-ordered additive commutative group, a `SigmaConditionallyCompleteLattice` structure +exists provided every non-empty bounded above countable set of positive +elements has a least upper bound. -/ +@[reducible] +noncomputable def sigmaConditionallyCompleteLatticeOfPosCountableSet + (X : Type*) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (H : ∀ {S : Set X}, S ⊆ {x | 0 ≤ x} → S.Countable → S.Nonempty → + BddAbove S → ∃ x, IsLUB S x) : + SigmaConditionallyCompleteLattice X := + sigmaConditionallyCompleteLatticeOfHasCountableLUB + (exists_isLUB_of_pos_of_shift (P := Set.Countable) + (fun f hc => hc.image f) + (fun hc hpos hne hbdd => H hpos hc hne hbdd)) + +/-! ### Archimedean property -/ + +/-- Every sigma conditionally complete lattice-ordered group is Archimedean +in the vector-lattice sense. -/ +theorem IsVLArchimedean_of_sigmaConditionallyCompleteLattice + {X : Type*} [SigmaConditionallyCompleteLattice X] [AddCommGroup X] + [IsOrderedAddMonoid X] : IsVLArchimedean X := by + apply isVLArchimedean_of_eq_zero_of_nonneg_of_forall_nsmul_le + intro x y hx hn + set S : Set X := Set.range (fun n : ℕ => n • x) with hS_def + have hS_count : S.Countable := Set.countable_range _ + have hS_ne : S.Nonempty := ⟨0 • x, 0, rfl⟩ + have hS_bdd : BddAbove S := ⟨y, by rintro _ ⟨n, rfl⟩; exact hn n⟩ + set u := sSup S with hu_def + have hm : ∀ m : ℕ, m • x ≤ u := fun m => + SigmaConditionallyCompleteLattice.le_csSup S _ hS_count hS_bdd ⟨m, rfl⟩ + have hub : u - x ∈ upperBounds S := by + rintro _ ⟨m, rfl⟩ + rw [le_sub_iff_add_le, ← succ_nsmul] + exact hm (m + 1) + have hu' : u ≤ u - x := + SigmaConditionallyCompleteLattice.csSup_le S _ hS_count hS_ne hub + have hx_nonpos : x ≤ 0 := by + have h : u + x ≤ u := le_sub_iff_add_le.mp hu' + have h' : u + x ≤ u + 0 := by rwa [add_zero] + exact (add_le_add_iff_left u).mp h' + exact le_antisymm hx_nonpos hx diff --git a/LeanPool/OrderClosures/BanLat/OrderContinuous/Basic.lean b/LeanPool/OrderClosures/BanLat/OrderContinuous/Basic.lean new file mode 100644 index 0000000000..43c31f5760 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/OrderContinuous/Basic.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Convergences.Order +public import LeanPool.OrderClosures.BanLat.Normed +public import LeanPool.OrderClosures.BanLat.OrderComplete + + +/-! +# Order continuous norms — basic theory + +A normed vector lattice has an **order continuous norm** when every decreasing +net of non-negative elements with infimum zero converges to zero in norm. The +sequential version is **σ-order continuity**; equivalently, every increasing +positive sequence whose supremum exists converges in norm to that supremum. + +This file introduces the σ- and full classes `IsSigmaOrderContinuousNorm` and +`IsOrderContinuousNorm`, records that the latter is stronger, proves the +equivalent sequential characterisations of σ-order continuity, and shows that +an order continuous Banach lattice is order complete. +-/ + +@[expose] public section + +universe u + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +/-! ### Definitions -/ + +/-- A normed vector lattice has a **σ-order continuous norm** if every antitone +sequence of non-negative elements with greatest lower bound zero converges to +zero in norm. -/ +class IsSigmaOrderContinuousNorm (X : Type*) [NormedAddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [NormedVectorLattice X] : Prop where + tendsto_of_antitone_isGLB_zero : + ∀ {u : ℕ → X}, Antitone u → (∀ n, 0 ≤ u n) → + IsGLB (Set.range u) 0 → + Filter.Tendsto u Filter.atTop (nhds 0) + +/-- A normed vector lattice has an **order continuous norm** if every antitone +net of non-negative elements (over a non-empty directed index set) with +greatest lower bound zero converges to zero in norm. + +The index set `ι` is constrained to live in the same universe as `X`; in +applications (e.g. indexing by a subset of `X`) this is the case. -/ +class IsOrderContinuousNorm (X : Type u) [NormedAddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [NormedVectorLattice X] : Prop where + tendsto_of_antitone_isGLB_zero : + ∀ {ι : Type u} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + {u : ι → X}, Antitone u → (∀ i, 0 ≤ u i) → + IsGLB (Set.range u) 0 → + Filter.Tendsto u Filter.atTop (nhds 0) + +/-- In a normed vector lattice with order-continuous norm, order convergence of a net implies +norm convergence. -/ +theorem tendsto_of_orderConvergesTo_of_isOrderContinuousNorm + {X : Type u} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] [IsOrderContinuousNorm X] + {ι : Type u} [Preorder ι] + {x : ι → X} {a : X} (hx : OrderConvergesTo x a) : + Filter.Tendsto x Filter.atTop (nhds a) := by + rcases hx with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnn, hrglb, hrevent⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + have hr_tend : Filter.Tendsto r Filter.atTop (nhds 0) := + IsOrderContinuousNorm.tendsto_of_antitone_isGLB_zero hranti hrnn hrglb + rw [Metric.tendsto_nhds] + intro ε hε + have hr_event := Metric.tendsto_nhds.mp hr_tend ε hε + rcases hr_event.exists with ⟨k, hk⟩ + refine (hrevent k).mono fun i hi => ?_ + have hnorm_le : ‖x i - a‖ ≤ ‖r k‖ := by + rw [← norm_abs_eq_norm (x i - a)] + exact norm_le_norm_of_abs_le_abs (by + rw [abs_abs, abs_of_nonneg (hrnn k)] + exact hi) + calc + dist (x i) a = ‖x i - a‖ := dist_eq_norm _ _ + _ ≤ ‖r k‖ := hnorm_le + _ = dist (r k) 0 := by rw [dist_eq_norm, sub_zero] + _ < ε := hk + +/-- An order continuous norm is in particular σ-order continuous. -/ +instance (priority := 100) + IsOrderContinuousNorm.toIsSigmaOrderContinuousNorm {X : Type u} + [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] [h : IsOrderContinuousNorm X] : + IsSigmaOrderContinuousNorm X := by + refine ⟨fun {u} hanti hnn hglb => ?_⟩ + -- Transfer the ℕ-indexed sequence to the universe of `X` via `ULift`. + let u' : ULift.{u, 0} ℕ → X := fun n => u n.down + have hu'_anti : Antitone u' := fun a b h => hanti (by exact h) + have hu'_nn : ∀ i, 0 ≤ u' i := fun i => hnn i.down + have hu'_glb : IsGLB (Set.range u') 0 := by + have hrange : Set.range u' = Set.range u := by + ext z; constructor + · rintro ⟨⟨n⟩, rfl⟩; exact ⟨n, rfl⟩ + · rintro ⟨n, rfl⟩; exact ⟨⟨n⟩, rfl⟩ + rw [hrange]; exact hglb + have htend := h.tendsto_of_antitone_isGLB_zero hu'_anti hu'_nn hu'_glb + -- Pull back to ℕ: the map `n ↦ ⟨n⟩ : ℕ → ULift ℕ` is order isomorphic. + have : Filter.Tendsto (fun n : ℕ => u' ⟨n⟩) Filter.atTop (nhds 0) := by + refine htend.comp ?_ + refine Filter.tendsto_atTop.mpr fun ⟨b⟩ => ?_ + exact Filter.eventually_atTop.mpr ⟨b, fun n hn => hn⟩ + exact this + +namespace IsSigmaOrderContinuousNorm + +variable [NormedVectorLattice X] [IsSigmaOrderContinuousNorm X] + +/-! ### Equivalent sequential characterisations -/ + +/-- An increasing sequence with a least upper bound converges in norm to +that bound. -/ +theorem tendsto_of_monotone_isLUB {u : ℕ → X} {x : X} + (hmono : Monotone u) (hlub : IsLUB (Set.range u) x) : + Filter.Tendsto u Filter.atTop (nhds x) := by + -- Define v n = x - u n, which is antitone, nonneg, with GLB 0 + have hv_anti : Antitone (fun n => x - u n) := + fun _ _ h => sub_le_sub_left (hmono h) x + have hv_nn : ∀ n, 0 ≤ x - u n := + fun n => sub_nonneg.mpr (hlub.1 ⟨n, rfl⟩) + have hv_glb : IsGLB (Set.range (fun n => x - u n)) 0 := by + constructor + · rintro _ ⟨n, rfl⟩; exact hv_nn n + · intro w hw + have hlb : ∀ y ∈ Set.range u, y ≤ x - w := by + rintro _ ⟨n, rfl⟩ + exact le_sub_comm.mp (hw ⟨n, rfl⟩) + have h := hlub.2 hlb + rwa [le_sub_iff_add_le, add_comm, add_le_iff_nonpos_left] at h + have htv := tendsto_of_antitone_isGLB_zero hv_anti hv_nn hv_glb + convert htv.const_sub x using 1 + · ext n; abel + · abel_nf + +/-- An antitone sequence with a greatest lower bound converges in norm to +that bound. -/ +theorem tendsto_of_antitone_isGLB {u : ℕ → X} {x : X} + (hanti : Antitone u) (hglb : IsGLB (Set.range u) x) : + Filter.Tendsto u Filter.atTop (nhds x) := by + have hv_anti : Antitone (fun n => u n - x) := + fun _ _ h => sub_le_sub_right (hanti h) x + have hv_nn : ∀ n, 0 ≤ u n - x := + fun n => sub_nonneg.mpr (hglb.1 ⟨n, rfl⟩) + have hv_glb : IsGLB (Set.range (fun n => u n - x)) 0 := by + constructor + · rintro _ ⟨n, rfl⟩; exact hv_nn n + · intro w hw + have hlb : ∀ y ∈ Set.range u, w + x ≤ y := by + rintro _ ⟨n, rfl⟩ + exact add_le_of_le_sub_right (hw ⟨n, rfl⟩) + have h := hglb.2 hlb + rwa [add_le_iff_nonpos_left] at h + have htv := tendsto_of_antitone_isGLB_zero hv_anti hv_nn hv_glb + convert htv.add tendsto_const_nhds using 1 + · ext n; abel + · abel_nf + +/-- The norm is σ-order continuous: if `|u n - x| ≤ v n` for an antitone +sequence `v` with `inf v = 0`, then `u n → x` in norm. -/ +theorem tendsto_of_abs_sub_le_antitone {u : ℕ → X} {v : ℕ → X} {x : X} + (hv_anti : Antitone v) (hv_nn : ∀ n, 0 ≤ v n) + (hv_glb : IsGLB (Set.range v) 0) + (hle : ∀ n, |u n - x| ≤ v n) : + Filter.Tendsto u Filter.atTop (nhds x) := by + have hv_tend := tendsto_of_antitone_isGLB_zero hv_anti hv_nn hv_glb + have hnorm_le : ∀ n, ‖u n - x‖ ≤ ‖v n‖ := fun n => + norm_le_norm_of_abs_le_abs ((hle n).trans (le_abs_self _)) + have hv_norm := hv_tend.norm + rw [norm_zero] at hv_norm + have h0 := squeeze_zero_norm hnorm_le hv_norm + exact tendsto_sub_nhds_zero_iff.mp h0 + +/-- The norm itself is an order continuous function on positive elements: +if `u n` converges in order to `x`, then `‖u n‖ → ‖x‖`. -/ +theorem tendsto_norm_of_monotone_isLUB {u : ℕ → X} {x : X} + (hmono : Monotone u) + (hlub : IsLUB (Set.range u) x) : + Filter.Tendsto (fun n => ‖u n‖) Filter.atTop (nhds ‖x‖) := + (tendsto_of_monotone_isLUB hmono hlub).norm + +end IsSigmaOrderContinuousNorm + +/-! ### Order continuity implies order completeness -/ + +namespace BanachLattice + +variable [BanachLattice X] + +omit [BanachLattice X] in +/-- Archimedean "gap" lemma. In an Archimedean +vector lattice, any common lower bound of all differences `w - a` with `w` an +upper bound of a nonempty bounded-above set `A` and `a ∈ A` must be `≤ 0`. -/ +lemma le_zero_of_lb_upperBounds_sub [IsVLArchimedean X] + {A : Set X} (hne : A.Nonempty) (hbd : BddAbove A) {ε : X} + (hε : ∀ w ∈ upperBounds A, ∀ a ∈ A, ε ≤ w - a) : ε ≤ 0 := by + have key : ∀ n : ℕ, ∀ w ∈ upperBounds A, ∀ a ∈ A, n • ε ≤ w - a := by + intro n + induction n with + | zero => + intro w hw a ha + simpa using sub_nonneg.mpr (hw ha) + | succ k ih => + intro w hw a ha + have hub : w - k • ε ∈ upperBounds A := fun s hs => + le_sub_comm.mp (ih w hw s hs) + have hstep : ε ≤ (w - k • ε) - a := hε _ hub a ha + have h : k • ε + ε ≤ k • ε + ((w - k • ε) - a) := + add_le_add (le_refl (k • ε)) hstep + have h3 : k • ε + ((w - k • ε) - a) = w - a := by abel + rw [h3] at h + simpa [succ_nsmul] using h + obtain ⟨w₀, hw₀⟩ := hbd + obtain ⟨a₀, ha₀⟩ := hne + exact isVLArchimedean_iff_le_zero_of_forall_nsmul_le.mp inferInstance + (fun n => key n w₀ hw₀ a₀ ha₀) + +/-- An order continuous Banach lattice is order complete. -/ +@[reducible] +noncomputable def conditionallyCompleteLatticeOfIsOrderContinuousNorm + [IsOrderContinuousNorm X] : + ConditionallyCompleteLattice X := by + haveI : Nonempty X := ⟨0⟩ + refine conditionallyCompleteLatticeOfPosSet X + (fun {S} _ hSne hSbdd => ?_) + obtain ⟨w₀, hw₀⟩ := hSbdd + obtain ⟨s₀, hs₀⟩ := hSne + classical + -- Index: (upper bound of S) ×ᵒᵈ (nonempty finite subset of S), ordered so + -- that upper bounds decrease and finite subsets increase. + let Ub : Type _ := {w : X // w ∈ upperBounds S} + let Fn : Type _ := {F : Finset X // (↑F : Set X) ⊆ S ∧ F.Nonempty} + let I : Type _ := Ubᵒᵈ × Fn + have : Nonempty Ub := ⟨⟨w₀, hw₀⟩⟩ + have : Nonempty Fn := ⟨⟨{s₀}, by + refine ⟨?_, Finset.singleton_nonempty s₀⟩ + intro x hx; rcases Finset.mem_singleton.mp hx with rfl; exact hs₀⟩⟩ + have : Nonempty I := instNonemptyProd + have : IsDirected Fn (· ≤ ·) := by + refine ⟨fun F G => ?_⟩ + refine ⟨⟨F.val ∪ G.val, ?_, F.prop.2.mono Finset.subset_union_left⟩, + Finset.subset_union_left, Finset.subset_union_right⟩ + intro x hx + rcases Finset.mem_union.mp hx with h | h + · exact F.prop.1 h + · exact G.prop.1 h + have : IsDirected Ubᵒᵈ (· ≤ ·) := by + refine ⟨fun a b => ?_⟩ + refine ⟨OrderDual.toDual ⟨(OrderDual.ofDual a).val ⊓ (OrderDual.ofDual b).val, + fun s hs => le_inf ((OrderDual.ofDual a).prop hs) ((OrderDual.ofDual b).prop hs)⟩, + ?_, ?_⟩ + · change (_ : Ub) ≤ OrderDual.ofDual a + exact inf_le_left + · change (_ : Ub) ≤ OrderDual.ofDual b + exact inf_le_right + have : IsDirected I (· ≤ ·) := by + refine ⟨fun p q => ?_⟩ + obtain ⟨c, hac, hbc⟩ := (‹IsDirected Ubᵒᵈ (· ≤ ·)›).directed p.1 q.1 + obtain ⟨d, had, hbd⟩ := (‹IsDirected Fn (· ≤ ·)›).directed p.2 q.2 + exact ⟨(c, d), ⟨hac, had⟩, ⟨hbc, hbd⟩⟩ + -- The antitone net `z` on `I`: `z (w, F) = w - sup' F`. + let z : I → X := fun p => + (OrderDual.ofDual p.1).val - p.2.val.sup' p.2.prop.2 id + have hFle : ∀ p : I, p.2.val.sup' p.2.prop.2 id ≤ (OrderDual.ofDual p.1).val := + fun p => Finset.sup'_le _ _ fun x hx => + (OrderDual.ofDual p.1).prop (p.2.prop.1 hx) + have hz_nn : ∀ p : I, 0 ≤ z p := fun p => sub_nonneg.mpr (hFle p) + have hz_anti : Antitone z := by + intro p q hpq + have h1 : (OrderDual.ofDual q.1).val ≤ (OrderDual.ofDual p.1).val := hpq.1 + have h2 : p.2.val ⊆ q.2.val := hpq.2 + have hsup : p.2.val.sup' p.2.prop.2 id ≤ q.2.val.sup' q.2.prop.2 id := + Finset.sup'_mono _ h2 p.2.prop.2 + exact sub_le_sub h1 hsup + have hz_glb : IsGLB (Set.range z) 0 := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨p, rfl⟩; exact hz_nn p + · intro ε hε + -- `ε` is a lower bound of range `z`; apply the Archimedean gap lemma. + refine le_zero_of_lb_upperBounds_sub ⟨s₀, hs₀⟩ ⟨w₀, hw₀⟩ ?_ + intro w hw a ha + -- Form the element `(w, {a})` of `I` and evaluate `z`. + let p : I := (OrderDual.toDual ⟨w, hw⟩, + ⟨{a}, by + refine ⟨?_, Finset.singleton_nonempty a⟩ + intro x hx; rcases Finset.mem_singleton.mp hx with rfl; exact ha⟩) + have hzp : z p = w - a := by + simp [z, p, Finset.sup'_singleton] + have := hε ⟨p, rfl⟩ + rw [hzp] at this + exact this + -- Apply OCN to get `z → 0` in norm. + have htend : Filter.Tendsto z Filter.atTop (nhds 0) := + IsOrderContinuousNorm.tendsto_of_antitone_isGLB_zero hz_anti hz_nn hz_glb + -- Extract from `htend` that the monotone net `u_F = sup' F` is norm-Cauchy. + let u : Fn → X := fun F => F.val.sup' F.prop.2 id + have hu_mono : Monotone u := fun F G h => Finset.sup'_mono _ h F.prop.2 + have hu_cauchy : Cauchy (Filter.map u Filter.atTop) := by + rw [Metric.cauchy_iff] + refine ⟨Filter.map_neBot, fun ε hε => ?_⟩ + rw [Metric.tendsto_nhds] at htend + have hev := htend (ε/2) (by linarith) + rw [Filter.eventually_atTop] at hev + obtain ⟨p₀, hp₀⟩ := hev + refine ⟨u '' {F | p₀.2 ≤ F}, ?_, ?_⟩ + · exact Filter.image_mem_map (Filter.mem_atTop p₀.2) + · rintro _ ⟨F, hF, rfl⟩ _ ⟨G, hG, rfl⟩ + have hpF : p₀ ≤ (p₀.1, F) := ⟨le_refl _, hF⟩ + have hpG : p₀ ≤ (p₀.1, G) := ⟨le_refl _, hG⟩ + have h1 : dist (z (p₀.1, F)) 0 < ε/2 := hp₀ _ hpF + have h2 : dist (z (p₀.1, G)) 0 < ε/2 := hp₀ _ hpG + rw [dist_zero_right] at h1 h2 + have hzF : z (p₀.1, F) = (OrderDual.ofDual p₀.1).val - u F := rfl + have hzG : z (p₀.1, G) = (OrderDual.ofDual p₀.1).val - u G := rfl + rw [dist_eq_norm] + have heq : u F - u G = z (p₀.1, G) - z (p₀.1, F) := by + rw [hzF, hzG]; abel + rw [heq] + have : ‖z (p₀.1, G) - z (p₀.1, F)‖ ≤ ‖z (p₀.1, G)‖ + ‖z (p₀.1, F)‖ := by + rw [sub_eq_add_neg] + exact (norm_add_le _ _).trans_eq (by rw [norm_neg]) + linarith + -- By Banach completeness, `u` has a limit `x`. + obtain ⟨x, hx_tend⟩ := CompleteSpace.complete hu_cauchy + -- `x` is the LUB of range of `u`, which equals LUB of `S`. + have hx_lub : IsLUB (Set.range u) x := + isLUB_of_tendsto_atTop hu_mono hx_tend + refine ⟨x, ?_, ?_⟩ + · -- `x` is an upper bound of `S` + intro s hs + have hprop : (↑({s} : Finset X) : Set X) ⊆ S ∧ ({s} : Finset X).Nonempty := by + refine ⟨?_, Finset.singleton_nonempty s⟩ + intro y hy; rcases Finset.mem_singleton.mp hy with rfl; exact hs + have huFs : u ⟨{s}, hprop⟩ = s := by + change ({s} : Finset X).sup' (Finset.singleton_nonempty s) id = s + rw [Finset.sup'_singleton]; rfl + rw [← huFs] + exact hx_lub.1 ⟨⟨{s}, hprop⟩, rfl⟩ + · -- `x` is the least upper bound + intro y hy + refine hx_lub.2 ?_ + rintro _ ⟨F, rfl⟩ + exact Finset.sup'_le _ _ (fun s hs => hy (F.prop.1 hs)) + +end BanachLattice diff --git a/LeanPool/OrderClosures/BanLat/OrderContinuous/MeyerNieberg.lean b/LeanPool/OrderClosures/BanLat/OrderContinuous/MeyerNieberg.lean new file mode 100644 index 0000000000..75167aa935 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/OrderContinuous/MeyerNieberg.lean @@ -0,0 +1,909 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.OrderContinuous.Nakano +public import LeanPool.OrderClosures.BanLat.Disjoint + + +/-! +# Meyer-Nieberg theorem + +A Banach lattice has an order continuous norm iff every order-bounded +pairwise disjoint sequence converges to zero in norm. As a corollary, in +an order continuous Banach lattice every order-bounded set of pairwise +disjoint non-zero elements is at most countable. +-/ + +@[expose] public section + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +section Disjointification + +variable {E : Type*} [AddCommGroup E] [Lattice E] [IsOrderedAddMonoid E] + [VectorLattice E] + +/-- A sequence is `k`-disjoint if every `k`-element finite subfamily has +infimum of moduli equal to zero. -/ +private def IsKDisjointSeq (k : ℕ) (u : ℕ → E) : Prop := + ∀ s : Finset ℕ, s.card = k → ∀ hs : s.Nonempty, + s.inf' hs (fun n => |u n|) = 0 + +omit [Lattice E] [IsOrderedAddMonoid E] [VectorLattice E] in +private lemma sum_range_increments (u : ℕ → E) : + ∀ n : ℕ, (∑ i ∈ Finset.range n, (u (i + 1) - u i)) = u n - u 0 := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [Finset.sum_range_succ] + rw [ih] + abel + +omit [VectorLattice E] in +private lemma finset_sum_increments_le_bound {x : E} {u : ℕ → E} + (h0 : ∀ n, 0 ≤ u n) (hmono : Monotone u) (hle : ∀ n, u n ≤ x) + (s : Finset ℕ) : + (∑ i ∈ s, (u (i + 1) - u i)) ≤ x := by + classical + let N : ℕ := s.sup id + 1 + have hsub : s ⊆ Finset.range N := by + intro i hi + have hi_le : i ≤ s.sup id := by + simpa using (Finset.le_sup (f := id) hi) + simpa [N] using Nat.lt_succ_of_le hi_le + have hnonneg : ∀ i ∈ Finset.range N, i ∉ s → 0 ≤ u (i + 1) - u i := by + intro i _ _ + exact sub_nonneg.mpr (hmono (Nat.le_succ i)) + calc + (∑ i ∈ s, (u (i + 1) - u i)) ≤ + ∑ i ∈ Finset.range N, (u (i + 1) - u i) := + Finset.sum_le_sum_of_subset_of_nonneg hsub hnonneg + _ = u N - u 0 := sum_range_increments u N + _ ≤ u N := sub_le_self _ (h0 0) + _ ≤ x := hle N + +omit [VectorLattice E] in +private lemma isVLDisjoint_finset_sum_local {ι : Type*} {s : Finset ι} {x : E} + {f : ι → E} (h : ∀ i ∈ s, IsVLDisjoint x (f i)) : + IsVLDisjoint x (∑ i ∈ s, f i) := by + classical + induction s using Finset.induction_on with + | empty => simpa using isVLDisjoint_zero_right x + | insert a s ha ih => + rw [Finset.sum_insert ha] + refine (h a (Finset.mem_insert_self a s)).add_right ?_ + exact ih (fun i hi => h i (Finset.mem_insert_of_mem hi)) + +omit [VectorLattice E] in +private lemma sum_range_mono_of_nonneg {f : ℕ → E} (hf : ∀ n, 0 ≤ f n) : + Monotone fun n => ∑ i ∈ Finset.range n, f i := by + intro n m hnm + exact Finset.sum_le_sum_of_subset_of_nonneg ((Finset.range_subset_range).2 hnm) + (fun i _ _ => hf i) + +/-- First disjointification step: replace the increments of an increasing +bounded sequence by a `(k + 1)`-disjoint sequence up to an error +`1 / (k + 1)` times the bound. -/ +private theorem disjointification_step_one {x : E} {u : ℕ → E} + (h0 : ∀ n, 0 ≤ u n) (hmono : Monotone u) (hle : ∀ n, u n ≤ x) (k : ℕ) : + ∃ v : ℕ → E, + IsKDisjointSeq (k + 1) v ∧ + (∀ n, v n ∈ Set.Icc (0 : E) x) ∧ + ∀ n, v n ≤ u (n + 1) - u n ∧ + u (n + 1) - u n ≤ v n + ((1 : ℝ) / ((k : ℝ) + 1)) • x := by + classical + let c : ℝ := (1 : ℝ) / ((k : ℝ) + 1) + let d : ℕ → E := fun n => u (n + 1) - u n + let v : ℕ → E := fun n => (d n - c • x)⁺ + have hx0 : 0 ≤ x := (h0 0).trans (hle 0) + have hc0 : 0 ≤ c := by + dsimp [c] + positivity + have hcx0 : 0 ≤ c • x := smul_nonneg hc0 hx0 + have hd0 : ∀ n, 0 ≤ d n := fun n => sub_nonneg.mpr (hmono (Nat.le_succ n)) + refine ⟨v, ?_, ?_, ?_⟩ + · intro s hcard hs + have hv_nonneg : ∀ n, 0 ≤ v n := fun n => posPart_nonneg _ + have hv_abs : ∀ n, |v n| = v n := fun n => abs_of_nonneg (hv_nonneg n) + rw [show s.inf' hs (fun n => |v n|) = s.inf' hs v by + apply Finset.inf'_congr hs rfl + intro n _ + exact hv_abs n] + let a : E := s.inf' hs v + let r : ℕ → E := fun n => (d n - c • x)⁻ + have ha0 : 0 ≤ a := Finset.le_inf' hs v (fun n _ => hv_nonneg n) + have ha_le : ∀ n ∈ s, a ≤ v n := fun n hn => Finset.inf'_le v hn + have hr_nonneg : ∀ n, 0 ≤ r n := fun n => negPart_nonneg _ + have hdisj_each : ∀ n ∈ s, IsVLDisjoint a (r n) := by + intro n hn + have hbase : IsVLDisjoint (v n) (r n) := by + simpa only [v, r] using isVLDisjoint_posPart_negPart (d n - c • x) + refine hbase.mono_left ?_ + rw [abs_of_nonneg ha0, abs_of_nonneg (hv_nonneg n)] + exact ha_le n hn + have hdisj_sum : IsVLDisjoint a (∑ n ∈ s, r n) := + isVLDisjoint_finset_sum_local hdisj_each + have hmeet_zero : a ⊓ (∑ n ∈ s, r n) = 0 := + inf_eq_zero_of_isVLDisjoint ha0 (Finset.sum_nonneg (fun n _ => hr_nonneg n)) + hdisj_sum + have hsumd_le : (∑ n ∈ s, d n) ≤ x := + finset_sum_increments_le_bound h0 hmono hle s + have hxd_nonneg : 0 ≤ x - ∑ n ∈ s, d n := sub_nonneg.mpr hsumd_le + have hsumv_ge : a ≤ ∑ n ∈ s, v n := by + rcases hs with ⟨n, hn⟩ + exact (ha_le n hn).trans (Finset.single_le_sum (fun i _ => hv_nonneg i) hn) + have hr_eq : ∀ n, r n = c • x - d n + v n := by + intro n + have hdec : v n - r n = d n - c • x := by + simp [v, r, posPart_sub_negPart] + have h1 : v n = d n - c • x + r n := sub_eq_iff_eq_add.mp hdec + rw [h1] + abel + have hsumr_eq : (∑ n ∈ s, r n) = (x - ∑ n ∈ s, d n) + ∑ n ∈ s, v n := by + calc + (∑ n ∈ s, r n) = ∑ n ∈ s, (c • x - d n + v n) := by + refine Finset.sum_congr rfl ?_ + intro n _ + exact hr_eq n + _ = (∑ n ∈ s, c • x) - (∑ n ∈ s, d n) + ∑ n ∈ s, v n := by + simp [Finset.sum_add_distrib, Finset.sum_sub_distrib] + _ = x - (∑ n ∈ s, d n) + ∑ n ∈ s, v n := by + have hcard_real : (s.card : ℝ) = (k : ℝ) + 1 := by + norm_num [hcard] + rw [Finset.sum_const] + rw [← Nat.cast_smul_eq_nsmul ℝ s.card (c • x)] + rw [smul_smul, hcard_real] + have hcoef : ((k : ℝ) + 1) * c = 1 := by + dsimp [c] + field_simp [show (k : ℝ) + 1 ≠ 0 by positivity] + rw [hcoef, one_smul] + have ha_le_sumr : a ≤ ∑ n ∈ s, r n := by + rw [hsumr_eq] + exact hsumv_ge.trans (le_add_of_nonneg_left hxd_nonneg) + have ha_eq_zero : a = 0 := by + have : a ⊓ (∑ n ∈ s, r n) = a := inf_eq_left.mpr ha_le_sumr + exact this ▸ hmeet_zero + exact ha_eq_zero + · intro n + constructor + · exact posPart_nonneg _ + · have hv_le_d : v n ≤ d n := by + refine sup_le ?_ (hd0 n) + exact sub_le_self _ hcx0 + exact hv_le_d.trans ((sub_le_self _ (h0 n)).trans (hle (n + 1))) + · intro n + constructor + · have hv_le_d : v n ≤ d n := by + refine sup_le ?_ (hd0 n) + exact sub_le_self _ hcx0 + simpa [d, v] using hv_le_d + · have : d n ≤ v n + c • x := sub_le_iff_le_add.mp (le_posPart (d n - c • x)) + simpa [d, v, c] using this + +/-- Second disjointification step: split a `(k + 1)`-disjoint sequence into +one disjoint sequence and a `k`-disjoint remainder, up to an arbitrarily small +positive multiple of the bound. -/ +private theorem disjointification_step_two {x : E} {u : ℕ → E} {k : ℕ} + (hk : 1 < k) (hu_interval : ∀ n, u n ∈ Set.Icc (0 : E) x) + (hu_disj : IsKDisjointSeq (k + 1) u) {eps : ℝ} + (heps0 : 0 < eps) (heps1 : eps < 1) : + ∃ w y : ℕ → E, + IsKDisjointSeq k w ∧ + Pairwise (fun n m => IsVLDisjoint (y n) (y m)) ∧ + (∀ n, w n ∈ Set.Icc (0 : E) x) ∧ + (∀ n, y n ∈ Set.Icc (0 : E) x) ∧ + ∀ n, y n + w n ≤ u n ∧ u n ≤ y n + w n + eps • x := by + classical + have _hk_pos : 0 < k := by omega + let pref : ℕ → E := fun n => ∑ i ∈ Finset.range n, u i + let inv : ℝ := eps⁻¹ + let y : ℕ → E := fun n => (u n - inv • pref n - eps • x)⁺ + let w : ℕ → E := fun n => u n ⊓ inv • pref n + have hx0 : 0 ≤ x := (hu_interval 0).1.trans (hu_interval 0).2 + have hu0 : ∀ n, 0 ≤ u n := fun n => (hu_interval n).1 + have hux : ∀ n, u n ≤ x := fun n => (hu_interval n).2 + have heps_nonneg : 0 ≤ eps := le_of_lt heps0 + have heps_ne : eps ≠ 0 := ne_of_gt heps0 + have hinv0 : 0 ≤ inv := by + dsimp [inv] + exact inv_nonneg.mpr heps_nonneg + have hpref0 : ∀ n, 0 ≤ pref n := fun n => Finset.sum_nonneg (fun i _ => hu0 i) + have hpref_mono : Monotone pref := by + dsimp [pref] + exact sum_range_mono_of_nonneg hu0 + have hinvpref0 : ∀ n, 0 ≤ inv • pref n := fun n => smul_nonneg hinv0 (hpref0 n) + have hepsx0 : 0 ≤ eps • x := smul_nonneg heps_nonneg hx0 + have hy0 : ∀ n, 0 ≤ y n := fun n => posPart_nonneg _ + refine ⟨w, y, ?_, ?_, ?_, ?_, ?_⟩ + · intro s hcard hs + have hw_nonneg : ∀ n, 0 ≤ w n := fun n => le_inf (hu0 n) (hinvpref0 n) + rw [show s.inf' hs (fun n => |w n|) = s.inf' hs w by + apply Finset.inf'_congr hs rfl + intro n _ + exact abs_of_nonneg (hw_nonneg n)] + let a : E := s.inf' hs w + let b : E := s.inf' hs u + let n0 : ℕ := s.min' hs + have hn0_mem : n0 ∈ s := by + simpa [n0] using Finset.min'_mem s hs + have ha0 : 0 ≤ a := Finset.le_inf' hs w (fun n _ => hw_nonneg n) + have hb0 : 0 ≤ b := Finset.le_inf' hs u (fun n _ => hu0 n) + have ha_le_w : ∀ n ∈ s, a ≤ w n := fun n hn => Finset.inf'_le w hn + have ha_le_b : a ≤ b := by + refine Finset.le_inf' hs u ?_ + intro n hn + exact (ha_le_w n hn).trans inf_le_left + have ha_le_pref : a ≤ inv • pref n0 := (ha_le_w n0 hn0_mem).trans inf_le_right + have hb_disj_u_before : ∀ i ∈ Finset.range n0, IsVLDisjoint b (u i) := by + intro i hi + have hi_lt : i < n0 := by simpa using hi + have hi_not : i ∉ s := by + intro his + exact (Nat.not_lt_of_ge (Finset.min'_le s i his)) hi_lt + have hcard_insert : (insert i s).card = k + 1 := by + simp [hi_not, hcard] + have hne_insert : (insert i s : Finset ℕ).Nonempty := + ⟨i, Finset.mem_insert_self i s⟩ + have hinf := hu_disj (insert i s) hcard_insert hne_insert + have hinf_eq : (insert i s).inf' hne_insert (fun j => |u j|) = u i ⊓ b := by + rw [Finset.inf'_insert hs] + rw [abs_of_nonneg (hu0 i)] + congr 1 + apply Finset.inf'_congr hs rfl + intro j _ + exact abs_of_nonneg (hu0 j) + have hbi_zero : b ⊓ u i = 0 := by + rw [hinf_eq] at hinf + rwa [inf_comm] at hinf + exact isVLDisjoint_of_inf_eq_zero hbi_zero + have hb_disj_pref : IsVLDisjoint b (pref n0) := by + simpa [pref] using isVLDisjoint_finset_sum_local hb_disj_u_before + have hb_disj_invpref : IsVLDisjoint b (inv • pref n0) := hb_disj_pref.smul_right inv + have ha_disj_invpref : IsVLDisjoint a (inv • pref n0) := by + refine hb_disj_invpref.mono_left ?_ + rw [abs_of_nonneg ha0, abs_of_nonneg hb0] + exact ha_le_b + have ha_inf_zero : a ⊓ inv • pref n0 = 0 := + inf_eq_zero_of_isVLDisjoint ha0 (hinvpref0 n0) ha_disj_invpref + have ha_eq_zero : a = 0 := by + have : a ⊓ inv • pref n0 = a := inf_eq_left.mpr ha_le_pref + exact this ▸ ha_inf_zero + exact ha_eq_zero + · have hdisj_gt : ∀ {n m : ℕ}, n < m → IsVLDisjoint (y m) (y n) := by + intro n m hnm + have hnm_succ : n + 1 ≤ m := Nat.succ_le_iff.mpr hnm + have hpref_succ : pref (n + 1) = pref n + u n := by + simp [pref, Finset.sum_range_succ] + have hpref_nu_le_m : pref n + u n ≤ pref m := by + rw [← hpref_succ] + exact hpref_mono hnm_succ + have hscale_y : eps • y m = (eps • u m - pref m - (eps * eps) • x)⁺ := by + rw [← posPart_smul_nonneg heps_nonneg] + congr 1 + rw [smul_sub, smul_sub, smul_smul, smul_smul] + rw [show eps * inv = 1 by dsimp [inv]; exact mul_inv_cancel₀ heps_ne, one_smul] + have harg_le₁ : eps • u m - pref m - (eps * eps) • x ≤ + eps • x - pref n - u n := by + calc + eps • u m - pref m - (eps * eps) • x ≤ eps • x - (pref n + u n) - 0 := by + gcongr + · exact hux m + · exact smul_nonneg (mul_nonneg heps_nonneg heps_nonneg) hx0 + _ = eps • x - pref n - u n := by abel + have hle₁ : eps • y m ≤ (eps • x - pref n - u n)⁺ := by + rw [hscale_y] + exact posPart_mono harg_le₁ + have hneg_pref_le : -pref n ≤ inv • pref n := by + calc + -pref n = (-1 : ℝ) • pref n := by simp + _ ≤ inv • pref n := smul_le_smul_of_nonneg_right + (by linarith : (-1 : ℝ) ≤ inv) (hpref0 n) + have harg_le₂ : eps • x - pref n - u n ≤ inv • pref n + eps • x - u n := by + calc + eps • x - pref n - u n = eps • x + -pref n - u n := by abel + _ ≤ eps • x + inv • pref n - u n := by + gcongr + _ = inv • pref n + eps • x - u n := by abel + have hle₂ : eps • y m ≤ (inv • pref n + eps • x - u n)⁺ := + hle₁.trans (posPart_mono harg_le₂) + have hneg_eq : (inv • pref n + eps • x - u n)⁺ = + (u n - inv • pref n - eps • x)⁻ := by + rw [negPart_def] + congr 1 + abel + have hbound : eps • y m ≤ (u n - inv • pref n - eps • x)⁻ := by + rwa [hneg_eq] at hle₂ + have hbase : IsVLDisjoint (u n - inv • pref n - eps • x)⁻ (y n) := by + exact isVLDisjoint_comm.mp (by + simpa only [y] using isVLDisjoint_posPart_negPart + (u n - inv • pref n - eps • x)) + have hscaled : IsVLDisjoint (eps • y m) (y n) := by + refine hbase.mono_left ?_ + rw [abs_of_nonneg (smul_nonneg heps_nonneg (hy0 m)), + abs_of_nonneg (negPart_nonneg (u n - inv • pref n - eps • x))] + exact hbound + have hres := hscaled.smul_left inv + simpa [inv, smul_smul, heps_ne] using hres + intro n m hnm + rcases Nat.lt_or_gt_of_ne hnm with hlt | hgt + · exact isVLDisjoint_comm.mp (hdisj_gt hlt) + · exact hdisj_gt hgt + · intro n + constructor + · exact le_inf (hu0 n) (hinvpref0 n) + · exact inf_le_left.trans (hux n) + · intro n + constructor + · exact hy0 n + · have hy_le_u : y n ≤ u n := by + refine sup_le ?_ (hu0 n) + exact (sub_le_self _ hepsx0).trans (sub_le_self _ (hinvpref0 n)) + exact hy_le_u.trans (hux n) + · intro n + let p : E := inv • pref n + let e : E := eps • x + have hp0 : 0 ≤ p := hinvpref0 n + have he0 : 0 ≤ e := hepsx0 + have hy_eq : y n = u n - u n ⊓ (p + e) := by + rw [sub_inf_eq_posPart] + simp [y, p, e] + abel_nf + have hdecomp : y n + u n ⊓ (p + e) = u n := by + rw [hy_eq] + abel + constructor + · calc + y n + w n ≤ y n + u n ⊓ (p + e) := by + gcongr + exact inf_le_inf_left (u n) (le_add_of_nonneg_right he0) + _ = u n := hdecomp + · have hinf_le : u n ⊓ (p + e) ≤ w n + e := by + calc + u n ⊓ (p + e) ≤ u n ⊓ p + u n ⊓ e := + inf_le_inf_add_inf_of_nonneg (u n) p e (hu0 n) hp0 he0 + _ ≤ w n + e := by + gcongr + exact inf_le_right + calc + u n = y n + u n ⊓ (p + e) := hdecomp.symm + _ ≤ y n + (w n + e) := by gcongr + _ = y n + w n + eps • x := by simp [e]; abel + +omit [IsOrderedAddMonoid E] [VectorLattice E] in +private lemma pairwise_of_isKDisjointSeq_two {u : ℕ → E} + (hu : IsKDisjointSeq 2 u) : + Pairwise fun n m => IsVLDisjoint (u n) (u m) := by + intro n m hnm + have hcard : ({n, m} : Finset ℕ).card = 2 := by simp [hnm] + have hne : ({n, m} : Finset ℕ).Nonempty := ⟨n, by simp⟩ + have hinf := hu ({n, m} : Finset ℕ) hcard hne + simpa [IsVLDisjoint, hnm, inf_comm] using hinf + +private theorem split_isKDisjointSeq {x : E} : + ∀ {k : ℕ} {u : ℕ → E}, 0 < k → + (∀ n, u n ∈ Set.Icc (0 : E) x) → IsKDisjointSeq (k + 1) u → + ∀ {eps : ℝ}, 0 < eps → eps < 1 → + ∃ y : Fin k → ℕ → E, + (∀ i, Pairwise fun n m => IsVLDisjoint (y i n) (y i m)) ∧ + (∀ i n, y i n ∈ Set.Icc (0 : E) x) ∧ + ∀ n, (∑ i : Fin k, y i n) ≤ u n ∧ + u n ≤ (∑ i : Fin k, y i n) + eps • x := by + intro k + induction k with + | zero => + intro u hk + exact (Nat.not_lt_zero _ hk).elim + | succ k ih => + intro u hk hu_interval hu_disj eps heps0 heps1 + rcases k with _ | k + · refine ⟨fun _ => u, ?_, ?_, ?_⟩ + · intro i + exact pairwise_of_isKDisjointSeq_two hu_disj + · intro i n + exact hu_interval n + · intro n + have hx : 0 ≤ x := (hu_interval n).1.trans (hu_interval n).2 + have hepsx : 0 ≤ eps • x := smul_nonneg (le_of_lt heps0) hx + simp [hepsx] + · have hk_two : 1 < k.succ.succ := by omega + have heps_half_pos : 0 < eps / 2 := by + positivity + have heps_half_lt : eps / 2 < 1 := by linarith + obtain ⟨w, y0, hw_disj, hy0_disj, hw_interval, hy0_interval, hwy⟩ := + disjointification_step_two hk_two hu_interval hu_disj heps_half_pos heps_half_lt + obtain ⟨yr, hyr_disj, hyr_interval, hyr_approx⟩ := + ih (by omega) hw_interval hw_disj heps_half_pos heps_half_lt + let y : Fin (k.succ.succ) → ℕ → E := Fin.cons y0 yr + refine ⟨y, ?_, ?_, ?_⟩ + · intro i + induction i using Fin.cases with + | zero => + exact hy0_disj + | succ i => + exact hyr_disj i + · intro i n + induction i using Fin.cases with + | zero => + exact hy0_interval n + | succ i => + exact hyr_interval i n + · intro n + have hsum : (∑ i : Fin (k.succ.succ), y i n) = y0 n + ∑ i : Fin k.succ, yr i n := by + simp [y, Fin.sum_univ_succ] + constructor + · rw [hsum] + calc + y0 n + ∑ i : Fin k.succ, yr i n ≤ y0 n + w n := + add_le_add_right (hyr_approx n).1 (y0 n) + _ ≤ u n := (hwy n).1 + · have hupper := (hwy n).2 + have hrec := (hyr_approx n).2 + rw [hsum] + have hscalar : (eps / 2) • x + (eps / 2) • x = eps • x := by + rw [← add_smul] + ring_nf + calc + u n ≤ y0 n + w n + (eps / 2) • x := hupper + _ ≤ y0 n + ((∑ i : Fin k.succ, yr i n) + (eps / 2) • x) + + (eps / 2) • x := by + gcongr + _ = y0 n + ∑ i : Fin k.succ, yr i n + + ((eps / 2) • x + (eps / 2) • x) := by abel + _ = y0 n + ∑ i : Fin k.succ, yr i n + eps • x := by + rw [hscalar] + +/-- Disjointification of increments of an increasing order-bounded sequence. -/ +theorem exists_disjoint_sequences_approx_of_monotone_le {x : E} {u : ℕ → E} + (h0 : ∀ n, 0 ≤ u n) (hmono : Monotone u) (hle : ∀ n, u n ≤ x) + {k : ℕ} (hk : 0 < k) : + ∃ y : Fin k → ℕ → E, + (∀ i, Pairwise fun n m => IsVLDisjoint (y i n) (y i m)) ∧ + (∀ i n, y i n ∈ Set.Icc (0 : E) x) ∧ + ∀ n, (∑ i : Fin k, y i n) ≤ u (n + 1) - u n ∧ + u (n + 1) - u n ≤ + (∑ i : Fin k, y i n) + ((2 : ℝ) / ((k : ℝ) + 3)) • x := by + rcases k with _ | k + · exact (Nat.not_lt_zero _ hk).elim + rcases k with _ | k + · obtain ⟨v, hv_disj, hv_interval, hv_approx⟩ := + disjointification_step_one h0 hmono hle 1 + refine ⟨fun _ => v, ?_, ?_, ?_⟩ + · intro i + exact pairwise_of_isKDisjointSeq_two hv_disj + · intro i n + exact hv_interval n + · intro n + have hcoef : + ((1 : ℝ) / ((1 : ℝ) + 1)) = ((2 : ℝ) / ((1 : ℝ) + 3)) := by + norm_num + simpa [hcoef] using hv_approx n + · let K : ℕ := k.succ.succ + obtain ⟨v, hv_disj, hv_interval, hv_approx⟩ := + disjointification_step_one h0 hmono hle K + let eps : ℝ := (2 : ℝ) / ((K : ℝ) + 3) - (1 : ℝ) / ((K : ℝ) + 1) + have heps0 : 0 < eps := by + dsimp [eps] + have hlt : + (1 : ℝ) / ((K : ℝ) + 1) < (2 : ℝ) / ((K : ℝ) + 3) := by + rw [div_lt_div_iff₀ (show 0 < (K : ℝ) + 1 by positivity) + (show 0 < (K : ℝ) + 3 by positivity)] + have hK : (1 : ℝ) < K := by exact_mod_cast (by omega : 1 < K) + nlinarith + linarith + have heps1 : eps < 1 := by + dsimp [eps] + have hpos : 0 < (1 : ℝ) / ((K : ℝ) + 1) := by positivity + have hlt : (2 : ℝ) / ((K : ℝ) + 3) < 1 := by + rw [div_lt_one₀ (show 0 < (K : ℝ) + 3 by positivity)] + have hKnonneg : (0 : ℝ) ≤ K := by positivity + nlinarith + linarith + obtain ⟨y, hy_disj, hy_interval, hy_approx⟩ := + split_isKDisjointSeq (x := x) (k := K) (u := v) (by omega) hv_interval hv_disj + heps0 heps1 + refine ⟨y, hy_disj, hy_interval, ?_⟩ + intro n + constructor + · exact (hy_approx n).1.trans (hv_approx n).1 + · calc + u (n + 1) - u n ≤ v n + ((1 : ℝ) / ((K : ℝ) + 1)) • x := (hv_approx n).2 + _ ≤ ((∑ i : Fin K, y i n) + eps • x) + + ((1 : ℝ) / ((K : ℝ) + 1)) • x := + add_le_add_left (hy_approx n).2 _ + _ = (∑ i : Fin K, y i n) + ((2 : ℝ) / ((K : ℝ) + 3)) • x := by + have hscalar : eps • x + ((1 : ℝ) / ((K : ℝ) + 1)) • x = + ((2 : ℝ) / ((K : ℝ) + 3)) • x := by + rw [← add_smul] + congr 1 + simp [eps] + calc + (∑ i : Fin K, y i n) + eps • x + + ((1 : ℝ) / ((K : ℝ) + 1)) • x = + (∑ i : Fin K, y i n) + + (eps • x + ((1 : ℝ) / ((K : ℝ) + 1)) • x) := by abel + _ = (∑ i : Fin K, y i n) + ((2 : ℝ) / ((K : ℝ) + 3)) • x := by + rw [hscalar] + +end Disjointification + +section NormCriterion + +variable {E : Type*} [NormedAddCommGroup E] [Lattice E] [IsOrderedAddMonoid E] + [NormedVectorLattice E] + +omit [NormedVectorLattice E] in +/-- One direction of the interval criterion: Cauchy partial sums force disjoint +sequences in the interval to converge to zero in norm. -/ +private theorem disjoint_tendsto_zero_of_monotone_le_cauchySeq {x : E} + (hx : 0 ≤ x) + (hcauchy : ∀ {u : ℕ → E}, (∀ n, 0 ≤ u n) → Monotone u → + (∀ n, u n ≤ x) → CauchySeq u) + {u : ℕ → E} (hu_interval : ∀ n, u n ∈ Set.Icc (0 : E) x) + (hu_disj : Pairwise fun n m => IsVLDisjoint (u n) (u m)) : + Filter.Tendsto u Filter.atTop (nhds 0) := by + let v : ℕ → E := fun m => ∑ k ∈ Finset.range m, u k + have hv_nn : ∀ m, 0 ≤ v m := fun m => + Finset.sum_nonneg (fun k _ => (hu_interval k).1) + have hv_mono : Monotone v := by + refine monotone_nat_of_le_succ (fun n => ?_) + simp only [v, Finset.sum_range_succ] + exact le_add_of_nonneg_right (hu_interval n).1 + have key : ∀ m k, m ≤ k → v m ⊓ u k = 0 := by + intro m + induction m with + | zero => + intro k _ + simpa [v] using (inf_eq_left.mpr (hu_interval k).1 : (0 : E) ⊓ u k = 0) + | succ n ih => + intro k hk + have h1 : v n ⊓ u k = 0 := ih k (by omega) + have h2 : u n ⊓ u k = 0 := + inf_eq_zero_of_isVLDisjoint (hu_interval n).1 (hu_interval k).1 + (hu_disj (by omega)) + have heq : v (n + 1) = v n + u n := by + simp [v, Finset.sum_range_succ] + refine le_antisymm ?_ + (le_inf (by rw [heq]; exact add_nonneg (hv_nn n) (hu_interval n).1) + (hu_interval k).1) + rw [heq, inf_comm] + calc u k ⊓ (v n + u n) + ≤ u k ⊓ v n + u k ⊓ u n := + inf_le_inf_add_inf_of_nonneg (x := u k) (v n) (u n) + (hu_interval k).1 (hv_nn n) (hu_interval n).1 + _ = 0 := by rw [inf_comm, h1, inf_comm, h2, add_zero] + have hv_le : ∀ m, v m ≤ x := by + intro m + induction m with + | zero => simpa [v] using hx + | succ n ih => + have hdisj : IsVLDisjoint (v n) (u n) := + isVLDisjoint_of_inf_eq_zero (key n n (le_refl n)) + have heq : v (n + 1) = v n + u n := by + simp [v, Finset.sum_range_succ] + have hsup : v n + u n = v n ⊔ u n := + add_eq_sup_of_isVLDisjoint_of_nonneg (hv_nn n) (hu_interval n).1 hdisj + rw [heq, hsup] + exact sup_le ih (hu_interval n).2 + have hv_cauchy : CauchySeq v := hcauchy hv_nn hv_mono hv_le + rw [Metric.cauchySeq_iff] at hv_cauchy + rw [Metric.tendsto_nhds] + intro ε hε + obtain ⟨N, hN⟩ := hv_cauchy ε hε + refine Filter.eventually_atTop.mpr ⟨N, fun m hm => ?_⟩ + have hdist : dist (v (m + 1)) (v m) < ε := hN (m + 1) (by omega) m hm + have heq : v (m + 1) - v m = u m := by + simp [v, Finset.sum_range_succ] + rw [dist_zero_right] + rw [dist_eq_norm, heq] at hdist + exact hdist + +/-- The converse direction of the interval criterion: disjoint null sequences +in the interval force every increasing sequence bounded by the endpoint to be +norm-Cauchy. -/ +private theorem monotone_le_cauchySeq_of_disjoint_tendsto_zero {x : E} + (hx : 0 ≤ x) + (hdisj : ∀ {u : ℕ → E}, (∀ n, u n ∈ Set.Icc (0 : E) x) → + Pairwise (fun n m => IsVLDisjoint (u n) (u m)) → + Filter.Tendsto u Filter.atTop (nhds 0)) + {u : ℕ → E} (h0 : ∀ n, 0 ≤ u n) (hmono : Monotone u) + (hle : ∀ n, u n ≤ x) : + CauchySeq u := by + rw [Metric.cauchySeq_iff'] + intro ε hε + by_contra hbad + push Not at hbad + let next : ℕ → ℕ := fun N => (hbad N).choose + have hnext : ∀ N, N ≤ next N ∧ ε ≤ dist (u (next N)) (u N) := + fun N => (hbad N).choose_spec + let φ : ℕ → ℕ := fun n => Nat.rec 0 (fun _ N => next N) n + have hφ_succ : ∀ n, φ n < φ (n + 1) := by + intro n + have hleφ : φ n ≤ φ (n + 1) := (hnext (φ n)).1 + refine lt_of_le_of_ne hleφ ?_ + intro heq + have hdist : ε ≤ dist (u (φ (n + 1))) (u (φ n)) := by + simpa [φ] using (hnext (φ n)).2 + rw [heq, dist_self] at hdist + linarith + have hφ_strict : StrictMono φ := strictMono_nat_of_lt_succ hφ_succ + let z : ℕ → E := fun n => u (φ n) + have hz0 : ∀ n, 0 ≤ z n := fun n => h0 (φ n) + have hz_mono : Monotone z := fun m n hmn => hmono (hφ_strict.monotone hmn) + have hz_le : ∀ n, z n ≤ x := fun n => hle (φ n) + have hcoeff_tend : + Filter.Tendsto (fun k : ℕ => ‖((2 : ℝ) / ((k : ℝ) + 3)) • x‖) + Filter.atTop (nhds 0) := by + have hone : + Filter.Tendsto (fun k : ℕ => (1 : ℝ) / ((k : ℝ) + 3)) Filter.atTop + (nhds 0) := by + have hbase : + Filter.Tendsto (fun k : ℕ => (1 : ℝ) / ((k : ℝ) + 1)) Filter.atTop + (nhds 0) := tendsto_one_div_add_atTop_nhds_zero_nat + convert hbase.comp (Filter.tendsto_add_atTop_nat 2) using 1 + ext k + simp + ring + have htwo : + Filter.Tendsto (fun k : ℕ => (2 : ℝ) / ((k : ℝ) + 3)) Filter.atTop + (nhds 0) := by + simpa [div_eq_mul_inv] using (tendsto_const_nhds.mul hone) + have hvec : + Filter.Tendsto (fun k : ℕ => ((2 : ℝ) / ((k : ℝ) + 3)) • x) + Filter.atTop (nhds ((0 : ℝ) • x)) := + htwo.smul (show Filter.Tendsto (fun _ : ℕ => x) Filter.atTop (nhds x) from + tendsto_const_nhds) + simpa using hvec.norm + have herr_event := Metric.tendsto_nhds.mp hcoeff_tend (ε / 2) (by linarith) + rw [Filter.eventually_atTop] at herr_event + obtain ⟨K, hK⟩ := herr_event + let k : ℕ := K + 1 + have hkpos : 0 < k := by simp [k] + have herr : ‖((2 : ℝ) / ((k : ℝ) + 3)) • x‖ < ε / 2 := by + have hk := hK k (by simp [k]) + rw [Real.dist_eq] at hk + simpa [abs_of_nonneg (norm_nonneg _)] using hk + obtain ⟨y, hy_disj, hy_interval, hy_approx⟩ := + exists_disjoint_sequences_approx_of_monotone_le hz0 hz_mono hz_le hkpos + have hy_tend : ∀ i : Fin k, Filter.Tendsto (y i) Filter.atTop (nhds 0) := + fun i => hdisj (hy_interval i) (hy_disj i) + have hsum_tend : + Filter.Tendsto (fun n => ∑ i : Fin k, y i n) Filter.atTop (nhds 0) := by + have hsum : + Filter.Tendsto (fun n => ∑ i : Fin k, y i n) Filter.atTop + (nhds (∑ i : Fin k, (0 : E))) := + tendsto_finsetSum Finset.univ (fun i _ => hy_tend i) + simpa using hsum + have hsum_event := Metric.tendsto_nhds.mp hsum_tend (ε / 2) (by linarith) + rw [Filter.eventually_atTop] at hsum_event + obtain ⟨N, hN⟩ := hsum_event + have hsmall_sum : dist (∑ i : Fin k, y i N) 0 < ε / 2 := hN N (le_refl N) + rw [dist_zero_right] at hsmall_sum + have hlower : ε ≤ ‖z (N + 1) - z N‖ := by + have hdist : ε ≤ dist (u (φ (N + 1))) (u (φ N)) := by + simpa [φ] using (hnext (φ N)).2 + rwa [dist_eq_norm] at hdist + have hd_nonneg : 0 ≤ z (N + 1) - z N := + sub_nonneg.mpr (hz_mono (Nat.le_succ N)) + have hsum_nonneg : 0 ≤ ∑ i : Fin k, y i N := + Finset.sum_nonneg fun i _ => (hy_interval i N).1 + have hcoeff_nonneg : 0 ≤ (2 : ℝ) / ((k : ℝ) + 3) := by positivity + have hrhs_nonneg : 0 ≤ + (∑ i : Fin k, y i N) + ((2 : ℝ) / ((k : ℝ) + 3)) • x := + add_nonneg hsum_nonneg (smul_nonneg hcoeff_nonneg hx) + have hnorm_le : + ‖z (N + 1) - z N‖ ≤ + ‖(∑ i : Fin k, y i N) + ((2 : ℝ) / ((k : ℝ) + 3)) • x‖ := by + rw [← norm_abs_eq_norm (z (N + 1) - z N), + ← norm_abs_eq_norm ((∑ i : Fin k, y i N) + ((2 : ℝ) / ((k : ℝ) + 3)) • x)] + exact norm_le_norm_of_abs_le_abs (by + simpa [abs_of_nonneg hd_nonneg, abs_of_nonneg hrhs_nonneg] using (hy_approx N).2) + have hnorm_add : + ‖(∑ i : Fin k, y i N) + ((2 : ℝ) / ((k : ℝ) + 3)) • x‖ < + ε := by + have htri : + ‖(∑ i : Fin k, y i N) + ((2 : ℝ) / ((k : ℝ) + 3)) • x‖ ≤ + ‖∑ i : Fin k, y i N‖ + ‖((2 : ℝ) / ((k : ℝ) + 3)) • x‖ := + norm_add_le _ _ + linarith + linarith + +/-- For a normed vector lattice, increasing sequences bounded by `x` are +norm-Cauchy iff disjoint sequences in `[0, x]` converge to zero in norm. -/ +theorem monotone_le_cauchySeq_iff_disjoint_tendsto_zero {x : E} (hx : 0 ≤ x) : + (∀ {u : ℕ → E}, (∀ n, 0 ≤ u n) → Monotone u → (∀ n, u n ≤ x) → + CauchySeq u) ↔ + (∀ {u : ℕ → E}, (∀ n, u n ∈ Set.Icc (0 : E) x) → + Pairwise (fun n m => IsVLDisjoint (u n) (u m)) → + Filter.Tendsto u Filter.atTop (nhds 0)) := by + exact ⟨disjoint_tendsto_zero_of_monotone_le_cauchySeq hx, + monotone_le_cauchySeq_of_disjoint_tendsto_zero hx⟩ + +end NormCriterion + +namespace BanachLattice + +variable [BanachLattice X] + +/-- In an order continuous Banach lattice, every order-bounded pairwise +disjoint sequence converges to zero in norm. -/ +theorem disjoint_bddAbove_tendsto_zero [IsOrderContinuousNorm X] + {u : ℕ → X} (hd : Pairwise fun i j => IsVLDisjoint (u i) (u j)) + (hbd : BddAbove (Set.range fun n => |u n|)) : + Filter.Tendsto u Filter.atTop (nhds 0) := by + classical + obtain ⟨w, hw⟩ := hbd + -- Partial sums of `|u_k|`. + let v : ℕ → X := fun m => ∑ k ∈ Finset.range m, |u k| + have hv_nn : ∀ m, 0 ≤ v m := fun m => + Finset.sum_nonneg (fun _ _ => abs_nonneg _) + have hv_mono : Monotone v := by + refine monotone_nat_of_le_succ (fun n => ?_) + simp only [v, Finset.sum_range_succ] + exact le_add_of_nonneg_right (abs_nonneg _) + -- Partial sums are disjoint from later terms (by induction). + have key : ∀ m k, m ≤ k → v m ⊓ |u k| = 0 := by + intro m + induction m with + | zero => + intro k _ + simp [v] + | succ n ih => + intro k hk + have h1 : v n ⊓ |u k| = 0 := ih k (by omega) + have h2 : |u n| ⊓ |u k| = 0 := hd (by omega) + have heq : v (n + 1) = v n + |u n| := by + simp [v, Finset.sum_range_succ] + refine le_antisymm ?_ + (le_inf (by rw [heq]; exact add_nonneg (hv_nn n) (abs_nonneg _)) + (abs_nonneg _)) + rw [heq, inf_comm] + calc |u k| ⊓ (v n + |u n|) + ≤ |u k| ⊓ v n + |u k| ⊓ |u n| := + inf_le_inf_add_inf_of_nonneg (x := |u k|) (v n) (|u n|) + (abs_nonneg _) (hv_nn n) (abs_nonneg _) + _ = 0 := by rw [inf_comm, h1, inf_comm, h2, add_zero] + -- Partial sums are bounded by `w`. + have hv_le : ∀ m, v m ≤ w := by + intro m + induction m with + | zero => simpa [v] using (abs_nonneg (u 0)).trans (hw ⟨0, rfl⟩) + | succ n ih => + have hdisj : v n ⊓ |u n| = 0 := key n n (le_refl n) + have heq : v (n + 1) = v n + |u n| := by + simp [v, Finset.sum_range_succ] + have hsup : v n + |u n| = v n ⊔ |u n| := by + have := inf_add_sup (v n) (|u n|) + rw [hdisj, zero_add] at this + exact this.symm + rw [heq, hsup] + exact sup_le ih (hw ⟨n, rfl⟩) + -- Use Nakano to get `v` converges in norm. + obtain ⟨_, _, hv_tend⟩ := + tendsto_of_monotone_bddAbove hv_mono ⟨w, by rintro _ ⟨m, rfl⟩; exact hv_le m⟩ + have hv_cauchy : CauchySeq v := hv_tend.cauchySeq + rw [Metric.cauchySeq_iff] at hv_cauchy + rw [Metric.tendsto_nhds] + intro ε hε + obtain ⟨N, hN⟩ := hv_cauchy ε hε + refine Filter.eventually_atTop.mpr ⟨N, fun m hm => ?_⟩ + have hdist : dist (v (m + 1)) (v m) < ε := hN (m + 1) (by omega) m hm + have heq : v (m + 1) - v m = |u m| := by + simp [v, Finset.sum_range_succ] + rw [dist_zero_right, ← norm_abs_eq_norm] + rw [dist_eq_norm, heq] at hdist + exact hdist + +/-- A Banach lattice whose order-bounded pairwise disjoint sequences all +converge to zero in norm has an order continuous norm. -/ +theorem isOrderContinuousNorm_of_disjoint_tendsto_zero + (h : ∀ {u : ℕ → X}, + Pairwise (fun i j => IsVLDisjoint (u i) (u j)) → + BddAbove (Set.range fun n => |u n|) → + Filter.Tendsto u Filter.atTop (nhds 0)) : + IsOrderContinuousNorm X := by + classical + have hmono_tend : + ∀ {u : ℕ → X}, Monotone u → BddAbove (Set.range u) → + ∃ x, IsLUB (Set.range u) x ∧ Filter.Tendsto u Filter.atTop (nhds x) := by + intro u hu_mono hu_bdd + obtain ⟨b, hb⟩ := hu_bdd + let v : ℕ → X := fun n => u n - u 0 + have hv0 : ∀ n, 0 ≤ v n := fun n => sub_nonneg.mpr (hu_mono (Nat.zero_le n)) + have hv_mono : Monotone v := fun m n hmn => sub_le_sub_right (hu_mono hmn) (u 0) + have hv_le : ∀ n, v n ≤ b - u 0 := fun n => sub_le_sub_right (hb ⟨n, rfl⟩) (u 0) + have hb0 : 0 ≤ b - u 0 := by simpa [v] using hv_le 0 + have hv_cauchy : CauchySeq v := by + refine (monotone_le_cauchySeq_iff_disjoint_tendsto_zero hb0).2 ?_ hv0 hv_mono hv_le + intro y hy_interval hy_disj + refine h hy_disj ?_ + exact ⟨b - u 0, by + rintro _ ⟨n, rfl⟩ + simpa [abs_of_nonneg (hy_interval n).1] using (hy_interval n).2⟩ + obtain ⟨a, hv_tend⟩ := cauchySeq_tendsto_of_complete hv_cauchy + have hu_tend : Filter.Tendsto u Filter.atTop (nhds (u 0 + a)) := by + have htend : Filter.Tendsto (fun n => u 0 + v n) Filter.atTop (nhds (u 0 + a)) := + tendsto_const_nhds.add hv_tend + convert htend using 1 + · ext n + simp [v, sub_eq_add_neg] + exact ⟨u 0 + a, isLUB_of_tendsto_atTop hu_mono hu_tend, hu_tend⟩ + let banach : BanachLattice X := inferInstance + let : SigmaConditionallyCompleteLattice X := + sigmaConditionallyCompleteLatticeOfMonoBddAboveTendsto hmono_tend + let orderedAdd : IsOrderedAddMonoid X := { + add_le_add_left := fun _ _ h _ => add_le_add_left h _ + } + let : IsOrderedAddMonoid X := orderedAdd + let sigmaOrderContinuous : IsSigmaOrderContinuousNorm X := + isSigmaOrderContinuousNorm_of_mono_bddAbove_tendsto hmono_tend + have : IsSigmaOrderContinuousNorm X := sigmaOrderContinuous + exact @isOrderContinuousNorm_of_isSigmaConditionallyCompleteLattice X + inferInstance inferInstance orderedAdd banach sigmaOrderContinuous + +/-- **Meyer-Nieberg theorem**: a Banach lattice has an order continuous norm +iff every order-bounded pairwise disjoint sequence converges to zero. -/ +theorem isOrderContinuousNorm_iff_disjoint_tendsto_zero : + IsOrderContinuousNorm X ↔ + (∀ {u : ℕ → X}, + Pairwise (fun i j => IsVLDisjoint (u i) (u j)) → + BddAbove (Set.range fun n => |u n|) → + Filter.Tendsto u Filter.atTop (nhds 0)) := + ⟨fun _ => disjoint_bddAbove_tendsto_zero, + fun h => isOrderContinuousNorm_of_disjoint_tendsto_zero (fun hd hbd => h hd hbd)⟩ + +/-- In an order continuous Banach lattice, any order-bounded set of pairwise +disjoint non-zero elements is at most countable. -/ +theorem countable_of_pairwise_disjoint_bddAbove [IsOrderContinuousNorm X] + {S : Set X} (h0 : ∀ x ∈ S, x ≠ 0) + (hd : S.Pairwise (fun x y => IsVLDisjoint x y)) + (hbd : BddAbove ((fun x => |x|) '' S)) : + S.Countable := by + -- Stratify by norm: `S_n = {x ∈ S | ‖x‖ ≥ 1/(n+1)}`. + classical + set T : ℕ → Set X := fun n => {x ∈ S | 1 / (n + 1 : ℝ) ≤ ‖x‖} with hT + -- Each stratum is finite. + have hTfin : ∀ n, (T n).Finite := by + intro n + by_contra hinf + rw [Set.not_finite] at hinf + let φ : ℕ ↪ ↥(T n) := hinf.natEmbedding + let y : ℕ → X := fun k => ((φ k : ↥(T n)) : X) + have hy_mem : ∀ k, y k ∈ S := fun k => (φ k).prop.1 + have hy_norm : ∀ k, 1 / (n + 1 : ℝ) ≤ ‖y k‖ := fun k => (φ k).prop.2 + have hy_inj : Function.Injective y := by + intro a b hab + have : φ a = φ b := Subtype.ext hab + exact φ.injective this + have hy_disj : Pairwise fun i j => IsVLDisjoint (y i) (y j) := by + intro i j hij + exact hd (hy_mem i) (hy_mem j) (fun h => hij (hy_inj h)) + have hy_bd : BddAbove (Set.range fun k => |y k|) := by + obtain ⟨u, hu⟩ := hbd + exact ⟨u, by rintro _ ⟨k, rfl⟩; exact hu ⟨y k, hy_mem k, rfl⟩⟩ + have htend : Filter.Tendsto y Filter.atTop (nhds 0) := + disjoint_bddAbove_tendsto_zero hy_disj hy_bd + rw [Metric.tendsto_nhds] at htend + have hpos : (0 : ℝ) < 1 / (n + 1 : ℝ) := by positivity + have hev := htend (1 / (n + 1 : ℝ)) hpos + rw [Filter.eventually_atTop] at hev + obtain ⟨K, hK⟩ := hev + have := hK K (le_refl K) + rw [dist_zero_right] at this + exact absurd (hy_norm K) (not_le.mpr this) + -- `S = ⋃ n, T n` because every nonzero element has positive norm. + have hcover : S ⊆ ⋃ n, T n := by + intro x hx + have hne : x ≠ 0 := h0 x hx + have hnorm : 0 < ‖x‖ := norm_pos_iff.mpr hne + obtain ⟨n, hn⟩ := exists_nat_one_div_lt hnorm + exact Set.mem_iUnion.mpr ⟨n, hx, le_of_lt hn⟩ + refine (Set.Countable.mono hcover ?_) + exact Set.countable_iUnion (fun n => (hTfin n).countable) + +end BanachLattice diff --git a/LeanPool/OrderClosures/BanLat/OrderContinuous/Nakano.lean b/LeanPool/OrderClosures/BanLat/OrderContinuous/Nakano.lean new file mode 100644 index 0000000000..040079d29d --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/OrderContinuous/Nakano.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.OrderContinuous.Basic + + +/-! +# Nakano's theorem + +For a Banach lattice the following are equivalent: + +* the norm is order continuous; +* the lattice is σ-conditionally complete and the norm is σ-order continuous; +* every increasing order-bounded sequence converges in norm. + +The equivalence is recorded through the corresponding implications between +order continuity, σ-conditional completeness, σ-order continuity, and monotone +norm convergence of bounded sequences. +-/ + +@[expose] public section + +namespace BanachLattice + +section Forward +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [BanachLattice X] + +/-- In an order continuous Banach lattice, every increasing order-bounded +sequence converges in norm to its supremum. -/ +theorem tendsto_of_monotone_bddAbove [IsOrderContinuousNorm X] + {u : ℕ → X} (hmono : Monotone u) (hbd : BddAbove (Set.range u)) : + ∃ x, IsLUB (Set.range u) x ∧ Filter.Tendsto u Filter.atTop (nhds x) := by + -- Order continuity implies order completeness, hence σ-order completeness; + -- σ-OC gives the LUB and σ-order continuity of the norm gives convergence. + let : ConditionallyCompleteLattice X := + conditionallyCompleteLatticeOfIsOrderContinuousNorm + have hx : IsLUB (Set.range u) (sSup (Set.range u)) := + ⟨fun _ ha => le_csSup hbd ha, + fun _ ha => csSup_le (Set.range_nonempty u) ha⟩ + exact ⟨_, hx, IsSigmaOrderContinuousNorm.tendsto_of_monotone_isLUB hmono hx⟩ + +end Forward + +section Sigma +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +/-- A lattice-ordered additive commutative group in which every increasing order-bounded sequence +converges in norm to a least upper bound is σ-conditionally complete. -/ +@[reducible] +noncomputable def sigmaConditionallyCompleteLatticeOfMonoBddAboveTendsto + (h : ∀ {u : ℕ → X}, Monotone u → BddAbove (Set.range u) → + ∃ x, IsLUB (Set.range u) x ∧ Filter.Tendsto u Filter.atTop (nhds x)) : + SigmaConditionallyCompleteLattice X := by + haveI : Nonempty X := ⟨0⟩ + refine sigmaConditionallyCompleteLatticeOfPosSeq X + (fun {u} hmono _ hbd => ?_) + obtain ⟨x, hx, _⟩ := h hmono hbd + exact ⟨x, hx⟩ + +variable [BanachLattice X] + +/-- A Banach lattice in which every increasing order-bounded sequence +converges in norm has a σ-order continuous norm. -/ +theorem isSigmaOrderContinuousNorm_of_mono_bddAbove_tendsto + (h : ∀ {u : ℕ → X}, Monotone u → BddAbove (Set.range u) → + ∃ x, IsLUB (Set.range u) x ∧ Filter.Tendsto u Filter.atTop (nhds x)) : + IsSigmaOrderContinuousNorm X := by + refine ⟨fun {u} hanti hnn hglb => ?_⟩ + -- Set v n = u 0 - u n; this is monotone, ≥ 0, bounded above by u 0. + have hv_mono : Monotone (fun n => u 0 - u n) := + fun n m hnm => sub_le_sub_left (hanti hnm) _ + have hv_bdd : BddAbove (Set.range fun n => u 0 - u n) := + ⟨u 0, by + rintro _ ⟨n, rfl⟩ + simpa using sub_nonneg.mpr (hnn n)⟩ + obtain ⟨x, hx_lub, hx_tend⟩ := h hv_mono hv_bdd + -- u 0 - x is a lower bound of range u, hence ≤ 0 since IsGLB (range u) 0. + have hub_le : u 0 - x ∈ lowerBounds (Set.range u) := by + rintro _ ⟨n, rfl⟩ + have h1 : u 0 - u n ≤ x := hx_lub.1 ⟨n, rfl⟩ + exact sub_le_comm.mp h1 + have h_le_zero : u 0 - x ≤ 0 := hglb.2 hub_le + -- u 0 - x ≥ 0 since x ≤ u 0. + have hxle : x ≤ u 0 := hx_lub.2 (by + rintro _ ⟨n, rfl⟩ + exact sub_le_self _ (hnn n)) + have h_ge_zero : (0 : X) ≤ u 0 - x := sub_nonneg.mpr hxle + have hux_eq : u 0 - x = 0 := le_antisymm h_le_zero h_ge_zero + -- Now u n = u 0 - (u 0 - u n) → u 0 - x = 0. + have htend : Filter.Tendsto (fun n => u 0 - (u 0 - u n)) Filter.atTop (nhds (u 0 - x)) := + tendsto_const_nhds.sub hx_tend + have hux : Filter.Tendsto u Filter.atTop (nhds (u 0 - x)) := by + convert htend using 1 + ext n; abel + rw [hux_eq] at hux + exact hux + +end Sigma + +section Backward +variable {X : Type*} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] [IsSigmaOrderContinuousNorm X] + +/-- In a σ-conditionally complete Banach lattice with σ-order continuous norm, +every antitone sequence bounded below converges in norm to its greatest lower +bound. -/ +private lemma tendsto_antitone_seq_of_bddBelow + {z : ℕ → X} (hanti : Antitone z) (hbdd : BddBelow (Set.range z)) : + ∃ v, IsGLB (Set.range z) v ∧ Filter.Tendsto z Filter.atTop (nhds v) := by + have hcount : (Set.range z).Countable := Set.countable_range _ + have hne : (Set.range z).Nonempty := Set.range_nonempty _ + have hglb : IsGLB (Set.range z) (sInf (Set.range z)) := + ⟨fun _ hy => SigmaConditionallyCompleteLattice.csInf_le _ _ hcount hbdd hy, + fun _ hy => SigmaConditionallyCompleteLattice.le_csInf _ _ hcount hne hy⟩ + exact ⟨_, hglb, IsSigmaOrderContinuousNorm.tendsto_of_antitone_isGLB hanti hglb⟩ + +private lemma cauchySeq_of_directed_dist {ι : Type*} [Preorder ι] + [IsDirected ι (· ≤ ·)] [Nonempty ι] {Y : Type*} [PseudoMetricSpace Y] + (y : ι → Y) + (h : ∀ ε > 0, ∃ α₀, ∀ α ≥ α₀, ∀ β ≥ α₀, dist (y α) (y β) < ε) : + CauchySeq y := by + rw [CauchySeq, Metric.cauchy_iff] + refine ⟨Filter.map_neBot, fun ε hε => ?_⟩ + obtain ⟨α₀, hα₀⟩ := h ε hε + refine ⟨y '' {α | α₀ ≤ α}, ?_, ?_⟩ + · exact Filter.image_mem_map (Filter.mem_atTop α₀) + · rintro _ ⟨α, hα, rfl⟩ _ ⟨β, hβ, rfl⟩ + exact hα₀ α hα β hβ + +/-- A Banach lattice that is σ-conditionally complete and has σ-order +continuous norm has an order continuous norm. -/ +theorem isOrderContinuousNorm_of_isSigmaConditionallyCompleteLattice : + IsOrderContinuousNorm X := by + classical + refine ⟨fun {ι} _ _ _ {y} hanti hnn hglb => ?_⟩ + -- Once `y` is Cauchy, completeness gives a limit, which is the order GLB. + suffices hcauchy : CauchySeq y by + obtain ⟨w, hw⟩ := cauchySeq_tendsto_of_complete hcauchy + have hwglb : IsGLB (Set.range y) w := isGLB_of_tendsto_atTop hanti hw + have hw_eq : w = 0 := hwglb.unique hglb + rw [hw_eq] at hw + exact hw + -- For Cauchy: assume not, derive a "bad gap" for every starting point. + refine cauchySeq_of_directed_dist y (fun ε hε => ?_) + by_contra hcon + push Not at hcon + -- For every α₀, ∃ α₀ ≤ α ≤ γ with ‖y α - y γ‖ ≥ ε/2. + have hbad : ∀ α₀ : ι, ∃ p : ι × ι, α₀ ≤ p.1 ∧ p.1 ≤ p.2 ∧ ε / 2 ≤ ‖y p.1 - y p.2‖ := by + intro α₀ + obtain ⟨α, hα, β, hβ, hdist⟩ := hcon α₀ + obtain ⟨γ, hγα, hγβ⟩ := exists_ge_ge α β + have h1 : ‖y α - y γ‖ + ‖y β - y γ‖ ≥ ε := by + have htr := dist_triangle (y α) (y γ) (y β) + rw [dist_comm (y γ) (y β)] at htr + simp only [dist_eq_norm] at htr hdist + linarith + by_cases hαbad : ε / 2 ≤ ‖y α - y γ‖ + · exact ⟨(α, γ), hα, hγα, hαbad⟩ + · push Not at hαbad + exact ⟨(β, γ), hβ, hγβ, by linarith⟩ + -- Define the recursive choice function and the resulting subsequence. + let step : ι → ι × ι := fun α₀ => (hbad α₀).choose + have hstep : ∀ α₀ : ι, α₀ ≤ (step α₀).1 ∧ (step α₀).1 ≤ (step α₀).2 ∧ + ε / 2 ≤ ‖y (step α₀).1 - y (step α₀).2‖ := fun α₀ => (hbad α₀).choose_spec + -- Build the recursive pair-valued sequence g : ℕ → ι × ι. + let g : ℕ → ι × ι := fun n => Nat.rec (step Classical.ofNonempty) + (fun _ p => step p.2) n + have hg_succ : ∀ n, g (n + 1) = step (g n).2 := fun _ => rfl + have hg_le : ∀ n, (g n).1 ≤ (g n).2 := fun n => by + induction n with + | zero => exact (hstep _).2.1 + | succ k _ => rw [hg_succ]; exact (hstep _).2.1 + have hg_step : ∀ n, (g n).2 ≤ (g (n + 1)).1 := fun n => by + rw [hg_succ]; exact (hstep _).1 + have hg_dist : ∀ n, ε / 2 ≤ ‖y (g n).1 - y (g n).2‖ := fun n => by + induction n with + | zero => exact (hstep _).2.2 + | succ k _ => rw [hg_succ]; exact (hstep _).2.2 + -- The interleaved sequence z : ℕ → X. + let z : ℕ → X := fun k => if k % 2 = 0 then y (g (k / 2)).1 else y (g (k / 2)).2 + have hz_anti : Antitone z := by + refine antitone_nat_of_succ_le (fun k => ?_) + rcases Nat.even_or_odd k with ⟨m, hm⟩ | ⟨m, hm⟩ + · subst hm + have e1 : (m + m) % 2 = 0 := by omega + have e2 : (m + m + 1) % 2 = 1 := by omega + have e3 : (m + m) / 2 = m := by omega + have e4 : (m + m + 1) / 2 = m := by omega + simp only [z, e1, e2, e3, e4, ↓reduceIte] + exact hanti (hg_le m) + · subst hm + have e1 : (2 * m + 1) % 2 = 1 := by omega + have e2 : (2 * m + 1 + 1) % 2 = 0 := by omega + have e3 : (2 * m + 1) / 2 = m := by omega + have e4 : (2 * m + 1 + 1) / 2 = m + 1 := by omega + simp only [z, e1, e2, e3, e4, ↓reduceIte] + exact hanti (hg_step m) + have hz_nn : ∀ k, 0 ≤ z k := by + intro k; simp only [z]; split <;> exact hnn _ + have hz_bdd : BddBelow (Set.range z) := ⟨0, by rintro _ ⟨k, rfl⟩; exact hz_nn k⟩ + -- By σ-CCL + σ-OCN, z is Cauchy. + obtain ⟨_, _, hzv⟩ := tendsto_antitone_seq_of_bddBelow hz_anti hz_bdd + have hzcauchy : CauchySeq z := hzv.cauchySeq + rw [Metric.cauchySeq_iff] at hzcauchy + obtain ⟨N, hN⟩ := hzcauchy (ε / 2) (by linarith) + -- The pair (2N, 2N+1) violates Cauchy by hg_dist. + have hN1 : 2 * N ≥ N := by omega + have hN2 : 2 * N + 1 ≥ N := by omega + have hdN := hN (2 * N) hN1 (2 * N + 1) hN2 + have hh1 : (2 * N) % 2 = 0 := by omega + have hh2 : (2 * N + 1) % 2 = 1 := by omega + have hh3 : (2 * N) / 2 = N := by omega + have hh4 : (2 * N + 1) / 2 = N := by omega + simp only [z, hh1, hh2, hh3, hh4, ↓reduceIte, one_ne_zero] at hdN + rw [dist_eq_norm] at hdN + linarith [hg_dist N] + +end Backward + +end BanachLattice diff --git a/LeanPool/OrderClosures/BanLat/OrderUnit.lean b/LeanPool/OrderClosures/BanLat/OrderUnit.lean new file mode 100644 index 0000000000..5372d34923 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/OrderUnit.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Disjoint + + +/-! +# Order units + +This file introduces the two standard notions of order unit in a vector +lattice. A **weak order unit** is a non-negative element disjoint only from +zero, while a **strong order unit** is a non-negative element which dominates +every other element up to a positive scalar multiple. Every strong order unit +is a weak order unit. +-/ + +@[expose] public section + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- An element `e` of a vector lattice is a **weak order unit** if it is +non-negative and the only element disjoint from `e` is `0`. -/ +def WeakOrderUnit (e : X) : Prop := + 0 ≤ e ∧ ∀ x : X, IsVLDisjoint x e → x = 0 + +/-- An element `e` of a vector lattice is a **strong order unit** if it is +non-negative and every element of `X` is dominated, in absolute value, by some +non-negative real multiple of `e`. -/ +def StrongOrderUnit (e : X) : Prop := + 0 ≤ e ∧ ∀ x : X, ∃ c : ℝ, 0 ≤ c ∧ |x| ≤ c • e + +/-- For a non-negative element `e`, disjointness from `e` implies disjointness +from every natural scalar multiple of `e`. -/ +private lemma abs_inf_natCast_smul_eq_zero {x e : X} (he : 0 ≤ e) + (hxe : |x| ⊓ e = 0) : ∀ k : ℕ, |x| ⊓ ((k : ℝ) • e) = 0 + | 0 => by simp + | k + 1 => by + have ih := abs_inf_natCast_smul_eq_zero he hxe k + have hke : 0 ≤ ((k : ℝ) • e) := + smul_nonneg (Nat.cast_nonneg k) he + have hsucc : ((k + 1 : ℕ) : ℝ) • e = (k : ℝ) • e + e := by + push_cast; rw [add_smul, one_smul] + rw [hsucc] + refine le_antisymm ?_ + (le_inf (abs_nonneg _) (add_nonneg hke he)) + calc |x| ⊓ ((k : ℝ) • e + e) + ≤ |x| ⊓ ((k : ℝ) • e) + |x| ⊓ e := + inf_le_inf_add_inf_of_nonneg |x| ((k : ℝ) • e) e (abs_nonneg x) hke he + _ = 0 := by rw [ih, hxe, add_zero] + +/-- Every strong order unit is a weak order unit. -/ +theorem WeakOrderUnit.of_strongOrderUnit {e : X} (he : StrongOrderUnit e) : + WeakOrderUnit e := by + refine ⟨he.1, fun x hxe => ?_⟩ + rw [IsVLDisjoint, abs_of_nonneg he.1] at hxe + obtain ⟨c, hc, hxc⟩ := he.2 x + obtain ⟨n, hn⟩ := exists_nat_ge c + have hxn : |x| ≤ (n : ℝ) • e := + hxc.trans (smul_le_smul_of_nonneg_right hn he.1) + have hkey := abs_inf_natCast_smul_eq_zero he.1 hxe n + have habs : |x| = 0 := by rw [← inf_eq_left.mpr hxn, hkey] + exact (abs_eq_zero_iff_zero x).mp habs diff --git a/LeanPool/OrderClosures/BanLat/Pi.lean b/LeanPool/OrderClosures/BanLat/Pi.lean new file mode 100644 index 0000000000..b9500a1025 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Pi.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Normed + +/-! +# Products of vector lattices + +The pointwise product of vector lattices is a vector lattice. This is the product +instance from BanLat `Pi.lean`; the separate finite-dimensional normed products +are outside the dependency closure of the order-adherence constructions. +-/ + +@[expose] public section + +/-! ### Pointwise product -/ + +namespace Pi + +variable {ι : Type*} {X : ι → Type*} + [∀ i, AddCommGroup (X i)] [∀ i, Lattice (X i)] [∀ i, IsOrderedAddMonoid (X i)] + [∀ i, VectorLattice (X i)] + +/-- The pointwise product of a family of vector lattices is a vector lattice. +The lattice operations and absolute value are computed pointwise (see +`Pi.sup_apply`, `Pi.inf_apply`, `Pi.abs_apply` in Mathlib). -/ +instance instVectorLattice : VectorLattice (∀ i, X i) := ⟨⟩ + +end Pi diff --git a/LeanPool/OrderClosures/BanLat/Substructures/Band/Basic.lean b/LeanPool/OrderClosures/BanLat/Substructures/Band/Basic.lean new file mode 100644 index 0000000000..9728df02a6 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Substructures/Band/Basic.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Substructures.Ideal +public import LeanPool.OrderClosures.BanLat.OrderComplete + + +/-! +# Bands + +A **band** in a vector lattice is an order ideal that is **order closed**: +whenever a subset of the band has a supremum in the ambient space, that +supremum also lies in the band. + +This file defines the bundled structure `Band`, relates bands to order ideals +and vector sublattices, proves the basic closure properties, and records that +order completeness passes from the ambient vector lattice to a band. +-/ + +@[expose] public section + +section MainVariables +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-! ### The band structure -/ + +/-- A **band** in a vector lattice is an order ideal that is **order closed**: +whenever a subset of the band has a supremum in `X`, that supremum also lies +in the band. -/ +structure Band (X : Type*) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] + extends OrderIdeal X where + sSup_mem' : + ∀ (S : Set X), S ⊆ carrier → S.Nonempty → ∀ x, IsLUB S x → x ∈ carrier + +namespace Band + +instance : SetLike (Band X) X where + coe B := B.carrier + coe_injective p q h := by + cases p; cases q; congr + exact SetLike.ext' h + +variable (B : Band X) + +/-! ### A band is an ideal and a vector sublattice -/ + +/-- Every band is an order ideal. -/ +def toOrderIdeal' : OrderIdeal X := B.toOrderIdeal + +/-! ### Closure under suprema -/ + +/-- A band is closed under suprema: if a subset of the band has a supremum in +`X`, the supremum lies in the band. -/ +theorem sSup_mem {S : Set X} (hS : S ⊆ (B : Set X)) (hne : S.Nonempty) + {x : X} (hx : IsLUB S x) : x ∈ B := + B.sSup_mem' S hS hne x hx + +/-! ### Basic membership lemmas inherited from the underlying ideal -/ + +/-- A band is closed under `⊔`. -/ +theorem sup_mem {x y : X} (hx : x ∈ B) (hy : y ∈ B) : + x ⊔ y ∈ B := + B.toOrderIdeal.sup_mem hx hy + +/-- A band is closed under `⊓`. -/ +theorem inf_mem {x y : X} (hx : x ∈ B) (hy : y ∈ B) : + x ⊓ y ∈ B := + B.toOrderIdeal.inf_mem hx hy + +/-- A band is solid. -/ +theorem solid {x y : X} (hx : x ∈ B) (hy0 : 0 ≤ y) (hyx : y ≤ x) : + y ∈ B := + B.toOrderIdeal.solid hx hy0 hyx + +/-- A band is closed under absolute value. -/ +theorem abs_mem {x : X} (hx : x ∈ B) : |x| ∈ B := + B.toOrderIdeal.abs_mem hx + +/-- Membership in a band is equivalent to membership of the absolute value. -/ +theorem mem_of_abs_mem {x : X} (h : |x| ∈ B) : x ∈ B := + B.toOrderIdeal.mem_of_abs_mem h + +/-- Solidity in terms of absolute value. -/ +theorem mem_of_abs_le_abs {x y : X} (hx : x ∈ B) (h : |y| ≤ |x|) : + y ∈ B := + B.toOrderIdeal.mem_of_abs_le_abs hx h + +/-! ### Construction from the positive directed closure condition + +It suffices to test the closure condition on positive directed subsets: +an order ideal closed under suprema of positive directed subsets is +automatically a band. -/ + +/-- An order ideal is a band as soon as every directed subset of positive +elements with supremum in `X` has its supremum in the ideal. -/ +def ofPosDirectedSSupMem (J : OrderIdeal X) + (h : ∀ S, S ⊆ (J : Set X) → (∀ x ∈ S, 0 ≤ x) → DirectedOn (· ≤ ·) S + → S.Nonempty → ∀ x, IsLUB S x → x ∈ J) : Band X where + toOrderIdeal := J + sSup_mem' := by + classical + intro S hSJ hne y hy + obtain ⟨s₀, hs₀⟩ := hne + have hs₀J : s₀ ∈ J := hSJ hs₀ + have finsup_mem : ∀ (F : Finset X) (hF : F.Nonempty), ↑F ⊆ S → + F.sup' hF id ∈ J := by + intro F hF hFS + induction hF using Finset.Nonempty.cons_induction with + | singleton x => + rw [Finset.sup'_singleton] + exact hSJ (hFS (by simp)) + | cons x F hxF hFne ih => + rw [Finset.sup'_cons hFne id] + refine J.sup_mem (hSJ (hFS ?_)) (ih ?_) + · simp + · intro a ha; exact hFS (by simp [ha]) + set T : Set X := + { z | ∃ F : Finset X, ∃ hF : F.Nonempty, ↑F ⊆ S ∧ s₀ ∈ F ∧ + z = F.sup' hF id - s₀ } + have hT_J : T ⊆ (J : Set X) := by + rintro z ⟨F, hF, hFS, _, rfl⟩ + exact J.toSubmodule.sub_mem (finsup_mem F hF hFS) hs₀J + have hT_pos : ∀ z ∈ T, 0 ≤ z := by + rintro z ⟨F, hF, hFS, hs₀F, rfl⟩ + exact sub_nonneg.mpr (Finset.le_sup' id hs₀F) + have hT_dir : DirectedOn (· ≤ ·) T := by + rintro a ⟨Fa, hFa, hFaS, hs₀a, rfl⟩ b ⟨Fb, hFb, hFbS, hs₀b, rfl⟩ + refine ⟨(Fa ∪ Fb).sup' (hFa.mono Finset.subset_union_left) id - s₀, + ⟨Fa ∪ Fb, hFa.mono Finset.subset_union_left, ?_, ?_, rfl⟩, ?_, ?_⟩ + · rw [Finset.coe_union]; exact Set.union_subset hFaS hFbS + · exact Finset.mem_union.mpr (Or.inl hs₀a) + · exact sub_le_sub_right + (Finset.sup'_mono id Finset.subset_union_left hFa) s₀ + · exact sub_le_sub_right + (Finset.sup'_mono id Finset.subset_union_right hFb) s₀ + have hT_ne : T.Nonempty := + ⟨0, ⟨{s₀}, Finset.singleton_nonempty s₀, by + intro a ha; rw [Finset.coe_singleton, Set.mem_singleton_iff] at ha + rw [ha]; exact hs₀, + Finset.mem_singleton_self _, by + rw [Finset.sup'_singleton]; exact (sub_self s₀).symm⟩⟩ + have hT_lub : IsLUB T (y - s₀) := by + refine ⟨?_, ?_⟩ + · rintro z ⟨F, hF, hFS, _, rfl⟩ + exact sub_le_sub_right + (Finset.sup'_le hF id (fun a ha => hy.1 (hFS ha))) s₀ + · intro c hc + rw [sub_le_iff_le_add] + apply hy.2 + intro s hs + have hF : ({s, s₀} : Finset X).Nonempty := ⟨s, by simp⟩ + have hFS : (↑({s, s₀} : Finset X) : Set X) ⊆ S := by + intro a ha + rw [Finset.coe_insert, Finset.coe_singleton] at ha + rcases ha with rfl | rfl + · exact hs + · exact hs₀ + have hs₀mem : s₀ ∈ ({s, s₀} : Finset X) := by simp + have hT_elt : ({s, s₀} : Finset X).sup' hF id - s₀ ∈ T := + ⟨_, hF, hFS, hs₀mem, rfl⟩ + have hle : ({s, s₀} : Finset X).sup' hF id - s₀ ≤ c := hc hT_elt + have hsup_ge : s ≤ ({s, s₀} : Finset X).sup' hF id := + Finset.le_sup' id (by simp : s ∈ ({s, s₀} : Finset X)) + have : ({s, s₀} : Finset X).sup' hF id ≤ c + s₀ := + sub_le_iff_le_add.mp hle + exact hsup_ge.trans this + have hu : y - s₀ ∈ J := h T hT_J hT_pos hT_dir hT_ne (y - s₀) hT_lub + have hres : y - s₀ + s₀ ∈ J := J.toSubmodule.add_mem hu hs₀J + change y ∈ J + rw [sub_add_cancel] at hres + exact hres + +end Band + +end MainVariables + +section CCLSubtype + +variable {X : Type*} [AddCommGroup X] [ConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [VectorLattice X] + +namespace Band + +/-! ### Order completeness of the underlying subtype -/ + +/-- A band in an order complete vector lattice is itself order complete. -/ +noncomputable instance instConditionallyCompleteLatticeSubtype + (B : Band X) : + ConditionallyCompleteLattice ↥B.toSubmodule := by + letI : Nonempty ↥B.toSubmodule := ⟨0⟩ + refine conditionallyCompleteLatticeOfPosSet ↥B.toSubmodule ?_ + intro S _ hne hbdd + set T : Set X := Subtype.val '' S with hT_def + have hT_sub : T ⊆ (B : Set X) := by + rintro _ ⟨⟨a, ha⟩, _, rfl⟩; exact ha + have hT_ne : T.Nonempty := hne.image _ + obtain ⟨u, hu⟩ := hbdd + have hT_bdd : BddAbove T := + ⟨u.1, by rintro _ ⟨v, hv, rfl⟩; exact hu hv⟩ + have hT_lub : IsLUB T (sSup T) := isLUB_csSup hT_ne hT_bdd + refine ⟨⟨sSup T, B.sSup_mem hT_sub hT_ne hT_lub⟩, ?_, ?_⟩ + · rintro a ha + change a.1 ≤ sSup T + exact hT_lub.1 ⟨a, ha, rfl⟩ + · rintro a hub + change sSup T ≤ a.1 + exact hT_lub.2 (by rintro _ ⟨b, hb, rfl⟩; exact hub hb) + +end Band + +end CCLSubtype diff --git a/LeanPool/OrderClosures/BanLat/Substructures/Band/DisjointComplement.lean b/LeanPool/OrderClosures/BanLat/Substructures/Band/DisjointComplement.lean new file mode 100644 index 0000000000..da401cc205 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Substructures/Band/DisjointComplement.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Disjoint +public import LeanPool.OrderClosures.BanLat.Substructures.Band.Basic + + +/-! +# Disjoint complements + +The **disjoint complement** `Aᵈ` of a set `A ⊆ X` consists of all elements of +`X` disjoint from every member of `A`. It is always a band, and behaves +naturally with respect to inclusion, union, and double complementation. + +In a normed vector lattice, every disjoint complement is norm closed: it is +an intersection of zero-sets of the continuous maps `x ↦ |x| ⊓ |a|`. +-/ + +@[expose] public section + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-! ### The disjoint complement as a set -/ + +/-- The **disjoint complement** of a set `A ⊆ X` is the set of all elements +disjoint from every member of `A`. -/ +def disjointComplement (A : Set X) : Set X := + {x : X | ∀ a ∈ A, IsVLDisjoint x a} + +@[inherit_doc] +postfix:max "ᵈ" => disjointComplement + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- Membership in the disjoint complement: `x ∈ Aᵈ` iff `x` is disjoint from +every member of `A`. -/ +theorem mem_disjointComplement_iff {A : Set X} {x : X} : + x ∈ Aᵈ ↔ ∀ a ∈ A, IsVLDisjoint x a := Iff.rfl + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- Disjoint complementation is anti-monotone: `A ⊆ B` implies `Bᵈ ⊆ Aᵈ`. -/ +theorem disjointComplement_anti {A B : Set X} (h : A ⊆ B) : + Bᵈ ⊆ Aᵈ := fun _ hx a ha => hx a (h ha) + +omit [VectorLattice X] in +/-- The intersection of a set with its disjoint complement is contained in +`{0}`. -/ +theorem disjointComplement_inter_eq_zero (A : Set X) : + A ∩ Aᵈ ⊆ {0} := by + rintro a ⟨ha, had⟩ + have hd : |a| ⊓ |a| = 0 := had a ha + rw [inf_idem] at hd + exact (abs_eq_zero_iff_zero a).mp hd + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- Every set is contained in its double disjoint complement. -/ +theorem subset_disjointComplement_disjointComplement (A : Set X) : + A ⊆ Aᵈᵈ := fun a ha _ hy => isVLDisjoint_comm.mp (hy a ha) + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- The triple disjoint complement equals the single disjoint complement. -/ +theorem disjointComplement_disjointComplement_disjointComplement (A : Set X) : + Aᵈᵈᵈ = Aᵈ := + Set.Subset.antisymm + (disjointComplement_anti (subset_disjointComplement_disjointComplement A)) + (subset_disjointComplement_disjointComplement Aᵈ) + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- The disjoint complement of a union is the intersection of the disjoint +complements. -/ +theorem disjointComplement_union (A B : Set X) : + (A ∪ B)ᵈ = Aᵈ ∩ Bᵈ := by + ext x + refine ⟨fun hx => ⟨fun a ha => hx a (Or.inl ha), fun b hb => hx b (Or.inr hb)⟩, + fun ⟨hA, hB⟩ _ hy => ?_⟩ + rcases hy with hy | hy + · exact hA _ hy + · exact hB _ hy + +omit [VectorLattice X] in +/-- The disjoint complement of a set together with its disjoint complement is +the singleton `{0}`. -/ +theorem disjointComplement_union_disjointComplement_eq_singleton (A : Set X) : + (A ∪ Aᵈ)ᵈ = ({0} : Set X) := by + apply Set.Subset.antisymm + · intro x hx + have hxA : x ∈ Aᵈ := fun a ha => hx a (Or.inl ha) + have hxAd : x ∈ Aᵈᵈ := fun a ha => hx a (Or.inr ha) + exact disjointComplement_inter_eq_zero Aᵈ ⟨hxA, hxAd⟩ + · rintro x rfl a _ + exact isVLDisjoint_zero_left a + +namespace Band + +/-! ### The disjoint complement is a band -/ + +/-- The disjoint complement of any set is a band. -/ +def disjointComplement (A : Set X) : Band X := + Band.ofPosDirectedSSupMem + (.ofSolid + { carrier := Aᵈ + add_mem' := fun {_ _} hx hy a ha => (hx a ha).add_left (hy a ha) + zero_mem' := fun a _ => isVLDisjoint_zero_left a + smul_mem' := fun c {_} hx a ha => (hx a ha).smul_left c } + (fun _ _ hx hxy a ha => (hx a ha).mono_left hxy)) + (by + intro S hSJ hpos _ hne y hy a ha + have hy_nn : 0 ≤ y := by + obtain ⟨s, hs⟩ := hne + exact (hpos s hs).trans (hy.1 hs) + have key : IsLUB ((fun z => |a| ⊓ z) '' S) (|a| ⊓ y) := isLUB_inf_const _ hy + have hzero : ∀ s ∈ S, |a| ⊓ s = 0 := by + intro s hs + have h : |s| ⊓ |a| = 0 := hSJ hs a ha + rw [abs_of_nonneg (hpos s hs), inf_comm] at h + exact h + have h_le : |a| ⊓ y ≤ 0 := + key.2 (by rintro _ ⟨s, hs, rfl⟩; exact (hzero s hs).le) + have h_ge : 0 ≤ |a| ⊓ y := le_inf (abs_nonneg _) hy_nn + have hay : |a| ⊓ y = 0 := le_antisymm h_le h_ge + change |y| ⊓ |a| = 0 + rw [abs_of_nonneg hy_nn, inf_comm]; exact hay) + +end Band + +/-! ### Closedness in normed vector lattices -/ + +section Normed + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +/-- In a normed vector lattice, the disjoint complement of any set is norm +closed: it is the intersection of the zero-sets of the continuous maps +`x ↦ |x| ⊓ |a|`. -/ +theorem isClosed_disjointComplement (A : Set X) : IsClosed (Aᵈ) := by + have heq : (Aᵈ : Set X) = ⋂ a ∈ A, (fun x : X => |x| ⊓ |a|) ⁻¹' {0} := by + ext x + simp [disjointComplement, IsVLDisjoint] + rw [heq] + refine isClosed_iInter (fun a => isClosed_iInter (fun _ => ?_)) + exact isClosed_singleton.preimage + (NormedVectorLattice.lipschitzWith_abs.continuous.inf continuous_const) + +end Normed diff --git a/LeanPool/OrderClosures/BanLat/Substructures/Ideal.lean b/LeanPool/OrderClosures/BanLat/Substructures/Ideal.lean new file mode 100644 index 0000000000..0a56b7c7c7 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Substructures/Ideal.lean @@ -0,0 +1,1127 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Substructures.Sublattice +public import LeanPool.OrderClosures.BanLat.Normed +public import LeanPool.OrderClosures.BanLat.OrderUnit +public import Mathlib.Analysis.Normed.Group.Completeness + + +/-! +# Order ideals of vector lattices + +An **order ideal** (or simply *ideal*) of a vector lattice is a sublattice that is **solid**: +if `x ∈ J` and `|y| ≤ |x|` then `y ∈ J`. Equivalently, an ideal is precisely a solid +subspace. This file defines the bundled `OrderIdeal` structure extending +`VectorSublattice` and establishes the basic characterisations and properties. +-/ + +@[expose] public section + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- An `OrderIdeal` of a vector lattice `X` is a vector sublattice that is **solid**: +whenever `x ∈ J` and `0 ≤ y ≤ x`, we have `y ∈ J`. -/ +structure OrderIdeal (X : Type*) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] + extends VectorSublattice X where + solid' : ∀ {x y : X}, x ∈ carrier → 0 ≤ y → y ≤ x → y ∈ carrier + +namespace OrderIdeal + +instance : SetLike (OrderIdeal X) X where + coe J := J.carrier + coe_injective p q h := by + cases p; cases q; congr + exact SetLike.ext' h + +/-- Order ideals of `X`, ordered by inclusion, form a **partial order**. -/ +instance : PartialOrder (OrderIdeal X) := .ofSetLike (OrderIdeal X) X + +variable (J : OrderIdeal X) + +/-- An order ideal is solid: `x ∈ J` and `0 ≤ y ≤ x` imply `y ∈ J`. -/ +theorem solid {x y : X} (hx : x ∈ J) (hy0 : 0 ≤ y) (hyx : y ≤ x) : + y ∈ J := + J.solid' hx hy0 hyx + +/-- Every order ideal is a vector sublattice. -/ +def toVectorSublattice' : VectorSublattice X := + J.toVectorSublattice + +/-- An order ideal is closed under `⊔`. -/ +theorem sup_mem {x y : X} (hx : x ∈ J) (hy : y ∈ J) : + x ⊔ y ∈ J := + J.toVectorSublattice.sup_mem hx hy + +/-- An order ideal is closed under `⊓`. -/ +theorem inf_mem {x y : X} (hx : x ∈ J) (hy : y ∈ J) : + x ⊓ y ∈ J := + J.toVectorSublattice.inf_mem hx hy + +/-- An order ideal is closed under absolute value. -/ +theorem abs_mem {x : X} (hx : x ∈ J) : |x| ∈ J := + J.toVectorSublattice.abs_mem hx + +/-- If `|x| ∈ J` then `x ∈ J`. -/ +theorem mem_of_abs_mem {x : X} (h : |x| ∈ J) : x ∈ J := by + have hpos : x⁺ ∈ J := J.solid h (posPart_nonneg x) (sup_le (le_abs_self x) (abs_nonneg x)) + have hneg : x⁻ ∈ J := J.solid h (negPart_nonneg x) (sup_le (neg_le_abs x) (abs_nonneg x)) + have := J.toSubmodule.sub_mem hpos hneg + rwa [posPart_sub_negPart] at this + +/-- Solidity in terms of absolute value: `x ∈ J` and `|y| ≤ |x|` imply +`y ∈ J`. -/ +theorem mem_of_abs_le_abs {x y : X} (hx : x ∈ J) + (h : |y| ≤ |x|) : y ∈ J := + J.mem_of_abs_mem (J.solid (J.abs_mem hx) (abs_nonneg y) h) + +/-! ### Construction from solidity -/ + +/-- Build an `OrderIdeal` from a submodule that is solid in the absolute-value +sense: `x ∈ M` and `|y| ≤ |x|` imply `y ∈ M`. Every solid subspace is +automatically a sublattice and an ideal. -/ +def ofSolid (M : Submodule ℝ X) + (h : ∀ x y : X, x ∈ M → |y| ≤ |x| → y ∈ M) : + OrderIdeal X where + toSubmodule := M + sup_mem' := fun {x y} hx hy => by + have hax : |x| ∈ M := h x (|x|) hx (abs_of_nonneg (abs_nonneg x)).le + have hay : |y| ∈ M := h y (|y|) hy (abs_of_nonneg (abs_nonneg y)).le + have hab : |x| + |y| ∈ M := M.add_mem hax hay + apply h (|x| + |y|) (x ⊔ y) hab + rw [abs_of_nonneg (add_nonneg (abs_nonneg x) (abs_nonneg y))] + apply sup_le + · exact sup_le + (le_trans (le_abs_self x) (le_add_of_nonneg_right (abs_nonneg y))) + (le_trans (le_abs_self y) (le_add_of_nonneg_left (abs_nonneg x))) + · calc -(x ⊔ y) = (-x) ⊓ (-y) := neg_sup x y + _ ≤ -x := inf_le_left + _ ≤ |x| := neg_le_abs x + _ ≤ |x| + |y| := le_add_of_nonneg_right (abs_nonneg y) + solid' := fun {x y} hx hy0 hyx => + h x y hx (by rwa [abs_of_nonneg hy0, abs_of_nonneg (le_trans hy0 hyx)]) + +/-- A submodule is the carrier of an order ideal iff it is solid. -/ +theorem solid_iff (M : Submodule ℝ X) : + (∀ x y : X, x ∈ M → |y| ≤ |x| → y ∈ M) ↔ + (∀ x y : X, x ∈ M → 0 ≤ y → y ≤ x → y ∈ M) ∧ + ∀ x y : X, x ∈ M → y ∈ M → x ⊔ y ∈ M := by + constructor + · intro h + exact ⟨fun _ _ hx hy0 hyx => (ofSolid M h).solid' hx hy0 hyx, + fun _ _ hx hy => (ofSolid M h).sup_mem' hx hy⟩ + · intro ⟨hsol, hsup⟩ x y hx hle + -- |x| ∈ M + have habs_x : |x| ∈ M := hsup x (-x) hx (M.neg_mem hx) + -- |y| ∈ M by solidity: 0 ≤ |y| ≤ |x| and |x| ∈ M + have habs_y : |y| ∈ M := hsol (|x|) (|y|) habs_x (abs_nonneg y) hle + -- y⁺ ∈ M: 0 ≤ y⁺ ≤ |y| + have hpos : y⁺ ∈ M := + hsol (|y|) y⁺ habs_y (posPart_nonneg y) (sup_le (le_abs_self y) (abs_nonneg y)) + -- y⁻ ∈ M: 0 ≤ y⁻ ≤ |y| + have hneg : y⁻ ∈ M := + hsol (|y|) y⁻ habs_y (negPart_nonneg y) (sup_le (neg_le_abs y) (abs_nonneg y)) + have := M.sub_mem hpos hneg + rwa [posPart_sub_negPart] at this + +/-- The coercion to `Submodule ℝ X` is injective. -/ +theorem toSubmodule_injective : + Function.Injective + (fun J : OrderIdeal X => J.toSubmodule) := by + intro p q h + cases p; cases q; congr + exact VectorSublattice.toSubmodule_injective h + +/-! ### Ideal generated by a set -/ + +/-- The intersection of two order ideals is an order ideal. -/ +protected def inf (J₁ J₂ : OrderIdeal X) : OrderIdeal X where + toSubmodule := J₁.toSubmodule ⊓ J₂.toSubmodule + sup_mem' := fun hx hy => + ⟨J₁.sup_mem hx.1 hy.1, J₂.sup_mem hx.2 hy.2⟩ + solid' := fun hx hy0 hyx => + ⟨J₁.solid hx.1 hy0 hyx, J₂.solid hx.2 hy0 hyx⟩ + +/-- Order ideals of `X` admit arbitrary intersections: they form a complete +semilattice for the `⊓` operation. -/ +instance : InfSet (OrderIdeal X) where + sInf S := + { toSubmodule := InfSet.sInf ((fun J : OrderIdeal X => J.toSubmodule) '' S) + sup_mem' := fun {x y} hx hy => by + have hx' := (Submodule.mem_sInf).mp hx + have hy' := (Submodule.mem_sInf).mp hy + refine (Submodule.mem_sInf).mpr ?_ + rintro _ ⟨J, hJ, rfl⟩ + exact J.sup_mem (hx' _ ⟨J, hJ, rfl⟩) (hy' _ ⟨J, hJ, rfl⟩) + solid' := fun {x y} hx hy0 hyx => by + have hx' := (Submodule.mem_sInf).mp hx + refine (Submodule.mem_sInf).mpr ?_ + rintro _ ⟨J, hJ, rfl⟩ + exact J.solid (hx' _ ⟨J, hJ, rfl⟩) hy0 hyx } + +/-- Membership in an arbitrary intersection of order ideals. -/ +@[simp] theorem mem_sInf {S : Set (OrderIdeal X)} {x : X} : + x ∈ (InfSet.sInf S : OrderIdeal X) ↔ ∀ J ∈ S, x ∈ J := by + change x ∈ InfSet.sInf ((fun J : OrderIdeal X => J.toSubmodule) '' S) ↔ _ + rw [Submodule.mem_sInf] + exact ⟨fun h J hJ => h _ ⟨J, hJ, rfl⟩, by rintro h _ ⟨J, hJ, rfl⟩; exact h J hJ⟩ + +/-- The **ideal generated by a set** `s ⊆ X` is the smallest order ideal of +`X` containing `s`, defined as the intersection of all order ideals containing +`s`. -/ +def generated (s : Set X) : OrderIdeal X := + InfSet.sInf {J : OrderIdeal X | s ⊆ (J : Set X)} + +/-- The set `s` is contained in the ideal it generates. -/ +theorem subset_generated (s : Set X) : s ⊆ (generated s : Set X) := + fun _ hx => mem_sInf.mpr (fun _ hJ => hJ hx) + +/-- The ideal generated by `s` is contained in any ideal containing `s`. -/ +theorem generated_le {s : Set X} {J : OrderIdeal X} (h : s ⊆ (J : Set X)) : + generated s ≤ J := + fun _ hx => mem_sInf.mp hx J h + +/-- The order ideal of elements bounded in absolute value by a non-negative +linear combination of `|y|`'s for `y ∈ s`. -/ +private def generatedAux (s : Set X) : OrderIdeal X := + ofSolid + { carrier := {x : X | ∃ (t : Finset X) (c : X → ℝ), + (∀ y ∈ t, y ∈ s) ∧ (∀ y ∈ t, 0 ≤ c y) ∧ |x| ≤ ∑ y ∈ t, c y • |y|} + add_mem' := by + classical + rintro x x' ⟨t, c, hts, hc, hxle⟩ ⟨t', c', ht's, hc', hx'le⟩ + refine ⟨t ∪ t', + fun y => (if y ∈ t then c y else 0) + (if y ∈ t' then c' y else 0), + ?_, ?_, ?_⟩ + · intro y hy + rcases Finset.mem_union.mp hy with h | h + · exact hts y h + · exact ht's y h + · intro y _ + refine add_nonneg ?_ ?_ + · split_ifs with h + · exact hc y h + · exact le_rfl + · split_ifs with h + · exact hc' y h + · exact le_rfl + · have h1 : ∑ y ∈ t, c y • |y| = + ∑ y ∈ t ∪ t', (if y ∈ t then c y else 0) • |y| := by + rw [show ∑ y ∈ t, c y • |y| = + ∑ y ∈ t, (if y ∈ t then c y else 0) • |y| from + Finset.sum_congr rfl (fun y hy => by rw [ite_eq_left hy])] + exact Finset.sum_subset Finset.subset_union_left + (fun y _ hy => by rw [ite_eq_right hy, zero_smul]) + have h2 : ∑ y ∈ t', c' y • |y| = + ∑ y ∈ t ∪ t', (if y ∈ t' then c' y else 0) • |y| := by + rw [show ∑ y ∈ t', c' y • |y| = + ∑ y ∈ t', (if y ∈ t' then c' y else 0) • |y| from + Finset.sum_congr rfl (fun y hy => by rw [ite_eq_left hy])] + exact Finset.sum_subset Finset.subset_union_right + (fun y _ hy => by rw [ite_eq_right hy, zero_smul]) + calc |x + x'| + ≤ |x| + |x'| := abs_add_le _ _ + _ ≤ (∑ y ∈ t, c y • |y|) + (∑ y ∈ t', c' y • |y|) := + add_le_add hxle hx'le + _ = (∑ y ∈ t ∪ t', (if y ∈ t then c y else 0) • |y|) + + (∑ y ∈ t ∪ t', (if y ∈ t' then c' y else 0) • |y|) := by + rw [h1, h2] + _ = ∑ y ∈ t ∪ t', ((if y ∈ t then c y else 0) + + (if y ∈ t' then c' y else 0)) • |y| := by + rw [← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun y _ => ?_ + rw [add_smul] + zero_mem' := ⟨∅, fun _ => 0, by simp, by simp, by simp⟩ + smul_mem' := by + rintro r x ⟨t, c, hts, hc, hxle⟩ + refine ⟨t, fun y => |r| * c y, hts, + fun y hy => mul_nonneg (abs_nonneg _) (hc y hy), ?_⟩ + rw [abs_smul'] + calc |r| • |x| + ≤ |r| • ∑ y ∈ t, c y • |y| := + smul_le_smul_of_nonneg_left hxle (abs_nonneg _) + _ = ∑ y ∈ t, (|r| * c y) • |y| := by + rw [Finset.smul_sum] + refine Finset.sum_congr rfl fun y _ => ?_ + rw [smul_smul] } + (fun x y ⟨t, c, hts, hc, hxle⟩ hyx_abs => + ⟨t, c, hts, hc, le_trans hyx_abs hxle⟩) + +/-- **Explicit description of the generated ideal.** An element `x` lies in the +ideal generated by `s` if and only if `|x|` is bounded above by a non-negative +linear combination of absolute values of elements of `s`. -/ +theorem mem_generated_iff {s : Set X} {x : X} : + x ∈ generated s ↔ + ∃ (t : Finset X) (c : X → ℝ), + (∀ y ∈ t, y ∈ s) ∧ (∀ y ∈ t, 0 ≤ c y) ∧ + |x| ≤ ∑ y ∈ t, c y • |y| := by + refine ⟨fun hx => ?_, ?_⟩ + · have h : generated s ≤ generatedAux s := by + apply generated_le + intro y hy + exact ⟨{y}, fun _ => 1, by + intro z hz; rw [Finset.mem_singleton] at hz; exact hz ▸ hy, + by intros; exact zero_le_one, + by simp⟩ + exact h hx + · rintro ⟨t, c, hts, hc, hxle⟩ + refine (mem_sInf (S := {J : OrderIdeal X | s ⊆ (J : Set X)})).mpr fun J hJ => ?_ + have hsum : ∑ y ∈ t, c y • |y| ∈ J := by + apply J.toSubmodule.sum_mem + intro y hy + exact J.toSubmodule.smul_mem _ (J.abs_mem (hJ (hts y hy))) + exact J.mem_of_abs_mem (J.solid hsum (abs_nonneg _) hxle) + +/-! ### Principal ideal -/ + +/-- The **principal ideal** generated by `a` is the set of elements `x` with +`|x| ≤ c • |a|` for some `c ≥ 0`. -/ +def principal (a : X) : OrderIdeal X where + toSubmodule := + { carrier := {x : X | ∃ c : ℝ, 0 ≤ c ∧ |x| ≤ c • |a|} + add_mem' := fun {x y} ⟨cx, hcx, hx⟩ ⟨cy, hcy, hy⟩ => + ⟨cx + cy, add_nonneg hcx hcy, by + calc |x + y| ≤ |x| + |y| := abs_add_le x y + _ ≤ cx • |a| + cy • |a| := add_le_add hx hy + _ = (cx + cy) • |a| := (add_smul cx cy |a|).symm⟩ + zero_mem' := ⟨0, le_rfl, by simp⟩ + smul_mem' := fun r x ⟨c, hc, hx⟩ => + ⟨|r| * c, mul_nonneg (abs_nonneg r) hc, by + rw [abs_smul' x r] + calc |r| • |x| ≤ |r| • (c • |a|) := + smul_le_smul_of_nonneg_left hx (abs_nonneg r) + _ = (|r| * c) • |a| := smul_smul |r| c |a|⟩ } + sup_mem' := fun {x y} ⟨cx, hcx, hx⟩ ⟨cy, hcy, hy⟩ => + ⟨cx + cy, add_nonneg hcx hcy, by + have : |x ⊔ y| ≤ |x| + |y| := by + apply sup_le + · exact sup_le + (le_trans (le_abs_self x) (le_add_of_nonneg_right (abs_nonneg y))) + (le_trans (le_abs_self y) (le_add_of_nonneg_left (abs_nonneg x))) + · calc -(x ⊔ y) = (-x) ⊓ (-y) := neg_sup x y + _ ≤ -x := inf_le_left + _ ≤ |x| := neg_le_abs x + _ ≤ |x| + |y| := le_add_of_nonneg_right (abs_nonneg y) + calc |x ⊔ y| ≤ |x| + |y| := this + _ ≤ cx • |a| + cy • |a| := add_le_add hx hy + _ = (cx + cy) • |a| := (add_smul cx cy |a|).symm⟩ + solid' := fun {x y} ⟨c, hc, hx⟩ hy0 hyx => + ⟨c, hc, le_trans (by rw [abs_of_nonneg hy0]; exact le_trans hyx (le_abs_self x)) hx⟩ + +/-- Characterisation of membership in the principal ideal. -/ +theorem mem_principal {a x : X} : + x ∈ principal a ↔ ∃ c : ℝ, 0 ≤ c ∧ |x| ≤ c • |a| := Iff.rfl + +/-- The generator belongs to its own principal ideal. -/ +theorem self_mem_principal (a : X) : a ∈ principal a := + ⟨1, zero_le_one, by simp⟩ + +/-- The principal ideal generated by `a` coincides with the ideal generated by +the singleton `{|a|}`. -/ +theorem principal_eq_generated_abs (a : X) : + principal a = generated ({|a|} : Set X) := by + refine le_antisymm (fun x hx => ?_) (generated_le ?_) + · obtain ⟨c, hc, hxle⟩ := hx + refine (mem_sInf (S := {J : OrderIdeal X | {|a|} ⊆ (J : Set X)})).mpr fun J hJ => ?_ + have ha : |a| ∈ J := hJ rfl + have hca : c • |a| ∈ J := J.toSubmodule.smul_mem c ha + exact J.mem_of_abs_mem (J.solid hca (abs_nonneg _) hxle) + · intro y hy + rw [Set.mem_singleton_iff] at hy + subst hy + exact ⟨1, zero_le_one, by rw [abs_abs, one_smul]⟩ + +/-! ### Gauge norm on the principal ideal -/ + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- The **gauge norm** (or order-unit norm) of `x` with respect to `a` is +`inf {c ≥ 0 | |x| ≤ c • |a|}`. For `x` in the principal ideal of `a`, this +is finite and defines a lattice seminorm; it is a norm precisely when the +ambient space is Archimedean. -/ +noncomputable def gaugeNorm (a x : X) : ℝ := + sInf {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|} + +variable (a : X) + +/-- The gauge norm is non-negative. -/ +theorem gaugeNorm_nonneg (x : X) : 0 ≤ gaugeNorm a x := by + unfold gaugeNorm + by_cases h : {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|}.Nonempty + · exact le_csInf h fun _ ⟨hc, _⟩ => hc + · rw [Set.not_nonempty_iff_eq_empty.mp h, Real.sInf_empty] + +/-- The gauge norm of zero is zero. -/ +theorem gaugeNorm_zero : gaugeNorm a 0 = 0 := by + apply le_antisymm + · exact csInf_le ⟨0, fun _ ⟨hd, _⟩ => hd⟩ ⟨le_rfl, by simp⟩ + · exact gaugeNorm_nonneg a 0 + +/-- The gauge norm is symmetric. -/ +theorem gaugeNorm_neg (x : X) : + gaugeNorm a (-x) = gaugeNorm a x := by + simp only [gaugeNorm, abs_neg] + +/-- Triangle inequality for the gauge norm. -/ +private theorem gaugeNorm_bddBelow (x : X) : + BddBelow {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|} := + ⟨0, fun _ ⟨hc, _⟩ => hc⟩ + +theorem gaugeNorm_add_le {x y : X} (hx : x ∈ principal a) (hy : y ∈ principal a) : + gaugeNorm a (x + y) ≤ gaugeNorm a x + gaugeNorm a y := by + -- Bound `gaugeNorm a (x + y) - cy` for each admissible bound `cy` of `y`. + have step1 : ∀ cy, cy ∈ {c : ℝ | 0 ≤ c ∧ |y| ≤ c • |a|} → + gaugeNorm a (x + y) - cy ≤ gaugeNorm a x := by + intro cy ⟨hcy, hcy_le⟩ + apply le_csInf hx + intro cx ⟨hcx, hcx_le⟩ + have : cx + cy ∈ {c : ℝ | 0 ≤ c ∧ |x + y| ≤ c • |a|} := + ⟨add_nonneg hcx hcy, le_trans (abs_add_le x y) + (by rw [add_smul]; exact add_le_add hcx_le hcy_le)⟩ + exact sub_le_iff_le_add.mpr (csInf_le (gaugeNorm_bddBelow a (x + y)) this) + -- Then take the infimum over admissible bounds of `y`. + have step2 : gaugeNorm a (x + y) - gaugeNorm a x ≤ gaugeNorm a y := + le_csInf hy (fun cy hcy => by linarith [step1 cy hcy]) + linarith + +/-- Absolute homogeneity of the gauge norm. -/ +private theorem gaugeNorm_div_mem {r : ℝ} (hr_pos : 0 < |r|) {x : X} {c : ℝ} + (hc : 0 ≤ c) (hle : |r| • |x| ≤ c • |a|) : + c / |r| ∈ {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|} := by + refine ⟨div_nonneg hc hr_pos.le, ?_⟩ + have := smul_le_smul_of_nonneg_left hle (inv_nonneg.mpr hr_pos.le) + rw [smul_smul, inv_mul_cancel₀ (ne_of_gt hr_pos), one_smul, smul_smul] at this + rwa [div_eq_inv_mul] + +theorem gaugeNorm_smul (r : ℝ) (x : X) : + gaugeNorm a (r • x) = |r| * gaugeNorm a x := by + by_cases hr : r = 0 + · simp [hr, gaugeNorm_zero] + · have hr_pos : (0 : ℝ) < |r| := abs_pos.mpr hr + -- S_x nonempty ↔ S_{rx} nonempty (when r ≠ 0) + by_cases hne : {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|}.Nonempty + · apply le_antisymm + · -- ≤: gaugeNorm(rx)/|r| ≤ gaugeNorm(x), then multiply + suffices h : gaugeNorm a (r • x) / |r| ≤ gaugeNorm a x from + (div_le_iff₀ hr_pos).mp h |>.trans (le_of_eq (mul_comm _ _)) + apply le_csInf hne + intro d ⟨hd, hle⟩ + rw [div_le_iff₀ hr_pos] + exact (csInf_le (gaugeNorm_bddBelow a (r • x)) + ⟨mul_nonneg hr_pos.le hd, by + rw [abs_smul' x r, mul_smul] + exact smul_le_smul_of_nonneg_left hle hr_pos.le⟩).trans (le_of_eq (mul_comm _ _)) + · -- ≥: for any c in S_{rx}, c/|r| ∈ S_x, so gaugeNorm(x) ≤ c/|r| + obtain ⟨d, hd, hle⟩ := hne + have hne_rx : {c : ℝ | 0 ≤ c ∧ |r • x| ≤ c • |a|}.Nonempty := + ⟨|r| * d, mul_nonneg hr_pos.le hd, by + rw [abs_smul' x r, mul_smul] + exact smul_le_smul_of_nonneg_left hle hr_pos.le⟩ + apply le_csInf hne_rx + intro c ⟨hc, hle'⟩ + calc |r| * gaugeNorm a x + ≤ |r| * (c / |r|) := + mul_le_mul_of_nonneg_left + (csInf_le (gaugeNorm_bddBelow a x) (gaugeNorm_div_mem a hr_pos hc + (by rwa [abs_smul' x r] at hle'))) hr_pos.le + _ = c := by field_simp + · -- Both S_x and S_{rx} empty: both sides are 0 + have hne2 : ¬{c : ℝ | 0 ≤ c ∧ |r • x| ≤ c • |a|}.Nonempty := by + intro ⟨c, hc, hle⟩ + exact hne ⟨c / |r|, gaugeNorm_div_mem a hr_pos hc + (by rwa [abs_smul' x r] at hle)⟩ + simp only [gaugeNorm, Set.not_nonempty_iff_eq_empty.mp hne, + Set.not_nonempty_iff_eq_empty.mp hne2, Real.sInf_empty, mul_zero] + +/-- The gauge norm controls the absolute value: `|x| ≤ ‖x‖_a • |a|` for +`x` in the principal ideal. -/ +theorem abs_le_gaugeNorm_smul_abs [IsVLArchimedean X] {x : X} + (hx : x ∈ principal a) : |x| ≤ gaugeNorm a x • |a| := by + suffices h : (|x| - gaugeNorm a x • |a|)⁺ = 0 by + have := le_posPart (|x| - gaugeNorm a x • |a|) + rw [h] at this; exact sub_nonpos.mp this + apply IsVLArchimedean.eq_zero_of_nonneg_of_forall_nsmul_le (y := |a|) (posPart_nonneg _) + intro n + by_cases hn : n = 0 + · simp [hn] + · have hne : {c : ℝ | 0 ≤ c ∧ |x| ≤ c • |a|}.Nonempty := hx + have hn_pos : (0 : ℝ) < ↑n := Nat.cast_pos.mpr (Nat.pos_of_ne_zero hn) + have hlt : gaugeNorm a x < gaugeNorm a x + 1 / ↑n := + lt_add_of_pos_right _ (div_pos one_pos hn_pos) + obtain ⟨c, ⟨_, hcle⟩, hc_lt⟩ := exists_lt_of_csInf_lt hne hlt + have hstep : |x| - gaugeNorm a x • |a| ≤ (1 / (↑n : ℝ)) • |a| := by + calc |x| - gaugeNorm a x • |a| + ≤ c • |a| - gaugeNorm a x • |a| := sub_le_sub_right hcle _ + _ = (c - gaugeNorm a x) • |a| := (sub_smul c (gaugeNorm a x) |a|).symm + _ ≤ (1 / ↑n) • |a| := + smul_le_smul_of_nonneg_right (by linarith) (abs_nonneg a) + have hpos_le : (|x| - gaugeNorm a x • |a|)⁺ ≤ (1 / (↑n : ℝ)) • |a| := + sup_le hstep (smul_nonneg (div_nonneg one_pos.le hn_pos.le) (abs_nonneg a)) + calc n • (|x| - gaugeNorm a x • |a|)⁺ + ≤ n • ((1 / (↑n : ℝ)) • |a|) := + nsmul_le_nsmul hpos_le (smul_nonneg (div_nonneg one_pos.le hn_pos.le) + (abs_nonneg a)) le_rfl + _ = ((↑n : ℝ) * (1 / ↑n)) • |a| := by + rw [← Nat.cast_smul_eq_nsmul ℝ, smul_smul] + _ = |a| := by rw [mul_one_div_cancel (ne_of_gt hn_pos), one_smul] + +/-- Any admissible constant bounds the gauge norm from above. -/ +theorem gaugeNorm_le_of_abs_le {x : X} {c : ℝ} (hc : 0 ≤ c) + (h : |x| ≤ c • |a|) : gaugeNorm a x ≤ c := + csInf_le ⟨0, fun _ ⟨hd, _⟩ => hd⟩ ⟨hc, h⟩ + +/-- The gauge norm is monotone with respect to `|·|`: the solid-norm +property. -/ +theorem gaugeNorm_mono_abs {x y : X} (hy : y ∈ principal a) (h : |x| ≤ |y|) : + gaugeNorm a x ≤ gaugeNorm a y := by + -- S_y ⊆ S_x, so sInf S_x ≤ sInf S_y + apply le_csInf hy + intro c ⟨hc, hle⟩ + exact csInf_le (gaugeNorm_bddBelow a x) ⟨hc, le_trans h hle⟩ + +/-- In an Archimedean vector lattice the gauge norm is definite: +`gaugeNorm a x = 0 ↔ x = 0` for `x` in the principal ideal of `a`. -/ +theorem gaugeNorm_eq_zero_iff [IsVLArchimedean X] {x : X} + (hx : x ∈ principal a) : gaugeNorm a x = 0 ↔ x = 0 := by + constructor + · intro h + have := abs_le_gaugeNorm_smul_abs a hx + rw [h, zero_smul] at this + exact (abs_eq_zero_iff_zero x).mp (le_antisymm this (abs_nonneg x)) + · intro h; rw [h]; exact gaugeNorm_zero a + +/-- The closed unit ball of the gauge norm is the order interval +`[-|a|, |a|]`. -/ +theorem gaugeNorm_le_one_iff [IsVLArchimedean X] {x : X} (hx : x ∈ principal a) : + gaugeNorm a x ≤ 1 ↔ |x| ≤ |a| := by + constructor + · intro h + calc |x| ≤ gaugeNorm a x • |a| := abs_le_gaugeNorm_smul_abs a hx + _ ≤ 1 • |a| := smul_le_smul_of_nonneg_right h (abs_nonneg a) + _ = |a| := one_smul ℝ |a| + · intro h + exact gaugeNorm_le_of_abs_le a one_pos.le (by rwa [one_smul]) + +/-- If `0 ≤ e ≤ u` then `‖·‖_u ≤ ‖·‖_e` on `I_e`. -/ +theorem gaugeNorm_anti {e u : X} (he : 0 ≤ e) (heu : e ≤ u) + {x : X} (hx : x ∈ principal e) : gaugeNorm u x ≤ gaugeNorm e x := by + -- S_e ⊆ S_u (since |e| = e ≤ u = |u|, so c • |e| ≤ c • |u|) + apply le_csInf hx + intro c ⟨hc, hle⟩ + apply csInf_le (gaugeNorm_bddBelow u x) + exact ⟨hc, le_trans hle (smul_le_smul_of_nonneg_left + (by rwa [abs_of_nonneg he, abs_of_nonneg (le_trans he heu)]) hc)⟩ + +/-! ### Normed vector lattice structure on the principal ideal -/ + +/-- The underlying submodule of the principal ideal. -/ +abbrev principalSubmodule (a : X) : Submodule ℝ X := + (principal a).toSubmodule + +/-- The gauge norm as a `Norm` instance on the principal ideal. -/ +noncomputable instance instNormPrincipal (a : X) : + Norm ↥(principalSubmodule a) where + norm x := gaugeNorm a x.1 + +/-- The principal ideal inherits a lattice structure from `X`. -/ +noncomputable instance instLatticePrincipal (a : X) : + Lattice ↥(principalSubmodule a) where + sup x y := ⟨x.1 ⊔ y.1, (principal a).sup_mem x.2 y.2⟩ + inf x y := ⟨x.1 ⊓ y.1, (principal a).inf_mem x.2 y.2⟩ + le_sup_left := fun x y => show x.1 ≤ x.1 ⊔ y.1 from le_sup_left + le_sup_right := fun x y => show y.1 ≤ x.1 ⊔ y.1 from le_sup_right + sup_le := fun x y z h1 h2 => show x.1 ⊔ y.1 ≤ z.1 from sup_le h1 h2 + inf_le_left := fun x y => show x.1 ⊓ y.1 ≤ x.1 from inf_le_left + inf_le_right := fun x y => show x.1 ⊓ y.1 ≤ y.1 from inf_le_right + le_inf := fun x y z h1 h2 => show x.1 ≤ y.1 ⊓ z.1 from le_inf h1 h2 + +/-- The principal ideal is an ordered additive monoid. -/ +instance instIsOrderedAddMonoidPrincipal (a : X) : + @IsOrderedAddMonoid ↥(principalSubmodule a) + inferInstance (instLatticePrincipal a).toPartialOrder.toPreorder where + add_le_add_left := fun x y (h : x.1 ≤ y.1) z => + show x.1 + z.1 ≤ y.1 + z.1 from add_le_add_left h _ + +/-- In an Archimedean vector lattice, the principal ideal `I_a` with the gauge +norm is a normed additive commutative group. -/ +@[reducible] +noncomputable def principalNormedAddCommGroup [IsVLArchimedean X] + (a : X) : + NormedAddCommGroup ↥(principalSubmodule a) := + NormedAddCommGroup.ofCore (𝕜 := ℝ) { + toCore := { + norm_nonneg := fun x => gaugeNorm_nonneg a x.1 + norm_smul := fun r x => gaugeNorm_smul a r x.1 + norm_triangle := fun x y => gaugeNorm_add_le a x.2 y.2 + } + norm_eq_zero_iff := fun x => (gaugeNorm_eq_zero_iff a x.2).trans + ⟨fun h => Subtype.ext h, fun h => congr_arg Subtype.val h⟩ + } + +/-- In an Archimedean vector lattice, the principal ideal `I_a` with the gauge +norm admits a `VectorLattice` structure. -/ +@[reducible] +noncomputable def principalVectorLattice (a : X) : + @VectorLattice ↥(principalSubmodule a) inferInstance + (instLatticePrincipal a) + (instIsOrderedAddMonoidPrincipal a) where + toModule := (principalSubmodule a).module + smul_le_smul_of_nonneg_left := by + intro c hc x y hxy + change c • x.1 ≤ c • y.1 + exact smul_le_smul_of_nonneg_left hxy hc + +/-- In an Archimedean vector lattice, the principal ideal `I_a` equipped with +the gauge norm is a normed vector lattice. -/ +@[reducible] +noncomputable def principalNormedVectorLattice [IsVLArchimedean X] + (a : X) : + @NormedVectorLattice ↥(principalSubmodule a) + (principalNormedAddCommGroup a) + (instLatticePrincipal a) + (instIsOrderedAddMonoidPrincipal a) := by + letI : NormedAddCommGroup ↥(principalSubmodule a) := principalNormedAddCommGroup a + letI : Lattice ↥(principalSubmodule a) := instLatticePrincipal a + letI : IsOrderedAddMonoid ↥(principalSubmodule a) := instIsOrderedAddMonoidPrincipal a + letI : VectorLattice ↥(principalSubmodule a) := principalVectorLattice a + let solidNorm : HasSolidNorm ↥(principalSubmodule a) := { + solid := by + intro x y h + change gaugeNorm a x.1 ≤ gaugeNorm a y.1 + exact gaugeNorm_mono_abs a y.2 h + } + let normSmul : NormSMulClass ℝ ↥(principalSubmodule a) := { + norm_smul := by + intro r x + change gaugeNorm a (r • x.1) = ‖r‖ * gaugeNorm a x.1 + rw [gaugeNorm_smul a r x.1, Real.norm_eq_abs] + } + exact @NormedVectorLattice.mk ↥(principalSubmodule a) + (principalNormedAddCommGroup a) + (instLatticePrincipal a) + (instIsOrderedAddMonoidPrincipal a) + (principalVectorLattice a) + solidNorm + normSmul + +/-! ### Sum of ideals -/ + +/-- A non-negative element dominated by a sum `u₁ + u₂` of positive elements of +`J₁` and `J₂` can be split accordingly, so it lies in `J₁ + J₂`. -/ +private theorem sum_pos_mem (J₁ J₂ : OrderIdeal X) {v u₁ u₂ : X} + (hu₁ : u₁ ∈ J₁) (hu₂ : u₂ ∈ J₂) (hu₁0 : 0 ≤ u₁) (hu₂0 : 0 ≤ u₂) + (hv0 : 0 ≤ v) (hvle : v ≤ u₁ + u₂) : + v ∈ J₁.toSubmodule + J₂.toSubmodule := by + have hv₁ : v ⊓ u₁ ∈ J₁ := J₁.solid hu₁ (le_inf hv0 hu₁0) inf_le_right + have heq : v - v ⊓ u₁ = (v - u₁)⁺ := by + rw [inf_eq_sub_posPart_sub]; abel + have hv₂ : v - v ⊓ u₁ ∈ J₂ := by + rw [heq] + exact J₂.solid hu₂ (posPart_nonneg _) + (sup_le (sub_le_iff_le_add'.mpr hvle) hu₂0) + refine Submodule.mem_sup.mpr ⟨v ⊓ u₁, hv₁, v - v ⊓ u₁, hv₂, ?_⟩ + abel + +/-- The sum of two order ideals (as submodules) is again an order ideal. -/ +def sum (J₁ J₂ : OrderIdeal X) : OrderIdeal X := + ofSolid (J₁.toSubmodule + J₂.toSubmodule) <| by + intro x y hx hyx + obtain ⟨x₁, hx₁, x₂, hx₂, rfl⟩ := Submodule.mem_sup.mp hx + -- `|y| ≤ |x₁| + |x₂|`; split `y⁺` and `y⁻` separately using `sum_pos_mem`. + have habs : |y| ≤ |x₁| + |x₂| := le_trans hyx (abs_add_le x₁ x₂) + have h_pos_le : y⁺ ≤ |x₁| + |x₂| := + le_trans (sup_le (le_abs_self y) (abs_nonneg y)) habs + have h_neg_le : y⁻ ≤ |x₁| + |x₂| := + le_trans (sup_le (neg_le_abs y) (abs_nonneg y)) habs + have hpos : y⁺ ∈ J₁.toSubmodule + J₂.toSubmodule := + sum_pos_mem J₁ J₂ (J₁.abs_mem hx₁) (J₂.abs_mem hx₂) + (abs_nonneg _) (abs_nonneg _) (posPart_nonneg _) h_pos_le + have hneg : y⁻ ∈ J₁.toSubmodule + J₂.toSubmodule := + sum_pos_mem J₁ J₂ (J₁.abs_mem hx₁) (J₂.abs_mem hx₂) + (abs_nonneg _) (abs_nonneg _) (negPart_nonneg _) h_neg_le + have := (J₁.toSubmodule + J₂.toSubmodule).sub_mem hpos hneg + rwa [posPart_sub_negPart] at this + +/-- The underlying submodule of `sum J₁ J₂` is `J₁.toSubmodule + J₂.toSubmodule`. -/ +@[simp] +theorem sum_toSubmodule (J₁ J₂ : OrderIdeal X) : + (sum J₁ J₂).toSubmodule = J₁.toSubmodule + J₂.toSubmodule := rfl + +/-- **Positive decomposition** in the sum of two ideals: every non-negative +element of `J₁ + J₂` admits a splitting `y = y₁ + y₂` with `0 ≤ y₁ ∈ J₁` and +`0 ≤ y₂ ∈ J₂`. -/ +theorem exists_sum_decomp_nonneg (J₁ J₂ : OrderIdeal X) {y : X} + (hy : y ∈ J₁.toSubmodule + J₂.toSubmodule) (hy0 : 0 ≤ y) : + ∃ y₁ y₂ : X, y₁ ∈ J₁ ∧ y₂ ∈ J₂ ∧ y₁ + y₂ = y ∧ 0 ≤ y₁ ∧ 0 ≤ y₂ := by + obtain ⟨u₁, hu₁, u₂, hu₂, rfl⟩ := Submodule.mem_sup.mp hy + have hau₁ : |u₁| ∈ J₁ := J₁.abs_mem hu₁ + have hau₂ : |u₂| ∈ J₂ := J₂.abs_mem hu₂ + have hau₁_nn : 0 ≤ |u₁| := abs_nonneg _ + have hau₂_nn : 0 ≤ |u₂| := abs_nonneg _ + have hyle : u₁ + u₂ ≤ |u₁| + |u₂| := + add_le_add (le_abs_self u₁) (le_abs_self u₂) + refine ⟨(u₁ + u₂) ⊓ |u₁|, (u₁ + u₂) - (u₁ + u₂) ⊓ |u₁|, + J₁.solid hau₁ (le_inf hy0 hau₁_nn) inf_le_right, + ?_, by abel, le_inf hy0 hau₁_nn, ?_⟩ + · have heq : (u₁ + u₂) - (u₁ + u₂) ⊓ |u₁| = ((u₁ + u₂) - |u₁|)⁺ := by + rw [inf_eq_sub_posPart_sub]; abel + rw [heq] + exact J₂.solid hau₂ (posPart_nonneg _) + (sup_le (sub_le_iff_le_add'.mpr hyle) hau₂_nn) + · have heq : (u₁ + u₂) - (u₁ + u₂) ⊓ |u₁| = ((u₁ + u₂) - |u₁|)⁺ := by + rw [inf_eq_sub_posPart_sub]; abel + rw [heq]; exact posPart_nonneg _ + +/-- **Bounded decomposition** in the sum of two ideals: every element of +`J₁ + J₂` admits a splitting `z = a + b` with `a ∈ J₁`, `b ∈ J₂` and the +lattice estimates `|a| ≤ |z|`, `|b| ≤ |z|`. -/ +theorem exists_sum_decomp (J₁ J₂ : OrderIdeal X) {z : X} + (hz : z ∈ J₁.toSubmodule + J₂.toSubmodule) : + ∃ a b : X, a ∈ J₁ ∧ b ∈ J₂ ∧ a + b = z ∧ |a| ≤ |z| ∧ |b| ≤ |z| := by + obtain ⟨u₁, hu₁, u₂, hu₂, rfl⟩ := Submodule.mem_sup.mp hz + have habs : |u₁ + u₂| ≤ |u₁| + |u₂| := abs_add_le u₁ u₂ + -- Positive part split + have hxp_le : (u₁ + u₂)⁺ ≤ |u₁| + |u₂| := + le_trans (sup_le (le_abs_self _) (abs_nonneg _)) habs + let ap := (u₁ + u₂)⁺ ⊓ |u₁| + have hap_nn : 0 ≤ ap := le_inf (posPart_nonneg _) (abs_nonneg _) + have hap_le_xp : ap ≤ (u₁ + u₂)⁺ := inf_le_left + have hap_mem : ap ∈ J₁ := J₁.solid (J₁.abs_mem hu₁) hap_nn inf_le_right + let bp := (u₁ + u₂)⁺ - ap + have hbp_eq : bp = ((u₁ + u₂)⁺ - |u₁|)⁺ := by + change (u₁ + u₂)⁺ - (u₁ + u₂)⁺ ⊓ |u₁| = ((u₁ + u₂)⁺ - |u₁|)⁺ + rw [inf_eq_sub_posPart_sub]; abel + have hbp_nn : 0 ≤ bp := by rw [hbp_eq]; exact posPart_nonneg _ + have hbp_le_xp : bp ≤ (u₁ + u₂)⁺ := sub_le_self _ hap_nn + have hbp_mem : bp ∈ J₂ := by + rw [hbp_eq] + exact J₂.solid (J₂.abs_mem hu₂) (posPart_nonneg _) + (sup_le (sub_le_iff_le_add'.mpr hxp_le) (abs_nonneg _)) + have hab_p_sum : ap + bp = (u₁ + u₂)⁺ := by + change ap + ((u₁ + u₂)⁺ - ap) = _ + abel + -- Negative part split + have hxn_le : (u₁ + u₂)⁻ ≤ |u₁| + |u₂| := + le_trans (sup_le (neg_le_abs _) (abs_nonneg _)) habs + let an := (u₁ + u₂)⁻ ⊓ |u₁| + have han_nn : 0 ≤ an := le_inf (negPart_nonneg _) (abs_nonneg _) + have han_le_xn : an ≤ (u₁ + u₂)⁻ := inf_le_left + have han_mem : an ∈ J₁ := J₁.solid (J₁.abs_mem hu₁) han_nn inf_le_right + let bn := (u₁ + u₂)⁻ - an + have hbn_eq : bn = ((u₁ + u₂)⁻ - |u₁|)⁺ := by + change (u₁ + u₂)⁻ - (u₁ + u₂)⁻ ⊓ |u₁| = ((u₁ + u₂)⁻ - |u₁|)⁺ + rw [inf_eq_sub_posPart_sub]; abel + have hbn_nn : 0 ≤ bn := by rw [hbn_eq]; exact posPart_nonneg _ + have hbn_le_xn : bn ≤ (u₁ + u₂)⁻ := sub_le_self _ han_nn + have hbn_mem : bn ∈ J₂ := by + rw [hbn_eq] + exact J₂.solid (J₂.abs_mem hu₂) (posPart_nonneg _) + (sup_le (sub_le_iff_le_add'.mpr hxn_le) (abs_nonneg _)) + have hab_n_sum : an + bn = (u₁ + u₂)⁻ := by + change an + ((u₁ + u₂)⁻ - an) = _ + abel + -- Assemble + refine ⟨ap - an, bp - bn, + J₁.toSubmodule.sub_mem hap_mem han_mem, + J₂.toSubmodule.sub_mem hbp_mem hbn_mem, ?_, ?_, ?_⟩ + · calc ap - an + (bp - bn) + = (ap + bp) - (an + bn) := by abel + _ = (u₁ + u₂)⁺ - (u₁ + u₂)⁻ := by rw [hab_p_sum, hab_n_sum] + _ = u₁ + u₂ := posPart_sub_negPart _ + · calc |ap - an| + = |ap + (-an)| := by rw [sub_eq_add_neg] + _ ≤ |ap| + |(-an)| := abs_add_le _ _ + _ = ap + an := by rw [abs_of_nonneg hap_nn, abs_neg, abs_of_nonneg han_nn] + _ ≤ (u₁ + u₂)⁺ + (u₁ + u₂)⁻ := add_le_add hap_le_xp han_le_xn + _ = |u₁ + u₂| := posPart_add_negPart _ + · calc |bp - bn| + = |bp + (-bn)| := by rw [sub_eq_add_neg] + _ ≤ |bp| + |(-bn)| := abs_add_le _ _ + _ = bp + bn := by rw [abs_of_nonneg hbp_nn, abs_neg, abs_of_nonneg hbn_nn] + _ ≤ (u₁ + u₂)⁺ + (u₁ + u₂)⁻ := add_le_add hbp_le_xp hbn_le_xn + _ = |u₁ + u₂| := posPart_add_negPart _ + +/-! ### Complete lattice structure -/ + +/-- The whole space `X` is an order ideal. -/ +instance : Top (OrderIdeal X) where + top := + { toSubmodule := ⊤ + sup_mem' := fun _ _ => Submodule.mem_top + solid' := fun _ _ _ => Submodule.mem_top } + +@[simp] theorem mem_top {x : X} : x ∈ (⊤ : OrderIdeal X) := Submodule.mem_top + +/-- The trivial ideal `{0}` is an order ideal. -/ +instance : Bot (OrderIdeal X) where + bot := + { toSubmodule := ⊥ + sup_mem' := fun {x y} hx hy => by + have hx' : x = 0 := (Submodule.mem_bot ℝ).mp hx + have hy' : y = 0 := (Submodule.mem_bot ℝ).mp hy + rw [hx', hy', sup_idem]; exact Submodule.zero_mem _ + solid' := fun {x y} hx hy0 hyx => by + have hx' : x = 0 := (Submodule.mem_bot ℝ).mp hx + rw [hx'] at hyx + exact (Submodule.mem_bot ℝ).mpr (le_antisymm hyx hy0) } + +@[simp] theorem mem_bot {x : X} : x ∈ (⊥ : OrderIdeal X) ↔ x = 0 := + Submodule.mem_bot ℝ + +/-- Order ideals of `X`, ordered by inclusion, form a **complete lattice**. +Binary joins are given by the (Minkowski) sum `sum`, binary meets and arbitrary +infima are given by intersection, the bottom element is the trivial ideal +`{0}`, and the top element is the whole space. -/ +instance : CompleteLattice (OrderIdeal X) where + __ := (inferInstance : PartialOrder (OrderIdeal X)) + sup := sum + inf := OrderIdeal.inf + top := ⊤ + bot := ⊥ + sInf := sInf + sSup S := sInf {K : OrderIdeal X | ∀ I ∈ S, I ≤ K} + le_top := fun _ _ _ => Submodule.mem_top + bot_le := fun J x hx => by + have hx' : x ∈ (⊥ : Submodule ℝ X) := hx + have : x = 0 := (Submodule.mem_bot ℝ).mp hx' + exact this ▸ J.toSubmodule.zero_mem + le_sup_left := fun J₁ J₂ x hx => + Submodule.mem_sup.mpr ⟨x, hx, 0, J₂.toSubmodule.zero_mem, add_zero x⟩ + le_sup_right := fun J₁ J₂ x hx => + Submodule.mem_sup.mpr ⟨0, J₁.toSubmodule.zero_mem, x, hx, zero_add x⟩ + sup_le := fun J₁ J₂ K hJ₁ hJ₂ x hx => by + obtain ⟨x₁, hx₁, x₂, hx₂, rfl⟩ := Submodule.mem_sup.mp hx + exact K.toSubmodule.add_mem (hJ₁ hx₁) (hJ₂ hx₂) + inf_le_left := fun _ _ _ hx => hx.1 + inf_le_right := fun _ _ _ hx => hx.2 + le_inf := fun _ _ _ h₁ h₂ _ hx => ⟨h₁ hx, h₂ hx⟩ + isLUB_sSup := fun S => by + refine ⟨?_, ?_⟩ + · intro J hJ x hx + rw [mem_sInf] + intro K hK + exact hK J hJ hx + · intro J hJ x hx + rw [mem_sInf] at hx + exact hx J hJ + isGLB_sInf := fun S => by + refine ⟨?_, ?_⟩ + · intro J hJ x hx + rw [mem_sInf] at hx + exact hx J hJ + · intro J hJ x hx + rw [mem_sInf] + intro K hK + exact hJ hK hx + +@[simp] theorem sup_toSubmodule (J₁ J₂ : OrderIdeal X) : + (J₁ ⊔ J₂).toSubmodule = J₁.toSubmodule + J₂.toSubmodule := rfl + +@[simp] theorem inf_toSubmodule (J₁ J₂ : OrderIdeal X) : + (J₁ ⊓ J₂).toSubmodule = J₁.toSubmodule ⊓ J₂.toSubmodule := rfl + +/-! ### Strong order units and the principal ideal -/ + +/-- An element is a strong order unit precisely when it is non-negative and the +principal ideal it generates is the whole space. -/ +theorem strongOrderUnit_iff_principal_eq_top {e : X} : + StrongOrderUnit e ↔ 0 ≤ e ∧ principal e = ⊤ := by + refine ⟨fun ⟨he, hdom⟩ => ⟨he, ?_⟩, fun ⟨he, htop⟩ => ⟨he, fun x => ?_⟩⟩ + · refine SetLike.ext fun x => iff_of_true ?_ mem_top + obtain ⟨c, hc, hxc⟩ := hdom x + exact ⟨c, hc, by rwa [abs_of_nonneg he]⟩ + · have hx : x ∈ principal e := htop ▸ mem_top + obtain ⟨c, hc, hxc⟩ := hx + exact ⟨c, hc, by rwa [abs_of_nonneg he] at hxc⟩ + +/-! ### Existence of proper non-trivial ideals -/ + +/-- Two non-negative lattice-disjoint elements cannot sit in a common principal +ideal: if `0 ≤ p, q` with `p ⊓ q = 0` and `q ∈ principal p`, then `q = 0`. -/ +private lemma eq_zero_of_mem_principal_disjoint {p q : X} (hp : 0 ≤ p) + (hq : 0 ≤ q) (hpq : p ⊓ q = 0) (hq_in : q ∈ principal p) : q = 0 := by + obtain ⟨c, hc, hle⟩ := hq_in + rw [abs_of_nonneg hq, abs_of_nonneg hp] at hle + rcases le_or_gt 1 c with h1 | h1 + · have hq_le_cq : q ≤ c • q := by + calc q = (1 : ℝ) • q := (one_smul ℝ q).symm + _ ≤ c • q := smul_le_smul_of_nonneg_right h1 hq + have hboth : q ≤ c • p ⊓ c • q := le_inf hle hq_le_cq + rw [← nonneg_smul_inf p q c (le_trans zero_le_one h1), hpq, smul_zero] at hboth + exact le_antisymm hboth hq + · have hcp_le_p : c • p ≤ p := by + calc c • p ≤ (1 : ℝ) • p := smul_le_smul_of_nonneg_right h1.le hp + _ = p := one_smul ℝ p + have hq_le_p : q ≤ p := le_trans hle hcp_le_p + have : p ⊓ q = q := inf_eq_right.mpr hq_le_p + rwa [this] at hpq + +/-- If the real dimension of `X` is strictly greater than one, then `X` admits +an order ideal that is **neither trivial nor the whole space**. -/ +theorem exists_proper_nontrivial [IsVLArchimedean X] (h : 1 < Module.rank ℝ X) : + ∃ J : OrderIdeal X, J ≠ ⊥ ∧ J ≠ ⊤ := by + obtain ⟨u, v, hu, hv, huv⟩ := exists_pair_ne_zero_isVLDisjoint h + have habs_u_nn : 0 ≤ |u| := abs_nonneg u + have habs_v_nn : 0 ≤ |v| := abs_nonneg v + have habs_u_nz : |u| ≠ 0 := fun h => hu ((abs_eq_zero_iff_zero u).mp h) + have habs_v_nz : |v| ≠ 0 := fun h => hv ((abs_eq_zero_iff_zero v).mp h) + refine ⟨principal (|u|), ?_, ?_⟩ + · intro heq + have : (|u| : X) ∈ (⊥ : OrderIdeal X) := heq ▸ self_mem_principal |u| + exact habs_u_nz (mem_bot.mp this) + · intro heq + have hv_mem : (|v| : X) ∈ principal (|u|) := heq ▸ mem_top + exact habs_v_nz + (eq_zero_of_mem_principal_disjoint habs_u_nn habs_v_nn huv hv_mem) + +/-! ### Closure of an ideal in a normed vector lattice -/ + +section Closure + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +/-- The topological closure of the underlying submodule of an order ideal is +itself solid: if `x` lies in the closure and `|y| ≤ |x|`, then `y` lies in the +closure. -/ +theorem topologicalClosure_solid (J : OrderIdeal X) : + ∀ x y : X, x ∈ J.toSubmodule.topologicalClosure → |y| ≤ |x| → + y ∈ J.toSubmodule.topologicalClosure := by + intro x y hx hy_abs + have hx' : x ∈ closure (J.toSubmodule : Set X) := by + rwa [← Submodule.topologicalClosure_coe] + obtain ⟨xn, hxn_mem, hxn_lim⟩ := mem_closure_iff_seq_limit.mp hx' + -- Truncated sequence yₙ = (y ⊔ -|xₙ|) ⊓ |xₙ|, which lies in J and converges to y. + set yn : ℕ → X := fun n => (y ⊔ (-|xn n|)) ⊓ |xn n| with hyn_def + have habs_nn : ∀ n, (0 : X) ≤ |xn n| := fun _ => abs_nonneg _ + have hyn_mem : ∀ n, yn n ∈ J.toSubmodule := by + intro n + have habs_mem : |xn n| ∈ J := J.abs_mem (hxn_mem n) + have h_le : yn n ≤ |xn n| := inf_le_right + have h_neg_le : -|xn n| ≤ |xn n| := + le_trans (neg_nonpos_of_nonneg (habs_nn n)) (habs_nn n) + have h_ge : -|xn n| ≤ yn n := le_inf le_sup_right h_neg_le + have h_abs_yn : |yn n| ≤ |xn n| := by + rw [abs_le']; exact ⟨h_le, by rwa [neg_le]⟩ + have : |yn n| ∈ J := J.solid habs_mem (abs_nonneg _) h_abs_yn + exact J.mem_of_abs_mem this + -- Continuity of `|·|`, `⊔`, `⊓` makes `yn → y`. + have hcont_abs : Continuous (|·| : X → X) := + NormedVectorLattice.lipschitzWith_abs.continuous + have habs_tendsto : Filter.Tendsto (fun n => |xn n|) Filter.atTop (nhds |x|) := + (hcont_abs.tendsto _).comp hxn_lim + have hneg_tendsto : Filter.Tendsto (fun n => -|xn n|) Filter.atTop (nhds (-|x|)) := + habs_tendsto.neg + have hsup_tendsto : + Filter.Tendsto (fun n => y ⊔ (-|xn n|)) Filter.atTop (nhds (y ⊔ (-|x|))) := + (NormedVectorLattice.continuous_sup.tendsto _).comp + (tendsto_const_nhds.prodMk_nhds hneg_tendsto) + have hyn_tendsto : + Filter.Tendsto yn Filter.atTop (nhds ((y ⊔ (-|x|)) ⊓ |x|)) := + (NormedVectorLattice.continuous_inf.tendsto _).comp + (hsup_tendsto.prodMk_nhds habs_tendsto) + have h_le_abs : y ≤ |x| := le_trans (le_abs_self y) hy_abs + have h_neg_le : -|x| ≤ y := by rw [neg_le]; exact le_trans (neg_le_abs y) hy_abs + have hy_eq : (y ⊔ (-|x|)) ⊓ |x| = y := by + rw [sup_eq_left.mpr h_neg_le, inf_eq_left.mpr h_le_abs] + rw [hy_eq] at hyn_tendsto + have hy_in_closure : y ∈ closure (J.toSubmodule : Set X) := + mem_closure_of_tendsto hyn_tendsto (Filter.Eventually.of_forall hyn_mem) + rwa [← Submodule.topologicalClosure_coe] at hy_in_closure + +/-- The **norm closure** of an order ideal `J` in a normed vector lattice is +again an order ideal, whose underlying submodule is the topological closure of +`J.toSubmodule`. -/ +def topologicalClosure (J : OrderIdeal X) : OrderIdeal X := + ofSolid J.toSubmodule.topologicalClosure (topologicalClosure_solid J) + +@[simp] +theorem topologicalClosure_toSubmodule (J : OrderIdeal X) : + (topologicalClosure J).toSubmodule = J.toSubmodule.topologicalClosure := rfl + +end Closure + +end OrderIdeal + +/-- A **closed order ideal** of a Banach lattice is an order ideal whose +underlying set is closed in the norm topology. -/ +structure ClosedOrderIdeal (X : Type*) [NormedAddCommGroup X] + [Lattice X] [IsOrderedAddMonoid X] [BanachLattice X] + extends OrderIdeal X where + isClosed' : IsClosed (toOrderIdeal : Set X) + +namespace ClosedOrderIdeal + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [BanachLattice X] + +instance : SetLike (ClosedOrderIdeal X) X where + coe J := J.toOrderIdeal + coe_injective p q h := by + cases p; cases q; congr + exact SetLike.coe_injective h + +/-- A closed order ideal is closed as a subset of `X`. -/ +theorem isClosed (J : ClosedOrderIdeal X) : IsClosed (J : Set X) := + J.isClosed' + +/-- Closed order ideals form a partial order under inclusion. -/ +instance : PartialOrder (ClosedOrderIdeal X) := + .ofSetLike (ClosedOrderIdeal X) X + +/-- The intersection of two closed order ideals is a closed order ideal. -/ +def inf (J₁ J₂ : ClosedOrderIdeal X) : ClosedOrderIdeal X where + toOrderIdeal := J₁.toOrderIdeal ⊓ J₂.toOrderIdeal + isClosed' := J₁.isClosed.inter J₂.isClosed + +/-- **Norm-bounded decomposition** in the sum of two ideals of a normed vector +lattice: every element of `J₁ + J₂` splits as `z = a + b` with `a ∈ J₁`, +`b ∈ J₂` and `‖a‖ ≤ ‖z‖`, `‖b‖ ≤ ‖z‖`. -/ +private theorem exists_sum_decomp_norm (J₁ J₂ : OrderIdeal X) {z : X} + (hz : z ∈ J₁.toSubmodule + J₂.toSubmodule) : + ∃ a b : X, a ∈ J₁ ∧ b ∈ J₂ ∧ a + b = z ∧ ‖a‖ ≤ ‖z‖ ∧ ‖b‖ ≤ ‖z‖ := by + obtain ⟨a, b, ha, hb, hsum, habs_a, habs_b⟩ := OrderIdeal.exists_sum_decomp J₁ J₂ hz + refine ⟨a, b, ha, hb, hsum, ?_, ?_⟩ + · rw [← norm_abs_eq_norm z]; exact norm_le_norm_of_abs_le_abs (by rwa [abs_abs]) + · rw [← norm_abs_eq_norm z]; exact norm_le_norm_of_abs_le_abs (by rwa [abs_abs]) + +/-- The sum of two closed order ideals in a Banach lattice is again closed. -/ +theorem isClosed_sum {J₁ J₂ : OrderIdeal X} + (h₁ : IsClosed (J₁ : Set X)) (h₂ : IsClosed (J₂ : Set X)) : + IsClosed ((OrderIdeal.sum J₁ J₂ : OrderIdeal X) : Set X) := by + rw [← isSeqClosed_iff_isClosed] + intro z_seq z hz_mem hz_lim + -- Extract a subsequence whose consecutive distances are summable. + have hCauchy : CauchySeq z_seq := hz_lim.cauchySeq + obtain ⟨φ, hφ_mono, hφ_sum⟩ := + Metric.exists_subseq_summable_dist_of_cauchySeq z_seq hCauchy + -- The subsequence still converges to z. + have hsub_lim : Filter.Tendsto (z_seq ∘ φ) Filter.atTop (nhds z) := + hz_lim.comp hφ_mono.tendsto_atTop + -- Differences along the subsequence. + set w : ℕ → X := fun k => z_seq (φ (k + 1)) - z_seq (φ k) with hw_def + have hw_norm : ∀ k, ‖w k‖ = dist (z_seq (φ (k + 1))) (z_seq (φ k)) := by + intro k; rw [hw_def, dist_eq_norm] + have hw_summable : Summable fun k => ‖w k‖ := by + simpa [hw_norm] using hφ_sum + have hw_mem : ∀ k, w k ∈ J₁.toSubmodule + J₂.toSubmodule := fun k => + (J₁.toSubmodule + J₂.toSubmodule).sub_mem (hz_mem _) (hz_mem _) + -- Decompose each difference with norm bounds. + choose a b ha hb hab ha_norm hb_norm using + fun k => exists_sum_decomp_norm J₁ J₂ (hw_mem k) + have ha_summable : Summable fun k => ‖a k‖ := + hw_summable.of_nonneg_of_le (fun _ => norm_nonneg _) ha_norm + have hb_summable : Summable fun k => ‖b k‖ := + hw_summable.of_nonneg_of_le (fun _ => norm_nonneg _) hb_norm + have ha_sum : Summable a := ha_summable.of_norm + have hb_sum : Summable b := hb_summable.of_norm + obtain ⟨A, hA_hasSum⟩ := ha_sum + obtain ⟨B, hB_hasSum⟩ := hb_sum + -- The partial sums of `a` live in the closed ideal `J₁`, hence so does `A`. + have hA_mem : A ∈ J₁ := + h₁.mem_of_tendsto hA_hasSum + (Filter.Eventually.of_forall fun s => + J₁.toSubmodule.sum_mem (fun k _ => ha k)) + have hB_mem : B ∈ J₂ := + h₂.mem_of_tendsto hB_hasSum + (Filter.Eventually.of_forall fun s => + J₂.toSubmodule.sum_mem (fun k _ => hb k)) + -- `w k = a k + b k`, so `HasSum w (A + B)`. + have hw_hasSum : HasSum w (A + B) := by + have : HasSum (fun k => a k + b k) (A + B) := hA_hasSum.add hB_hasSum + convert this using 1 + funext k; exact (hab k).symm + -- Telescoping: partial sums of `w` tend to `z - z_seq (φ 0)`. + have htelescope : Filter.Tendsto + (fun n : ℕ => ∑ k ∈ Finset.range n, w k) Filter.atTop + (nhds (z - z_seq (φ 0))) := by + have hsum_eq : ∀ n, (∑ k ∈ Finset.range n, w k) + = z_seq (φ n) - z_seq (φ 0) := by + intro n + simpa [hw_def] using + Finset.sum_range_sub (fun k => z_seq (φ k)) n + simp only [hsum_eq] + exact hsub_lim.sub_const _ + -- Identify the two limits of the partial sums. + have hAB_eq : A + B = z - z_seq (φ 0) := + tendsto_nhds_unique hw_hasSum.tendsto_sum_nat htelescope + have hz_eq : z = z_seq (φ 0) + (A + B) := by rw [hAB_eq]; abel + change z ∈ (J₁.toSubmodule + J₂.toSubmodule : Submodule ℝ X) + rw [hz_eq] + exact (J₁.toSubmodule + J₂.toSubmodule).add_mem + (hz_mem (φ 0)) + (Submodule.mem_sup.mpr ⟨A, hA_mem, B, hB_mem, rfl⟩) + +/-- The sum of two closed order ideals of a Banach lattice is again a closed +order ideal. -/ +def sup (J₁ J₂ : ClosedOrderIdeal X) : ClosedOrderIdeal X where + toOrderIdeal := OrderIdeal.sum J₁.toOrderIdeal J₂.toOrderIdeal + isClosed' := isClosed_sum J₁.isClosed J₂.isClosed + +/-- The arbitrary intersection of a family of closed order ideals is a closed +order ideal. -/ +def sInf (S : Set (ClosedOrderIdeal X)) : ClosedOrderIdeal X where + toOrderIdeal := InfSet.sInf ((fun J : ClosedOrderIdeal X => J.toOrderIdeal) '' S) + isClosed' := by + have h : ((InfSet.sInf ((fun J : ClosedOrderIdeal X => J.toOrderIdeal) '' S) : + OrderIdeal X) : Set X) = + ⋂ J ∈ S, (J : Set X) := by + ext x + rw [Set.mem_iInter₂] + exact OrderIdeal.mem_sInf.trans + ⟨fun h J hJ => h _ ⟨J, hJ, rfl⟩, by rintro h _ ⟨J, hJ, rfl⟩; exact h J hJ⟩ + rw [show ((InfSet.sInf ((fun J : ClosedOrderIdeal X => J.toOrderIdeal) '' S) : + OrderIdeal X) : Set X) = + ⋂ J ∈ S, (J : Set X) from h] + exact isClosed_biInter fun J _ => J.isClosed + +/-- Closed order ideals of a Banach lattice form a **lattice** under inclusion, +with binary meets given by intersection and binary joins by the sum. -/ +instance : Lattice (ClosedOrderIdeal X) where + sup := sup + inf := inf + le_sup_left := fun J₁ J₂ x hx => by + change x ∈ OrderIdeal.sum J₁.toOrderIdeal J₂.toOrderIdeal + exact Submodule.mem_sup.mpr ⟨x, hx, 0, J₂.toSubmodule.zero_mem, add_zero x⟩ + le_sup_right := fun J₁ J₂ x hx => by + change x ∈ OrderIdeal.sum J₁.toOrderIdeal J₂.toOrderIdeal + exact Submodule.mem_sup.mpr ⟨0, J₁.toSubmodule.zero_mem, x, hx, zero_add x⟩ + sup_le := fun J₁ J₂ K hJ₁ hJ₂ x hx => by + obtain ⟨x₁, hx₁, x₂, hx₂, rfl⟩ := Submodule.mem_sup.mp hx + exact K.toSubmodule.add_mem (hJ₁ hx₁) (hJ₂ hx₂) + inf_le_left := fun _ _ _ hx => hx.1 + inf_le_right := fun _ _ _ hx => hx.2 + le_inf := fun _ _ _ h₁ h₂ _ hx => ⟨h₁ hx, h₂ hx⟩ + +/-- Closed order ideals of a Banach lattice admit **arbitrary intersections**: +they form a complete semilattice for the `⊓` operation. -/ +instance : InfSet (ClosedOrderIdeal X) where + sInf := sInf + +/-- Membership in an arbitrary intersection of closed order ideals. -/ +@[simp] theorem mem_sInf {S : Set (ClosedOrderIdeal X)} {x : X} : + x ∈ (InfSet.sInf S : ClosedOrderIdeal X) ↔ ∀ J ∈ S, x ∈ J := by + change x ∈ (InfSet.sInf ((fun J : ClosedOrderIdeal X => J.toOrderIdeal) '' S) : OrderIdeal X) ↔ _ + rw [OrderIdeal.mem_sInf] + refine ⟨fun h J hJ => h _ ⟨J, hJ, rfl⟩, ?_⟩ + rintro h _ ⟨J, hJ, rfl⟩; exact h J hJ + +/-- The underlying submodule of a binary meet is the intersection of the +underlying submodules. -/ +@[simp] theorem inf_toSubmodule (J₁ J₂ : ClosedOrderIdeal X) : + (J₁ ⊓ J₂).toSubmodule = J₁.toSubmodule ⊓ J₂.toSubmodule := rfl + +/-- The underlying submodule of a binary join is the sum of the underlying +submodules. -/ +@[simp] theorem sup_toSubmodule (J₁ J₂ : ClosedOrderIdeal X) : + (J₁ ⊔ J₂).toSubmodule = J₁.toSubmodule + J₂.toSubmodule := rfl + +end ClosedOrderIdeal diff --git a/LeanPool/OrderClosures/BanLat/Substructures/Sublattice.lean b/LeanPool/OrderClosures/BanLat/Substructures/Sublattice.lean new file mode 100644 index 0000000000..51196d775c --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Substructures/Sublattice.lean @@ -0,0 +1,935 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Disjoint +public import LeanPool.OrderClosures.BanLat.LLexpr +public import LeanPool.OrderClosures.BanLat.Normed +public import Mathlib.Algebra.Group.Pointwise.Set.Basic +public import Mathlib.Geometry.Convex.Cone.Pointed +public import Mathlib.Order.Sublattice +public import Mathlib.Order.SupClosed + + +/-! +# Sublattices of vector lattices + +A **vector sublattice** of a vector lattice is a linear subspace closed under the lattice +operations. Since all lattice operations are expressible in terms of each other, it suffices +that the subspace be closed under any one operation — for example, `⊔` or `|·|`. The key +characterisation proved here is that closure under absolute value is equivalent to the +sublattice property. The file also constructs generated sublattices, describes +them in terms of sup- and inf-closures, and records the induced normed vector +lattice structure on closed sublattices. +-/ + +@[expose] public section + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-! ### Sup- and inf-closure of a pointed cone + +In a vector lattice, the sup-closure and inf-closure of a pointed cone +`C ⊆ X` are again pointed cones. -/ + +namespace PointedCone + +omit [VectorLattice X] in +/-- If `s` is closed under addition, so is its sup-closure. -/ +theorem add_mem_supClosure_of_addClosed {s : Set X} + (hadd : ∀ ⦃a⦄, a ∈ s → ∀ ⦃b⦄, b ∈ s → a + b ∈ s) + {x y : X} (hx : x ∈ _root_.supClosure s) (hy : y ∈ _root_.supClosure s) : + x + y ∈ _root_.supClosure s := by + have step : ∀ a ∈ s, ∀ b ∈ _root_.supClosure s, a + b ∈ _root_.supClosure s := by + intro a ha b hb + have h_sc : SupClosed {c : X | a + c ∈ _root_.supClosure s} := fun u hu v hv => by + change a + (u ⊔ v) ∈ _root_.supClosure s + rw [add_sup]; exact supClosed_supClosure hu hv + have hsub : s ⊆ {c : X | a + c ∈ _root_.supClosure s} := + fun c hc => subset_supClosure (hadd ha hc) + exact supClosure_min hsub h_sc hb + have h_sc : SupClosed {c : X | c + y ∈ _root_.supClosure s} := fun u hu v hv => by + change (u ⊔ v) + y ∈ _root_.supClosure s + rw [sup_add]; exact supClosed_supClosure hu hv + have hsub : s ⊆ {c : X | c + y ∈ _root_.supClosure s} := + fun c hc => step c hc y hy + exact supClosure_min hsub h_sc hx + +/-- If `s` is closed under non-negative scaling, so is its sup-closure. -/ +theorem smul_mem_supClosure_of_smulClosed {s : Set X} + (hsmul : ∀ ⦃a : ℝ⦄, 0 ≤ a → ∀ ⦃x⦄, x ∈ s → a • x ∈ s) + {a : ℝ} (ha : 0 ≤ a) {x : X} (hx : x ∈ _root_.supClosure s) : + a • x ∈ _root_.supClosure s := by + have h_sc : SupClosed {c : X | a • c ∈ _root_.supClosure s} := fun u hu v hv => by + change a • (u ⊔ v) ∈ _root_.supClosure s + rw [nonneg_smul_sup u v a ha]; exact supClosed_supClosure hu hv + have hsub : s ⊆ {c : X | a • c ∈ _root_.supClosure s} := + fun c hc => subset_supClosure (hsmul ha hc) + exact supClosure_min hsub h_sc hx + +omit [VectorLattice X] in +/-- If `s` is closed under addition, so is its inf-closure. -/ +theorem add_mem_infClosure_of_addClosed {s : Set X} + (hadd : ∀ ⦃a⦄, a ∈ s → ∀ ⦃b⦄, b ∈ s → a + b ∈ s) + {x y : X} (hx : x ∈ _root_.infClosure s) (hy : y ∈ _root_.infClosure s) : + x + y ∈ _root_.infClosure s := by + have step : ∀ a ∈ s, ∀ b ∈ _root_.infClosure s, a + b ∈ _root_.infClosure s := by + intro a ha b hb + have h_ic : InfClosed {c : X | a + c ∈ _root_.infClosure s} := fun u hu v hv => by + change a + (u ⊓ v) ∈ _root_.infClosure s + rw [add_inf]; exact infClosed_infClosure hu hv + have hsub : s ⊆ {c : X | a + c ∈ _root_.infClosure s} := + fun c hc => subset_infClosure (hadd ha hc) + exact infClosure_min hsub h_ic hb + have h_ic : InfClosed {c : X | c + y ∈ _root_.infClosure s} := fun u hu v hv => by + change (u ⊓ v) + y ∈ _root_.infClosure s + rw [inf_add]; exact infClosed_infClosure hu hv + have hsub : s ⊆ {c : X | c + y ∈ _root_.infClosure s} := + fun c hc => step c hc y hy + exact infClosure_min hsub h_ic hx + +/-- If `s` is closed under non-negative scaling, so is its inf-closure. -/ +theorem smul_mem_infClosure_of_smulClosed {s : Set X} + (hsmul : ∀ ⦃a : ℝ⦄, 0 ≤ a → ∀ ⦃x⦄, x ∈ s → a • x ∈ s) + {a : ℝ} (ha : 0 ≤ a) {x : X} (hx : x ∈ _root_.infClosure s) : + a • x ∈ _root_.infClosure s := by + have h_ic : InfClosed {c : X | a • c ∈ _root_.infClosure s} := fun u hu v hv => by + change a • (u ⊓ v) ∈ _root_.infClosure s + rw [nonneg_smul_inf u v a ha]; exact infClosed_infClosure hu hv + have hsub : s ⊆ {c : X | a • c ∈ _root_.infClosure s} := + fun c hc => subset_infClosure (hsmul ha hc) + exact infClosure_min hsub h_ic hx + +/-- The sup-closure of a pointed cone is a pointed cone. -/ +def supClosure (C : PointedCone ℝ X) : PointedCone ℝ X where + carrier := _root_.supClosure (C : Set X) + zero_mem' := subset_supClosure C.zero_mem + add_mem' hx hy := add_mem_supClosure_of_addClosed (fun _ hx _ hy => C.add_mem hx hy) hx hy + smul_mem' c _ hx := + smul_mem_supClosure_of_smulClosed (fun _ ha _ hx => C.smul_mem ha hx) c.2 hx + +@[simp] +theorem coe_supClosure (C : PointedCone ℝ X) : + (supClosure C : Set X) = _root_.supClosure (C : Set X) := rfl + +/-- The inf-closure of a pointed cone is a pointed cone. -/ +def infClosure (C : PointedCone ℝ X) : PointedCone ℝ X where + carrier := _root_.infClosure (C : Set X) + zero_mem' := subset_infClosure C.zero_mem + add_mem' hx hy := add_mem_infClosure_of_addClosed (fun _ hx _ hy => C.add_mem hx hy) hx hy + smul_mem' c _ hx := + smul_mem_infClosure_of_smulClosed (fun _ ha _ hx => C.smul_mem ha hx) c.2 hx + +@[simp] +theorem coe_infClosure (C : PointedCone ℝ X) : + (infClosure C : Set X) = _root_.infClosure (C : Set X) := rfl + +end PointedCone + +/-- A `VectorSublattice` of a vector lattice `X` is a linear subspace closed under +`⊔`. This is the bundled version: it extends `Submodule ℝ X` with lattice closure. -/ +structure VectorSublattice (X : Type*) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] extends Submodule ℝ X where + sup_mem' : ∀ {x y : X}, x ∈ carrier → y ∈ carrier → x ⊔ y ∈ carrier + +namespace VectorSublattice + +instance : SetLike (VectorSublattice X) X where + coe Y := Y.carrier + coe_injective p q h := by + cases p; cases q; congr + exact SetLike.ext' h + +variable (Y : VectorSublattice X) + +/-- A vector sublattice is closed under `⊔`. -/ +theorem sup_mem {x y : X} (hx : x ∈ Y) (hy : y ∈ Y) : + x ⊔ y ∈ Y := + Y.sup_mem' hx hy + +/-- A vector sublattice is closed under `⊓`. -/ +theorem inf_mem {x y : X} (hx : x ∈ Y) (hy : y ∈ Y) : + x ⊓ y ∈ Y := by + rw [inf_eq_sub_posPart x y] + exact Y.toSubmodule.sub_mem hx (Y.sup_mem' (Y.toSubmodule.sub_mem hx hy) (Y.toSubmodule.zero_mem)) + +/-- A vector sublattice is closed under the positive part. -/ +theorem posPart_mem {x : X} (hx : x ∈ Y) : x⁺ ∈ Y := + Y.sup_mem' hx (Y.toSubmodule.zero_mem) + +/-- A vector sublattice is closed under the negative part. -/ +theorem negPart_mem {x : X} (hx : x ∈ Y) : x⁻ ∈ Y := + posPart_mem Y (Y.toSubmodule.neg_mem hx) + +/-- A vector sublattice is closed under absolute value. -/ +theorem abs_mem {x : X} (hx : x ∈ Y) : |x| ∈ Y := + sup_mem Y hx (Y.toSubmodule.neg_mem hx) + +/-- The underlying set of a vector sublattice is an `IsSublattice`. -/ +theorem isSublattice : IsSublattice (Y : Set X) where + supClosed := by intro _ ha _ hb; exact sup_mem Y ha hb + infClosed := by intro _ ha _ hb; exact inf_mem Y ha hb + +/-! ### Construction from absolute-value closure -/ + +/-- The positive part lies in a submodule closed under absolute value. -/ +private theorem posPart_mem_of_absClosed (M : Submodule ℝ X) + (h : ∀ x : X, x ∈ M → |x| ∈ M) {x : X} (hx : x ∈ M) : x⁺ ∈ M := by + have key : x + |x| = 2 • x⁺ := add_abs_eq_two_nsmul_posPart x + have h2 : (2 : ℝ)⁻¹ • (x + |x|) = x⁺ := by + rw [key, ← Nat.cast_smul_eq_nsmul ℝ 2]; norm_num [smul_smul] + rw [← h2] + exact M.smul_mem _ (M.add_mem hx (h x hx)) + +/-- Build a `VectorSublattice` from a submodule closed under `|·|`. -/ +def ofAbsClosed (M : Submodule ℝ X) + (h : ∀ x : X, x ∈ M → |x| ∈ M) : VectorSublattice X where + toSubmodule := M + sup_mem' := fun {x y} hx hy => by + rw [sup_eq_add_posPart x y] + exact M.add_mem hx (posPart_mem_of_absClosed M h (M.sub_mem hy hx)) + +/-- A submodule is a vector sublattice iff it is closed under absolute value. -/ +theorem abs_mem_iff_sup_mem (M : Submodule ℝ X) : + (∀ x : X, x ∈ M → |x| ∈ M) ↔ + ∀ x y : X, x ∈ M → y ∈ M → x ⊔ y ∈ M := by + constructor + · intro h x y hx hy + exact (ofAbsClosed M h).sup_mem' hx hy + · intro h x hx + exact h x (-x) hx (M.neg_mem hx) + +/-! ### Coercion to submodule -/ + +/-- The coercion to `Submodule ℝ X` is injective. -/ +theorem toSubmodule_injective : + Function.Injective + (toSubmodule : VectorSublattice X → Submodule ℝ X) := by + intro p q h + cases p; cases q; congr + +/-- A vector sublattice and its underlying submodule have the same carrier. -/ +@[simp] +theorem coe_toSubmodule : (Y.toSubmodule : Set X) = (Y : Set X) := rfl + +/-! ### Coercion to pointed cone + +Every vector sublattice, being a linear subspace, is in particular a pointed +convex cone. -/ + +/-- Every vector sublattice is (canonically) a pointed cone. -/ +instance : CoeHead (VectorSublattice X) (PointedCone ℝ X) where + coe Y := + { toAddSubmonoid := Y.toSubmodule.toAddSubmonoid + smul_mem' := fun c _ hx => Y.toSubmodule.smul_mem c.1 hx } + +theorem coe_toPointedCone (Y : VectorSublattice X) : + ((Y : PointedCone ℝ X) : Set X) = (Y : Set X) := rfl + +/-! ### Lattice structure on the underlying subtype + +A vector sublattice `Y` inherits a lattice and vector-lattice structure from +the ambient space, with `⊔` and `⊓` computed pointwise. -/ + +/-- The lattice structure on the underlying subtype of a vector sublattice. -/ +noncomputable instance instLatticeSubtype : Lattice ↥Y.toSubmodule := + Subtype.lattice (P := fun x => x ∈ Y.toSubmodule) + (fun _ _ hx hy => Y.sup_mem hx hy) (fun _ _ hx hy => Y.inf_mem hx hy) + +/-- The subtype of a vector sublattice is an ordered additive monoid. -/ +instance instIsOrderedAddMonoidSubtype : + IsOrderedAddMonoid ↥Y.toSubmodule where + add_le_add_left := by + intro a b (h : a.1 ≤ b.1) c; exact add_le_add_left h c.1 + add_le_add_right := by + intro a b (h : a.1 ≤ b.1) c; exact add_le_add_right h c.1 + +/-- Scalar multiplication by non-negative reals is monotone on the subtype of +a vector sublattice. -/ +instance instPosSMulMonoSubtype : PosSMulMono ℝ ↥Y.toSubmodule where + smul_le_smul_of_nonneg_left := by + intro a ha b₁ b₂ h + change (a • b₁).1 ≤ (a • b₂).1 + exact smul_le_smul_of_nonneg_left h ha + +/-- The subtype of a vector sublattice is itself a vector lattice. -/ +instance instVectorLatticeSubtype : VectorLattice ↥Y.toSubmodule := ⟨⟩ + +/-! ### Lattice structure on `VectorSublattice X` + +The collection of vector sublattices of `X` is ordered by inclusion. It +contains the whole space `⊤ = X` and the zero subspace `⊥ = {0}`, and is +closed under arbitrary intersections. -/ + +instance : PartialOrder (VectorSublattice X) := + PartialOrder.lift (fun Y => (Y : Set X)) SetLike.coe_injective + +/-- The whole space `X` is a vector sublattice. -/ +instance : Top (VectorSublattice X) where + top := + { toSubmodule := ⊤ + sup_mem' := fun _ _ => Submodule.mem_top } + +/-- Every element belongs to `⊤`. -/ +@[simp] +theorem mem_top {x : X} : x ∈ (⊤ : VectorSublattice X) := + Submodule.mem_top + +/-- The zero subspace `{0}` is a vector sublattice. -/ +instance : Bot (VectorSublattice X) where + bot := + { toSubmodule := ⊥ + sup_mem' := fun {x y} hx hy => by + have hx' : x = 0 := (Submodule.mem_bot ℝ).mp hx + have hy' : y = 0 := (Submodule.mem_bot ℝ).mp hy + rw [hx', hy', sup_idem]; exact Submodule.zero_mem _ } + +/-- An element of `⊥` is zero. -/ +@[simp] +theorem mem_bot {x : X} : x ∈ (⊥ : VectorSublattice X) ↔ x = 0 := + Submodule.mem_bot ℝ + +/-- Arbitrary intersections of vector sublattices are vector sublattices. -/ +instance : InfSet (VectorSublattice X) where + sInf S := + { toSubmodule := sInf ((·.toSubmodule) '' S) + sup_mem' := fun {x y} hx hy => by + have hx' := (Submodule.mem_sInf).mp hx + have hy' := (Submodule.mem_sInf).mp hy + refine (Submodule.mem_sInf).mpr ?_ + rintro _ ⟨Y, hY, rfl⟩ + exact Y.sup_mem (hx' _ ⟨Y, hY, rfl⟩) (hy' _ ⟨Y, hY, rfl⟩) } + +/-! ### The vector sublattice generated by a set + +The vector sublattice generated by a set `s ⊆ X` is by definition the +smallest vector sublattice of `X` containing `s`, obtained as the infimum +of all vector sublattices containing `s`. -/ + +/-- The vector sublattice generated by a set `s`: the smallest vector +sublattice of `X` containing `s`. -/ +def generated (s : Set X) : VectorSublattice X := + sInf {Y : VectorSublattice X | s ⊆ Y} + +/-- The generating set is contained in the vector sublattice it generates. -/ +theorem subset_generated (s : Set X) : s ⊆ (generated s : Set X) := by + intro x hx + refine (Submodule.mem_sInf).mpr ?_ + rintro _ ⟨Y, hY, rfl⟩ + exact hY hx + +/-- The vector sublattice generated by `s` is contained in every vector +sublattice containing `s`. -/ +theorem generated_le {s : Set X} {Y : VectorSublattice X} (h : s ⊆ Y) : + generated s ≤ Y := by + intro x hx + have := (Submodule.mem_sInf).mp hx + exact this _ ⟨Y, h, rfl⟩ + +/-- For a submodule `M`, its lattice closure is closed under addition. -/ +private lemma latticeClosure_add_mem_of_submodule (M : Submodule ℝ X) + {x y : X} (hx : x ∈ latticeClosure (M : Set X)) + (hy : y ∈ latticeClosure (M : Set X)) : + x + y ∈ latticeClosure (M : Set X) := by + let := AddCommGroup.toDistribLattice X + refine latticeClosure_sup_inf_induction + (p := fun a _ => a + y ∈ latticeClosure (M : Set X)) ?_ ?_ ?_ hx + · intro a ha + refine latticeClosure_sup_inf_induction + (p := fun b _ => a + b ∈ latticeClosure (M : Set X)) ?_ ?_ ?_ hy + · intro b hb; exact subset_latticeClosure (M.add_mem ha hb) + · intro p _ q _ h₁ h₂ + rw [add_sup]; exact isSublattice_latticeClosure.supClosed h₁ h₂ + · intro p _ q _ h₁ h₂ + rw [add_inf]; exact isSublattice_latticeClosure.infClosed h₁ h₂ + · intro p _ q _ h₁ h₂ + rw [sup_add]; exact isSublattice_latticeClosure.supClosed h₁ h₂ + · intro p _ q _ h₁ h₂ + rw [inf_add]; exact isSublattice_latticeClosure.infClosed h₁ h₂ + +/-- For a submodule `M`, its lattice closure is closed under scaling. -/ +private lemma latticeClosure_smul_mem_of_submodule (M : Submodule ℝ X) + (c : ℝ) {x : X} (hx : x ∈ latticeClosure (M : Set X)) : + c • x ∈ latticeClosure (M : Set X) := by + let := AddCommGroup.toDistribLattice X + rcases le_or_gt 0 c with hc | hc + · refine latticeClosure_sup_inf_induction + (p := fun a _ => c • a ∈ latticeClosure (M : Set X)) ?_ ?_ ?_ hx + · intro a ha; exact subset_latticeClosure (M.smul_mem c ha) + · intro p _ q _ h₁ h₂ + rw [nonneg_smul_sup p q c hc] + exact isSublattice_latticeClosure.supClosed h₁ h₂ + · intro p _ q _ h₁ h₂ + rw [nonneg_smul_inf p q c hc] + exact isSublattice_latticeClosure.infClosed h₁ h₂ + · have hc' : 0 ≤ -c := by linarith + refine latticeClosure_sup_inf_induction + (p := fun a _ => c • a ∈ latticeClosure (M : Set X)) ?_ ?_ ?_ hx + · intro a ha; exact subset_latticeClosure (M.smul_mem c ha) + · intro p _ q _ h₁ h₂ + have eq : c • (p ⊔ q) = (c • p) ⊓ (c • q) := by + rw [show c • (p ⊔ q) = -((-c) • (p ⊔ q)) by rw [neg_smul, neg_neg], + nonneg_smul_sup p q (-c) hc', neg_sup, neg_smul, neg_neg, neg_smul, neg_neg] + rw [eq] + exact isSublattice_latticeClosure.infClosed h₁ h₂ + · intro p _ q _ h₁ h₂ + have eq : c • (p ⊓ q) = (c • p) ⊔ (c • q) := by + rw [show c • (p ⊓ q) = -((-c) • (p ⊓ q)) by rw [neg_smul, neg_neg], + nonneg_smul_inf p q (-c) hc', neg_inf, neg_smul, neg_neg, neg_smul, neg_neg] + rw [eq] + exact isSublattice_latticeClosure.supClosed h₁ h₂ + +/-- The vector sublattice whose underlying set is the lattice closure of a +submodule. -/ +private def sublatticeOfSubmoduleLatticeClosure (M : Submodule ℝ X) : + VectorSublattice X where + toSubmodule := + { carrier := latticeClosure (M : Set X) + zero_mem' := subset_latticeClosure M.zero_mem + add_mem' := latticeClosure_add_mem_of_submodule M + smul_mem' := latticeClosure_smul_mem_of_submodule M } + sup_mem' := fun {_ _} hx hy => by + let := AddCommGroup.toDistribLattice X + exact isSublattice_latticeClosure.supClosed hx hy + +/-- The vector sublattice generated by a linear subspace `M` coincides with +the sup-closure of the inf-closure of `M`. -/ +theorem generated_submodule_eq_supClosure_infClosure (M : Submodule ℝ X) : + (generated (M : Set X) : Set X) = supClosure (infClosure (M : Set X)) := by + let := AddCommGroup.toDistribLattice X + rw [supClosure_infClosure] + refine Set.Subset.antisymm ?_ ?_ + · have h : (M : Set X) ⊆ (sublatticeOfSubmoduleLatticeClosure M : Set X) := + fun _ hx => subset_latticeClosure hx + exact generated_le h + · exact latticeClosure_min (subset_generated _) + (generated (M : Set X)).isSublattice + +/-- The vector sublattice generated by a linear subspace `M` coincides with +the inf-closure of the sup-closure of `M`. -/ +theorem generated_submodule_eq_infClosure_supClosure (M : Submodule ℝ X) : + (generated (M : Set X) : Set X) = infClosure (supClosure (M : Set X)) := by + let := AddCommGroup.toDistribLattice X + rw [infClosure_supClosure, ← supClosure_infClosure] + exact generated_submodule_eq_supClosure_infClosure M + +open scoped Pointwise in +/-- The difference set `supClosure C - supClosure C` of a pointed cone is a +vector sublattice. -/ +private def sublatticeOfConeSupClosureDiff (C : PointedCone ℝ X) : + VectorSublattice X where + toSubmodule := + { carrier := _root_.supClosure (C : Set X) - _root_.supClosure (C : Set X) + zero_mem' := + ⟨0, subset_supClosure C.zero_mem, 0, subset_supClosure C.zero_mem, sub_self 0⟩ + add_mem' := by + rintro _ _ ⟨u₁, hu₁, v₁, hv₁, rfl⟩ ⟨u₂, hu₂, v₂, hv₂, rfl⟩ + refine ⟨u₁ + u₂, ?_, v₁ + v₂, ?_, ?_⟩ + · exact PointedCone.add_mem_supClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hu₁ hu₂ + · exact PointedCone.add_mem_supClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hv₁ hv₂ + · change (u₁ + u₂) - (v₁ + v₂) = (u₁ - v₁) + (u₂ - v₂); abel + smul_mem' := by + rintro c _ ⟨u, hu, v, hv, rfl⟩ + rcases le_or_gt 0 c with hc | hc + · refine ⟨c • u, ?_, c • v, ?_, ?_⟩ + · exact PointedCone.smul_mem_supClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc hu + · exact PointedCone.smul_mem_supClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc hv + · change c • u - c • v = c • (u - v); rw [smul_sub] + · have hc' : 0 ≤ -c := by linarith + refine ⟨(-c) • v, ?_, (-c) • u, ?_, ?_⟩ + · exact PointedCone.smul_mem_supClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc' hv + · exact PointedCone.smul_mem_supClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc' hu + · change (-c) • v - (-c) • u = c • (u - v) + rw [smul_sub, neg_smul, neg_smul]; abel } + sup_mem' := by + rintro _ _ ⟨u₁, hu₁, v₁, hv₁, rfl⟩ ⟨u₂, hu₂, v₂, hv₂, rfl⟩ + refine ⟨(u₁ + v₂) ⊔ (u₂ + v₁), ?_, v₁ + v₂, ?_, ?_⟩ + · exact supClosed_supClosure + (PointedCone.add_mem_supClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hu₁ hv₂) + (PointedCone.add_mem_supClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hu₂ hv₁) + · exact PointedCone.add_mem_supClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hv₁ hv₂ + · have h : ((u₁ - v₁) ⊔ (u₂ - v₂)) + (v₁ + v₂) = (u₁ + v₂) ⊔ (u₂ + v₁) := by + rw [sup_add]; congr 1 <;> abel + change ((u₁ + v₂) ⊔ (u₂ + v₁)) - (v₁ + v₂) = (u₁ - v₁) ⊔ (u₂ - v₂) + rw [← h]; abel + +open scoped Pointwise in +/-- The vector sublattice generated by a pointed cone `C` coincides with the +difference set of the sup-closure of `C` with itself. -/ +theorem generated_pointedCone_eq_sub_supClosure (C : PointedCone ℝ X) : + (generated (C : Set X) : Set X) + = supClosure (C : Set X) - supClosure (C : Set X) := by + refine Set.Subset.antisymm ?_ ?_ + · have h : (C : Set X) ⊆ (sublatticeOfConeSupClosureDiff C : Set X) := fun x hx => + ⟨x, subset_supClosure hx, 0, subset_supClosure C.zero_mem, sub_zero x⟩ + exact generated_le h + · rintro _ ⟨u, hu, v, hv, rfl⟩ + have hC : (C : Set X) ⊆ (generated (C : Set X) : Set X) := subset_generated _ + have h_sup : SupClosed (generated (C : Set X) : Set X) := + (generated (C : Set X)).isSublattice.supClosed + have hu_gen := supClosure_min hC h_sup hu + have hv_gen := supClosure_min hC h_sup hv + exact (generated (C : Set X)).toSubmodule.sub_mem hu_gen hv_gen + +open scoped Pointwise in +/-- The difference set `infClosure C - infClosure C` of a pointed cone is a +vector sublattice. -/ +private def sublatticeOfConeInfClosureDiff (C : PointedCone ℝ X) : + VectorSublattice X where + toSubmodule := + { carrier := _root_.infClosure (C : Set X) - _root_.infClosure (C : Set X) + zero_mem' := + ⟨0, subset_infClosure C.zero_mem, 0, subset_infClosure C.zero_mem, sub_self 0⟩ + add_mem' := by + rintro _ _ ⟨u₁, hu₁, v₁, hv₁, rfl⟩ ⟨u₂, hu₂, v₂, hv₂, rfl⟩ + refine ⟨u₁ + u₂, ?_, v₁ + v₂, ?_, ?_⟩ + · exact PointedCone.add_mem_infClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hu₁ hu₂ + · exact PointedCone.add_mem_infClosure_of_addClosed + (fun _ h _ h' => C.add_mem h h') hv₁ hv₂ + · change (u₁ + u₂) - (v₁ + v₂) = (u₁ - v₁) + (u₂ - v₂); abel + smul_mem' := by + rintro c _ ⟨u, hu, v, hv, rfl⟩ + rcases le_or_gt 0 c with hc | hc + · refine ⟨c • u, ?_, c • v, ?_, ?_⟩ + · exact PointedCone.smul_mem_infClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc hu + · exact PointedCone.smul_mem_infClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc hv + · change c • u - c • v = c • (u - v); rw [smul_sub] + · have hc' : 0 ≤ -c := by linarith + refine ⟨(-c) • v, ?_, (-c) • u, ?_, ?_⟩ + · exact PointedCone.smul_mem_infClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc' hv + · exact PointedCone.smul_mem_infClosure_of_smulClosed + (fun _ h _ h' => C.smul_mem h h') hc' hu + · change (-c) • v - (-c) • u = c • (u - v) + rw [smul_sub, neg_smul, neg_smul]; abel } + sup_mem' := by + rintro _ _ ⟨u₁, hu₁, v₁, hv₁, rfl⟩ ⟨u₂, hu₂, v₂, hv₂, rfl⟩ + have hadd : ∀ ⦃a⦄, a ∈ (C : Set X) → ∀ ⦃b⦄, b ∈ (C : Set X) → a + b ∈ (C : Set X) := + fun _ ha _ hb => C.add_mem ha hb + have hu₁v₂ : u₁ + v₂ ∈ _root_.infClosure (C : Set X) := + PointedCone.add_mem_infClosure_of_addClosed hadd hu₁ hv₂ + have hu₂v₁ : u₂ + v₁ ∈ _root_.infClosure (C : Set X) := + PointedCone.add_mem_infClosure_of_addClosed hadd hu₂ hv₁ + have hv₁v₂ : v₁ + v₂ ∈ _root_.infClosure (C : Set X) := + PointedCone.add_mem_infClosure_of_addClosed hadd hv₁ hv₂ + have hinf : (u₁ + v₂) ⊓ (u₂ + v₁) ∈ _root_.infClosure (C : Set X) := + infClosed_infClosure hu₁v₂ hu₂v₁ + refine ⟨u₁ + u₂ + v₁ + v₂, ?_, (u₁ + v₂) ⊓ (u₂ + v₁) + (v₁ + v₂), ?_, ?_⟩ + · have heq : u₁ + u₂ + v₁ + v₂ = (u₁ + v₂) + (u₂ + v₁) := by abel + rw [heq] + exact PointedCone.add_mem_infClosure_of_addClosed hadd hu₁v₂ hu₂v₁ + · exact PointedCone.add_mem_infClosure_of_addClosed hadd hinf hv₁v₂ + · have step1 : (u₁ + v₂) ⊔ (u₂ + v₁) = + (u₁ + v₂) + (u₂ + v₁) - (u₁ + v₂) ⊓ (u₂ + v₁) := by + rw [eq_sub_iff_add_eq, add_comm] + exact inf_add_sup _ _ + have step2 : ((u₁ - v₁) ⊔ (u₂ - v₂)) + (v₁ + v₂) = + (u₁ + v₂) ⊔ (u₂ + v₁) := by + rw [sup_add]; congr 1 <;> abel + change u₁ + u₂ + v₁ + v₂ - ((u₁ + v₂) ⊓ (u₂ + v₁) + (v₁ + v₂)) + = (u₁ - v₁) ⊔ (u₂ - v₂) + symm + calc (u₁ - v₁) ⊔ (u₂ - v₂) + = ((u₁ + v₂) ⊔ (u₂ + v₁)) - (v₁ + v₂) := by rw [← step2]; abel + _ = ((u₁ + v₂) + (u₂ + v₁) - (u₁ + v₂) ⊓ (u₂ + v₁)) - (v₁ + v₂) := by rw [← step1] + _ = u₁ + u₂ + v₁ + v₂ - ((u₁ + v₂) ⊓ (u₂ + v₁) + (v₁ + v₂)) := by abel + +open scoped Pointwise in +/-- The vector sublattice generated by a pointed cone `C` coincides with the +difference set of the inf-closure of `C` with itself. -/ +theorem generated_pointedCone_eq_sub_infClosure (C : PointedCone ℝ X) : + (generated (C : Set X) : Set X) + = infClosure (C : Set X) - infClosure (C : Set X) := by + refine Set.Subset.antisymm ?_ ?_ + · have h : (C : Set X) ⊆ (sublatticeOfConeInfClosureDiff C : Set X) := fun x hx => + ⟨x, subset_infClosure hx, 0, subset_infClosure C.zero_mem, sub_zero x⟩ + exact generated_le h + · rintro _ ⟨u, hu, v, hv, rfl⟩ + have hC : (C : Set X) ⊆ (generated (C : Set X) : Set X) := subset_generated _ + have h_inf : InfClosed (generated (C : Set X) : Set X) := + (generated (C : Set X)).isSublattice.infClosed + have hu_gen := infClosure_min hC h_inf hu + have hv_gen := infClosure_min hC h_inf hv + exact (generated (C : Set X)).toSubmodule.sub_mem hu_gen hv_gen + +omit [VectorLattice X] in +/-- For a finite set `s` of pairwise lattice-disjoint elements and a family +`g : X → X` taking values disjoint from a fixed `a`, the sum over `s` remains +lattice-disjoint from `a`. -/ +private lemma isVLDisjoint_finsetSum {a : X} {s : Finset X} {g : X → X} + (h : ∀ i ∈ s, IsVLDisjoint a (g i)) : + IsVLDisjoint a (∑ i ∈ s, g i) := by + classical + induction s using Finset.induction_on with + | empty => simpa using isVLDisjoint_zero_right a + | insert b s hb ih => + rw [Finset.sum_insert hb] + refine (h b (Finset.mem_insert_self b s)).add_right ?_ + exact ih (fun i hi => h i (Finset.mem_insert_of_mem hi)) + +/-- Disjoint sum of a scalar family: for a Finset `s` of pairwise-disjoint +elements with any scalars `f`, `|∑ f(a) • a| = ∑ |f(a)| • |a|`. -/ +private lemma abs_sum_finset_of_pairwise_vlDisjoint {s : Finset X} {f : X → ℝ} + (hdisj : (s : Set X).Pairwise IsVLDisjoint) : + |∑ a ∈ s, f a • a| = ∑ a ∈ s, |f a| • |a| := by + classical + induction s using Finset.induction_on with + | empty => simp + | insert a s ha ih => + have hdisj_s : (s : Set X).Pairwise IsVLDisjoint := fun i hi j hj hij => + hdisj (Finset.mem_insert_of_mem hi) (Finset.mem_insert_of_mem hj) hij + rw [Finset.sum_insert ha, Finset.sum_insert ha] + have hdisj_head : IsVLDisjoint (f a • a) (∑ i ∈ s, f i • i) := by + apply isVLDisjoint_finsetSum + intro i hi + have hne_ai : a ≠ i := fun h => ha (h ▸ hi) + exact ((hdisj (Finset.mem_insert_self a s) + (Finset.mem_insert_of_mem hi) hne_ai).smul_left (f a)).smul_right (f i) + rw [abs_add_of_isVLDisjoint hdisj_head, abs_smul', ih hdisj_s] + +/-- The vector sublattice generated by a set of pairwise lattice-disjoint, +non-negative elements coincides with its linear span. -/ +theorem generated_eq_span_of_pairwise_vlDisjoint {A : Set X} + (hA : A.Pairwise IsVLDisjoint) (hA_nn : ∀ a ∈ A, 0 ≤ a) : + (generated A).toSubmodule = Submodule.span ℝ A := by + refine le_antisymm ?_ (Submodule.span_le.mpr (subset_generated A)) + have h_abs : ∀ u, u ∈ Submodule.span ℝ A → |u| ∈ Submodule.span ℝ A := by + intro u hu + obtain ⟨f, t, ht_sub, _, hsum⟩ := + Submodule.mem_span_iff_exists_finset_subset.mp hu + have hdisj_t : (t : Set X).Pairwise IsVLDisjoint := fun i hi j hj hij => + hA (ht_sub hi) (ht_sub hj) hij + have hnn_t : ∀ a ∈ t, 0 ≤ a := fun a ha => hA_nn a (ht_sub ha) + rw [← hsum, abs_sum_finset_of_pairwise_vlDisjoint hdisj_t] + refine Submodule.sum_mem _ fun a ha => ?_ + rw [abs_of_nonneg (hnn_t a ha)] + exact Submodule.smul_mem _ _ (Submodule.subset_span (ht_sub ha)) + let Y : VectorSublattice X := ofAbsClosed (Submodule.span ℝ A) h_abs + have hA_sub : A ⊆ (Y : Set X) := Submodule.subset_span + have hle := generated_le (Y := Y) hA_sub + intro x hx + exact hle hx + +end VectorSublattice + +namespace LLexpr + +variable {n : ℕ} + +section Combinations + +variable {X : Type*} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- The sublattice generated by the image of a tuple `x : Fin n → X` coincides +with the set of lattice-linear combinations of `x`. -/ +theorem generated_range_eq_combinations (x : Fin n → X) : + (VectorSublattice.generated (Set.range x) : Set X) + = combinations x := by + let Y : VectorSublattice X := + { toSubmodule := + { carrier := combinations x + zero_mem' := ⟨.zero, rfl⟩ + add_mem' := by + rintro _ _ ⟨e₁, rfl⟩ ⟨e₂, rfl⟩ + exact ⟨.add e₁ e₂, rfl⟩ + smul_mem' := by + rintro r _ ⟨e, rfl⟩ + exact ⟨.smul r e, rfl⟩ } + sup_mem' := by + rintro _ _ ⟨e₁, rfl⟩ ⟨e₂, rfl⟩ + exact ⟨.sup e₁ e₂, rfl⟩ } + refine Set.Subset.antisymm ?_ ?_ + · change (VectorSublattice.generated (Set.range x) : Set X) ⊆ (Y : Set X) + exact VectorSublattice.generated_le (Y := Y) (by + rintro _ ⟨i, rfl⟩ + exact ⟨.var i, rfl⟩) + · rintro _ ⟨e, rfl⟩ + induction e with + | zero => + exact (VectorSublattice.generated (Set.range x)).toSubmodule.zero_mem + | var i => + exact VectorSublattice.subset_generated (Set.range x) ⟨i, rfl⟩ + | add e₁ e₂ he₁ he₂ => + exact (VectorSublattice.generated (Set.range x)).toSubmodule.add_mem he₁ he₂ + | smul r e he => + exact (VectorSublattice.generated (Set.range x)).toSubmodule.smul_mem r he + | sup e₁ e₂ he₁ he₂ => + exact (VectorSublattice.generated (Set.range x)).sup_mem he₁ he₂ + | inf e₁ e₂ he₁ he₂ => + exact (VectorSublattice.generated (Set.range x)).inf_mem he₁ he₂ + +/-- The sublattice generated by a set `s` coincides with the union, over all +natural numbers `n` and all `n`-tuples `x` with values in `s`, of the sets of +lattice-linear combinations of `x`. -/ +theorem generated_eq_iUnion_combinations (s : Set X) : + (VectorSublattice.generated s : Set X) + = ⋃ (n : ℕ) (x : Fin n → s), combinations ((↑) ∘ x) := by + let U : Set X := ⋃ (n : ℕ) (x : Fin n → s), combinations ((↑) ∘ x) + let Y : VectorSublattice X := + { toSubmodule := + { carrier := U + zero_mem' := by + refine Set.mem_iUnion.mpr ⟨0, ?_⟩ + refine Set.mem_iUnion.mpr ⟨Fin.elim0, ?_⟩ + exact ⟨.zero, rfl⟩ + add_mem' := by + rintro _ _ hx hy + simp only [U, Set.mem_iUnion] at hx hy ⊢ + obtain ⟨m, x, e₁, rfl⟩ := hx + obtain ⟨k, y, e₂, rfl⟩ := hy + refine ⟨m + k, Fin.append x y, .add (reindexExpr (Fin.castAdd k) e₁) + (reindexExpr (Fin.natAdd m) e₂), ?_⟩ + simp [Function.comp_def] + smul_mem' := by + rintro r _ hx + simp only [U, Set.mem_iUnion] at hx ⊢ + obtain ⟨m, x, e, rfl⟩ := hx + exact ⟨m, x, .smul r e, rfl⟩ } + sup_mem' := by + rintro _ _ hx hy + simp only [U, Set.mem_iUnion] at hx hy ⊢ + obtain ⟨m, x, e₁, rfl⟩ := hx + obtain ⟨k, y, e₂, rfl⟩ := hy + refine ⟨m + k, Fin.append x y, .sup (reindexExpr (Fin.castAdd k) e₁) + (reindexExpr (Fin.natAdd m) e₂), ?_⟩ + simp [Function.comp_def] } + have hsY : s ⊆ Y := by + intro a ha + change a ∈ U + refine Set.mem_iUnion.mpr ⟨1, ?_⟩ + refine Set.mem_iUnion.mpr ⟨(fun _ : Fin 1 => ⟨a, ha⟩), ?_⟩ + exact ⟨.var 0, rfl⟩ + refine Set.Subset.antisymm ?_ ?_ + · exact VectorSublattice.generated_le hsY + · intro a ha + simp only [Set.mem_iUnion] at ha + obtain ⟨m, x, hx⟩ := ha + have hxgen : + a ∈ + (VectorSublattice.generated (Set.range ((Subtype.val : s → X) ∘ x)) : Set X) := by + rwa [generated_range_eq_combinations ((Subtype.val : s → X) ∘ x)] + exact VectorSublattice.generated_le (Y := VectorSublattice.generated s) (fun y hy => by + obtain ⟨i, rfl⟩ := hy + exact VectorSublattice.subset_generated s (x i).2) hxgen + +end Combinations + +end LLexpr + +/-! ### Normed and Banach lattice structure on sublattices -/ + +section Normed + +variable {X : Type*} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [NormedVectorLattice X] + +namespace VectorSublattice + +variable (Y : VectorSublattice X) + +/-- A vector sublattice of a normed vector lattice is itself a normed vector +lattice under the induced norm and lattice operations. -/ +instance instNormedVectorLatticeSubtype : + NormedVectorLattice ↥Y.toSubmodule where + solid := by + intro x y h + change ‖x.1‖ ≤ ‖y.1‖ + exact HasSolidNorm.solid h + norm_smul a x := norm_smul a x.1 + +/-- The closure of a vector sublattice in a normed vector lattice is again a +vector sublattice. -/ +noncomputable def topologicalClosure (Y : VectorSublattice X) : VectorSublattice X where + toSubmodule := Y.toSubmodule.topologicalClosure + sup_mem' := fun {x y} hx hy => by + have hx' : x ∈ closure (Y.toSubmodule : Set X) := by + rw [← Submodule.topologicalClosure_coe]; exact hx + have hy' : y ∈ closure (Y.toSubmodule : Set X) := by + rw [← Submodule.topologicalClosure_coe]; exact hy + have hxy : x ⊔ y ∈ closure (Y.toSubmodule : Set X) := + map_mem_closure₂ (f := fun a b : X => a ⊔ b) + NormedVectorLattice.continuous_sup hx' hy' + (fun _ ha _ hb => Y.sup_mem ha hb) + rw [← Submodule.topologicalClosure_coe] at hxy + exact hxy + +/-- A norm-closed vector sublattice of a Banach lattice is itself a Banach +lattice under the induced structures. -/ +@[reducible] +noncomputable def banachLatticeSubtype [CompleteSpace X] + (hclosed : IsClosed (Y : Set X)) : BanachLattice ↥Y.toSubmodule where + toCompleteSpace := by + have : IsClosed (Y.toSubmodule : Set X) := hclosed + infer_instance + +omit [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] [NormedVectorLattice X] in +/-- Finite subsets of a countable set form a countable set of finsets. -/ +private lemma countable_finsets_subset {D : Set X} (hD : D.Countable) : + {t : Finset X | ↑t ⊆ D}.Countable := by + classical + have h_fin : {u : Set X | u.Finite ∧ u ⊆ D}.Countable := + Set.countable_ofPred_finite_subset hD + apply Set.Countable.mono ?_ (h_fin.image + (fun (u : Set X) => if h : u.Finite then h.toFinset else ∅)) + intro t ht + refine ⟨↑t, ⟨Finset.finite_toSet t, ht⟩, ?_⟩ + simp + +omit [IsOrderedAddMonoid X] [NormedVectorLattice X] in +/-- If `D` is countable, then so is its sup-closure. -/ +private lemma countable_supClosure {D : Set X} (hD : D.Countable) : + (_root_.supClosure D).Countable := by + classical + set FD := {t : Finset X | ↑t ⊆ D} with hFD_def + have hFD : FD.Countable := countable_finsets_subset hD + apply Set.Countable.mono ?_ + (hFD.image (fun t : Finset X => if h : t.Nonempty then t.sup' h id else (0 : X))) + intro x hx + obtain ⟨t, ht, hsub, rfl⟩ := hx + refine ⟨t, hsub, ?_⟩ + simp [dite_eq_left ht] + +omit [IsOrderedAddMonoid X] [NormedVectorLattice X] in +/-- If `D` is countable, then so is its inf-closure. -/ +private lemma countable_infClosure {D : Set X} (hD : D.Countable) : + (_root_.infClosure D).Countable := by + classical + set FD := {t : Finset X | ↑t ⊆ D} with hFD_def + have hFD : FD.Countable := countable_finsets_subset hD + apply Set.Countable.mono ?_ + (hFD.image (fun t : Finset X => if h : t.Nonempty then t.inf' h id else (0 : X))) + intro x hx + obtain ⟨t, ht, hsub, rfl⟩ := hx + refine ⟨t, hsub, ?_⟩ + simp [dite_eq_left ht] + +/-- If `s ⊆ closure D`, then every element of `supClosure s` belongs to the closure of +`supClosure D`. -/ +private lemma supClosure_subset_closure_supClosure {s D : Set X} + (h : s ⊆ closure D) : + _root_.supClosure s ⊆ closure (_root_.supClosure D) := by + intro x hx + obtain ⟨t, ht, hsub, rfl⟩ := hx + classical + have ht_attach : t.attach.Nonempty := Finset.attach_nonempty_iff.mpr ht + choose f hf_mem hf_tendsto using fun (y : {a // a ∈ t}) => + (mem_closure_iff_seq_limit.mp (h (hsub y.property)) : + ∃ seq, (∀ n, seq n ∈ D) ∧ Filter.Tendsto seq Filter.atTop (nhds y.val)) + set xn : ℕ → X := fun n => t.attach.sup' ht_attach (fun y => f y n) + have h_sum_mem : ∀ n, xn n ∈ _root_.supClosure D := by + intro n + refine ⟨t.attach.image (fun y => f y n), ht_attach.image _, ?_, ?_⟩ + · rintro z hz + simp only [Finset.coe_image, Set.mem_image] at hz + obtain ⟨y, _, rfl⟩ := hz + exact hf_mem y n + · rw [Finset.sup'_image] + rfl + have h_eq : t.attach.sup' ht_attach (Subtype.val : {a // a ∈ t} → X) = t.sup' ht id := by + refine le_antisymm ?_ ?_ + · exact Finset.sup'_le _ _ fun y _ => Finset.le_sup' (f := id) y.2 + · refine Finset.sup'_le _ _ fun a ha => ?_ + exact Finset.le_sup' (f := Subtype.val) (Finset.mem_attach t ⟨a, ha⟩) + have h_tendsto : Filter.Tendsto xn Filter.atTop + (nhds (t.attach.sup' ht_attach (Subtype.val : {a // a ∈ t} → X))) := + Filter.Tendsto.finset_sup'_nhds_apply ht_attach (fun y _ => hf_tendsto y) + rw [← h_eq] + exact mem_closure_of_tendsto h_tendsto (Filter.Eventually.of_forall h_sum_mem) + +/-- Dual version for inf-closure. -/ +private lemma infClosure_subset_closure_infClosure {s D : Set X} + (h : s ⊆ closure D) : + _root_.infClosure s ⊆ closure (_root_.infClosure D) := by + intro x hx + obtain ⟨t, ht, hsub, rfl⟩ := hx + classical + have ht_attach : t.attach.Nonempty := Finset.attach_nonempty_iff.mpr ht + choose f hf_mem hf_tendsto using fun (y : {a // a ∈ t}) => + (mem_closure_iff_seq_limit.mp (h (hsub y.property)) : + ∃ seq, (∀ n, seq n ∈ D) ∧ Filter.Tendsto seq Filter.atTop (nhds y.val)) + set xn : ℕ → X := fun n => t.attach.inf' ht_attach (fun y => f y n) + have h_sum_mem : ∀ n, xn n ∈ _root_.infClosure D := by + intro n + refine ⟨t.attach.image (fun y => f y n), ht_attach.image _, ?_, ?_⟩ + · rintro z hz + simp only [Finset.coe_image, Set.mem_image] at hz + obtain ⟨y, _, rfl⟩ := hz + exact hf_mem y n + · rw [Finset.inf'_image] + rfl + have h_eq : t.attach.inf' ht_attach (Subtype.val : {a // a ∈ t} → X) = t.inf' ht id := by + refine le_antisymm ?_ ?_ + · refine Finset.le_inf' _ _ fun a ha => ?_ + exact Finset.inf'_le (f := Subtype.val) (Finset.mem_attach t ⟨a, ha⟩) + · exact Finset.le_inf' _ _ fun y _ => Finset.inf'_le (f := id) y.2 + have h_tendsto : Filter.Tendsto xn Filter.atTop + (nhds (t.attach.inf' ht_attach (Subtype.val : {a // a ∈ t} → X))) := + Filter.Tendsto.finset_inf'_nhds_apply ht_attach (fun y _ => hf_tendsto y) + rw [← h_eq] + exact mem_closure_of_tendsto h_tendsto (Filter.Eventually.of_forall h_sum_mem) + +/-- IsSeparable is preserved under sup-closure in a normed vector lattice. -/ +private lemma isSeparable_supClosure {s : Set X} + (hs : TopologicalSpace.IsSeparable s) : + TopologicalSpace.IsSeparable (_root_.supClosure s) := by + obtain ⟨D, hD_ctble, hs_sub⟩ := hs + exact ⟨_root_.supClosure D, countable_supClosure hD_ctble, + supClosure_subset_closure_supClosure hs_sub⟩ + +/-- IsSeparable is preserved under inf-closure in a normed vector lattice. -/ +private lemma isSeparable_infClosure {s : Set X} + (hs : TopologicalSpace.IsSeparable s) : + TopologicalSpace.IsSeparable (_root_.infClosure s) := by + obtain ⟨D, hD_ctble, hs_sub⟩ := hs + exact ⟨_root_.infClosure D, countable_infClosure hD_ctble, + infClosure_subset_closure_infClosure hs_sub⟩ + +/-- The closed vector sublattice generated by a countable subset of a normed +vector lattice is separable. -/ +theorem separableSpace_topologicalClosure_generated_of_countable + {A : Set X} (hA : A.Countable) : + TopologicalSpace.SeparableSpace + ↥(topologicalClosure (generated A)).toSubmodule := by + have h_span_eq : (generated A : Set X) = + (generated (Submodule.span ℝ A : Set X) : Set X) := by + refine Set.Subset.antisymm ?_ ?_ + · exact generated_le (Set.Subset.trans Submodule.subset_span (subset_generated _)) + · exact generated_le + (Submodule.span_le.mpr (subset_generated A)) + have h_gen : (generated A : Set X) = + _root_.supClosure (_root_.infClosure (Submodule.span ℝ A : Set X)) := by + rw [h_span_eq]; exact generated_submodule_eq_supClosure_infClosure _ + have h_span_sep : TopologicalSpace.IsSeparable (Submodule.span ℝ A : Set X) := + (hA.isSeparable).span + have h_gen_sep : TopologicalSpace.IsSeparable (generated A : Set X) := by + rw [h_gen] + exact isSeparable_supClosure (isSeparable_infClosure h_span_sep) + have h_closure_sep : TopologicalSpace.IsSeparable + ((topologicalClosure (generated A)).toSubmodule : Set X) := by + have : ((topologicalClosure (generated A)).toSubmodule : Set X) = + closure (generated A : Set X) := Submodule.topologicalClosure_coe _ + rw [this] + exact h_gen_sep.closure + exact h_closure_sep.separableSpace + +end VectorSublattice + +end Normed diff --git a/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean new file mode 100644 index 0000000000..2d083da913 --- /dev/null +++ b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean @@ -0,0 +1,504 @@ +/- +Copyright (c) 2026 David Muñoz-Lahoz. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: David Muñoz-Lahoz +-/ + +module + +public import LeanPool.OrderClosures.BanLat.LLexpr +public import Mathlib.Data.Fin.VecNotation +public import Mathlib.Tactic.SplitIfs +public import Mathlib.Tactic.Linarith +public import Mathlib.Util.Qq + + +/-! +# The `llarith` tactic + +`llarith` proves lattice-linear identities and non-strict inequalities in vector +lattices by reducing them to the corresponding statement over `ℝ`. It quotes the +goal as an `LLexpr`, proves the real identity by expanding lattice operations to +`max` and `min` and splitting cases, and transfers the result back with +`LLexpr.vanishes_of_vanishes_real`. + +The supported expression language consists of vector-valued atoms, `0`, addition, +subtraction, negation, real scalar multiplication, `⊔`, `⊓`, positive parts, +negative parts, and absolute values. A goal `a ≤ b` is handled as the equivalent +lattice-linear identity `a ⊔ b = b`. Local hypotheses of the form `0 ≤ x`, +`x ≤ 0`, `0 < x`, and `x < 0` are used when `x` is one of the quoted atoms. +-/ + +public meta section + +namespace LLexpr + +open Lean Meta Elab Tactic Qq + +namespace Tactic + +/-- A quoted lattice-linear expression whose coefficients are elaborated Lean expressions. + +Unsupported vector-valued subterms are represented by `var`; they are treated as +atomic variables in the real identity check. -/ +inductive Quoted where + /-- The constant zero expression. -/ + | zero + /-- A vector-valued atom, represented by its index in the collected atom list. -/ + | var (idx : Nat) + /-- Addition of quoted expressions. -/ + | add (lhs rhs : Quoted) + /-- Real scalar multiplication of a quoted expression. -/ + | smul (coeff : Expr) (arg : Quoted) + /-- Supremum of quoted expressions. -/ + | sup (lhs rhs : Quoted) + /-- Infimum of quoted expressions. -/ + | inf (lhs rhs : Quoted) + deriving BEq + +/-- The sign information about a quoted atom that `llarith` can use. -/ +inductive AtomSign where + /-- No usable sign information was found. -/ + | unknown + /-- The atom is known to be non-negative. -/ + | nonneg + /-- The atom is known to be non-positive. -/ + | nonpos + deriving BEq, Inhabited + +/-- Sign information for an atom, together with a proof of the corresponding weak inequality. -/ +structure AtomSignInfo where + /-- Whether the atom is known to be non-negative or non-positive. -/ + sign : AtomSign + /-- A proof of `0 ≤ x` in the non-negative case, or `x ≤ 0` in the non-positive case. -/ + proof : Expr + +/-- State threaded through quotation: the distinct vector-valued atoms already found. -/ +structure QuoteState where + /-- The vector-valued atoms, in the order used for the generated `Fin n → X` tuple. -/ + atoms : Array Expr := #[] + +/-- The monad used while quoting a goal into an `LLexpr`. -/ +abbrev QuoteM := StateT QuoteState TacticM + +/-- Report that the current target is outside the goal shapes supported by `llarith`. -/ +def throwUnsupportedTarget : TacticM α := + throwError "llarith only supports equality and non-strict inequality goals" + +/-- Syntactic comparison of vector-valued atoms, ignoring metadata. -/ +def sameAtom (x y : Expr) : Bool := + x.consumeMData == y.consumeMData + +/-- Return the index of an atom, adding it to the quotation state if it is new. -/ +def registerAtom (e : Expr) : QuoteM Nat := do + let e := e.consumeMData + let atoms := (← get).atoms + for h : i in [:atoms.size] do + if sameAtom e atoms[i] then + return i + modify fun s => { s with atoms := s.atoms.push e } + return atoms.size + +/-- Return the index of an already collected atom, if any. -/ +def findAtom (atoms : Array Expr) (e : Expr) : Option Nat := + Id.run do + let e := e.consumeMData + for h : i in [:atoms.size] do + if sameAtom e atoms[i] then + return some i + return none + +/-- Test whether an expression is definitionally the zero element of the given type. -/ +def isZeroOfType (type e : Expr) : TacticM Bool := do + let z ← mkAppOptM ``OfNat.ofNat #[some type, some (mkNatLit 0), none] + withReducible <| isDefEq e z + +/-- Test whether an elaborated type expression is definitionally `ℝ`. -/ +def isRealType (type : Expr) : TacticM Bool := do + withReducible <| isDefEq type q(ℝ) + +/-- Quote a vector-valued expression as a lattice-linear expression. + +Recognized syntax is translated to the corresponding `Quoted` constructor. Any +other vector-valued subterm is registered as an atomic variable. -/ +def quoteExprWithFuel : Nat → (type : Expr) → (e : Expr) → QuoteM Quoted + | 0, _, _ => throwError "llarith expression traversal exhausted its structural bound" + | fuel + 1, type, e => do + if ← liftM <| isZeroOfType type e then + return .zero + let e := e.consumeMData + let args := e.getAppArgs + let some declName := e.getAppFn.constName? + | return .var (← registerAtom e) + match declName with + | ``HAdd.hAdd => + if h : args.size = 6 then + return .add (← quoteExprWithFuel fuel type args[4]) + (← quoteExprWithFuel fuel type args[5]) + else + return .var (← registerAtom e) + | ``HSub.hSub => + if h : args.size = 6 then + return .add (← quoteExprWithFuel fuel type args[4]) + (.smul q((-1 : ℝ)) (← quoteExprWithFuel fuel type args[5])) + else + return .var (← registerAtom e) + | ``Neg.neg => + if h : args.size = 3 then + return .smul q((-1 : ℝ)) (← quoteExprWithFuel fuel type args[2]) + else + return .var (← registerAtom e) + | ``HSMul.hSMul => + if h : args.size = 6 then + if ← liftM <| isRealType args[0] then + return .smul args[4] (← quoteExprWithFuel fuel type args[5]) + else + return .var (← registerAtom e) + else + return .var (← registerAtom e) + | ``Max.max => + if h : args.size = 4 then + return .sup (← quoteExprWithFuel fuel type args[2]) + (← quoteExprWithFuel fuel type args[3]) + else + return .var (← registerAtom e) + | ``Min.min => + if h : args.size = 4 then + return .inf (← quoteExprWithFuel fuel type args[2]) + (← quoteExprWithFuel fuel type args[3]) + else + return .var (← registerAtom e) + | ``PosPart.posPart => + if h : args.size = 3 then + return .sup (← quoteExprWithFuel fuel type args[2]) .zero + else + return .var (← registerAtom e) + | ``NegPart.negPart => + if h : args.size = 3 then + return .sup (.smul q((-1 : ℝ)) (← quoteExprWithFuel fuel type args[2])) .zero + else + return .var (← registerAtom e) + | ``abs => + if h : args.size = 4 then + let arg ← quoteExprWithFuel fuel type args[3] + return .sup arg (.smul q((-1 : ℝ)) arg) + else + return .var (← registerAtom e) + | _ => + return .var (← registerAtom e) + +/-- The expression size bounds the number of recursive quotation steps along any branch. -/ +def quoteExpr (type e : Expr) : QuoteM Quoted := + quoteExprWithFuel (e.sizeWithoutSharing + 1) type e + +/-- Replace atoms with sign-parametrized expressions when a sign hypothesis is available. + +For a non-negative atom `x`, the real side uses `x⁺`; for a non-positive atom, +it uses `-(-x)⁺`. After transfer, the original sign hypothesis rewrites these +expressions back to `x`. -/ +def Quoted.applySigns (signs : Array AtomSign) : Quoted → Quoted + | .zero => .zero + | .var idx => + match signs[idx]? with + | some .nonneg => .sup (.var idx) .zero + | some .nonpos => .smul q((-1 : ℝ)) (.sup (.smul q((-1 : ℝ)) (.var idx)) .zero) + | _ => .var idx + | .add lhs rhs => .add (lhs.applySigns signs) (rhs.applySigns signs) + | .smul coeff arg => .smul coeff (arg.applySigns signs) + | .sup lhs rhs => .sup (lhs.applySigns signs) (rhs.applySigns signs) + | .inf lhs rhs => .inf (lhs.applySigns signs) (rhs.applySigns signs) + +/-- Test whether an elaborated scalar coefficient is definitionally `-1`. -/ +def isNegOneCoeff (coeff : Expr) : TacticM Bool := do + withReducible <| isDefEq coeff q((-1 : ℝ)) + +/-- Remove simple redundancies introduced while quoting and applying signs. -/ +def Quoted.simplify : Quoted → TacticM Quoted + | .zero => return .zero + | .var idx => return .var idx + | .add lhs rhs => do + let lhs ← lhs.simplify + let rhs ← rhs.simplify + match lhs, rhs with + | .zero, rhs => return rhs + | lhs, .zero => return lhs + | _, _ => return .add lhs rhs + | .smul coeff arg => do + let arg ← arg.simplify + match arg with + | .zero => return .zero + | .smul coeff' arg' => + if (← isNegOneCoeff coeff) && (← isNegOneCoeff coeff') then + return arg' + else + return .smul coeff arg + | _ => return .smul coeff arg + | .sup lhs rhs => do + let lhs ← lhs.simplify + let rhs ← rhs.simplify + if lhs == rhs then + return lhs + else + match lhs, rhs with + | .sup a b, rhs => + if a == rhs || b == rhs then return lhs else return .sup lhs rhs + | lhs, .sup a b => + if a == lhs || b == lhs then return rhs else return .sup lhs rhs + | _, _ => return .sup lhs rhs + | .inf lhs rhs => do + let lhs ← lhs.simplify + let rhs ← rhs.simplify + if lhs == rhs then + return lhs + else + match lhs, rhs with + | .inf a b, rhs => + if a == rhs || b == rhs then return lhs else return .inf lhs rhs + | lhs, .inf a b => + if a == lhs || b == lhs then return rhs else return .inf lhs rhs + | _, _ => return .inf lhs rhs + +/-- Convert an array of optional sign information to the sign array used by quotation. -/ +def AtomSignInfo.toSigns (infos : Array (Option AtomSignInfo)) : Array AtomSign := + infos.map fun info => info.map (·.sign) |>.getD .unknown + +/-- If a proposition gives sign information about a collected atom, return that information. -/ +def signFromHyp (type : Expr) (atoms : Array Expr) (proof prop : Expr) : + TacticM (Option (Nat × AtomSignInfo)) := do + let prop ← instantiateMVars prop + let propWhnf ← whnf prop + let parseRel (strict : Bool) (relType lhs rhs : Expr) : + TacticM (Option (Nat × AtomSignInfo)) := do + unless ← withReducible (isDefEq relType type) do + return none + let weakProof ← if strict then mkAppM ``le_of_lt #[proof] else pure proof + if ← isZeroOfType type lhs then + return (findAtom atoms rhs).map fun idx => + (idx, { sign := .nonneg, proof := weakProof }) + else if ← isZeroOfType type rhs then + return (findAtom atoms lhs).map fun idx => + (idx, { sign := .nonpos, proof := weakProof }) + else + return none + match propWhnf.le? <|> prop.le? with + | some (relType, lhs, rhs) => parseRel false relType lhs rhs + | none => + match propWhnf.lt? <|> prop.lt? with + | some (relType, lhs, rhs) => parseRel true relType lhs rhs + | none => return none + +/-- Collect atom-level sign information from the local context. -/ +def collectAtomSigns (type : Expr) (atoms : Array Expr) : + TacticM (Array (Option AtomSignInfo)) := do + let mut signs : Array (Option AtomSignInfo) := Array.replicate atoms.size none + for localDecl in ← getLCtx do + unless localDecl.isImplementationDetail do + let hyp := mkFVar localDecl.fvarId + if let some (idx, info) ← signFromHyp type atoms hyp localDecl.type then + if (signs[idx]?).join.isNone then + signs := signs.set! idx (some info) + return signs + +/-- Add the weak inequalities extracted from sign hypotheses to the local context. -/ +def assertAtomSignFacts (infos : Array (Option AtomSignInfo)) : TacticM Unit := do + for h : i in [:infos.size] do + if let some info := infos[i] then + let proof ← instantiateMVars info.proof + let proofType ← inferType proof + let signName := (`llarith_sign).appendIndexAfter i + let (_, goal) ← (← (← getMainGoal).assert signName proofType proof).intro1P + setGoals [goal] + +/-- Build a closed expression for the `idx`th element of `Fin arity`. -/ +def mkFinExpr (idx arity : Nat) : Expr := + have idxExpr : Q(ℕ) := mkNatLitQ idx + have arityExpr : Q(ℕ) := mkNatLitQ arity + have hdec : decide ($idxExpr < $arityExpr) =Q true := ⟨⟩ + (q(⟨$idxExpr, of_decide_eq_true $hdec⟩) : Q(Fin $arityExpr)) + +/-- Convert quoted syntax into the corresponding formal `LLexpr`. -/ +def Quoted.toLLexpr (arity : Nat) : Quoted → TacticM Expr + | .zero => + mkAppOptM ``LLexpr.zero #[some (mkNatLit arity)] + | .var idx => + if idx < arity then + mkAppM ``LLexpr.var #[mkFinExpr idx arity] + else + throwError "llarith internal error: variable index out of bounds" + | .add lhs rhs => do + mkAppM ``LLexpr.add #[← lhs.toLLexpr arity, ← rhs.toLLexpr arity] + | .smul coeff arg => do + mkAppM ``LLexpr.smul #[coeff, ← arg.toLLexpr arity] + | .sup lhs rhs => do + mkAppM ``LLexpr.sup #[← lhs.toLLexpr arity, ← rhs.toLLexpr arity] + | .inf lhs rhs => do + mkAppM ``LLexpr.inf #[← lhs.toLLexpr arity, ← rhs.toLLexpr arity] + +/-- Build the finite tuple of vector-valued atoms used to evaluate the quoted `LLexpr`s. + +The tuple is emitted as a `PiFin` literal so that the final simplification step +can unfold each variable lookup. -/ +def mkFinFun (type : Expr) (atoms : Array Expr) : MetaM Expr := do + let .sort u ← whnf (← inferType type) + | throwError "llarith internal error: expected a type{indentExpr type}" + let some v := u.dec + | throwError "llarith only supports targets in Type" + have α : Q(Type v) := type + let atoms : Array Q($α) := atoms.map fun atom => atom + if h : atoms.isEmpty then + return q(Fin.elim0 : Fin 0 → $α) + else + return PiFin.mkLiteralQ (α := α) (n := atoms.size) fun i => atoms[i] + +/-- Prove the generated real vanishing statement. + +After introducing the real variables, this unfolds `LLexpr.eval` and first tries +`grind` on the real lattice expression. If that does not close the goal, it +falls back to expanding `max` and `min`, splitting cases, and closing the +resulting arithmetic goals with `linarith` or `nlinarith`. -/ +def proveRealVanishes (hreal : MVarId) : TacticM Unit := do + let savedGoals ← getGoals + setGoals [hreal] + try + evalTactic (← `(tactic| + intro r; + simp only [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, smul_eq_mul]; + first + | grind + | (simp only [sup_eq_maxDefault, inf_eq_minDefault, max_def, min_def]; + (repeat' split_ifs); + all_goals first + | linarith + | nlinarith))) + catch ex => + setGoals savedGoals + throwError "llarith failed to prove the associated real identity\n{ex.toMessageData}" + let remaining ← getGoals + unless remaining.isEmpty do + setGoals savedGoals + throwError "llarith failed to close the associated real identity" + setGoals savedGoals + +/-- Transfer a quoted real identity back to the original vector-lattice goal. + +If `asLe` is true, the quoted equality has the form `lhs ⊔ rhs = rhs` and is +post-processed as a proof of `lhs ≤ rhs`. -/ +def closeByTransfer (type : Expr) (lhsQ rhsQ : Quoted) (atoms : Array Expr) (asLe hasSigns : Bool) : + TacticM Unit := do + let arity := atoms.size + let lhsE ← instantiateMVars (← lhsQ.toLLexpr arity) + let rhsE ← instantiateMVars (← rhsQ.toLLexpr arity) + let diffE ← + instantiateMVars (← mkAppM ``LLexpr.add #[lhsE, ← mkAppM ``LLexpr.smul #[q((-1 : ℝ)), rhsE]]) + let hrealType ← mkAppM ``LLexpr.Vanishes #[q(ℝ), diffE] + let hreal ← mkFreshExprMVar hrealType .syntheticOpaque `llarith_real + proveRealVanishes hreal.mvarId! + let hreal ← instantiateMVars hreal + let tuple ← mkFinFun type atoms + let proof ← mkAppM ``LLexpr.eval_eq_of_vanishes_real #[tuple, lhsE, rhsE, hreal] + let proofType ← inferType proof + let transferName := `llarith_transfer + let (_, goal) ← (← (← getMainGoal).assert transferName proofType proof).intro1P + setGoals [goal] + let hIdent := mkIdent transferName + if !hasSigns then + if asLe then + evalTactic (← `(tactic| + first + | simpa [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm] using $hIdent:ident + | (simp at $hIdent:ident ⊢; + simp_all [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm]; + all_goals first + | exact $hIdent:ident + | simpa [add_assoc, add_comm, add_left_comm] using $hIdent:ident))) + else + evalTactic (← `(tactic| + first + | simpa [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm] using $hIdent:ident + | (simp at $hIdent:ident ⊢; + simp_all [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm]; + all_goals first + | exact $hIdent:ident + | convert $hIdent:ident using 1 <;> abel_nf))) + else if asLe then + evalTactic (← `(tactic| + simp at $hIdent:ident ⊢; + simp_all [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm]; + all_goals first + | exact $hIdent:ident + | simpa [add_assoc, add_comm, add_left_comm] using $hIdent:ident)) + else + evalTactic (← `(tactic| + simp at $hIdent:ident ⊢; + simp_all [LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm]; + all_goals first + | exact $hIdent:ident + | convert $hIdent:ident using 1 <;> abel_nf)) + +/-- Implementation of the user-facing `llarith` tactic. -/ +def evalLlarith : TacticM Unit := withMainContext do + let target ← instantiateMVars (← getMainTarget) + let targetWhnf ← whnf target + if let some (_, lhs, rhs) := targetWhnf.eq? <|> target.eq? then + let type ← inferType lhs + unless ← withReducible (isDefEq type (← inferType rhs)) do + throwError "llarith only supports homogeneous equality goals" + let ((lhsQ, rhsQ), state) ← + (do + let lhsQ ← quoteExpr type lhs + let rhsQ ← quoteExpr type rhs + return (lhsQ, rhsQ)).run {} + let signInfos ← collectAtomSigns type state.atoms + assertAtomSignFacts signInfos + let signs := AtomSignInfo.toSigns signInfos + let hasSigns := signInfos.any Option.isSome + closeByTransfer type (← (lhsQ.applySigns signs).simplify) + (← (rhsQ.applySigns signs).simplify) state.atoms false hasSigns + else if let some (type, lhs, rhs) := targetWhnf.le? <|> target.le? then + unless ← withReducible (isDefEq type (← inferType lhs)) do + throwError "llarith internal error: malformed inequality goal" + unless ← withReducible (isDefEq type (← inferType rhs)) do + throwError "llarith only supports homogeneous inequality goals" + let ((lhsQ, rhsQ), state) ← + (do + let lhsQ ← quoteExpr type lhs + let rhsQ ← quoteExpr type rhs + return (lhsQ, rhsQ)).run {} + let signInfos ← collectAtomSigns type state.atoms + assertAtomSignFacts signInfos + let signs := AtomSignInfo.toSigns signInfos + let hasSigns := signInfos.any Option.isSome + closeByTransfer type (← ((Quoted.sup lhsQ rhsQ).applySigns signs).simplify) + (← (rhsQ.applySigns signs).simplify) state.atoms true hasSigns + else + throwUnsupportedTarget + +/-- Prove lattice-linear identities by checking the corresponding identity over `ℝ`. + +The tactic supports equality and non-strict inequality goals built from vector-valued atoms, +`0`, `+`, `-`, unary negation, real scalar multiplication, `⊔`, `⊓`, positive and negative +parts, and absolute values. It also uses atom-level sign hypotheses of the form `0 ≤ x`, +`x ≤ 0`, `0 < x`, or `x < 0`. +-/ +elab "llarith" : tactic => evalLlarith + +end Tactic + +end LLexpr + +section Tests + +end Tests diff --git a/LeanPool/OrderClosures/GaoLeungCharacterization.lean b/LeanPool/OrderClosures/GaoLeungCharacterization.lean new file mode 100644 index 0000000000..e18daebd27 --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungCharacterization.lean @@ -0,0 +1,1039 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Substructures.Band.DisjointComplement + +public import LeanPool.OrderClosures.OrderAdherence + + +/-! +# The Gao--Leung order-continuity characterization + +This file proves Gao--Leung Theorem 2.7. The reverse implication is obtained +by contrapositive: failure of order continuity supplies an order-bounded +disjoint sequence, which gives a lattice embedding of `ℓ∞(ℕ × ℕ)` into the +ambient Banach lattice. The row-limit sublattice then separates uo-adherence +from order adherence. +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped BoundedContinuousFunction + +universe u + +section + +variable {X : Type u} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [BanachLattice X] + +/-- Extracts an order-convergent subsequence from norm convergence; used to +identify order adherence with topological closure for order-continuous norms. -/ +private theorem norm_tendsto_has_order_convergent_subsequence + {z : ℕ → X} {x : X} (hz : Tendsto z atTop (nhds x)) : + ∃ φ : ℕ → ℕ, StrictMono φ ∧ OrderConvergesTo (z ∘ φ) x := by + let V : ℕ → Set X := fun n ↦ Metric.closedBall x ((1 / 2 : ℝ) ^ n) + have hV : ∀ n, V n ∈ nhds x := fun n ↦ + Metric.closedBall_mem_nhds x (by positivity) + obtain ⟨φ, hφ, hzφ⟩ := hz.subseq_mem hV + let v : ℕ → X := fun n ↦ |z (φ n) - x| + have hv_norm : ∀ n, ‖v n‖ ≤ (1 / 2 : ℝ) ^ n := by + intro n + rw [norm_abs_eq_norm, ← dist_eq_norm] + exact hzφ n + have hv_sum : Summable v := by + apply Summable.of_norm_bounded summable_geometric_two + exact hv_norm + let r : ℕ → X := fun k ↦ ∑' n, v (n + k) + have hr_nonneg : ∀ k, 0 ≤ r k := fun k ↦ + tsum_nonneg fun n ↦ abs_nonneg _ + have hr_step : ∀ k, r k = v k + r (k + 1) := by + intro k + have hs := ((summable_nat_add_iff k).2 hv_sum).sum_add_tsum_nat_add 1 + simpa [r, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hs.symm + have hr_anti : Antitone r := antitone_nat_of_succ_le fun k ↦ by + rw [hr_step k] + exact le_add_of_nonneg_left (abs_nonneg _) + have hv_norm_sum : Summable fun n ↦ ‖v n‖ := by + apply Summable.of_nonneg_of_le (fun n ↦ norm_nonneg _) hv_norm + summable_geometric_two + have hr_tendsto : Tendsto r atTop (nhds 0) := by + apply squeeze_zero_norm + · intro k + change ‖∑' j, v (j + k)‖ ≤ ∑' j, ‖v (j + k)‖ + exact norm_tsum_le_tsum_norm ((summable_nat_add_iff k).2 hv_norm_sum) + · exact tendsto_sum_nat_add (fun n ↦ ‖v n‖) + refine ⟨φ, hφ, ?_⟩ + let K := ULift.{u} ℕ + let rr : K → X := fun k ↦ r k.down + have hrr_range : Set.range rr = Set.range r := by + ext y + constructor + · rintro ⟨k, rfl⟩ + exact ⟨k.down, rfl⟩ + · rintro ⟨k, rfl⟩ + exact ⟨ULift.up k, rfl⟩ + refine ⟨K, inferInstance, inferInstance, inferInstance, rr, + fun _ _ h ↦ hr_anti h, fun k ↦ hr_nonneg k.down, ?_, ?_⟩ + · rw [hrr_range] + exact isGLB_of_tendsto_atTop hr_anti hr_tendsto + intro k + apply eventually_atTop.mpr + refine ⟨k.down, fun n hn ↦ ?_⟩ + have htail : Summable fun j ↦ v (j + k.down) := + (summable_nat_add_iff k.down).2 hv_sum + have hterm : v (n - k.down + k.down) ≤ r k.down := by + exact htail.le_tsum (n - k.down) (fun j _ ↦ abs_nonneg _) + simpa [v, r, rr, Function.comp_apply, Nat.sub_add_cancel hn] using hterm + +/-- Identifies order adherence with norm closure under order continuity; used +for the forward implications in the Gao--Leung characterization. -/ +private theorem orderAdherence_eq_closure [IsOrderContinuousNorm X] (A : Set X) : + orderAdherence A = closure A := by + apply Set.Subset.antisymm + · rintro x ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + exact mem_closure_of_tendsto (tendsto_of_orderConvergesTo_of_isOrderContinuousNorm hfx) + (Eventually.of_forall hf) + · intro x hx + obtain ⟨z, hzA, hzx⟩ := mem_closure_iff_seq_limit.mp hx + obtain ⟨φ, hφ, hzφ⟩ := norm_tendsto_has_order_convergent_subsequence hzx + let I := ULift.{u} ℕ + refine ⟨I, inferInstance, inferInstance, inferInstance, + fun i ↦ z (φ i.down), fun i ↦ hzA _, ?_⟩ + rcases hzφ with ⟨κ, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, hbound⟩ + refine ⟨κ, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, ?_⟩ + intro k + obtain ⟨n, hn⟩ := eventually_atTop.mp (hbound k) + apply eventually_atTop.mpr + refine ⟨ULift.up n, fun i hi ↦ ?_⟩ + exact hn i.down hi + +end + +section DisjointEmbedding + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] +variable {P : Type*} + +/-- Propagates pairwise disjointness to a scalar multiple and a finite sum; +used in the finite disjoint-sum estimate below. -/ +private lemma isVLDisjoint_smul_finset_sum + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (a : P → ℝ) {p : P} {F : Finset P} (hp : p ∉ F) : + IsVLDisjoint (a p • x p) (∑ q ∈ F, a q • x q) := by + classical + induction F using Finset.induction_on with + | empty => simpa using isVLDisjoint_zero_right (a p • x p) + | @insert q F hq ih => + rw [Finset.sum_insert hq] + have hp' : p ≠ q ∧ p ∉ F := by + simpa only [Finset.mem_insert, not_or] using hp + apply IsVLDisjoint.add_right + · exact ((hx hp'.1).smul_left (a p)).smul_right (a q) + · exact ih hp'.2 + +/-- Bounds a positive finite combination of disjoint vectors by one common +order bound; this supplies boundedness for the supremum defining the embedding. -/ +private lemma finset_disjoint_sum_le + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {b : X} (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {a : P → ℝ} {M : ℝ} (hM : 0 ≤ M) + (ha : ∀ p, 0 ≤ a p ∧ a p ≤ M) (F : Finset P) : + ∑ p ∈ F, a p • x p ≤ M • b := by + classical + induction F using Finset.induction_on with + | empty => simpa using smul_nonneg hM hb + | @insert p F hp ih => + rw [Finset.sum_insert hp] + have hterm : a p • x p ≤ M • b := + (smul_le_smul_of_nonneg_left (hxb p).2 (ha p).1).trans + (smul_le_smul_of_nonneg_right (ha p).2 hb) + have hterm0 : 0 ≤ a p • x p := smul_nonneg (ha p).1 (hxb p).1 + have hsum0 : 0 ≤ ∑ q ∈ F, a q • x q := by + exact Finset.sum_nonneg fun q _ ↦ smul_nonneg (ha q).1 (hxb q).1 + have hdisj := isVLDisjoint_smul_finset_sum hx a hp + have hadd : a p • x p + ∑ q ∈ F, a q • x q = + a p • x p ⊔ ∑ q ∈ F, a q • x q := by + simpa [abs_of_nonneg hterm0, abs_of_nonneg hsum0] using + (sup_abs_eq_add_abs_of_isVLDisjoint hdisj).symm + rw [hadd] + exact sup_le hterm ih + +end DisjointEmbedding + +section DisjointEmbedding + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] +variable {P : Type*} [TopologicalSpace P] [DiscreteTopology P] [Countable P] + +/-- Supplies the vector-lattice structure on bounded scalar functions required +as the domain of `disjointEmbedding`. -/ +private noncomputable instance boundedContinuousFunctionVectorLattice : + VectorLattice (P →ᵇ ℝ) where + toModule := inferInstance + smul_le_smul_of_nonneg_left := by + intro a ha f g h p + exact mul_le_mul_of_nonneg_left (h p) ha + +/-- The finite positive combinations approximating the disjoint embedding; +their supremum is defined separately as `disjointSup`. -/ +private noncomputable def disjointFiniteSum (x : P → X) + (a : P →ᵇ ℝ) (F : Finset P) : X := + ∑ p ∈ F, a p • x p + +/-- The supremum of all finite coefficient sums; used as the positive-cone +map extended linearly in `disjointEmbedding`. -/ +private noncomputable def disjointSup (x : P → X) (a : P →ᵇ ℝ) : X := + sSup (Set.range (disjointFiniteSum x a)) + +omit [DiscreteTopology P] in +/-- Packages the defining finite sums as a genuine least upper bound; reused +throughout the construction of `disjointEmbedding`. -/ +private theorem disjointSup_isLUB + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {b : X} (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {a : P →ᵇ ℝ} (ha : 0 ≤ a) : + IsLUB (Set.range (disjointFiniteSum x a)) (disjointSup x a) := by + classical + have ha' : ∀ p, 0 ≤ a p ∧ a p ≤ ‖a‖ := by + intro p + exact ⟨ha p, (le_abs_self (a p)).trans + (by simpa [Real.norm_eq_abs] using a.norm_coe_le_norm p)⟩ + have hbound : BddAbove (Set.range (disjointFiniteSum x a)) := by + refine ⟨‖a‖ • b, ?_⟩ + rintro _ ⟨F, rfl⟩ + exact finset_disjoint_sum_le hx hb hxb (norm_nonneg a) ha' F + refine ⟨?_, ?_⟩ + · intro y hy + exact SigmaConditionallyCompleteLattice.le_csSup _ _ (Set.countable_range _) + hbound hy + · intro y hy + exact SigmaConditionallyCompleteLattice.csSup_le _ _ (Set.countable_range _) + (Set.range_nonempty _) hy + +omit [DiscreteTopology P] in +/-- Records positivity of `disjointSup`; needed by the positive linear +extension used to construct `disjointEmbedding`. -/ +private theorem disjointSup_nonneg + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {b : X} (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {a : P →ᵇ ℝ} (ha : 0 ≤ a) : + 0 ≤ disjointSup x a := by + apply (disjointSup_isLUB hx hb hxb ha).1 + exact ⟨∅, by simp [disjointFiniteSum]⟩ + +omit [DiscreteTopology P] in +/-- Proves additivity of `disjointSup` on the positive cone, the second input +to the positive linear extension defining `disjointEmbedding`. -/ +private theorem disjointSup_add + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {b : X} (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {a c : P →ᵇ ℝ} (ha : 0 ≤ a) (hc : 0 ≤ c) : + disjointSup x (a + c) = disjointSup x a + disjointSup x c := by + classical + have hac : 0 ≤ a + c := add_nonneg ha hc + have hA := disjointSup_isLUB hx hb hxb ha + have hC := disjointSup_isLUB hx hb hxb hc + have hAC := disjointSup_isLUB hx hb hxb hac + apply le_antisymm + · apply hAC.2 + rintro _ ⟨F, rfl⟩ + simp only [disjointFiniteSum, BoundedContinuousFunction.add_apply, add_smul, + Finset.sum_add_distrib] + exact add_le_add (hA.1 ⟨F, rfl⟩) (hC.1 ⟨F, rfl⟩) + · rw [add_comm, ← le_sub_iff_add_le] + apply hC.2 + rintro _ ⟨G, rfl⟩ + rw [le_sub_iff_add_le] + rw [add_comm, ← le_sub_iff_add_le] + apply hA.2 + rintro _ ⟨F, rfl⟩ + rw [le_sub_iff_add_le] + let H := F ∪ G + have hFa : disjointFiniteSum x a F ≤ disjointFiniteSum x a H := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_union_left) + intro p _ _ + exact smul_nonneg (ha p) (hxb p).1 + have hGc : disjointFiniteSum x c G ≤ disjointFiniteSum x c H := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.subset_union_right) + intro p _ _ + exact smul_nonneg (hc p) (hxb p).1 + calc + disjointFiniteSum x a F + disjointFiniteSum x c G ≤ + disjointFiniteSum x a H + disjointFiniteSum x c H := add_le_add hFa hGc + _ = disjointFiniteSum x (a + c) H := by + simp only [disjointFiniteSum, BoundedContinuousFunction.add_apply, add_smul, + Finset.sum_add_distrib] + _ ≤ disjointSup x (a + c) := hAC.1 ⟨H, rfl⟩ + +/-- Converts disjoint scalar coefficients on one vector into disjoint scalar +multiples; used when comparing finite sums with disjoint coefficient functions. -/ +private lemma isVLDisjoint_smul_same_of_inf_eq_zero + {x : X} {a c : ℝ} (hac : a ⊓ c = 0) : + IsVLDisjoint (a • x) (c • x) := by + by_cases hle : a ≤ c + · have ha0 : a = 0 := by simpa [inf_eq_left.mpr hle] using hac + rw [ha0, zero_smul] + exact isVLDisjoint_zero_left _ + · have hc0 : c = 0 := by + simpa [inf_eq_right.mpr (le_of_not_ge hle)] using hac + rw [hc0, zero_smul] + exact isVLDisjoint_zero_right _ + +omit [DiscreteTopology P] [Countable P] in +/-- Extends coefficientwise disjointness from one summand to a finite sum; +used to prove disjointness of two finite approximating sums. -/ +private lemma isVLDisjoint_smul_finset_sum_of_inf_eq_zero + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {a c : P →ᵇ ℝ} (hac : a ⊓ c = 0) + (p : P) (G : Finset P) : + IsVLDisjoint (a p • x p) (disjointFiniteSum x c G) := by + classical + induction G using Finset.induction_on with + | empty => simpa [disjointFiniteSum] using isVLDisjoint_zero_right (a p • x p) + | @insert q G hq ih => + rw [disjointFiniteSum, Finset.sum_insert hq] + apply IsVLDisjoint.add_right + · by_cases hpq : p = q + · subst q + apply isVLDisjoint_smul_same_of_inf_eq_zero + have hp := congrArg (fun f : P →ᵇ ℝ ↦ f p) hac + simpa using hp + · exact ((hx hpq).smul_left (a p)).smul_right (c q) + · simpa [disjointFiniteSum] using ih + +omit [DiscreteTopology P] [Countable P] in +/-- Shows that finite sums with disjoint coefficient functions are disjoint; +used to pass disjointness to their order suprema. -/ +private lemma isVLDisjoint_finset_sums_of_inf_eq_zero + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {a c : P →ᵇ ℝ} (hac : a ⊓ c = 0) + (F G : Finset P) : + IsVLDisjoint (disjointFiniteSum x a F) (disjointFiniteSum x c G) := by + classical + induction F using Finset.induction_on with + | empty => simpa [disjointFiniteSum] using isVLDisjoint_zero_left (disjointFiniteSum x c G) + | @insert p F hp ih => + rw [disjointFiniteSum, Finset.sum_insert hp] + exact IsVLDisjoint.add_left + (isVLDisjoint_smul_finset_sum_of_inf_eq_zero hx hac p G) + (by simpa [disjointFiniteSum] using ih) + +omit [DiscreteTopology P] in +/-- Passes disjointness of coefficient functions to the corresponding +`disjointSup` values; this proves that the eventual embedding is a lattice map. -/ +private theorem disjointSup_disjoint + {x : P → X} (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + {b : X} (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {a c : P →ᵇ ℝ} (hac : a ⊓ c = 0) : + disjointSup x a ⊓ disjointSup x c = 0 := by + have ha : 0 ≤ a := hac ▸ inf_le_left + have hc : 0 ≤ c := hac ▸ inf_le_right + have hA := disjointSup_isLUB hx hb hxb ha + have hC := disjointSup_isLUB hx hb hxb hc + let BC : Band X := Band.disjointComplement {disjointSup x c} + have hfiniteA : Set.range (disjointFiniteSum x a) ⊆ (BC : Set X) := by + rintro _ ⟨F, rfl⟩ _ hz + simp only [Set.mem_singleton_iff] at hz + subst hz + let BF : Band X := Band.disjointComplement {disjointFiniteSum x a F} + have hfiniteC : Set.range (disjointFiniteSum x c) ⊆ (BF : Set X) := by + rintro _ ⟨G, rfl⟩ _ hz + simp only [Set.mem_singleton_iff] at hz + subst hz + exact isVLDisjoint_comm.mp + (isVLDisjoint_finset_sums_of_inf_eq_zero hx hac F G) + have htauC : disjointSup x c ∈ BF := + BF.sSup_mem hfiniteC (Set.range_nonempty _) hC + exact isVLDisjoint_comm.mp (htauC _ rfl) + have htauA : disjointSup x a ∈ BC := + BC.sSup_mem hfiniteA (Set.range_nonempty _) hA + exact inf_eq_zero_of_isVLDisjoint + (disjointSup_nonneg hx hb hxb ha) (disjointSup_nonneg hx hb hxb hc) + (htauA _ rfl) + +/-- Embeds bounded coefficient functions along a disjoint family; this is the +main device used to transport the row-limit counterexample into `X`. -/ +private noncomputable def disjointEmbedding + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) : + VecLatHom (P →ᵇ ℝ) X := by + letI : IsVLArchimedean X := IsVLArchimedean_of_sigmaConditionallyCompleteLattice + let tau : (P →ᵇ ℝ) → X := disjointSup x + have htau_nonneg : ∀ a, 0 ≤ a → 0 ≤ tau a := + fun _ ha ↦ disjointSup_nonneg hx hb hxb ha + have htau_add : ∀ a c, 0 ≤ a → 0 ≤ c → tau (a + c) = tau a + tau c := + fun _ _ ha hc ↦ disjointSup_add hx hb hxb ha hc + let T : (P →ᵇ ℝ) →ₗ[ℝ] X := Positive.extension htau_nonneg htau_add + apply IsVecLatHom.mk' T + apply IsVecLatHom.of_disjoint T.isLinear (Positive.extension_positive htau_nonneg htau_add) + intro a c hac + have ha : 0 ≤ a := hac ▸ inf_le_left + have hc : 0 ≤ c := hac ▸ inf_le_right + rw [Positive.extension_nonneg htau_nonneg htau_add ha, + Positive.extension_nonneg htau_nonneg htau_add hc] + exact disjointSup_disjoint hx hb hxb hac + +omit [DiscreteTopology P] in +/-- Evaluates `disjointEmbedding` on the positive cone as `disjointSup`; used +for its order, norm, and band estimates. -/ +private theorem disjointEmbedding_apply_nonneg + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + (a : P →ᵇ ℝ) (ha : 0 ≤ a) : + disjointEmbedding x hx b hb hxb a = disjointSup x a := by + rw [disjointEmbedding] + exact Positive.extension_nonneg + (fun _ ha ↦ disjointSup_nonneg hx hb hxb ha) + (fun _ _ ha hc ↦ disjointSup_add hx hb hxb ha hc) ha + +omit [DiscreteTopology P] in +/-- Controls each coordinate summand by the absolute value of its embedded +vector; used both for the lower norm estimate and coordinate convergence. -/ +private theorem abs_apply_smul_le_abs_disjointEmbedding + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + (a : P →ᵇ ℝ) (p : P) : + |a p| • x p ≤ |disjointEmbedding x hx b hb hxb a| := by + rw [← (disjointEmbedding x hx b hb hxb).map_abs, + disjointEmbedding_apply_nonneg x hx b hb hxb |a| (abs_nonneg a)] + apply (disjointSup_isLUB hx hb hxb (abs_nonneg a)).1 + refine ⟨{p}, ?_⟩ + simp [disjointFiniteSum] + +omit [DiscreteTopology P] in +/-- Gives the embedding a uniform lower norm bound from the disjoint sequence; +used to bound coefficient functions in the row-limit exclusion argument. -/ +private theorem disjointEmbedding_lower_bound + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {ε : ℝ} (hε : 0 < ε) (hxnorm : ∀ p, ε ≤ ‖x p‖) (a : P →ᵇ ℝ) : + ε * ‖a‖ ≤ ‖disjointEmbedding x hx b hb hxb a‖ := by + have hcoord : ∀ p, ε * |a p| ≤ ‖disjointEmbedding x hx b hb hxb a‖ := by + intro p + have horder := abs_apply_smul_le_abs_disjointEmbedding x hx b hb hxb a p + have hnorm : ‖|a p| • x p‖ ≤ ‖disjointEmbedding x hx b hb hxb a‖ := by + rw [← norm_abs_eq_norm (disjointEmbedding x hx b hb hxb a)] + apply norm_le_norm_of_abs_le_abs + simpa [abs_of_nonneg (smul_nonneg (abs_nonneg _) (hxb p).1)] using horder + calc + ε * |a p| ≤ ‖x p‖ * |a p| := by gcongr; exact hxnorm p + _ = ‖|a p| • x p‖ := by + rw [norm_smul, Real.norm_of_nonneg (abs_nonneg _), mul_comm] + _ ≤ _ := hnorm + have hanorm : ‖a‖ ≤ ε⁻¹ * ‖disjointEmbedding x hx b hb hxb a‖ := by + apply (BoundedContinuousFunction.norm_le (mul_nonneg (inv_nonneg.mpr hε.le) + (norm_nonneg _))).2 + intro p + rw [Real.norm_eq_abs, le_inv_mul_iff₀ hε] + simpa [mul_comm] using hcoord p + calc + ε * ‖a‖ ≤ ε * (ε⁻¹ * ‖disjointEmbedding x hx b hb hxb a‖) := + mul_le_mul_of_nonneg_left hanorm hε.le + _ = ‖disjointEmbedding x hx b hb hxb a‖ := by field_simp + +omit [DiscreteTopology P] in +/-- Places positive embedded functions in the band generated by the disjoint +family; used in the proof of coordinatewise uo-convergence. -/ +private theorem disjointEmbedding_nonneg_mem_doubleDisjointComplement + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + (a : P →ᵇ ℝ) (ha : 0 ≤ a) : + disjointEmbedding x hx b hb hxb a ∈ (Set.range x)ᵈᵈ := by + let B : Band X := Band.disjointComplement ((Set.range x)ᵈ) + rw [disjointEmbedding_apply_nonneg x hx b hb hxb a ha] + apply B.sSup_mem (S := Set.range (disjointFiniteSum x a)) + · rintro _ ⟨F, rfl⟩ + apply B.toOrderIdeal.toSubmodule.sum_mem + intro p hp + apply B.toOrderIdeal.toSubmodule.smul_mem + exact subset_disjointComplement_disjointComplement (Set.range x) ⟨p, rfl⟩ + · exact Set.range_nonempty _ + · exact disjointSup_isLUB hx hb hxb ha + +omit [DiscreteTopology P] in +/-- A zero coefficient makes the embedded vector disjoint from that coordinate; +used to show that eventually vanishing coordinates converge uo. -/ +private theorem isVLDisjoint_disjointEmbedding_of_apply_eq_zero + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + (a : P →ᵇ ℝ) (ha : 0 ≤ a) (p : P) (hap : a p = 0) : + IsVLDisjoint (disjointEmbedding x hx b hb hxb a) (x p) := by + classical + let B : Band X := Band.disjointComplement {x p} + rw [disjointEmbedding_apply_nonneg x hx b hb hxb a ha] + have hfinite : Set.range (disjointFiniteSum x a) ⊆ (B : Set X) := by + rintro _ ⟨F, rfl⟩ + change ∀ y ∈ ({x p} : Set X), IsVLDisjoint (disjointFiniteSum x a F) y + intro y hy + rw [Set.mem_singleton_iff] at hy + subst y + induction F using Finset.induction_on with + | empty => simpa [disjointFiniteSum] using isVLDisjoint_zero_left (x p) + | @insert q F hq ih => + rw [disjointFiniteSum, Finset.sum_insert hq] + apply IsVLDisjoint.add_left + · by_cases hqp : q = p + · subst q + rw [hap, zero_smul] + exact isVLDisjoint_zero_left _ + · exact (hx hqp).smul_left (a q) + · simpa [disjointFiniteSum] using ih + have htau : disjointSup x a ∈ B := + B.sSup_mem hfinite (Set.range_nonempty _) (disjointSup_isLUB hx hb hxb ha) + exact htau _ rfl + +end DisjointEmbedding + +section DisjointSequence + +variable {X : Type u} [NormedAddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [BanachLattice X] + +/-- Extracts a positive order-bounded disjoint sequence with norms bounded away +from zero from failure of order continuity; this starts the reverse implication. -/ +private theorem exists_orderBounded_disjoint_sequence_norm_bounded_away + (hX : ¬ IsOrderContinuousNorm X) : + ∃ (ε : ℝ) (b : X) (x : ℕ → X), 0 < ε ∧ 0 ≤ b ∧ + Pairwise (fun m n ↦ IsVLDisjoint (x m) (x n)) ∧ + ∀ n, 0 ≤ x n ∧ x n ≤ b ∧ ε ≤ ‖x n‖ := by + classical + rw [BanachLattice.isOrderContinuousNorm_iff_disjoint_tendsto_zero] at hX + push Not at hX + obtain ⟨z, hzdisj, hzbdd, hznot⟩ := hX + rw [Metric.tendsto_atTop] at hznot + push Not at hznot + obtain ⟨ε, hε, hzlarge⟩ := hznot + let S : Set ℕ := {n | ε ≤ ‖z n‖} + have hSinf : S.Infinite := by + apply Set.infinite_of_not_bddAbove + rintro ⟨N, hN⟩ + obtain ⟨n, hn, hnε⟩ := hzlarge (N + 1) + have hnS : n ∈ S := by simpa [S, dist_zero_right] using hnε + have := hN hnS + omega + let e : ℕ ↪ S := hSinf.natEmbedding S + let φ : ℕ → ℕ := fun n ↦ (e n).1 + let x : ℕ → X := fun n ↦ |z (φ n)| + obtain ⟨b, hb⟩ := hzbdd + have hxb : ∀ n, x n ≤ b := fun n ↦ hb ⟨φ n, rfl⟩ + have hb0 : 0 ≤ b := (abs_nonneg (z (φ 0))).trans (hxb 0) + refine ⟨ε, b, x, hε, hb0, ?_, ?_⟩ + · intro m n hmn + have hφ : φ m ≠ φ n := by + intro h + apply hmn + exact e.injective (Subtype.ext h) + simpa [x, IsVLDisjoint] using hzdisj hφ + · intro n + refine ⟨abs_nonneg _, hxb n, ?_⟩ + have he : (e n).1 ∈ S := (e n).2 + change ε ≤ ‖z (φ n)‖ at he + simpa [x, norm_abs_eq_norm] using he + +end DisjointSequence + +section RowLimitSublattice + +/-- The two-dimensional coordinate set used by the row-limit example. -/ +private abbrev PairIndex := ℕ × ℕ + +/-- Bounded scalar functions on the row-limit coordinate set. -/ +private abbrev PairLInfinity := PairIndex →ᵇ ℝ + +/-- Functions whose row tails converge to the scaled row head; bundled first +as a submodule before adding lattice closure. -/ +private def rowLimitSubmodule : Submodule ℝ PairLInfinity where + carrier := {a | ∀ m : ℕ, + Tendsto (fun n : ℕ ↦ a (m, n + 1)) atTop + (nhds ((m + 1 : ℕ) * a (m, 0)))} + zero_mem' := by simp + add_mem' := by + intro a c ha hc m + simpa [mul_add] using (ha m).add (hc m) + smul_mem' := by + intro r a ha m + simpa [mul_assoc, mul_left_comm, mul_comm] using (ha m).const_smul r + +/-- The row-limit submodule as a vector sublattice; its image supplies the +sublattice separating order adherence from uo-adherence. -/ +private noncomputable def rowLimitSublattice : VectorSublattice PairLInfinity := + VectorSublattice.ofAbsClosed rowLimitSubmodule fun a ha ↦ by + intro m + change Tendsto (fun k => |a (m, k + 1)|) atTop (𝓝 ((m + 1 : ℕ) * |a (m, 0)|)) + simpa only [abs_mul, abs_of_nonneg (by positivity : (0 : ℝ) ≤ (m + 1 : ℕ))] + using (ha m).abs + +/-- The limiting row-head function that belongs to uo-adherence but will be +excluded from order adherence. -/ +private noncomputable def rowHead : PairLInfinity := + BoundedContinuousFunction.ofNormedAddCommGroupDiscrete + (fun p : PairIndex ↦ if p.2 = 0 then 1 else 0) 1 (by + intro p + simp [Real.norm_eq_abs] + split_ifs <;> norm_num) + +/-- Finite row approximations to `rowHead`; these lie in `rowLimitSublattice` +and agree eventually at every coordinate. -/ +private noncomputable def rowApprox (j : ℕ) : PairLInfinity := + BoundedContinuousFunction.ofNormedAddCommGroupDiscrete + (fun p : PairIndex ↦ + if p.2 = 0 then + if p.1 ≤ j then 1 else 0 + else if p.1 ≤ j ∧ j < p.2 then (p.1 + 1 : ℕ) else 0) + (j + 1) (by + intro p + rw [Real.norm_eq_abs] + by_cases hn : p.2 = 0 + · simp only [hn, ite_true] + by_cases hm : p.1 ≤ j + · rw [ite_eq_left hm, abs_one] + exact_mod_cast Nat.succ_le_succ (Nat.zero_le j) + · rw [ite_eq_right hm, abs_zero] + positivity + · simp only [hn, ite_false] + by_cases ht : p.1 ≤ j ∧ j < p.2 + · rw [ite_eq_left ht, abs_of_nonneg (by positivity)] + exact_mod_cast Nat.succ_le_succ ht.1 + · rw [ite_eq_right ht, abs_zero] + positivity) + +/-- Verifies that every finite row approximation belongs to the row-limit +sublattice, so its image can witness uo-adherence. -/ +private theorem rowApprox_mem (j : ℕ) : rowApprox j ∈ rowLimitSublattice := by + intro m + by_cases hm : m ≤ j + · have heq : + (fun n : ℕ ↦ rowApprox j (m, n + 1)) =ᶠ[atTop] + (fun _ ↦ (m + 1 : ℕ)) := by + apply eventually_atTop.mpr + refine ⟨j, fun n hn ↦ ?_⟩ + simp [rowApprox, hm] + omega + have ht := tendsto_const_nhds.congr' heq.symm + simpa [rowApprox, hm] using ht + · have heq : + (fun n : ℕ ↦ rowApprox j (m, n + 1)) =ᶠ[atTop] + (fun _ ↦ 0) := by + filter_upwards with n + simp [rowApprox, hm] + have ht := tendsto_const_nhds.congr' heq.symm + simp [rowApprox, hm] + +/-- Records eventual coordinatewise agreement of the row approximations with +`rowHead`; this is the input for their embedded uo-convergence. -/ +private theorem rowApprox_eventually_apply_eq_rowHead (p : PairIndex) : + ∀ᶠ j in atTop, rowApprox j p = rowHead p := by + apply eventually_atTop.mpr + refine ⟨max p.1 p.2, fun j hj ↦ ?_⟩ + by_cases hn : p.2 = 0 + · simp [rowApprox, rowHead, hn] + omega + · simp [rowApprox, rowHead, hn] + omega + +end RowLimitSublattice + +section CoordinatewiseUO + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] +variable {P : Type*} [TopologicalSpace P] [DiscreteTopology P] [Countable P] + +omit [DiscreteTopology P] [Countable P] in +/-- Turns eventual coordinatewise vanishing into order convergence after +clamping; used to establish uo-convergence of the disjoint embedding. -/ +private theorem orderConvergesTo_inf_of_eventually_coordinate_zero + (x : P → X) (T : VecLatHom (P →ᵇ ℝ) X) (d : ℕ → P →ᵇ ℝ) + (hd0 : ∀ j, 0 ≤ d j) + (hband : ∀ j, T (d j) ∈ (Set.range x)ᵈᵈ) + (hdisj : ∀ j p, d j p = 0 → IsVLDisjoint (T (d j)) (x p)) + (hdzero : ∀ p, ∀ᶠ j in atTop, d j p = 0) (w : X) (hw : 0 ≤ w) : + OrderConvergesTo (fun j ↦ T (d j) ⊓ w) 0 := by + classical + let z : ℕ → X := fun j ↦ T (d j) ⊓ w + have hTd0 : ∀ j, 0 ≤ T (d j) := fun j ↦ + by simpa using T.monotone (hd0 j) + have hz0 : ∀ j, 0 ≤ z j := fun j ↦ le_inf (hTd0 j) hw + have hzw : ∀ j, z j ≤ w := fun _ ↦ inf_le_right + let r : ℕ → X := fun k ↦ sSup (Set.range fun j ↦ z (j + k)) + have hrLUB : ∀ k, IsLUB (Set.range fun j ↦ z (j + k)) (r k) := by + intro k + refine ⟨?_, ?_⟩ + · intro y hy + exact SigmaConditionallyCompleteLattice.le_csSup _ _ (Set.countable_range _) + ⟨w, by rintro _ ⟨j, rfl⟩; exact hzw (j + k)⟩ hy + · intro y hy + exact SigmaConditionallyCompleteLattice.csSup_le _ _ (Set.countable_range _) + (Set.range_nonempty _) hy + have hr0 : ∀ k, 0 ≤ r k := fun k ↦ + (hz0 k).trans ((hrLUB k).1 ⟨0, by simp⟩) + have hranti : Antitone r := antitone_nat_of_succ_le fun k ↦ by + apply (hrLUB (k + 1)).2 + rintro _ ⟨j, rfl⟩ + apply (hrLUB k).1 + exact ⟨j + 1, congrArg z (by omega)⟩ + let q : X := sInf (Set.range r) + have hqGLB : IsGLB (Set.range r) q := by + refine ⟨?_, ?_⟩ + · intro y hy + exact SigmaConditionallyCompleteLattice.csInf_le _ _ (Set.countable_range _) + ⟨0, by rintro _ ⟨k, rfl⟩; exact hr0 k⟩ hy + · intro y hy + exact SigmaConditionallyCompleteLattice.le_csInf _ _ (Set.countable_range _) + (Set.range_nonempty _) hy + have hq0 : 0 ≤ q := hqGLB.2 (by rintro _ ⟨k, rfl⟩; exact hr0 k) + let A : Set X := Set.range x + let B : Band X := Band.disjointComplement Aᵈ + have hzB : ∀ j, z j ∈ B := by + intro j + apply B.toOrderIdeal.solid (hband j) (hz0 j) inf_le_left + have hrB : ∀ k, r k ∈ B := fun k ↦ + B.sSup_mem (by rintro _ ⟨j, rfl⟩; exact hzB (j + k)) + (Set.range_nonempty _) (hrLUB k) + have hqB : q ∈ B := + B.toOrderIdeal.solid (hrB 0) hq0 (hqGLB.1 ⟨0, rfl⟩) + have hq_disjoint : q ∈ Aᵈ := by + intro y hy + obtain ⟨p, rfl⟩ := hy + obtain ⟨N, hN⟩ := eventually_atTop.mp (hdzero p) + let D : Band X := Band.disjointComplement {x p} + have hzD : Set.range (fun j ↦ z (j + N)) ⊆ (D : Set X) := by + rintro _ ⟨j, rfl⟩ _ hy' + rw [Set.mem_singleton_iff] at hy' + subst hy' + have hTd := hdisj (j + N) p (hN (j + N) (by omega)) + apply hTd.mono_left + rw [abs_of_nonneg (hz0 (j + N)), abs_of_nonneg (hTd0 (j + N))] + exact inf_le_left + have hrD : r N ∈ D := + D.sSup_mem hzD (Set.range_nonempty _) (hrLUB N) + apply (hrD _ rfl).mono_left + simp only [abs_of_nonneg hq0, abs_of_nonneg (hr0 N)] + exact hqGLB.1 ⟨N, rfl⟩ + have hqeq : q = 0 := by + apply Set.mem_singleton_iff.mp + exact disjointComplement_inter_eq_zero Aᵈ ⟨hq_disjoint, hqB⟩ + have hrGLB : IsGLB (Set.range r) 0 := by simpa [hqeq] using hqGLB + refine ⟨ULift.{u} ℕ, inferInstance, inferInstance, inferInstance, + fun k ↦ r k.down, fun _ _ h ↦ hranti h, fun k ↦ hr0 k.down, ?_, ?_⟩ + · have hrange : Set.range (fun k : ULift.{u} ℕ ↦ r k.down) = Set.range r := by + ext y + constructor + · rintro ⟨k, rfl⟩; exact ⟨k.down, rfl⟩ + · rintro ⟨k, rfl⟩; exact ⟨ULift.up k, rfl⟩ + rw [hrange] + exact hrGLB + · intro k + apply eventually_atTop.mpr + refine ⟨k.down, fun j hj ↦ ?_⟩ + have hzle : z j ≤ r k.down := by + apply (hrLUB k.down).1 + exact ⟨j - k.down, congrArg z (Nat.sub_add_cancel hj)⟩ + simpa [abs_of_nonneg (hz0 j), z] using hzle + +omit [DiscreteTopology P] in +/-- Transfers eventual coordinatewise equality to uo-convergence through the +disjoint embedding; applied to `rowApprox` and `rowHead`. -/ +private theorem disjointEmbedding_uoConverges_of_eventuallyEq + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + (a : ℕ → P →ᵇ ℝ) (e : P →ᵇ ℝ) + (hae : ∀ p, ∀ᶠ j in atTop, a j p = e p) : + UOConvergesTo (fun j ↦ disjointEmbedding x hx b hb hxb (a j)) + (disjointEmbedding x hx b hb hxb e) := by + classical + let T := disjointEmbedding x hx b hb hxb + let d : ℕ → P →ᵇ ℝ := fun j ↦ |a j - e| + have hd0 : ∀ j, 0 ≤ d j := fun _ ↦ abs_nonneg _ + intro w hw + have hz := orderConvergesTo_inf_of_eventually_coordinate_zero x T d hd0 + (fun j ↦ disjointEmbedding_nonneg_mem_doubleDisjointComplement + x hx b hb hxb (d j) (hd0 j)) + (fun j p hp ↦ isVLDisjoint_disjointEmbedding_of_apply_eq_zero + x hx b hb hxb (d j) (hd0 j) p hp) + (fun p ↦ (hae p).mono fun j hj ↦ by simp [d, hj]) w hw + convert hz using 1 + ext j + dsimp only [d] + change |T (a j) - T e| ⊓ w = T |a j - e| ⊓ w + apply congrArg (fun y : X ↦ y ⊓ w) + calc + |T (a j) - T e| = |T (a j - e)| := congrArg abs (map_sub T (a j) e).symm + _ = T |a j - e| := (T.map_abs _).symm + +end CoordinatewiseUO + +section SublatticeImage + +variable {E : Type*} {X : Type*} + [AddCommGroup E] [Lattice E] [IsOrderedAddMonoid E] [VectorLattice E] + [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] [VectorLattice X] + +/-- Bundles the image of a vector sublattice under a lattice homomorphism; +used to place the row-limit construction inside the ambient lattice. -/ +private def vectorSublatticeImage (T : VecLatHom E X) (H : VectorSublattice E) : + VectorSublattice X where + carrier := T '' (H : Set E) + zero_mem' := ⟨0, H.toSubmodule.zero_mem, map_zero T⟩ + add_mem' := by + rintro _ _ ⟨a, ha, rfl⟩ ⟨c, hc, rfl⟩ + exact ⟨a + c, H.toSubmodule.add_mem ha hc, map_add T a c⟩ + smul_mem' := by + rintro r _ ⟨a, ha, rfl⟩ + exact ⟨r • a, H.toSubmodule.smul_mem r ha, map_smul T r a⟩ + sup_mem' := by + rintro _ _ ⟨a, ha, rfl⟩ ⟨c, hc, rfl⟩ + exact ⟨a ⊔ c, H.sup_mem ha hc, T.map_sup' a c⟩ + +end SublatticeImage + +section CoordinateConvergence + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] +variable {P : Type*} [TopologicalSpace P] [DiscreteTopology P] [Countable P] + +omit [DiscreteTopology P] in +/-- Recovers convergence of each nonzero coordinate from order convergence of +embedded functions; used to exclude `rowHead` from order adherence. -/ +private theorem tendsto_apply_of_disjointEmbedding_orderConvergesTo + (x : P → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {I : Type*} [Preorder I] + (c : I → P →ᵇ ℝ) (e : P →ᵇ ℝ) + (hc : OrderConvergesTo + (fun i ↦ disjointEmbedding x hx b hb hxb (c i)) + (disjointEmbedding x hx b hb hxb e)) (p : P) (hxp : x p ≠ 0) : + Tendsto (fun i ↦ c i p) atTop (nhds (e p)) := by + classical + rw [Metric.tendsto_nhds] + by_contra hnot + push Not at hnot + obtain ⟨δ, hδ, hfreq⟩ := hnot + rcases hc with ⟨K, hpre, hdir, hne, r, hranti, hr0, hrglb, hbound⟩ + let : Preorder K := hpre + let : IsDirected K (· ≤ ·) := hdir + let : Nonempty K := hne + have hlower : δ • x p ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + obtain ⟨i, hiδ, hibound⟩ := (hfreq.and_eventually (hbound k)).exists + have hcoeff := abs_apply_smul_le_abs_disjointEmbedding + x hx b hb hxb (c i - e) p + have hscale : δ • x p ≤ |c i p - e p| • x p := by + apply smul_le_smul_of_nonneg_right + · simpa [Real.dist_eq] using hiδ + · exact (hxb p).1 + calc + δ • x p ≤ |c i p - e p| • x p := hscale + _ ≤ |disjointEmbedding x hx b hb hxb (c i - e)| := by simpa using hcoeff + _ = |disjointEmbedding x hx b hb hxb (c i) - + disjointEmbedding x hx b hb hxb e| := by rw [map_sub] + _ ≤ r k := hibound + have hnonpos : δ • x p ≤ 0 := hrglb.2 hlower + have hzero : δ • x p = 0 := + le_antisymm hnonpos (smul_nonneg hδ.le (hxb p).1) + exact (smul_ne_zero hδ.ne' hxp) hzero + +end CoordinateConvergence + +section RowLimitExclusion + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] + +/-- Shows that the embedded row head is not an order-adherence point of the +row-limit image, providing the strict separation needed in the counterexample. -/ +private theorem rowHead_not_mem_orderAdherence_image + (x : PairIndex → X) (hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q)) + (b : X) (hb : 0 ≤ b) (hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b) + {ε : ℝ} (hε : 0 < ε) (hxnorm : ∀ p, ε ≤ ‖x p‖) : + disjointEmbedding x hx b hb hxb rowHead ∉ + orderAdherence (vectorSublatticeImage + (disjointEmbedding x hx b hb hxb) rowLimitSublattice : Set X) := by + classical + let T := disjointEmbedding x hx b hb hxb + let Y := vectorSublatticeImage T rowLimitSublattice + rintro ⟨I, hpre, hdir, hne, f, hfY, hforder⟩ + let : Preorder I := hpre + let : IsDirected I (· ≤ ·) := hdir + let : Nonempty I := hne + have hpreimage : ∀ i, ∃ c : PairLInfinity, c ∈ rowLimitSublattice ∧ T c = f i := by + intro i + exact hfY i + choose c hcH hcT using hpreimage + have hcorder : OrderConvergesTo (fun i ↦ T (c i)) (T rowHead) := by + convert hforder using 1 + ext i + exact hcT i + have hcorder' := hcorder + rcases hcorder' with ⟨K, hkpre, hkdir, hkne, r, hranti, hr0, hrglb, hbound⟩ + let : Preorder K := hkpre + let : IsDirected K (· ≤ ·) := hkdir + let : Nonempty K := hkne + let k₀ : K := Classical.choice inferInstance + let C : ℝ := ‖r k₀‖ + ‖T rowHead‖ + have hTbound : ∀ᶠ i in atTop, ‖T (c i)‖ ≤ C := by + filter_upwards [hbound k₀] with i hi + have hdiff : ‖T (c i) - T rowHead‖ ≤ ‖r k₀‖ := by + apply norm_le_norm_of_abs_le_abs + simpa [abs_of_nonneg (hr0 k₀)] using hi + calc + ‖T (c i)‖ = ‖(T (c i) - T rowHead) + T rowHead‖ := by + congr 1 + abel + _ ≤ ‖T (c i) - T rowHead‖ + ‖T rowHead‖ := norm_add_le _ _ + _ ≤ C := add_le_add hdiff le_rfl + let M : ℝ := ε⁻¹ * C + have hcbound : ∀ᶠ i in atTop, ‖c i‖ ≤ M := by + filter_upwards [hTbound] with i hi + have hlower := disjointEmbedding_lower_bound x hx b hb hxb hε hxnorm (c i) + rw [le_inv_mul_iff₀ hε] + exact hlower.trans hi + obtain ⟨m, hm⟩ := exists_nat_gt (2 * M) + have hmM : M < (m + 1 : ℕ) / 2 := by + norm_num + nlinarith + have hxp : x (m, 0) ≠ 0 := by + apply norm_ne_zero_iff.mp + exact ne_of_gt (hε.trans_le (hxnorm (m, 0))) + have hcoord := tendsto_apply_of_disjointEmbedding_orderConvergesTo + x hx b hb hxb c rowHead hcorder (m, 0) hxp + have hhalf : ∀ᶠ i in atTop, (1 / 2 : ℝ) < c i (m, 0) := by + apply hcoord + exact Ioi_mem_nhds (show (1 / 2 : ℝ) < rowHead (m, 0) by simp [rowHead]; norm_num) + obtain ⟨i, hic, hihalf⟩ := (hcbound.and hhalf).exists + have hlimit_le : (m + 1 : ℕ) * c i (m, 0) ≤ M := by + apply le_of_tendsto' (hcH i m) + intro n + calc + c i (m, n + 1) ≤ |c i (m, n + 1)| := le_abs_self _ + _ = ‖c i (m, n + 1)‖ := by rw [Real.norm_eq_abs] + _ ≤ ‖c i‖ := BoundedContinuousFunction.norm_coe_le_norm _ _ + _ ≤ M := hic + have hlimit_gt : M < (m + 1 : ℕ) * c i (m, 0) := by + calc + M < (m + 1 : ℕ) / 2 := hmM + _ < (m + 1 : ℕ) * c i (m, 0) := by + have hmpos : (0 : ℝ) < (m + 1 : ℕ) := by positivity + nlinarith + exact (not_lt_of_ge hlimit_le) hlimit_gt + +end RowLimitExclusion + +section LiftConvergence + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +omit [IsOrderedAddMonoid X] in +/-- Reindexes sequential order convergence by `ULift ℕ`; used to match the +universe required by the definitions of adherence. -/ +private theorem orderConvergesTo_uliftNat {f : ℕ → X} {x : X} + (h : OrderConvergesTo f x) : + OrderConvergesTo (fun i : ULift.{u} ℕ ↦ f i.down) x := by + rcases h with ⟨K, hpre, hdir, hne, r, hranti, hr0, hrglb, hbound⟩ + refine ⟨K, hpre, hdir, hne, r, hranti, hr0, hrglb, ?_⟩ + intro k + obtain ⟨n, hn⟩ := eventually_atTop.mp (hbound k) + apply eventually_atTop.mpr + exact ⟨ULift.up n, fun i hi ↦ hn i.down hi⟩ + +omit [IsOrderedAddMonoid X] in +/-- Reindexes sequential uo-convergence by `ULift ℕ`; used when inserting the +row approximations into uo-adherence. -/ +private theorem uoConvergesTo_uliftNat {f : ℕ → X} {x : X} + (h : UOConvergesTo f x) : + UOConvergesTo (fun i : ULift.{u} ℕ ↦ f i.down) x := by + intro a ha + exact orderConvergesTo_uliftNat (h a ha) + +end LiftConvergence + +section ReverseImplication + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] + +/-- Derives order continuity from equality of order and uo-adherence on every +vector sublattice; this is the reverse step of the Gao--Leung cycle. -/ +private theorem orderContinuousNorm_of_forall_orderAdherence_eq_uoAdherence + (h : ∀ Y : VectorSublattice X, + orderAdherence (Y : Set X) = uoAdherence (Y : Set X)) : + IsOrderContinuousNorm X := by + classical + by_contra hX + obtain ⟨ε, b, xn, hε, hb, hxpair, hxn⟩ := + exists_orderBounded_disjoint_sequence_norm_bounded_away hX + let x : PairIndex → X := fun p ↦ xn (Nat.pairEquiv p) + have hx : Pairwise fun p q ↦ IsVLDisjoint (x p) (x q) := by + intro p q hpq + apply hxpair + exact fun hp ↦ hpq (Nat.pairEquiv.injective hp) + have hxb : ∀ p, 0 ≤ x p ∧ x p ≤ b := fun p ↦ ⟨(hxn _).1, (hxn _).2.1⟩ + have hxnorm : ∀ p, ε ≤ ‖x p‖ := fun p ↦ (hxn _).2.2 + let T := disjointEmbedding x hx b hb hxb + let Y := vectorSublatticeImage T rowLimitSublattice + have huolim : UOConvergesTo (fun j ↦ T (rowApprox j)) (T rowHead) := + disjointEmbedding_uoConverges_of_eventuallyEq x hx b hb hxb rowApprox rowHead + rowApprox_eventually_apply_eq_rowHead + have huomem : T rowHead ∈ uoAdherence (Y : Set X) := by + refine ⟨ULift.{u} ℕ, inferInstance, inferInstance, inferInstance, + fun j ↦ T (rowApprox j.down), ?_, + uoConvergesTo_uliftNat (f := fun j ↦ T (rowApprox j)) huolim⟩ + intro j + exact ⟨rowApprox j.down, rowApprox_mem j.down, rfl⟩ + have hordmem : T rowHead ∈ orderAdherence (Y : Set X) := by + rw [h Y] + exact huomem + exact rowHead_not_mem_orderAdherence_image x hx b hb hxb hε hxnorm hordmem + +end ReverseImplication + +section Characterization + +variable {X : Type u} [NormedAddCommGroup X] [SigmaConditionallyCompleteLattice X] + [IsOrderedAddMonoid X] [BanachLattice X] + +/-- Gao--Leung, Theorem 2.7 (paper Theorem `ND`). -/ +theorem gaoLeung_orderContinuous_characterization : + ((∀ Y : VectorSublattice X, IsOrderClosed (orderAdherence (Y : Set X))) ↔ + (∀ Y : VectorSublattice X, orderAdherence (Y : Set X) = uoAdherence (Y : Set X))) ∧ + ((∀ Y : VectorSublattice X, orderAdherence (Y : Set X) = uoAdherence (Y : Set X)) ↔ + IsOrderContinuousNorm X) := by + let A : Prop := ∀ Y : VectorSublattice X, + IsOrderClosed (orderAdherence (Y : Set X)) + let B : Prop := ∀ Y : VectorSublattice X, + orderAdherence (Y : Set X) = uoAdherence (Y : Set X) + let C : Prop := IsOrderContinuousNorm X + have hCA : C → A := by + intro hC + let : IsOrderContinuousNorm X := hC + intro Y + change orderAdherence (orderAdherence (Y : Set X)) ⊆ orderAdherence (Y : Set X) + rw [orderAdherence_eq_closure, orderAdherence_eq_closure, closure_closure] + have hAB : A → B := by + intro hA Y + apply Set.Subset.antisymm + · exact (orderAdherence_subset_uoAdherence_subset (Y := Y)).1 + · intro x hx + exact hA Y ((orderAdherence_subset_uoAdherence_subset (Y := Y)).2 hx) + have hBC : B → C := by + exact orderContinuousNorm_of_forall_orderAdherence_eq_uoAdherence + exact ⟨⟨hAB, fun hB ↦ hCA (hBC hB)⟩, ⟨hBC, fun hC ↦ hAB (hCA hC)⟩⟩ + +end Characterization + +end OrderClosures diff --git a/LeanPool/OrderClosures/GaoLeungProblem.lean b/LeanPool/OrderClosures/GaoLeungProblem.lean new file mode 100644 index 0000000000..8b782e2ec6 --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem.Counterexample +public import LeanPool.OrderClosures.GaoLeungProblem.CNFOrder +public import LeanPool.OrderClosures.GaoLeungProblem.OrdinalSpace +public import LeanPool.OrderClosures.GaoLeungProblem.StageFormula +public import LeanPool.OrderClosures.GaoLeungProblem.Iterations + + +/-! +# The Gao--Leung problem and counterexamples + +Compatibility umbrella for the paper-ordered Gao--Leung formalization. +-/ + +@[expose] public section diff --git a/LeanPool/OrderClosures/GaoLeungProblem/CNFOrder.lean b/LeanPool/OrderClosures/GaoLeungProblem/CNFOrder.lean new file mode 100644 index 0000000000..8bcd24789a --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem/CNFOrder.lean @@ -0,0 +1,736 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem.Counterexample +public import Mathlib.SetTheory.Ordinal.Principal + + +/-! +# The Cantor-normal-form extension order +-/ + +@[expose] public section + +namespace OrderClosures + +open Set + +universe u v + +section OrdinalConstruction + +/-- The relation `≺` from the proof of Theorem `thm:solid-iterations`, expressed +directly using Mathlib's Cantor normal form at base `ω`. -/ +def cnfExtensionLT (ζ ζ' : Ordinal.{u}) : Prop := + ∃ (pre tail : List (Ordinal.{u} × Ordinal.{u})) (β c γ d : Ordinal.{u}), + Ordinal.CNF Ordinal.omega0 ζ = pre ++ (β, c) :: tail ∧ + Ordinal.CNF Ordinal.omega0 ζ' = pre ++ [(γ, d)] ∧ + ((γ = β ∧ c < d) ∨ + (β < γ ∧ + (pre = [] ∨ ∃ δ e, pre.getLast? = some (δ, e) ∧ γ < δ))) + +/-- Reflexive closure of the paper's relation `≺`. -/ +def cnfExtensionLE (ζ ζ' : Ordinal.{u}) : Prop := ζ = ζ' ∨ cnfExtensionLT ζ ζ' + +/-- One strict extension after a fixed CNF prefix; introduced separately so +transitivity and comparability can be proved before taking transitive closure. -/ +def CNFStep (pre : List (Ordinal.{u} × Ordinal.{u})) + (x y : Ordinal.{u} × Ordinal.{u}) : Prop := + (y.1 = x.1 ∧ x.2 < y.2) ∨ + (x.1 < y.1 ∧ + (pre = [] ∨ ∃ z, pre.getLast? = some z ∧ y.1 < z.1)) + +/-- The transitive closure of one-step CNF extensions; used as a tractable list +model of `cnfExtensionLT`. -/ +def CNFListLT (l l' : List (Ordinal.{u} × Ordinal.{u})) : Prop := + ∃ (pre tail : List (Ordinal.{u} × Ordinal.{u})) + (x y : Ordinal.{u} × Ordinal.{u}), + l = pre ++ x :: tail ∧ l' = pre ++ [y] ∧ CNFStep pre x y + +/-- Evaluates a list of exponent-coefficient pairs as an ordinal CNF sum; used +to compare list extensions with ordinal inequalities. -/ +noncomputable def cnfValue + (l : List (Ordinal.{u} × Ordinal.{u})) : Ordinal.{u} := + l.foldr (fun p r ↦ Ordinal.omega0 ^ p.1 * p.2 + r) 0 + +/-- Computes the ordinal represented by concatenated CNF lists; used in the +later comparison lemmas for common prefixes. -/ +theorem cnfValue_append + (l m : List (Ordinal.{u} × Ordinal.{u})) : + cnfValue (l ++ m) = cnfValue l + cnfValue m := by + induction l with + | nil => simp [cnfValue] + | cons p l ih => + change Ordinal.omega0 ^ p.1 * p.2 + cnfValue (l ++ m) = + (Ordinal.omega0 ^ p.1 * p.2 + cnfValue l) + cnfValue m + rw [ih, add_assoc] + +/-- Bounds a valid CNF tail by the next larger omega power; used to compare +CNF values after extending a common prefix. -/ +theorem cnfValue_lt_opow + (l : List (Ordinal.{u} × Ordinal.{u})) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hcoeff : ∀ p ∈ l, p.2 < Ordinal.omega0) + {e : Ordinal.{u}} (hexp : ∀ p ∈ l, p.1 < e) : + cnfValue l < Ordinal.omega0 ^ e := by + induction l generalizing e with + | nil => + simpa [cnfValue] using Ordinal.opow_pos e Ordinal.omega0_pos + | cons a l ih => + simp only [List.map_cons, List.pairwise_cons] at hsorted + have htail : cnfValue l < Ordinal.omega0 ^ a.1 := by + apply ih hsorted.2 + · intro p hp + exact hcoeff p (List.mem_cons_of_mem a hp) + · intro p hp + exact hsorted.1 p.1 (List.mem_map.mpr ⟨p, hp, rfl⟩) + rw [cnfValue, List.foldr_cons] + exact Ordinal.opow_mul_add_lt_opow + (hcoeff a (by simp)) htail (hexp a (by simp)) + +/-- Shows that evaluating the CNF list of an ordinal recovers that ordinal; +used to translate between list and ordinal formulations of the extension order. -/ +theorem CNF_cnfValue + (l : List (Ordinal.{u} × Ordinal.{u})) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hpos : ∀ p ∈ l, 0 < p.2) + (hlt : ∀ p ∈ l, p.2 < Ordinal.omega0) : + Ordinal.CNF Ordinal.omega0 (cnfValue l) = l := by + induction l with + | nil => simp [cnfValue] + | cons p l ih => + simp only [List.map_cons, List.pairwise_cons] at hsorted + have htailPos : ∀ q ∈ l, 0 < q.2 := fun q hq ↦ + hpos q (List.mem_cons_of_mem p hq) + have htailLt : ∀ q ∈ l, q.2 < Ordinal.omega0 := fun q hq ↦ + hlt q (List.mem_cons_of_mem p hq) + have htailExp : ∀ q ∈ l, q.1 < p.1 := fun q hq ↦ + hsorted.1 q.1 (List.mem_map.mpr ⟨q, hq, rfl⟩) + have htailValue : cnfValue l < Ordinal.omega0 ^ p.1 := + cnfValue_lt_opow l hsorted.2 htailLt htailExp + change Ordinal.CNF Ordinal.omega0 + (Ordinal.omega0 ^ p.1 * p.2 + cnfValue l) = p :: l + rw [Ordinal.CNF.opow_mul_add Ordinal.one_lt_omega0 + (hpos p (by simp)).ne' (hlt p (by simp)) htailValue, + ih hsorted.2 htailPos htailLt] + +/-- Inserts one monomial into a valid CNF list with ordinal-addition semantics; +used to construct explicit strict extensions. -/ +noncomputable def cnfAddMonomial + (l : List (Ordinal.{u} × Ordinal.{u})) (γ d : Ordinal.{u}) : + List (Ordinal.{u} × Ordinal.{u}) := + match l with + | [] => [(γ, d)] + | (δ, e) :: tail => + if γ < δ then (δ, e) :: cnfAddMonomial tail γ d + else if γ = δ then [(δ, e + d)] else [(γ, d)] + +/-- Computes the value after inserting one monomial into a CNF list; used to +verify that `cnfAddMonomial` models ordinal addition. -/ +theorem cnfValue_cnfAddMonomial + (l : List (Ordinal.{u} × Ordinal.{u})) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hlt : ∀ p ∈ l, p.2 < Ordinal.omega0) + (γ d : Ordinal.{u}) (hd : 0 < d) : + cnfValue (cnfAddMonomial l γ d) = + cnfValue l + Ordinal.omega0 ^ γ * d := by + induction l with + | nil => simp [cnfAddMonomial, cnfValue] + | cons p l ih => + rcases p with ⟨δ, e⟩ + simp only [List.map_cons, List.pairwise_cons] at hsorted + have htailLt : ∀ p ∈ l, p.2 < Ordinal.omega0 := fun p hp ↦ + hlt p (List.mem_cons_of_mem (δ, e) hp) + have htailExp : ∀ p ∈ l, p.1 < δ := fun p hp ↦ + hsorted.1 p.1 (List.mem_map.mpr ⟨p, hp, rfl⟩) + have htailValue : cnfValue l < Ordinal.omega0 ^ δ := + cnfValue_lt_opow l hsorted.2 htailLt htailExp + by_cases hγδ : γ < δ + · simp only [cnfAddMonomial, hγδ, ↓reduceIte] + change Ordinal.omega0 ^ δ * e + cnfValue (cnfAddMonomial l γ d) = + (Ordinal.omega0 ^ δ * e + cnfValue l) + Ordinal.omega0 ^ γ * d + rw [ih hsorted.2 htailLt, add_assoc] + · by_cases hγeqδ : γ = δ + · subst γ + simp only [cnfAddMonomial, hγδ, ↓reduceIte] + simp only [cnfValue, List.foldr_cons, List.foldr_nil, add_zero] + change Ordinal.omega0 ^ δ * (e + d) = + (Ordinal.omega0 ^ δ * e + cnfValue l) + Ordinal.omega0 ^ δ * d + rw [mul_add, add_assoc, + Ordinal.add_of_omega0_opow_le htailValue + (Ordinal.le_mul_left _ hd)] + · have hδγ : δ < γ := + lt_of_le_of_ne (le_of_not_gt hγδ) (Ne.symm hγeqδ) + have hallExp : ∀ p ∈ (δ, e) :: l, p.1 < γ := by + intro p hp + simp only [List.mem_cons] at hp + rcases hp with hp | hp + · simpa only [hp] using hδγ + · exact (htailExp p hp).trans hδγ + have hvalue : cnfValue ((δ, e) :: l) < Ordinal.omega0 ^ γ := + cnfValue_lt_opow ((δ, e) :: l) + (by simpa only [List.map_cons, List.pairwise_cons] using hsorted) + hlt hallExp + simp only [cnfAddMonomial, hγδ, hγeqδ, ↓reduceIte] + simp only [cnfValue, List.foldr_cons, List.foldr_nil, add_zero] + exact (Ordinal.add_of_omega0_opow_le hvalue + (Ordinal.le_mul_left _ hd)).symm + +/-- Preserves the upper exponent bound when adding a monomial; needed for the +validity proof of the constructed CNF list. -/ +theorem cnfAddMonomial_exponents_lt + (l : List (Ordinal.{u} × Ordinal.{u})) (γ d δ : Ordinal.{u}) + (hl : ∀ p ∈ l, p.1 < δ) (hγ : γ < δ) : + ∀ p ∈ cnfAddMonomial l γ d, p.1 < δ := by + induction l with + | nil => simpa [cnfAddMonomial] using hγ + | cons p l ih => + rcases p with ⟨e, c⟩ + have he : e < δ := hl (e, c) (by simp) + have htail : ∀ p ∈ l, p.1 < δ := fun p hp ↦ + hl p (List.mem_cons_of_mem (e, c) hp) + by_cases hγe : γ < e + · simp only [cnfAddMonomial, hγe, ↓reduceIte] + intro p hp + simp only [List.mem_cons] at hp + rcases hp with rfl | hp + · exact he + · exact ih htail p hp + · by_cases hγeqe : γ = e + · subst γ + simpa [cnfAddMonomial, hγe] using he + · simpa [cnfAddMonomial, hγe, hγeqe] using hγ + +/-- Identifies the final exponent after adding a monomial; used to control +subsequent extensions of the constructed CNF list. -/ +theorem cnfAddMonomial_lastExponent + (l : List (Ordinal.{u} × Ordinal.{u})) (γ d : Ordinal.{u}) : + ((cnfAddMonomial l γ d).getLast?.map Prod.fst).getD 0 = γ := by + induction l with + | nil => simp [cnfAddMonomial] + | cons p l ih => + rcases p with ⟨δ, e⟩ + by_cases hγδ : γ < δ + · simp only [cnfAddMonomial, hγδ, ↓reduceIte] + cases l with + | nil => simp [cnfAddMonomial] + | cons q l => + have hout : cnfAddMonomial (q :: l) γ d ≠ [] := by + rcases q with ⟨qδ, qe⟩ + by_cases hγq : γ < qδ + · simp [cnfAddMonomial, hγq] + · by_cases hγeq : γ = qδ + · simp [cnfAddMonomial, hγeq] + · simp [cnfAddMonomial, hγq, hγeq] + rw [show (δ, e) :: cnfAddMonomial (q :: l) γ d = + [(δ, e)] ++ cnfAddMonomial (q :: l) γ d by rfl, + List.getLast?_append_of_ne_nil _ hout] + exact ih + · by_cases hγeqδ : γ = δ + · subst γ + simp [cnfAddMonomial] + · simp [cnfAddMonomial, hγδ, hγeqδ] + +/-- Reduces monomial insertion to list append when its exponent is below all +existing exponents; used in the strict-extension construction. -/ +theorem cnfAddMonomial_eq_append_of_lt_all + (l : List (Ordinal.{u} × Ordinal.{u})) (γ d : Ordinal.{u}) + (hγ : ∀ p ∈ l, γ < p.1) : + cnfAddMonomial l γ d = l ++ [(γ, d)] := by + induction l with + | nil => simp [cnfAddMonomial] + | cons p l ih => + have hγp := hγ p (by simp) + simp only [cnfAddMonomial, hγp, ↓reduceIte, List.cons_append] + rw [ih (fun q hq ↦ hγ q (List.mem_cons_of_mem p hq))] + +/-- Proves that monomial insertion preserves CNF validity; this allows its +value to be recognized by Mathlib's canonical CNF operation. -/ +theorem cnfAddMonomial_valid + (l : List (Ordinal.{u} × Ordinal.{u})) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hpos : ∀ p ∈ l, 0 < p.2) + (hlt : ∀ p ∈ l, p.2 < Ordinal.omega0) + (γ d : Ordinal.{u}) (hdpos : 0 < d) (hdlt : d < Ordinal.omega0) : + let out := cnfAddMonomial l γ d + (out.map Prod.fst).Pairwise (fun a b ↦ b < a) ∧ + (∀ p ∈ out, 0 < p.2) ∧ + (∀ p ∈ out, p.2 < Ordinal.omega0) := by + induction l with + | nil => simp [cnfAddMonomial, hdpos, hdlt] + | cons p l ih => + rcases p with ⟨δ, e⟩ + simp only [List.map_cons, List.pairwise_cons] at hsorted + have htailPos : ∀ p ∈ l, 0 < p.2 := fun p hp ↦ + hpos p (List.mem_cons_of_mem (δ, e) hp) + have htailLt : ∀ p ∈ l, p.2 < Ordinal.omega0 := fun p hp ↦ + hlt p (List.mem_cons_of_mem (δ, e) hp) + obtain ⟨ihsorted, ihpos, ihlt⟩ := + ih hsorted.2 htailPos htailLt + by_cases hγδ : γ < δ + · simp only [cnfAddMonomial, hγδ, ↓reduceIte, List.map_cons, + List.pairwise_cons] + refine ⟨⟨?_, ihsorted⟩, ?_, ?_⟩ + · intro e' he' + rw [List.mem_map] at he' + obtain ⟨p, hp, rfl⟩ := he' + exact cnfAddMonomial_exponents_lt l γ d δ + (fun p hp ↦ hsorted.1 p.1 (List.mem_map.mpr ⟨p, hp, rfl⟩)) hγδ p hp + · intro p hp + simp only [List.mem_cons] at hp + rcases hp with rfl | hp + · exact hpos (δ, e) (by simp) + · exact ihpos p hp + · intro p hp + simp only [List.mem_cons] at hp + rcases hp with rfl | hp + · exact hlt (δ, e) (by simp) + · exact ihlt p hp + · by_cases hγeqδ : γ = δ + · subst γ + have hepos : 0 < e := hpos (δ, e) (by simp) + have helt : e < Ordinal.omega0 := hlt (δ, e) (by simp) + have hsumpos : 0 < e + d := hepos.trans_le (le_self_add) + have hsumlt : e + d < Ordinal.omega0 := by + obtain ⟨m, rfl⟩ := Ordinal.lt_omega0.mp helt + obtain ⟨n, rfl⟩ := Ordinal.lt_omega0.mp hdlt + rw [← Nat.cast_add] + exact Ordinal.natCast_lt_omega0 (m + n) + simp [cnfAddMonomial, hsumpos, hsumlt] + · simp [cnfAddMonomial, hγδ, hγeqδ, hdpos, hdlt] + +/-- Identifies the canonical CNF of a value with one added monomial; used to +construct explicit CNF extensions. -/ +theorem CNF_cnfValue_add_monomial + (l : List (Ordinal.{u} × Ordinal.{u})) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hpos : ∀ p ∈ l, 0 < p.2) + (hlt : ∀ p ∈ l, p.2 < Ordinal.omega0) + (γ d : Ordinal.{u}) (hdpos : 0 < d) (hdlt : d < Ordinal.omega0) : + Ordinal.CNF Ordinal.omega0 + (cnfValue l + Ordinal.omega0 ^ γ * d) = cnfAddMonomial l γ d := by + rw [← cnfValue_cnfAddMonomial l hsorted hlt γ d hdpos] + obtain ⟨hsorted', hpos', hlt'⟩ := + cnfAddMonomial_valid l hsorted hpos hlt γ d hdpos hdlt + exact CNF_cnfValue _ hsorted' hpos' hlt' + +/-- Adds a common head to a one-step CNF extension; used to lift extensions +through arbitrary common prefixes. -/ +theorem CNFStep.cons_prefix + {pre : List (Ordinal.{u} × Ordinal.{u})} + {x y : Ordinal.{u} × Ordinal.{u}} {δ e : Ordinal.{u}} + (h : CNFStep pre x y) (hy : y.1 < δ) : + CNFStep ((δ, e) :: pre) x y := by + rcases h with hsame | ⟨hxy, hpre⟩ + · exact Or.inl hsame + · refine Or.inr ⟨hxy, Or.inr ?_⟩ + cases pre with + | nil => exact ⟨(δ, e), by simp, hy⟩ + | cons p pre => + rcases hpre with hfalse | ⟨z, hz, hyz⟩ + · simp at hfalse + · exact ⟨z, by simpa using hz, hyz⟩ + +/-- Shows that adding a sufficiently small monomial gives a strict CNF-list +extension; used to approximate ordinals from below. -/ +theorem CNFListLT_cnfAddMonomial + (l : List (Ordinal.{u} × Ordinal.{u})) (hne : l ≠ []) + (hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a)) + (hpos : ∀ p ∈ l, 0 < p.2) + (hlt : ∀ p ∈ l, p.2 < Ordinal.omega0) + (β c : Ordinal.{u}) (hlast : l.getLast? = some (β, c)) + (γ d : Ordinal.{u}) (hdpos : 0 < d) + (hβγ : β ≤ γ) : + CNFListLT l (cnfAddMonomial l γ d) := by + induction l with + | nil => exact (hne rfl).elim + | cons p l ih => + rcases p with ⟨δ, e⟩ + cases l with + | nil => + simp only [List.getLast?_singleton, Option.some.injEq] at hlast + rcases hlast with ⟨rfl, rfl⟩ + by_cases hγeqβ : γ = β + · subst γ + refine ⟨[], [], (β, c), (β, c + d), by simp, + by simp [cnfAddMonomial], ?_⟩ + exact Or.inl ⟨rfl, lt_add_of_pos_right c hdpos⟩ + · have hβγ' : β < γ := lt_of_le_of_ne hβγ (Ne.symm hγeqβ) + refine ⟨[], [], (β, c), (γ, d), by simp, + by simp [cnfAddMonomial, hβγ'.not_gt, hγeqβ], ?_⟩ + exact Or.inr ⟨hβγ', Or.inl rfl⟩ + | cons q l => + simp only [List.map_cons, List.pairwise_cons] at hsorted + have htailPos : ∀ p ∈ q :: l, 0 < p.2 := fun p hp ↦ + hpos p (List.mem_cons_of_mem (δ, e) hp) + have htailLt : ∀ p ∈ q :: l, p.2 < Ordinal.omega0 := fun p hp ↦ + hlt p (List.mem_cons_of_mem (δ, e) hp) + have htailSorted : (List.map Prod.fst (q :: l)).Pairwise + (fun a b ↦ b < a) := by + simpa only [List.map_cons, List.pairwise_cons] using hsorted.2 + have hlastTail : (q :: l).getLast? = some (β, c) := by + simpa using hlast + by_cases hγδ : γ < δ + · rcases ih (by simp) htailSorted htailPos htailLt hlastTail with + ⟨pre, tail, x, y, hin, hout, hstep⟩ + have hyMem : y ∈ cnfAddMonomial (q :: l) γ d := by + rw [hout] + exact List.mem_append_right _ (by simp) + have hyδ : y.1 < δ := + cnfAddMonomial_exponents_lt (q :: l) γ d δ + (fun p hp ↦ hsorted.1 p.1 (List.mem_map.mpr ⟨p, hp, rfl⟩)) + hγδ y hyMem + refine ⟨(δ, e) :: pre, tail, x, y, ?_, ?_, + CNFStep.cons_prefix hstep hyδ⟩ + · simpa only [List.cons_append] using + congrArg (List.cons (δ, e)) hin + · simp only [cnfAddMonomial, hγδ, ↓reduceIte] + simpa only [cnfAddMonomial, hγδ, ↓reduceIte, List.cons_append] using + congrArg (List.cons (δ, e)) hout + · by_cases hγeqδ : γ = δ + · subst γ + refine ⟨[], q :: l, (δ, e), (δ, e + d), by simp, + by simp [cnfAddMonomial], ?_⟩ + exact Or.inl ⟨rfl, lt_add_of_pos_right e hdpos⟩ + · have hδγ : δ < γ := + lt_of_le_of_ne (le_of_not_gt hγδ) (Ne.symm hγeqδ) + refine ⟨[], q :: l, (δ, e), (γ, d), by simp, + by simp [cnfAddMonomial, hγδ, hγeqδ], ?_⟩ + exact Or.inr ⟨hδγ, Or.inl rfl⟩ + +/-- Compares values of lists with the same valid prefix; used to show that +CNF-list extension implies ordinary ordinal inequality. -/ +theorem cnfValue_append_lt_append + (pre l l' : List (Ordinal.{u} × Ordinal.{u})) + (h : cnfValue l < cnfValue l') : + cnfValue (pre ++ l) < cnfValue (pre ++ l') := by + induction pre with + | nil => simpa using h + | cons p pre ih => + simp only [List.cons_append, cnfValue, List.foldr_cons] + exact (add_lt_add_iff_left _).2 ih + +/-- Converts strict extension of canonical CNF lists into strict ordinal +inequality; used throughout the ordinal-space construction. -/ +theorem CNFListLT.ordinal_lt {ζ ζ' : Ordinal.{u}} + (h : CNFListLT (Ordinal.CNF Ordinal.omega0 ζ) + (Ordinal.CNF Ordinal.omega0 ζ')) : ζ < ζ' := by + rcases h with ⟨pre, tail, ⟨β, c⟩, ⟨γ, d⟩, hζ, hζ', hstep⟩ + have hsorted := (Ordinal.CNF.sortedGT Ordinal.omega0 ζ).pairwise + rw [hζ, List.map_append, List.map_cons, List.pairwise_append] at hsorted + have hsuffix : ((β, c) :: tail).map Prod.fst |>.Pairwise (fun a b ↦ b < a) := + hsorted.2.1 + rw [List.map_cons, List.pairwise_cons] at hsuffix + have hcoeff : ∀ p ∈ tail, p.2 < Ordinal.omega0 := by + intro p hp + apply Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 + rw [hζ] + exact List.mem_append_right _ (List.mem_cons_of_mem _ hp) + have htail : cnfValue tail < Ordinal.omega0 ^ β := + cnfValue_lt_opow tail hsuffix.2 hcoeff (fun p hp ↦ + hsuffix.1 p.1 (List.mem_map.mpr ⟨p, hp, rfl⟩)) + have hc : c < Ordinal.omega0 := by + apply Ordinal.CNF.snd_lt (o := ζ) (x := (β, c)) Ordinal.one_lt_omega0 + rw [hζ] + exact List.mem_append_right _ List.mem_cons_self + have hd : 0 < d := by + apply Ordinal.CNF.snd_pos (b := Ordinal.omega0) (o := ζ') (x := (γ, d)) + rw [hζ'] + exact List.mem_append_right _ (by simp) + have hdiv : cnfValue ((β, c) :: tail) < cnfValue [(γ, d)] := by + rcases hstep with ⟨rfl, hcd⟩ | ⟨hβγ, _⟩ + · simp only [cnfValue, List.foldr_cons, List.foldr_nil, add_zero] + exact Ordinal.opow_mul_add_lt_opow_mul htail hcd + · simp only [cnfValue, List.foldr_cons, List.foldr_nil, add_zero] + exact (Ordinal.opow_mul_add_lt_opow hc htail hβγ).trans_le + (Ordinal.le_mul_left _ hd) + rw [← Ordinal.CNF.foldr Ordinal.omega0 ζ, + ← Ordinal.CNF.foldr Ordinal.omega0 ζ'] + change cnfValue (Ordinal.CNF Ordinal.omega0 ζ) < + cnfValue (Ordinal.CNF Ordinal.omega0 ζ') + rw [hζ, hζ'] + exact cnfValue_append_lt_append pre _ _ hdiv + +/-- Equates the ordinal definition of `cnfExtensionLT` with its list model; +this bridge supplies transitivity and upper-cone linearity. -/ +theorem cnfExtensionLT_iff_CNFListLT {ζ ζ' : Ordinal.{u}} : + cnfExtensionLT ζ ζ' ↔ + CNFListLT (Ordinal.CNF Ordinal.omega0 ζ) + (Ordinal.CNF Ordinal.omega0 ζ') := by + constructor + · rintro ⟨pre, tail, β, c, γ, d, hζ, hζ', hstep⟩ + refine ⟨pre, tail, (β, c), (γ, d), hζ, hζ', ?_⟩ + rcases hstep with hstep | ⟨hβγ, hpre⟩ + · exact Or.inl hstep + · refine Or.inr ⟨hβγ, ?_⟩ + rcases hpre with rfl | ⟨δ, e, hlast, hγδ⟩ + · exact Or.inl rfl + · exact Or.inr ⟨(δ, e), hlast, hγδ⟩ + · rintro ⟨pre, tail, ⟨β, c⟩, ⟨γ, d⟩, hζ, hζ', hstep⟩ + refine ⟨pre, tail, β, c, γ, d, hζ, hζ', ?_⟩ + rcases hstep with hstep | ⟨hβγ, hpre⟩ + · exact Or.inl hstep + · refine Or.inr ⟨hβγ, ?_⟩ + rcases hpre with rfl | ⟨⟨δ, e⟩, hlast, hγδ⟩ + · exact Or.inl rfl + · exact Or.inr ⟨δ, e, hlast, hγδ⟩ + +/-- Appending one smaller singleton monomial creates a strict CNF extension; +used in the later Gao-stage approximation argument. -/ +theorem cnfExtensionLT_add_singleton_of_last + {ζ q γ d β c : Ordinal.{u}} + {pre : List (Ordinal.{u} × Ordinal.{u})} + (hζ : Ordinal.CNF Ordinal.omega0 ζ = pre ++ [(β, c)]) + (hq : Ordinal.CNF Ordinal.omega0 q = [(γ, d)]) + (hβγ : β ≤ γ) : cnfExtensionLT ζ (ζ + q) := by + let l := Ordinal.CNF Ordinal.omega0 ζ + have hl : l = pre ++ [(β, c)] := hζ + have hlne : l ≠ [] := by rw [hl]; simp + have hsorted : (l.map Prod.fst).Pairwise (fun a b ↦ b < a) := + (Ordinal.CNF.sortedGT Ordinal.omega0 ζ).pairwise + have hpos : ∀ p ∈ l, 0 < p.2 := fun p hp ↦ + Ordinal.CNF.snd_pos hp + have hlt : ∀ p ∈ l, p.2 < Ordinal.omega0 := fun p hp ↦ + Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 hp + have hlast : l.getLast? = some (β, c) := by rw [hl]; simp + have hdpos : 0 < d := by + apply Ordinal.CNF.snd_pos (b := Ordinal.omega0) (o := q) (x := (γ, d)) + rw [hq] + simp + have hdlt : d < Ordinal.omega0 := by + apply Ordinal.CNF.snd_lt (b := Ordinal.omega0) (o := q) (x := (γ, d)) + Ordinal.one_lt_omega0 + rw [hq] + simp + have hζvalue : cnfValue l = ζ := Ordinal.CNF.foldr Ordinal.omega0 ζ + have hqvalue : q = Ordinal.omega0 ^ γ * d := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 q, hq] + simp + apply cnfExtensionLT_iff_CNFListLT.mpr + rw [← hζvalue, hqvalue, + CNF_cnfValue_add_monomial l hsorted hpos hlt γ d hdpos hdlt, + CNF_cnfValue l hsorted hpos hlt] + exact CNFListLT_cnfAddMonomial l hlne hsorted hpos hlt β c hlast + γ d hdpos hβγ + +/-- Proves transitivity for one-step extensions sharing a prefix; used in the +global transitivity proof for `CNFListLT`. -/ +theorem CNFStep.trans {pre : List (Ordinal.{u} × Ordinal.{u})} + {x y z : Ordinal.{u} × Ordinal.{u}} + (hxy : CNFStep pre x y) (hyz : CNFStep pre y z) : CNFStep pre x z := by + rcases hxy with hxy | hxy <;> rcases hyz with hyz | hyz + · exact Or.inl ⟨hyz.1.trans hxy.1, hxy.2.trans hyz.2⟩ + · exact Or.inr ⟨hxy.1 ▸ hyz.1, hyz.2⟩ + · refine Or.inr ⟨hxy.1.trans_eq hyz.1.symm, ?_⟩ + rcases hxy.2 with hp | ⟨w, hw, hb⟩ + · exact Or.inl hp + · exact Or.inr ⟨w, hw, by simpa only [hyz.1] using hb⟩ + · exact Or.inr ⟨hxy.1.trans hyz.1, hyz.2⟩ + +/-- Establishes comparability of two one-step extensions above a common +prefix; used to linearize each upper cone. -/ +theorem CNFStep.trichotomy {pre : List (Ordinal.{u} × Ordinal.{u})} + {x y z : Ordinal.{u} × Ordinal.{u}} + (hxy : CNFStep pre x y) (hxz : CNFStep pre x z) : + y = z ∨ CNFStep pre y z ∨ CNFStep pre z y := by + rcases x with ⟨β, c⟩ + rcases y with ⟨γ, d⟩ + rcases z with ⟨δ, e⟩ + simp only [CNFStep] at hxy hxz ⊢ + rcases hxy with ⟨rfl, hcd⟩ | ⟨hβγ, hγ⟩ <;> + rcases hxz with ⟨rfl, hce⟩ | ⟨hβδ, hδ⟩ + · rcases lt_trichotomy d e with hde | rfl | hed + · exact Or.inr (Or.inl (Or.inl ⟨rfl, hde⟩)) + · exact Or.inl rfl + · exact Or.inr (Or.inr (Or.inl ⟨rfl, hed⟩)) + · exact Or.inr (Or.inl (Or.inr ⟨hβδ, hδ⟩)) + · exact Or.inr (Or.inr (Or.inr ⟨hβγ, hγ⟩)) + · rcases lt_trichotomy γ δ with hγδ | hγδ | hδγ + · exact Or.inr (Or.inl (Or.inr ⟨hγδ, hδ⟩)) + · subst δ + rcases lt_trichotomy d e with hde | rfl | hed + · exact Or.inr (Or.inl (Or.inl ⟨rfl, hde⟩)) + · exact Or.inl rfl + · exact Or.inr (Or.inr (Or.inl ⟨rfl, hed⟩)) + · exact Or.inr (Or.inr (Or.inr ⟨hδγ, hγ⟩)) + +/-- Lifts one-step transitivity to the transitive closure `CNFListLT`; used to +prove that `cnfExtensionLE` is a partial order. -/ +theorem CNFListLT.trans {l m n : List (Ordinal.{u} × Ordinal.{u})} + (hlm : CNFListLT l m) (hmn : CNFListLT m n) : CNFListLT l n := by + rcases hlm with ⟨p, t, x, y, hl, hm, hxy⟩ + rcases hmn with ⟨q, s, y', z, hm', hn, hyz⟩ + have heq : p ++ [y] = q ++ y' :: s := hm.symm.trans hm' + have hlen : q.length ≤ p.length := by + have h : p.length + 1 = q.length + s.length + 1 := by + simpa only [List.length_append, List.length_cons, List.length_nil, + Nat.zero_add, Nat.add_assoc] + using congrArg List.length heq + omega + have hqp : q <+: p := by + apply (List.isPrefix_append_of_length hlen).mp + exact ⟨y' :: s, heq.symm⟩ + rcases hqp with ⟨r, hpr⟩ + rw [← hpr] at hl hm hxy heq + have hr : r ++ [y] = y' :: s := + List.append_cancel_left (by simpa only [List.append_assoc] using heq) + cases r with + | nil => + simp only [List.append_nil] at hl hm hxy + simp only [List.nil_append] at hr + simp only [List.cons.injEq] at hr + rcases hr with ⟨rfl, rfl⟩ + exact ⟨q, t, x, z, by simpa only [List.nil_append] using hl, + hn, CNFStep.trans hxy hyz⟩ + | cons w r => + simp only [List.cons_append, List.cons.injEq] at hr + rcases hr with ⟨rfl, rfl⟩ + refine ⟨q, r ++ x :: t, w, z, ?_, hn, hyz⟩ + simpa only [List.cons_append, List.append_assoc] using hl + +/-- Shows that two CNF lists extending a fixed list are comparable; used for +linearity of upper cones in the ordinal extension order. -/ +theorem CNFListLT.upper_trichotomy + {l m n : List (Ordinal.{u} × Ordinal.{u})} + (hlm : CNFListLT l m) (hln : CNFListLT l n) : + m = n ∨ CNFListLT m n ∨ CNFListLT n m := by + rcases hlm with ⟨p, t, x, y, hl, hm, hxy⟩ + rcases hln with ⟨q, s, x', z, hl', hn, hxz⟩ + have hpref : p <+: l := ⟨x :: t, hl.symm⟩ + have qpref : q <+: l := ⟨x' :: s, hl'.symm⟩ + rcases lt_trichotomy p.length q.length with hpq | hpq | hqp + · have hprefq : p <+: q := by + apply (List.isPrefix_append_of_length hpq.le).mp + rw [hl'] at hpref + exact hpref + rcases hprefq with ⟨r, hqr⟩ + rw [← hqr] at hl' hn hxz + cases r with + | nil => + simp only [List.append_nil] at hqr + exact (hpq.ne (congrArg List.length hqr)).elim + | cons w r => + have heq : w :: r ++ x' :: s = x :: t := + List.append_cancel_left (by + simpa only [List.cons_append, List.append_assoc] using hl'.symm.trans hl) + have hw : w = x := (List.cons.inj heq).1 + have hr : r ++ x' :: s = t := (List.cons.inj heq).2 + subst w + subst t + refine Or.inr (Or.inr ⟨p, r ++ [z], x, y, ?_, hm, hxy⟩) + simpa only [List.cons_append, List.append_assoc] using hn + · have hpqeq : p = q := by + rw [List.prefix_iff_eq_take] at hpref qpref + rw [hpref, qpref, hpq] + subst q + have heq : x :: t = x' :: s := + List.append_cancel_left (hl.symm.trans hl') + have hxx' : x = x' := (List.cons.inj heq).1 + have hts : t = s := (List.cons.inj heq).2 + subst x' + subst s + rcases CNFStep.trichotomy hxy hxz with rfl | hyz | hzy + · exact Or.inl (hm.trans hn.symm) + · exact Or.inr (Or.inl ⟨p, [], y, z, hm, hn, hyz⟩) + · exact Or.inr (Or.inr ⟨p, [], z, y, hn, hm, hzy⟩) + · have qprefp : q <+: p := by + apply (List.isPrefix_append_of_length hqp.le).mp + rw [hl] at qpref + exact qpref + rcases qprefp with ⟨r, hpr⟩ + rw [← hpr] at hl hm hxy + cases r with + | nil => + simp only [List.append_nil] at hpr + exact (hqp.ne (congrArg List.length hpr)).elim + | cons w r => + have heq : w :: r ++ x :: t = x' :: s := + List.append_cancel_left (by + simpa only [List.cons_append, List.append_assoc] using hl.symm.trans hl') + have hw : w = x' := (List.cons.inj heq).1 + have hr : r ++ x :: t = s := (List.cons.inj heq).2 + subst w + subst s + refine Or.inr (Or.inl ⟨q, r ++ [y], x', z, ?_, hn, hxz⟩) + simpa only [List.cons_append, List.append_assoc] using hm + +/-- Property P1 of the ordinal relation in the proof of `thm:solid-iterations`. -/ +theorem cnfExtensionLE_partialOrder_and_subrelation : + IsPartialOrder (Ordinal.{u}) cnfExtensionLE ∧ + ∀ {ζ ζ' : Ordinal.{u}}, cnfExtensionLE ζ ζ' → ζ ≤ ζ' := by + have hlt : ∀ {ζ ζ' : Ordinal.{u}}, cnfExtensionLT ζ ζ' → ζ < ζ' := by + intro ζ ζ' h + exact CNFListLT.ordinal_lt (cnfExtensionLT_iff_CNFListLT.mp h) + have htrans : ∀ a b c : Ordinal.{u}, cnfExtensionLT a b → + cnfExtensionLT b c → cnfExtensionLT a c := by + intro a b c hab hbc + apply cnfExtensionLT_iff_CNFListLT.mpr + exact CNFListLT.trans (cnfExtensionLT_iff_CNFListLT.mp hab) + (cnfExtensionLT_iff_CNFListLT.mp hbc) + let : IsPreorder (Ordinal.{u}) cnfExtensionLE := { + refl := fun _ ↦ Or.inl rfl + trans := fun a b c hab hbc ↦ by + rcases hab with rfl | hab + · exact hbc + rcases hbc with rfl | hbc + · exact Or.inr hab + · exact Or.inr (htrans a b c hab hbc) + } + let : Std.Antisymm + (cnfExtensionLE : Ordinal.{u} → Ordinal.{u} → Prop) := ⟨by + intro a b hab hba + rcases hab with rfl | hab + · rfl + rcases hba with rfl | hba + · rfl + · exact ((hlt hab).asymm (hlt hba)).elim + ⟩ + constructor + · exact IsPartialOrder.mk + · intro ζ ζ' h + rcases h with rfl | h + · exact le_rfl + · exact (hlt h).le + +/-- Property P2 of the ordinal relation in the proof of `thm:solid-iterations`. -/ +theorem cnfExtensionLT_linear_above (ζ : Ordinal.{u}) : + ∀ {η η' : Ordinal.{u}}, cnfExtensionLT ζ η → cnfExtensionLT ζ η' → + (cnfExtensionLT η η' ↔ η < η') := by + intro η η' hη hη' + constructor + · intro h + exact CNFListLT.ordinal_lt (cnfExtensionLT_iff_CNFListLT.mp h) + · intro hlt + rcases CNFListLT.upper_trichotomy + (cnfExtensionLT_iff_CNFListLT.mp hη) + (cnfExtensionLT_iff_CNFListLT.mp hη') with heq | h | h + · have hηeq : η = η' := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 η, + ← Ordinal.CNF.foldr Ordinal.omega0 η', heq] + exact (hlt.ne hηeq).elim + · exact cnfExtensionLT_iff_CNFListLT.mpr h + · exact ((CNFListLT.ordinal_lt h).asymm hlt).elim + +/-- Includes equality in upper-cone comparability; used when minimal Gao +dominators must be compared in `StageFormula`. -/ +theorem cnfExtensionLE_linear_above (ζ : Ordinal.{u}) + {η η' : Ordinal.{u}} (hη : cnfExtensionLE ζ η) + (hη' : cnfExtensionLE ζ η') : + cnfExtensionLE η η' ∨ cnfExtensionLE η' η := by + rcases hη with rfl | hη + · exact Or.inl hη' + rcases hη' with rfl | hη' + · exact Or.inr (Or.inr hη) + rcases lt_trichotomy η η' with hlt | heq | hgt + · exact Or.inl (Or.inr ((cnfExtensionLT_linear_above ζ hη hη').mpr hlt)) + · exact Or.inl (Or.inl heq) + · exact Or.inr (Or.inr ((cnfExtensionLT_linear_above ζ hη' hη).mpr hgt)) + +end OrdinalConstruction + +end OrderClosures diff --git a/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean b/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean new file mode 100644 index 0000000000..116d09ce5b --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean @@ -0,0 +1,526 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module +public import Mathlib.Data.Fintype.Order + +public import LeanPool.OrderClosures.Solovay +public import LeanPool.OrderClosures.GaoLeungCharacterization +public import Mathlib.Order.TransfiniteIteration +public import Mathlib.SetTheory.Ordinal.CantorNormalForm + + +/-! +# The Gao--Leung problem and counterexamples + +Formalization of the paper's counterexamples concerning order and unbounded-order +adherences of sublattices and solid sets. +-/ + +@[expose] public section + +namespace OrderClosures + +open Set + +universe u v + +section GaoLeungTheorem + +/-- The Gao--Leung question, as a predicate on an ambient vector lattice. -/ +def GaoLeungProperty (X : Type u) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [VectorLattice X] : Prop := + ∀ Y : VectorSublattice X, IsOrderClosed (uoAdherence (Y : Set X)) + +end GaoLeungTheorem + +section Counterexample + +/-- Paper Theorem 2.1: an order-complete `C(K)` of arbitrarily large density, +with a closed separable sublattice whose order closure is all of `C(K)`. -/ +theorem gao_counterexample (κ : Cardinal.{u}) : + ∃ (K : Type u) (_ : TopologicalSpace K) (_ : CompactSpace K) (_ : T2Space K), + IsOrderComplete C(K, ℝ) ∧ κ ≤ densityCharacter C(K, ℝ) ∧ + ∃ Y : VectorSublattice C(K, ℝ), + IsClosed (Y : Set C(K, ℝ)) ∧ + TopologicalSpace.IsSeparable (Y : Set C(K, ℝ)) ∧ + ∀ Z : VectorSublattice C(K, ℝ), + Y ≤ Z → IsOrderClosed (Z : Set C(K, ℝ)) → Z = ⊤ := by + induction κ using Cardinal.inductionOn with + | _ Gamma => + classical + obtain ⟨lin, wf⟩ := exists_wellFoundedLT Gamma + let : LinearOrder Gamma := lin + let : WellFoundedLT Gamma := wf + let : TopologicalSpace Gamma := ⊥ + let : DiscreteTopology Gamma := ⟨rfl⟩ + let B := RegularOpen (SolovayProduct Gamma) + let K := BooleanStone B + refine ⟨K, inferInstance, inferInstance, inferInstance, + isOrderComplete_continuousMap K, ?_, + solovayVectorSublattice Gamma, + isClosed_solovayVectorSublattice Gamma, + isSeparable_solovayVectorSublattice Gamma, ?_⟩ + · calc + Cardinal.mk Gamma ≤ Cardinal.mk B := + Cardinal.mk_le_of_injective (solovayA_injective Gamma 0) + _ ≤ densityCharacter C(K, ℝ) := + cardinalMk_le_densityCharacter_booleanStoneContinuousMap B + · intro Z hYZ hZorder + exact solovayVectorSublattice_maximalOrderClosed Gamma Z hYZ hZorder + +/-- Paper Remark `rem:gao-cardinality`: cardinality of an arbitrary order adherence. -/ +theorem orderAdherence_cardinality_bound + {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (D : Set X) : + Cardinal.mk (orderAdherence D) ≤ + (2 : Cardinal) ^ ((2 : Cardinal) ^ Cardinal.mk D) := by + let Φ : orderAdherence D → Set (Set D) := fun x ↦ + {A | x.1 ∈ orderAdherence ((fun z : D ↦ z.1) '' A)} + have hΦ : Function.Injective Φ := by + intro x y hxy + apply Subtype.ext + by_contra hne + rcases x.2 with ⟨ι, hpre, hdir, hnon, f, hfD, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hnon + rcases hfx with ⟨κ, hκpre, hκdir, hκnon, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκnon + have hk : ∃ k, ¬ |x.1 - y.1| ≤ r k := by + by_contra hk + push Not at hk + have hlower : |x.1 - y.1| ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + exact hk k + have habs : |x.1 - y.1| = 0 := + le_antisymm (hrglb.2 hlower) (abs_nonneg _) + exact hne (sub_eq_zero.mp ((abs_eq_zero_iff_zero _).mp habs)) + obtain ⟨k, hk⟩ := hk + obtain ⟨i₀, hi₀⟩ := Filter.eventually_atTop.mp (hbound k) + let fD : ι → D := fun i ↦ ⟨f i, hfD i⟩ + let A : Set D := Set.range (fun i : Set.Ici i₀ ↦ fD i.1) + have hIci : DirectedOn (· ≤ ·) (Set.Ici i₀) := by + intro a ha b hb + obtain ⟨c, hac, hbc⟩ := directed_of (· ≤ ·) a b + exact ⟨c, ha.trans hac, hac, hbc⟩ + let : IsDirectedOrder (Set.Ici i₀) := hIci.isDirectedOrder + let : Nonempty (Set.Ici i₀) := ⟨⟨i₀, le_rfl⟩⟩ + have hrestrict : OrderConvergesTo (fun i : Set.Ici i₀ ↦ f i.1) x.1 := by + refine ⟨κ, inferInstance, inferInstance, inferInstance, r, hranti, hrnonneg, + hrglb, ?_⟩ + intro l + obtain ⟨i₁, hi₁⟩ := Filter.eventually_atTop.mp (hbound l) + obtain ⟨m, hi₀m, hi₁m⟩ := directed_of (· ≤ ·) i₀ i₁ + apply Filter.eventually_atTop.mpr + refine ⟨⟨m, hi₀m⟩, ?_⟩ + intro j hj + exact hi₁ j.1 (hi₁m.trans hj) + have hxA : x.1 ∈ orderAdherence ((fun z : D ↦ z.1) '' A) := by + refine ⟨Set.Ici i₀, inferInstance, inferInstance, inferInstance, + fun i ↦ f i.1, ?_, hrestrict⟩ + intro i + exact ⟨fD i.1, ⟨i, rfl⟩, rfl⟩ + have hxA' : A ∈ Φ x := hxA + have hyA' : A ∈ Φ y := by + rw [← hxy] + exact hxA' + change y.1 ∈ orderAdherence ((fun z : D ↦ z.1) '' A) at hyA' + rcases hyA' with ⟨τ, hτpre, hτdir, hτnon, a, haA, hay⟩ + let : Preorder τ := hτpre + let : IsDirected τ (· ≤ ·) := hτdir + let : Nonempty τ := hτnon + have habound : ∀ j, |a j - x.1| ≤ r k := by + intro j + rcases haA j with ⟨z, ⟨i, rfl⟩, hza⟩ + rw [← hza] + exact hi₀ i.1 i.2 + have hybound : |y.1 - x.1| ≤ r k := + (hay.sub (orderConvergesTo_const x.1)).abs.le_of_forall_le habound + exact hk (by simpa [abs_sub_comm] using hybound) + calc + Cardinal.mk (orderAdherence D) ≤ Cardinal.mk (Set (Set D)) := + Cardinal.mk_le_of_injective hΦ + _ = (2 : Cardinal) ^ ((2 : Cardinal) ^ Cardinal.mk D) := by + rw [Cardinal.mk_set, Cardinal.mk_set] + +/-- Paper Proposition `prop:solid-large-order-closure`. -/ +theorem exists_solid_large_orderAdherence (κ : Cardinal.{u}) : + ∃ (X : Type u) (_ : AddCommGroup X) (_ : Lattice X) (_ : IsOrderedAddMonoid X) + (_ : VectorLattice X), + ∃ S : Set X, LatticeOrderedAddCommGroup.IsSolid S ∧ + solidGeneratorNumber S = Cardinal.aleph0 ∧ + κ ≤ solidGeneratorNumber (orderAdherence S) := by + induction κ using Cardinal.inductionOn with + | _ Γ => + let X := Option Γ → ℕ → ℝ + let g : ℕ → X := fun n _ m ↦ if m ≤ n then (n + 1 : ℕ) else 0 + let S : Set X := solidHull (Set.range g) + refine ⟨X, inferInstance, inferInstance, inferInstance, inferInstance, S, + LatticeOrderedAddCommGroup.isSolid_solidClosure _, ?_, ?_⟩ + · apply le_antisymm + · calc + solidGeneratorNumber S ≤ Cardinal.mk (Set.range g) := by + apply csInf_le' + exact ⟨Set.range g, rfl, rfl⟩ + _ ≤ Cardinal.aleph0 := by + simpa [Cardinal.mk_nat] using Cardinal.mk_range_le_lift (f := g) + · apply le_csInf + · exact ⟨Cardinal.mk (Set.range g), Set.range g, rfl, rfl⟩ + · intro c hc + rcases hc with ⟨A, hAc, hAS⟩ + rw [← hAc] + by_contra hAfin + have hAlt : Cardinal.mk A < Cardinal.aleph0 := lt_of_not_ge hAfin + let : Finite A := Cardinal.mk_lt_aleph0_iff.mp hAlt + have hchoice : ∀ a : A, ∃ n, |a.1| ≤ |g n| := by + intro a + have haS : a.1 ∈ S := by + rw [← hAS] + exact ⟨a.1, a.2, le_rfl⟩ + rcases haS with ⟨b, ⟨n, rfl⟩, hab⟩ + exact ⟨n, hab⟩ + choose N hN using hchoice + obtain ⟨M, hM⟩ := Finite.exists_le N + have hgS : g (M + 1) ∈ S := ⟨g (M + 1), ⟨M + 1, rfl⟩, le_rfl⟩ + rw [← hAS] at hgS + rcases hgS with ⟨a, haA, hga⟩ + let aa : A := ⟨a, haA⟩ + have ha0 := hN aa (none : Option Γ) (M + 1) + have hga0 := hga (none : Option Γ) (M + 1) + have hNM := hM aa + dsimp [g, X] at ha0 hga0 + rw [ite_eq_right (by omega)] at ha0 + simp only [abs_zero] at ha0 + rw [ite_eq_left (by omega)] at hga0 + norm_num at hga0 + change |a none (M + 1)| ≤ 0 at ha0 + have hpos : (0 : ℝ) < |(M : ℝ) + 1 + 1| := by positivity + linarith + · have hadh : orderAdherence S = Set.univ := by + ext f + simp only [Set.mem_univ, iff_true] + have hsolid : LatticeOrderedAddCommGroup.IsSolid (orderAdherence S) := by + rw [orderAdherence_eq_solidOrderAdherence + (LatticeOrderedAddCommGroup.isSolid_solidClosure (Set.range g))] + exact LatticeOrderedAddCommGroup.isSolid_solidClosure _ + apply hsolid (x := |f|) (y := f) + · let I := ULift.{u} ℕ + let p : I → X := fun n ↦ |f| ⊓ g n.down + have hg_nonneg : ∀ n, 0 ≤ g n := by + intro n γ m + simp only [g, X] + split_ifs <;> positivity + have hg_mono : Monotone g := by + intro n k hnk γ m + simp only [g, X] + by_cases hmn : m ≤ n + · rw [ite_eq_left hmn, ite_eq_left (hmn.trans hnk)] + exact_mod_cast Nat.succ_le_succ hnk + · rw [ite_eq_right hmn] + split_ifs <;> positivity + have hp_mono : Monotone p := fun _ _ hnk ↦ + inf_le_inf_left _ (hg_mono hnk) + have hp_lub : IsLUB (Set.range p) |f| := by + constructor + · rintro _ ⟨n, rfl⟩ + exact inf_le_left + · intro c hc γ m + obtain ⟨k, hk⟩ := exists_nat_ge |f γ m| + let n := max m k + have hkn : (k : ℝ) ≤ n := by exact_mod_cast Nat.le_max_right m k + have hfn : |f γ m| ≤ (n + 1 : ℕ) := by + norm_num + linarith + have hcn := hc ⟨ULift.up n, rfl⟩ γ m + dsimp [p, g, X, n] at hcn + rw [ite_eq_left (Nat.le_max_left m k)] at hcn + rw [inf_eq_left.mpr (by simpa [n] using hfn)] at hcn + exact hcn + refine ⟨I, inferInstance, inferInstance, inferInstance, p, ?_, + orderConvergesTo_of_monotone_isLUB hp_mono hp_lub⟩ + intro n + refine ⟨g n.down, ⟨n.down, rfl⟩, ?_⟩ + have hp_nonneg : 0 ≤ p n := le_inf (abs_nonneg f) (hg_nonneg n.down) + rw [abs_of_nonneg hp_nonneg, abs_of_nonneg (hg_nonneg n.down)] + exact (inf_le_right : |f| ⊓ g n.down ≤ g n.down) + · simp + rw [hadh] + apply le_csInf + · refine ⟨Cardinal.mk (Set.univ : Set X), Set.univ, rfl, ?_⟩ + ext x + constructor + · exact fun _ ↦ Set.mem_univ x + · intro _ + exact ⟨x, Set.mem_univ x, le_rfl⟩ + · intro c hc + rcases hc with ⟨A, hAc, hAuniv⟩ + rw [← hAc] + by_contra hsmall + have hlt : Cardinal.mk A < Cardinal.mk Γ := lt_of_not_ge hsmall + obtain ⟨e⟩ := (Cardinal.le_def A Γ).mp hlt.le + let d : Γ → ℝ := Function.extend e + (fun a : A ↦ |a.1 (some (e a)) 0| + 1) (fun _ ↦ 0) + let f : X := fun γ m ↦ match γ, m with + | some δ, 0 => d δ + | _, _ => 0 + have hfA : f ∈ solidHull A := by + rw [hAuniv] + exact Set.mem_univ f + rcases hfA with ⟨a, haA, hfa⟩ + let aa : A := ⟨a, haA⟩ + have hcoord := hfa (some (e aa)) 0 + change |f (some (e aa)) 0| ≤ |a (some (e aa)) 0| at hcoord + change |Function.extend (⇑e) (fun a : A => |a.1 (some (e a)) 0| + 1) + (fun _ => 0) (e aa)| ≤ |a (some (e aa)) 0| at hcoord + rw [Function.Injective.extend_apply e.injective] at hcoord + rw [abs_of_nonneg (by positivity)] at hcoord + linarith [abs_nonneg (a (some (e aa)) 0)] + +/-- The class of all suprema of subsets of the positive part of `S`, used in +the proof of Proposition `prop:cardinalitybound`. -/ +def positiveSubsetSuprema + {X : Type u} [AddCommGroup X] [Lattice X] + (S : Set X) : Set X := + {x | ∃ A : Set X, A ⊆ S ∩ Ici 0 ∧ IsLUB A x} + +/-- The order-closed envelope used for the cardinality estimate. -/ +def signedPositiveSubsetSuprema + {X : Type u} [AddCommGroup X] [Lattice X] + (S : Set X) : Set X := + {x | x⁺ ∈ positiveSubsetSuprema S ∧ x⁻ ∈ positiveSubsetSuprema S} + +/-- Isolates the order-closedness of positive subset suprema so it can be +reused for the signed envelope in `signedPositiveSubsetSuprema_isOrderClosed`. -/ +theorem positiveSubsetSuprema_isOrderClosed + {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + {S : Set X} (hS : LatticeOrderedAddCommGroup.IsSolid S) : + IsOrderClosed (positiveSubsetSuprema S) := by + have hnonneg : ∀ {z : X}, z ∈ positiveSubsetSuprema S → 0 ≤ z := by + intro z hz + rcases hz with ⟨A, hAS, hAlub⟩ + by_cases hA : A.Nonempty + · obtain ⟨a, ha⟩ := hA + exact (hAS ha).2.trans (hAlub.1 ha) + · have hupper : z ≤ z + z := hAlub.2 fun a ha ↦ (hA ⟨a, ha⟩).elim + exact nonneg_of_le_add_right hupper + have hdown : ∀ {y z : X}, 0 ≤ y → y ≤ z → + z ∈ positiveSubsetSuprema S → y ∈ positiveSubsetSuprema S := by + intro y z hy0 hyz hz + rcases hz with ⟨A, hAS, hAlub⟩ + let B : Set X := (fun a ↦ a ⊓ y) '' A + refine ⟨B, ?_, ?_⟩ + · rintro b ⟨a, ha, rfl⟩ + have ha0 : 0 ≤ a := (hAS ha).2 + have hab0 : 0 ≤ a ⊓ y := le_inf ha0 hy0 + have habs : |a ⊓ y| ≤ |a| := by + simp [abs_of_nonneg hab0, abs_of_nonneg ha0] + exact ⟨hS (hAS ha).1 habs, hab0⟩ + · constructor + · rintro b ⟨a, ha, rfl⟩ + exact inf_le_right + · intro w hw + have hupperA : z + w - y ∈ upperBounds A := by + intro a ha + have haz : a ≤ z := hAlub.1 ha + have haw : a ⊓ y ≤ w := hw ⟨a, ha, rfl⟩ + change a ≤ z + w - y + calc + a = (a - a ⊓ y) + (a ⊓ y) := by abel + _ ≤ (z - y) + w := add_le_add (by + rw [sub_inf_eq_posPart] + exact (posPart_mono (sub_le_sub_right haz y)).trans_eq + (posPart_of_nonneg (sub_nonneg.mpr hyz))) haw + _ = z + w - y := by abel + have hzw := hAlub.2 hupperA + change y ≤ w + apply sub_nonpos.mp + have hcancel := sub_le_sub_left hzw z + convert hcancel using 1 <;> abel + intro x + rintro ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + have hf0 : ∀ i, 0 ≤ f i := fun i ↦ hnonneg (hf i) + have hx0 : 0 ≤ x := hfx.nonneg hf0 + rcases hfx with ⟨κ, hκpre, hκdir, hκne, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκne + let y : κ → X := fun k ↦ (x - r k)⁺ + have hy_lub : IsLUB (Set.range y) x := by + constructor + · rintro _ ⟨k, rfl⟩ + exact show (x - r k) ⊔ 0 ≤ x from + sup_le (sub_le_self _ (hrnonneg k)) hx0 + · intro c hc + have hlow : x - c ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + have hraw : x - r k ≤ c := (le_posPart _).trans (hc ⟨k, rfl⟩) + exact sub_le_iff_le_add.mpr (by + simpa [add_comm] using (sub_le_iff_le_add.mp hraw)) + exact sub_nonpos.mp (hrglb.2 hlow) + have hy : ∀ k, y k ∈ positiveSubsetSuprema S := by + intro k + obtain ⟨i, hi⟩ := (hbound k).exists + have hyfi : y k ≤ f i := by + dsimp [y] + have hi' : |x - f i| ≤ r k := by simpa [abs_sub_comm] using hi + have hsub : x - f i ≤ r k := (le_abs_self _).trans hi' + have hraw : x - r k ≤ f i := sub_le_iff_le_add.mpr (by + simpa [add_comm] using (sub_le_iff_le_add.mp hsub)) + exact sup_le hraw (hf0 i) + exact hdown (posPart_nonneg _) hyfi (hf i) + choose A hAS hAlub using hy + let B : Set X := {a | ∃ k, a ∈ A k} + refine ⟨B, ?_, ?_⟩ + · rintro a ⟨k, ha⟩ + exact hAS k ha + · constructor + · rintro a ⟨k, ha⟩ + exact (hAlub k).1 ha |>.trans (hy_lub.1 ⟨k, rfl⟩) + · intro c hc + apply hy_lub.2 + rintro _ ⟨k, rfl⟩ + exact (hAlub k).2 fun a ha ↦ hc ⟨k, ha⟩ + +/-- Unnumbered assertion in the proof of `prop:cardinalitybound`. -/ +theorem signedPositiveSubsetSuprema_isOrderClosed + {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + {S : Set X} (hS : LatticeOrderedAddCommGroup.IsSolid S) : + IsOrderClosed (signedPositiveSubsetSuprema S) := by + intro x + rintro ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + have hpos : OrderConvergesTo (fun i ↦ (f i)⁺) x⁺ := by + simpa [posPart] using hfx.sup (orderConvergesTo_const (0 : X)) + have hneg : OrderConvergesTo (fun i ↦ (f i)⁻) x⁻ := by + simpa [negPart, posPart] using hfx.neg.sup (orderConvergesTo_const (0 : X)) + constructor + · exact positiveSubsetSuprema_isOrderClosed hS + ⟨ι, inferInstance, inferInstance, inferInstance, fun i ↦ (f i)⁺, + fun i ↦ (hf i).1, hpos⟩ + · exact positiveSubsetSuprema_isOrderClosed hS + ⟨ι, inferInstance, inferInstance, inferInstance, fun i ↦ (f i)⁻, + fun i ↦ (hf i).2, hneg⟩ + +/-- Paper Proposition `prop:cardinalitybound`. -/ +theorem solid_orderAdherence_cardinality_bound + {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + {S : Set X} (hS : LatticeOrderedAddCommGroup.IsSolid S) : + Cardinal.mk (orderAdherence S) ≤ (2 : Cardinal) ^ Cardinal.mk S := by + let E := signedPositiveSubsetSuprema S + have hSE : S ⊆ E := by + intro s hs + constructor + · refine ⟨{s⁺}, ?_, isLUB_singleton⟩ + rintro a rfl + have hspos : |s⁺| ≤ |s| := by + rw [abs_of_nonneg (posPart_nonneg s)] + exact posPart_le_abs s + exact ⟨hS hs hspos, posPart_nonneg s⟩ + · refine ⟨{s⁻}, ?_, isLUB_singleton⟩ + rintro a rfl + have hsneg : |s⁻| ≤ |s| := by + rw [abs_of_nonneg (negPart_nonneg s)] + exact negPart_le_abs s + exact ⟨hS hs hsneg, negPart_nonneg s⟩ + have hadhE : orderAdherence S ⊆ E := fun _ hx ↦ + signedPositiveSubsetSuprema_isOrderClosed hS (orderAdherence_mono hSE hx) + let Aplus : E → Set X := fun x ↦ Classical.choose x.2.1 + let Aminus : E → Set X := fun x ↦ Classical.choose x.2.2 + have hAplus : ∀ x : E, + Aplus x ⊆ S ∩ Ici 0 ∧ IsLUB (Aplus x) x.1⁺ := fun x ↦ + Classical.choose_spec x.2.1 + have hAminus : ∀ x : E, + Aminus x ⊆ S ∩ Ici 0 ∧ IsLUB (Aminus x) x.1⁻ := fun x ↦ + Classical.choose_spec x.2.2 + let Ψ : E → Set S := fun x ↦ + {s | s.1 ∈ Aplus x ∨ -s.1 ∈ Aminus x} + have hΨ : Function.Injective Ψ := by + intro x y hxy + have hplus_le : x.1⁺ ≤ y.1⁺ := (hAplus x).2.2 fun a ha ↦ by + by_cases ha0 : a = 0 + · simp [ha0] + · have haS : a ∈ S := ((hAplus x).1 ha).1 + have haΨx : (⟨a, haS⟩ : S) ∈ Ψ x := Or.inl ha + have haΨy : (⟨a, haS⟩ : S) ∈ Ψ y := by + rw [← hxy] + exact haΨx + rcases haΨy with hay | hnega + · exact (hAplus y).2.1 hay + · have hnega0 : 0 ≤ -a := ((hAminus y).1 hnega).2 + have : a = 0 := le_antisymm (by simpa using hnega0) ((hAplus x).1 ha).2 + exact (ha0 this).elim + have hplus_ge : y.1⁺ ≤ x.1⁺ := (hAplus y).2.2 fun a ha ↦ by + by_cases ha0 : a = 0 + · simp [ha0] + · have haS : a ∈ S := ((hAplus y).1 ha).1 + have haΨy : (⟨a, haS⟩ : S) ∈ Ψ y := Or.inl ha + have haΨx : (⟨a, haS⟩ : S) ∈ Ψ x := by + rw [hxy] + exact haΨy + rcases haΨx with hax | hnega + · exact (hAplus x).2.1 hax + · have hnega0 : 0 ≤ -a := ((hAminus x).1 hnega).2 + have : a = 0 := le_antisymm (by simpa using hnega0) ((hAplus y).1 ha).2 + exact (ha0 this).elim + have hminus_le : x.1⁻ ≤ y.1⁻ := (hAminus x).2.2 fun a ha ↦ by + by_cases ha0 : a = 0 + · simp [ha0] + · have haS : a ∈ S := ((hAminus x).1 ha).1 + have hnegS : -a ∈ S := hS haS (by simp) + have haΨx : (⟨-a, hnegS⟩ : S) ∈ Ψ x := by + right + simpa using ha + have haΨy : (⟨-a, hnegS⟩ : S) ∈ Ψ y := by + rw [← hxy] + exact haΨx + rcases haΨy with hnega | hay + · have hnega0 : 0 ≤ -a := ((hAplus y).1 hnega).2 + have : a = 0 := le_antisymm (by simpa using hnega0) ((hAminus x).1 ha).2 + exact (ha0 this).elim + · exact (hAminus y).2.1 (by simpa using hay) + have hminus_ge : y.1⁻ ≤ x.1⁻ := (hAminus y).2.2 fun a ha ↦ by + by_cases ha0 : a = 0 + · simp [ha0] + · have haS : a ∈ S := ((hAminus y).1 ha).1 + have hnegS : -a ∈ S := hS haS (by simp) + have haΨy : (⟨-a, hnegS⟩ : S) ∈ Ψ y := by + right + simpa using ha + have haΨx : (⟨-a, hnegS⟩ : S) ∈ Ψ x := by + rw [hxy] + exact haΨy + rcases haΨx with hnega | hax + · have hnega0 : 0 ≤ -a := ((hAplus x).1 hnega).2 + have : a = 0 := le_antisymm (by simpa using hnega0) ((hAminus y).1 ha).2 + exact (ha0 this).elim + · exact (hAminus x).2.1 (by simpa using hax) + apply Subtype.ext + calc + x.1 = x.1⁺ - x.1⁻ := (posPart_sub_negPart x.1).symm + _ = y.1⁺ - y.1⁻ := by + rw [le_antisymm hplus_le hplus_ge, le_antisymm hminus_le hminus_ge] + _ = y.1 := posPart_sub_negPart y.1 + let θ : orderAdherence S → E := fun x ↦ ⟨x.1, hadhE x.2⟩ + have hθ : Function.Injective θ := fun x y hxy ↦ by + apply Subtype.ext + dsimp [θ] at hxy + exact congrArg (fun z : E ↦ z.1) hxy + calc + Cardinal.mk (orderAdherence S) ≤ Cardinal.mk E := Cardinal.mk_le_of_injective hθ + _ ≤ Cardinal.mk (Set S) := Cardinal.mk_le_of_injective hΨ + _ = (2 : Cardinal) ^ Cardinal.mk S := Cardinal.mk_set + +end Counterexample + +end OrderClosures diff --git a/LeanPool/OrderClosures/GaoLeungProblem/Iterations.lean b/LeanPool/OrderClosures/GaoLeungProblem/Iterations.lean new file mode 100644 index 0000000000..2f04e53981 --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem/Iterations.lean @@ -0,0 +1,760 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem.StageFormula +public import Mathlib.SetTheory.Cardinal.Ordinal + + +/-! +# Arbitrarily long order-adherence iterations +-/ + +@[expose] public section + +namespace OrderClosures + +open Set + +universe u v + +section OrdinalConstruction + +/-- The canonical transfinite tower obtained by iterating order adherence; +used as the tower field of the final global construction. -/ +noncomputable def canonicalOrderAdherenceTower + {X : Type v} [AddCommGroup X] [Lattice X] + (A : Set X) : OrderAdherenceTower A where + stage η := transfiniteIterate orderAdherence η A + stage_zero := transfiniteIterate_bot _ _ + stage_succ η := transfiniteIterate_succ _ _ _ (by + rw [not_isMax_iff] + exact ⟨η + 1, lt_add_one η⟩) + stage_limit η hη := by + rw [transfiniteIterate_limit _ _ _ hη] + ext x + simp + +/-- A successor-indexed generator type for one Gao component; used to enumerate +the initial component stage with controlled cardinality. -/ +abbrev GaoSuccessorGenerator (β : Ordinal.{u}) := + {ζ : GaoIndex β // ζ ∈ GaoStageIndices β 1} + +/-- Indices for all Gao components below the successor cardinal of `κ`; used +as the coordinate type of the global product. -/ +abbrev GaoComponentIndex (κ : Cardinal.{u}) := + Set.Iio (Cardinal.ord (Order.succ κ)) + +/-- The continuous-function lattice attached to one Gao ordinal component. -/ +abbrev GaoComponent (β : Ordinal.{u}) := + C(GaoCompactSpace β, ℝ) + +/-- The padded dependent product containing every required Gao component; +used for the global arbitrary-iteration witness. -/ +abbrev GaoIterationProduct (κ : Cardinal.{u}) := + (∀ β : GaoComponentIndex κ, GaoComponent β.1) × + (ULift.{u + 1, u} (Cardinal.ord κ).ToType → ℝ) + +/-- Supplies pointwise order compatibility with addition on the iteration +product. -/ +instance (κ : Cardinal.{u}) : IsOrderedAddMonoid (GaoIterationProduct κ) where + add_le_add_left a b hab c := by + constructor + · intro β + simpa [add_comm] using add_le_add_right (hab.1 β) (c.1 β) + · intro i + simpa [add_comm] using add_le_add_right (hab.2 i) (c.2 i) + +/-- Supplies monotonicity of nonnegative scalar multiplication on the iteration +product, needed for its vector-lattice structure. -/ +instance (κ : Cardinal.{u}) : PosSMulMono ℝ (GaoIterationProduct κ) where + smul_le_smul_of_nonneg_left a ha b₁ b₂ hbc := by + constructor + · intro β + rw [ContinuousMap.le_def] + intro y + exact smul_le_smul_of_nonneg_left ((hbc.1 β) y) ha + · intro i + exact smul_le_smul_of_nonneg_left (hbc.2 i) ha + +/-- Bundles the pointwise vector-lattice structure on the padded product. -/ +noncomputable instance (κ : Cardinal.{u}) : VectorLattice (GaoIterationProduct κ) where + +/-- Computes absolute value in the component part of the iteration product; +used to analyze solid domination of global generators. -/ +theorem gaoIterationProduct_abs_fst + (κ : Cardinal.{u}) (x : GaoIterationProduct κ) (β : GaoComponentIndex κ) : + |x|.1 β = |x.1 β| := rfl + +/-- Computes absolute value in the padding coordinate of the iteration +product; used to recover generator indices from domination. -/ +theorem gaoIterationProduct_abs_snd + (κ : Cardinal.{u}) (x : GaoIterationProduct κ) + (a : ULift.{u + 1, u} (Cardinal.ord κ).ToType) : + |x|.2 a = |x.2 a| := rfl + +/-- Bounds the cardinality of the chosen successor-generator type; used to +fit all component generators into the global cardinal `κ`. -/ +theorem mk_gaoSuccessorGenerator_le + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : Ordinal.{u}) (hβ : β < Cardinal.ord (Order.succ κ)) : + Cardinal.mk (GaoSuccessorGenerator β) ≤ Cardinal.lift.{u + 1, u} κ := by + let bound : Ordinal.{u} := (Ordinal.omega0 ^ β + 1) + 1 + let e : GaoIndex β ↪ Set.Iio bound := + ⟨fun ζ ↦ ⟨ζ.1, by + change ζ.1 < (Ordinal.omega0 ^ β + 1) + 1 + rw [← Order.succ_eq_add_one, Order.lt_succ_iff] + exact ζ.2⟩, + fun _ _ h ↦ Subtype.ext (congrArg (fun z : Set.Iio bound ↦ z.1) h)⟩ + have hβcard : β.card ≤ κ := Cardinal.card_le_iff.mpr hβ + have hpowcard : (Ordinal.omega0 ^ β).card ≤ κ := by + refine (Ordinal.card_opow_le Ordinal.omega0 β).trans ?_ + rw [Ordinal.card_omega0] + exact max_le hκ (max_le hκ hβcard) + have honeκ : (1 : Cardinal) ≤ κ := Cardinal.one_lt_aleph0.le.trans hκ + have hboundcard : bound.card ≤ κ := by + calc + bound.card = (Ordinal.omega0 ^ β).card + 1 + 1 := by + simp only [bound, Ordinal.card_add, Ordinal.card_one] + _ ≤ κ + 1 + 1 := add_le_add (add_le_add hpowcard le_rfl) le_rfl + _ = κ := by + rw [Cardinal.add_eq_left hκ honeκ, Cardinal.add_eq_left hκ honeκ] + calc + Cardinal.mk (GaoSuccessorGenerator β) ≤ Cardinal.mk (GaoIndex β) := + Cardinal.mk_subtype_le _ + _ ≤ Cardinal.mk (Set.Iio bound) := Cardinal.mk_le_of_injective e.injective + _ = Cardinal.lift.{u + 1, u} bound.card := Cardinal.mk_Iio_ordinal bound + _ ≤ Cardinal.lift.{u + 1, u} κ := Cardinal.lift_le.mpr hboundcard + +/-- Embeds a successor-stage generator into the corresponding continuous- +function component; used to form the global diagonal family. -/ +noncomputable def gaoGeneratorEmbedding + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : Ordinal.{u}) (hβ : β < Cardinal.ord (Order.succ κ)) : + GaoSuccessorGenerator β ↪ ULift.{u + 1, u} (Cardinal.ord κ).ToType := by + apply Classical.choice + rw [← Cardinal.le_def] + change Cardinal.mk (GaoSuccessorGenerator β) ≤ + Cardinal.lift.{u + 1, u} (Cardinal.mk (Cardinal.ord κ).ToType) + rw [Cardinal.mk_ord_toType] + exact mk_gaoSuccessorGenerator_le κ hκ β hβ + +/-- Adds the padding coordinate to a component generator so different indices +remain distinguishable under solid domination. -/ +noncomputable def gaoComponentGenerator + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) + (a : ULift.{u + 1, u} (Cardinal.ord κ).ToType) : GaoComponent β.1 := by + classical + exact if h : ∃ ζ : GaoSuccessorGenerator β.1, + gaoGeneratorEmbedding κ hκ β.1 β.2 ζ = a then + ordinalProjection β.1 (Classical.choose h).1 + else 0 + +/-- Evaluates a component generator after embedding into the padded product; +used to relate global generators to their Gao coordinates. -/ +theorem gaoComponentGenerator_embedding + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) (ζ : GaoSuccessorGenerator β.1) : + gaoComponentGenerator κ hκ β + (gaoGeneratorEmbedding κ hκ β.1 β.2 ζ) = + ordinalProjection β.1 ζ.1 := by + rw [gaoComponentGenerator, dite_eq_left ⟨ζ, rfl⟩] + congr 1 + exact congrArg (fun η : GaoSuccessorGenerator β.1 ↦ η.1) + ((gaoGeneratorEmbedding κ hκ β.1 β.2).injective + (Classical.choose_spec + (show ∃ η : GaoSuccessorGenerator β.1, + gaoGeneratorEmbedding κ hκ β.1 β.2 η = + gaoGeneratorEmbedding κ hκ β.1 β.2 ζ from ⟨ζ, rfl⟩))) + +/-- The diagonal generator in the full product for a fixed cardinal index; +its range generates the global solid set. -/ +noncomputable def gaoGlobalGenerator + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (a : ULift.{u + 1, u} (Cardinal.ord κ).ToType) : GaoIterationProduct κ := + (fun β ↦ gaoComponentGenerator κ hκ β a, + fun b ↦ if b = a then (1 : ℝ) else 0) + +/-- Projection from the global product to one continuous-function component; +used to transfer adherence membership downward. -/ +def gaoProductProjection (κ : Cardinal.{u}) (β : GaoComponentIndex κ) : + GaoIterationProduct κ → GaoComponent β.1 := fun x ↦ x.1 β + +/-- Single-coordinate inclusion of a Gao component into the padded product; +used to lift adherence witnesses upward. -/ +noncomputable def gaoProductInclusion + (κ : Cardinal.{u}) (β : GaoComponentIndex κ) : + GaoComponent β.1 → GaoIterationProduct κ := fun x ↦ + (Pi.single β x, 0) + +/-- Shows that coordinate projection preserves order convergence; used to +project every global adherence stage to its component stage. -/ +theorem orderConvergesTo_gaoProductProjection + (κ : Cardinal.{u}) (β : GaoComponentIndex κ) + {i : Type v} [Preorder i] {f : i → GaoIterationProduct κ} + {x : GaoIterationProduct κ} (hfx : OrderConvergesTo f x) : + OrderConvergesTo (fun j ↦ gaoProductProjection κ β (f j)) + (gaoProductProjection κ β x) := by + classical + rcases hfx with ⟨τ, hτpre, hτdir, hτne, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder τ := hτpre + let : IsDirected τ (· ≤ ·) := hτdir + let : Nonempty τ := hτne + refine ⟨τ, inferInstance, inferInstance, inferInstance, + fun k ↦ gaoProductProjection κ β (r k), ?_, ?_, ?_, ?_⟩ + · intro k l hkl + exact (hranti hkl).1 β + · intro k + exact (hrnonneg k).1 β + · constructor + · rintro _ ⟨k, rfl⟩ + exact (hrglb.1 ⟨k, rfl⟩).1 β + · intro c hc + let w : GaoIterationProduct κ := (Pi.single β c, 0) + have hw : w ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + constructor + · intro γ + by_cases hγ : γ = β + · subst γ + simp only [w, Pi.single_eq_same] + exact hc ⟨k, rfl⟩ + · simpa [w, hγ] using (hrnonneg k).1 γ + · exact fun _ ↦ (hrnonneg k).2 _ + have hw0 := hrglb.2 hw + simpa [w] using hw0.1 β + · intro k + exact (hbound k).mono fun j hj ↦ hj.1 β + +/-- Shows that single-coordinate inclusion preserves order convergence; used +to lift component adherence witnesses into the global product. -/ +theorem orderConvergesTo_gaoProductInclusion + (κ : Cardinal.{u}) (β : GaoComponentIndex κ) + {i : Type v} [Preorder i] {f : i → GaoComponent β.1} + {x : GaoComponent β.1} (hfx : OrderConvergesTo f x) : + OrderConvergesTo (fun j ↦ gaoProductInclusion κ β (f j)) + (gaoProductInclusion κ β x) := by + classical + rcases hfx with ⟨τ, hτpre, hτdir, hτne, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder τ := hτpre + let : IsDirected τ (· ≤ ·) := hτdir + let : Nonempty τ := hτne + refine ⟨τ, inferInstance, inferInstance, inferInstance, + fun k ↦ gaoProductInclusion κ β (r k), ?_, ?_, ?_, ?_⟩ + · intro k l hkl + constructor + · intro γ + by_cases hγ : γ = β + · subst γ + simpa [gaoProductInclusion] using hranti hkl + · simp [gaoProductInclusion, hγ] + · exact le_rfl + · intro k + constructor + · intro γ + by_cases hγ : γ = β + · subst γ + simpa [gaoProductInclusion] using hrnonneg k + · simp [gaoProductInclusion, hγ] + · exact le_rfl + · constructor + · rintro _ ⟨k, rfl⟩ + constructor + · intro γ + by_cases hγ : γ = β + · subst γ + simpa [gaoProductInclusion] using hrglb.1 ⟨k, rfl⟩ + · simp [gaoProductInclusion, hγ] + · exact le_rfl + · intro w hw + constructor + · intro γ + by_cases hγ : γ = β + · subst γ + apply hrglb.2 + rintro _ ⟨k, rfl⟩ + simpa [gaoProductInclusion] using (hw ⟨k, rfl⟩).1 β + · obtain ⟨k⟩ := (inferInstance : Nonempty τ) + simpa [gaoProductInclusion, hγ] using + (hw ⟨k, rfl⟩).1 γ + · intro a + obtain ⟨k⟩ := (inferInstance : Nonempty τ) + simpa [gaoProductInclusion] using (hw ⟨k, rfl⟩).2 a + · intro k + exact (hbound k).mono fun j hj ↦ by + constructor + · intro γ + change |((Pi.single + (M := fun δ : GaoComponentIndex κ ↦ GaoComponent δ.1) β (f j) - + Pi.single (M := fun δ : GaoComponentIndex κ ↦ GaoComponent δ.1) β x) γ)| ≤ + (Pi.single (M := fun δ : GaoComponentIndex κ ↦ GaoComponent δ.1) + β (r k)) γ + by_cases hγ : γ = β + · subst γ + simpa only [Pi.sub_apply, Pi.single_eq_same] using hj + · simp [hγ] + · intro a + change |((0 : ULift.{u + 1, u} (Cardinal.ord κ).ToType → ℝ) a - 0)| ≤ 0 + simp + +/-- Transfers membership in order adherence through product projection; used +in the inductive comparison of global and component stages. -/ +theorem gaoProductProjection_orderAdherence + (κ : Cardinal.{u}) (β : GaoComponentIndex κ) (A : Set (GaoIterationProduct κ)) : + gaoProductProjection κ β '' orderAdherence A ⊆ + orderAdherence (gaoProductProjection κ β '' A) := by + rintro _ ⟨x, ⟨i, hpre, hdir, hne, f, hfA, hfx⟩, rfl⟩ + exact ⟨i, hpre, hdir, hne, fun j ↦ gaoProductProjection κ β (f j), + fun j ↦ ⟨f j, hfA j, rfl⟩, orderConvergesTo_gaoProductProjection κ β hfx⟩ + +/-- Transfers component order-adherence membership through coordinate +inclusion; used for the reverse stage comparison. -/ +theorem gaoProductInclusion_orderAdherence + (κ : Cardinal.{u}) (β : GaoComponentIndex κ) (A : Set (GaoComponent β.1)) : + gaoProductInclusion κ β '' orderAdherence A ⊆ + orderAdherence (gaoProductInclusion κ β '' A) := by + rintro _ ⟨x, ⟨i, hpre, hdir, hne, f, hfA, hfx⟩, rfl⟩ + exact ⟨i, hpre, hdir, hne, fun j ↦ gaoProductInclusion κ β (f j), + fun j ↦ ⟨f j, hfA j, rfl⟩, orderConvergesTo_gaoProductInclusion κ β hfx⟩ + +/-- The solid hull of the global diagonal generator range; this is the set +whose adherence tower has the prescribed length. -/ +noncomputable def gaoIterationSet + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) : Set (GaoIterationProduct κ) := + solidHull (Set.range (gaoGlobalGenerator κ hκ)) + +/-- Places each embedded component generator in the global solid generator +set; this initializes the stage-inclusion induction. -/ +theorem gaoComponentGenerator_mem + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) + (a : ULift.{u + 1, u} (Cardinal.ord κ).ToType) : + gaoComponentGenerator κ hκ β a ∈ GaoStageSet β.1 1 := by + classical + rw [gaoComponentGenerator] + split + next h => + let ζ := Classical.choose h + have hζ := ζ.2 + refine ⟨ζ.1, hζ, ?_⟩ + have hnonneg : 0 ≤ ordinalProjection β.1 ζ.1 := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + rw [abs_of_nonneg hnonneg] + next h => + let ζ : GaoIndex β.1 := ⟨0, by simp⟩ + refine ⟨ζ, ⟨by simp [ζ], by simp [ζ, leastCNFExponent]⟩, ?_⟩ + have hnonneg : 0 ≤ ordinalProjection β.1 ζ := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + simpa using hnonneg + +/-- Proves the initial projection inclusion between the global set and a Gao +component; used as the base case of `gaoProjection_stage`. -/ +theorem gaoProjection_initial + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) : + gaoProductProjection κ β '' gaoIterationSet κ hκ ⊆ GaoStageSet β.1 1 := by + rintro _ ⟨x, ⟨g, ⟨a, rfl⟩, hx⟩, rfl⟩ + apply isSolid_gaoStageSet β.1 1 (gaoComponentGenerator_mem κ hκ β a) + exact hx.1 β + +/-- Proves the initial inclusion of a component Gao stage into the global +solid set; used as the base case of `gaoInclusion_stage`. -/ +theorem gaoInclusion_initial + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) : + gaoProductInclusion κ β '' GaoStageSet β.1 1 ⊆ gaoIterationSet κ hκ := by + classical + rintro _ ⟨x, ⟨ζ, hζ, hx⟩, rfl⟩ + let ζ' : GaoSuccessorGenerator β.1 := ⟨ζ, hζ⟩ + let a := gaoGeneratorEmbedding κ hκ β.1 β.2 ζ' + refine ⟨gaoGlobalGenerator κ hκ a, ⟨a, rfl⟩, ?_⟩ + constructor + · intro γ + rw [gaoIterationProduct_abs_fst, gaoIterationProduct_abs_fst] + by_cases hγ : γ = β + · subst γ + simp only [gaoProductInclusion, gaoGlobalGenerator, Pi.single_eq_same] + rw [gaoComponentGenerator_embedding] + have hnonneg : 0 ≤ ordinalProjection β.1 ζ := by + intro y + simp only [ordinalProjection] + split_ifs <;> norm_num + dsimp only [ζ'] + rw [abs_of_nonneg hnonneg] + exact hx + · change |(Pi.single + (M := fun δ : GaoComponentIndex κ ↦ GaoComponent δ.1) β x) γ| ≤ + |gaoComponentGenerator κ hκ γ a| + rw [Pi.single_eq_of_ne hγ] + simp + · intro b + rw [gaoIterationProduct_abs_snd, gaoIterationProduct_abs_snd] + simp only [gaoProductInclusion, gaoGlobalGenerator, Pi.zero_apply] + simp + +/-- Propagates the projection inclusion through every adherence stage; used +to transfer component strictness to the global tower. -/ +theorem gaoProjection_stage + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) : ∀ η : Ordinal.{u + 1}, + gaoProductProjection κ β '' + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage η ⊆ + (canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage η := by + intro η + induction η using Ordinal.limitRecOn with + | zero => + simpa only [OrderAdherenceTower.stage_zero] using gaoProjection_initial κ hκ β + | add_one η ih => + rintro _ ⟨x, hx, rfl⟩ + rw [← Order.succ_eq_add_one, + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage_succ] at hx + rw [← Order.succ_eq_add_one, + (canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage_succ] + apply orderAdherence_mono ih + exact gaoProductProjection_orderAdherence κ β _ ⟨x, hx, rfl⟩ + | limit η hη ih => + rintro _ ⟨x, hx, rfl⟩ + rw [(canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage_limit η hη] at hx + rw [(canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage_limit η hη] + rcases Set.mem_iUnion.mp hx with ⟨δ, hxδ⟩ + apply Set.mem_iUnion.mpr + exact ⟨δ, ih δ.1 δ.2 ⟨x, hxδ, rfl⟩⟩ + +/-- Propagates component inclusion through every adherence stage; paired with +`gaoProjection_stage` to compare the two towers. -/ +theorem gaoInclusion_stage + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + (β : GaoComponentIndex κ) : ∀ η : Ordinal.{u + 1}, + gaoProductInclusion κ β '' + (canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage η ⊆ + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage η := by + intro η + induction η using Ordinal.limitRecOn with + | zero => + simpa only [OrderAdherenceTower.stage_zero] using gaoInclusion_initial κ hκ β + | add_one η ih => + rintro _ ⟨x, hx, rfl⟩ + rw [← Order.succ_eq_add_one, + (canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage_succ] at hx + rw [← Order.succ_eq_add_one, + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage_succ] + apply orderAdherence_mono ih + exact gaoProductInclusion_orderAdherence κ β _ ⟨x, hx, rfl⟩ + | limit η hη ih => + rintro _ ⟨x, hx, rfl⟩ + rw [(canonicalOrderAdherenceTower (GaoStageSet β.1 1)).stage_limit η hη] at hx + rw [(canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage_limit η hη] + rcases Set.mem_iUnion.mp hx with ⟨δ, hxδ⟩ + apply Set.mem_iUnion.mpr + exact ⟨δ, ih δ.1 δ.2 ⟨x, hxδ, rfl⟩⟩ + +/-- Supplies the ordinal successor inequality needed to choose the component +whose strict stage witnesses a prescribed global stage. -/ +theorem one_add_le_add_one_ordinal (δ : Ordinal.{u}) : + 1 + δ ≤ δ + 1 := by + induction δ using Ordinal.limitRecOn with + | zero => simp + | add_one δ ih => + calc + 1 + (δ + 1) = (1 + δ) + 1 := (add_assoc 1 δ 1).symm + _ ≤ (δ + 1) + 1 := by + simpa only [Order.succ_eq_add_one] using Order.succ_le_succ ih + | limit δ hδ ih => + rw [Ordinal.one_add_of_omega0_le (Ordinal.omega0_le_of_isSuccLimit hδ)] + exact le_self_add + +/-- Transfers strictness from a suitable Gao component to every stage below +the target ordinal of the global iteration tower. -/ +theorem gaoIterationTower_strict + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) : + ∀ η < Ordinal.lift.{u + 1, u} (Cardinal.ord (Order.succ κ)), + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage η ⊂ + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage (Order.succ η) := by + classical + intro η hη + obtain ⟨δ, hδ, hδη⟩ := Ordinal.lt_lift_iff.mp hη + have hκsucc : Cardinal.aleph0 ≤ Order.succ κ := hκ.trans (Order.le_succ κ) + have hlimit := Cardinal.isSuccLimit_ord hκsucc + let β : GaoComponentIndex κ := ⟨Order.succ δ, hlimit.succ_lt hδ⟩ + let C := canonicalOrderAdherenceTower (GaoStageSet β.1 1) + have hδβ : δ ≤ β.1 := by + dsimp only [β] + exact Order.le_succ δ + have hδoneβ : δ + 1 ≤ β.1 := by + dsimp only [β] + rw [Order.succ_eq_add_one] + have hgamma : 1 + δ ≤ β.1 := + (one_add_le_add_one_ordinal δ).trans hδoneβ + obtain ⟨ζ, hζnext, hζprev⟩ := ordinalProjection_strict_stage β.1 (1 + δ) hgamma + let p := ordinalProjection β.1 ζ + have hCδ := gao_orderAdherence_stage_formula β.1 C δ hδβ + have hCnext := gao_orderAdherence_stage_formula β.1 C (δ + 1) hδoneβ + have hpCnext : p ∈ C.stage (Ordinal.lift.{u + 1, u} (δ + 1)) := by + rw [hCnext] + simpa only [p, add_assoc] using hζnext + have hpCprev : p ∉ C.stage (Ordinal.lift.{u + 1, u} δ) := by + rw [hCδ] + exact hζprev + have hliftnext : Ordinal.lift.{u + 1, u} (δ + 1) = Order.succ η := by + rw [Order.succ_eq_add_one, Ordinal.lift_add_one, hδη] + let q := gaoProductInclusion κ β p + have hqnext : q ∈ + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage (Order.succ η) := by + rw [← hliftnext] + exact gaoInclusion_stage κ hκ β _ ⟨p, hpCnext, rfl⟩ + have hqprev : q ∉ + (canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage η := by + intro hq + have hproj := gaoProjection_stage κ hκ β η ⟨q, hq, rfl⟩ + have hp : p ∈ C.stage η := by + simpa [q, gaoProductProjection, gaoProductInclusion] using hproj + rw [← hδη] at hp + exact hpCprev hp + rw [Set.ssubset_iff_exists] + refine ⟨?_, q, hqnext, hqprev⟩ + intro x hx + rw [(canonicalOrderAdherenceTower (gaoIterationSet κ hκ)).stage_succ] + exact subset_orderAdherence _ hx + +/-- Recovers equality of generator indices from solid domination; used to +prove injectivity of the global generator map. -/ +theorem gaoGlobalGenerator_index_eq_of_abs_le + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) + {a b : ULift.{u + 1, u} (Cardinal.ord κ).ToType} + (hab : |gaoGlobalGenerator κ hκ a| ≤ |gaoGlobalGenerator κ hκ b|) : + a = b := by + classical + by_contra hne + have h := hab.2 a + rw [gaoIterationProduct_abs_snd, gaoIterationProduct_abs_snd] at h + simp [gaoGlobalGenerator, hne] at h + norm_num at h + +/-- Proves that distinct indices give distinct global generators; used for the +lower bound on the generator cardinal. -/ +theorem gaoGlobalGenerator_injective + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) : + Function.Injective (gaoGlobalGenerator κ hκ) := by + intro a b hab + apply gaoGlobalGenerator_index_eq_of_abs_le κ hκ + rw [hab] + +/-- Computes the cardinality of the global generator range; used in the exact +calculation of `solidGeneratorNumber`. -/ +theorem mk_gaoGlobalGenerator_range + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) : + Cardinal.mk (Set.range (gaoGlobalGenerator κ hκ)) = + Cardinal.lift.{u + 1, u} κ := by + calc + Cardinal.mk (Set.range (gaoGlobalGenerator κ hκ)) = + Cardinal.mk (ULift.{u + 1, u} (Cardinal.ord κ).ToType) := + Cardinal.mk_range_eq _ (gaoGlobalGenerator_injective κ hκ) + _ = Cardinal.lift.{u + 1, u} κ := by + change Cardinal.lift.{u + 1, u} + (Cardinal.mk (Cardinal.ord κ).ToType) = Cardinal.lift.{u + 1, u} κ + rw [Cardinal.mk_ord_toType] + +/-- Proves that the constructed solid set has generator number exactly `κ`; +used in the final arbitrary-iteration theorem. -/ +theorem solidGeneratorNumber_gaoIterationSet + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) : + solidGeneratorNumber (gaoIterationSet κ hκ) = Cardinal.lift.{u + 1, u} κ := by + classical + apply le_antisymm + · calc + solidGeneratorNumber (gaoIterationSet κ hκ) ≤ + Cardinal.mk (Set.range (gaoGlobalGenerator κ hκ)) := by + apply csInf_le' + exact ⟨Set.range (gaoGlobalGenerator κ hκ), rfl, rfl⟩ + _ = Cardinal.lift.{u + 1, u} κ := mk_gaoGlobalGenerator_range κ hκ + · apply le_csInf + · exact ⟨Cardinal.mk (Set.range (gaoGlobalGenerator κ hκ)), + Set.range (gaoGlobalGenerator κ hκ), rfl, rfl⟩ + · intro c hc + rcases hc with ⟨A, hAc, hAS⟩ + rw [← hAc] + have hbelow : ∀ a : ULift.{u + 1, u} (Cardinal.ord κ).ToType, + ∃ x : A, |gaoGlobalGenerator κ hκ a| ≤ |x.1| := by + intro a + have hgenS : gaoGlobalGenerator κ hκ a ∈ solidHull A := by + rw [hAS] + exact ⟨gaoGlobalGenerator κ hκ a, ⟨a, rfl⟩, le_rfl⟩ + rcases hgenS with ⟨x, hxA, hax⟩ + exact ⟨⟨x, hxA⟩, hax⟩ + choose x hx using hbelow + have habove : ∀ a : ULift.{u + 1, u} (Cardinal.ord κ).ToType, + ∃ b : ULift.{u + 1, u} (Cardinal.ord κ).ToType, + |(x a).1| ≤ |gaoGlobalGenerator κ hκ b| := by + intro a + have hxS : (x a).1 ∈ gaoIterationSet κ hκ := by + rw [← hAS] + exact ⟨(x a).1, (x a).2, le_rfl⟩ + rcases hxS with ⟨g, ⟨b, rfl⟩, hxb⟩ + exact ⟨b, hxb⟩ + choose b hb using habove + have hxinj : Function.Injective x := by + intro a a' haa' + have hab' : |gaoGlobalGenerator κ hκ a| ≤ + |gaoGlobalGenerator κ hκ (b a')| := by + calc + |gaoGlobalGenerator κ hκ a| ≤ |(x a).1| := hx a + _ = |(x a').1| := by rw [haa'] + _ ≤ |gaoGlobalGenerator κ hκ (b a')| := hb a' + have ha'b : a' = b a' := + gaoGlobalGenerator_index_eq_of_abs_le κ hκ ((hx a').trans (hb a')) + exact (gaoGlobalGenerator_index_eq_of_abs_le κ hκ hab').trans ha'b.symm + calc + Cardinal.lift.{u + 1, u} κ = + Cardinal.mk (ULift.{u + 1, u} (Cardinal.ord κ).ToType) := by + change Cardinal.lift.{u + 1, u} κ = Cardinal.lift.{u + 1, u} + (Cardinal.mk (Cardinal.ord κ).ToType) + rw [Cardinal.mk_ord_toType] + _ ≤ Cardinal.mk A := Cardinal.mk_le_of_injective hxinj + +/-- Paper Theorem `thm:solid-iterations`: constructs solid sets requiring any +prescribed admissible number of order-adherence iterations. -/ +theorem solid_sets_require_arbitrarily_many_iterations + (κ : Cardinal.{u}) (hκ : Cardinal.aleph0 ≤ κ) (ξ : Ordinal.{u}) + (hξ : ξ ≤ Cardinal.ord (Order.succ κ)) : + ∃ (X : Type (u + 1)) (_ : AddCommGroup X) (_ : Lattice X) + (_ : IsOrderedAddMonoid X) (_ : VectorLattice X), + ∃ S : Set X, LatticeOrderedAddCommGroup.IsSolid S ∧ + solidGeneratorNumber S = Cardinal.lift.{u + 1, u} κ ∧ + NeedsOrderAdherenceIterations S (Ordinal.lift.{u + 1, u} ξ) := by + let S := gaoIterationSet κ hκ + refine ⟨GaoIterationProduct κ, inferInstance, inferInstance, inferInstance, + inferInstance, S, LatticeOrderedAddCommGroup.isSolid_solidClosure _, + solidGeneratorNumber_gaoIterationSet κ hκ, ?_⟩ + refine ⟨canonicalOrderAdherenceTower S, ?_⟩ + intro η hη + exact gaoIterationTower_strict κ hκ η + (hη.trans_le (Ordinal.lift_le.mpr hξ)) + +/-- Converts an absolute-value bound by an order-null net into order +convergence to zero; used in `solid_generated_orderAdherence`. -/ +theorem orderConvergesTo_zero_of_abs_le_gao + {X : Type u} [AddCommGroup X] [Lattice X] + {i : Type v} [Preorder i] {f g : i → X} + (hg : OrderConvergesTo g 0) (hfg : ∀ j, |f j| ≤ |g j|) : + OrderConvergesTo f 0 := by + rcases hg with ⟨k, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, hbound⟩ + refine ⟨k, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, ?_⟩ + intro l + exact (hbound l).mono fun j hj ↦ by + simpa only [sub_zero] using (hfg j).trans (by simpa only [sub_zero] using hj) + +/-- Paper Lemma `lem:solid-generated-order-adh`. -/ +theorem solid_generated_orderAdherence + {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] {G : Set X} (hG : G ⊆ Ici 0) : + orderAdherence (solidHull G) = + {x | ∃ (ι : Type u) (_ : Preorder ι) (_ : IsDirected ι (· ≤ ·)) + (_ : Nonempty ι) (a : ι → X), + (∀ i, a i ∈ G) ∧ + OrderConvergesTo (fun i ↦ |x| ⊓ a i) |x| ∧ + IsLUB (Set.range fun i ↦ |x| ⊓ a i) |x|} := by + ext x + constructor + · rintro ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + rcases hfx with ⟨κ, hκpre, hκdir, hκne, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκne + let y : κ → X := fun k ↦ (|x| - r k)⁺ + have hy_mono : Monotone y := fun _ _ hkl ↦ + posPart_mono (sub_le_sub_left (hranti hkl) |x|) + have hy_lub : IsLUB (Set.range y) |x| := by + constructor + · rintro _ ⟨k, rfl⟩ + exact show (|x| - r k) ⊔ 0 ≤ |x| from + sup_le (sub_le_self _ (hrnonneg k)) (abs_nonneg _) + · intro c hc + have hlow : |x| - c ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + have hraw : |x| - r k ≤ c := (le_posPart _).trans (hc ⟨k, rfl⟩) + exact sub_le_iff_le_add.mpr (by + simpa [add_comm] using (sub_le_iff_le_add.mp hraw)) + exact sub_nonpos.mp (hrglb.2 hlow) + have hyG : ∀ k, ∃ a ∈ G, y k ≤ a := by + intro k + obtain ⟨i, hi⟩ := (hbound k).exists + rcases hf i with ⟨a, haG, hfa⟩ + have hx_le : |x| ≤ |f i| + r k := by + calc + |x| = |(x - f i) + f i| := by congr 1; abel + _ ≤ |x - f i| + |f i| := abs_add_le _ _ + _ = |f i| + |x - f i| := add_comm _ _ + _ ≤ |f i| + r k := add_le_add_right (by + simpa [abs_sub_comm] using hi) _ + have hsub : |x| - r k ≤ |f i| := sub_le_iff_le_add.mpr hx_le + have hyf : y k ≤ |f i| := + show (|x| - r k) ⊔ 0 ≤ |f i| from sup_le hsub (abs_nonneg _) + exact ⟨a, haG, hyf.trans (by simpa [abs_of_nonneg (hG haG)] using hfa)⟩ + choose a haG hya using hyG + let q : κ → X := fun k ↦ |x| ⊓ a k + have hy_order : OrderConvergesTo y |x| := + orderConvergesTo_of_monotone_isLUB hy_mono hy_lub + have hq_order : OrderConvergesTo q |x| := by + have hzero : OrderConvergesTo (fun k ↦ q k - |x|) 0 := by + have hbase : OrderConvergesTo (fun k ↦ y k - |x|) 0 := by + simpa using hy_order.sub (orderConvergesTo_const |x|) + apply orderConvergesTo_zero_of_abs_le_gao hbase + intro k + dsimp [q] + have hyx : y k ≤ |x| := hy_lub.1 ⟨k, rfl⟩ + have hyq : y k ≤ |x| ⊓ a k := le_inf hyx (hya k) + rw [abs_of_nonpos (sub_nonpos.mpr inf_le_left), + abs_of_nonpos (sub_nonpos.mpr hyx)] + exact neg_le_neg (sub_le_sub_right hyq |x|) + have := hzero.add (orderConvergesTo_const (ι := κ) |x|) + simpa [q] using this + have hq_lub : IsLUB (Set.range q) |x| := by + constructor + · rintro _ ⟨k, rfl⟩ + exact inf_le_left + · intro c hc + apply hy_lub.2 + rintro _ ⟨k, rfl⟩ + exact (le_inf (hy_lub.1 ⟨k, rfl⟩) (hya k)).trans (hc ⟨k, rfl⟩) + exact ⟨κ, inferInstance, inferInstance, inferInstance, a, haG, hq_order, hq_lub⟩ + · rintro ⟨ι, hpre, hdir, hne, a, haG, hq_order, _hq_lub⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + let c : ι → X := fun i ↦ (x ⊓ a i) ⊔ (-a i) + have hc_mem : ∀ i, c i ∈ solidHull G := by + intro i + refine ⟨a i, haG i, ?_⟩ + dsimp [c] + have hai : 0 ≤ a i := hG (haG i) + change |(x ⊓ a i) ⊔ -a i| ≤ |a i| + llarith + have hc_order : OrderConvergesTo c x := by + have hzero : OrderConvergesTo (fun i ↦ c i - x) 0 := by + have hbase : OrderConvergesTo (fun i ↦ (|x| ⊓ a i) - |x|) 0 := by + simpa using hq_order.sub (orderConvergesTo_const |x|) + apply orderConvergesTo_zero_of_abs_le_gao hbase + intro i + dsimp [c] + have hai : 0 ≤ a i := hG (haG i) + change |((x ⊓ a i) ⊔ (-a i)) - x| ≤ abs ((|x| ⊓ a i) - |x|) + llarith + have := hzero.add (orderConvergesTo_const (ι := ι) x) + simpa [c] using this + exact ⟨ι, inferInstance, inferInstance, inferInstance, c, hc_mem, hc_order⟩ + +end OrdinalConstruction + +end OrderClosures diff --git a/LeanPool/OrderClosures/GaoLeungProblem/OrdinalSpace.lean b/LeanPool/OrderClosures/GaoLeungProblem/OrdinalSpace.lean new file mode 100644 index 0000000000..5a75c02bc7 --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem/OrdinalSpace.lean @@ -0,0 +1,905 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem.CNFOrder + + +/-! +# The compact ordinal space and coordinate projections +-/ + +@[expose] public section + +namespace OrderClosures + +open Set + +universe u v + +section OrdinalConstruction + +/-- Coordinate indices in the compact ordinal construction. -/ +abbrev GaoIndex (ξ : Ordinal.{u}) := Set.Iic (Ordinal.omega0 ^ ξ + 1) + +/-- The closed subspace of the Cantor cube used in the proof of +`thm:solid-iterations`. -/ +def GaoCompactSpace (ξ : Ordinal.{u}) := + {x : GaoIndex ξ → Bool | + ∀ a b : GaoIndex ξ, cnfExtensionLT a.1 b.1 → x a ≤ x b} + +/-- Coordinate projection `π_ζ` on the Gao compact space. -/ +noncomputable def ordinalProjection (ξ : Ordinal.{u}) (ζ : GaoIndex ξ) : + C(GaoCompactSpace ξ, ℝ) where + toFun := fun x ↦ if x.1 ζ then 1 else 0 + continuous_toFun := by + exact (continuous_of_discreteTopology : + Continuous (fun b : Bool ↦ if b then (1 : ℝ) else 0)).comp + ((continuous_apply ζ).comp continuous_subtype_val) + +/-- Extracts finitely many Cantor-cube coordinates controlling a continuous +real map; used to prove the incomparable-projection infimum formula. -/ +theorem continuousMap_exists_finite_coordinates + {I : Type u} {K : Set (I → Bool)} (f : C(K, ℝ)) (x : K) + {V : Set ℝ} (hV : IsOpen V) (hxV : f x ∈ V) : + ∃ F : Finset I, ∀ y : K, (∀ i ∈ F, y.1 i = x.1 i) → f y ∈ V := by + have hopen : IsOpen (f ⁻¹' V) := hV.preimage f.continuous + rcases isOpen_induced_iff.mp hopen with ⟨W, hW, hWeq⟩ + have hxW : x.1 ∈ W := by + have : x ∈ f ⁻¹' V := hxV + rw [← hWeq] at this + exact this + rcases isOpen_pi_iff.mp hW x.1 hxW with ⟨F, v, hv, hvW⟩ + refine ⟨F, fun y hy ↦ ?_⟩ + have hyv : y.1 ∈ (F : Set I).pi v := by + intro i hi + rw [hy i (Finset.mem_coe.mp hi)] + exact (hv i (Finset.mem_coe.mp hi)).2 + have hyW := hvW hyv + have : y ∈ Subtype.val ⁻¹' W := hyW + rw [hWeq] at this + exact this + +/-- The least exponent in the Cantor normal form of an ordinal (zero at the +empty normal form). -/ +noncomputable def leastCNFExponent (ζ : Ordinal.{u}) : Ordinal.{u} := + ((Ordinal.CNF Ordinal.omega0 ζ).getLast?.map Prod.fst).getD 0 + +/-- The index set `Z_β` from Claim 3. -/ +def GaoStageIndices (ξ β : Ordinal.{u}) : Set (GaoIndex ξ) := + {ζ | ζ.1 ≤ Ordinal.omega0 ^ ξ ∧ leastCNFExponent ζ.1 < β} + +/-- The solid set `S_β` from Claim 3. -/ +def GaoStageSet (ξ β : Ordinal.{u}) : Set C(GaoCompactSpace ξ, ℝ) := + {f | ∃ ζ ∈ GaoStageIndices ξ β, |f| ≤ ordinalProjection ξ ζ} + +/-- Records solidity of each Gao stage set; used to invoke the solid form of +order adherence in the stage formula. -/ +theorem isSolid_gaoStageSet (ξ β : Ordinal.{u}) : + LatticeOrderedAddCommGroup.IsSolid (GaoStageSet ξ β) := by + intro f hf g hgf + obtain ⟨ζ, hζ, hfζ⟩ := hf + exact ⟨ζ, hζ, hgf.trans hfζ⟩ + +/-- Claim 1 in the proof of Theorem `thm:solid-iterations`. -/ +theorem ordinalProjection_incomparable_iInf + (ξ : Ordinal.{u}) (Z : Set (GaoIndex ξ)) (hZ : Z.Infinite) + (hinc : Z.Pairwise fun ζ ζ' ↦ ¬ cnfExtensionLE ζ.1 ζ'.1) : + IsGLB (ordinalProjection ξ '' Z) 0 := by + classical + constructor + · rintro p ⟨ζ, _, rfl⟩ x + simp only [ordinalProjection] + split_ifs <;> norm_num + · intro f hf x + by_contra hfx + have hfxpos : 0 < f x := lt_of_not_ge hfx + obtain ⟨F, hF⟩ := continuousMap_exists_finite_coordinates f x + isOpen_Ioi hfxpos + let bad : Set (GaoIndex ξ) := ⋃ i ∈ (F : Set (GaoIndex ξ)), + {ζ | ζ ∈ Z ∧ x.1 i = true ∧ cnfExtensionLE i.1 ζ.1} + have hbad : bad.Finite := by + apply F.finite_toSet.biUnion + intro i _ + apply Set.Subsingleton.finite + intro ζ hζ ζ' hζ' + rcases hζ with ⟨hζZ, _, hiζ⟩ + rcases hζ' with ⟨hζ'Z, _, hiζ'⟩ + by_contra hne + have hnot := hinc hζZ hζ'Z hne + rcases hiζ with hiζ | hiζ + · have : i = ζ := Subtype.ext hiζ + subst i + exact hnot hiζ' + rcases hiζ' with hiζ' | hiζ' + · have : i = ζ' := Subtype.ext hiζ' + subst i + exact (hinc hζ'Z hζZ (Ne.symm hne)) (Or.inr hiζ) + · rcases lt_trichotomy ζ.1 ζ'.1 with hlt | heq | hgt + · exact hnot (Or.inr + ((cnfExtensionLT_linear_above i.1 hiζ hiζ').mpr hlt)) + · exact hne (Subtype.ext heq) + · exact (hinc hζ'Z hζZ (Ne.symm hne)) + (Or.inr ((cnfExtensionLT_linear_above i.1 hiζ' hiζ).mpr hgt)) + obtain ⟨ζ, hζZ, hζbad⟩ := hZ.exists_notMem_finite hbad + let y : GaoIndex ξ → Bool := fun a ↦ + if cnfExtensionLE a.1 ζ.1 then false else x.1 a + have hy_mono : ∀ a b : GaoIndex ξ, + cnfExtensionLT a.1 b.1 → y a ≤ y b := by + intro a b hab + dsimp [y] + by_cases ha : cnfExtensionLE a.1 ζ.1 + · rw [ite_eq_left ha] + exact Bool.false_le _ + · rw [ite_eq_right ha] + by_cases hb : cnfExtensionLE b.1 ζ.1 + · exact (ha (cnfExtensionLE_partialOrder_and_subrelation.1.trans + a.1 b.1 ζ.1 (Or.inr hab) hb)).elim + · rw [ite_eq_right hb] + exact x.2 a b hab + let yK : GaoCompactSpace ξ := ⟨y, hy_mono⟩ + have hyF : ∀ i ∈ F, yK.1 i = x.1 i := by + intro i hi + dsimp [yK, y] + by_cases hxi : x.1 i = true + · rw [ite_eq_right] + intro hiζ + apply hζbad + simp only [bad, Set.mem_iUnion] + exact ⟨i, Finset.mem_coe.mpr hi, hζZ, hxi, hiζ⟩ + · have hxi' : x.1 i = false := Bool.eq_false_of_not_eq_true hxi + by_cases hiζ : cnfExtensionLE i.1 ζ.1 + · rw [ite_eq_left hiζ, hxi'] + · rw [ite_eq_right hiζ, hxi'] + have hfy : 0 < f yK := hF yK hyF + have hfζ := hf ⟨ζ, hζZ, rfl⟩ yK + have hyζ : yK.1 ζ = false := by + dsimp [yK, y] + rw [ite_eq_left (show cnfExtensionLE ζ.1 ζ.1 from Or.inl rfl)] + simp only [ordinalProjection, hyζ, Bool.false_eq_true, ↓reduceIte] at hfζ + exact not_lt_of_ge hfζ hfy + +/-- Characterizes order between coordinate projections by CNF extension; +used in all dominator and strict-stage arguments. -/ +theorem ordinalProjection_le_iff + (ξ : Ordinal.{u}) (a b : GaoIndex ξ) : + ordinalProjection ξ a ≤ ordinalProjection ξ b ↔ cnfExtensionLE a.1 b.1 := by + classical + constructor + · intro hab + by_contra hrel + let x : GaoIndex ξ → Bool := fun c ↦ + if cnfExtensionLE a.1 c.1 then true else false + have hxmono : ∀ c d : GaoIndex ξ, + cnfExtensionLT c.1 d.1 → x c ≤ x d := by + intro c d hcd + dsimp [x] + by_cases hac : cnfExtensionLE a.1 c.1 + · rw [ite_eq_left hac, ite_eq_left] + exact cnfExtensionLE_partialOrder_and_subrelation.1.trans + a.1 c.1 d.1 hac (Or.inr hcd) + · rw [ite_eq_right hac] + exact Bool.false_le _ + let xK : GaoCompactSpace ξ := ⟨x, hxmono⟩ + have habx := hab xK + have hxa : xK.1 a = true := by + simp [xK, x, cnfExtensionLE] + have hxb : xK.1 b = false := by + simp [xK, x, hrel] + simp only [ordinalProjection, hxa, hxb, Bool.false_eq_true, ↓reduceIte] at habx + norm_num at habx + · intro hab x + rcases hab with hab | hab + · have : a = b := Subtype.ext hab + subst b + exact le_rfl + · dsimp [ordinalProjection] + by_cases hxa : x.1 a = true + · have hxb : x.1 b = true := by + have hx := Bool.le_iff_imp.mp (x.2 a b hab) + have hx' : True → x.1 b = true := by + simpa only [hxa, Bool.true_eq] using hx + exact hx' trivial + simp only [hxa, hxb, ite_true] + norm_num + · simp only [hxa] + positivity + +/-- The leading monomial of an ordinal's canonical normal form; isolated for +the singleton-chain supremum analysis. -/ +noncomputable def leadingCNFTerm (a : Ordinal.{u}) : Ordinal.{u} := + Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a * + (a / Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) + +/-- Bounds a singleton CNF monomial by the leading term of an ordinal; used +to identify possible upper bounds of singleton chains. -/ +theorem cnf_singleton_le_leadingCNFTerm + {q a γ d : Ordinal.{u}} + (hq : Ordinal.CNF Ordinal.omega0 q = [(γ, d)]) (hqa : q ≤ a) : + q ≤ leadingCNFTerm a := by + have hqeq : q = Ordinal.omega0 ^ γ * d := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 q, hq] + simp + have hq0 : q ≠ 0 := by + intro hzero + rw [hzero, Ordinal.CNF.zero_right] at hq + simp at hq + have hdpos : 0 < d := by + apply Ordinal.CNF.snd_pos (b := Ordinal.omega0) (o := q) (x := (γ, d)) + rw [hq] + simp + have hdlt : d < Ordinal.omega0 := by + apply Ordinal.CNF.snd_lt (b := Ordinal.omega0) (o := q) (x := (γ, d)) + Ordinal.one_lt_omega0 + rw [hq] + simp + have hlogq : Ordinal.log Ordinal.omega0 q = γ := by + rw [hqeq, Ordinal.log_opow_mul Ordinal.one_lt_omega0 γ hdpos.ne', + Ordinal.log_eq_zero hdlt, add_zero] + have ha0 : a ≠ 0 := by + intro ha + apply hq0 + exact le_antisymm (ha ▸ hqa) (zero_le : (0 : Ordinal) ≤ q) + have hlogle := Ordinal.log_mono_right Ordinal.omega0 hqa + rw [hlogq] at hlogle + rcases hlogle.eq_or_lt with hloge | hloglt + · rw [leadingCNFTerm, ← hloge, hqeq] + apply mul_le_mul_right + exact (Ordinal.mul_le_iff_le_div + (Ordinal.opow_ne_zero γ Ordinal.omega0_ne_zero)).mp (hqeq ▸ hqa) + · have hqpow : q < Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a := + (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 hq0).2 (by + simpa only [hlogq] using hloglt) + exact hqpow.le.trans (by + rw [leadingCNFTerm] + exact Ordinal.le_mul_left _ + (Ordinal.div_opow_log_pos Ordinal.omega0 ha0)) + +/-- Gives the canonical CNF description of a singleton omega monomial; used +to translate singleton-chain inequalities into exponent inequalities. -/ +theorem cnf_singleton_spec + {q γ d : Ordinal.{u}} + (hq : Ordinal.CNF Ordinal.omega0 q = [(γ, d)]) : + q = Ordinal.omega0 ^ γ * d ∧ 0 < d ∧ d < Ordinal.omega0 ∧ + Ordinal.log Ordinal.omega0 q = γ := by + have hqeq : q = Ordinal.omega0 ^ γ * d := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 q, hq] + simp + have hdpos : 0 < d := by + apply Ordinal.CNF.snd_pos (b := Ordinal.omega0) (o := q) (x := (γ, d)) + rw [hq] + simp + have hdlt : d < Ordinal.omega0 := by + apply Ordinal.CNF.snd_lt (b := Ordinal.omega0) (o := q) (x := (γ, d)) + Ordinal.one_lt_omega0 + rw [hq] + simp + refine ⟨hqeq, hdpos, hdlt, ?_⟩ + rw [hqeq, Ordinal.log_opow_mul Ordinal.one_lt_omega0 γ hdpos.ne', + Ordinal.log_eq_zero hdlt, add_zero] + +/-- Shows that the least upper bound of a nonempty singleton-monomial chain is +itself a singleton monomial; used in the chain-supremum analysis. -/ +theorem cnf_eq_singleton_of_isLUB + (Q : Set (Ordinal.{u})) (a : Ordinal.{u}) (hQ : Q.Nonempty) + (hsingle : ∀ q ∈ Q, ∃ γ d, Ordinal.CNF Ordinal.omega0 q = [(γ, d)]) + (hlub : IsLUB Q a) : + ∃ γ d, Ordinal.CNF Ordinal.omega0 a = [(γ, d)] := by + obtain ⟨q, hqQ⟩ := hQ + obtain ⟨γ, d, hq⟩ := hsingle q hqQ + have hq0 : q ≠ 0 := by + intro hzero + rw [hzero, Ordinal.CNF.zero_right] at hq + simp at hq + have hqa : q ≤ a := hlub.1 hqQ + have ha0 : a ≠ 0 := by + intro ha + apply hq0 + exact le_antisymm (ha ▸ hqa) (zero_le : (0 : Ordinal) ≤ q) + have hleadUpper : leadingCNFTerm a ∈ upperBounds Q := by + intro r hrQ + obtain ⟨e, c, hr⟩ := hsingle r hrQ + exact cnf_singleton_le_leadingCNFTerm hr (hlub.1 hrQ) + have halead : a ≤ leadingCNFTerm a := hlub.2 hleadUpper + have hleada : leadingCNFTerm a ≤ a := by + exact Ordinal.mul_div_le a + (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) + have hleadeq : leadingCNFTerm a = a := le_antisymm hleada halead + have hmod : a % (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) = 0 := by + have hdiv := Ordinal.div_add_mod a + (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) + change leadingCNFTerm a + + a % (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) = a at hdiv + apply add_left_cancel (a := leadingCNFTerm a) + calc + leadingCNFTerm a + a % (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a) = + a := hdiv + _ = leadingCNFTerm a + 0 := by rw [add_zero, hleadeq] + refine ⟨Ordinal.log Ordinal.omega0 a, + a / Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 a, ?_⟩ + rw [Ordinal.CNF.ne_zero ha0, hmod, Ordinal.CNF.zero_right] + +/-- Makes the exponent of a nonattained singleton-chain supremum strictly +larger than every member exponent; used at the limit case of the CNF chain. -/ +theorem cnf_singleton_exponent_lt_of_isLUB_not_mem + (Q : Set (Ordinal.{u})) (a : Ordinal.{u}) + (hsingle : ∀ q ∈ Q, ∃ γ d, Ordinal.CNF Ordinal.omega0 q = [(γ, d)]) + (hlub : IsLUB Q a) (haQ : a ∉ Q) + {q β c γ d : Ordinal.{u}} (hqQ : q ∈ Q) + (hq : Ordinal.CNF Ordinal.omega0 q = [(β, c)]) + (ha : Ordinal.CNF Ordinal.omega0 a = [(γ, d)]) : β < γ := by + obtain ⟨hqeq, hcpos, hclt, hlogq⟩ := cnf_singleton_spec hq + obtain ⟨haeq, hdpos, hdlt, hloga⟩ := cnf_singleton_spec ha + have hqa : q ≤ a := hlub.1 hqQ + have hqne : q ≠ a := fun h ↦ haQ (h ▸ hqQ) + have hqalt : q < a := lt_of_le_of_ne hqa hqne + have hβγ : β ≤ γ := by + have := Ordinal.log_mono_right Ordinal.omega0 hqa + simpa only [hlogq, hloga] using this + apply hβγ.lt_of_ne + intro hβγeq + subst β + obtain ⟨m, rfl⟩ := Ordinal.lt_omega0.mp hclt + obtain ⟨n, rfl⟩ := Ordinal.lt_omega0.mp hdlt + have hmpos : 0 < m := by exact_mod_cast hcpos + have hnpos : 0 < n := by exact_mod_cast hdpos + have hmn : m < n := by + by_contra h + have hnm : n ≤ m := le_of_not_gt h + have hmul : Ordinal.omega0 ^ γ * (n : Ordinal) ≤ + Ordinal.omega0 ^ γ * (m : Ordinal) := + mul_le_mul_right (by exact_mod_cast hnm) _ + have hmulLt : Ordinal.omega0 ^ γ * (m : Ordinal) < + Ordinal.omega0 ^ γ * (n : Ordinal) := by + rw [← hβγeq, ← hqeq, hβγeq, ← haeq] + exact hqalt + exact (not_le_of_gt hmulLt) hmul + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt hnpos) + have hkpos : 0 < k := lt_of_lt_of_le hmpos (Nat.le_of_lt_succ hmn) + let b : Ordinal.{u} := Ordinal.omega0 ^ γ * (k : Ordinal) + have hbUpper : b ∈ upperBounds Q := by + intro r hrQ + obtain ⟨ε, e, hr⟩ := hsingle r hrQ + obtain ⟨hreq, hepos, helt, hlogr⟩ := cnf_singleton_spec hr + have hra : r ≤ a := hlub.1 hrQ + have hrne : r ≠ a := fun h ↦ haQ (h ▸ hrQ) + have hralt : r < a := lt_of_le_of_ne hra hrne + have hεγ : ε ≤ γ := by + have := Ordinal.log_mono_right Ordinal.omega0 hra + simpa only [hlogr, hloga] using this + rcases hεγ.eq_or_lt with rfl | hεγlt + · obtain ⟨j, rfl⟩ := Ordinal.lt_omega0.mp helt + have hjlt : j < k + 1 := by + by_contra h + have hle : k + 1 ≤ j := le_of_not_gt h + have hmul : Ordinal.omega0 ^ ε * ((k + 1 : ℕ) : Ordinal) ≤ + Ordinal.omega0 ^ ε * (j : Ordinal) := + mul_le_mul_right (by exact_mod_cast hle) _ + have hmulLt : Ordinal.omega0 ^ ε * (j : Ordinal) < + Ordinal.omega0 ^ ε * ((k + 1 : ℕ) : Ordinal) := by + rw [← hreq, ← haeq] + exact hralt + exact (not_le_of_gt hmulLt) hmul + dsimp [b] + rw [hreq] + exact mul_le_mul_right (by exact_mod_cast (Nat.le_of_lt_succ hjlt)) _ + · have hr0 : r ≠ 0 := by + intro hzero + rw [hzero, Ordinal.CNF.zero_right] at hr + simp at hr + have hrpow : r < Ordinal.omega0 ^ γ := + (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 hr0).2 (by + simpa only [hlogr] using hεγlt) + exact hrpow.le.trans (by + dsimp [b] + exact Ordinal.le_mul_left _ (by exact_mod_cast hkpos)) + have hab : a ≤ b := hlub.2 hbUpper + have hba : b < a := by + dsimp [b] + rw [haeq] + exact mul_lt_mul_of_pos_left (by exact_mod_cast (Nat.lt_succ_self k)) + (Ordinal.opow_pos γ Ordinal.omega0_pos) + exact (not_le_of_gt hba) hab + +/-- Identifies an equal-length CNF extension as deletion of the last source +term; used to analyze stabilization in chains of extensions. -/ +theorem CNFListLT.eq_dropLast_of_length_eq + {l m : List (Ordinal.{u} × Ordinal.{u})} + (h : CNFListLT l m) (hlen : m.length = l.length) : + ∃ x y, l = l.dropLast ++ [x] ∧ m = l.dropLast ++ [y] ∧ + CNFStep l.dropLast x y := by + rcases h with ⟨pre, tail, x, y, hl, hm, hstep⟩ + have htail : tail = [] := by + have hlength := congrArg List.length hl + rw [hm] at hlen + simp only [List.length_append, List.length_cons, List.length_nil] at hlength hlen + have : tail.length = 0 := by omega + simpa using this + subst tail + have hdrop : l.dropLast = pre := by simp [hl] + exact ⟨x, y, by simp [hl], by simpa [hdrop] using hm, + by simpa [hdrop] using hstep⟩ + +/-- Proves that the ordinary supremum of a nonempty extension chain remains +above every member in `cnfExtensionLE`; used by `ordinalProjection_chain_iSup`. -/ +theorem cnfExtensionLE_chain_lub + (ξ : Ordinal.{u}) (Z : Set (GaoIndex ξ)) (α : GaoIndex ξ) + (hchain : ∀ ⦃ζ⦄, ζ ∈ Z → ∀ ⦃ζ'⦄, ζ' ∈ Z → + cnfExtensionLE ζ.1 ζ'.1 ∨ cnfExtensionLE ζ'.1 ζ.1) + (hsup : IsLUB ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) α.1) : + ∀ ζ ∈ Z, cnfExtensionLE ζ.1 α.1 := by + classical + intro ζ hζZ + by_cases hαZ : α ∈ Z + · rcases hchain hζZ hαZ with hζα | hαζ + · exact hζα + · exact Or.inl (le_antisymm + (hsup.1 ⟨ζ, hζZ, rfl⟩) + (cnfExtensionLE_partialOrder_and_subrelation.2 hαζ)) + have hζαle : ζ.1 ≤ α.1 := hsup.1 ⟨ζ, hζZ, rfl⟩ + have hζα : ζ.1 < α.1 := hζαle.lt_of_ne fun h ↦ by + have hsub : ζ = α := Subtype.ext h + exact hαZ (hsub ▸ hζZ) + let U : GaoIndex ξ → Prop := fun η ↦ η ∈ Z ∧ ζ.1 < η.1 + have hU : ∃ η, U η := by + by_contra h + have hαζle : α.1 ≤ ζ.1 := hsup.2 (by + rintro _ ⟨η, hηZ, rfl⟩ + exact le_of_not_gt fun hζη ↦ h ⟨η, hηZ, hζη⟩) + exact (not_le_of_gt hζα) hαζle + obtain ⟨η₀, hη₀U, hη₀min⟩ := + exists_minimalFor_of_wellFoundedLT U + (fun η : GaoIndex ξ ↦ (Ordinal.CNF Ordinal.omega0 η.1).length) hU + have hζη₀ : cnfExtensionLT ζ.1 η₀.1 := by + rcases hchain hζZ hη₀U.1 with h | h + · rcases h with heq | hlt + · exact (hη₀U.2.ne' heq.symm).elim + · exact hlt + · exact (not_le_of_gt hη₀U.2 + (cnfExtensionLE_partialOrder_and_subrelation.2 h)).elim + let V : Set (GaoIndex ξ) := {η | η ∈ Z ∧ η₀.1 ≤ η.1} + have hη₀V : η₀ ∈ V := ⟨hη₀U.1, le_rfl⟩ + have hrelV : ∀ η ∈ V, cnfExtensionLE η₀.1 η.1 := by + intro η hηV + rcases hchain hη₀U.1 hηV.1 with h | h + · exact h + · have hOrd := cnfExtensionLE_partialOrder_and_subrelation.2 h + have heq : η₀.1 = η.1 := le_antisymm hηV.2 hOrd + exact Or.inl heq + have hlenV : ∀ η ∈ V, + (Ordinal.CNF Ordinal.omega0 η.1).length = + (Ordinal.CNF Ordinal.omega0 η₀.1).length := by + intro η hηV + rcases hrelV η hηV with heq | hlt + · rw [heq] + · have hle : (Ordinal.CNF Ordinal.omega0 η.1).length ≤ + (Ordinal.CNF Ordinal.omega0 η₀.1).length := by + rcases cnfExtensionLT_iff_CNFListLT.mp hlt with + ⟨pre, tail, x, y, hη₀cnf, hηcnf, _⟩ + rw [hη₀cnf, hηcnf] + simp only [List.length_append, List.length_cons, List.length_nil] + omega + have hηU : U η := ⟨hηV.1, hη₀U.2.trans_le hηV.2⟩ + exact le_antisymm hle (hη₀min hηU hle) + let pre := (Ordinal.CNF Ordinal.omega0 η₀.1).dropLast + have hη₀ne : Ordinal.CNF Ordinal.omega0 η₀.1 ≠ [] := by + have hη₀pos : 0 < η₀.1 := (zero_le : (0 : Ordinal) ≤ ζ.1).trans_lt hη₀U.2 + intro h + have := Ordinal.CNF.foldr Ordinal.omega0 η₀.1 + rw [h] at this + exact hη₀pos.ne' this.symm + have hcnfV : ∀ η ∈ V, ∃ γ d, + Ordinal.CNF Ordinal.omega0 η.1 = pre ++ [(γ, d)] := by + intro η hηV + rcases hrelV η hηV with heq | hlt + · have hsub : η₀ = η := Subtype.ext heq + subst η + let p := (Ordinal.CNF Ordinal.omega0 η₀.1).getLast hη₀ne + refine ⟨p.1, p.2, ?_⟩ + simpa only [pre, p] using (List.dropLast_append_getLast hη₀ne).symm + · obtain ⟨x, y, _, hηcnf, _⟩ := + CNFListLT.eq_dropLast_of_length_eq + (cnfExtensionLT_iff_CNFListLT.mp hlt) (hlenV η hηV) + obtain ⟨γ, d⟩ := y + exact ⟨γ, d, hηcnf⟩ + let ρ : Ordinal.{u} := cnfValue pre + have residual_of_common : ∀ (η : GaoIndex ξ) (γ d : Ordinal.{u}), + Ordinal.CNF Ordinal.omega0 η.1 = pre ++ [(γ, d)] → + Ordinal.CNF Ordinal.omega0 (η.1 - ρ) = [(γ, d)] ∧ + ρ + (η.1 - ρ) = η.1 := by + intro η γ d hηcnf + have hηeq : ρ + cnfValue [(γ, d)] = η.1 := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 η.1] + change ρ + cnfValue [(γ, d)] = cnfValue (Ordinal.CNF Ordinal.omega0 η.1) + rw [hηcnf, cnfValue_append] + have hρle : ρ ≤ η.1 := hηeq ▸ le_self_add + have hsub : η.1 - ρ = cnfValue [(γ, d)] := + Ordinal.sub_eq_of_add_eq hηeq + constructor + · rw [hsub] + apply CNF_cnfValue + · simp + · intro p hp + have hpη : p ∈ Ordinal.CNF Ordinal.omega0 η.1 := by + rw [hηcnf] + exact List.mem_append_right _ hp + exact Ordinal.CNF.snd_pos hpη + · intro p hp + have hpη : p ∈ Ordinal.CNF Ordinal.omega0 η.1 := by + rw [hηcnf] + exact List.mem_append_right _ hp + exact Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 hpη + · exact Ordinal.add_sub_cancel_of_le hρle + let Q : Set (Ordinal.{u}) := + (fun η : GaoIndex ξ ↦ η.1 - ρ) '' V + have hQne : Q.Nonempty := ⟨η₀.1 - ρ, ⟨η₀, hη₀V, rfl⟩⟩ + have hsingleQ : ∀ q ∈ Q, ∃ γ d, + Ordinal.CNF Ordinal.omega0 q = [(γ, d)] := by + rintro q ⟨η, hηV, rfl⟩ + obtain ⟨γ, d, hηcnf⟩ := hcnfV η hηV + exact ⟨γ, d, (residual_of_common η γ d hηcnf).1⟩ + obtain ⟨β, c, hη₀cnf⟩ := hcnfV η₀ hη₀V + have hq₀cnf : Ordinal.CNF Ordinal.omega0 (η₀.1 - ρ) = [(β, c)] := + (residual_of_common η₀ β c hη₀cnf).1 + have hρaddη₀ : ρ + (η₀.1 - ρ) = η₀.1 := + (residual_of_common η₀ β c hη₀cnf).2 + have hρleη₀ : ρ ≤ η₀.1 := hρaddη₀ ▸ le_self_add + have hη₀αle : η₀.1 ≤ α.1 := hsup.1 ⟨η₀, hη₀U.1, rfl⟩ + have hρleα : ρ ≤ α.1 := hρleη₀.trans hη₀αle + let a : Ordinal.{u} := α.1 - ρ + have hρadda : ρ + a = α.1 := Ordinal.add_sub_cancel_of_le hρleα + have hlubQ : IsLUB Q a := by + constructor + · rintro q ⟨η, hηV, rfl⟩ + rw [Ordinal.sub_le] + rw [hρadda] + exact hsup.1 ⟨η, hηV.1, rfl⟩ + · intro b hb + rw [Ordinal.sub_le] + apply hsup.2 + rintro _ ⟨η, hηZ, rfl⟩ + rcases hchain hηZ hη₀U.1 with hηη₀ | hη₀η + · have hηleη₀ := cnfExtensionLE_partialOrder_and_subrelation.2 hηη₀ + calc + η.1 ≤ η₀.1 := hηleη₀ + _ = ρ + (η₀.1 - ρ) := hρaddη₀.symm + _ ≤ ρ + b := add_le_add_right (hb ⟨η₀, hη₀V, rfl⟩) ρ + · have hη₀leη := cnfExtensionLE_partialOrder_and_subrelation.2 hη₀η + have hηV : η ∈ V := ⟨hηZ, hη₀leη⟩ + obtain ⟨γ', d', hηcnf⟩ := hcnfV η hηV + have hρaddη := (residual_of_common η γ' d' hηcnf).2 + calc + η.1 = ρ + (η.1 - ρ) := hρaddη.symm + _ ≤ ρ + b := add_le_add_right (hb ⟨η, hηV, rfl⟩) ρ + have haQ : a ∉ Q := by + rintro ⟨η, hηV, hηsub⟩ + obtain ⟨γ', d', hηcnf⟩ := hcnfV η hηV + have hρaddη := (residual_of_common η γ' d' hηcnf).2 + change η.1 - ρ = a at hηsub + have hηα : η.1 = α.1 := by + calc + η.1 = ρ + (η.1 - ρ) := hρaddη.symm + _ = ρ + a := by rw [hηsub] + _ = α.1 := hρadda + have hsub : η = α := Subtype.ext hηα + exact hαZ (hsub ▸ hηV.1) + obtain ⟨γ, d, hacnf⟩ := + cnf_eq_singleton_of_isLUB Q a hQne hsingleQ hlubQ + have hβγ : β < γ := cnf_singleton_exponent_lt_of_isLUB_not_mem + Q a hsingleQ hlubQ haQ ⟨η₀, hη₀V, rfl⟩ hq₀cnf hacnf + obtain ⟨hq₀eq, _, _, hlogq₀⟩ := cnf_singleton_spec hq₀cnf + obtain ⟨haeq, hdpos, _, _⟩ := cnf_singleton_spec hacnf + have hq₀a : (η₀.1 - ρ) + a = a := by + apply Ordinal.add_of_omega0_opow_le + · apply (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 ?_).2 + · simpa only [hlogq₀] using hβγ + · rw [hq₀eq] + exact mul_ne_zero (Ordinal.opow_ne_zero β Ordinal.omega0_ne_zero) + (ne_of_gt (cnf_singleton_spec hq₀cnf).2.1) + · rw [haeq] + exact Ordinal.le_mul_left _ hdpos + have hη₀adda : η₀.1 + a = α.1 := by + calc + η₀.1 + a = (ρ + (η₀.1 - ρ)) + a := by rw [hρaddη₀] + _ = ρ + ((η₀.1 - ρ) + a) := add_assoc _ _ _ + _ = ρ + a := by rw [hq₀a] + _ = α.1 := hρadda + have hη₀α : cnfExtensionLT η₀.1 α.1 := by + rw [← hη₀adda] + exact cnfExtensionLT_add_singleton_of_last hη₀cnf hacnf hβγ.le + exact cnfExtensionLE_partialOrder_and_subrelation.1.trans + ζ.1 η₀.1 α.1 (Or.inr hζη₀) (Or.inr hη₀α) + +/-- Controls the least CNF exponent of a chain supremum; used to keep the +supremum projection inside the required Gao stage. -/ +theorem leastCNFExponent_chain_lub_le + (ξ γ : Ordinal.{u}) (Z : Set (GaoIndex ξ)) (α : GaoIndex ξ) + (hne : Z.Nonempty) + (hchain : ∀ ⦃ζ⦄, ζ ∈ Z → ∀ ⦃ζ'⦄, ζ' ∈ Z → + cnfExtensionLE ζ.1 ζ'.1 ∨ cnfExtensionLE ζ'.1 ζ.1) + (hsup : IsLUB ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) α.1) + (hleast : ∀ ζ ∈ Z, leastCNFExponent ζ.1 < γ) : + leastCNFExponent α.1 ≤ γ := by + classical + by_cases hαZ : α ∈ Z + · exact (hleast α hαZ).le + obtain ⟨ζ, hζZ⟩ := hne + have hζα : ζ.1 < α.1 := (hsup.1 ⟨ζ, hζZ, rfl⟩).lt_of_ne fun h ↦ by + have hsub : ζ = α := Subtype.ext h + exact hαZ (hsub ▸ hζZ) + let U : GaoIndex ξ → Prop := fun η ↦ η ∈ Z ∧ ζ.1 < η.1 + have hU : ∃ η, U η := by + by_contra h + have hαζ : α.1 ≤ ζ.1 := hsup.2 (by + rintro _ ⟨η, hηZ, rfl⟩ + exact le_of_not_gt fun hζη ↦ h ⟨η, hηZ, hζη⟩) + exact (not_le_of_gt hζα) hαζ + obtain ⟨η₀, hη₀U, hη₀min⟩ := exists_minimalFor_of_wellFoundedLT U + (fun η : GaoIndex ξ ↦ (Ordinal.CNF Ordinal.omega0 η.1).length) hU + have hη₀Z : η₀ ∈ Z := hη₀U.1 + let V : Set (GaoIndex ξ) := {η | η ∈ Z ∧ η₀.1 ≤ η.1} + have hη₀V : η₀ ∈ V := ⟨hη₀Z, le_rfl⟩ + have hrelV : ∀ η ∈ V, cnfExtensionLE η₀.1 η.1 := by + intro η hηV + rcases hchain hη₀Z hηV.1 with h | h + · exact h + · exact Or.inl (le_antisymm hηV.2 + (cnfExtensionLE_partialOrder_and_subrelation.2 h)) + have hlenV : ∀ η ∈ V, + (Ordinal.CNF Ordinal.omega0 η.1).length = + (Ordinal.CNF Ordinal.omega0 η₀.1).length := by + intro η hηV + rcases hrelV η hηV with heq | hlt + · rw [heq] + · have hle : (Ordinal.CNF Ordinal.omega0 η.1).length ≤ + (Ordinal.CNF Ordinal.omega0 η₀.1).length := by + rcases cnfExtensionLT_iff_CNFListLT.mp hlt with + ⟨pre, tail, x, y, hη₀cnf, hηcnf, _⟩ + rw [hη₀cnf, hηcnf] + simp only [List.length_append, List.length_cons, List.length_nil] + omega + exact le_antisymm hle + (hη₀min ⟨hηV.1, hη₀U.2.trans_le hηV.2⟩ hle) + let pre := (Ordinal.CNF Ordinal.omega0 η₀.1).dropLast + have hη₀ne : Ordinal.CNF Ordinal.omega0 η₀.1 ≠ [] := by + have hη₀pos : 0 < η₀.1 := + (zero_le : (0 : Ordinal) ≤ ζ.1).trans_lt hη₀U.2 + intro h + have hfold := Ordinal.CNF.foldr Ordinal.omega0 η₀.1 + rw [h] at hfold + exact hη₀pos.ne' hfold.symm + have hcnfV : ∀ η ∈ V, ∃ δ d, + Ordinal.CNF Ordinal.omega0 η.1 = pre ++ [(δ, d)] := by + intro η hηV + rcases hrelV η hηV with heq | hlt + · have hsub : η₀ = η := Subtype.ext heq + subst η + let p := (Ordinal.CNF Ordinal.omega0 η₀.1).getLast hη₀ne + refine ⟨p.1, p.2, ?_⟩ + simpa only [pre, p] using (List.dropLast_append_getLast hη₀ne).symm + · obtain ⟨x, y, _, hηcnf, _⟩ := + CNFListLT.eq_dropLast_of_length_eq + (cnfExtensionLT_iff_CNFListLT.mp hlt) (hlenV η hηV) + exact ⟨y.1, y.2, hηcnf⟩ + let ρ : Ordinal.{u} := cnfValue pre + have residual_of_common : ∀ (η : GaoIndex ξ) (δ d : Ordinal.{u}), + Ordinal.CNF Ordinal.omega0 η.1 = pre ++ [(δ, d)] → + Ordinal.CNF Ordinal.omega0 (η.1 - ρ) = [(δ, d)] ∧ + ρ + (η.1 - ρ) = η.1 := by + intro η δ d hηcnf + have hηeq : ρ + cnfValue [(δ, d)] = η.1 := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 η.1] + change ρ + cnfValue [(δ, d)] = cnfValue (Ordinal.CNF Ordinal.omega0 η.1) + rw [hηcnf, cnfValue_append] + have hρle : ρ ≤ η.1 := hηeq ▸ le_self_add + have hsub : η.1 - ρ = cnfValue [(δ, d)] := + Ordinal.sub_eq_of_add_eq hηeq + constructor + · rw [hsub] + apply CNF_cnfValue + · simp + · intro p hp + exact Ordinal.CNF.snd_pos (by + rw [hηcnf] + exact List.mem_append_right _ hp) + · intro p hp + exact Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 (by + rw [hηcnf] + exact List.mem_append_right _ hp) + · exact Ordinal.add_sub_cancel_of_le hρle + let Q : Set (Ordinal.{u}) := (fun η : GaoIndex ξ ↦ η.1 - ρ) '' V + have hQne : Q.Nonempty := ⟨η₀.1 - ρ, ⟨η₀, hη₀V, rfl⟩⟩ + have hsingleQ : ∀ q ∈ Q, ∃ δ d, + Ordinal.CNF Ordinal.omega0 q = [(δ, d)] ∧ δ < γ := by + rintro q ⟨η, hηV, rfl⟩ + obtain ⟨δ, d, hηcnf⟩ := hcnfV η hηV + refine ⟨δ, d, (residual_of_common η δ d hηcnf).1, ?_⟩ + have := hleast η hηV.1 + simpa [leastCNFExponent, hηcnf] using this + obtain ⟨δ₀, d₀, hη₀cnf⟩ := hcnfV η₀ hη₀V + have hρaddη₀ := (residual_of_common η₀ δ₀ d₀ hη₀cnf).2 + have hρleη₀ : ρ ≤ η₀.1 := hρaddη₀ ▸ le_self_add + have hρleα : ρ ≤ α.1 := hρleη₀.trans (hsup.1 ⟨η₀, hη₀Z, rfl⟩) + let a : Ordinal.{u} := α.1 - ρ + have hρadda : ρ + a = α.1 := Ordinal.add_sub_cancel_of_le hρleα + have hlubQ : IsLUB Q a := by + constructor + · rintro _ ⟨η, hηV, rfl⟩ + rw [Ordinal.sub_le, hρadda] + exact hsup.1 ⟨η, hηV.1, rfl⟩ + · intro b hb + rw [Ordinal.sub_le] + apply hsup.2 + rintro _ ⟨η, hηZ, rfl⟩ + rcases hchain hηZ hη₀Z with hηη₀ | hη₀η + · calc + η.1 ≤ η₀.1 := cnfExtensionLE_partialOrder_and_subrelation.2 hηη₀ + _ = ρ + (η₀.1 - ρ) := hρaddη₀.symm + _ ≤ ρ + b := add_le_add_right (hb ⟨η₀, hη₀V, rfl⟩) ρ + · have hηV : η ∈ V := ⟨hηZ, + cnfExtensionLE_partialOrder_and_subrelation.2 hη₀η⟩ + obtain ⟨δ, d, hηcnf⟩ := hcnfV η hηV + have hρaddη := (residual_of_common η δ d hηcnf).2 + calc + η.1 = ρ + (η.1 - ρ) := hρaddη.symm + _ ≤ ρ + b := add_le_add_right (hb ⟨η, hηV, rfl⟩) ρ + obtain ⟨Γ, D, hacnf⟩ := cnf_eq_singleton_of_isLUB Q a hQne + (fun q hq ↦ let ⟨δ, d, h, _⟩ := hsingleQ q hq; ⟨δ, d, h⟩) hlubQ + have hpowUpper : Ordinal.omega0 ^ γ ∈ upperBounds Q := by + intro q hq + obtain ⟨δ, d, hqcnf, hδγ⟩ := hsingleQ q hq + obtain ⟨_, _, _, hlogq⟩ := cnf_singleton_spec hqcnf + exact ((Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 (by + obtain ⟨hqeq, hdpos, _, _⟩ := cnf_singleton_spec hqcnf + rw [hqeq] + exact mul_ne_zero (Ordinal.opow_ne_zero δ Ordinal.omega0_ne_zero) + hdpos.ne')).2 (by simpa only [hlogq] using hδγ)).le + have haPow : a ≤ Ordinal.omega0 ^ γ := hlubQ.2 hpowUpper + obtain ⟨haeq, hDpos, _, _⟩ := cnf_singleton_spec hacnf + have hΓγ : Γ ≤ γ := by + rw [haeq] at haPow + have hΓa : Ordinal.omega0 ^ Γ ≤ Ordinal.omega0 ^ Γ * D := + Ordinal.le_mul_left _ hDpos + exact (Ordinal.opow_le_opow_iff_right Ordinal.one_lt_omega0).mp + (hΓa.trans haPow) + have hsortedPre : (pre.map Prod.fst).Pairwise (fun x y ↦ y < x) := by + have h := (Ordinal.CNF.sortedGT Ordinal.omega0 η₀.1).pairwise + rw [hη₀cnf, List.map_append, List.pairwise_append] at h + exact h.1 + have hposPre : ∀ p ∈ pre, 0 < p.2 := by + intro p hp + exact Ordinal.CNF.snd_pos (by rw [hη₀cnf]; exact List.mem_append_left _ hp) + have hltPre : ∀ p ∈ pre, p.2 < Ordinal.omega0 := by + intro p hp + exact Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 (by + rw [hη₀cnf] + exact List.mem_append_left _ hp) + have hαcnf : Ordinal.CNF Ordinal.omega0 α.1 = cnfAddMonomial pre Γ D := by + rw [← hρadda, haeq] + exact CNF_cnfValue_add_monomial pre hsortedPre hposPre hltPre Γ D hDpos + (cnf_singleton_spec hacnf).2.2.1 + rw [leastCNFExponent, hαcnf, cnfAddMonomial_lastExponent] + exact hΓγ + +/-- Claim 2 in the proof of Theorem `thm:solid-iterations`. -/ +theorem ordinalProjection_chain_iSup + (ξ : Ordinal.{u}) (Z : Set (GaoIndex ξ)) (α : GaoIndex ξ) + (hne : Z.Nonempty) + (hchain : ∀ ⦃ζ⦄, ζ ∈ Z → ∀ ⦃ζ'⦄, ζ' ∈ Z → + cnfExtensionLE ζ.1 ζ'.1 ∨ cnfExtensionLE ζ'.1 ζ.1) + (hsup : IsLUB ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) α.1) : + IsLUB (ordinalProjection ξ '' Z) (ordinalProjection ξ α) := by + classical + constructor + · rintro _ ⟨ζ, hζ, rfl⟩ + exact (ordinalProjection_le_iff ξ ζ α).2 + (cnfExtensionLE_chain_lub ξ Z α hchain hsup ζ hζ) + · intro f hf + by_cases hαZ : α ∈ Z + · exact hf ⟨α, hαZ, rfl⟩ + · intro x + by_cases hx : x.1 α = true + · change (if x.1 α = true then 1 else 0) ≤ f x + rw [ite_eq_left hx] + by_contra hle + have hfx : f x < 1 := lt_of_not_ge hle + obtain ⟨F, hF⟩ := continuousMap_exists_finite_coordinates f x + isOpen_Iio hfx + have hαpos : 0 < α.1 := by + rw [pos_iff_ne_zero] + intro hαzero + obtain ⟨ζ, hζ⟩ := hne + have hζα : ζ.1 ≤ α.1 := hsup.1 ⟨ζ, hζ, rfl⟩ + have hζzero : ζ.1 = 0 := + le_antisymm (hαzero ▸ hζα) (zero_le : (0 : Ordinal) ≤ ζ.1) + apply hαZ + have hζeq : ζ = α := Subtype.ext (hζzero.trans hαzero.symm) + exact hζeq ▸ hζ + let Fα := F.filter fun i ↦ i.1 < α.1 + let δ : Ordinal.{u} := Fα.sup fun i ↦ i.1 + have hδα : δ < α.1 := by + apply (Finset.sup_lt_iff hαpos).2 + intro i hi + exact (Finset.mem_filter.mp hi).2 + have hex : ∃ ζ ∈ Z, δ < ζ.1 := by + by_contra h + push Not at h + have hαδ : α.1 ≤ δ := hsup.2 (by + rintro _ ⟨ζ, hζ, rfl⟩ + exact h ζ hζ) + exact (not_le_of_gt hδα) hαδ + obtain ⟨ζ₀, hζ₀Z, hδζ₀⟩ := hex + let y : GaoIndex ξ → Bool := fun a ↦ + if cnfExtensionLE ζ₀.1 a.1 then true else x.1 a + have hy_mono : ∀ a b : GaoIndex ξ, + cnfExtensionLT a.1 b.1 → y a ≤ y b := by + intro a b hab + dsimp [y] + by_cases ha : cnfExtensionLE ζ₀.1 a.1 + · have hb : cnfExtensionLE ζ₀.1 b.1 := + cnfExtensionLE_partialOrder_and_subrelation.1.trans + ζ₀.1 a.1 b.1 ha (Or.inr hab) + rw [ite_eq_left ha, ite_eq_left hb] + · rw [ite_eq_right ha] + by_cases hb : cnfExtensionLE ζ₀.1 b.1 + · rw [ite_eq_left hb] + exact Bool.le_true _ + · rw [ite_eq_right hb] + exact x.2 a b hab + have hζ₀α : cnfExtensionLT ζ₀.1 α.1 := by + rcases cnfExtensionLE_chain_lub ξ Z α hchain hsup ζ₀ hζ₀Z with + heq | hlt + · have hsubeq : ζ₀ = α := Subtype.ext heq + exact (hαZ (hsubeq ▸ hζ₀Z)).elim + · exact hlt + have hζ₀αOrd : ζ₀.1 < α.1 := + CNFListLT.ordinal_lt (cnfExtensionLT_iff_CNFListLT.mp hζ₀α) + let yK : GaoCompactSpace ξ := ⟨y, hy_mono⟩ + have hyF : ∀ i ∈ F, yK.1 i = x.1 i := by + intro i hi + dsimp [yK, y] + by_cases hζ₀i : cnfExtensionLE ζ₀.1 i.1 + · rw [ite_eq_left hζ₀i] + have hζ₀iOrd : ζ₀.1 ≤ i.1 := + cnfExtensionLE_partialOrder_and_subrelation.2 hζ₀i + by_cases hiα : i.1 < α.1 + · have hiFα : i ∈ Fα := Finset.mem_filter.mpr ⟨hi, hiα⟩ + have hiδ : i.1 ≤ δ := Finset.le_sup (f := fun j ↦ j.1) hiFα + exact (not_lt_of_ge hiδ (hδζ₀.trans_le hζ₀iOrd)).elim + · have hαi : α.1 ≤ i.1 := le_of_not_gt hiα + rcases hαi.eq_or_lt with hαeqi | hαi + · have hsubeq : α = i := Subtype.ext hαeqi + subst i + exact hx.symm + · have hζ₀iLT : cnfExtensionLT ζ₀.1 i.1 := by + rcases hζ₀i with hζ₀eqi | hζ₀i + · exact (not_lt_of_ge hαi.le (hζ₀eqi ▸ hζ₀αOrd)).elim + · exact hζ₀i + have hαiLT : cnfExtensionLT α.1 i.1 := + (cnfExtensionLT_linear_above ζ₀.1 hζ₀α hζ₀iLT).mpr hαi + exact (Bool.le_iff_imp.mp (x.2 α i hαiLT) hx).symm + · rw [ite_eq_right hζ₀i] + have hfy : f yK < 1 := hF yK hyF + have hupper := hf ⟨ζ₀, hζ₀Z, rfl⟩ yK + have hyζ₀ : yK.1 ζ₀ = true := by + dsimp [yK, y] + rw [ite_eq_left (show cnfExtensionLE ζ₀.1 ζ₀.1 from Or.inl rfl)] + change (if yK.1 ζ₀ = true then 1 else 0) ≤ f yK at hupper + rw [ite_eq_left hyζ₀] at hupper + exact (not_lt_of_ge hupper hfy).elim + · have hnonneg : 0 ≤ f x := by + obtain ⟨ζ, hζ⟩ := hne + have hproj : 0 ≤ ordinalProjection ξ ζ x := by + change 0 ≤ if x.1 ζ = true then 1 else 0 + split_ifs <;> norm_num + exact hproj.trans (hf ⟨ζ, hζ, rfl⟩ x) + simp only [ordinalProjection, hx] + exact hnonneg + +end OrdinalConstruction + +end OrderClosures diff --git a/LeanPool/OrderClosures/GaoLeungProblem/StageFormula.lean b/LeanPool/OrderClosures/GaoLeungProblem/StageFormula.lean new file mode 100644 index 0000000000..a848f28fe2 --- /dev/null +++ b/LeanPool/OrderClosures/GaoLeungProblem/StageFormula.lean @@ -0,0 +1,715 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.GaoLeungProblem.OrdinalSpace + + +/-! +# Adherence formulas for Gao stages +-/ + +@[expose] public section + +namespace OrderClosures + +open Set + +universe u v + +section OrdinalConstruction + +/-- Stage indices whose coordinate projections dominate a given function; +used to select finite minimal dominators. -/ +def gaoDominators (ξ γ : Ordinal.{u}) + (b : C(GaoCompactSpace ξ, ℝ)) : Set (GaoIndex ξ) := + {ζ | ζ ∈ GaoStageIndices ξ γ ∧ b ≤ ordinalProjection ξ ζ} + +/-- Minimal elements of the dominator set in the CNF extension order; used to +reduce a positive directed family to finitely many coordinates. -/ +def gaoMinimalDominators (ξ γ : Ordinal.{u}) + (b : C(GaoCompactSpace ξ, ℝ)) : Set (GaoIndex ξ) := + {μ | μ ∈ gaoDominators ξ γ b ∧ + ∀ η ∈ gaoDominators ξ γ b, cnfExtensionLE η.1 μ.1 → η = μ} + +/-- Extracts a coordinate projection dominating a positive Gao-stage element; +this starts the finite-minimal-dominator reduction. -/ +theorem gaoDominators_nonempty + (ξ γ : Ordinal.{u}) {b : C(GaoCompactSpace ξ, ℝ)} + (hb0 : 0 ≤ b) (hb : b ∈ GaoStageSet ξ γ) : + (gaoDominators ξ γ b).Nonempty := by + obtain ⟨ζ, hζ, hbζ⟩ := hb + refine ⟨ζ, hζ, ?_⟩ + simpa only [abs_of_nonneg hb0] using hbζ + +/-- Refines any dominator to a minimal one; used to replace arbitrary +dominating coordinates by a finite canonical family. -/ +theorem gaoDominator_above_minimal + (ξ γ : Ordinal.{u}) {b : C(GaoCompactSpace ξ, ℝ)} + {ζ : GaoIndex ξ} (hζ : ζ ∈ gaoDominators ξ γ b) : + ∃ μ ∈ gaoMinimalDominators ξ γ b, cnfExtensionLE μ.1 ζ.1 := by + classical + let P : GaoIndex ξ → Prop := fun η ↦ + η ∈ gaoDominators ξ γ b ∧ cnfExtensionLE η.1 ζ.1 + obtain ⟨μ, hμP, hμmin⟩ := exists_minimalFor_of_wellFoundedLT P + (fun η : GaoIndex ξ ↦ η.1) ⟨ζ, hζ, Or.inl rfl⟩ + refine ⟨μ, ⟨hμP.1, ?_⟩, hμP.2⟩ + intro η hη hημ + have hηP : P η := ⟨hη, + cnfExtensionLE_partialOrder_and_subrelation.1.trans + η.1 μ.1 ζ.1 hημ hμP.2⟩ + have hηleμ := cnfExtensionLE_partialOrder_and_subrelation.2 hημ + exact Subtype.ext (le_antisymm hηleμ (hμmin hηP hηleμ)) + +/-- Shows that distinct minimal dominators are CNF-incomparable; used with the +incomparable-projection infimum theorem. -/ +theorem gaoMinimalDominators_pairwise + (ξ γ : Ordinal.{u}) (b : C(GaoCompactSpace ξ, ℝ)) : + (gaoMinimalDominators ξ γ b).Pairwise + (fun μ ν ↦ ¬ cnfExtensionLE μ.1 ν.1) := by + intro μ hμ ν hν hne hμν + exact hne (hν.2 μ hμ.1 hμν) + +/-- Proves finiteness of the minimal dominator family; needed to combine it +with directedness of the positive approximating set. -/ +theorem gaoMinimalDominators_finite + (ξ γ : Ordinal.{u}) {b : C(GaoCompactSpace ξ, ℝ)} + (hb0 : 0 ≤ b) (hbne : b ≠ 0) : + (gaoMinimalDominators ξ γ b).Finite := by + classical + by_contra hinf + have hMInf : (gaoMinimalDominators ξ γ b).Infinite := hinf + have hglb := ordinalProjection_incomparable_iInf ξ + (gaoMinimalDominators ξ γ b) hMInf + (gaoMinimalDominators_pairwise ξ γ b) + have hbLower : b ∈ lowerBounds + (ordinalProjection ξ '' gaoMinimalDominators ξ γ b) := by + rintro _ ⟨μ, hμ, rfl⟩ + exact hμ.1.2 + have hb_le_zero : b ≤ 0 := hglb.2 hbLower + exact hbne (le_antisymm hb_le_zero hb0) + +/-- Produces one Gao-stage coordinate dominating an entire directed positive +family; this is the main input to the forward adherence inclusion. -/ +theorem directedPositive_gaoStage_dominated + (ξ γ : Ordinal.{u}) {z : C(GaoCompactSpace ξ, ℝ)} + (hz : z ∈ directedPositiveAdherence (GaoStageSet ξ γ)) : + ∃ α : GaoIndex ξ, α.1 ≤ Ordinal.omega0 ^ ξ ∧ + leastCNFExponent α.1 ≤ γ ∧ z ≤ ordinalProjection ξ α := by + classical + rcases hz with ⟨hz0, B, hBstage, hBne, hBdir, hBlub⟩ + by_cases hzero : z = 0 + · let α : GaoIndex ξ := ⟨0, by simp⟩ + refine ⟨α, by simp [α], by simp [α, leastCNFExponent], ?_⟩ + rw [hzero] + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + have hbne : ∃ b ∈ B, b ≠ 0 := by + by_contra h + have hzeroUpper : (0 : C(GaoCompactSpace ξ, ℝ)) ∈ upperBounds B := by + intro b hb + have hb0 := (hBstage hb).2 + have hbzero : b = 0 := by + by_contra hbne' + exact h ⟨b, hb, hbne'⟩ + rw [hbzero] + exact hzero (le_antisymm (hBlub.2 hzeroUpper) hz0) + obtain ⟨b₀, hb₀B, hb₀ne⟩ := hbne + have hb₀0 : 0 ≤ b₀ := (hBstage hb₀B).2 + let M := gaoMinimalDominators ξ γ b₀ + have hMfin : M.Finite := gaoMinimalDominators_finite ξ γ hb₀0 hb₀ne + have hMne : M.Nonempty := by + obtain ⟨ζ, hζ⟩ := gaoDominators_nonempty ξ γ hb₀0 (hBstage hb₀B).1 + obtain ⟨μ, hμ, _⟩ := gaoDominator_above_minimal ξ γ hζ + exact ⟨μ, hμ⟩ + let : Nonempty B := hBne.to_subtype + let : IsDirectedOrder B := hBdir.isDirectedOrder + let b₀B : B := ⟨b₀, hb₀B⟩ + let D : M → Set B := fun μ ↦ + {b | b₀ ≤ b.1 ∧ ∃ ζ ∈ gaoDominators ξ γ b.1, + cnfExtensionLE μ.1.1 ζ.1} + have hcover : ∀ b : B, b₀ ≤ b.1 → ∃ μ : M, b ∈ D μ := by + intro b hb₀b + have hb0 : 0 ≤ b.1 := (hBstage b.2).2 + obtain ⟨ζ, hζ⟩ := gaoDominators_nonempty ξ γ hb0 (hBstage b.2).1 + have hζ₀ : ζ ∈ gaoDominators ξ γ b₀ := ⟨hζ.1, hb₀b.trans hζ.2⟩ + obtain ⟨μ, hμ, hμζ⟩ := gaoDominator_above_minimal ξ γ hζ₀ + exact ⟨⟨μ, hμ⟩, hb₀b, ζ, hζ, hμζ⟩ + have hcofinal : ∃ μ : M, ∀ b : B, ∃ c ∈ D μ, b ≤ c := by + by_contra h + have hbad : ∀ μ : M, ∃ b : B, ∀ c ∈ D μ, ¬ b ≤ c := by + intro μ + have hμ : ¬ ∀ b : B, ∃ c ∈ D μ, b ≤ c := fun hμ ↦ h ⟨μ, hμ⟩ + push Not at hμ + exact hμ + choose w hw using hbad + let : Fintype M := hMfin.fintype + obtain ⟨d, hd⟩ := Finite.exists_le w + obtain ⟨e, hde, hb₀e⟩ := exists_ge_ge d b₀B + obtain ⟨μ, heD⟩ := hcover e hb₀e + exact (hw μ e heD) ((hd μ).trans hde) + obtain ⟨μ, hμcofinal⟩ := hcofinal + have hDne : (D μ).Nonempty := by + obtain ⟨c, hcD, _⟩ := hμcofinal b₀B + exact ⟨c, hcD⟩ + let ζfun : D μ → GaoIndex ξ := fun b ↦ Classical.choose b.2.2 + have hζfun : ∀ b : D μ, + ζfun b ∈ gaoDominators ξ γ b.1.1 ∧ + cnfExtensionLE μ.1.1 (ζfun b).1 := fun b ↦ + ⟨Classical.choose_spec b.2.2 |>.1, + Classical.choose_spec b.2.2 |>.2⟩ + let Z : Set (GaoIndex ξ) := Set.range ζfun + have hZne : Z.Nonempty := by + obtain ⟨b, hb⟩ := hDne + exact ⟨ζfun ⟨b, hb⟩, ⟨⟨b, hb⟩, rfl⟩⟩ + have hZchain : ∀ ⦃ζ⦄, ζ ∈ Z → ∀ ⦃ζ'⦄, ζ' ∈ Z → + cnfExtensionLE ζ.1 ζ'.1 ∨ cnfExtensionLE ζ'.1 ζ.1 := by + rintro _ ⟨b, rfl⟩ _ ⟨c, rfl⟩ + exact cnfExtensionLE_linear_above μ.1.1 (hζfun b).2 (hζfun c).2 + let a : Ordinal.{u} := sSup ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) + have hvalsne : ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z).Nonempty := hZne.image _ + have hvalsBdd : BddAbove ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) := by + refine ⟨Ordinal.omega0 ^ ξ, ?_⟩ + rintro _ ⟨_, ⟨b, rfl⟩, rfl⟩ + exact (hζfun b).1.1.1 + have haLUB : IsLUB ((fun ζ : GaoIndex ξ ↦ ζ.1) '' Z) a := + isLUB_csSup hvalsne hvalsBdd + have hale : a ≤ Ordinal.omega0 ^ ξ := by + apply haLUB.2 + rintro _ ⟨_, ⟨b, rfl⟩, rfl⟩ + exact (hζfun b).1.1.1 + let α : GaoIndex ξ := ⟨a, hale.trans le_self_add⟩ + have hprojLUB : IsLUB (ordinalProjection ξ '' Z) + (ordinalProjection ξ α) := + ordinalProjection_chain_iSup ξ Z α hZne hZchain haLUB + have hzα : z ≤ ordinalProjection ξ α := hBlub.2 (by + intro b hbB + obtain ⟨c, hcD, hbc⟩ := hμcofinal ⟨b, hbB⟩ + let cD : D μ := ⟨c, hcD⟩ + calc + b ≤ c.1 := hbc + _ ≤ ordinalProjection ξ (ζfun cD) := (hζfun cD).1.2 + _ ≤ ordinalProjection ξ α := hprojLUB.1 ⟨ζfun cD, ⟨cD, rfl⟩, rfl⟩) + have hleast : leastCNFExponent α.1 ≤ γ := by + apply leastCNFExponent_chain_lub_le ξ γ Z α hZne hZchain haLUB + rintro _ ⟨b, rfl⟩ + exact (hζfun b).1.1.2 + exact ⟨α, hale, hleast, hzα⟩ + +/-- Establishes the forward inclusion for one order-adherence step by using a +single coordinate dominator. -/ +theorem orderAdherence_gaoStage_subset + (ξ γ : Ordinal.{u}) : + orderAdherence (GaoStageSet ξ γ) ⊆ GaoStageSet ξ (γ + 1) := by + rw [orderAdherence_eq_solidOrderAdherence (isSolid_gaoStageSet ξ γ)] + rintro f ⟨z, hz, hfz⟩ + obtain ⟨α, hαbound, hαleast, hzα⟩ := + directedPositive_gaoStage_dominated ξ γ hz + refine ⟨α, ⟨hαbound, ?_⟩, hfz.trans ?_⟩ + · exact hαleast.trans_lt (lt_add_one γ) + · simpa only [abs_of_nonneg hz.1] using hzα + +/-- Singleton omega monomials with exponent below `γ`; used as the directed +approximating family for a limit-stage coordinate. -/ +def singletonCNFBelow (γ : Ordinal.{u}) : Set (Ordinal.{u}) := + {q | ∃ δ d, Ordinal.CNF Ordinal.omega0 q = [(δ, d)] ∧ + q < Ordinal.omega0 ^ γ} + +/-- Shows that singleton CNF monomials below `γ` have supremum `ω^γ`; used to +construct the reverse adherence approximation at limit exponents. -/ +theorem singletonCNFBelow_isLUB (γ : Ordinal.{u}) (hγ : γ ≠ 0) : + IsLUB (singletonCNFBelow γ) (Ordinal.omega0 ^ γ) := by + constructor + · rintro q ⟨δ, d, hq, hqpow⟩ + exact hqpow.le + · intro c hc + have hlim : Order.IsSuccLimit (Ordinal.omega0 ^ γ) := + Ordinal.isSuccLimit_opow_left Ordinal.isSuccLimit_omega0 hγ + apply hlim.isLUB_Iio.2 + intro r hr + by_cases hr0 : r = 0 + · subst r + exact zero_le + let δ := Ordinal.log Ordinal.omega0 r + let d := r / Ordinal.omega0 ^ δ + let q := Ordinal.omega0 ^ δ * (d + 1) + have hdpos : 0 < d := Ordinal.div_opow_log_pos Ordinal.omega0 hr0 + have hdlt : d < Ordinal.omega0 := + Ordinal.div_opow_log_lt r Ordinal.one_lt_omega0 + have hdsuccpos : 0 < d + 1 := hdpos.trans_le le_self_add + have hdsucclt : d + 1 < Ordinal.omega0 := by + obtain ⟨n, hn⟩ := Ordinal.lt_omega0.mp hdlt + rw [hn, ← Nat.cast_one, ← Nat.cast_add] + exact Ordinal.natCast_lt_omega0 (n + 1) + have hδγ : δ < γ := + (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 hr0).mp hr + have hqcnf : Ordinal.CNF Ordinal.omega0 q = [(δ, d + 1)] := by + dsimp [q] + simpa using Ordinal.CNF.opow_mul_add (b := Ordinal.omega0) + (e := δ) (x := d + 1) (y := 0) Ordinal.one_lt_omega0 + hdsuccpos.ne' hdsucclt (Ordinal.opow_pos δ Ordinal.omega0_pos) + have hqpow : q < Ordinal.omega0 ^ γ := by + dsimp [q] + simpa only [add_zero] using Ordinal.opow_mul_add_lt_opow hdsucclt + (Ordinal.opow_pos δ Ordinal.omega0_pos) hδγ + have hrq : r < q := by + rw [← Ordinal.div_add_mod r (Ordinal.omega0 ^ δ)] + dsimp [q, d] + exact Ordinal.opow_mul_add_lt_opow_mul + (Ordinal.mod_lt r (Ordinal.opow_ne_zero δ Ordinal.omega0_ne_zero)) + (lt_add_one (r / Ordinal.omega0 ^ δ)) + exact hrq.le.trans (hc ⟨δ, d + 1, hqcnf, hqpow⟩) + +/-- Turns a strict exponent inequality into a strict CNF extension of +singleton monomials; used by `gaoIndex_approximation`. -/ +theorem singletonCNF_step_of_lt + {q r δ d ε e : Ordinal.{u}} + (hq : Ordinal.CNF Ordinal.omega0 q = [(δ, d)]) + (hr : Ordinal.CNF Ordinal.omega0 r = [(ε, e)]) (hqr : q < r) : + (ε = δ ∧ d < e) ∨ δ < ε := by + obtain ⟨hqeq, _, _, hlogq⟩ := cnf_singleton_spec hq + obtain ⟨hreq, _, _, hlogr⟩ := cnf_singleton_spec hr + have hδε : δ ≤ ε := by + have := Ordinal.log_mono_right Ordinal.omega0 hqr.le + simpa only [hlogq, hlogr] using this + rcases hδε.eq_or_lt with hδε | hδε + · left + refine ⟨hδε.symm, ?_⟩ + rw [← hδε] at hreq + by_contra h + have hed : e ≤ d := le_of_not_gt h + have hmul : Ordinal.omega0 ^ δ * e ≤ Ordinal.omega0 ^ δ * d := + mul_le_mul_right hed _ + exact (not_le_of_gt (by rw [← hqeq, ← hreq]; exact hqr)) hmul + · exact Or.inr hδε + +/-- Appending a smaller singleton CNF term to a finite prefix computes its normal form. -/ +theorem cnfValue_add_singleton_below + (pre : List (Ordinal.{u} × Ordinal.{u})) (γ : Ordinal.{u}) (n : ℕ) + (hpreSorted : (pre.map Prod.fst).Pairwise (fun x y ↦ y < x)) + (hpreAbove : ∀ x ∈ pre, γ < x.1) + (hprePos : ∀ x ∈ pre, 0 < x.2) + (hpreLt : ∀ x ∈ pre, x.2 < Ordinal.omega0) + (q : Ordinal.{u}) (hq : q ∈ singletonCNFBelow γ) : + ∃ δ d, Ordinal.CNF Ordinal.omega0 q = [(δ, d)] ∧ δ < γ ∧ + Ordinal.CNF Ordinal.omega0 + (cnfValue pre + Ordinal.omega0 ^ γ * (n : Ordinal) + q) = + if n = 0 then pre ++ [(δ, d)] + else pre ++ (γ, (n : Ordinal)) :: [(δ, d)] := by + obtain ⟨δ, d, hqcnf, hqpow⟩ := hq + obtain ⟨hqeq, hdpos, hdlt, hlogq⟩ := cnf_singleton_spec hqcnf + have hδγraw : Ordinal.log Ordinal.omega0 q < γ := + (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 (by + rw [hqeq] + exact mul_ne_zero (Ordinal.opow_ne_zero δ Ordinal.omega0_ne_zero) + hdpos.ne')).mp hqpow + have hδγ : δ < γ := by simpa only [hlogq] using hδγraw + refine ⟨δ, d, hqcnf, hδγ, ?_⟩ + by_cases hn : n = 0 + · subst n + simp only [Nat.cast_zero, mul_zero, add_zero, ↓reduceIte] + rw [hqeq, CNF_cnfValue_add_monomial pre hpreSorted hprePos hpreLt + δ d hdpos hdlt, cnfAddMonomial_eq_append_of_lt_all pre δ d + (fun x hx ↦ hδγ.trans (hpreAbove x hx))] + · let l := pre ++ [(γ, (n : Ordinal))] + have hnpos : 0 < (n : Ordinal) := by exact_mod_cast (Nat.pos_of_ne_zero hn) + have hnlt : (n : Ordinal) < Ordinal.omega0 := Ordinal.natCast_lt_omega0 n + have hlsorted : (l.map Prod.fst).Pairwise (fun x y ↦ y < x) := by + dsimp [l] + rw [List.map_append, List.pairwise_append] + refine ⟨hpreSorted, by simp, ?_⟩ + intro a ha b hb + obtain ⟨x, hx, rfl⟩ := List.mem_map.mp ha + simp only [List.map_singleton, List.mem_singleton] at hb + subst b + exact hpreAbove x hx + have hlpos : ∀ x ∈ l, 0 < x.2 := by + intro x hx + rcases List.mem_append.mp hx with hx | hx + · exact hprePos x hx + · simp only [List.mem_singleton] at hx + subst x + exact hnpos + have hllt : ∀ x ∈ l, x.2 < Ordinal.omega0 := by + intro x hx + rcases List.mem_append.mp hx with hx | hx + · exact hpreLt x hx + · simp only [List.mem_singleton] at hx + subst x + exact hnlt + have hδl : ∀ x ∈ l, δ < x.1 := by + intro x hx + rcases List.mem_append.mp hx with hx | hx + · exact hδγ.trans (hpreAbove x hx) + · simp only [List.mem_singleton] at hx + subst x + exact hδγ + rw [ite_eq_right hn] + change Ordinal.CNF Ordinal.omega0 + ((cnfValue pre + Ordinal.omega0 ^ γ * (n : Ordinal)) + q) = + pre ++ (γ, (n : Ordinal)) :: [(δ, d)] + have hlvalue : cnfValue l = cnfValue pre + Ordinal.omega0 ^ γ * (n : Ordinal) := by + dsimp [l] + rw [cnfValue_append] + simp [cnfValue] + rw [← hlvalue, hqeq, + CNF_cnfValue_add_monomial l hlsorted hlpos hllt δ d hdpos hdlt, + cnfAddMonomial_eq_append_of_lt_all l δ d hδl] + simp [l, List.append_assoc] + +/-- Builds a directed family of earlier-stage indices whose projections order +converge to a prescribed next-stage projection. -/ +theorem gaoIndex_approximation + (ξ γ : Ordinal.{u}) (hγ : γ ≠ 0) (ζ : GaoIndex ξ) + (hζbound : ζ.1 ≤ Ordinal.omega0 ^ ξ) + (hζleast : leastCNFExponent ζ.1 = γ) : + ∃ Z : Set (GaoIndex ξ), Z.Nonempty ∧ + (∀ η ∈ Z, η ∈ GaoStageIndices ξ γ) ∧ + (∀ ⦃η⦄, η ∈ Z → ∀ ⦃η'⦄, η' ∈ Z → + cnfExtensionLE η.1 η'.1 ∨ cnfExtensionLE η'.1 η.1) ∧ + IsLUB ((fun η : GaoIndex ξ ↦ η.1) '' Z) ζ.1 := by + classical + have hζ0 : ζ.1 ≠ 0 := by + intro hzero + have : γ = 0 := by + rw [← hζleast, hzero] + simp [leastCNFExponent] + exact hγ this + let pre := (Ordinal.CNF Ordinal.omega0 ζ.1).dropLast + have hcnfne : Ordinal.CNF Ordinal.omega0 ζ.1 ≠ [] := by + intro h + have hfold := Ordinal.CNF.foldr Ordinal.omega0 ζ.1 + rw [h] at hfold + exact hζ0 hfold.symm + let p := (Ordinal.CNF Ordinal.omega0 ζ.1).getLast hcnfne + have hpcnf : Ordinal.CNF Ordinal.omega0 ζ.1 = pre ++ [p] := by + simpa only [pre, p] using (List.dropLast_append_getLast hcnfne).symm + have hpγ : p.1 = γ := by + have := hζleast + rw [leastCNFExponent, hpcnf] at this + have hlast : (pre ++ [p]).getLast? = some p := by simp + rw [hlast] at this + simpa using this + let c := p.2 + have hpeq : p = (γ, c) := Prod.ext hpγ rfl + have hζcnf : Ordinal.CNF Ordinal.omega0 ζ.1 = pre ++ [(γ, c)] := by + rw [hpcnf, hpeq] + have hcpos : 0 < c := by + apply Ordinal.CNF.snd_pos (x := (γ, c)) + rw [hζcnf] + simp + have hclt : c < Ordinal.omega0 := by + apply Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 (x := (γ, c)) + rw [hζcnf] + simp + obtain ⟨m, hm⟩ := Ordinal.lt_omega0.mp hclt + have hmpos : 0 < m := by rw [hm] at hcpos; exact_mod_cast hcpos + obtain ⟨n, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt hmpos) + let ρ : Ordinal.{u} := cnfValue pre + let base : Ordinal.{u} := ρ + Ordinal.omega0 ^ γ * (n : Ordinal) + have hζeq : ζ.1 = base + Ordinal.omega0 ^ γ := by + rw [← Ordinal.CNF.foldr Ordinal.omega0 ζ.1, hζcnf, hm] + change cnfValue (pre ++ [(γ, ((n + 1 : ℕ) : Ordinal))]) = + base + Ordinal.omega0 ^ γ + rw [cnfValue_append] + simp only [cnfValue, List.foldr_cons, List.foldr_nil, add_zero] + dsimp [base, ρ] + change cnfValue pre + Ordinal.omega0 ^ γ * ((n + 1 : ℕ) : Ordinal) = + cnfValue pre + Ordinal.omega0 ^ γ * (n : Ordinal) + Ordinal.omega0 ^ γ + simp only [Nat.cast_add, Nat.cast_one, mul_add, mul_one, add_assoc] + let Q := singletonCNFBelow γ + have hQne : Q.Nonempty := by + have hγpos : 0 < γ := (pos_iff_ne_zero).2 hγ + have honepow : (1 : Ordinal) < Ordinal.omega0 ^ γ := by + have hp : Ordinal.omega0 ^ (1 : Ordinal) ≤ Ordinal.omega0 ^ γ := + (Ordinal.opow_le_opow_iff_right Ordinal.one_lt_omega0).2 + (by simpa using (Order.succ_le_iff.2 hγpos : Order.succ 0 ≤ γ)) + exact Ordinal.one_lt_omega0.trans_le (by simpa using hp) + refine ⟨1, 0, 1, ?_, honepow⟩ + simpa using Ordinal.CNF.opow_mul_add (b := Ordinal.omega0) + (e := 0) (x := 1) (y := 0) Ordinal.one_lt_omega0 one_ne_zero + Ordinal.one_lt_omega0 (Ordinal.opow_pos 0 Ordinal.omega0_pos) + let ηval : Q → Ordinal.{u} := fun q ↦ base + q.1 + have hηlt : ∀ q : Q, ηval q < ζ.1 := by + intro q + obtain ⟨δ, d, hqcnf, hqpow⟩ := q.2 + rw [hζeq] + exact (add_lt_add_iff_left base).2 hqpow + let η : Q → GaoIndex ξ := fun q ↦ + ⟨ηval q, (hηlt q).le.trans hζbound |>.trans le_self_add⟩ + have hpreSorted : (pre.map Prod.fst).Pairwise (fun x y ↦ y < x) := by + have h := (Ordinal.CNF.sortedGT Ordinal.omega0 ζ.1).pairwise + rw [hζcnf, List.map_append, List.pairwise_append] at h + exact h.1 + have hpreAbove : ∀ x ∈ pre, γ < x.1 := by + have h := (Ordinal.CNF.sortedGT Ordinal.omega0 ζ.1).pairwise + rw [hζcnf, List.map_append, List.pairwise_append] at h + intro x hx + exact h.2.2 x.1 (by exact List.mem_map.mpr ⟨x, hx, rfl⟩) + γ (by simp) + have hprePos : ∀ x ∈ pre, 0 < x.2 := by + intro x hx + exact Ordinal.CNF.snd_pos (by rw [hζcnf]; exact List.mem_append_left _ hx) + have hpreLt : ∀ x ∈ pre, x.2 < Ordinal.omega0 := by + intro x hx + exact Ordinal.CNF.snd_lt Ordinal.one_lt_omega0 (by + rw [hζcnf] + exact List.mem_append_left _ hx) + have hηcnf : ∀ q : Q, ∃ δ d, + Ordinal.CNF Ordinal.omega0 q.1 = [(δ, d)] ∧ δ < γ ∧ + Ordinal.CNF Ordinal.omega0 (η q).1 = + if n = 0 then pre ++ [(δ, d)] + else pre ++ (γ, (n : Ordinal)) :: [(δ, d)] := by + intro q + exact cnfValue_add_singleton_below pre γ n hpreSorted hpreAbove hprePos hpreLt q.1 q.2 + have hηstage : ∀ q : Q, η q ∈ GaoStageIndices ξ γ := by + intro q + obtain ⟨δ, d, hqcnf, hδγ, hcnf⟩ := hηcnf q + refine ⟨(hηlt q).le.trans hζbound, ?_⟩ + rw [leastCNFExponent, hcnf] + split_ifs <;> simp_all + let Z : Set (GaoIndex ξ) := Set.range η + let : Nonempty Q := hQne.to_subtype + have hZne : Z.Nonempty := Set.range_nonempty η + have hZstage : ∀ η' ∈ Z, η' ∈ GaoStageIndices ξ γ := by + rintro _ ⟨q, rfl⟩ + exact hηstage q + have hηchainLT : ∀ q r : Q, q.1 < r.1 → + cnfExtensionLT (η q).1 (η r).1 := by + intro q r hqr + obtain ⟨δ, d, hqcnf, hδγ, hqηcnf⟩ := hηcnf q + obtain ⟨ε, e, hrcnf, hεγ, hrηcnf⟩ := hηcnf r + have hstep := singletonCNF_step_of_lt hqcnf hrcnf hqr + by_cases hn : n = 0 + · refine ⟨pre, [], δ, d, ε, e, ?_, ?_, ?_⟩ + · simpa [hn] using hqηcnf + · simpa [hn] using hrηcnf + · rcases hstep with hsame | hexp + · exact Or.inl hsame + · exact Or.inr ⟨hexp, by + by_cases hp : pre = [] + · exact Or.inl hp + · let last := pre.getLast hp + have hlast : pre.getLast? = some last := by + dsimp [last] + exact List.getLast?_eq_getLast_of_ne_nil hp + have hlastMem : last ∈ pre := by + dsimp [last] + exact List.getLast_mem hp + exact Or.inr ⟨last.1, last.2, hlast, + hεγ.trans (hpreAbove last hlastMem)⟩⟩ + · let common := pre ++ [(γ, (n : Ordinal))] + refine ⟨common, [], δ, d, ε, e, ?_, ?_, ?_⟩ + · simpa [hn, common, List.append_assoc] using hqηcnf + · simpa [hn, common, List.append_assoc] using hrηcnf + · rcases hstep with hsame | hexp + · exact Or.inl hsame + · exact Or.inr ⟨hexp, Or.inr ⟨γ, (n : Ordinal), by + simp [common], hεγ⟩⟩ + have hZchain : ∀ ⦃η₁⦄, η₁ ∈ Z → ∀ ⦃η₂⦄, η₂ ∈ Z → + cnfExtensionLE η₁.1 η₂.1 ∨ cnfExtensionLE η₂.1 η₁.1 := by + rintro _ ⟨q, rfl⟩ _ ⟨r, rfl⟩ + rcases lt_trichotomy q.1 r.1 with hlt | heq | hgt + · exact Or.inl (Or.inr (hηchainLT q r hlt)) + · have hsub : q = r := Subtype.ext heq + subst r + exact Or.inl (Or.inl rfl) + · exact Or.inr (Or.inr (hηchainLT r q hgt)) + have hvalLUB : IsLUB ((fun η' : GaoIndex ξ ↦ η'.1) '' Z) ζ.1 := by + have hmap := (Ordinal.isNormal_add_right base).map_isLUB + (singletonCNFBelow_isLUB γ hγ) hQne + rw [hζeq] + have hsets : ((fun η' : GaoIndex ξ ↦ η'.1) '' Z) = + (fun q : Ordinal.{u} ↦ base + q) '' Q := by + ext x + constructor + · rintro ⟨_, ⟨q, rfl⟩, rfl⟩ + exact ⟨q.1, q.2, rfl⟩ + · rintro ⟨q, hq, rfl⟩ + exact ⟨η ⟨q, hq⟩, ⟨⟨q, hq⟩, rfl⟩, rfl⟩ + rw [hsets] + exact hmap + exact ⟨Z, hZne, hZstage, hZchain, hvalLUB⟩ + +/-- Establishes the reverse inclusion for a successor Gao stage from the +explicit coordinate approximations. -/ +theorem gaoStage_succ_subset_orderAdherence + (ξ γ : Ordinal.{u}) (hγ : γ ≠ 0) : + GaoStageSet ξ (γ + 1) ⊆ orderAdherence (GaoStageSet ξ γ) := by + classical + intro f hf + obtain ⟨ζ, hζstage, hfζ⟩ := hf + by_cases hleast : leastCNFExponent ζ.1 < γ + · exact subset_orderAdherence (GaoStageSet ξ γ) + ⟨ζ, ⟨hζstage.1, hleast⟩, hfζ⟩ + have hleastLe : leastCNFExponent ζ.1 ≤ γ := by + rw [← Order.succ_eq_add_one] at hζstage + exact Order.lt_succ_iff.mp hζstage.2 + have hleastEq : leastCNFExponent ζ.1 = γ := + le_antisymm hleastLe (le_of_not_gt hleast) + obtain ⟨Z, hZne, hZstage, hZchain, hvalLUB⟩ := + gaoIndex_approximation ξ γ hγ ζ hζstage.1 hleastEq + have hprojLUB := ordinalProjection_chain_iSup ξ Z ζ hZne hZchain hvalLUB + let : Nonempty Z := hZne.to_subtype + let p : Z → C(GaoCompactSpace ξ, ℝ) := fun η ↦ ordinalProjection ξ η.1 + have hpmono : Monotone p := by + intro η θ hηθ + apply (ordinalProjection_le_iff ξ η.1 θ.1).2 + rcases hZchain η.2 θ.2 with h | h + · exact h + · have hOrd := cnfExtensionLE_partialOrder_and_subrelation.2 h + exact Or.inl (le_antisymm hηθ hOrd) + have hpLUB : IsLUB (Set.range p) (ordinalProjection ξ ζ) := by + have hsets : Set.range p = ordinalProjection ξ '' Z := by + ext g + constructor + · rintro ⟨η, rfl⟩ + exact ⟨η.1, η.2, rfl⟩ + · rintro ⟨η, hηZ, rfl⟩ + exact ⟨⟨η, hηZ⟩, rfl⟩ + rw [hsets] + exact hprojLUB + have hprojAdh : ordinalProjection ξ ζ ∈ orderAdherence (GaoStageSet ξ γ) := by + refine ⟨Z, inferInstance, inferInstance, inferInstance, p, ?_, + orderConvergesTo_of_monotone_isLUB hpmono hpLUB⟩ + intro η + refine ⟨η.1, hZstage η.1 η.2, ?_⟩ + have hnonneg : 0 ≤ ordinalProjection ξ η.1 := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + rw [abs_of_nonneg hnonneg] + apply isSolid_orderAdherence (isSolid_gaoStageSet ξ γ) hprojAdh + have hnonneg : 0 ≤ ordinalProjection ξ ζ := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + simpa only [abs_of_nonneg hnonneg] using hfζ + +/-- Packages both inclusions into the one-step Gao-stage formula; used by the +transfinite induction in `gao_orderAdherence_stage_formula`. -/ +theorem orderAdherence_gaoStage + (ξ γ : Ordinal.{u}) (hγ : γ ≠ 0) : + orderAdherence (GaoStageSet ξ γ) = GaoStageSet ξ (γ + 1) := + Set.Subset.antisymm (orderAdherence_gaoStage_subset ξ γ) + (gaoStage_succ_subset_orderAdherence ξ γ hγ) + +/-- Claim 3 in the proof of Theorem `thm:solid-iterations`. -/ +theorem gao_orderAdherence_stage_formula + (ξ : Ordinal.{u}) (T : OrderAdherenceTower (GaoStageSet ξ 1)) : + ∀ β ≤ ξ, T.stage (Ordinal.lift.{u + 1, u} β) = GaoStageSet ξ (1 + β) := by + intro β + induction β using Ordinal.limitRecOn with + | zero => + intro hzero + simpa using T.stage_zero + | add_one β ih => + intro hβ + have hβξ : β ≤ ξ := le_self_add.trans hβ + have hstage := ih hβξ + have hnonzero : 1 + β ≠ 0 := by + exact (zero_lt_one.trans_le (le_self_add : (1 : Ordinal) ≤ 1 + β)).ne' + rw [show Ordinal.lift.{u + 1, u} (β + 1) = + Order.succ (Ordinal.lift.{u + 1, u} β) by + rw [Order.succ_eq_add_one, Ordinal.lift_add_one], + T.stage_succ, hstage, orderAdherence_gaoStage ξ (1 + β) hnonzero, + add_assoc] + | limit β hβlim ih => + intro hβξ + rw [T.stage_limit _ (Ordinal.isSuccLimit_lift.mpr hβlim)] + ext f + constructor + · intro hf + rcases Set.mem_iUnion.mp hf with ⟨η, hfη⟩ + obtain ⟨δ, hδη⟩ := Ordinal.mem_range_lift_of_le η.2.le + have hδβ : δ < β := by + have h := η.2 + rw [← hδη] at h + exact Ordinal.lift_lt.mp h + have hδξ : δ ≤ ξ := hδβ.le.trans hβξ + have hfδ : f ∈ GaoStageSet ξ (1 + δ) := by + rw [← ih δ hδβ hδξ] + simpa only [hδη] using hfη + obtain ⟨ζ, hζ, hfζ⟩ := hfδ + exact ⟨ζ, ⟨hζ.1, hζ.2.trans_le (add_le_add_right hδβ.le 1)⟩, hfζ⟩ + · intro hf + obtain ⟨ζ, hζ, hfζ⟩ := hf + obtain ⟨δ, hδβ, hleastδ⟩ := + ((Ordinal.isNormal_add_right 1).lt_iff_exists_lt hβlim).mp hζ.2 + have hδξ : δ ≤ ξ := hδβ.le.trans hβξ + apply Set.mem_iUnion.mpr + let η : Set.Iio (Ordinal.lift.{u + 1, u} β) := + ⟨Ordinal.lift.{u + 1, u} δ, Ordinal.lift_lt.mpr hδβ⟩ + refine ⟨η, ?_⟩ + rw [ih δ hδβ hδξ] + exact ⟨ζ, ⟨hζ.1, hleastδ⟩, hfζ⟩ + +/-- The strict witness separating consecutive stages in Claim 3. -/ +theorem ordinalProjection_strict_stage + (ξ γ : Ordinal.{u}) (hγ : γ ≤ ξ) : + ∃ ζ : GaoIndex ξ, + ordinalProjection ξ ζ ∈ GaoStageSet ξ (γ + 1) ∧ + ordinalProjection ξ ζ ∉ GaoStageSet ξ γ := by + have hpow : Ordinal.omega0 ^ γ ≤ Ordinal.omega0 ^ ξ := + Ordinal.opow_le_opow_right Ordinal.omega0_pos hγ + let ζ : GaoIndex ξ := ⟨Ordinal.omega0 ^ γ, + hpow.trans le_self_add⟩ + have hcnf : Ordinal.CNF Ordinal.omega0 ζ.1 = [(γ, 1)] := by + dsimp [ζ] + simpa using Ordinal.CNF.opow_mul_add (b := Ordinal.omega0) + (e := γ) (x := 1) (y := 0) Ordinal.one_lt_omega0 one_ne_zero + Ordinal.one_lt_omega0 (Ordinal.opow_pos γ Ordinal.omega0_pos) + have hleast : leastCNFExponent ζ.1 = γ := by + simp [leastCNFExponent, hcnf] + refine ⟨ζ, ?_, ?_⟩ + · refine ⟨ζ, ⟨hpow, ?_⟩, ?_⟩ + · rw [hleast] + rw [Ordinal.lt_add_iff one_ne_zero] + exact ⟨0, zero_lt_one, by simp⟩ + · have hnonneg : 0 ≤ ordinalProjection ξ ζ := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + rw [abs_of_nonneg hnonneg] + · rintro ⟨η, hη, hdom⟩ + have hnonneg : 0 ≤ ordinalProjection ξ ζ := by + intro x + simp only [ordinalProjection] + split_ifs <;> norm_num + rw [abs_of_nonneg hnonneg] at hdom + have hrel := (ordinalProjection_le_iff ξ ζ η).mp hdom + rcases hrel with heq | hrel + · have : leastCNFExponent η.1 = γ := by + rw [← heq] + exact hleast + exact (lt_irrefl γ) (by simpa only [this] using hη.2) + · rcases hrel with ⟨pre, tail, β, c, δ, d, hζcnf, hηcnf, hstep⟩ + rw [hcnf] at hζcnf + cases pre with + | nil => + simp only [List.nil_append, List.cons.injEq] at hζcnf + rcases hζcnf with ⟨hhead, rfl⟩ + have hβ : β = γ := congrArg Prod.fst hhead.symm + have hc : c = 1 := congrArg Prod.snd hhead.symm + subst β + subst c + have hγδ : γ ≤ δ := by + rcases hstep with ⟨rfl, _⟩ | ⟨hγδ, _⟩ + · exact le_rfl + · exact hγδ.le + have hleastη : leastCNFExponent η.1 = δ := by + simp [leastCNFExponent, hηcnf] + exact (not_lt_of_ge (hleastη.symm ▸ hγδ)) hη.2 + | cons p pre => + simp only [List.cons_append, List.cons.injEq] at hζcnf + rcases hζcnf with ⟨rfl, hfalse⟩ + simp at hfalse + +end OrdinalConstruction + +end OrderClosures diff --git a/LeanPool/OrderClosures/OrderAdherence.lean b/LeanPool/OrderClosures/OrderAdherence.lean new file mode 100644 index 0000000000..290b02f40b --- /dev/null +++ b/LeanPool/OrderClosures/OrderAdherence.lean @@ -0,0 +1,454 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.BanLat.Pi +public import LeanPool.OrderClosures.BanLat.OrderContinuous.MeyerNieberg +public import LeanPool.OrderClosures.BanLat.LatticeSeminorm +public import LeanPool.OrderClosures.BanLat.Substructures.Sublattice +public import LeanPool.OrderClosures.BanLat.Tactic.LLexpr +public import LeanPool.OrderClosures.BanLat.Examples.CofK.Basic +public import LeanPool.OrderClosures.BanLat.Operators.Hom +public import Mathlib.SetTheory.Cardinal.Aleph +public import Mathlib.SetTheory.Cardinal.Order +public import Mathlib.SetTheory.Ordinal.Arithmetic + + +/-! +# Order adherence + +Shared definitions and results about order convergence, unbounded-order convergence, +solid hulls, and iterated order adherence used throughout the formalization. +-/ + +@[expose] public section + +open Set + +namespace OrderClosures + +universe u v + +section Convergence + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- Unbounded-order convergence, defined using BanLat's `OrderConvergesTo`. -/ +def UOConvergesTo {ι : Type v} [Preorder ι] (f : ι → X) (x : X) : Prop := + ∀ a : X, 0 ≤ a → OrderConvergesTo (fun i ↦ |f i - x| ⊓ a) 0 + +/-- The order adherence of a set: limits of order-convergent nets in the set. -/ +def orderAdherence (A : Set X) : Set X := + {x | ∃ (ι : Type u) (_ : Preorder ι) (_ : IsDirected ι (· ≤ ·)) (_ : Nonempty ι), + ∃ f : ι → X, (∀ i, f i ∈ A) ∧ OrderConvergesTo f x} + +/-- The unbounded-order adherence of a set. -/ +def uoAdherence (A : Set X) : Set X := + {x | ∃ (ι : Type u) (_ : Preorder ι) (_ : IsDirected ι (· ≤ ·)) (_ : Nonempty ι), + ∃ f : ι → X, (∀ i, f i ∈ A) ∧ UOConvergesTo f x} + +/-- A set is order closed when it contains the order limits of all its nets. -/ +def IsOrderClosed (A : Set X) : Prop := orderAdherence A ⊆ A + +/-- A set is unbounded-order closed when it contains the uo-limits of all its nets. -/ +def IsUOClosed (A : Set X) : Prop := uoAdherence A ⊆ A + +/-- The least order-closed set containing `A`. -/ +def orderClosure (A : Set X) : Set X := + ⋂₀ {B : Set X | A ⊆ B ∧ IsOrderClosed B} + +/-- The paper's directed-supremum description of the positive part of order adherence. -/ +def directedPositiveAdherence (A : Set X) : Set X := + {x | 0 ≤ x ∧ ∃ B : Set X, + B ⊆ A ∩ {y | 0 ≤ y} ∧ B.Nonempty ∧ DirectedOn (· ≤ ·) B ∧ IsLUB B x} + +/-- For a solid set, order adherence is the solid hull of its directed positive suprema. -/ +def solidOrderAdherence (A : Set X) : Set X := + LatticeOrderedAddCommGroup.solidClosure (directedPositiveAdherence A) + +/-- Finite iteration of order adherence. -/ +def iteratedOrderAdherence (A : Set X) : ℕ → Set X + | 0 => A + | n + 1 => orderAdherence (iteratedOrderAdherence A n) + +/-- A transfinite order-adherence tower. At limit stages it is the union of earlier stages. -/ +structure OrderAdherenceTower (A : Set X) where + /-- The set reached at each ordinal stage. -/ + stage : Ordinal.{u} → Set X + stage_zero : stage 0 = A + stage_succ : ∀ ξ, stage (Order.succ ξ) = orderAdherence (stage ξ) + stage_limit : ∀ ξ, Order.IsSuccLimit ξ → + stage ξ = ⋃ η : Set.Iio ξ, stage η.1 + +/-- At least `ξ` stages are needed when every earlier adherence step is proper. -/ +def NeedsOrderAdherenceIterations (A : Set X) (ξ : Ordinal.{u}) : Prop := + ∃ T : OrderAdherenceTower A, + ∀ η < ξ, T.stage η ⊂ T.stage (Order.succ η) + +omit [VectorLattice X] in +/-- The generic net definition and the directed-positive definition agree for solid sets. -/ +theorem orderAdherence_eq_solidOrderAdherence {A : Set X} + (hA : LatticeOrderedAddCommGroup.IsSolid A) : + orderAdherence A = solidOrderAdherence A := by + ext x + constructor + · rintro ⟨ι, hpre, hdir, hne, f, hfA, hf⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + rcases hf with ⟨κ, hκpre, hκdir, hκne, r, hranti, hrnonneg, hrglb, hbound⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκne + let y : κ → X := fun k ↦ (|x| - r k)⁺ + have hy_mono : Monotone y := by + intro k l hkl + exact posPart_mono (sub_le_sub_left (hranti hkl) |x|) + have hy_mem : ∀ k, y k ∈ A := by + intro k + obtain ⟨i, hi⟩ := (hbound k).exists + have hx_le : |x| ≤ |f i| + r k := by + calc + |x| = |(x - f i) + f i| := by congr 1; abel + _ ≤ |x - f i| + |f i| := abs_add_le _ _ + _ = |f i| + |x - f i| := add_comm _ _ + _ ≤ |f i| + r k := add_le_add_right (by simpa [abs_sub_comm] using hi) _ + have hsub : |x| - r k ≤ |f i| := sub_le_iff_le_add.mpr hx_le + have hy_le : y k ≤ |f i| := + show (|x| - r k) ⊔ 0 ≤ |f i| from sup_le hsub (abs_nonneg _) + exact hA (hfA i) (by simpa [y, abs_of_nonneg (posPart_nonneg _)] using hy_le) + have hy_lub : IsLUB (Set.range y) |x| := by + refine ⟨?_, ?_⟩ + · rintro _ ⟨k, rfl⟩ + exact show (|x| - r k) ⊔ 0 ≤ |x| from + sup_le (sub_le_self _ (hrnonneg k)) (abs_nonneg _) + · intro c hc + have hlow : |x| - c ∈ lowerBounds (Set.range r) := by + rintro _ ⟨k, rfl⟩ + have hraw : |x| - r k ≤ c := (le_posPart _).trans (hc ⟨k, rfl⟩) + exact sub_le_iff_le_add.mpr (by + simpa [add_comm] using (sub_le_iff_le_add.mp hraw)) + exact sub_nonpos.mp (hrglb.2 hlow) + refine ⟨|x|, ?_, ?_⟩ + · refine ⟨abs_nonneg x, Set.range y, ?_, ?_, ?_, hy_lub⟩ + · rintro _ ⟨k, rfl⟩ + exact ⟨hy_mem k, posPart_nonneg _⟩ + · exact Set.range_nonempty y + · rintro _ ⟨k, rfl⟩ _ ⟨l, rfl⟩ + obtain ⟨m, hkm, hlm⟩ := directed_of (· ≤ ·) k l + exact ⟨y m, ⟨m, rfl⟩, hy_mono hkm, hy_mono hlm⟩ + · simp + · rintro ⟨z, hz, hxz⟩ + rcases hz with ⟨hz, B, hBA, hBne, hBdir, hBlub⟩ + have hxz' : |x| ≤ z := by simpa [abs_of_nonneg hz] using hxz + let : Nonempty B := hBne.to_subtype + let : IsDirectedOrder B := hBdir.isDirectedOrder + let b : B → X := fun w ↦ w.1 + have hb_mono : Monotone b := by + intro p q hpq + exact hpq + have hb_range : Set.range b = B := by + ext w + simp [b] + have hb_order : OrderConvergesTo b z := + orderConvergesTo_of_monotone_isLUB hb_mono (by simpa [hb_range] using hBlub) + let g : B → X := fun w ↦ (x ⊓ b w) ⊔ (-b w) + have hg_mem : ∀ w, g w ∈ A := by + intro w + have hw := hBA w.2 + have hg_upper : g w ≤ b w := by + exact sup_le inf_le_right ((neg_nonpos.mpr hw.2).trans hw.2) + have hg_lower : -g w ≤ b w := by + simpa using neg_le_neg (show -b w ≤ g w from le_sup_right) + have hg_abs : |g w| ≤ b w := (abs_le').2 ⟨hg_upper, hg_lower⟩ + exact hA hw.1 (by simpa [b, abs_of_nonneg hw.2] using hg_abs) + have hxbounds : x ≤ z ∧ -x ≤ z := (abs_le').mp hxz' + have hnegzx : -z ≤ x := by simpa using neg_le_neg hxbounds.2 + have hlim : x ⊓ z ⊔ -z = x := by + rw [inf_eq_left.mpr hxbounds.1, sup_eq_left.mpr hnegzx] + have hg_order : OrderConvergesTo g x := by + have h := ((orderConvergesTo_const (X := X) (ι := B) x).inf hb_order).sup hb_order.neg + simpa [g, hlim] using h + exact ⟨B, inferInstance, inferInstance, inferInstance, g, hg_mem, hg_order⟩ + +omit [VectorLattice X] in +/-- Order adherence is extensive. -/ +theorem subset_orderAdherence (A : Set X) : A ⊆ orderAdherence A := by + intro x hx + exact ⟨ULift.{u} PUnit, inferInstance, inferInstance, inferInstance, + fun _ ↦ x, fun _ ↦ hx, orderConvergesTo_const x⟩ + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- Order adherence is monotone. -/ +theorem orderAdherence_mono : Monotone (orderAdherence : Set X → Set X) := by + intro A B hAB x + rintro ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + exact ⟨ι, hpre, hdir, hne, f, fun i ↦ hAB (hf i), hfx⟩ + +omit [VectorLattice X] in +/-- Uo-adherence is extensive. -/ +theorem subset_uoAdherence (A : Set X) : A ⊆ uoAdherence A := by + intro x hx + refine ⟨ULift.{u} PUnit, inferInstance, inferInstance, inferInstance, + fun _ ↦ x, fun _ ↦ hx, ?_⟩ + intro a ha + simpa [inf_eq_left.mpr ha] using + (orderConvergesTo_const (ι := ULift.{u} PUnit) (0 : X)) + +omit [VectorLattice X] in +/-- Order convergence implies unbounded-order convergence. -/ +theorem OrderConvergesTo.uoConvergesTo {ι : Type v} [Preorder ι] + {f : ι → X} {x : X} + (h : OrderConvergesTo f x) : UOConvergesTo f x := by + intro a ha + have hsub := h.sub (orderConvergesTo_const (ι := ι) x) + have hinf := hsub.abs.inf (orderConvergesTo_const (ι := ι) a) + simpa [inf_eq_left.mpr ha] using hinf + +omit [IsOrderedAddMonoid X] [VectorLattice X] in +/-- Converts domination by an order-null net into order convergence to zero; +used to pass from uo-convergence to convergence of lattice clamps. -/ +private theorem orderConvergesTo_zero_of_abs_le {ι : Type v} [Preorder ι] + {f g : ι → X} (hg : OrderConvergesTo g 0) (hfg : ∀ i, |f i| ≤ |g i|) : + OrderConvergesTo f 0 := by + rcases hg with ⟨κ, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, hbound⟩ + refine ⟨κ, hpre, hdir, hne, r, hranti, hrnonneg, hrglb, ?_⟩ + intro k + exact (hbound k).mono fun i hi ↦ by + simpa using (hfg i).trans (by simpa using hi) + +omit [VectorLattice X] in +/-- Bounds the change of a lattice clamp by the clamped difference; used by +`UOConvergesTo.clamp` to obtain its controlling order-null net. -/ +private theorem abs_clamp_le (x a : X) (ha : 0 ≤ a) : + |(x ⊓ a) ⊔ (-a)| ≤ a := by + apply (abs_le').2 + exact ⟨sup_le inf_le_right ((neg_nonpos.mpr ha).trans ha), + by simpa using neg_le_neg (show -a ≤ (x ⊓ a) ⊔ (-a) from le_sup_right)⟩ + +omit [VectorLattice X] in +/-- Shows that clamping a uo-convergent net to a fixed order interval gives +order convergence; this is the key reduction in the adherence comparison. -/ +private theorem UOConvergesTo.clamp {ι : Type v} [Preorder ι] + {f : ι → X} {x : X} + (h : UOConvergesTo f x) (a : X) (ha : 0 ≤ a) : + OrderConvergesTo (fun i ↦ (f i ⊓ a) ⊔ (-a)) ((x ⊓ a) ⊔ (-a)) := by + let c : X := (x ⊓ a) ⊔ (-a) + let d : ι → X := fun i ↦ ((f i ⊓ a) ⊔ (-a)) - c + have ht := h (a + a) (add_nonneg ha ha) + have hd_bound : ∀ i, |d i| ≤ |(|f i - x| ⊓ (a + a))| := by + intro i + have hfirst : |d i| ≤ |f i - x| := by + exact (abs_sup_sub_sup_le_abs (f i ⊓ a) (x ⊓ a) (-a)).trans + (abs_inf_sub_inf_le_abs (f i) x a) + have hsecond : |d i| ≤ a + a := by + calc + |d i| = |((f i ⊓ a) ⊔ (-a)) + -((x ⊓ a) ⊔ (-a))| := by + simp [d, c, sub_eq_add_neg] + _ ≤ |(f i ⊓ a) ⊔ (-a)| + |(x ⊓ a) ⊔ (-a)| := by + simpa using abs_add_le ((f i ⊓ a) ⊔ (-a)) (-((x ⊓ a) ⊔ (-a))) + _ ≤ a + a := add_le_add (abs_clamp_le _ _ ha) (abs_clamp_le _ _ ha) + have ht_nonneg : 0 ≤ |f i - x| ⊓ (a + a) := + le_inf (abs_nonneg _) (add_nonneg ha ha) + simpa [abs_of_nonneg ht_nonneg] using (le_inf hfirst hsecond) + have hd : OrderConvergesTo d 0 := orderConvergesTo_zero_of_abs_le ht hd_bound + have hsum := hd.add (orderConvergesTo_const (ι := ι) c) + simpa [d, c] using hsum + +/-- Gao--Leung, Lemma 2.1: the two adherences lie within two order-adherence steps. -/ +theorem orderAdherence_subset_uoAdherence_subset {Y : VectorSublattice X} : + orderAdherence (Y : Set X) ⊆ uoAdherence (Y : Set X) ∧ + uoAdherence (Y : Set X) ⊆ orderAdherence (orderAdherence (Y : Set X)) := by + constructor + · rintro x ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + exact ⟨ι, inferInstance, inferInstance, inferInstance, f, hf, + OrderConvergesTo.uoConvergesTo hfx⟩ + · rintro x ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + let g : ι → X := fun i ↦ (x ⊓ |f i|) ⊔ (-|f i|) + have hg_mem : ∀ i, g i ∈ orderAdherence (Y : Set X) := by + intro i + have hai : |f i| ∈ Y := Y.abs_mem (hf i) + refine ⟨ι, inferInstance, inferInstance, inferInstance, + fun j ↦ (f j ⊓ |f i|) ⊔ (-|f i|), ?_, ?_⟩ + · intro j + exact Y.sup_mem (Y.inf_mem (hf j) hai) (Y.toSubmodule.neg_mem hai) + · exact hfx.clamp |f i| (abs_nonneg _) + have ht := hfx |x| (abs_nonneg x) + have hdiff : OrderConvergesTo (fun i ↦ g i - x) 0 := by + apply orderConvergesTo_zero_of_abs_le ht + intro i + dsimp [g] + llarith + have hg_order := hdiff.add (orderConvergesTo_const (ι := ι) x) + refine ⟨ι, inferInstance, inferInstance, inferInstance, g, hg_mem, ?_⟩ + simpa [g] using hg_order + +/-- If the uo-adherence is order closed, it is the order closure. -/ +theorem uoAdherence_eq_orderClosure_of_isOrderClosed {Y : VectorSublattice X} + (hY : IsOrderClosed (uoAdherence (Y : Set X))) : + uoAdherence (Y : Set X) = orderClosure (Y : Set X) := by + apply Set.Subset.antisymm + · intro x hx + rw [orderClosure] + apply Set.mem_sInter.mpr + intro B hB + rcases hB with ⟨hYB, hBclosed⟩ + have hadhYB : orderAdherence (Y : Set X) ⊆ B := + fun _ hz ↦ hBclosed (orderAdherence_mono hYB hz) + have hdoubleYB : orderAdherence (orderAdherence (Y : Set X)) ⊆ B := + fun _ hz ↦ hBclosed (orderAdherence_mono hadhYB hz) + exact hdoubleYB ((orderAdherence_subset_uoAdherence_subset (Y := Y)).2 hx) + · intro x hx + rw [orderClosure] at hx + exact Set.mem_sInter.mp hx (uoAdherence (Y : Set X)) + ⟨subset_uoAdherence (Y : Set X), hY⟩ + +/-- The remaining equalities and stabilization stated after Gao--Leung Lemma 2.1. -/ +theorem uoAdherence_eq_double_orderAdherence_and_stabilizes + {Y : VectorSublattice X} (hY : IsOrderClosed (uoAdherence (Y : Set X))) : + uoAdherence (Y : Set X) = orderAdherence (orderAdherence (Y : Set X)) ∧ + orderAdherence (orderAdherence (orderAdherence (Y : Set X))) = + orderAdherence (orderAdherence (Y : Set X)) := by + have heq : uoAdherence (Y : Set X) = + orderAdherence (orderAdherence (Y : Set X)) := by + apply Set.Subset.antisymm + · exact (orderAdherence_subset_uoAdherence_subset (Y := Y)).2 + · exact fun _ hx ↦ hY (orderAdherence_mono + (orderAdherence_subset_uoAdherence_subset (Y := Y)).1 hx) + refine ⟨heq, ?_⟩ + calc + orderAdherence (orderAdherence (orderAdherence (Y : Set X))) = + orderAdherence (uoAdherence (Y : Set X)) := congrArg orderAdherence heq.symm + _ = uoAdherence (Y : Set X) := Set.Subset.antisymm hY + (subset_orderAdherence (uoAdherence (Y : Set X))) + _ = orderAdherence (orderAdherence (Y : Set X)) := heq + +omit [VectorLattice X] in +/-- The order adherence of a solid set is solid. -/ +theorem isSolid_orderAdherence {A : Set X} + (hA : LatticeOrderedAddCommGroup.IsSolid A) : + LatticeOrderedAddCommGroup.IsSolid (orderAdherence A) := by + rw [orderAdherence_eq_solidOrderAdherence hA] + exact LatticeOrderedAddCommGroup.isSolid_solidClosure (directedPositiveAdherence A) + +end Convergence + +section Solidity + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + +/-- The least solid set containing `A`, using Mathlib's solid closure. -/ +abbrev solidHull (A : Set X) : Set X := + LatticeOrderedAddCommGroup.solidClosure A + +/-- The interval-union description of the solid hull used in the paper. -/ +theorem solidHull_eq_iUnion_Icc (A : Set X) : + solidHull A = ⋃ a ∈ A, Set.Icc (-|a|) |a| := by + ext x + simp only [solidHull, LatticeOrderedAddCommGroup.solidClosure, Set.mem_ofPred_eq, + Set.mem_iUnion, Set.mem_Icc] + constructor + · rintro ⟨a, ha, hxa⟩ + have hx_bounds := (abs_le').mp hxa + refine ⟨a, ha, ?_, hx_bounds.1⟩ + simpa using neg_le_neg hx_bounds.2 + · rintro ⟨a, ha, hlow, hupp⟩ + refine ⟨a, ha, (abs_le').2 ⟨hupp, ?_⟩⟩ + simpa using neg_le_neg hlow + +/-- The least cardinality of a set whose solid hull is `S`. -/ +noncomputable def solidGeneratorNumber (S : Set X) : Cardinal := + sInf {κ : Cardinal | ∃ A : Set X, Cardinal.mk A = κ ∧ solidHull A = S} + +/-- Scalar dilation of a set. -/ +def scaleSet (a : ℝ) (A : Set X) [SMul ℝ X] : Set X := + (fun x ↦ a • x) '' A + +/-- A set-theoretic unit ball for a specified real-valued norm. -/ +def unitBallFor (p : X → ℝ) : Set X := {x | p x ≤ 1} + +end Solidity + +section CompletenessAndNorms + +/-- Order completeness, stated without installing a second lattice instance. -/ +def IsOrderComplete (X : Type u) [Preorder X] : Prop := + ∀ A : Set X, A.Nonempty → BddAbove A → ∃ x, IsLUB A x + +/-- Install BanLat's order-complete lattice structure locally from the paper's +set-theoretic order-completeness predicate. -/ +@[reducible] +noncomputable def conditionallyCompleteLatticeOfIsOrderComplete + (X : Type u) [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + (hX : IsOrderComplete X) : ConditionallyCompleteLattice X := + conditionallyCompleteLatticeOfPosSet X fun _ hne hbdd => hX _ hne hbdd + +/-- Density character: the least cardinality of a dense subset. -/ +noncomputable def densityCharacter (X : Type u) [TopologicalSpace X] : Cardinal := + sInf {κ : Cardinal | ∃ D : Set X, Dense D ∧ Cardinal.mk D = κ} + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [Module ℝ X] + +/-- A real lattice norm recorded independently of the ambient typeclass norm. -/ +structure PaperLatticeNorm (X : Type u) [AddCommGroup X] [Lattice X] + [IsOrderedAddMonoid X] [Module ℝ X] where + /-- The real-valued lattice norm. -/ + toFun : X → ℝ + nonneg : ∀ x, 0 ≤ toFun x + eq_zero_iff : ∀ x, toFun x = 0 ↔ x = 0 + add_le : ∀ x y, toFun (x + y) ≤ toFun x + toFun y + smul : ∀ (a : ℝ) x, toFun (a • x) = |a| * toFun x + solid : ∀ {x y}, |x| ≤ |y| → toFun x ≤ toFun y + +/-- Allows a bundled paper lattice norm to be applied as a function; used by +all subsequent Fatou and norm-comparison statements. -/ +instance : CoeFun (PaperLatticeNorm X) (fun _ ↦ X → ℝ) := ⟨PaperLatticeNorm.toFun⟩ + +/-- Sequential completeness for the metric induced by `p`. -/ +def IsCompleteFor (p : X → ℝ) : Prop := + ∀ f : ℕ → X, + (∀ ε > 0, ∃ N, ∀ m ≥ N, ∀ n ≥ N, p (f m - f n) < ε) → + ∃ x, ∀ ε > 0, ∃ N, ∀ n ≥ N, p (f n - x) < ε + +/-- Fatou's property for a specified lattice norm. -/ +def HasFatouProperty (p : X → ℝ) : Prop := + ∀ {ι : Type u} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + (f : ι → X) (x : X), Monotone f → (∀ i, 0 ≤ f i) → + IsLUB (Set.range f) x → IsLUB (p '' Set.range f) (p x) + +/-- Weak Fatou property with constant `K` for a specified lattice norm. -/ +def HasWeakFatouProperty (p : X → ℝ) (K : ℝ) : Prop := + 1 ≤ K ∧ ∀ {ι : Type u} [Preorder ι] [IsDirected ι (· ≤ ·)] [Nonempty ι] + (f : ι → X) (x : X), Monotone f → (∀ i, 0 ≤ f i) → + IsLUB (Set.range f) x → ∀ c, (∀ i, p (f i) ≤ c) → p x ≤ K * c + +/-- Equivalence of two norms through two positive comparison constants. -/ +def EquivalentNorms (p q : X → ℝ) : Prop := + ∃ c C : ℝ, 0 < c ∧ 0 < C ∧ ∀ x, c * p x ≤ q x ∧ q x ≤ C * p x + +/-- The ambient norm as a paper lattice norm. -/ +noncomputable def ambientLatticeNorm + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] : PaperLatticeNorm Y where + toFun := norm + nonneg := norm_nonneg + eq_zero_iff := fun _ ↦ norm_eq_zero + add_le := norm_add_le + smul := norm_smul + solid := fun h ↦ HasSolidNorm.solid h + +end CompletenessAndNorms + +end OrderClosures diff --git a/LeanPool/OrderClosures/Solovay.lean b/LeanPool/OrderClosures/Solovay.lean new file mode 100644 index 0000000000..e91c78018b --- /dev/null +++ b/LeanPool/OrderClosures/Solovay.lean @@ -0,0 +1,1660 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.OrderAdherence +public import Mathlib.Order.Heyting.Regular +public import Mathlib.Order.BooleanSubalgebra +public import Mathlib.SetTheory.Cardinal.Order +public import Mathlib.Topology.Category.Stonean.Basic +public import Mathlib.Order.PrimeSeparator +public import Mathlib.Topology.ContinuousMap.StoneWeierstrass + + +/-! +# Solovay's complete Boolean algebra construction + +This file formalizes the construction in Robert M. Solovay's *New Proof of a +Theorem of Gaifman and Hales*. It realizes the resulting complete Boolean +algebra as the clopen algebra of its Stone space and develops the analytic +facts needed for the Gao--Leung counterexample. +-/ + +@[expose] public section + +open Set + +noncomputable section + +namespace OrderClosures + +universe u + + +/-- The regular-open completion of the open-set Boolean algebra, used as the +complete Boolean algebra in Solovay's construction. -/ +abbrev RegularOpen (X : Type u) [TopologicalSpace X] := + Heyting.Regular (TopologicalSpace.Opens X) + +/-- Supplies arbitrary suprema and infima on regular open sets; required for +complete-generation arguments below. -/ +noncomputable instance regularOpenCompleteLattice + (X : Type u) [TopologicalSpace X] : CompleteLattice (RegularOpen X) := + Heyting.Regular.gi.liftCompleteLattice + +/-- Bundles the complete Boolean-algebra structure of regular open sets; used +as the algebra whose Stone spectrum forms the counterexample. -/ +noncomputable instance regularOpenCompleteBooleanAlgebra + (X : Type u) [TopologicalSpace X] : CompleteBooleanAlgebra (RegularOpen X) where + __ := Heyting.Regular.instBooleanAlgebra + __ := regularOpenCompleteLattice X + +/-- Regards a clopen set as a regular open element; used to turn finite +cylinders into Boolean-algebra generators. -/ +def regularOpenOfClopen {X : Type u} [TopologicalSpace X] + (s : Set X) (hs : IsClopen s) : RegularOpen X := by + let U : TopologicalSpace.Opens X := ⟨s, hs.2⟩ + let V : TopologicalSpace.Opens X := ⟨sᶜ, hs.1.isOpen_compl⟩ + have hUV : IsCompl U V := by + rw [isCompl_iff] + constructor + · rw [disjoint_iff] + apply TopologicalSpace.Opens.ext + simp [U, V] + · rw [codisjoint_iff] + apply TopologicalSpace.Opens.ext + simp [U, V] + exact ⟨U, (congrArg (fun W ↦ Wᶜ) hUV.compl_eq).trans hUV.symm.compl_eq⟩ + +@[simp] theorem coe_regularOpenOfClopen {X : Type u} [TopologicalSpace X] + (s : Set X) (hs : IsClopen s) : + (((regularOpenOfClopen s hs : RegularOpen X) : + TopologicalSpace.Opens X) : Set X) = s := rfl + +/-- Reduces equality of regular open sets to equality of carriers; used to +simplify Boolean-algebra computations in the Solovay construction. -/ +theorem regularOpen_ext {X : Type u} [TopologicalSpace X] + {U V : RegularOpen X} + (h : (((U : TopologicalSpace.Opens X) : Set X)) = + (((V : TopologicalSpace.Opens X) : Set X))) : U = V := by + apply Heyting.Regular.coe_injective + exact TopologicalSpace.Opens.ext h + +/-- Makes the regular-open constructor respect equality of clopen carriers; +used when rewriting cylinder identities. -/ +theorem regularOpenOfClopen_congr {X : Type u} [TopologicalSpace X] + {s t : Set X} (hs : IsClopen s) (ht : IsClopen t) (h : s = t) : + regularOpenOfClopen s hs = regularOpenOfClopen t ht := by + apply regularOpen_ext + simpa only [coe_regularOpenOfClopen] using h + +/-- Computes intersections of clopen sets inside the regular-open algebra; +used for finite cylinder meets and Boolean subalgebras. -/ +theorem regularOpenOfClopen_inf {X : Type u} [TopologicalSpace X] + (s t : Set X) (hs : IsClopen s) (ht : IsClopen t) : + regularOpenOfClopen (s ∩ t) (hs.inter ht) = + regularOpenOfClopen s hs ⊓ regularOpenOfClopen t ht := by + apply regularOpen_ext + rfl + +/-- Computes complements of clopen sets inside the regular-open algebra; +used to show the cylinder-generated family is a Boolean subalgebra. -/ +theorem regularOpenOfClopen_compl {X : Type u} [TopologicalSpace X] + (s : Set X) (hs : IsClopen s) : + regularOpenOfClopen sᶜ hs.compl = (regularOpenOfClopen s hs)ᶜ := by + apply regularOpen_ext + change sᶜ = + ((((⟨s, hs.2⟩ : TopologicalSpace.Opens X)ᶜ : + TopologicalSpace.Opens X)) : Set X) + let U : TopologicalSpace.Opens X := ⟨s, hs.2⟩ + let V : TopologicalSpace.Opens X := ⟨sᶜ, hs.1.isOpen_compl⟩ + have hUV : IsCompl U V := by + rw [isCompl_iff] + constructor + · rw [disjoint_iff] + apply TopologicalSpace.Opens.ext + simp [U, V] + · rw [codisjoint_iff] + apply TopologicalSpace.Opens.ext + simp [U, V] + rw [show (⟨s, hs.2⟩ : TopologicalSpace.Opens X) = U from rfl, + hUV.compl_eq] + rfl + +/-- Expresses a clopen union as a supremum of regular-open elements; used to +derive the explicit Solovay generator formulas. -/ +theorem regularOpenOfClopen_eq_sSup {X : Type u} [TopologicalSpace X] + (S : Set (RegularOpen X)) (t : Set X) (ht : IsClopen t) + (hunion : t = ⋃ U ∈ S, + ((((U : RegularOpen X) : TopologicalSpace.Opens X) : Set X))) : + regularOpenOfClopen t ht = sSup S := by + apply le_antisymm + · change (⟨t, ht.2⟩ : TopologicalSpace.Opens X) ≤ + ((sSup S : RegularOpen X) : TopologicalSpace.Opens X) + intro x hx + change x ∈ t at hx + rw [hunion] at hx + simp only [Set.mem_iUnion] at hx + rcases hx with ⟨U, hUS, hxU⟩ + exact (show U ≤ sSup S from le_sSup hUS) hxU + · apply sSup_le + intro U hUS + change (U : TopologicalSpace.Opens X) ≤ ⟨t, ht.2⟩ + intro x hx + change x ∈ t + rw [hunion] + simp only [Set.mem_iUnion] + exact ⟨U, hUS, hx⟩ + +/-- Recovers a regular open set as the supremum of a family whose union is +dense in it; used in the proof that the Solovay generators are complete. -/ +theorem regularOpen_eq_sSup_of_union {X : Type u} [TopologicalSpace X] + (U : RegularOpen X) (S : Set (RegularOpen X)) + (hunion : (((U : TopologicalSpace.Opens X) : Set X)) = ⋃ V ∈ S, + ((((V : RegularOpen X) : TopologicalSpace.Opens X) : Set X))) : + U = sSup S := by + apply le_antisymm + · change (U : TopologicalSpace.Opens X) ≤ + ((sSup S : RegularOpen X) : TopologicalSpace.Opens X) + intro x hx + have hx' : x ∈ (((U : TopologicalSpace.Opens X) : Set X)) := hx + rw [hunion] at hx' + simp only [Set.mem_iUnion] at hx' + rcases hx' with ⟨V, hVS, hxV⟩ + exact (show V ≤ sSup S from le_sSup hVS) hxV + · apply sSup_le + intro V hVS + change (V : TopologicalSpace.Opens X) ≤ + (U : TopologicalSpace.Opens X) + intro x hx + have hx' : x ∈ ⋃ W ∈ S, + ((((W : RegularOpen X) : TopologicalSpace.Opens X) : Set X)) := by + simp only [Set.mem_iUnion] + exact ⟨V, hVS, hx⟩ + rw [← hunion] at hx' + exact hx' + +section Solovay + +variable (Gamma : Type u) [LinearOrder Gamma] [TopologicalSpace Gamma] + [DiscreteTopology Gamma] + +/-- The countable product of the well-ordered index type on which the Solovay +cylinder algebra is constructed. -/ +abbrev SolovayProduct := ℕ → Gamma + +/-- The basic Solovay generator comparing coordinate `n` with `eta`; these +generators will completely generate the regular-open algebra. -/ +def solovayA (n : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f n = eta} + ((isClopen_discrete {eta}).preimage (continuous_apply n)) + +/-- The finite-coordinate cylinder through `g`; used as the topological basis +recovered from the Solovay generators. -/ +def solovayCylinderSet (F : Finset ℕ) (g : SolovayProduct Gamma) : + Set (SolovayProduct Gamma) := + ⋂ i ∈ F, {f | f i = g i} + +omit [LinearOrder Gamma] in +/-- Shows that every finite-coordinate Solovay cylinder is clopen; this allows +it to define an element of the regular-open Boolean algebra. -/ +theorem isClopen_solovayCylinderSet (F : Finset ℕ) + (g : SolovayProduct Gamma) : IsClopen (solovayCylinderSet Gamma F g) := by + apply isClopen_biInter_finset + intro i hi + exact (isClopen_discrete {g i}).preimage (continuous_apply i) + +/-- The regular-open element associated with a finite cylinder; used to prove +complete generation of every regular open set. -/ +def solovayCylinder (F : Finset ℕ) (g : SolovayProduct Gamma) : + RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen (solovayCylinderSet Gamma F g) + (isClopen_solovayCylinderSet Gamma F g) + +omit [LinearOrder Gamma] [TopologicalSpace Gamma] [DiscreteTopology Gamma] in +@[simp] theorem mem_solovayCylinderSet (F : Finset ℕ) + (g f : SolovayProduct Gamma) : + f ∈ solovayCylinderSet Gamma F g ↔ ∀ i ∈ F, f i = g i := by + simp [solovayCylinderSet] + +/-- Auxiliary coordinate-comparison element used to recover finite cylinders +from the basic `solovayA` generators. -/ +def solovayB (m n : ℕ) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f m ≤ f n} + (by + change IsClopen + ((fun f : SolovayProduct Gamma ↦ (f m, f n)) ⁻¹' + {p : Gamma × Gamma | p.1 ≤ p.2}) + exact (isClopen_discrete _).preimage + ((continuous_apply m).prodMk (continuous_apply n))) + +/-- The regular-open event that coordinate `n` is strictly below `eta`; used +in the Boolean identities for the generators. -/ +def solovayLT (n : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f n < eta} + ((isClopen_discrete {xi : Gamma | xi < eta}).preimage (continuous_apply n)) + +/-- The regular-open event that coordinate `n` is at most `eta`; used in the +well-founded recovery of exact coordinate values. -/ +def solovayLE (n : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f n ≤ eta} + ((isClopen_discrete {xi : Gamma | xi ≤ eta}).preimage (continuous_apply n)) + +/-- Auxiliary comparison element combining two coordinates and a threshold; +used in the recursive cylinder-generation identities. -/ +def solovayC (m n : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f m < f n → f m < eta} + (by + change IsClopen + ((fun f : SolovayProduct Gamma ↦ (f m, f n)) ⁻¹' + {p : Gamma × Gamma | p.1 < p.2 → p.1 < eta}) + exact (isClopen_discrete _).preimage + ((continuous_apply m).prodMk (continuous_apply n))) + +/-- The strict comparison event between two coordinates; isolated for reuse +in the formulas for `solovayC` and `solovayBad`. -/ +def solovayStrict (m n : ℕ) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f m < f n} + (by + change IsClopen + ((fun f : SolovayProduct Gamma ↦ (f m, f n)) ⁻¹' + {p : Gamma × Gamma | p.1 < p.2}) + exact (isClopen_discrete _).preimage + ((continuous_apply m).prodMk (continuous_apply n))) + +/-- The complement of a strict coordinate bound; used in exact-coordinate +cylinder formulas. -/ +def solovayNotLT (m : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | ¬ f m < eta} + ((isClopen_discrete {xi : Gamma | ¬ xi < eta}).preimage (continuous_apply m)) + +/-- The exceptional part of a coordinate comparison; separated so it can be +eliminated in the well-founded generator induction. -/ +def solovayBad (m n : ℕ) (eta : Gamma) : RegularOpen (SolovayProduct Gamma) := + regularOpenOfClopen {f | f m < f n ∧ ¬ f m < eta} + (by + change IsClopen + ((fun f : SolovayProduct Gamma ↦ (f m, f n)) ⁻¹' + {p : Gamma × Gamma | p.1 < p.2 ∧ ¬ p.1 < eta}) + exact (isClopen_discrete _).preimage + ((continuous_apply m).prodMk (continuous_apply n))) + +/-- Closure predicate for a Boolean subalgebra under arbitrary suprema; used +to formulate complete generation by the Solovay family. -/ +def IsCompleteBooleanSubalgebra {B : Type u} [CompleteBooleanAlgebra B] + (L : BooleanSubalgebra B) : Prop := + ∀ S : Set B, S ⊆ L → sSup S ∈ L + +/-- Derives closure under arbitrary infima from closure under arbitrary +suprema and complement; used repeatedly for the generated Boolean algebra. -/ +theorem IsCompleteBooleanSubalgebra.sInf_mem {B : Type u} + [CompleteBooleanAlgebra B] {L : BooleanSubalgebra B} + (hL : IsCompleteBooleanSubalgebra L) (S : Set B) (hSL : S ⊆ L) : + sInf S ∈ L := by + have hcomp : Compl.compl '' S ⊆ L := by + rintro _ ⟨x, hxS, rfl⟩ + exact L.compl_mem (hSL hxS) + have hmem := L.compl_mem (hL _ hcomp) + convert hmem using 1 + rw [compl_sSup'] + congr 1 + ext x + simp + +/-- Expresses the strict-order event as a supremum of basic generators; used +to place it in every complete subalgebra containing `solovayA`. -/ +theorem solovayLT_eq_sSup (n : ℕ) (eta : Gamma) : + solovayLT Gamma n eta = + sSup (solovayA Gamma n '' Set.Iio eta) := by + apply regularOpenOfClopen_eq_sSup + ext f + simp only [Set.mem_iUnion, Set.mem_image, Set.mem_Iio, Set.mem_ofPred_eq] + constructor + · intro h + exact ⟨solovayA Gamma n (f n), ⟨f n, h, rfl⟩, rfl⟩ + · rintro ⟨U, ⟨eta', hη, rfl⟩, hf⟩ + change f n = eta' at hf + exact hf ▸ hη + +/-- Computes the event that one coordinate is strictly below another; used in +the recursive recovery of finite cylinders. -/ +theorem solovayStrict_eq (m n : ℕ) : + solovayStrict Gamma m n = (solovayB Gamma n m)ᶜ := by + unfold solovayB + rw [← regularOpenOfClopen_compl] + apply regularOpenOfClopen_congr + ext f + simp + +/-- Computes the complementary order event; used to build exact coordinate +conditions from the Solovay generators. -/ +theorem solovayNotLT_eq (m : ℕ) (eta : Gamma) : + solovayNotLT Gamma m eta = (solovayLT Gamma m eta)ᶜ := by + unfold solovayLT + rw [← regularOpenOfClopen_compl] + apply regularOpenOfClopen_congr + ext f + simp + +/-- Decomposes the exceptional comparison event into previously generated +pieces; used in the induction recovering cylinder elements. -/ +theorem solovayBad_eq (m n : ℕ) (eta : Gamma) : + solovayBad Gamma m n eta = + solovayStrict Gamma m n ⊓ solovayNotLT Gamma m eta := by + unfold solovayStrict solovayNotLT + rw [← regularOpenOfClopen_inf] + apply regularOpenOfClopen_congr + rfl + +/-- Gives the Boolean formula for the auxiliary comparison element `solovayC`; +used to derive the non-strict order event. -/ +theorem solovayC_eq (m n : ℕ) (eta : Gamma) : + solovayC Gamma m n eta = (solovayBad Gamma m n eta)ᶜ := by + unfold solovayBad + rw [← regularOpenOfClopen_compl] + apply regularOpenOfClopen_congr + ext f + simp + +/-- Expresses a non-strict coordinate bound as an infimum of comparison +elements; used in the well-founded generator induction. -/ +theorem solovayLE_eq_sInf (n : ℕ) (eta : Gamma) : + solovayLE Gamma n eta = sInf (Set.range fun m ↦ solovayC Gamma m n eta) := by + apply le_antisymm + · apply le_sInf + intro U hU + rcases hU with ⟨m, rfl⟩ + change (⟨{f : SolovayProduct Gamma | f n ≤ eta}, _⟩ : + TopologicalSpace.Opens (SolovayProduct Gamma)) ≤ + ⟨{f : SolovayProduct Gamma | f m < f n → f m < eta}, _⟩ + intro f hf hmn + exact hmn.trans_le hf + · let W : TopologicalSpace.Opens (SolovayProduct Gamma) := + (sInf (Set.range fun m ↦ solovayC Gamma m n eta) : + RegularOpen (SolovayProduct Gamma)) + change W ≤ ⟨{f : SolovayProduct Gamma | f n ≤ eta}, _⟩ + intro g hg + change g n ≤ eta + by_contra hgn + have hetagn : eta < g n := lt_of_not_ge hgn + rcases isOpen_pi_iff.mp W.2 g hg with ⟨F, v, hv, hvW⟩ + obtain ⟨m, hm⟩ := (insert n F).exists_nat_subset_range + have hmF : m ∉ F := by + intro hmF + exact (Nat.lt_irrefl m) + (Finset.mem_range.mp (hm (Finset.mem_insert_of_mem hmF))) + have hmn : m ≠ n := by + intro hmn + subst n + exact (Nat.lt_irrefl m) + (Finset.mem_range.mp (hm (Finset.mem_insert_self m F))) + let h : SolovayProduct Gamma := fun i ↦ if i = m then eta else g i + have hhF : h ∈ (F : Set ℕ).pi v := by + intro i hi + rw [show h i = g i by simp [h, ne_of_mem_of_not_mem hi hmF]] + exact (hv i (Finset.mem_coe.mp hi)).2 + have hhW : h ∈ W := hvW hhF + have hhC : h ∈ (solovayC Gamma m n eta : + TopologicalSpace.Opens (SolovayProduct Gamma)) := + (show sInf (Set.range fun k ↦ solovayC Gamma k n eta) ≤ + solovayC Gamma m n eta from sInf_le (Set.mem_range_self m)) hhW + change h m < h n → h m < eta at hhC + have hhm : h m = eta := by simp [h] + have hhn : h n = g n := by simp [h, hmn.symm] + have hhless : h m < h n := by simpa only [hhm, hhn] using hetagn + have hout := hhC hhless + rw [hhm] at hout + exact (lt_irrefl eta) hout + +/-- Gives the fundamental Boolean identity for a Solovay generator; used to +recover exact coordinate cylinders. -/ +theorem solovayA_eq (n : ℕ) (eta : Gamma) : + solovayA Gamma n eta = + solovayLE Gamma n eta ⊓ (solovayLT Gamma n eta)ᶜ := by + rw [← solovayNotLT_eq] + unfold solovayLE solovayNotLT + rw [← regularOpenOfClopen_inf] + apply regularOpenOfClopen_congr + ext f + simp [le_antisymm_iff] + +/-- Performs the well-founded step placing all `solovayA` elements in a +complete subalgebra generated by the basic family. -/ +theorem solovayA_mem_of_generators [WellFoundedLT Gamma] + (L : BooleanSubalgebra (RegularOpen (SolovayProduct Gamma))) + (hcomplete : IsCompleteBooleanSubalgebra L) + (hB : ∀ m n, solovayB Gamma m n ∈ L) : + ∀ eta n, solovayA Gamma n eta ∈ L := by + intro eta + induction eta using WellFoundedLT.induction with + | ind eta ih => + intro n + have hLT : ∀ k, solovayLT Gamma k eta ∈ L := by + intro k + rw [solovayLT_eq_sSup] + apply hcomplete + rintro U ⟨theta, htheta, rfl⟩ + exact ih theta htheta k + have hC : ∀ m, solovayC Gamma m n eta ∈ L := by + intro m + rw [solovayC_eq, solovayBad_eq, solovayStrict_eq, + solovayNotLT_eq] + exact L.compl_mem (L.inf_mem (L.compl_mem (hB n m)) + (L.compl_mem (hLT m))) + have hLE : solovayLE Gamma n eta ∈ L := by + rw [solovayLE_eq_sInf] + apply hcomplete.sInf_mem + rintro U ⟨m, rfl⟩ + exact hC m + rw [solovayA_eq] + exact L.inf_mem hLE (L.compl_mem (hLT n)) + +omit [LinearOrder Gamma] in +/-- Splits a finite cylinder after inserting one coordinate; used for the +induction showing all finite cylinders are generated. -/ +theorem solovayCylinder_insert (i : ℕ) (F : Finset ℕ) + (g : SolovayProduct Gamma) : + solovayCylinder Gamma (insert i F) g = + solovayA Gamma i (g i) ⊓ solovayCylinder Gamma F g := by + apply regularOpen_ext + change solovayCylinderSet Gamma (insert i F) g = + {f | f i = g i} ∩ solovayCylinderSet Gamma F g + ext f + simp [solovayCylinderSet] + +omit [LinearOrder Gamma] in +/-- Places every finite Solovay cylinder in a complete subalgebra containing +the generators; used to recover arbitrary regular open sets. -/ +theorem solovayCylinder_mem + (L : BooleanSubalgebra (RegularOpen (SolovayProduct Gamma))) + (hA : ∀ n eta, solovayA Gamma n eta ∈ L) : + ∀ F g, solovayCylinder Gamma F g ∈ L := by + intro F + induction F using Finset.induction_on with + | empty => + intro g + have htop : solovayCylinder Gamma ∅ g = ⊤ := by + apply regularOpen_ext + simp [solovayCylinder, solovayCylinderSet] + rw [htop] + exact L.top_mem + | @insert i F hi ih => + intro g + rw [solovayCylinder_insert] + exact L.inf_mem (hA i (g i)) (ih g) + +/-- The basic cylinders lying below a regular open element; their supremum is +used to reconstruct that element. -/ +def solovayCylindersBelow (U : RegularOpen (SolovayProduct Gamma)) : + Set (RegularOpen (SolovayProduct Gamma)) := + {V | ∃ F g, V = solovayCylinder Gamma F g ∧ + ((((V : RegularOpen (SolovayProduct Gamma)) : + TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma))) ⊆ + (((U : TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma)))} + +omit [LinearOrder Gamma] in +/-- Represents the points of a regular open set by cylinders lying below it; +used to express that set as a supremum of generated cylinder elements. -/ +theorem solovay_union_cylinders_below + (U : RegularOpen (SolovayProduct Gamma)) : + (((U : TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma))) = + ⋃ V ∈ solovayCylindersBelow Gamma U, + ((((V : RegularOpen (SolovayProduct Gamma)) : + TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma))) := by + ext x + constructor + · intro hxU + rcases isOpen_pi_iff.mp + (U : TopologicalSpace.Opens (SolovayProduct Gamma)).2 x hxU with + ⟨F, v, hv, hvU⟩ + let V := solovayCylinder Gamma F x + have hVU : + ((((V : RegularOpen (SolovayProduct Gamma)) : + TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma))) ⊆ + (((U : TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma))) := by + intro y hy + apply hvU + intro i hi + have hyi : y i = x i := by + apply (mem_solovayCylinderSet Gamma F x y).mp + (show y ∈ solovayCylinderSet Gamma F x by exact hy) + exact Finset.mem_coe.mp hi + rw [hyi] + exact (hv i (Finset.mem_coe.mp hi)).2 + have hVS : V ∈ solovayCylindersBelow Gamma U := + ⟨F, x, rfl, hVU⟩ + simp only [Set.mem_iUnion] + refine ⟨V, hVS, ?_⟩ + exact (mem_solovayCylinderSet Gamma F x x).mpr fun _ _ ↦ rfl + · simp only [Set.mem_iUnion] + rintro ⟨V, ⟨F, g, rfl, hVU⟩, hxV⟩ + exact hVU hxV + +omit [LinearOrder Gamma] in +/-- Shows every regular open element belongs to any complete subalgebra +containing the Solovay generators; this proves generation of the full algebra. -/ +theorem solovay_every_regularOpen_mem + (L : BooleanSubalgebra (RegularOpen (SolovayProduct Gamma))) + (hcomplete : IsCompleteBooleanSubalgebra L) + (hA : ∀ n eta, solovayA Gamma n eta ∈ L) + (U : RegularOpen (SolovayProduct Gamma)) : U ∈ L := by + rw [regularOpen_eq_sSup_of_union U (solovayCylindersBelow Gamma U) + (solovay_union_cylinders_below Gamma U)] + apply hcomplete + intro V hV + rcases hV with ⟨F, g, rfl, hsub⟩ + exact solovayCylinder_mem Gamma L hA F g + +/-- Packages the preceding membership argument as complete generation of the +regular-open Boolean algebra; used in the Gao counterexample. -/ +theorem solovay_generates_regularOpen [WellFoundedLT Gamma] + (L : BooleanSubalgebra (RegularOpen (SolovayProduct Gamma))) + (hcomplete : IsCompleteBooleanSubalgebra L) + (hB : ∀ m n, solovayB Gamma m n ∈ L) : L = ⊤ := by + apply BooleanSubalgebra.ext + intro U + simp only [BooleanSubalgebra.mem_top, iff_true] + apply solovay_every_regularOpen_mem Gamma L hcomplete + exact fun n eta ↦ solovayA_mem_of_generators Gamma L hcomplete hB eta n + +/-- Shows one coordinate layer of Solovay generators is injectively indexed; +used for the density-character lower bound. -/ +theorem solovayA_injective (n : ℕ) : Function.Injective (solovayA Gamma n) := by + intro eta theta h + by_contra hne + have hsets := congrArg + (fun U : RegularOpen (SolovayProduct Gamma) ↦ + (((U : TopologicalSpace.Opens (SolovayProduct Gamma)) : + Set (SolovayProduct Gamma)))) h + change {f : SolovayProduct Gamma | f n = eta} = {f | f n = theta} at hsets + let f : SolovayProduct Gamma := fun _ ↦ eta + have hf : f ∈ {g : SolovayProduct Gamma | g n = eta} := rfl + rw [hsets] at hf + exact hne hf + +end Solovay + +section BooleanStone + +variable (B : Type u) [BooleanAlgebra B] + +/-- The bounded-lattice equations defining a two-valued Stone point; used to +realize the Stone spectrum as a closed Cantor-cube subspace. -/ +def IsBooleanStonePoint (f : B → Bool) : Prop := + f ⊥ = ⊥ ∧ f ⊤ = ⊤ ∧ + (∀ a b, f (a ⊓ b) = f a ⊓ f b) ∧ + (∀ a b, f (a ⊔ b) = f a ⊔ f b) + +/-- The Stone spectrum of a Boolean algebra, represented by its two-valued +bounded-lattice homomorphisms. -/ +abbrev BooleanStone := {f : B → Bool // IsBooleanStonePoint B f} + +/-- Proves that the Boolean-homomorphism equations define a closed subset of +the Cantor cube; used to obtain compactness of the Stone spectrum. -/ +theorem isClosed_isBooleanStonePoint : + IsClosed {f : B → Bool | IsBooleanStonePoint B f} := by + unfold IsBooleanStonePoint + repeat' apply IsClosed.inter + · exact isClosed_eq (continuous_apply ⊥) continuous_const + · exact isClosed_eq (continuous_apply ⊤) continuous_const + · change IsClosed ({f : B → Bool | ∀ a b, f (a ⊓ b) = f a ⊓ f b} : + Set (B → Bool)) + rw [show {f : B → Bool | ∀ a b, f (a ⊓ b) = f a ⊓ f b} = + ⋂ a, ⋂ b, {f : B → Bool | f (a ⊓ b) = f a ⊓ f b} by + ext f + simp] + exact isClosed_iInter fun a ↦ isClosed_iInter fun b ↦ + isClosed_eq (continuous_apply (a ⊓ b)) + (show Continuous (fun f : B → Bool ↦ f a ⊓ f b) by fun_prop) + · change IsClosed ({f : B → Bool | ∀ a b, f (a ⊔ b) = f a ⊔ f b} : + Set (B → Bool)) + rw [show {f : B → Bool | ∀ a b, f (a ⊔ b) = f a ⊔ f b} = + ⋂ a, ⋂ b, {f : B → Bool | f (a ⊔ b) = f a ⊔ f b} by + ext f + simp] + exact isClosed_iInter fun a ↦ isClosed_iInter fun b ↦ + isClosed_eq (continuous_apply (a ⊔ b)) + (show Continuous (fun f : B → Bool ↦ f a ⊔ f b) by fun_prop) + +/-- Compactness inherited from the closed realization inside the Cantor cube; +used throughout the continuous-function construction. -/ +noncomputable instance booleanStoneCompactSpace : CompactSpace (BooleanStone B) := + isCompact_iff_compactSpace.mp (isClosed_isBooleanStonePoint B).isCompact + +/-- The Stone spectrum is Hausdorff as a subspace of a product of discrete +two-point spaces. -/ +instance booleanStoneT2Space : T2Space (BooleanStone B) := inferInstance + +/-- The clopen set of Stone points evaluating a Boolean element to true; used +for the faithful Stone representation. -/ +def booleanStoneClopen (b : B) : Set (BooleanStone B) := + {x | x.1 b = true} + +/-- Shows that evaluation at a Boolean element defines a clopen subset of the +Stone spectrum; used for the clopen representation and its indicators. -/ +theorem isClopen_booleanStoneClopen (b : B) : + IsClopen (booleanStoneClopen B b) := + (isClopen_discrete {true}).preimage + ((continuous_apply b).comp continuous_subtype_val) + +/-- Bundles a Stone point as a bounded-lattice homomorphism; used to access +its algebraic laws uniformly. -/ +def booleanStoneHom (x : BooleanStone B) : BoundedLatticeHom B Bool where + toFun := x.1 + map_inf' := x.2.2.2.1 + map_sup' := x.2.2.2.2 + map_top' := x.2.2.1 + map_bot' := x.2.1 + +@[simp] theorem booleanStone_apply_bot (x : BooleanStone B) : x.1 ⊥ = false := + x.2.1 + +@[simp] theorem booleanStone_apply_top (x : BooleanStone B) : x.1 ⊤ = true := + x.2.2.1 + +@[simp] theorem booleanStone_apply_inf (x : BooleanStone B) (a b : B) : + x.1 (a ⊓ b) = x.1 a ⊓ x.1 b := x.2.2.2.1 a b + +@[simp] theorem booleanStone_apply_sup (x : BooleanStone B) (a b : B) : + x.1 (a ⊔ b) = x.1 a ⊔ x.1 b := x.2.2.2.2 a b + +@[simp] theorem booleanStone_apply_compl (x : BooleanStone B) (a : B) : + x.1 aᶜ = (x.1 a)ᶜ := by + exact map_compl' (booleanStoneHom B x) a + +/-- Constructs the Stone point associated with a prime ideal; used to separate +Boolean elements when an order relation fails. -/ +noncomputable def booleanStonePointOfPrime (J : Order.Ideal B) + (hJ : Order.Ideal.IsPrime J) : BooleanStone B := by + classical + exact ⟨fun b ↦ decide (b ∉ J), by + refine ⟨?_, ?_, ?_, ?_⟩ + · simp [J.bot_mem] + · simp [hJ.toIsProper.top_notMem] + · intro a b + by_cases ha : a ∈ J + · have hab : a ⊓ b ∈ J := J.lower inf_le_left ha + simp [ha, hab] + · by_cases hb : b ∈ J + · have hab : a ⊓ b ∈ J := J.lower inf_le_right hb + simp [ha, hb, hab] + · have hab : a ⊓ b ∉ J := fun h ↦ (hJ.mem_or_mem h).elim ha hb + simp [ha, hb, hab] + · intro a b + by_cases ha : a ∈ J + · by_cases hb : b ∈ J + · have hab : a ⊔ b ∈ J := J.sup_mem ha hb + simp [ha, hb, hab] + · have hab : a ⊔ b ∉ J := by + simp [Order.Ideal.sup_mem_iff, ha, hb] + simp [ha, hb, hab] + · have hab : a ⊔ b ∉ J := by + simp [Order.Ideal.sup_mem_iff, ha] + simp [ha, hab]⟩ + +/-- Separates a failed Boolean inequality by a Stone point; used to prove +faithfulness of the clopen representation. -/ +theorem exists_booleanStonePoint_of_not_le {a b : B} (hab : ¬ a ≤ b) : + ∃ x : BooleanStone B, x.1 a = true ∧ x.1 b = false := by + let F : Order.PFilter B := Order.PFilter.principal a + let I : Order.Ideal B := Order.Ideal.principal b + have hFI : Disjoint (F : Set B) (I : Set B) := by + rw [Set.disjoint_left] + intro c hcF hcI + exact hab ((Order.PFilter.mem_principal.mp hcF).trans + (Order.Ideal.mem_principal.mp hcI)) + rcases DistribLattice.prime_ideal_of_disjoint_filter_ideal hFI with + ⟨J, hJ, hIJ, hFJ⟩ + have hbJ : b ∈ J := hIJ Order.Ideal.mem_principal_self + have haJ : a ∉ J := by + intro haJ + exact Set.disjoint_left.mp hFJ (Order.PFilter.mem_principal.mpr le_rfl) haJ + refine ⟨booleanStonePointOfPrime B J hJ, ?_, ?_⟩ + · simp [booleanStonePointOfPrime, haJ] + · simp [booleanStonePointOfPrime, hbJ] + +/-- Identifies Boolean order with inclusion of the corresponding Stone +clopens; used for injectivity and order computations. -/ +theorem booleanStoneClopen_subset_iff {a b : B} : + booleanStoneClopen B a ⊆ booleanStoneClopen B b ↔ a ≤ b := by + constructor + · intro h + by_contra hab + rcases exists_booleanStonePoint_of_not_le B hab with ⟨x, hxa, hxb⟩ + exact Bool.false_ne_true (hxb.symm.trans (h hxa)) + · intro hab x hxa + change x.1 b = true + have hmap : x.1 a ≤ x.1 b := + OrderHomClass.monotone (booleanStoneHom B x) hab + rw [hxa] at hmap + exact top_unique hmap + +/-- Proves injectivity of the Stone clopen representation; used to embed the +complete Boolean algebra into continuous functions. -/ +theorem booleanStoneClopen_injective : + Function.Injective (booleanStoneClopen B) := by + intro a b hab + apply le_antisymm + · exact booleanStoneClopen_subset_iff B |>.mp (by rw [hab]) + · exact booleanStoneClopen_subset_iff B |>.mp (by rw [hab]) + +@[simp] theorem booleanStoneClopen_top : + booleanStoneClopen B ⊤ = Set.univ := by + ext x + simp [booleanStoneClopen] + +@[simp] theorem booleanStoneClopen_inf (a b : B) : + booleanStoneClopen B (a ⊓ b) = + booleanStoneClopen B a ∩ booleanStoneClopen B b := by + ext x + simp [booleanStoneClopen] + +@[simp] theorem booleanStoneClopen_compl (a : B) : + booleanStoneClopen B aᶜ = (booleanStoneClopen B a)ᶜ := by + ext x + simp [booleanStoneClopen] + +/-- Selects `b` or its complement according to a Stone coordinate; used to +encode signed finite cylinders as Boolean elements. -/ +def booleanStoneSignedCoordinate (x : BooleanStone B) (b : B) : B := + if x.1 b = true then b else bᶜ + +/-- Evaluates membership in a signed-coordinate cylinder through its Boolean +element; used to translate finite Cantor cylinders to Stone clopens. -/ +theorem booleanStoneClopen_signedCoordinate (x : BooleanStone B) (b : B) : + booleanStoneClopen B (booleanStoneSignedCoordinate B x b) = + {y | y.1 b = x.1 b} := by + ext y + by_cases hx : x.1 b = true + · simp [booleanStoneSignedCoordinate, hx, booleanStoneClopen] + · simp [booleanStoneSignedCoordinate, hx, booleanStoneClopen] + +/-- The finite meet encoding the Cantor cylinder through a Stone point; used +to produce represented clopen neighborhood bases. -/ +def booleanStoneCylinderElement (F : Finset B) (x : BooleanStone B) : B := + F.inf (booleanStoneSignedCoordinate B x) + +/-- Identifies a finite Stone-space cylinder with the clopen represented by +its Boolean cylinder element; used to prove the clopen basis theorem. -/ +theorem booleanStoneClopen_cylinderElement (F : Finset B) + (x : BooleanStone B) : + booleanStoneClopen B (booleanStoneCylinderElement B F x) = + {y | ∀ b ∈ F, y.1 b = x.1 b} := by + classical + induction F using Finset.induction_on with + | empty => simp [booleanStoneCylinderElement] + | @insert b F hb ih => + unfold booleanStoneCylinderElement + change booleanStoneClopen B (F.inf (booleanStoneSignedCoordinate B x)) = + {y | ∀ b ∈ F, y.1 b = x.1 b} at ih + rw [Finset.inf_insert, booleanStoneClopen_inf, + booleanStoneClopen_signedCoordinate, ih] + ext y + simp + +/-- Refines every neighborhood of a Stone point to a represented clopen; +used in extremal disconnectedness and point-separation arguments. -/ +theorem booleanStone_clopen_basis {U : Set (BooleanStone B)} + (hU : IsOpen U) {x : BooleanStone B} (hxU : x ∈ U) : + ∃ b : B, x ∈ booleanStoneClopen B b ∧ booleanStoneClopen B b ⊆ U := by + rcases isOpen_induced_iff.mp hU with ⟨V, hV, hVU⟩ + have hxV : x.1 ∈ V := by + have : x ∈ Subtype.val ⁻¹' V := by simpa [hVU] using hxU + exact this + rcases isOpen_pi_iff.mp hV x.1 hxV with ⟨F, v, hv, hvV⟩ + refine ⟨booleanStoneCylinderElement B F x, ?_, ?_⟩ + · rw [booleanStoneClopen_cylinderElement] + exact fun _ _ ↦ rfl + · intro y hy + have hycoord : ∀ b ∈ F, y.1 b = x.1 b := by + rwa [booleanStoneClopen_cylinderElement] at hy + have hyV : y.1 ∈ V := by + apply hvV + intro b hb + rw [hycoord b (Finset.mem_coe.mp hb)] + exact (hv b (Finset.mem_coe.mp hb)).2 + have : y ∈ Subtype.val ⁻¹' V := hyV + rwa [hVU] at this + +end BooleanStone + +section CompleteBooleanStone + +variable (B : Type u) [CompleteBooleanAlgebra B] + +/-- Supplies extremal disconnectedness from completeness of the Boolean +algebra; needed for continuous suprema in `C(BooleanStone B, ℝ)`. -/ +noncomputable instance booleanStoneExtremallyDisconnected : + ExtremallyDisconnected (BooleanStone B) where + open_closure U hU := by + let S : Set B := {b | booleanStoneClopen B b ⊆ U} + let c : B := sSup S + have hUc : U ⊆ booleanStoneClopen B c := by + intro x hxU + rcases booleanStone_clopen_basis B hU hxU with ⟨b, hxb, hbU⟩ + have hbS : b ∈ S := hbU + exact (booleanStoneClopen_subset_iff B).mpr (le_sSup hbS) hxb + have hclosure_le : closure U ⊆ booleanStoneClopen B c := + closure_minimal hUc (isClopen_booleanStoneClopen B c).1 + have hc_le : booleanStoneClopen B c ⊆ closure U := by + intro x hxc + by_contra hxclosure + have hxopen : x ∈ (closure U)ᶜ := hxclosure + rcases booleanStone_clopen_basis B (isOpen_compl_iff.mpr isClosed_closure) + hxopen with ⟨d, hxd, hd⟩ + have hcd : c ≤ dᶜ := by + apply sSup_le + intro b hbS + apply (booleanStoneClopen_subset_iff B).mp + intro y hyb + rw [booleanStoneClopen_compl] + intro hyd + have hyU : y ∈ U := hbS hyb + have hyclosure : y ∈ closure U := subset_closure hyU + exact (hd hyd) hyclosure + have hxccompl : x ∈ booleanStoneClopen B dᶜ := + (booleanStoneClopen_subset_iff B).mpr hcd hxc + rw [booleanStoneClopen_compl] at hxccompl + exact hxccompl hxd + rw [Set.Subset.antisymm hclosure_le hc_le] + exact (isClopen_booleanStoneClopen B c).2 + +end CompleteBooleanStone + +section OrderCompleteCofK + +variable (K : Type u) [TopologicalSpace K] [ExtremallyDisconnected K] + +/-- The union of strict rational upper-level sets of a function family; used +as the raw level set for the continuous supremum. -/ +def continuousFamilyLevelOpen (A : Set C(K, ℝ)) (q : ℚ) : Set K := + ⋃ f ∈ A, f ⁻¹' Set.Ioi (q : ℝ) + +omit [ExtremallyDisconnected K] in +/-- Shows that a rational strict upper-level set of a continuous family is +open; used to regularize level sets in the supremum construction. -/ +theorem isOpen_continuousFamilyLevelOpen (A : Set C(K, ℝ)) (q : ℚ) : + IsOpen (continuousFamilyLevelOpen K A q) := by + apply isOpen_iUnion + intro f + apply isOpen_iUnion + intro hf + exact isOpen_Ioi.preimage f.continuous + +/-- The closure of a family level set, made clopen by extremal disconnectedness; +used to define pointwise rational cuts. -/ +def continuousFamilyRegularizedLevel (A : Set C(K, ℝ)) (q : ℚ) : Set K := + closure (continuousFamilyLevelOpen K A q) + +/-- Uses extremal disconnectedness to make regularized family level sets +clopen; needed to assemble a continuous supremum. -/ +theorem isClopen_continuousFamilyRegularizedLevel + (A : Set C(K, ℝ)) (q : ℚ) : + IsClopen (continuousFamilyRegularizedLevel K A q) := + ⟨isClosed_closure, ExtremallyDisconnected.open_closure _ + (isOpen_continuousFamilyLevelOpen K A q)⟩ + +/-- Rational thresholds whose regularized level contains `x`; their supremum +defines the candidate least upper bound. -/ +def continuousFamilyCutValues (A : Set C(K, ℝ)) (x : K) : Set ℝ := + ((fun q : ℚ ↦ (q : ℝ)) '' + {q | x ∈ continuousFamilyRegularizedLevel K A q}) + +/-- The real supremum of the rational cut values at a point; later shown +continuous and bundled as `continuousFamilySup`. -/ +noncomputable def continuousFamilySupValue (A : Set C(K, ℝ)) (x : K) : ℝ := + sSup (continuousFamilyCutValues K A x) + +omit [ExtremallyDisconnected K] in +/-- Shows that regularized upper-level sets decrease with the threshold; used +to prove consistency of the cut-value construction. -/ +theorem continuousFamilyRegularizedLevel_antitone (A : Set C(K, ℝ)) : + Antitone (continuousFamilyRegularizedLevel K A) := by + intro q r hqr + apply closure_mono + intro x hx + simp only [continuousFamilyLevelOpen, Set.mem_iUnion, Set.mem_preimage, + Set.mem_Ioi] at hx ⊢ + rcases hx with ⟨f, hfA, hrfx⟩ + exact ⟨f, hfA, (Rat.cast_le.mpr hqr).trans_lt hrfx⟩ + +omit [ExtremallyDisconnected K] in +/-- Supplies rational cut values at each point for a nonempty family; needed +to define the pointwise cut supremum. -/ +theorem continuousFamilyCutValues_nonempty {A : Set C(K, ℝ)} + (hA : A.Nonempty) (x : K) : (continuousFamilyCutValues K A x).Nonempty := by + rcases hA with ⟨f, hfA⟩ + rcases exists_rat_lt (f x) with ⟨q, hq⟩ + refine ⟨(q : ℝ), ⟨q, ?_, rfl⟩⟩ + apply subset_closure + simp only [continuousFamilyLevelOpen, Set.mem_iUnion, Set.mem_preimage, + Set.mem_Ioi] + exact ⟨f, hfA, hq⟩ + +omit [ExtremallyDisconnected K] in +/-- Bounds the rational cut values using a common upper bound of the family; +used to make their real supremum well-defined. -/ +theorem continuousFamilyCutValues_bddAbove {A : Set C(K, ℝ)} + {h : C(K, ℝ)} (hh : h ∈ upperBounds A) (x : K) : + BddAbove (continuousFamilyCutValues K A x) := by + refine ⟨h x, ?_⟩ + rintro r ⟨q, hxq, rfl⟩ + have hopen_le : continuousFamilyLevelOpen K A q ⊆ + h ⁻¹' Set.Ici (q : ℝ) := by + intro y hy + simp only [continuousFamilyLevelOpen, Set.mem_iUnion, Set.mem_preimage, + Set.mem_Ioi] at hy + rcases hy with ⟨f, hfA, hqf⟩ + exact le_of_lt (hqf.trans_le (hh hfA y)) + have hclosed : IsClosed (h ⁻¹' Set.Ici (q : ℝ)) := + isClosed_Ici.preimage h.continuous + exact (closure_minimal hopen_le hclosed hxq) + +omit [ExtremallyDisconnected K] in +/-- Bounds every cut value by any continuous upper bound of the family; used +to prove minimality of the constructed supremum. -/ +theorem continuousFamilyCutValue_le_upperBound {A : Set C(K, ℝ)} + (hA : A.Nonempty) {h : C(K, ℝ)} (hh : h ∈ upperBounds A) (x : K) : + continuousFamilySupValue K A x ≤ h x := by + apply csSup_le (continuousFamilyCutValues_nonempty K hA x) + rintro r ⟨q, hxq, rfl⟩ + have hopen_le : continuousFamilyLevelOpen K A q ⊆ + h ⁻¹' Set.Ici (q : ℝ) := by + intro y hy + simp only [continuousFamilyLevelOpen, Set.mem_iUnion, Set.mem_preimage, + Set.mem_Ioi] at hy + rcases hy with ⟨f, hfA, hqf⟩ + exact le_of_lt (hqf.trans_le (hh hfA y)) + exact closure_minimal hopen_le (isClosed_Ici.preimage h.continuous) hxq + +/-- Proves continuity of the cut-defined supremum value; this allows it to be +bundled as `continuousFamilySup`. -/ +theorem continuous_continuousFamilySupValue {A : Set C(K, ℝ)} + (hA : A.Nonempty) (hAbdd : BddAbove A) : + Continuous (continuousFamilySupValue K A) := by + rcases hAbdd with ⟨h, hh⟩ + apply continuous_iff_lower_upperSemicontinuous.mpr + constructor + · rw [lowerSemicontinuous_iff_isOpen_preimage] + intro a + rw [show continuousFamilySupValue K A ⁻¹' Set.Ioi a = + ⋃ q : ℚ, ⋃ (_ : a < (q : ℝ)), + continuousFamilyRegularizedLevel K A q by + ext x + constructor + · intro hx + have hbdd := continuousFamilyCutValues_bddAbove K hh x + have hne := continuousFamilyCutValues_nonempty K hA x + rcases (lt_csSup_iff hbdd hne).mp hx with ⟨r, hr, har⟩ + rcases hr with ⟨q, hxq, rfl⟩ + simp only [Set.mem_iUnion] + exact ⟨q, har, hxq⟩ + · simp only [Set.mem_iUnion] + rintro ⟨q, haq, hxq⟩ + exact haq.trans_le (le_csSup + (continuousFamilyCutValues_bddAbove K hh x) ⟨q, hxq, rfl⟩)] + apply isOpen_iUnion + intro q + apply isOpen_iUnion + intro haq + exact (isClopen_continuousFamilyRegularizedLevel K A q).2 + · rw [upperSemicontinuous_iff_isOpen_preimage] + intro a + rw [show continuousFamilySupValue K A ⁻¹' Set.Iio a = + ⋃ q : ℚ, ⋃ (_ : (q : ℝ) < a), + (continuousFamilyRegularizedLevel K A q)ᶜ by + ext x + constructor + · intro hx + change continuousFamilySupValue K A x < a at hx + rcases exists_rat_btwn hx with ⟨q, hgq, hqa⟩ + simp only [Set.mem_iUnion, Set.mem_compl_iff] + refine ⟨q, hqa, ?_⟩ + intro hxq + have hqg : (q : ℝ) ≤ continuousFamilySupValue K A x := + le_csSup (continuousFamilyCutValues_bddAbove K hh x) + ⟨q, hxq, rfl⟩ + exact (not_le_of_gt hgq) hqg + · simp only [Set.mem_iUnion, Set.mem_compl_iff] + rintro ⟨q, hqa, hxq⟩ + have hgq : continuousFamilySupValue K A x ≤ (q : ℝ) := by + apply csSup_le (continuousFamilyCutValues_nonempty K hA x) + rintro r ⟨q', hxq', rfl⟩ + by_contra hq'q + have hqq' : q < q' := Rat.cast_lt.mp (lt_of_not_ge hq'q) + exact hxq (continuousFamilyRegularizedLevel_antitone K A + (le_of_lt hqq') hxq') + exact hgq.trans_lt hqa] + apply isOpen_iUnion + intro q + apply isOpen_iUnion + intro hqa + exact (isClopen_continuousFamilyRegularizedLevel K A q).1.isOpen_compl + +/-- Bundles the cut-defined pointwise supremum as a continuous function; used +to prove order completeness of the continuous-function lattice. -/ +noncomputable def continuousFamilySup (A : Set C(K, ℝ)) + (hA : A.Nonempty) (hAbdd : BddAbove A) : C(K, ℝ) := + ⟨continuousFamilySupValue K A, + continuous_continuousFamilySupValue K hA hAbdd⟩ + +/-- Verifies that the constructed continuous function is the least upper bound +of the family; used to prove order completeness of `C(K, ℝ)`. -/ +theorem continuousFamilySup_isLUB (A : Set C(K, ℝ)) + (hA : A.Nonempty) (hAbdd : BddAbove A) : + IsLUB A (continuousFamilySup K A hA hAbdd) := by + rcases hAbdd with ⟨h, hh⟩ + constructor + · intro f hfA x + change f x ≤ continuousFamilySupValue K A x + by_contra hfg + have hgf : continuousFamilySupValue K A x < f x := lt_of_not_ge hfg + rcases exists_rat_btwn hgf with ⟨q, hgq, hqf⟩ + have hxq : x ∈ continuousFamilyRegularizedLevel K A q := by + apply subset_closure + simp only [continuousFamilyLevelOpen, Set.mem_iUnion, Set.mem_preimage, + Set.mem_Ioi] + exact ⟨f, hfA, hqf⟩ + have hqg : (q : ℝ) ≤ continuousFamilySupValue K A x := + le_csSup (continuousFamilyCutValues_bddAbove K hh x) + ⟨q, hxq, rfl⟩ + exact (not_le_of_gt hgq) hqg + · intro k hk x + exact continuousFamilyCutValue_le_upperBound K hA hk x + +/-- Packages the continuous-family supremum construction as order completeness +of continuous real functions on an extremally disconnected compact space. -/ +theorem isOrderComplete_continuousMap : IsOrderComplete C(K, ℝ) := by + intro A hA hAbdd + exact ⟨continuousFamilySup K A hA hAbdd, + continuousFamilySup_isLUB K A hA hAbdd⟩ + +end OrderCompleteCofK + +section ClopenIndicators + +variable (K : Type u) [TopologicalSpace K] + +/-- The continuous zero-one indicator of a clopen set; used to embed Boolean +clopens into the vector lattice of continuous functions. -/ +noncomputable def clopenIndicator (s : Set K) (hs : IsClopen s) : C(K, ℝ) where + toFun := s.indicator 1 + continuous_toFun := + continuous_indicator (by simp [hs]) continuous_const.continuousOn + +@[simp] theorem clopenIndicator_apply_mem (s : Set K) (hs : IsClopen s) + {x : K} (hx : x ∈ s) : clopenIndicator K s hs x = 1 := by + simp [clopenIndicator, hx] + +@[simp] theorem clopenIndicator_apply_notMem (s : Set K) (hs : IsClopen s) + {x : K} (hx : x ∉ s) : clopenIndicator K s hs x = 0 := by + simp [clopenIndicator, hx] + +@[simp] theorem clopenIndicator_empty : + clopenIndicator K ∅ isClopen_empty = 0 := by + ext x + simp [clopenIndicator] + +/-- Computes the infimum of two clopen indicators; used to make Boolean +indicators compatible with lattice operations. -/ +theorem clopenIndicator_inter (s t : Set K) (hs : IsClopen s) (ht : IsClopen t) : + clopenIndicator K (s ∩ t) (hs.inter ht) = + clopenIndicator K s hs ⊓ clopenIndicator K t ht := by + ext x + by_cases hxs : x ∈ s <;> by_cases hxt : x ∈ t <;> + simp [clopenIndicator, hxs, hxt] + +/-- Computes the supremum of two clopen indicators; used in the Boolean-to- +vector-sublattice transfer. -/ +theorem clopenIndicator_union (s t : Set K) (hs : IsClopen s) (ht : IsClopen t) : + clopenIndicator K (s ∪ t) (hs.union ht) = + clopenIndicator K s hs ⊔ clopenIndicator K t ht := by + ext x + by_cases hxs : x ∈ s <;> by_cases hxt : x ∈ t <;> + simp [clopenIndicator, hxs, hxt] + +/-- Computes the indicator of a clopen complement; used to recover Boolean +complements inside a vector sublattice. -/ +theorem clopenIndicator_compl (s : Set K) (hs : IsClopen s) : + clopenIndicator K sᶜ hs.compl = 1 - clopenIndicator K s hs := by + ext x + by_cases hxs : x ∈ s <;> simp [clopenIndicator, hxs] + +end ClopenIndicators + +section BooleanStoneIndicators + +variable (B : Type u) [CompleteBooleanAlgebra B] + +/-- The continuous indicator associated with a Boolean element under Stone +duality; used as the Boolean generator inside the vector lattice. -/ +noncomputable def booleanStoneIndicator (b : B) : C(BooleanStone B, ℝ) := + clopenIndicator (BooleanStone B) (booleanStoneClopen B b) + (isClopen_booleanStoneClopen B b) + +@[simp] theorem booleanStoneIndicator_apply (b : B) (x : BooleanStone B) : + booleanStoneIndicator B b x = if x.1 b = true then 1 else 0 := by + by_cases hxb : x.1 b = true + · simp [booleanStoneIndicator, booleanStoneClopen, hxb] + · simp [booleanStoneIndicator, booleanStoneClopen, hxb] + +@[simp] theorem booleanStoneIndicator_bot : booleanStoneIndicator B ⊥ = 0 := by + ext x + simp [booleanStoneIndicator_apply] + +@[simp] theorem booleanStoneIndicator_inf (a b : B) : + booleanStoneIndicator B (a ⊓ b) = + booleanStoneIndicator B a ⊓ booleanStoneIndicator B b := by + ext x + by_cases ha : x.1 a = true <;> by_cases hb : x.1 b = true <;> + simp [booleanStoneIndicator_apply, ha, hb] + +@[simp] theorem booleanStoneIndicator_sup (a b : B) : + booleanStoneIndicator B (a ⊔ b) = + booleanStoneIndicator B a ⊔ booleanStoneIndicator B b := by + ext x + by_cases ha : x.1 a = true <;> by_cases hb : x.1 b = true <;> + simp [booleanStoneIndicator_apply, ha, hb] + +@[simp] theorem booleanStoneIndicator_compl (a : B) : + booleanStoneIndicator B aᶜ = 1 - booleanStoneIndicator B a := by + ext x + by_cases ha : x.1 a = true <;> simp [booleanStoneIndicator_apply, ha] + +/-- Shows that arbitrary Boolean suprema correspond to closures of unions of +Stone clopens; used to transfer completeness into vector sublattices. -/ +theorem booleanStoneClopen_sSup (S : Set B) : + booleanStoneClopen B (sSup S) = + closure (⋃ b ∈ S, booleanStoneClopen B b) := by + apply Set.Subset.antisymm + · intro x hxs + by_contra hxclosure + have hxopen : x ∈ (closure (⋃ b ∈ S, booleanStoneClopen B b))ᶜ := + hxclosure + rcases booleanStone_clopen_basis B (isOpen_compl_iff.mpr isClosed_closure) + hxopen with ⟨d, hxd, hd⟩ + have hsd : sSup S ≤ dᶜ := by + apply sSup_le + intro b hbS + apply (booleanStoneClopen_subset_iff B).mp + intro y hyb + rw [booleanStoneClopen_compl] + intro hyd + have hyunion : y ∈ ⋃ c ∈ S, booleanStoneClopen B c := by + simp only [Set.mem_iUnion] + exact ⟨b, hbS, hyb⟩ + exact (hd hyd) (subset_closure hyunion) + have hxcomp : x ∈ booleanStoneClopen B dᶜ := + (booleanStoneClopen_subset_iff B).mpr hsd hxs + rw [booleanStoneClopen_compl] at hxcomp + exact hxcomp hxd + · apply closure_minimal + · intro x hx + simp only [Set.mem_iUnion] at hx + rcases hx with ⟨b, hbS, hxb⟩ + exact (booleanStoneClopen_subset_iff B).mpr (le_sSup hbS) hxb + · exact (isClopen_booleanStoneClopen B (sSup S)).1 + +/-- Transfers Boolean order to order between indicator functions; used in +order-convergence and sublattice generation arguments. -/ +theorem booleanStoneIndicator_mono {a b : B} (hab : a ≤ b) : + booleanStoneIndicator B a ≤ booleanStoneIndicator B b := by + intro x + by_cases hxa : x ∈ booleanStoneClopen B a + · have hxb : x ∈ booleanStoneClopen B b := + (booleanStoneClopen_subset_iff B).mpr hab hxa + simp [booleanStoneIndicator, hxa, hxb] + · have hnonneg : (0 : ℝ) ≤ booleanStoneIndicator B b x := by + by_cases hxb : x ∈ booleanStoneClopen B b <;> + simp [booleanStoneIndicator, hxb] + simpa [booleanStoneIndicator, hxa] using hnonneg + +/-- Records positivity of Boolean Stone indicators; used when constructing +monotone order-convergent families. -/ +theorem booleanStoneIndicator_nonneg (a : B) : + (0 : C(BooleanStone B, ℝ)) ≤ booleanStoneIndicator B a := by + intro x + by_cases hxa : x ∈ booleanStoneClopen B a <;> + simp [booleanStoneIndicator, hxa] + +/-- Boolean elements whose Stone indicators lie in a fixed vector sublattice; +used to transfer complete Boolean generation to vector-lattice generation. -/ +noncomputable def booleanSubalgebraInVectorSublattice + (Z : VectorSublattice C(BooleanStone B, ℝ)) + (hOne : (1 : C(BooleanStone B, ℝ)) ∈ Z) : BooleanSubalgebra B where + carrier := {b | booleanStoneIndicator B b ∈ Z} + supClosed' := by + intro a ha b hb + change booleanStoneIndicator B a ∈ Z at ha + change booleanStoneIndicator B b ∈ Z at hb + change booleanStoneIndicator B (a ⊔ b) ∈ Z + rw [booleanStoneIndicator_sup] + exact Z.sup_mem ha hb + infClosed' := by + intro a ha b hb + change booleanStoneIndicator B a ∈ Z at ha + change booleanStoneIndicator B b ∈ Z at hb + change booleanStoneIndicator B (a ⊓ b) ∈ Z + rw [booleanStoneIndicator_inf] + exact Z.inf_mem ha hb + compl_mem' := by + intro a ha + change booleanStoneIndicator B a ∈ Z at ha + change booleanStoneIndicator B aᶜ ∈ Z + rw [booleanStoneIndicator_compl] + exact Z.sub_mem hOne ha + bot_mem' := by + change booleanStoneIndicator B ⊥ ∈ Z + rw [booleanStoneIndicator_bot] + exact Z.zero_mem + +/-- Shows that Boolean elements whose indicators lie in a vector sublattice +form a complete Boolean subalgebra; used with Solovay generation for maximality. -/ +theorem booleanSubalgebraInVectorSublattice_complete + (Z : VectorSublattice C(BooleanStone B, ℝ)) + (hOne : (1 : C(BooleanStone B, ℝ)) ∈ Z) + (hZclosed : IsOrderClosed (Z : Set C(BooleanStone B, ℝ))) : + IsCompleteBooleanSubalgebra + (booleanSubalgebraInVectorSublattice B Z hOne) := by + intro S hS + by_cases hSne : S.Nonempty + · classical + let I := {F : Finset S // F.Nonempty} + let b₀ : S := ⟨hSne.some, hSne.some_mem⟩ + let F₀ : I := ⟨{b₀}, Finset.singleton_nonempty b₀⟩ + let : Nonempty I := ⟨F₀⟩ + let : IsDirected I (· ≤ ·) := ⟨fun F G ↦ + ⟨⟨F.1 ∪ G.1, F.2.mono Finset.subset_union_left⟩, + Finset.subset_union_left, Finset.subset_union_right⟩⟩ + let u : I → C(BooleanStone B, ℝ) := fun F ↦ + F.1.sup' F.2 (fun b ↦ booleanStoneIndicator B b.1) + have huZ : ∀ F, u F ∈ Z := by + intro F + apply Finset.sup'_mem (Z : Set C(BooleanStone B, ℝ)) + (fun _ hx _ hy ↦ Z.sup_mem hx hy) F.1 F.2 + intro b hb + exact hS b.2 + have humono : Monotone u := by + intro F G hFG + change F.1.sup' F.2 (fun b ↦ booleanStoneIndicator B b.1) ≤ + G.1.sup' G.2 (fun b ↦ booleanStoneIndicator B b.1) + exact Finset.sup'_mono + (f := fun b : S ↦ booleanStoneIndicator B b.1) + (s₁ := F.1) (s₂ := G.1) hFG F.2 + have hlub : IsLUB (Set.range u) (booleanStoneIndicator B (sSup S)) := by + constructor + · rintro _ ⟨F, rfl⟩ + apply Finset.sup'_le + intro b hb + exact booleanStoneIndicator_mono B (le_sSup b.2) + · intro k hk + have hkzero : (0 : C(BooleanStone B, ℝ)) ≤ k := by + have hF₀k : u F₀ ≤ k := hk ⟨F₀, rfl⟩ + exact (booleanStoneIndicator_nonneg B b₀.1).trans (by + simpa [u, F₀] using hF₀k) + intro x + by_cases hxs : x ∈ booleanStoneClopen B (sSup S) + · have hxclosure : x ∈ closure + (⋃ b ∈ S, booleanStoneClopen B b) := by + rwa [← booleanStoneClopen_sSup] + have hclosed : IsClosed {y : BooleanStone B | (1 : ℝ) ≤ k y} := + isClosed_le continuous_const k.continuous + have hunion : (⋃ b ∈ S, booleanStoneClopen B b) ⊆ + {y : BooleanStone B | (1 : ℝ) ≤ k y} := by + intro y hy + simp only [Set.mem_iUnion] at hy + rcases hy with ⟨b, hbS, hyb⟩ + let bs : S := ⟨b, hbS⟩ + let Fs : I := ⟨{bs}, Finset.singleton_nonempty bs⟩ + have hbind : booleanStoneIndicator B b ≤ k := by + have hk' := hk ⟨Fs, rfl⟩ + simpa [u, Fs, bs] using hk' + have := hbind y + simpa [booleanStoneIndicator, hyb] using this + have hxone : (1 : ℝ) ≤ k x := + closure_minimal hunion hclosed hxclosure + simpa [booleanStoneIndicator, hxs] using hxone + · have hxzero := hkzero x + simpa [booleanStoneIndicator, hxs] using hxzero + have hconv : OrderConvergesTo u (booleanStoneIndicator B (sSup S)) := + orderConvergesTo_of_monotone_isLUB humono hlub + apply hZclosed + exact ⟨I, inferInstance, inferInstance, inferInstance, u, huZ, hconv⟩ + · have hSempty : S = ∅ := Set.not_nonempty_iff_eq_empty.mp hSne + subst S + simp + +end BooleanStoneIndicators + +end OrderClosures + +namespace OrderClosures + +universe u v + +section ClosedOrderSublattices + +variable {K : Type u} [TopologicalSpace K] [CompactSpace K] + +/-- Converts uniform convergence with a summable error bound into order +convergence; used to show order-closed sublattices are norm closed. -/ +theorem continuousMap_orderConvergesTo_of_tendsto + {ι : Type v} [Preorder ι] {f : ι → C(K, ℝ)} {x : C(K, ℝ)} + (hfx : Filter.Tendsto f Filter.atTop (nhds x)) : + OrderConvergesTo f x := by + let r : ℕ → C(K, ℝ) := fun n ↦ + ContinuousMap.const K (((n : ℝ) + 1)⁻¹) + have hranti : Antitone r := by + intro m n hmn y + simp only [r] + exact inv_anti₀ (by positivity) + (by exact_mod_cast Nat.add_le_add_right hmn 1) + have hrnonneg : ∀ n, (0 : C(K, ℝ)) ≤ r n := by + intro n y + simp only [r] + exact inv_nonneg.mpr (add_nonneg (Nat.cast_nonneg _) zero_le_one) + have hscalar : Filter.Tendsto (fun n : ℕ ↦ (((n : ℝ) + 1)⁻¹)) + Filter.atTop (nhds 0) := by + simpa only [one_div] using + (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ)) + have hrglb : IsGLB (Set.range r) 0 := by + constructor + · rintro _ ⟨n, rfl⟩ + exact hrnonneg n + · intro z hz y + apply ge_of_tendsto' hscalar + intro n + simpa [r] using hz ⟨n, rfl⟩ y + let κ := ULift.{u} ℕ + let r' : κ → C(K, ℝ) := fun n ↦ r n.down + have hrange : Set.range r' = Set.range r := by + ext z + simp only [Set.mem_range, r'] + constructor + · rintro ⟨n, rfl⟩ + exact ⟨n.down, rfl⟩ + · rintro ⟨n, rfl⟩ + exact ⟨ULift.up n, rfl⟩ + refine ⟨κ, inferInstance, inferInstance, inferInstance, r', ?_, ?_, ?_, ?_⟩ + · intro m n hmn + exact hranti hmn + · intro n + exact hrnonneg n.down + · rw [hrange] + exact hrglb + intro k + have hkpos : 0 < (((k.down : ℝ) + 1)⁻¹) := by positivity + have hevent : ∀ᶠ n in Filter.atTop, + f n ∈ Metric.ball x (((k.down : ℝ) + 1)⁻¹) := + hfx (Metric.ball_mem_nhds x hkpos) + filter_upwards [hevent] with n hn + intro y + have hnorm : ‖f n - x‖ < (((k.down : ℝ) + 1)⁻¹) := by + simpa only [Metric.mem_ball, dist_eq_norm] using hn + calc + |(f n - x) y| ≤ ‖f n - x‖ := by + simpa only [Real.norm_eq_abs] using + (ContinuousMap.norm_coe_le_norm (f n - x) y) + _ ≤ (((k.down : ℝ) + 1)⁻¹) := hnorm.le + _ = r' k y := by simp [r', r] + +/-- Derives norm closedness of a vector sublattice from order closedness; used +to compare the closed separable sublattice with larger order-closed ones. -/ +theorem isClosed_of_isOrderClosed_vectorSublattice + (Z : VectorSublattice C(K, ℝ)) + (hZ : IsOrderClosed (Z : Set C(K, ℝ))) : + IsClosed (Z : Set C(K, ℝ)) := by + apply IsSeqClosed.isClosed + intro f x hfZ hfx + apply hZ + let ι := ULift.{u} ℕ + let f' : ι → C(K, ℝ) := fun n ↦ f n.down + have hdown : Filter.Tendsto (fun n : ι ↦ n.down) + Filter.atTop Filter.atTop := by + refine Filter.tendsto_atTop.2 fun n ↦ ?_ + filter_upwards [Filter.eventually_ge_atTop (ULift.up n)] with m hm + exact hm + have hf'tend : Filter.Tendsto f' Filter.atTop (nhds x) := by + exact hfx.comp hdown + exact ⟨ι, inferInstance, inferInstance, inferInstance, f', + (fun n ↦ hfZ n.down), continuousMap_orderConvergesTo_of_tendsto hf'tend⟩ + +end ClosedOrderSublattices + +section BooleanIndicatorsGenerate + +variable (B : Type u) [CompleteBooleanAlgebra B] + +/-- Produces a Boolean indicator separating two distinct Stone points; used +in the lattice Stone--Weierstrass argument. -/ +theorem booleanStoneIndicators_separateStrongly + (Z : VectorSublattice C(BooleanStone B, ℝ)) + (hOne : (1 : C(BooleanStone B, ℝ)) ∈ Z) + (hIndicator : ∀ b, booleanStoneIndicator B b ∈ Z) : + (Z : Set C(BooleanStone B, ℝ)).SeparatesPointsStrongly := by + intro v x y + by_cases hxy : x = y + · subst y + refine ⟨v x • (1 : C(BooleanStone B, ℝ)), + Z.toSubmodule.smul_mem (v x) hOne, ?_, ?_⟩ + all_goals simp + · have hxyfun : x.1 ≠ y.1 := by + intro h + exact hxy (Subtype.ext h) + obtain ⟨b, hb⟩ := Function.ne_iff.mp hxyfun + cases hxb : x.1 b <;> cases hyb : y.1 b + · exact False.elim (hb (by simp [hxb, hyb])) + · let g := (v y - v x) • booleanStoneIndicator B b + + v x • (1 : C(BooleanStone B, ℝ)) + refine ⟨g, Z.add_mem + (Z.toSubmodule.smul_mem (v y - v x) (hIndicator b)) + (Z.toSubmodule.smul_mem (v x) hOne), ?_, ?_⟩ + · simp [g, booleanStoneIndicator_apply, hxb] + · simp [g, booleanStoneIndicator_apply, hyb] + · let g := (v x - v y) • booleanStoneIndicator B b + + v y • (1 : C(BooleanStone B, ℝ)) + refine ⟨g, Z.add_mem + (Z.toSubmodule.smul_mem (v x - v y) (hIndicator b)) + (Z.toSubmodule.smul_mem (v y) hOne), ?_, ?_⟩ + · simp [g, booleanStoneIndicator_apply, hxb] + · simp [g, booleanStoneIndicator_apply, hyb] + · exact False.elim (hb (by simp [hxb, hyb])) + +/-- Shows that a closed vector sublattice containing every Boolean indicator +is all of `C(K, ℝ)`; used to prove maximality of the Solovay sublattice. -/ +theorem vectorSublattice_eq_top_of_booleanStoneIndicators + (Z : VectorSublattice C(BooleanStone B, ℝ)) + (hOne : (1 : C(BooleanStone B, ℝ)) ∈ Z) + (hIndicator : ∀ b, booleanStoneIndicator B b ∈ Z) + (hZorder : IsOrderClosed (Z : Set C(BooleanStone B, ℝ))) : + Z = ⊤ := by + have hZclosed : IsClosed (Z : Set C(BooleanStone B, ℝ)) := + isClosed_of_isOrderClosed_vectorSublattice Z hZorder + have hclosure : closure (Z : Set C(BooleanStone B, ℝ)) = ⊤ := + ContinuousMap.sublattice_closure_eq_top (Z : Set C(BooleanStone B, ℝ)) + ⟨0, Z.zero_mem⟩ + (fun f hf g hg ↦ Z.inf_mem hf hg) + (fun f hf g hg ↦ Z.sup_mem hf hg) + (booleanStoneIndicators_separateStrongly B Z hOne hIndicator) + refine le_antisymm + (show Z ≤ (⊤ : VectorSublattice C(BooleanStone B, ℝ)) from + fun _ _ ↦ trivial) ?_ + intro f hf + have hfclosure : f ∈ closure (Z : Set C(BooleanStone B, ℝ)) := by + rw [hclosure] + trivial + rwa [hZclosed.closure_eq] at hfclosure + +end BooleanIndicatorsGenerate + +section DensityCharacter + +/-- Bounds density character below by the cardinality of a one-separated +family; used for the Stone-space continuous-function density estimate. -/ +theorem cardinalMk_le_densityCharacter_of_oneSeparated + {A : Type u} {X : Type u} [PseudoMetricSpace X] + (e : A → X) (hsep : ∀ a b, a ≠ b → (1 : ℝ) ≤ dist (e a) (e b)) : + Cardinal.mk A ≤ densityCharacter X := by + unfold densityCharacter + apply le_csInf + · exact ⟨Cardinal.mk (Set.univ : Set X), Set.univ, dense_univ, rfl⟩ + · intro c hc + rcases hc with ⟨D, hDdense, rfl⟩ + have hthird : (0 : ℝ) < 1 / 3 := by norm_num + choose d hdD hdclose using fun a ↦ hDdense.exists_dist_lt (e a) hthird + let φ : A → D := fun a ↦ ⟨d a, hdD a⟩ + apply Cardinal.mk_le_of_injective (f := φ) + intro a b hab + by_contra hne + have hval : d a = d b := congrArg Subtype.val hab + have hone : (1 : ℝ) ≤ dist (e a) (e b) := hsep a b hne + have hlt : dist (e a) (e b) < 1 := by + calc + dist (e a) (e b) ≤ dist (e a) (d a) + dist (d a) (e b) := + dist_triangle _ _ _ + _ = dist (e a) (d a) + dist (e b) (d b) := by + rw [hval, dist_comm (d b) (e b)] + _ < 1 / 3 + 1 / 3 := add_lt_add (hdclose a) (hdclose b) + _ < 1 := by norm_num + exact (not_lt_of_ge hone) hlt + +/-- Shows distinct Boolean elements give indicators at distance at least one; +used to obtain a large separated family. -/ +theorem one_le_dist_booleanStoneIndicator + (B : Type u) [CompleteBooleanAlgebra B] {a b : B} (hab : a ≠ b) : + (1 : ℝ) ≤ dist (booleanStoneIndicator B a) (booleanStoneIndicator B b) := by + rw [dist_eq_norm] + by_cases hle : a ≤ b + · have hnle : ¬ b ≤ a := fun hba ↦ hab (le_antisymm hle hba) + rcases exists_booleanStonePoint_of_not_le B hnle with ⟨x, hxb, hxa⟩ + calc + (1 : ℝ) = ‖(booleanStoneIndicator B a - booleanStoneIndicator B b) x‖ := by + simp [booleanStoneIndicator_apply, hxa, hxb] + _ ≤ ‖booleanStoneIndicator B a - booleanStoneIndicator B b‖ := + ContinuousMap.norm_coe_le_norm _ _ + · rcases exists_booleanStonePoint_of_not_le B hle with ⟨x, hxa, hxb⟩ + calc + (1 : ℝ) = ‖(booleanStoneIndicator B a - booleanStoneIndicator B b) x‖ := by + simp [booleanStoneIndicator_apply, hxa, hxb] + _ ≤ ‖booleanStoneIndicator B a - booleanStoneIndicator B b‖ := + ContinuousMap.norm_coe_le_norm _ _ + +/-- Transfers the size of a Boolean algebra to a lower bound on the density +character of its continuous-function lattice. -/ +theorem cardinalMk_le_densityCharacter_booleanStoneContinuousMap + (B : Type u) [CompleteBooleanAlgebra B] : + Cardinal.mk B ≤ densityCharacter C(BooleanStone B, ℝ) := + cardinalMk_le_densityCharacter_of_oneSeparated (booleanStoneIndicator B) + (fun _ _ ↦ one_le_dist_booleanStoneIndicator B) + +end DensityCharacter + +section SolovayVectorSublattice + +variable (Gamma : Type u) [LinearOrder Gamma] [WellFoundedLT Gamma] + [TopologicalSpace Gamma] [DiscreteTopology Gamma] + +/-- A countable selection of Boolean Stone indicators generating the Solovay +vector sublattice used in the Gao counterexample. -/ +noncomputable def solovayVectorGenerators : + Set C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ) := + Set.range (fun p : ℕ × ℕ ↦ + booleanStoneIndicator (RegularOpen (SolovayProduct Gamma)) + (solovayB Gamma p.1 p.2)) ∪ {1} + +/-- The closed vector sublattice generated by the selected Solovay indicators; +this is the separable maximal order-closed witness. -/ +noncomputable def solovayVectorSublattice : + VectorSublattice C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ) := + VectorSublattice.topologicalClosure + (VectorSublattice.generated (solovayVectorGenerators Gamma)) + +omit [WellFoundedLT Gamma] in +/-- Records countability of the selected vector generators; used to prove +separability of their closed generated sublattice. -/ +theorem solovayVectorGenerators_countable : + (solovayVectorGenerators Gamma).Countable := by + exact Set.countable_range _ |>.union (Set.countable_singleton _) + +omit [WellFoundedLT Gamma] in +/-- Places each selected generator in the Solovay vector sublattice; used to +show that any containing sublattice contains the generated Boolean algebra. -/ +theorem solovayVectorGenerator_mem + {f : C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ)} + (hf : f ∈ solovayVectorGenerators Gamma) : + f ∈ solovayVectorSublattice Gamma := by + exact + (VectorSublattice.generated + (solovayVectorGenerators Gamma)).toSubmodule.le_topologicalClosure + (VectorSublattice.subset_generated (solovayVectorGenerators Gamma) hf) + +omit [WellFoundedLT Gamma] in +/-- Records closedness of the generated Solovay vector sublattice; this is one +of the properties required by `gao_counterexample`. -/ +theorem isClosed_solovayVectorSublattice : + IsClosed (solovayVectorSublattice Gamma : + Set C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ)) := by + unfold solovayVectorSublattice VectorSublattice.topologicalClosure + exact Submodule.isClosed_topologicalClosure _ + +omit [WellFoundedLT Gamma] in +/-- Derives separability from the countable generator family; this supplies +the separable sublattice in `gao_counterexample`. -/ +theorem isSeparable_solovayVectorSublattice : + TopologicalSpace.IsSeparable (solovayVectorSublattice Gamma : + Set C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ)) := by + let : TopologicalSpace.SeparableSpace + (solovayVectorSublattice Gamma).toSubmodule := + VectorSublattice.separableSpace_topologicalClosure_generated_of_countable + (solovayVectorGenerators_countable Gamma) + exact TopologicalSpace.IsSeparable.of_subtype + (solovayVectorSublattice Gamma : + Set C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ)) + +/-- Shows that every order-closed vector sublattice containing the Solovay +sublattice is the whole continuous-function lattice. -/ +theorem solovayVectorSublattice_maximalOrderClosed + (Z : VectorSublattice + C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ)) + (hYZ : solovayVectorSublattice Gamma ≤ Z) + (hZorder : IsOrderClosed + (Z : Set C(BooleanStone (RegularOpen (SolovayProduct Gamma)), ℝ))) : + Z = ⊤ := by + let B := RegularOpen (SolovayProduct Gamma) + have hOne : (1 : C(BooleanStone B, ℝ)) ∈ Z := by + apply hYZ + apply solovayVectorGenerator_mem Gamma + exact Or.inr (Set.mem_singleton _) + let L : BooleanSubalgebra B := + booleanSubalgebraInVectorSublattice B Z hOne + have hLcomplete : IsCompleteBooleanSubalgebra L := + booleanSubalgebraInVectorSublattice_complete B Z hOne hZorder + have hLgen : ∀ m n, solovayB Gamma m n ∈ L := by + intro m n + change booleanStoneIndicator B (solovayB Gamma m n) ∈ Z + apply hYZ + apply solovayVectorGenerator_mem Gamma + exact Or.inl ⟨(m, n), rfl⟩ + have hLtop : L = ⊤ := + solovay_generates_regularOpen Gamma L hLcomplete hLgen + have hAllIndicators : ∀ b : B, booleanStoneIndicator B b ∈ Z := by + intro b + change b ∈ L + rw [hLtop] + trivial + exact vectorSublattice_eq_top_of_booleanStoneIndicators B Z hOne + hAllIndicators hZorder + +end SolovayVectorSublattice + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou.lean b/LeanPool/OrderClosures/WeaklyFatou.lean new file mode 100644 index 0000000000..3972cd726b --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.Reductions +public import LeanPool.OrderClosures.WeaklyFatou.FiniteTree +public import LeanPool.OrderClosures.WeaklyFatou.TreeNorm +public import LeanPool.OrderClosures.WeaklyFatou.Bands +public import LeanPool.OrderClosures.WeaklyFatou.Moderated +public import LeanPool.OrderClosures.WeaklyFatou.FinalSpace + + +/-! +# Weakly Fatou norms + +Compatibility umbrella for the paper-ordered weakly Fatou construction. +-/ + +@[expose] public section diff --git a/LeanPool/OrderClosures/WeaklyFatou/Bands.lean b/LeanPool/OrderClosures/WeaklyFatou/Bands.lean new file mode 100644 index 0000000000..4bc1da2d86 --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/Bands.lean @@ -0,0 +1,681 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.TreeNorm + + +/-! +# Bands, upshift, trimming, and the weak Fatou estimate +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-! ## Bands, upshift, and the weak Fatou estimate -/ + +/-- Indexing the root band and the sibling bands. -/ +abbrev TreeBandIndex (n : ℕ) := Option (TreeNonterminal n) + +/-- Support of a sibling band, with `none` denoting the root band. -/ +def treeBandSupport (n : ℕ) : TreeBandIndex n → Set (TreeNode n) + | none => {TreeNode.root n} + | some u => {t | TreeNode.parent t = u.1 ∧ t ≠ TreeNode.root n} + +/-- Coordinate projection onto a sibling band. -/ +noncomputable def treeBandProjection (n : ℕ) (B : TreeBandIndex n) + (w : TreeCoefficients n) : TreeCoefficients n := + by + classical + exact w.filter fun t ↦ t ∈ treeBandSupport n B + +/-- Projection onto a finite family of sibling bands. -/ +noncomputable def finiteBandProjection (n : ℕ) (Λ : Finset (TreeBandIndex n)) + (w : TreeCoefficients n) : TreeCoefficients n := + by + classical + exact w.filter fun t ↦ ∃ B ∈ Λ, t ∈ treeBandSupport n B + +/-- Assigns a node to the root band or the sibling band indexed by its parent; +used to define the finite band partition pointwise. -/ +noncomputable def treeBandOfNode (n : ℕ) (t : TreeNode n) : TreeBandIndex n := + by + classical + exact if h : t = TreeNode.root n then none else + some ⟨TreeNode.parent t, by + have htpos : 0 < TreeNode.level t := Nat.pos_of_ne_zero fun hzero ↦ h (by + apply Subtype.ext + have hnil : t.1 = [] := List.length_eq_zero_iff.mp (by + simpa [TreeNode.level] using hzero) + simpa [TreeNode.root] using hnil) + have hp : TreeNode.level (TreeNode.parent t) = TreeNode.level t - 1 := by + simp [TreeNode.parent, TreeNode.level] + have htn : TreeNode.level t ≤ n := t.2 + omega⟩ + +/-- Assigns every node to its canonical root or sibling band; used to partition +coefficient supports. -/ +theorem node_mem_its_treeBand (n : ℕ) (t : TreeNode n) : + t ∈ treeBandSupport n (treeBandOfNode n t) := by + classical + by_cases h : t = TreeNode.root n + · simp [treeBandOfNode, h, treeBandSupport] + · simp [treeBandOfNode, h, treeBandSupport] + +/-- Recovers the canonical band from membership in a band support; used to +prove uniqueness in the band partition. -/ +theorem treeBandOfNode_eq_of_mem (n : ℕ) (t : TreeNode n) + (B : TreeBandIndex n) (ht : t ∈ treeBandSupport n B) : + treeBandOfNode n t = B := by + classical + cases B with + | none => + have htroot : t = TreeNode.root n := by simpa [treeBandSupport] using ht + simp [treeBandOfNode, htroot] + | some u => + have ht' : TreeNode.parent t = u.1 ∧ t ≠ TreeNode.root n := by + simpa [treeBandSupport] using ht + simp [treeBandOfNode, ht'.2, ht'.1] + +/-- Characterizes when a band projection has nonempty support; used to define +and track recurrent bands. -/ +theorem treeBandProjection_support_nonempty_iff (n : ℕ) + (B : TreeBandIndex n) (w : TreeCoefficients n) : + (treeBandProjection n B w).support.Nonempty ↔ + ∃ t ∈ w.support, treeBandOfNode n t = B := by + classical + constructor + · rintro ⟨t, ht⟩ + have ht' : t ∈ w.support ∧ t ∈ treeBandSupport n B := by + simpa [treeBandProjection] using ht + exact ⟨t, ht'.1, treeBandOfNode_eq_of_mem n t B ht'.2⟩ + · rintro ⟨t, htw, htB⟩ + refine ⟨t, ?_⟩ + have htmem := node_mem_its_treeBand n t + rw [htB] at htmem + simp [treeBandProjection, htw, htmem] + +/-- The finite set of canonical bands meeting the support of `w`; used by the +subsequence recursion in `tree_thinning`. -/ +noncomputable def bandsAt (n : ℕ) (w : TreeCoefficients n) : + Finset (TreeBandIndex n) := by + classical + exact w.support.image (treeBandOfNode n) + +/-- Characterizes the finite set of bands occurring in a coefficient vector; +used in the thinning recursion. -/ +theorem mem_bandsAt_iff (n : ℕ) (w : TreeCoefficients n) + (B : TreeBandIndex n) : + B ∈ bandsAt n w ↔ (treeBandProjection n B w).support.Nonempty := by + classical + rw [treeBandProjection_support_nonempty_iff] + simp [bandsAt, eq_comm] + +/-- Gives the pointwise formula for projection onto finitely many bands; used +to decompose coefficients in trimming and moderatedness. -/ +theorem finiteBandProjection_apply (n : ℕ) (Λ : Finset (TreeBandIndex n)) + (w : TreeCoefficients n) (t : TreeNode n) : + (treeBandOfNode n t ∈ Λ → finiteBandProjection n Λ w t = w t) ∧ + (treeBandOfNode n t ∉ Λ → finiteBandProjection n Λ w t = 0) := by + classical + constructor + · intro hB + apply Finsupp.filter_apply_pos + exact ⟨treeBandOfNode n t, hB, node_mem_its_treeBand n t⟩ + · intro hB + apply Finsupp.filter_apply_neg + rintro ⟨B, hBΛ, htB⟩ + exact hB (treeBandOfNode_eq_of_mem n t B htB ▸ hBΛ) + +/-- A finite band projection preserves nonnegativity. -/ +theorem finiteBandProjection_nonneg (n : ℕ) (Λ : Finset (TreeBandIndex n)) + {w : TreeCoefficients n} (hw : 0 ≤ w) : 0 ≤ finiteBandProjection n Λ w := by + intro t + by_cases ht : treeBandOfNode n t ∈ Λ + · rw [(finiteBandProjection_apply n Λ w t).1 ht] + exact hw t + · rw [(finiteBandProjection_apply n Λ w t).2 ht] + exact le_rfl + +/-- A finite band projection decreases nonnegative coefficient vectors. -/ +theorem finiteBandProjection_le (n : ℕ) (Λ : Finset (TreeBandIndex n)) + {w : TreeCoefficients n} (hw : 0 ≤ w) : finiteBandProjection n Λ w ≤ w := by + intro t + by_cases ht : treeBandOfNode n t ∈ Λ + · rw [(finiteBandProjection_apply n Λ w t).1 ht] + · rw [(finiteBandProjection_apply n Λ w t).2 ht] + exact hw t + +/-- Expresses the mass of a finite band projection as a finite sum; used for +tail-mass estimates in the trimming lemma. -/ +theorem treeRho_finiteBandProjection (n : ℕ) + (Λ : Finset (TreeBandIndex n)) (w : TreeCoefficients n) : + treeRho n (finiteBandProjection n Λ w) = + ∑ B ∈ Λ, treeRho n (treeBandProjection n B w) := by + classical + have hfinite : treeRho n (finiteBandProjection n Λ w) = + ∑ t ∈ w.support, (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * + |finiteBandProjection n Λ w t| := by + rw [treeRho] + apply Finsupp.sum_of_support_subset + · rw [finiteBandProjection, Finsupp.support_filter] + exact Finset.filter_subset _ _ + · simp + have hband (B : TreeBandIndex n) : treeRho n (treeBandProjection n B w) = + ∑ t ∈ w.support, (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * + |treeBandProjection n B w t| := by + rw [treeRho] + apply Finsupp.sum_of_support_subset + · rw [treeBandProjection, Finsupp.support_filter] + exact Finset.filter_subset _ _ + · simp + rw [hfinite] + simp_rw [hband] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro t ht + by_cases hΛ : treeBandOfNode n t ∈ Λ + · rw [(finiteBandProjection_apply n Λ w t).1 hΛ] + rw [Finset.sum_eq_single (treeBandOfNode n t)] + · rw [treeBandProjection, Finsupp.filter_apply_pos] + exact node_mem_its_treeBand n t + · intro B hBΛ hBne + have hnot : t ∉ treeBandSupport n B := by + intro htB + exact hBne (treeBandOfNode_eq_of_mem n t B htB).symm + rw [treeBandProjection, Finsupp.filter_apply_neg _ _ hnot] + simp + · intro hnot + exact (hnot hΛ).elim + · rw [(finiteBandProjection_apply n Λ w t).2 hΛ] + simp only [abs_zero, mul_zero] + symm + apply Finset.sum_eq_zero + intro B hBΛ + have hnot : t ∉ treeBandSupport n B := by + intro htB + exact hΛ (treeBandOfNode_eq_of_mem n t B htB ▸ hBΛ) + rw [treeBandProjection, Finsupp.filter_apply_neg _ _ hnot] + simp + +/-- Chooses the root or parent node representing a band; used to define the +upshift of all coefficients in that band. -/ +noncomputable def treeBandParent (n : ℕ) : TreeBandIndex n → TreeNode n + | none => TreeNode.root n + | some u => u.1 + +/-- Identifies a nonroot node's parent with the representative of its band; +used to analyze the support of the upshift. -/ +theorem parent_eq_treeBandParent (n : ℕ) (t : TreeNode n) : + TreeNode.parent t = treeBandParent n (treeBandOfNode n t) := by + classical + by_cases ht : t = TreeNode.root n + · subst t + simp [treeBandOfNode, treeBandParent, TreeNode.parent, TreeNode.root] + · simp [treeBandOfNode, treeBandParent, ht] + +/-- The upshift `S_n`, merging coefficients at their parents. -/ +noncomputable def treeUpshift (n : ℕ) (w : TreeCoefficients n) : TreeCoefficients n := + w.mapDomain TreeNode.parent + +/-- The finite set of representative parents of a finite band family; used to +bound the support of upshifted coefficients. -/ +noncomputable def treeBandParents (n : ℕ) + (Λ : Finset (TreeBandIndex n)) : Finset (TreeNode n) := by + classical + exact Λ.image (treeBandParent n) + +/-- Bounds the support of an upshift by the finite set of band parents; used +to obtain a finite-dimensional convergent subsequence. -/ +theorem treeUpshift_support_subset_bandParents (n : ℕ) + (Λ : Finset (TreeBandIndex n)) (w : TreeCoefficients n) : + (treeUpshift n (finiteBandProjection n Λ w)).support ⊆ + treeBandParents n Λ := by + classical + intro q hq + rw [treeUpshift] at hq + have hq' := Finsupp.mapDomain_support hq + rcases Finset.mem_image.mp hq' with ⟨t, ht, rfl⟩ + rw [treeBandParents] + apply Finset.mem_image.mpr + refine ⟨treeBandOfNode n t, ?_, (parent_eq_treeBandParent n t).symm⟩ + have htfinite : t ∈ (finiteBandProjection n Λ w).support := ht + by_contra hnot + have hzero := (finiteBandProjection_apply n Λ w t).2 hnot + exact Finsupp.mem_support_iff.mp htfinite hzero + +/-- Compares the weight of a parent node with that of its child; used to bound +the `treeRho` cost of upshifting. -/ +theorem treeParent_weight_le (n : ℕ) (t : TreeNode n) : + (2 : ℝ) ^ (-(TreeNode.level (TreeNode.parent t) : ℤ)) ≤ + 2 * (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) := by + have hp : TreeNode.level (TreeNode.parent t) = TreeNode.level t - 1 := by + simp [TreeNode.parent, TreeNode.level] + by_cases ht : TreeNode.level t = 0 + · simp [hp, ht] + · have hz : -(TreeNode.level (TreeNode.parent t) : ℤ) = + -(TreeNode.level t : ℤ) + 1 := by omega + rw [hz, zpow_add₀ (by norm_num)] + simp [mul_comm] + +/-- Shows that a node cylinder lies inside its parent cylinder; used to prove +that upshifting increases the associated tree operator. -/ +theorem treeCylinder_subset_parent (n : ℕ) (t : TreeNode n) : + treeCylinder n t ⊆ treeCylinder n (TreeNode.parent t) := by + intro α hα j + let j' : Fin (TreeNode.level t) := ⟨j, by + exact j.isLt.trans_le (by simp [TreeNode.parent, TreeNode.level])⟩ + have hj := hα j' + have hpref : strictPrefix (TreeNode.parent t) j = strictPrefix t j' := by + apply Subtype.ext + apply Subtype.ext + change t.1.dropLast.take j = t.1.take j' + have htne : t.1 ≠ [] := by + intro ht + have hjlt := j.isLt + simp [TreeNode.parent, TreeNode.level, ht] at hjlt + nth_rewrite 2 [← List.dropLast_append_getLast htne] + exact (List.take_append_of_le_length j.isLt.le).symm + have hget : (TreeNode.parent t).1.get j = t.1.get j' := by + rw [List.get_eq_getElem, List.get_eq_getElem] + simp [TreeNode.parent] + rfl + rw [hpref, hget] + exact hj + +/-- Converts cylinder inclusion into domination by the parent tree function; +used in `treeUpshift_basic`. -/ +theorem treeFunction_le_parent (n : ℕ) (t : TreeNode n) : + treeFunction n t ≤ treeFunction n (TreeNode.parent t) := by + intro α + change treeFunction n t α ≤ treeFunction n (TreeNode.parent t) α + by_cases hα : α ∈ treeCylinder n t + · rw [treeFunction_apply_of_mem n t hα, + treeFunction_apply_of_mem n _ (treeCylinder_subset_parent n t hα)] + · rw [treeFunction_apply_of_notMem n t hα] + exact treeFunction_nonneg n _ α + +/-- Paper Lemma `lem:upshift-basic`. -/ +theorem treeUpshift_basic (n : ℕ) (w : TreeCoefficients n) (hw : 0 ≤ w) : + treeRho n (treeUpshift n w) ≤ 2 * treeRho n w ∧ + treeOperator n w ≤ treeOperator n (treeUpshift n w) := by + have hupnonneg : 0 ≤ treeUpshift n w := + Finsupp.mapDomain_nonneg hw + constructor + · classical + have hrho_up : treeRho n (treeUpshift n w) = + (treeUpshift n w).sum fun t a ↦ + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * a := by + rw [treeRho] + apply Finsupp.sum_congr + intro t _ + rw [abs_of_nonneg (hupnonneg t)] + rw [hrho_up] + rw [treeUpshift, Finsupp.sum_mapDomain_index (by simp) (by simp [mul_add])] + rw [treeRho, Finsupp.sum, Finsupp.sum, Finset.mul_sum] + apply Finset.sum_le_sum + intro t _ + rw [abs_of_nonneg (hw t)] + calc + (2 : ℝ) ^ (-(TreeNode.level (TreeNode.parent t) : ℤ)) * w t ≤ + (2 * (2 : ℝ) ^ (-(TreeNode.level t : ℤ))) * w t := + mul_le_mul_of_nonneg_right (treeParent_weight_le n t) (hw t) + _ = 2 * ((2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * w t) := by ring + · classical + change (w.sum fun t a ↦ a • treeFunction n t) ≤ + (Finsupp.mapDomain TreeNode.parent w).sum fun t a ↦ a • treeFunction n t + rw [Finsupp.sum_mapDomain_index (by simp) (by simp [add_smul])] + apply Finsupp.sum_le_sum + intro t _ α + change w t * treeFunction n t α ≤ w t * treeFunction n (TreeNode.parent t) α + exact mul_le_mul_of_nonneg_left (treeFunction_le_parent n t α) (hw t) + +/-- A single band projection cannot increase `treeRho`; used to uniformly +bound each coordinate in the sharp-subsequence extraction. -/ +theorem treeRho_bandProjection_le (n : ℕ) (B : TreeBandIndex n) + (w : TreeCoefficients n) : + treeRho n (treeBandProjection n B w) ≤ treeRho n w := by + classical + have heq : treeRho n (treeBandProjection n B w) = + ∑ t ∈ w.support.filter (fun t ↦ t ∈ treeBandSupport n B), + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |w t| := by + rw [treeRho, treeBandProjection, Finsupp.sum] + apply Finset.sum_congr rfl + intro t ht + rw [Finsupp.filter_apply_pos _ _ (Finset.mem_filter.mp ht).2] + rw [heq, treeRho, Finsupp.sum] + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.filter_subset _ _) + intro t _ _ + exact mul_nonneg (zpow_nonneg (by norm_num) _) (abs_nonneg _) + +/-- A projection onto finitely many bands cannot increase `treeRho`; used in +the coefficient decomposition for `component_moderated`. -/ +theorem treeRho_finiteBandProjection_le (n : ℕ) + (Λ : Finset (TreeBandIndex n)) (w : TreeCoefficients n) : + treeRho n (finiteBandProjection n Λ w) ≤ treeRho n w := by + classical + have heq : treeRho n (finiteBandProjection n Λ w) = + ∑ t ∈ w.support.filter (fun t ↦ treeBandOfNode n t ∈ Λ), + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |w t| := by + have hp (t : TreeNode n) : + (∃ B ∈ Λ, t ∈ treeBandSupport n B) ↔ treeBandOfNode n t ∈ Λ := by + constructor + · rintro ⟨B, hB, ht⟩ + exact treeBandOfNode_eq_of_mem n t B ht ▸ hB + · intro ht + exact ⟨treeBandOfNode n t, ht, node_mem_its_treeBand n t⟩ + rw [treeRho, finiteBandProjection, Finsupp.sum, Finsupp.support_filter] + simp_rw [hp] + apply Finset.sum_congr rfl + intro t ht + have happly : (w.filter fun x ↦ treeBandOfNode n x ∈ Λ) t = w t := + Finsupp.filter_apply_pos (fun x ↦ treeBandOfNode n x ∈ Λ) w + (Finset.mem_filter.mp ht).2 + rw [happly] + rw [heq, treeRho, Finsupp.sum] + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.filter_subset _ _) + intro t _ _ + exact mul_nonneg (zpow_nonneg (by norm_num) _) (abs_nonneg _) + +/-- Bounds the total mass of any finite band family by the original mass; +used to prove summability of limiting band masses in `tree_trim`. -/ +theorem sum_treeRho_bandProjection_le (n : ℕ) + (Λ : Finset (TreeBandIndex n)) (w : TreeCoefficients n) : + ∑ B ∈ Λ, treeRho n (treeBandProjection n B w) ≤ treeRho n w := by + rw [← treeRho_finiteBandProjection] + exact treeRho_finiteBandProjection_le n Λ w + +/-- Paper Lemma `lem:sharp-subsequence`. -/ +theorem tree_sharp_subsequence + (n : ℕ) (w : ℕ → TreeCoefficients n) (C : ℝ) + (hw : ∀ m, treeRho n (w m) ≤ C) : + ∃ φ : ℕ → ℕ, StrictMono φ ∧ ∀ B : TreeBandIndex n, + ∃ l : ℝ, Tendsto (fun m ↦ treeRho n (treeBandProjection n B (w (φ m)))) + atTop (nhds l) := by + classical + let : Countable (TreeNode n) := by + unfold TreeNode + infer_instance + let : Countable (TreeNonterminal n) := by + unfold TreeNonterminal + infer_instance + let D := max C 0 + let y : ℕ → TreeBandIndex n → Set.Icc (0 : ℝ) D := fun m B ↦ + ⟨treeRho n (treeBandProjection n B (w m)), + treeRho_nonneg n _, + (treeRho_bandProjection_le n B (w m)).trans + ((hw m).trans (le_max_left C 0))⟩ + let : SeqCompactSpace (TreeBandIndex n → Set.Icc (0 : ℝ) D) := inferInstance + obtain ⟨l, _, φ, hφ, hlim⟩ := + (SeqCompactSpace.isSeqCompact_univ + (X := TreeBandIndex n → Set.Icc (0 : ℝ) D)) (x := y) (fun _ ↦ Set.mem_univ _) + refine ⟨φ, hφ, fun B ↦ ⟨(l B).1, ?_⟩⟩ + have hcoord := tendsto_pi_nhds.mp hlim B + simpa [y, Function.comp_def] using tendsto_subtype_rng.mp hcoord + +/-- The bands occurring in infinitely many supports of a sequence. -/ +def recurrentBands (n : ℕ) (w : ℕ → TreeCoefficients n) : Set (TreeBandIndex n) := + {B | Set.Infinite {m | (treeBandProjection n B (w m)).support.Nonempty}} + +/-- Records a final support occurrence for each nonrecurrent band; used to +construct a subsequence in which transient bands occur at most once. -/ +noncomputable def lastBandOccurrence (n : ℕ) + (w : ℕ → TreeCoefficients n) (B : TreeBandIndex n) : ℕ := by + classical + let S : Set ℕ := {m | (treeBandProjection n B (w m)).support.Nonempty} + exact if h : S.Finite then h.toFinset.sup id else 0 + +/-- Bounds every occurrence of a nonrecurrent band by its recorded last index; +used to choose a subsequence with transient bands occurring at most once. -/ +theorem le_lastBandOccurrence (n : ℕ) (w : ℕ → TreeCoefficients n) + (B : TreeBandIndex n) + (hfinite : {m | (treeBandProjection n B (w m)).support.Nonempty}.Finite) + {m : ℕ} (hm : (treeBandProjection n B (w m)).support.Nonempty) : + m ≤ lastBandOccurrence n w B := by + classical + rw [lastBandOccurrence, dite_eq_left hfinite] + exact Finset.le_sup (s := hfinite.toFinset) (f := id) (by simpa using hm) + +/-- A countable family admits positive weights with every finite sum below a given budget. -/ +private theorem exists_positive_finite_sum_budget {ι : Type*} [Countable ι] + {ε : ℝ} (hε : 0 < ε) : + ∃ δ : ι → ℝ, (∀ i, 0 < δ i) ∧ ∀ F : Finset ι, ∑ i ∈ F, δ i ≤ ε := by + classical + let : Encodable ι := Encodable.ofCountable _ + let a := ε / 2 + have ha : 0 < a := div_pos hε (by norm_num) + let δ : ι → ℝ := fun i ↦ a * (1 / 2 : ℝ) ^ Encodable.encode i + have hδpos (i : ι) : 0 < δ i := mul_pos ha (pow_pos (by norm_num) _) + have hgeom : Summable (fun i : ι ↦ (1 / 2 : ℝ) ^ Encodable.encode i) := by + simpa [Function.comp_def] using + summable_geometric_two.comp_injective Encodable.encode_injective + have hgeom_tsum_le : ∑' i : ι, (1 / 2 : ℝ) ^ Encodable.encode i ≤ 2 := by + calc + ∑' i : ι, (1 / 2 : ℝ) ^ Encodable.encode i ≤ ∑' k : ℕ, (1 / 2 : ℝ) ^ k := + hgeom.tsum_le_tsum_of_inj Encodable.encode Encodable.encode_injective + (fun k _ ↦ by positivity) (fun _ ↦ le_rfl) summable_geometric_two + _ = 2 := tsum_geometric_two + have hδsummable : Summable δ := hgeom.mul_left a + refine ⟨δ, hδpos, fun F ↦ ?_⟩ + calc + ∑ i ∈ F, δ i ≤ ∑' i, δ i := + Summable.sum_le_tsum F (fun i _ ↦ (hδpos i).le) hδsummable + _ = a * ∑' i : ι, (1 / 2 : ℝ) ^ Encodable.encode i := tsum_mul_left + _ ≤ a * 2 := mul_le_mul_of_nonneg_left hgeom_tsum_le ha.le + _ = ε := by dsimp [a]; ring + +/-- Paper Lemma `lem:trim`. -/ +theorem tree_trim + (n : ℕ) (x : ℕ → TreeComponent n) (w : ℕ → TreeCoefficients n) + {ε : ℝ} (hε : 0 < ε) + (hw : ∀ m, 0 ≤ w m) + (hdom : ∀ m, (x m).1 ≤ treeOperator n (w m)) + (hrho : ∀ m, treeRho n (w m) < 1 + ε / 4) + (hsharp : ∀ B : TreeBandIndex n, ∃ l : ℝ, + Tendsto (fun m ↦ treeRho n (treeBandProjection n B (w m))) + atTop (nhds l)) : + ∃ w' : ℕ → TreeCoefficients n, + (∀ m, 0 ≤ w' m ∧ (x m).1 ≤ treeOperator n (w' m) ∧ + treeRho n (w' m) < 1 + ε / 2) ∧ + (recurrentBands n w').Finite := by + classical + let M : ℝ := (2 : ℝ) ^ n + have hM : 0 < M := pow_pos (by norm_num) n + let lam : TreeBandIndex n → ℝ := fun B ↦ Classical.choose (hsharp B) + have hlamlim (B : TreeBandIndex n) : + Tendsto (fun m ↦ treeRho n (treeBandProjection n B (w m))) + atTop (nhds (lam B)) := Classical.choose_spec (hsharp B) + have hlamnonneg (B : TreeBandIndex n) : 0 ≤ lam B := by + apply ge_of_tendsto (hlamlim B) + exact Filter.Eventually.of_forall fun m ↦ treeRho_nonneg n _ + have hlamfinite (S : Finset (TreeBandIndex n)) : + ∑ B ∈ S, lam B ≤ 1 + ε / 4 := by + have hlim : Tendsto + (fun m ↦ ∑ B ∈ S, treeRho n (treeBandProjection n B (w m))) + atTop (nhds (∑ B ∈ S, lam B)) := + tendsto_finsetSum S fun B _ ↦ hlamlim B + apply le_of_tendsto hlim + exact Filter.Eventually.of_forall fun m ↦ + (sum_treeRho_bandProjection_le n S (w m)).trans (hrho m).le + have hlamsummable : Summable lam := + summable_of_sum_le (fun B ↦ hlamnonneg B) hlamfinite + let tailBudget : ℝ := ε / (8 * M) + have htailBudget : 0 < tailBudget := div_pos hε (mul_pos (by norm_num) hM) + obtain ⟨Λ₀, hΛ₀⟩ := + (Metric.tendsto_atTop.mp hlamsummable.hasSum) tailBudget htailBudget + let Λ : Finset (TreeBandIndex n) := insert none Λ₀ + have hnoneΛ : none ∈ Λ := by simp [Λ] + have hΛapprox : dist (∑ B ∈ Λ, lam B) (∑' B, lam B) < tailBudget := + hΛ₀ Λ (Finset.subset_insert none Λ₀) + have hΛsum_le : ∑ B ∈ Λ, lam B ≤ ∑' B, lam B := + Summable.sum_le_tsum Λ (fun B _ ↦ hlamnonneg B) hlamsummable + have htail (F : Finset (TreeBandIndex n)) + (hF : ∀ B ∈ F, B ∉ Λ) : ∑ B ∈ F, lam B < tailBudget := by + have hdis : Disjoint Λ F := Finset.disjoint_left.mpr fun B hBΛ hBF ↦ + (hF B hBF) hBΛ + have hunion : (∑ B ∈ Λ, lam B) + ∑ B ∈ F, lam B = + ∑ B ∈ Λ ∪ F, lam B := by + exact (Finset.sum_union hdis).symm + have hle : ∑ B ∈ Λ ∪ F, lam B ≤ ∑' B, lam B := + Summable.sum_le_tsum (Λ ∪ F) (fun B _ ↦ hlamnonneg B) hlamsummable + rw [Real.dist_eq, abs_of_nonpos (sub_nonpos.mpr hΛsum_le)] at hΛapprox + linarith + obtain ⟨δ, hδpos, hδfinite⟩ := + exists_positive_finite_sum_budget (ι := TreeBandIndex n) htailBudget + have hcutoff (B : TreeBandIndex n) : ∃ N : ℕ, ∀ m ≥ N, + treeRho n (treeBandProjection n B (w m)) < lam B + δ B := by + obtain ⟨N, hN⟩ := + (Metric.tendsto_atTop.mp (hlamlim B)) (δ B) (hδpos B) + refine ⟨N, fun m hm ↦ ?_⟩ + have habs := hN m hm + rw [Real.dist_eq] at habs + have hsub : treeRho n (treeBandProjection n B (w m)) - lam B < δ B := + (le_abs_self _).trans_lt habs + linarith + let N : TreeBandIndex n → ℕ := fun B ↦ Classical.choose (hcutoff B) + have hN (B : TreeBandIndex n) (m : ℕ) (hm : N B ≤ m) : + treeRho n (treeBandProjection n B (w m)) < lam B + δ B := + Classical.choose_spec (hcutoff B) m hm + let removedBands : ℕ → Finset (TreeBandIndex n) := fun m ↦ + (bandsAt n (w m)).filter fun B ↦ B ∉ Λ ∧ N B ≤ m + let r : ℕ → TreeCoefficients n := fun m ↦ + finiteBandProjection n (removedBands m) (w m) + let w' : ℕ → TreeCoefficients n := fun m ↦ + w m - r m + (M * treeRho n (r m)) • treeBasis (TreeNode.root n) + have hr_nonneg (m : ℕ) : 0 ≤ r m := + finiteBandProjection_nonneg n (removedBands m) (hw m) + have hkeep_nonneg (m : ℕ) : 0 ≤ w m - r m := + sub_nonneg.mpr (finiteBandProjection_le n (removedBands m) (hw m)) + have hrho_r (m : ℕ) : treeRho n (r m) < ε / (4 * M) := by + have hRB (B : TreeBandIndex n) (hB : B ∈ removedBands m) : + treeRho n (treeBandProjection n B (w m)) < lam B + δ B := by + exact hN B m (Finset.mem_filter.mp hB).2.2 + have houtside (B : TreeBandIndex n) (hB : B ∈ removedBands m) : B ∉ Λ := + (Finset.mem_filter.mp hB).2.1 + change treeRho n (finiteBandProjection n (removedBands m) (w m)) < _ + rw [treeRho_finiteBandProjection] + calc + ∑ B ∈ removedBands m, treeRho n (treeBandProjection n B (w m)) ≤ + ∑ B ∈ removedBands m, (lam B + δ B) := by + apply Finset.sum_le_sum + intro B hB + exact (hRB B hB).le + _ = (∑ B ∈ removedBands m, lam B) + ∑ B ∈ removedBands m, δ B := by + rw [← Finset.sum_add_distrib] + _ < tailBudget + tailBudget := + add_lt_add_of_lt_of_le (htail (removedBands m) houtside) + (hδfinite (removedBands m)) + _ = ε / (4 * M) := by + dsimp [tailBudget] + field_simp + ring + refine ⟨w', ?_, ?_⟩ + · intro m + have hroot_nonneg : 0 ≤ + (M * treeRho n (r m)) • treeBasis (TreeNode.root n) := by + intro t + change 0 ≤ (M * treeRho n (r m)) * treeBasis (TreeNode.root n) t + apply mul_nonneg (mul_nonneg hM.le (treeRho_nonneg n (r m))) + by_cases ht : t = TreeNode.root n <;> simp [treeBasis, ht] + refine ⟨add_nonneg (hkeep_nonneg m) hroot_nonneg, ?_, ?_⟩ + · calc + (x m).1 ≤ treeOperator n (w m) := hdom m + _ = treeOperator n (w m - r m) + treeOperator n (r m) := by + rw [← treeOperator_add] + congr 1 + abel + _ ≤ treeOperator n (w m - r m) + + (M * treeRho n (r m)) • treeFunction n (TreeNode.root n) := by + exact add_le_add le_rfl + (treeOperator_le_root_of_nonneg n (r m) (hr_nonneg m)) + _ = treeOperator n (w' m) := by + change _ = treeOperator n + (w m - r m + (M * treeRho n (r m)) • treeBasis (TreeNode.root n)) + rw [treeOperator_add, treeOperator_smul, treeBasis, + treeOperator_single, one_smul] + · have hkeep_le : w m - r m ≤ w m := by + exact sub_le_self _ (hr_nonneg m) + calc + treeRho n (w' m) ≤ treeRho n (w m - r m) + + treeRho n ((M * treeRho n (r m)) • treeBasis (TreeNode.root n)) := + treeRho_add_le n _ _ + _ ≤ treeRho n (w m) + M * treeRho n (r m) := by + apply add_le_add + · exact treeRho_mono_of_nonneg n (hkeep_nonneg m) hkeep_le + · rw [treeRho_smul, abs_of_nonneg + (mul_nonneg hM.le (treeRho_nonneg n (r m)))] + simp [treeBasis, treeRho, TreeNode.root, TreeNode.level] + _ < 1 + ε / 2 := by + have hMr : M * treeRho n (r m) < ε / 4 := by + calc + M * treeRho n (r m) < M * (ε / (4 * M)) := + mul_lt_mul_of_pos_left (hrho_r m) hM + _ = ε / 4 := by field_simp + linarith [hrho m] + · apply Set.Finite.subset Λ.finite_toSet + intro B hBrec + by_contra hBΛ + have hoccFinite : + {m | (treeBandProjection n B (w' m)).support.Nonempty}.Finite := by + apply (Finset.finite_toSet (Finset.range (N B))).subset + intro m hm + simp only [Finset.mem_coe, Finset.mem_range] + by_contra hmN + have hNm : N B ≤ m := Nat.le_of_not_gt hmN + rcases hm with ⟨t, ht⟩ + have htw' : t ∈ (w' m).support ∧ t ∈ treeBandSupport n B := by + simpa [treeBandProjection] using ht + have htBand : treeBandOfNode n t = B := + treeBandOfNode_eq_of_mem n t B htw'.2 + have htroot : t ≠ TreeNode.root n := by + intro htr + have : B = none := by + rw [← htBand, htr] + simp [treeBandOfNode] + exact hBΛ (this ▸ hnoneΛ) + have hwt_ne : w m t ≠ 0 := by + intro hzero + have hrzero : r m t = 0 := by + by_cases htR : treeBandOfNode n t ∈ removedBands m + · change finiteBandProjection n (removedBands m) (w m) t = 0 + rw [(finiteBandProjection_apply n (removedBands m) (w m) t).1 htR, + hzero] + · change finiteBandProjection n (removedBands m) (w m) t = 0 + rw [(finiteBandProjection_apply n (removedBands m) (w m) t).2 htR] + have hrootzero : treeBasis (TreeNode.root n) t = 0 := by + simp [treeBasis, htroot] + have htne := Finsupp.mem_support_iff.mp htw'.1 + change (w m - r m + + (M * treeRho n (r m)) • treeBasis (TreeNode.root n)) t ≠ 0 at htne + simp [Finsupp.add_apply, Finsupp.sub_apply, hzero, hrzero, + Finsupp.smul_apply, hrootzero, smul_eq_mul] at htne + have hBbands : B ∈ bandsAt n (w m) := by + rw [mem_bandsAt_iff, treeBandProjection_support_nonempty_iff] + exact ⟨t, Finsupp.mem_support_iff.mpr hwt_ne, htBand⟩ + have hBR : B ∈ removedBands m := by + apply Finset.mem_filter.mpr + exact ⟨hBbands, hBΛ, hNm⟩ + have hrval : r m t = w m t := by + change finiteBandProjection n (removedBands m) (w m) t = w m t + rw [(finiteBandProjection_apply n (removedBands m) (w m) t).1] + exact htBand ▸ hBR + have hrootzero : treeBasis (TreeNode.root n) t = 0 := by + simp [treeBasis, htroot] + have htne := Finsupp.mem_support_iff.mp htw'.1 + change (w m - r m + + (M * treeRho n (r m)) • treeBasis (TreeNode.root n)) t ≠ 0 at htne + simp [Finsupp.add_apply, Finsupp.sub_apply, hrval, + Finsupp.smul_apply, hrootzero, smul_eq_mul] at htne + exact hBrec hoccFinite + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou/FinalSpace.lean b/LeanPool/OrderClosures/WeaklyFatou/FinalSpace.lean new file mode 100644 index 0000000000..d335ae20c3 --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/FinalSpace.lean @@ -0,0 +1,599 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.Moderated + + +/-! +# Component adherence and the final `c₀`-sum +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-! ## Component spaces and the final `c₀`-sum -/ + +/-- Terminal tree functions `L_n`. -/ +def terminalTreeFunctions (n : ℕ) : Set (BoundedContinuousFunction (TreeProduct n) ℝ) := + treeFunction n '' {t : TreeNode n | TreeNode.level t = n} + +/-- Paper Proposition `prop:component`. -/ +theorem component_large_iterated_adherence (n : ℕ) : + TopologicalSpace.IsSeparable (Set.univ : Set (TreeComponent n)) ∧ + IsCompleteFor (componentLatticeNorm n) ∧ + HasWeakFatouProperty (componentLatticeNorm n) 2 ∧ + ((2 : ℝ) ^ n • componentRoot n) ∈ + iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) n ∧ + componentLatticeNorm n ((2 : ℝ) ^ n • componentRoot n) = (2 : ℝ) ^ n := by + have hiter : ∀ k : ℕ, ∀ t : TreeNode n, TreeNode.level t + k = n → + ((2 : ℝ) ^ n • componentTreeFunction n t) ∈ + iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) k := by + intro k + induction k with + | zero => + intro t ht + have hlevel : TreeNode.level t = n := by omega + change componentLatticeNorm n ((2 : ℝ) ^ n • componentTreeFunction n t) ≤ 1 + rw [(componentLatticeNorm n).smul, abs_of_pos (pow_pos (by norm_num) n), + (component_basic n).2.2.2 t hlevel] + rw [← zpow_natCast, ← zpow_add₀ (by norm_num)] + norm_num + | succ k ih => + intro t ht + have ht_nonterminal : TreeNode.level t < n := by omega + let f : ℕ → TreeComponent n := fun m ↦ + (2 : ℝ) ^ n • componentTreeFunction n (TreeNode.child t ht_nonterminal m) + have hf : ∀ m, f m ∈ + iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) k := by + intro m + apply ih + have hlevelchild : TreeNode.level (TreeNode.child t ht_nonterminal m) = + TreeNode.level t + 1 := by simp [TreeNode.child, TreeNode.level] + rw [hlevelchild] + omega + have hchild := treeFunction_child_properties n t ht_nonterminal + have hmono : Monotone + (fun m ↦ componentTreeFunction n (TreeNode.child t ht_nonterminal m)) := by + intro a b hab + exact hchild.2.1 hab + have hlub : IsLUB + (Set.range fun m ↦ componentTreeFunction n + (TreeNode.child t ht_nonterminal m)) (componentTreeFunction n t) := by + constructor + · rintro _ ⟨m, rfl⟩ + exact hchild.1 m |>.2 + · intro z hz + change treeFunction n t ≤ z.1 + apply hchild.2.2.2 + rintro _ ⟨m, rfl⟩ + exact hz ⟨m, rfl⟩ + change ((2 : ℝ) ^ n • componentTreeFunction n t) ∈ orderAdherence + (iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) k) + refine ⟨ℕ, inferInstance, inferInstance, inferInstance, f, hf, ?_⟩ + simpa [f] using + (orderConvergesTo_of_monotone_isLUB hmono hlub).smul ((2 : ℝ) ^ n) + have hroot : componentTreeFunction n (TreeNode.root n) = componentRoot n := rfl + have hmembership : ((2 : ℝ) ^ n • componentRoot n) ∈ + iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) n := by + rw [← hroot] + apply hiter n (TreeNode.root n) + simp [TreeNode.root, TreeNode.level] + have hnorm : componentLatticeNorm n ((2 : ℝ) ^ n • componentRoot n) = + (2 : ℝ) ^ n := by + rw [(componentLatticeNorm n).smul, abs_of_pos (pow_pos (by norm_num) n), + (component_basic n).2.2.1, mul_one] + exact ⟨(component_basic n).1, (component_basic n).2.1, + (component_weakFatou n).2, hmembership, hnorm⟩ + +/-- The ambient product of all component spaces. -/ +abbrev ComponentProduct := ∀ n : ℕ, TreeComponent n + +/-- The usual `c₀` condition for the component norms. -/ +def componentVanishes (x : ComponentProduct) : Prop := + Tendsto (fun n ↦ componentLatticeNorm n (x n)) atTop (nhds 0) + +/-- The concrete `c₀`-sum as a vector sublattice of the component product. -/ +noncomputable def componentC0Sublattice : VectorSublattice ComponentProduct where + carrier := {x | componentVanishes x} + zero_mem' := by + change Tendsto (fun n ↦ componentLatticeNorm n (0 : TreeComponent n)) atTop (nhds 0) + have hzero : (fun n ↦ componentLatticeNorm n (0 : TreeComponent n)) = + fun _ ↦ 0 := by + funext n + exact (componentLatticeNorm n).eq_zero_iff 0 |>.2 rfl + rw [hzero] + exact tendsto_const_nhds + add_mem' := by + intro x y hx hy + change Tendsto (fun n ↦ componentLatticeNorm n (x n)) atTop (nhds 0) at hx + change Tendsto (fun n ↦ componentLatticeNorm n (y n)) atTop (nhds 0) at hy + change Tendsto (fun n ↦ componentLatticeNorm n (x n + y n)) atTop (nhds 0) + apply squeeze_zero + · exact fun n ↦ (componentLatticeNorm n).nonneg _ + · exact fun n ↦ (componentLatticeNorm n).add_le _ _ + · simpa using hx.add hy + smul_mem' := by + intro a x hx + change Tendsto (fun n ↦ componentLatticeNorm n (x n)) atTop (nhds 0) at hx + change Tendsto (fun n ↦ componentLatticeNorm n (a • x n)) atTop (nhds 0) + have heq : (fun n ↦ componentLatticeNorm n (a • x n)) = + fun n ↦ |a| * componentLatticeNorm n (x n) := by + funext n + exact (componentLatticeNorm n).smul a (x n) + rw [heq] + simpa using hx.const_mul |a| + sup_mem' := by + intro x y hx hy + change Tendsto (fun n ↦ componentLatticeNorm n (x n)) atTop (nhds 0) at hx + change Tendsto (fun n ↦ componentLatticeNorm n (y n)) atTop (nhds 0) at hy + change Tendsto (fun n ↦ componentLatticeNorm n (x n ⊔ y n)) atTop (nhds 0) + apply squeeze_zero + · exact fun n ↦ (componentLatticeNorm n).nonneg _ + · intro n + have habsx : componentLatticeNorm n |x n| = componentLatticeNorm n (x n) := by + apply le_antisymm + · exact (componentLatticeNorm n).solid (by simp) + · exact (componentLatticeNorm n).solid (by simp) + have habsy : componentLatticeNorm n |y n| = componentLatticeNorm n (y n) := by + apply le_antisymm + · exact (componentLatticeNorm n).solid (by simp) + · exact (componentLatticeNorm n).solid (by simp) + calc + componentLatticeNorm n (x n ⊔ y n) ≤ + componentLatticeNorm n (|x n| + |y n|) := + (componentLatticeNorm n).solid (by + have hsum0 : (0 : TreeComponent n) ≤ |x n| + |y n| := + add_nonneg (abs_nonneg _) (abs_nonneg _) + rw [abs_of_nonneg hsum0] + apply abs_le'.mpr + constructor + · exact sup_le ((le_abs_self _).trans (le_add_of_nonneg_right (abs_nonneg _))) + ((le_abs_self _).trans (le_add_of_nonneg_left (abs_nonneg _))) + · exact (neg_le_neg (le_sup_left : x n ≤ x n ⊔ y n)).trans + ((neg_le_abs _).trans (le_add_of_nonneg_right (abs_nonneg _)))) + _ ≤ componentLatticeNorm n |x n| + componentLatticeNorm n |y n| := + (componentLatticeNorm n).add_le _ _ + _ = componentLatticeNorm n (x n) + componentLatticeNorm n (y n) := by + rw [habsx, habsy] + · simpa using hx.add hy + +/-- The final space `X = c₀(X_n)`, using the underlying submodule carrier. -/ +abbrev FinalSpace := ↥componentC0Sublattice.toSubmodule + +/-- Inclusion of one component as a coordinate band of the final `c₀`-sum. -/ +noncomputable def finalCoordinateEmbedding (n : ℕ) (z : TreeComponent n) : FinalSpace := + ⟨fun m ↦ if h : m = n then h.symm ▸ z else 0, by + change Tendsto + (fun m ↦ componentLatticeNorm m (if h : m = n then h.symm ▸ z else 0)) + atTop (nhds 0) + have heq : (fun m ↦ componentLatticeNorm m + (if h : m = n then h.symm ▸ z else 0)) =ᶠ[atTop] fun _ ↦ 0 := by + filter_upwards [eventually_gt_atTop n] with m hm + rw [dite_eq_right hm.ne'] + exact (componentLatticeNorm m).eq_zero_iff _ |>.2 rfl + exact (tendsto_congr' heq).2 tendsto_const_nhds⟩ + +@[simp] private theorem finalCoordinateEmbedding_same (n : ℕ) (z : TreeComponent n) : + (finalCoordinateEmbedding n z).1 n = z := by + simp [finalCoordinateEmbedding] + +/-- Evaluates a single-coordinate embedding away from its chosen coordinate; +used in the final lattice and convergence calculations. -/ +theorem finalCoordinateEmbedding_ne (n m : ℕ) (h : m ≠ n) + (z : TreeComponent n) : (finalCoordinateEmbedding n z).1 m = 0 := by + simp [finalCoordinateEmbedding, h] + +/-- Pointwise lattice operations on the final `c₀`-sum. -/ +noncomputable instance finalSpaceLattice : Lattice FinalSpace where + le := fun x y ↦ x.1 ≤ y.1 + le_refl := fun _ ↦ le_rfl + le_trans := fun _ _ _ hxy hyz ↦ hxy.trans hyz + le_antisymm := fun x y hxy hyx ↦ Subtype.ext (le_antisymm hxy hyx) + sup := fun x y ↦ ⟨x.1 ⊔ y.1, componentC0Sublattice.sup_mem x.2 y.2⟩ + le_sup_left := fun _ _ ↦ le_sup_left + le_sup_right := fun _ _ ↦ le_sup_right + sup_le := fun _ _ _ hx hz ↦ sup_le hx hz + inf := fun x y ↦ ⟨x.1 ⊓ y.1, componentC0Sublattice.inf_mem x.2 y.2⟩ + inf_le_left := fun _ _ ↦ inf_le_left + inf_le_right := fun _ _ ↦ inf_le_right + le_inf := fun _ _ _ hx hz ↦ le_inf hx hz + +/-- Compatibility of addition and order on the final space. -/ +instance finalSpaceIsOrderedAddMonoid : IsOrderedAddMonoid FinalSpace where + add_le_add_left a b hab c := by + intro n + simpa [add_comm] using add_le_add_right (hab n) (c.1 n) + +/-- The final `c₀`-sum is a real vector lattice. -/ +noncomputable instance finalSpaceVectorLattice : VectorLattice FinalSpace where + smul_le_smul_of_nonneg_left := by + intro a ha x y hxy n + exact smul_le_smul_of_nonneg_left (hxy n) ha + +/-- The supremum norm on the final `c₀`-sum. -/ +noncomputable def finalNormValue (x : FinalSpace) : ℝ := + sSup (Set.range fun n ↦ componentLatticeNorm n (x.1 n)) + +/-- Records boundedness of the component norms of a `c₀` vector; needed to +justify the supremum defining `finalNormValue`. -/ +theorem finalNormValue_bddAbove (x : FinalSpace) : + BddAbove (Set.range fun n ↦ componentLatticeNorm n (x.1 n)) := + x.2.bddAbove_range + +/-- Bounds each component norm by the final supremum norm; used in all norm +laws and coordinatewise estimates for the final space. -/ +theorem componentNorm_le_finalNormValue (x : FinalSpace) (n : ℕ) : + componentLatticeNorm n (x.1 n) ≤ finalNormValue x := by + exact le_csSup (finalNormValue_bddAbove x) ⟨n, rfl⟩ + +/-- The final lattice norm, with all its laws exposed as proof obligations. -/ +noncomputable def finalLatticeNorm : PaperLatticeNorm FinalSpace where + toFun := finalNormValue + nonneg := by + intro x + exact ((componentLatticeNorm 0).nonneg _).trans + (componentNorm_le_finalNormValue x 0) + eq_zero_iff := by + intro x + constructor + · intro hx + apply Subtype.ext + funext n + apply (componentLatticeNorm n).eq_zero_iff (x.1 n) |>.1 + apply le_antisymm + · simpa [hx] using componentNorm_le_finalNormValue x n + · exact (componentLatticeNorm n).nonneg _ + · rintro rfl + unfold finalNormValue + have hzero : (fun n ↦ componentLatticeNorm n ((0 : FinalSpace).1 n)) = + fun _ ↦ 0 := by + funext n + apply (componentLatticeNorm n).eq_zero_iff _ |>.2 + rfl + rw [hzero] + simp + add_le := by + intro x y + apply csSup_le (Set.range_nonempty _) + rintro _ ⟨n, rfl⟩ + calc + componentLatticeNorm n ((x + y).1 n) ≤ + componentLatticeNorm n (x.1 n) + componentLatticeNorm n (y.1 n) := by + simpa using (componentLatticeNorm n).add_le (x.1 n) (y.1 n) + _ ≤ finalNormValue x + finalNormValue y := + add_le_add (componentNorm_le_finalNormValue x n) + (componentNorm_le_finalNormValue y n) + smul := by + intro a x + unfold finalNormValue + simp_rw [show ∀ n, componentLatticeNorm n ((a • x).1 n) = + |a| * componentLatticeNorm n (x.1 n) by + intro n + simpa using (componentLatticeNorm n).smul a (x.1 n)] + exact + (Real.smul_iSup_of_nonneg (abs_nonneg a) + (fun n ↦ componentLatticeNorm n (x.1 n))).symm + solid := by + intro x y hxy + apply csSup_le (Set.range_nonempty _) + rintro _ ⟨n, rfl⟩ + exact ((componentLatticeNorm n).solid (hxy n)).trans + (componentNorm_le_finalNormValue y n) + +/-- Paper Lemma `lem:c0-weak-fatou`. -/ +theorem finalSpace_weakFatou : + IsCompleteFor finalLatticeNorm ∧ HasWeakFatouProperty finalLatticeNorm 2 := by + have hcomplete : IsCompleteFor finalLatticeNorm := by + intro f hf + have hcoordCauchy (k : ℕ) : + ∀ ε > 0, ∃ N, ∀ m ≥ N, ∀ q ≥ N, + componentLatticeNorm k ((f m).1 k - (f q).1 k) < ε := by + intro ε hε + obtain ⟨N, hN⟩ := hf ε hε + refine ⟨N, fun m hm q hq ↦ ?_⟩ + exact (componentNorm_le_finalNormValue (f m - f q) k).trans_lt + (hN m hm q hq) + choose x hx using fun k ↦ (component_basic k).2.1 (fun m ↦ (f m).1 k) (hcoordCauchy k) + have hxVanishes : componentVanishes x := by + change Tendsto (fun k ↦ componentLatticeNorm k (x k)) atTop (nhds 0) + rw [Metric.tendsto_atTop] + intro ε hε + have hthird : 0 < ε / 3 := div_pos hε (by norm_num) + obtain ⟨N, hN⟩ := hf (ε / 3) hthird + have hfN : Tendsto (fun k ↦ componentLatticeNorm k ((f N).1 k)) + atTop (nhds 0) := (f N).2 + rw [Metric.tendsto_atTop] at hfN + obtain ⟨K, hK⟩ := hfN (ε / 3) hthird + refine ⟨K, fun k hk ↦ ?_⟩ + obtain ⟨L, hL⟩ := hx k (ε / 3) hthird + let m := max N L + have hmN : N ≤ m := le_max_left _ _ + have hmL : L ≤ m := le_max_right _ _ + have hmx : componentLatticeNorm k ((f m).1 k - x k) < ε / 3 := hL m hmL + have hfmN : componentLatticeNorm k ((f m).1 k - (f N).1 k) < ε / 3 := by + exact (componentNorm_le_finalNormValue (f m - f N) k).trans_lt (hN m hmN N le_rfl) + have hfNk : componentLatticeNorm k ((f N).1 k) < ε / 3 := by + have := hK k hk + rw [Real.dist_eq, sub_zero, abs_of_nonneg ((componentLatticeNorm k).nonneg _)] at this + exact this + have hneg : componentLatticeNorm k (x k - (f m).1 k) = + componentLatticeNorm k ((f m).1 k - x k) := by + rw [show x k - (f m).1 k = -((f m).1 k - x k) by abel, + show -((f m).1 k - x k) = (-1 : ℝ) • ((f m).1 k - x k) by simp, + (componentLatticeNorm k).smul] + norm_num + have hxbound : componentLatticeNorm k (x k) < ε := by + calc + componentLatticeNorm k (x k) = + componentLatticeNorm k ((x k - (f m).1 k) + + (((f m).1 k - (f N).1 k) + (f N).1 k)) := by + congr 1 + abel + _ ≤ componentLatticeNorm k (x k - (f m).1 k) + + componentLatticeNorm k (((f m).1 k - (f N).1 k) + (f N).1 k) := + (componentLatticeNorm k).add_le _ _ + _ ≤ componentLatticeNorm k (x k - (f m).1 k) + + (componentLatticeNorm k ((f m).1 k - (f N).1 k) + + componentLatticeNorm k ((f N).1 k)) := + add_le_add le_rfl ((componentLatticeNorm k).add_le _ _) + _ < ε := by rw [hneg]; linarith + rw [Real.dist_eq, sub_zero, abs_of_nonneg ((componentLatticeNorm k).nonneg _)] + exact hxbound + let x₀ : FinalSpace := ⟨x, hxVanishes⟩ + refine ⟨x₀, ?_⟩ + intro ε hε + have hhalf : 0 < ε / 2 := half_pos hε + obtain ⟨N, hN⟩ := hf (ε / 2) hhalf + refine ⟨N, fun q hq ↦ ?_⟩ + have hcoord (k : ℕ) : + componentLatticeNorm k ((f q).1 k - x k) ≤ ε / 2 := by + apply le_of_forall_pos_le_add + intro δ hδ + obtain ⟨L, hL⟩ := hx k δ hδ + let m := max N L + have hmN : N ≤ m := le_max_left _ _ + have hmL : L ≤ m := le_max_right _ _ + calc + componentLatticeNorm k ((f q).1 k - x k) = + componentLatticeNorm k (((f q).1 k - (f m).1 k) + + ((f m).1 k - x k)) := by + congr 1 + abel + _ ≤ componentLatticeNorm k ((f q).1 k - (f m).1 k) + + componentLatticeNorm k ((f m).1 k - x k) := + (componentLatticeNorm k).add_le _ _ + _ ≤ ε / 2 + δ := + (add_lt_add (componentNorm_le_finalNormValue (f q - f m) k |>.trans_lt + (hN q hq m hmN)) (hL m hmL)).le + have hfinal : finalLatticeNorm (f q - x₀) ≤ ε / 2 := by + apply csSup_le (Set.range_nonempty _) + rintro _ ⟨k, rfl⟩ + exact hcoord k + exact hfinal.trans_lt (by linarith) + have hweak : HasWeakFatouProperty finalLatticeNorm 2 := by + refine ⟨by norm_num, ?_⟩ + intro ι _ _ _ f x hfmono hfpos hflub c hfc + apply csSup_le (Set.range_nonempty _) + rintro _ ⟨k, rfl⟩ + have hcoordLUB : IsLUB (Set.range fun i ↦ (f i).1 k) (x.1 k) := by + constructor + · rintro _ ⟨i, rfl⟩ + exact hflub.1 ⟨i, rfl⟩ k + · intro z hz + let y : FinalSpace := x + finalCoordinateEmbedding k (z - x.1 k) + have hyupper : y ∈ upperBounds (Set.range f) := by + rintro _ ⟨i, rfl⟩ m + by_cases hmk : m = k + · subst m + simpa [y] using hz ⟨i, rfl⟩ + · have hix := hflub.1 ⟨i, rfl⟩ m + simpa [y, finalCoordinateEmbedding_ne k m hmk] using hix + have hxy := hflub.2 hyupper k + simpa [y] using hxy + exact (component_weakFatou k).2.2 (fun i ↦ (f i).1 k) (x.1 k) + (fun _ _ hij ↦ hfmono hij k) (fun i ↦ hfpos i k) hcoordLUB c + (fun i ↦ (componentNorm_le_finalNormValue (f i) k).trans (hfc i)) + exact ⟨hcomplete, hweak⟩ + +/-- Shows that single-coordinate inclusion is isometric; used to transfer the +component large-vector norm to the final space. -/ +theorem finalLatticeNorm_coordinateEmbedding (n : ℕ) (z : TreeComponent n) : + finalLatticeNorm (finalCoordinateEmbedding n z) = componentLatticeNorm n z := by + apply le_antisymm + · apply csSup_le (Set.range_nonempty _) + rintro _ ⟨m, rfl⟩ + by_cases hmn : m = n + · subst m + simp + · change componentLatticeNorm m ((finalCoordinateEmbedding n z).1 m) ≤ _ + rw [finalCoordinateEmbedding_ne n m hmn] + rw [(componentLatticeNorm m).eq_zero_iff 0 |>.2 rfl] + exact (componentLatticeNorm n).nonneg z + · have h := componentNorm_le_finalNormValue (finalCoordinateEmbedding n z) n + rw [finalCoordinateEmbedding_same] at h + exact h + +/-- Shows that single-coordinate inclusion preserves order convergence; used +to transfer iterated component adherence into the final space. -/ +theorem finalCoordinateEmbedding_orderConverges + {n : ℕ} {ι : Type} [Preorder ι] {f : ι → TreeComponent n} {z : TreeComponent n} + (hf : OrderConvergesTo f z) : + OrderConvergesTo (fun i ↦ finalCoordinateEmbedding n (f i)) + (finalCoordinateEmbedding n z) := by + classical + rcases hf with ⟨κ, hκpre, hκdir, hκne, r, hranti, hrpos, hrglb, hcontrol⟩ + let : Preorder κ := hκpre + let : IsDirected κ (· ≤ ·) := hκdir + let : Nonempty κ := hκne + refine ⟨κ, inferInstance, inferInstance, inferInstance, + fun k ↦ finalCoordinateEmbedding n (r k), ?_, ?_, ?_, ?_⟩ + · intro a b hab m + by_cases hmn : m = n + · subst m + simpa using hranti hab + · simp [finalCoordinateEmbedding_ne n m hmn] + · intro k m + by_cases hmn : m = n + · subst m + simpa using hrpos k + · simp [finalCoordinateEmbedding_ne n m hmn] + · constructor + · rintro _ ⟨k, rfl⟩ + intro m + by_cases hmn : m = n + · subst m + simpa using hrpos k + · simp [finalCoordinateEmbedding_ne n m hmn] + · intro y hy m + by_cases hmn : m = n + · subst m + apply hrglb.2 + rintro _ ⟨k, rfl⟩ + simpa using hy ⟨k, rfl⟩ n + · let k₀ : κ := Classical.choice inferInstance + have := hy ⟨k₀, rfl⟩ m + simpa [finalCoordinateEmbedding_ne n m hmn] using this + · intro k + filter_upwards [hcontrol k] with i hi + intro m + by_cases hmn : m = n + · subst m + change |(finalCoordinateEmbedding n (f i)).1 n - + (finalCoordinateEmbedding n z).1 n| ≤ + (finalCoordinateEmbedding n (r k)).1 n + simpa using hi + · change |(finalCoordinateEmbedding n (f i)).1 m - + (finalCoordinateEmbedding n z).1 m| ≤ + (finalCoordinateEmbedding n (r k)).1 m + rw [finalCoordinateEmbedding_ne n m hmn, + finalCoordinateEmbedding_ne n m hmn, + finalCoordinateEmbedding_ne n m hmn] + simp + +/-- Transfers membership through every finite adherence stage along a +coordinate embedding; used for `finalLargeVector_properties`. -/ +theorem finalCoordinateEmbedding_iteratedOrderAdherence (n k : ℕ) + {z : TreeComponent n} + (hz : z ∈ iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) k) : + finalCoordinateEmbedding n z ∈ + iteratedOrderAdherence (unitBallFor finalLatticeNorm) k := by + induction k generalizing z with + | zero => + change componentLatticeNorm n z ≤ 1 at hz + change finalLatticeNorm (finalCoordinateEmbedding n z) ≤ 1 + simpa [finalLatticeNorm_coordinateEmbedding] using hz + | succ k ih => + change z ∈ orderAdherence + (iteratedOrderAdherence (unitBallFor (componentLatticeNorm n)) k) at hz + rcases hz with ⟨ι, hpre, hdir, hne, f, hfmem, hfz⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + change finalCoordinateEmbedding n z ∈ orderAdherence + (iteratedOrderAdherence (unitBallFor finalLatticeNorm) k) + refine ⟨ι, inferInstance, inferInstance, inferInstance, + fun i ↦ finalCoordinateEmbedding n (f i), fun i ↦ ih (hfmem i), ?_⟩ + exact finalCoordinateEmbedding_orderConverges hfz + +/-- The vector `z_n`, supported in coordinate `n`. -/ +noncomputable def finalLargeVector (n : ℕ) : FinalSpace := + ⟨fun m ↦ if h : m = n then h.symm ▸ ((2 : ℝ) ^ n • componentRoot n) else 0, by + change Tendsto + (fun m ↦ componentLatticeNorm m + (if h : m = n then h.symm ▸ ((2 : ℝ) ^ n • componentRoot n) else 0)) + atTop (nhds 0) + have heq : (fun m ↦ componentLatticeNorm m + (if h : m = n then h.symm ▸ ((2 : ℝ) ^ n • componentRoot n) else 0)) =ᶠ[atTop] + fun _ ↦ 0 := by + filter_upwards [eventually_gt_atTop n] with m hm + rw [dite_eq_right hm.ne'] + exact (componentLatticeNorm m).eq_zero_iff _ |>.2 rfl + exact (tendsto_congr' heq).2 tendsto_const_nhds⟩ + +/-- Paper Proposition `prop:zn`. -/ +theorem finalLargeVector_properties (n : ℕ) : + finalLargeVector n ∈ iteratedOrderAdherence (unitBallFor finalLatticeNorm) n ∧ + finalLatticeNorm (finalLargeVector n) = (2 : ℝ) ^ n := by + have heq : finalLargeVector n = + finalCoordinateEmbedding n ((2 : ℝ) ^ n • componentRoot n) := by + apply Subtype.ext + funext m + simp [finalLargeVector, finalCoordinateEmbedding] + rw [heq] + exact ⟨finalCoordinateEmbedding_iteratedOrderAdherence n n + (component_large_iterated_adherence n).2.2.2.1, + (finalLatticeNorm_coordinateEmbedding n _).trans + (component_large_iterated_adherence n).2.2.2.2⟩ + +/-- The constructed `c₀`-sum admits no equivalent Fatou lattice norm. -/ +theorem finalSpace_not_equivalent_fatou : + ∀ q : PaperLatticeNorm FinalSpace, + HasFatouProperty q → ¬ EquivalentNorms finalLatticeNorm q := by + intro q hq hequiv + rcases hequiv with ⟨c, C, hc, hC, hcompare⟩ + obtain ⟨n₀, hn₀⟩ := pow_unbounded_of_one_lt (C / c : ℝ) (by norm_num : (1 : ℝ) < 2) + let n := n₀ + 1 + have hn : 1 ≤ n := by simp [n] + have hlarge : C < c * (2 : ℝ) ^ n := by + have hpow : (2 : ℝ) ^ n₀ < (2 : ℝ) ^ n := by + change (2 : ℝ) ^ n₀ < (2 : ℝ) ^ (n₀ + 1) + rw [pow_succ] + nlinarith [pow_pos (by norm_num : (0 : ℝ) < 2) n₀] + have hcdiv : C < c * (2 : ℝ) ^ n₀ := by + rw [div_lt_iff₀ hc] at hn₀ + simpa [mul_comm] using hn₀ + exact hcdiv.trans (mul_lt_mul_of_pos_left hpow hc) + have hball : unitBallFor finalLatticeNorm ⊆ scaleSet C (unitBallFor q) := by + intro z hz + refine ⟨C⁻¹ • z, ?_, ?_⟩ + · change q (C⁻¹ • z) ≤ 1 + rw [q.smul, abs_of_pos (inv_pos.mpr hC), inv_mul_le_one₀ hC] + exact (hcompare z).2.trans (by + simpa using mul_le_mul_of_nonneg_left hz hC.le) + · simp [smul_smul, hC.ne'] + have hitermono : ∀ k, + iteratedOrderAdherence (unitBallFor finalLatticeNorm) k ⊆ + iteratedOrderAdherence (scaleSet C (unitBallFor q)) k := by + intro k + induction k with + | zero => exact hball + | succ k ih => exact orderAdherence_mono ih + have hsolidq : LatticeOrderedAddCommGroup.IsSolid (unitBallFor q) := by + intro y hy z hzy + exact (q.solid hzy).trans hy + have hscale := + (iteratedOrderAdherence_mono_and_scale hsolidq hsolidq hC).2.2 n + have hz := hitermono n (finalLargeVector_properties n).1 + rw [hscale, fatou_iterated_unitBall q hq n hn] at hz + rcases hz with ⟨y, hy, hyz⟩ + have hqz : q (finalLargeVector n) ≤ C := by + rw [← hyz, q.smul, abs_of_pos hC] + simpa using mul_le_mul_of_nonneg_left hy hC.le + have hpz : finalLatticeNorm (finalLargeVector n) = (2 : ℝ) ^ n := + (finalLargeVector_properties n).2 + have hlower := (hcompare (finalLargeVector n)).1 + rw [hpz] at hlower + exact (not_lt_of_ge (hlower.trans hqz)) hlarge + +/-- Paper Theorem `thm:fremlin-main`. -/ +theorem exists_weaklyFatou_not_equivalent_fatou : + ∃ (X : Type) (_ : AddCommGroup X) (_ : Lattice X) (_ : IsOrderedAddMonoid X) + (_ : VectorLattice X), + ∃ p : PaperLatticeNorm X, IsCompleteFor p ∧ HasWeakFatouProperty p 2 ∧ + ∀ q : PaperLatticeNorm X, HasFatouProperty q → ¬ EquivalentNorms p q := by + refine ⟨FinalSpace, inferInstance, inferInstance, inferInstance, inferInstance, + finalLatticeNorm, (finalSpace_weakFatou).1, (finalSpace_weakFatou).2, + finalSpace_not_equivalent_fatou⟩ + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou/FiniteTree.lean b/LeanPool/OrderClosures/WeaklyFatou/FiniteTree.lean new file mode 100644 index 0000000000..81bdf534ce --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/FiniteTree.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.Reductions + + +/-! +# The finite tree + +The finite-height tree, its cylinder sets, and the parent-disjointness lemma. +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-- Nodes of the finite-height tree `G_n = ⋃_{k ≤ n} ℕ^k`. -/ +abbrev TreeNode (n : ℕ) := {t : List ℕ // t.length ≤ n} + +namespace TreeNode + +/-- Level of a node. -/ +abbrev level {n : ℕ} (t : TreeNode n) : ℕ := t.1.length + +/-- The root `∅`. -/ +def root (n : ℕ) : TreeNode n := ⟨[], by simp⟩ + +/-- The child `t⌢m`. -/ +def child {n : ℕ} (t : TreeNode n) (h : level t < n) (m : ℕ) : TreeNode n := + ⟨t.1 ++ [m], by + simpa [level] using h⟩ + +/-- The parent map, fixing the root. -/ +def parent {n : ℕ} (t : TreeNode n) : TreeNode n := + ⟨t.1.dropLast, by + rw [List.length_dropLast] + exact (Nat.sub_le _ _).trans t.2⟩ + +/-- Restriction `t|j`. -/ +def restrict {n : ℕ} (t : TreeNode n) (j : ℕ) : TreeNode n := + ⟨t.1.take j, by + rw [List.length_take] + exact (min_le_right _ _).trans t.2⟩ + +end TreeNode + +/-- Non-terminal nodes `H_n`. -/ +abbrev TreeNonterminal (n : ℕ) := {t : TreeNode n // TreeNode.level t < n} + +/-- The product space `I_n = ℕ^{H_n}`. -/ +abbrev TreeProduct (n : ℕ) := TreeNonterminal n → ℕ + +/-- The strict prefix `t|j`, regarded as a non-terminal node. -/ +def strictPrefix {n : ℕ} (t : TreeNode n) (j : Fin (TreeNode.level t)) : + TreeNonterminal n := + ⟨TreeNode.restrict t j, by + calc + (TreeNode.restrict t j).level ≤ j := List.length_take_le _ _ + _ < TreeNode.level t := j.isLt + _ ≤ n := t.2⟩ + +/-- The cylinder `E_t`. -/ +def treeCylinder (n : ℕ) (t : TreeNode n) : Set (TreeProduct n) := + {α | ∀ j : Fin (TreeNode.level t), α (strictPrefix t j) ≤ t.1.get j} + +/-- Characterizes membership in a child cylinder by the parent coordinates +and one new label; used in the cylinder partition proofs. -/ +theorem mem_treeCylinder_child_iff + (n : ℕ) (t : TreeNode n) (ht : TreeNode.level t < n) (m : ℕ) + (α : TreeProduct n) : + α ∈ treeCylinder n (TreeNode.child t ht m) ↔ + α ∈ treeCylinder n t ∧ α ⟨t, ht⟩ ≤ m := by + constructor + · intro h + constructor + · intro j + let j' : Fin (TreeNode.level (TreeNode.child t ht m)) := + ⟨j, by + simp [TreeNode.level, TreeNode.child]⟩ + have hj := h j' + have hpref : strictPrefix (TreeNode.child t ht m) j' = strictPrefix t j := by + apply Subtype.ext + apply Subtype.ext + exact List.take_append_of_le_length j.isLt.le + have hget : (TreeNode.child t ht m).1.get j' = t.1.get j := by + rw [List.get_eq_getElem, List.get_eq_getElem] + exact List.getElem_append_left j.isLt + rw [hpref, hget] at hj + exact hj + · let j : Fin (TreeNode.level (TreeNode.child t ht m)) := + ⟨TreeNode.level t, by simp [TreeNode.level, TreeNode.child]⟩ + have hj := h j + have hpref : strictPrefix (TreeNode.child t ht m) j = ⟨t, ht⟩ := by + apply Subtype.ext + apply Subtype.ext + simp [j, strictPrefix, TreeNode.restrict, TreeNode.level, TreeNode.child] + have hget : (TreeNode.child t ht m).1.get j = m := by + simp [j, TreeNode.level, TreeNode.child] + rw [hpref, hget] at hj + exact hj + · rintro ⟨h, hlast⟩ j + by_cases hj : (j : ℕ) < TreeNode.level t + · let j' : Fin (TreeNode.level t) := ⟨j, hj⟩ + have hprefix := h j' + have hpref : strictPrefix (TreeNode.child t ht m) j = strictPrefix t j' := by + apply Subtype.ext + apply Subtype.ext + exact List.take_append_of_le_length hj.le + have hget : (TreeNode.child t ht m).1.get j = t.1.get j' := by + rw [List.get_eq_getElem, List.get_eq_getElem] + exact List.getElem_append_left hj + rw [hpref, hget] + exact hprefix + · have hjeq : (j : ℕ) = TreeNode.level t := by + have hjlt : (j : ℕ) < TreeNode.level t + 1 := by + simpa [TreeNode.level, TreeNode.child] using j.isLt + omega + let jlast : Fin (TreeNode.level (TreeNode.child t ht m)) := + ⟨TreeNode.level t, by simp [TreeNode.level, TreeNode.child]⟩ + have hjlast : j = jlast := Fin.ext hjeq + rw [hjlast] + have hpref : strictPrefix (TreeNode.child t ht m) jlast = ⟨t, ht⟩ := by + apply Subtype.ext + apply Subtype.ext + simp [jlast, strictPrefix, TreeNode.restrict, TreeNode.level, TreeNode.child] + have hget : (TreeNode.child t ht m).1.get jlast = m := by + simp [jlast, TreeNode.level, TreeNode.child] + rw [hpref, hget] + exact hlast + +/-- Paper Lemma `lem:basic-tree`, part (a). -/ +theorem treeCylinder_isClopen (n : ℕ) (t : TreeNode n) : + IsClopen (treeCylinder n t) := by + rw [show treeCylinder n t = + ⋂ j : Fin (TreeNode.level t), + {α | α (strictPrefix t j) ≤ t.1.get j} by + ext α + simp [treeCylinder]] + apply isClopen_iInter_of_finite + intro j + exact (isClopen_discrete {m : ℕ | m ≤ t.1.get j}).preimage + (continuous_apply (strictPrefix t j)) + +/-- The characteristic function `s_t = χ_{E_t}`. -/ +noncomputable def treeFunction (n : ℕ) (t : TreeNode n) : + BoundedContinuousFunction (TreeProduct n) ℝ := + BoundedContinuousFunction.indicator (treeCylinder n t) (treeCylinder_isClopen n t) + +/-- Evaluates a tree function on its supporting cylinder; used in the exact +basis and tree-operator computations. -/ +theorem treeFunction_apply_of_mem (n : ℕ) (t : TreeNode n) + {α : TreeProduct n} (hα : α ∈ treeCylinder n t) : treeFunction n t α = 1 := by + classical + simp [treeFunction, BoundedContinuousFunction.indicator, Set.indicator, hα] + +/-- Evaluates a tree function off its supporting cylinder; used to show finite +tree sums vanish outside their cylinder union. -/ +theorem treeFunction_apply_of_notMem (n : ℕ) (t : TreeNode n) + {α : TreeProduct n} (hα : α ∉ treeCylinder n t) : treeFunction n t α = 0 := by + classical + simp [treeFunction, BoundedContinuousFunction.indicator, Set.indicator, hα] + +/-- BanLat's vector-lattice structure is supplied here for real-valued bounded +continuous functions; all non-proof data comes from Mathlib's pointwise instances. -/ +noncomputable instance boundedContinuousFunctionNormedVectorLattice + (A : Type u) [TopologicalSpace A] : + NormedVectorLattice (BoundedContinuousFunction A ℝ) where + smul_le_smul_of_nonneg_left := by + intro a ha f g h p + exact mul_le_mul_of_nonneg_left (h p) ha + +/-- Paper Lemma `lem:basic-tree`, parts (b) and (c). -/ +theorem treeFunction_child_properties + (n : ℕ) (t : TreeNode n) (ht : TreeNode.level t < n) : + (∀ m, treeCylinder n (TreeNode.child t ht m) ⊆ treeCylinder n t ∧ + treeFunction n (TreeNode.child t ht m) ≤ treeFunction n t) ∧ + Monotone (fun m ↦ treeFunction n (TreeNode.child t ht m)) ∧ + IsLUB (Set.range fun m ↦ treeFunction n (TreeNode.child t ht m)) + (treeFunction n t) := by + have hnonneg : ∀ u : TreeNode n, 0 ≤ treeFunction n u := by + intro u α + change 0 ≤ treeFunction n u α + by_cases hα : α ∈ treeCylinder n u + · rw [treeFunction_apply_of_mem n u hα] + norm_num + · rw [treeFunction_apply_of_notMem n u hα] + have hindicator_mono : ∀ {u v : TreeNode n}, + treeCylinder n u ⊆ treeCylinder n v → treeFunction n u ≤ treeFunction n v := by + intro u v huv α + change treeFunction n u α ≤ treeFunction n v α + by_cases hα : α ∈ treeCylinder n u + · rw [treeFunction_apply_of_mem n u hα, + treeFunction_apply_of_mem n v (huv hα)] + · rw [treeFunction_apply_of_notMem n u hα] + exact hnonneg v α + have hsubset : ∀ m, + treeCylinder n (TreeNode.child t ht m) ⊆ treeCylinder n t := by + intro m α hα + exact (mem_treeCylinder_child_iff n t ht m α).mp hα |>.1 + have hle : ∀ m, treeFunction n (TreeNode.child t ht m) ≤ treeFunction n t := + fun m ↦ hindicator_mono (hsubset m) + refine ⟨fun m ↦ ⟨hsubset m, hle m⟩, ?_, ?_⟩ + · intro a b hab + apply hindicator_mono + intro α hα + rcases (mem_treeCylinder_child_iff n t ht a α).mp hα with ⟨hαt, hlast⟩ + exact (mem_treeCylinder_child_iff n t ht b α).mpr ⟨hαt, hlast.trans hab⟩ + · constructor + · rintro _ ⟨m, rfl⟩ + exact hle m + · intro g hg α + change treeFunction n t α ≤ g α + by_cases hα : α ∈ treeCylinder n t + · let m := α ⟨t, ht⟩ + have hchild : α ∈ treeCylinder n (TreeNode.child t ht m) := + (mem_treeCylinder_child_iff n t ht m α).mpr ⟨hα, le_rfl⟩ + calc + treeFunction n t α = 1 := treeFunction_apply_of_mem n t hα + _ = treeFunction n (TreeNode.child t ht m) α := + (treeFunction_apply_of_mem n _ hchild).symm + _ ≤ g α := hg ⟨m, rfl⟩ α + · rw [treeFunction_apply_of_notMem n t hα] + exact (hnonneg (TreeNode.child t ht 0) α).trans (hg ⟨0, rfl⟩ α) + +/-- Paper Lemma `lem:finite-cover`. -/ +theorem treeCylinder_finite_cover + (n : ℕ) (t : TreeNode n) (F : Finset (TreeNode n)) + (hcover : ∀ α ∈ treeCylinder n t, ∃ u ∈ F, α ∈ treeCylinder n u) : + ∃ u ∈ F, treeCylinder n t ⊆ treeCylinder n u := by + classical + by_contra hconcl + push Not at hconcl + let witness : ↥F → TreeProduct n := fun u ↦ + Classical.choose (Set.not_subset.mp (hconcl u.1 u.2)) + have hwitness_mem (u : ↥F) : witness u ∈ treeCylinder n t := + (Classical.choose_spec (Set.not_subset.mp (hconcl u.1 u.2))).1 + have hwitness_notMem (u : ↥F) : witness u ∉ treeCylinder n u.1 := + (Classical.choose_spec (Set.not_subset.mp (hconcl u.1 u.2))).2 + let α : TreeProduct n := fun q ↦ Finset.univ.sup fun u : ↥F ↦ witness u q + have hαt : α ∈ treeCylinder n t := by + intro j + apply Finset.sup_le + intro u _ + exact hwitness_mem u j + obtain ⟨u, huF, hαu⟩ := hcover α hαt + let uF : ↥F := ⟨u, huF⟩ + have hnot := hwitness_notMem uF + simp only [treeCylinder, Set.mem_ofPred_eq] at hnot + push Not at hnot + obtain ⟨j, hj⟩ := hnot + have hle : witness uF (strictPrefix u j) ≤ α (strictPrefix u j) := by + exact Finset.le_sup (s := Finset.univ) + (f := fun v : ↥F ↦ witness v (strictPrefix u j)) (Finset.mem_univ uF) + exact (not_lt_of_ge (hαu j)) (hj.trans_le hle) + +/-- Parent-disjointness (`π`-disjointness in the source). -/ +def ParentDisjoint {n : ℕ} (A B : Set (TreeNode n)) : Prop := + TreeNode.parent '' A ∩ TreeNode.parent '' B = ∅ + +/-- The finite union of the cylinders indexed by `F`. -/ +def finiteCylinderUnion (n : ℕ) (F : Finset (TreeNode n)) : Set (TreeProduct n) := + ⋃ t : F, treeCylinder n t.1 + +/-- The finite supremum of the tree functions, represented by the indicator +of the corresponding finite union. -/ +noncomputable def finiteTreeSup (n : ℕ) (F : Finset (TreeNode n)) : + BoundedContinuousFunction (TreeProduct n) ℝ := + BoundedContinuousFunction.indicator (finiteCylinderUnion n F) (by + apply isClopen_iUnion_of_finite + exact fun t ↦ treeCylinder_isClopen n t.1) + +/-- The last label of a nonroot node, with a harmless root default; used to +construct coordinates escaping finite cylinder unions. -/ +def treeLastLabel {n : ℕ} (t : TreeNode n) : ℕ := + if h : 0 < TreeNode.level t then + t.1.get ⟨TreeNode.level t - 1, Nat.sub_lt h (by omega)⟩ else 0 + +/-- Identifies the last strict prefix with the parent of a nonroot node; used +when constructing points outside parent-disjoint cylinder families. -/ +theorem strictPrefix_last_eq_parent {n : ℕ} (t : TreeNode n) + (ht : 0 < TreeNode.level t) : + let j : Fin (TreeNode.level t) := + ⟨TreeNode.level t - 1, Nat.sub_lt ht (by omega)⟩ + (strictPrefix t j).1 = TreeNode.parent t ∧ t.1.get j = treeLastLabel t := by + dsimp + constructor + · apply Subtype.ext + simp [strictPrefix, TreeNode.restrict, TreeNode.parent, TreeNode.level, + List.dropLast_eq_take] + · simp only [treeLastLabel, dite_eq_left ht] + rfl + +/-- Records positivity of a finite supremum of tree functions; used in the +least-upper-bound statement for parent-disjoint families. -/ +theorem finiteTreeSup_nonneg (n : ℕ) (F : Finset (TreeNode n)) : + 0 ≤ finiteTreeSup n F := by + intro α + classical + by_cases hα : α ∈ finiteCylinderUnion n F <;> + simp [finiteTreeSup, BoundedContinuousFunction.indicator, Set.indicator, hα] + +/-- Shows that a finite tree supremum vanishes outside its cylinder union; +used in the common-lower-bound argument. -/ +theorem finiteTreeSup_apply_of_notMem (n : ℕ) (F : Finset (TreeNode n)) + {α : TreeProduct n} (hα : α ∉ finiteCylinderUnion n F) : + finiteTreeSup n F α = 0 := by + classical + simp [finiteTreeSup, BoundedContinuousFunction.indicator, Set.indicator, hα] + +/-- Forces a common lower bound to be nonpositive when supports have +parent-disjoint subsequences; reused in both tree and transient-band lemmas. -/ +theorem commonLower_le_zero_of_parentDisjoint_subseq + (n : ℕ) (F : ℕ → Finset (TreeNode n)) + (hF : Pairwise fun i j ↦ ParentDisjoint (F i : Set (TreeNode n)) + (F j : Set (TreeNode n))) + (φ : ℕ → ℕ) (hφ : Function.Injective φ) + (hroot : ∀ m, TreeNode.root n ∉ F (φ m)) + (g : ℕ → BoundedContinuousFunction (TreeProduct n) ℝ) + (hgzero : ∀ m α, α ∉ finiteCylinderUnion n (F (φ m)) → g (φ m) α = 0) + {z : BoundedContinuousFunction (TreeProduct n) ℝ} + (hz : ∀ m, z ≤ g m) : z ≤ 0 := by + classical + intro α + change z α ≤ 0 + let β : ℕ → TreeProduct n := fun m q ↦ + max (α q) ((F (φ m)).sup fun t ↦ + if TreeNode.parent t = q.1 then treeLastLabel t + 1 else 0) + have hβoutside : ∀ m, β m ∉ finiteCylinderUnion n (F (φ m)) := by + intro m hmem + simp only [finiteCylinderUnion, Set.mem_iUnion] at hmem + obtain ⟨t, ht⟩ := hmem + have htF : t.1 ∈ F (φ m) := t.2 + have htroot : t.1 ≠ TreeNode.root n := fun h ↦ hroot m (h ▸ htF) + have htpos : 0 < TreeNode.level t.1 := Nat.pos_of_ne_zero fun hzero ↦ by + apply htroot + apply Subtype.ext + have hnil : t.1.1 = [] := List.length_eq_zero_iff.mp (by + simpa [TreeNode.level] using hzero) + simpa [TreeNode.root] using hnil + let j : Fin (TreeNode.level t.1) := + ⟨TreeNode.level t.1 - 1, Nat.sub_lt htpos (by omega)⟩ + have hj := strictPrefix_last_eq_parent t.1 htpos + have hsup : treeLastLabel t.1 + 1 ≤ + (F (φ m)).sup fun u ↦ + if TreeNode.parent u = (strictPrefix t.1 j).1 then treeLastLabel u + 1 else 0 := by + have hle := Finset.le_sup (s := F (φ m)) + (f := fun u ↦ if TreeNode.parent u = (strictPrefix t.1 j).1 then + treeLastLabel u + 1 else 0) htF + have hjparent : TreeNode.parent t.1 = (strictPrefix t.1 j).1 := hj.1.symm + change (if TreeNode.parent t.1 = (strictPrefix t.1 j).1 then + treeLastLabel t.1 + 1 else 0) ≤ _ at hle + rw [ite_eq_left hjparent] at hle + exact hle + have hlarge : treeLastLabel t.1 + 1 ≤ β m (strictPrefix t.1 j) := + hsup.trans (le_max_right _ _) + have hcyl := ht j + rw [hj.2] at hcyl + exact (not_lt_of_ge hcyl) (lt_of_lt_of_le (Nat.lt_succ_self _) hlarge) + have hβtendsto : Tendsto β atTop (nhds α) := by + rw [tendsto_pi_nhds] + intro q + let bad : Set ℕ := {m | ∃ t ∈ F (φ m), TreeNode.parent t = q.1} + have hbadsub : bad.Subsingleton := by + intro i hi j hj + rcases hi with ⟨ti, hti, hpi⟩ + rcases hj with ⟨tj, htj, hpj⟩ + by_contra hij + have hindices : φ i ≠ φ j := fun h ↦ hij (hφ h) + have hdis := hF hindices + have hqmem : q.1 ∈ + TreeNode.parent '' (F (φ i) : Set (TreeNode n)) ∩ + TreeNode.parent '' (F (φ j) : Set (TreeNode n)) := by + constructor + · exact ⟨ti, hti, hpi⟩ + · exact ⟨tj, htj, hpj⟩ + rw [hdis] at hqmem + exact hqmem + have hevent : ∀ᶠ m in atTop, m ∉ bad := by + rw [← Nat.cofinite_eq_atTop] + exact hbadsub.finite.eventually_cofinite_notMem + have heq : (fun m ↦ β m q) =ᶠ[atTop] fun _ ↦ α q := by + filter_upwards [hevent] with m hm + have hsupzero : (F (φ m)).sup (fun t ↦ + if TreeNode.parent t = q.1 then treeLastLabel t + 1 else 0) = 0 := by + apply le_antisymm + · apply Finset.sup_le + intro t ht + rw [ite_eq_right] + intro hparent + exact hm ⟨t, ht, hparent⟩ + · exact bot_le + simp [β, hsupzero] + exact (tendsto_congr' heq).2 tendsto_const_nhds + have hzβ : ∀ m, z (β m) ≤ 0 := by + intro m + have hle := hz (φ m) (β m) + change z (β m) ≤ g (φ m) (β m) at hle + rw [hgzero m (β m) (hβoutside m)] at hle + exact hle + have hzlim : Tendsto (fun m ↦ z (β m)) atTop (nhds (z α)) := + Filter.Tendsto.comp z.continuous.continuousAt hβtendsto + exact isClosed_Iic.mem_of_tendsto hzlim (Eventually.of_forall hzβ) + +/-- Paper Lemma `lem:pi-disjoint`. -/ +theorem parentDisjoint_treeFunctions_iInf + (n : ℕ) (F : ℕ → Finset (TreeNode n)) + (hF : Pairwise fun i j ↦ ParentDisjoint (F i : Set (TreeNode n)) (F j : Set (TreeNode n))) : + IsGLB (Set.range fun m ↦ finiteTreeSup n (F m)) 0 := by + constructor + · rintro _ ⟨m, rfl⟩ + exact finiteTreeSup_nonneg n (F m) + · intro z hz + have hzall : ∀ m, z ≤ finiteTreeSup n (F m) := fun m ↦ hz ⟨m, rfl⟩ + by_cases hrootExists : ∃ i, TreeNode.root n ∈ F i + · obtain ⟨i, hi⟩ := hrootExists + let φ : ℕ → ℕ := fun m ↦ i + m + 1 + have hφ : Function.Injective φ := by + intro a b h + dsimp [φ] at h + omega + have hroot : ∀ m, TreeNode.root n ∉ F (φ m) := by + intro m hm + have hne : i ≠ φ m := by + dsimp [φ] + omega + have hdis := hF hne + have hmem : TreeNode.root n ∈ + TreeNode.parent '' (F i : Set (TreeNode n)) ∩ + TreeNode.parent '' (F (φ m) : Set (TreeNode n)) := by + constructor + · exact ⟨TreeNode.root n, hi, by rfl⟩ + · exact ⟨TreeNode.root n, hm, by rfl⟩ + rw [hdis] at hmem + exact hmem + exact commonLower_le_zero_of_parentDisjoint_subseq n F hF φ hφ hroot + (fun m ↦ finiteTreeSup n (F m)) + (fun m α hα ↦ finiteTreeSup_apply_of_notMem n _ hα) hzall + · push Not at hrootExists + exact commonLower_le_zero_of_parentDisjoint_subseq n F hF id + Function.injective_id hrootExists (fun m ↦ finiteTreeSup n (F m)) + (fun m α hα ↦ finiteTreeSup_apply_of_notMem n _ hα) hzall + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou/Moderated.lean b/LeanPool/OrderClosures/WeaklyFatou/Moderated.lean new file mode 100644 index 0000000000..6dcbc028bc --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/Moderated.lean @@ -0,0 +1,459 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.Bands + + +/-! +# Thinning, transient bands, and component moderatedness +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-- Paper Lemma `lem:thinning`. -/ +theorem tree_thinning + (n : ℕ) (w : ℕ → TreeCoefficients n) (Λ : Finset (TreeBandIndex n)) + (hΛ : recurrentBands n w ⊆ (Λ : Set (TreeBandIndex n))) : + ∃ φ : ℕ → ℕ, StrictMono φ ∧ ∀ B ∉ Λ, + {m | (treeBandProjection n B (w (φ m))).support.Nonempty}.Subsingleton := by + classical + let φ : ℕ → ℕ := fun m ↦ Nat.rec 0 (fun _ r ↦ + max (r + 1) (((bandsAt n (w r)).filter fun B ↦ B ∉ Λ).sup fun B ↦ + lastBandOccurrence n w B + 1)) m + have hφ_succ (m : ℕ) : φ (m + 1) = + max (φ m + 1) (((bandsAt n (w (φ m))).filter fun B ↦ B ∉ Λ).sup fun B ↦ + lastBandOccurrence n w B + 1) := by simp [φ] + have hφ : StrictMono φ := by + apply strictMono_nat_of_lt_succ + intro m + rw [hφ_succ] + exact (Nat.lt_succ_self _).trans_le (le_max_left _ _) + refine ⟨φ, hφ, ?_⟩ + intro B hBΛ + have hBfinite : {m | (treeBandProjection n B (w m)).support.Nonempty}.Finite := by + apply Set.not_infinite.mp + intro hInf + exact hBΛ (hΛ hInf) + intro i hi j hj + by_contra hij + rcases lt_or_gt_of_ne hij with hijlt | hjilt + · have hBbands : B ∈ bandsAt n (w (φ i)) := + (mem_bandsAt_iff n _ B).mpr hi + have hBfilter : B ∈ (bandsAt n (w (φ i))).filter fun B ↦ B ∉ Λ := + Finset.mem_filter.mpr ⟨hBbands, hBΛ⟩ + have hlast_lt_succ : lastBandOccurrence n w B < φ (i + 1) := by + have hle := Finset.le_sup + (s := (bandsAt n (w (φ i))).filter fun B ↦ B ∉ Λ) + (f := fun B ↦ lastBandOccurrence n w B + 1) hBfilter + change lastBandOccurrence n w B + 1 ≤ _ at hle + have hle' := hle.trans (le_max_right (φ i + 1) + (((bandsAt n (w (φ i))).filter fun B ↦ B ∉ Λ).sup fun B ↦ + lastBandOccurrence n w B + 1)) + rw [← hφ_succ] at hle' + omega + have hsucc_le : φ (i + 1) ≤ φ j := hφ.monotone (Nat.succ_le_iff.mpr hijlt) + have hjlast := le_lastBandOccurrence n w B hBfinite hj + omega + · have hBbands : B ∈ bandsAt n (w (φ j)) := + (mem_bandsAt_iff n _ B).mpr hj + have hBfilter : B ∈ (bandsAt n (w (φ j))).filter fun B ↦ B ∉ Λ := + Finset.mem_filter.mpr ⟨hBbands, hBΛ⟩ + have hlast_lt_succ : lastBandOccurrence n w B < φ (j + 1) := by + have hle := Finset.le_sup + (s := (bandsAt n (w (φ j))).filter fun B ↦ B ∉ Λ) + (f := fun B ↦ lastBandOccurrence n w B + 1) hBfilter + change lastBandOccurrence n w B + 1 ≤ _ at hle + have hle' := hle.trans (le_max_right (φ j + 1) + (((bandsAt n (w (φ j))).filter fun B ↦ B ∉ Λ).sup fun B ↦ + lastBandOccurrence n w B + 1)) + rw [← hφ_succ] at hle' + omega + have hsucc_le : φ (j + 1) ≤ φ i := hφ.monotone (Nat.succ_le_iff.mpr hjilt) + have hilast := le_lastBandOccurrence n w B hBfinite hi + omega + +/-- Shows that a tree operator vanishes outside the union of cylinders in its +support; used by `tree_transient` to eliminate common positive lower bounds. -/ +theorem treeOperator_apply_eq_zero_of_outside_support + (n : ℕ) (w : TreeCoefficients n) {α : TreeProduct n} + (hα : α ∉ finiteCylinderUnion n w.support) : + treeOperator n w α = 0 := by + classical + rw [treeOperator_apply, Finsupp.sum] + apply Finset.sum_eq_zero + intro t ht + have hnot : α ∉ treeCylinder n t := by + intro hmem + apply hα + simp only [finiteCylinderUnion, Set.mem_iUnion] + exact ⟨⟨t, ht⟩, hmem⟩ + rw [treeFunction_apply_of_notMem n t hnot, mul_zero] + +/-- Paper Lemma `lem:transient`. -/ +theorem tree_transient + (n : ℕ) (w : ℕ → TreeCoefficients n) (Λ : Finset (TreeBandIndex n)) + (hnone : none ∈ Λ) + (hdis : ∀ B ∉ Λ, + {m | (treeBandProjection n B (w m)).support.Nonempty}.Subsingleton) : + let v := fun m ↦ w m - finiteBandProjection n Λ (w m) + (Pairwise fun i j ↦ ParentDisjoint ((v i).support : Set (TreeNode n)) + ((v j).support : Set (TreeNode n))) ∧ + ∀ z : BoundedContinuousFunction (TreeProduct n) ℝ, + 0 ≤ z → (∀ m, z ≤ treeOperator n (v m)) → z = 0 := by + classical + dsimp + let v : ℕ → TreeCoefficients n := fun m ↦ + w m - finiteBandProjection n Λ (w m) + have hv_apply (m : ℕ) (t : TreeNode n) : + v m t = if treeBandOfNode n t ∈ Λ then 0 else w m t := by + change (w m - finiteBandProjection n Λ (w m)) t = _ + rw [Finsupp.sub_apply] + by_cases hB : treeBandOfNode n t ∈ Λ + · rw [(finiteBandProjection_apply n Λ (w m) t).1 hB] + simp [hB] + · rw [(finiteBandProjection_apply n Λ (w m) t).2 hB] + simp [hB] + have hv_band_notMem {m : ℕ} {t : TreeNode n} (ht : t ∈ (v m).support) : + treeBandOfNode n t ∉ Λ := by + intro hB + have htne := Finsupp.mem_support_iff.mp ht + rw [hv_apply, ite_eq_left hB] at htne + exact htne rfl + have hv_root_notMem (m : ℕ) : TreeNode.root n ∉ (v m).support := by + intro ht + have hB := hv_band_notMem ht + apply hB + simpa [treeBandOfNode] using hnone + have hpair : Pairwise fun i j ↦ + ParentDisjoint ((v i).support : Set (TreeNode n)) + ((v j).support : Set (TreeNode n)) := by + intro i j hij + apply Set.eq_empty_iff_forall_notMem.mpr + intro q hq + rcases hq.1 with ⟨ti, hti, hpti⟩ + rcases hq.2 with ⟨tj, htj, hptj⟩ + have htiroot : ti ≠ TreeNode.root n := fun h ↦ hv_root_notMem i (h ▸ hti) + have htjroot : tj ≠ TreeNode.root n := fun h ↦ hv_root_notMem j (h ▸ htj) + let B := treeBandOfNode n ti + have hBnot : B ∉ Λ := hv_band_notMem hti + have hBsame : treeBandOfNode n tj = B := by + change treeBandOfNode n tj = treeBandOfNode n ti + rw [treeBandOfNode, dite_eq_right htjroot, treeBandOfNode, dite_eq_right htiroot] + congr 2 + exact hptj.trans hpti.symm + have hwti : ti ∈ (w i).support := by + rw [Finsupp.mem_support_iff] + have hvne := Finsupp.mem_support_iff.mp hti + rw [hv_apply, ite_eq_right hBnot] at hvne + exact hvne + have hBt_i : (treeBandProjection n B (w i)).support.Nonempty := + (treeBandProjection_support_nonempty_iff n B (w i)).mpr + ⟨ti, hwti, rfl⟩ + have hwjt : tj ∈ (w j).support := by + rw [Finsupp.mem_support_iff] + have hvne := Finsupp.mem_support_iff.mp htj + rw [hv_apply, ite_eq_right (hBsame ▸ hBnot)] at hvne + exact hvne + have hBt_j : (treeBandProjection n B (w j)).support.Nonempty := + (treeBandProjection_support_nonempty_iff n B (w j)).mpr + ⟨tj, hwjt, hBsame⟩ + exact hij ((hdis B hBnot) hBt_i hBt_j) + refine ⟨hpair, ?_⟩ + intro z hzpos hzlower + apply le_antisymm + · exact commonLower_le_zero_of_parentDisjoint_subseq n + (fun m ↦ (v m).support) hpair id Function.injective_id hv_root_notMem + (fun m ↦ treeOperator n (v m)) + (fun m α hα ↦ treeOperator_apply_eq_zero_of_outside_support n (v m) hα) + hzlower + · exact hzpos + +/-- Selects positive majorants whose transient bands occur in at most one sequence term. -/ +private theorem exists_thinned_treeMajorants + (n : ℕ) (x : ℕ → TreeComponent n) (hxmono : Monotone x) + (hxpos : ∀ m, 0 ≤ x m) (hxnorm : ∀ m, componentLatticeNorm n (x m) ≤ 1) + {ε : ℝ} (hε : 0 < ε) : + ∃ (Λ : Finset (TreeBandIndex n)) (W : ℕ → TreeCoefficients n), + none ∈ Λ ∧ (∀ m, 0 ≤ W m) ∧ (∀ m, (x m).1 ≤ treeOperator n (W m)) ∧ + (∀ m, treeRho n (W m) < 1 + ε / 2) ∧ + ∀ B ∉ Λ, {m | (treeBandProjection n B (W m)).support.Nonempty}.Subsingleton := by + classical + have hquarter : 0 < ε / 4 := div_pos hε (by norm_num) + choose w hw hmajor hrho using fun m ↦ + exists_treeMajorant_lt n (x m).1 hquarter + have hdom (m : ℕ) : (x m).1 ≤ treeOperator n (w m) := by + have hxpos' : 0 ≤ (x m).1 := hxpos m + simpa [abs_of_nonneg hxpos'] using hmajor m + have hrho' (m : ℕ) : treeRho n (w m) < 1 + ε / 4 := by + have hn := hxnorm m + change treeSeminorm n (x m).1 ≤ 1 at hn + linarith [hrho m] + obtain ⟨φ, hφ, hsharp⟩ := + tree_sharp_subsequence n w (1 + ε / 4) (fun m ↦ (hrho' m).le) + have hφid (m : ℕ) : m ≤ φ m := hφ.id_le m + have hdomφ (m : ℕ) : (x m).1 ≤ treeOperator n (w (φ m)) := by + have hxm := hxmono (hφid m) + change (x m).1 ≤ (x (φ m)).1 at hxm + exact hxm.trans (hdom (φ m)) + obtain ⟨wt, hwt, hrec⟩ := tree_trim n x (fun m ↦ w (φ m)) hε + (fun m ↦ hw (φ m)) hdomφ (fun m ↦ hrho' (φ m)) hsharp + let Λ : Finset (TreeBandIndex n) := insert none hrec.toFinset + have hnoneΛ : none ∈ Λ := by simp [Λ] + have hrecΛ : recurrentBands n wt ⊆ (Λ : Set (TreeBandIndex n)) := by + intro B hB + simp only [Λ, Finset.mem_coe, Finset.mem_insert] + exact Or.inr (hrec.mem_toFinset.mpr hB) + obtain ⟨ψ, hψ, hthin⟩ := tree_thinning n wt Λ hrecΛ + have hψid (m : ℕ) : m ≤ ψ m := hψ.id_le m + let W : ℕ → TreeCoefficients n := fun m ↦ wt (ψ m) + have hWpos (m : ℕ) : 0 ≤ W m := (hwt (ψ m)).1 + have hWdom (m : ℕ) : (x m).1 ≤ treeOperator n (W m) := by + have hxm := hxmono (hψid m) + change (x m).1 ≤ (x (ψ m)).1 at hxm + exact hxm.trans (hwt (ψ m)).2.1 + have hWrho (m : ℕ) : treeRho n (W m) < 1 + ε / 2 := + (hwt (ψ m)).2.2 + have hthinW : ∀ B ∉ Λ, + {m | (treeBandProjection n B (W m)).support.Nonempty}.Subsingleton := + hthin + exact ⟨Λ, W, hnoneΛ, hWpos, hWdom, hWrho, hthinW⟩ + +/-- Paper Proposition `prop:moderated`. -/ +theorem component_moderated + (n : ℕ) (x : ℕ → TreeComponent n) (hxmono : Monotone x) + (hxpos : ∀ m, 0 ≤ x m) (hxnorm : ∀ m, componentLatticeNorm n (x m) ≤ 1) + {ε : ℝ} (hε : 0 < ε) : + ∃ w : TreeCoefficients n, 0 ≤ w ∧ + (∀ m, (x m).1 ≤ treeOperator n w) ∧ treeRho n w ≤ 2 + ε := by + classical + obtain ⟨Λ, W, hnoneΛ, hWpos, hWdom, hWrho, hthinW⟩ := + exists_thinned_treeMajorants n x hxmono hxpos hxnorm hε + let U₀ : ℕ → TreeCoefficients n := fun m ↦ finiteBandProjection n Λ (W m) + let V : ℕ → TreeCoefficients n := fun m ↦ W m - U₀ m + let U : ℕ → TreeCoefficients n := fun m ↦ treeUpshift n (U₀ m) + have hU₀pos (m : ℕ) : 0 ≤ U₀ m := finiteBandProjection_nonneg n Λ (hWpos m) + have hVpos (m : ℕ) : 0 ≤ V m := sub_nonneg.mpr (finiteBandProjection_le n Λ (hWpos m)) + have hUpos (m : ℕ) : 0 ≤ U m := + Finsupp.mapDomain_nonneg (hU₀pos m) + let P : Finset (TreeNode n) := treeBandParents n Λ + have hUsupport (m : ℕ) : (U m).support ⊆ P := + treeUpshift_support_subset_bandParents n Λ (W m) + have hUrho (m : ℕ) : treeRho n (U m) < 2 + ε := by + calc + treeRho n (U m) ≤ 2 * treeRho n (U₀ m) := + (treeUpshift_basic n (U₀ m) (hU₀pos m)).1 + _ ≤ 2 * treeRho n (W m) := + mul_le_mul_of_nonneg_left (treeRho_finiteBandProjection_le n Λ (W m)) + (by norm_num) + _ < 2 * (1 + ε / 2) := mul_lt_mul_of_pos_left (hWrho m) (by norm_num) + _ = 2 + ε := by ring + let M : ℝ := (2 : ℝ) ^ n + have hM : 0 < M := pow_pos (by norm_num) n + let D : ℝ := M * (2 + ε) + have htwoeps : 0 < 2 + ε := by linarith + have hD : 0 < D := mul_pos hM htwoeps + have hUcoord (m : ℕ) (t : TreeNode n) : |U m t| ≤ D := by + have hone : |U m t| ≤ ∑ q ∈ (U m).support, |U m q| := by + by_cases ht : U m t = 0 + · rw [ht, abs_zero] + exact Finset.sum_nonneg fun _ _ ↦ abs_nonneg _ + · exact Finset.single_le_sum (fun q _ ↦ abs_nonneg (U m q)) + (Finsupp.mem_support_iff.mpr ht) + calc + |U m t| ≤ ∑ q ∈ (U m).support, |U m q| := hone + _ ≤ M * treeRho n (U m) := treeRho_controls_sum n (U m) + _ ≤ M * (2 + ε) := mul_le_mul_of_nonneg_left (hUrho m).le hM.le + _ = D := rfl + let y : ℕ → ↥P → Set.Icc (-D) D := fun m t ↦ + ⟨U m t.1, by + have habs := hUcoord m t.1 + exact ⟨(neg_le_neg habs).trans (neg_abs_le _), (le_abs_self _).trans habs⟩⟩ + let : SeqCompactSpace (↥P → Set.Icc (-D) D) := inferInstance + obtain ⟨l, _, θ, hθ, hlim⟩ := + (SeqCompactSpace.isSeqCompact_univ (X := ↥P → Set.Icc (-D) D)) + (x := y) (fun _ ↦ Set.mem_univ _) + let coeff : TreeNode n → ℝ := fun t ↦ + if ht : t ∈ P then (l ⟨t, ht⟩).1 else 0 + let u : TreeCoefficients n := Finsupp.onFinset P coeff (by + intro t ht + by_contra htP + simp [coeff, htP] at ht) + have hcoordlim (t : TreeNode n) : + Tendsto (fun m ↦ U (θ m) t) atTop (nhds (u t)) := by + by_cases ht : t ∈ P + · have htend := tendsto_pi_nhds.mp hlim ⟨t, ht⟩ + have htend' := tendsto_subtype_rng.mp htend + simpa [y, u, coeff, ht, Function.comp_def] using htend' + · have hzero (m : ℕ) : U (θ m) t = 0 := by + by_contra hne + exact ht (hUsupport (θ m) (Finsupp.mem_support_iff.mpr hne)) + have huzero : u t = 0 := by simp [u, coeff, ht] + simp only [hzero, huzero] + exact tendsto_const_nhds + have hupos : 0 ≤ u := by + intro t + apply ge_of_tendsto (hcoordlim t) + exact Filter.Eventually.of_forall fun m ↦ hUpos (θ m) t + have huSupport : u.support ⊆ P := Finsupp.support_onFinset_subset + have hTop_repr (q : TreeCoefficients n) (hq : q.support ⊆ P) : + treeOperator n q = ∑ t ∈ P, q t • treeFunction n t := by + rw [treeOperator] + apply Finsupp.sum_of_support_subset q hq + intro t _ + simp + have hRho_repr (q : TreeCoefficients n) (hq : q.support ⊆ P) : + treeRho n q = ∑ t ∈ P, + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |q t| := by + rw [treeRho] + apply Finsupp.sum_of_support_subset q hq + intro t _ + simp + have hToplim : Tendsto (fun m ↦ treeOperator n (U (θ m))) atTop + (nhds (treeOperator n u)) := by + have hsum : Tendsto + (fun m ↦ ∑ t ∈ P, U (θ m) t • treeFunction n t) atTop + (nhds (∑ t ∈ P, u t • treeFunction n t)) := + tendsto_finsetSum P fun t _ ↦ (hcoordlim t).smul_const (treeFunction n t) + rw [hTop_repr u huSupport] + apply tendsto_congr' _ |>.mpr hsum + exact Filter.Eventually.of_forall fun m ↦ hTop_repr (U (θ m)) (hUsupport (θ m)) + have hRholim : Tendsto (fun m ↦ treeRho n (U (θ m))) atTop + (nhds (treeRho n u)) := by + have hsum : Tendsto + (fun m ↦ ∑ t ∈ P, + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |U (θ m) t|) atTop + (nhds (∑ t ∈ P, + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |u t|)) := + tendsto_finsetSum P fun t _ ↦ tendsto_const_nhds.mul (hcoordlim t).abs + rw [hRho_repr u huSupport] + apply tendsto_congr' _ |>.mpr hsum + exact Filter.Eventually.of_forall fun m ↦ hRho_repr (U (θ m)) (hUsupport (θ m)) + have hurho : treeRho n u ≤ 2 + ε := by + apply le_of_tendsto hRholim + exact Filter.Eventually.of_forall fun m ↦ (hUrho (θ m)).le + have htransient_subseq (χ : ℕ → ℕ) (hχ : Function.Injective χ) + (z : BoundedContinuousFunction (TreeProduct n) ℝ) (hz : 0 ≤ z) + (hzlower : ∀ k, z ≤ treeOperator n (V (χ k))) : z = 0 := by + have hsub : ∀ B ∉ Λ, + {k | (treeBandProjection n B (W (χ k))).support.Nonempty}.Subsingleton := by + intro B hB i hi j hj + exact hχ (hthinW B hB hi hj) + have htr := (tree_transient n (fun k ↦ W (χ k)) Λ hnoneΛ hsub).2 + apply htr z hz + intro k + change z ≤ treeOperator n + (W (χ k) - finiteBandProjection n Λ (W (χ k))) + exact hzlower k + refine ⟨u, hupos, ?_, hurho⟩ + intro j α + apply le_of_forall_pos_le_add + intro η hη + obtain ⟨m₀, hm₀⟩ := (Metric.tendsto_atTop.mp hToplim) η hη + let K : ℕ := max j m₀ + let χ : ℕ → ℕ := fun k ↦ θ (k + K) + have hχ : Function.Injective χ := hθ.injective.comp fun a b hab ↦ by + omega + have hclose (k : ℕ) : + ‖treeOperator n (U (χ k)) - treeOperator n u‖ < η := by + have hk : m₀ ≤ k + K := le_trans (le_max_right j m₀) (Nat.le_add_left K k) + have := hm₀ (k + K) hk + rw [dist_eq_norm_sub] at this + exact this + have happrox (k : ℕ) : + treeOperator n (U (χ k)) ≤ treeOperator n u + + η • treeFunction n (TreeNode.root n) := by + let d := treeOperator n (U (χ k)) - treeOperator n u + have habs : |d| ≤ η • treeFunction n (TreeNode.root n) := by + calc + |d| ≤ ‖d‖ • treeFunction n (TreeNode.root n) := + abs_le_norm_smul_root n d + _ ≤ η • treeFunction n (TreeNode.root n) := by + intro β + simpa [treeFunction_root] using (hclose k).le + calc + treeOperator n (U (χ k)) = d + treeOperator n u := by + dsimp [d] + abel + _ ≤ |d| + treeOperator n u := add_le_add (le_abs_self d) le_rfl + _ ≤ η • treeFunction n (TreeNode.root n) + treeOperator n u := + add_le_add habs le_rfl + _ = treeOperator n u + η • treeFunction n (TreeNode.root n) := add_comm _ _ + let b : BoundedContinuousFunction (TreeProduct n) ℝ := + treeOperator n u + η • treeFunction n (TreeNode.root n) + let z : BoundedContinuousFunction (TreeProduct n) ℝ := ((x j).1 - b)⁺ + have hzpos : 0 ≤ z := posPart_nonneg _ + have hzlower (k : ℕ) : z ≤ treeOperator n (V (χ k)) := by + have hjχ : j ≤ χ k := by + have hK : j ≤ k + K := le_trans (le_max_left j m₀) (Nat.le_add_left K k) + exact hK.trans (hθ.id_le (k + K)) + have hxjχ := hxmono hjχ + change (x j).1 ≤ (x (χ k)).1 at hxjχ + have hxW : (x j).1 ≤ treeOperator n (W (χ k)) := + hxjχ.trans (hWdom (χ k)) + have hdecomp : treeOperator n (W (χ k)) = + treeOperator n (U₀ (χ k)) + treeOperator n (V (χ k)) := by + rw [← treeOperator_add] + congr 1 + dsimp [V] + abel + have hup := (treeUpshift_basic n (U₀ (χ k)) (hU₀pos (χ k))).2 + have hmain : (x j).1 ≤ b + treeOperator n (V (χ k)) := by + calc + (x j).1 ≤ treeOperator n (W (χ k)) := hxW + _ = treeOperator n (U₀ (χ k)) + treeOperator n (V (χ k)) := hdecomp + _ ≤ treeOperator n (U (χ k)) + treeOperator n (V (χ k)) := + add_le_add hup le_rfl + _ ≤ b + treeOperator n (V (χ k)) := + add_le_add (happrox k) le_rfl + have hdiff : (x j).1 - b ≤ treeOperator n (V (χ k)) := by + rw [sub_le_iff_le_add] + simpa [add_comm] using hmain + change ((x j).1 - b) ⊔ 0 ≤ treeOperator n (V (χ k)) + exact sup_le hdiff (treeOperator_nonneg n (V (χ k)) (hVpos (χ k))) + have hz0 := htransient_subseq χ hχ z hzpos hzlower + have hxb : (x j).1 ≤ b := by + rw [← sub_nonpos] + exact (le_posPart ((x j).1 - b)).trans_eq hz0 + have hpoint := hxb α + simpa [b, treeFunction_root] using hpoint + +/-- Paper Corollary `cor:weak-fatou`. -/ +theorem component_weakFatou (n : ℕ) : + IsWeakNakanoConstant (componentLatticeNorm n) 2 ∧ + HasWeakFatouProperty (componentLatticeNorm n) 2 := by + have hseq : IsWeakSequentialNakanoConstant (componentLatticeNorm n) 2 := by + refine ⟨by norm_num, ?_⟩ + intro x hxmono hxpos _ hxnorm ε hε + obtain ⟨w, hw, hwupper, hwrho⟩ := + component_moderated n x hxmono hxpos hxnorm hε + let y : TreeComponent n := ⟨treeOperator n w, treeOperator_mem_treeSublattice n w⟩ + refine ⟨y, ?_, ?_, ?_⟩ + · exact treeOperator_nonneg n w hw + · exact hwupper + · change treeSeminorm n (treeOperator n w) ≤ 2 + ε + apply (treeSeminorm_le_of_majorant n (treeOperator n w) w hw ?_).trans hwrho + rw [abs_of_nonneg (treeOperator_nonneg n w hw)] + let : Countable (TreeNode n) := by + unfold TreeNode + infer_instance + let : TopologicalSpace.SeparableSpace (TreeComponent n) := + VectorSublattice.separableSpace_topologicalClosure_generated_of_countable + (Set.countable_range (treeFunction n)) + have hNak : IsWeakNakanoConstant (componentLatticeNorm n) 2 := + weakNakano_of_weakSequentialNakano_p (Y := TreeComponent n) (K := 2) + (componentLatticeNorm n) hseq + exact ⟨hNak, weakFatou_of_weakNakano_p (componentLatticeNorm n) hNak⟩ + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean b/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean new file mode 100644 index 0000000000..936881105f --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean @@ -0,0 +1,466 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.OrderAdherence + + +/-! +# Weakly Fatou norms + +Formalization of the paper's construction of a weakly Fatou Banach lattice norm that is +not equivalent to any lattice norm with the Fatou property. +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-! ## The two reductions -/ + +section Reductions + +variable {X : Type u} [AddCommGroup X] [Lattice X] [IsOrderedAddMonoid X] + [VectorLattice X] + +/-- Paper Lemma `lem:order-basic`. -/ +theorem iteratedOrderAdherence_mono_and_scale + {A B : Set X} (_hA : LatticeOrderedAddCommGroup.IsSolid A) + (_hB : LatticeOrderedAddCommGroup.IsSolid B) {c : ℝ} (hc : 0 < c) : + (A ⊆ B → ∀ m, iteratedOrderAdherence A m ⊆ iteratedOrderAdherence B m) ∧ + (orderAdherence (scaleSet c A) = scaleSet c (orderAdherence A) ∧ + ∀ m, iteratedOrderAdherence (scaleSet c A) m = + scaleSet c (iteratedOrderAdherence A m)) := by + have hmono : A ⊆ B → ∀ m, + iteratedOrderAdherence A m ⊆ iteratedOrderAdherence B m := by + intro hAB m + induction m with + | zero => exact hAB + | succ m ih => exact orderAdherence_mono ih + have hscale : ∀ C : Set X, + orderAdherence (scaleSet c C) = scaleSet c (orderAdherence C) := by + intro C + apply Set.Subset.antisymm + · rintro x ⟨ι, hpre, hdir, hne, f, hf, hfx⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + refine ⟨c⁻¹ • x, ?_, by simp [smul_smul, hc.ne']⟩ + refine ⟨ι, inferInstance, inferInstance, inferInstance, + fun i ↦ c⁻¹ • f i, ?_, ?_⟩ + · intro i + rcases hf i with ⟨a, ha, hfa⟩ + change c⁻¹ • f i ∈ C + rw [← hfa] + simpa [smul_smul, hc.ne'] using ha + · exact hfx.smul c⁻¹ + · rintro x ⟨y, ⟨ι, hpre, hdir, hne, f, hf, hfy⟩, rfl⟩ + let : Preorder ι := hpre + let : IsDirected ι (· ≤ ·) := hdir + let : Nonempty ι := hne + refine ⟨ι, inferInstance, inferInstance, inferInstance, + fun i ↦ c • f i, ?_, hfy.smul c⟩ + exact fun i ↦ ⟨f i, hf i, rfl⟩ + have hiter : ∀ m, iteratedOrderAdherence (scaleSet c A) m = + scaleSet c (iteratedOrderAdherence A m) := by + intro m + induction m with + | zero => rfl + | succ m ih => + simpa only [iteratedOrderAdherence, ih] using + hscale (iteratedOrderAdherence A m) + exact ⟨hmono, hscale A, hiter⟩ + +/-- Paper Lemma `lem:fatou-order`, part (a). -/ +theorem weakFatou_iterated_unitBall + (p : PaperLatticeNorm X) {K : ℝ} (hK : HasWeakFatouProperty p K) : + ∀ m ≥ 1, iteratedOrderAdherence (unitBallFor p) m ⊆ + scaleSet (K ^ m) (unitBallFor p) := by + have hKpos : 0 < K := lt_of_lt_of_le zero_lt_one hK.1 + have hsolid : LatticeOrderedAddCommGroup.IsSolid (unitBallFor p) := by + intro y hy x hxy + exact (p.solid hxy).trans hy + have hstep : orderAdherence (unitBallFor p) ⊆ scaleSet K (unitBallFor p) := by + rw [orderAdherence_eq_solidOrderAdherence hsolid] + rintro x ⟨z, hz, hxz⟩ + rcases hz with ⟨hz0, B, hB, hBne, hBdir, hBlub⟩ + let : Nonempty B := hBne.to_subtype + let : IsDirectedOrder B := hBdir.isDirectedOrder + let f : B → X := fun b ↦ b.1 + have hfmono : Monotone f := fun _ _ h ↦ h + have hfrange : Set.range f = B := by + ext y + simp [f] + have hpz : p z ≤ K := by + have h := hK.2 f z hfmono (fun b ↦ (hB b.2).2) + (by simpa [hfrange] using hBlub) 1 + (fun b ↦ hB b.2 |>.1) + simpa using h + have hpx : p x ≤ K := (p.solid hxz).trans hpz + refine ⟨K⁻¹ • x, ?_, by simp [smul_smul, hKpos.ne']⟩ + change p (K⁻¹ • x) ≤ 1 + rw [p.smul, abs_of_pos (inv_pos.mpr hKpos)] + calc + K⁻¹ * p x ≤ K⁻¹ * K := + mul_le_mul_of_nonneg_left hpx (inv_nonneg.mpr hKpos.le) + _ = 1 := inv_mul_cancel₀ hKpos.ne' + intro m + induction m with + | zero => + intro hm + omega + | succ m ih => + intro _ + by_cases hm0 : m = 0 + · subst m + simpa [iteratedOrderAdherence] using hstep + · have hm1 : 1 ≤ m := Nat.one_le_iff_ne_zero.mpr hm0 + have hpowpos : 0 < K ^ m := pow_pos hKpos m + have hscale := + (iteratedOrderAdherence_mono_and_scale hsolid hsolid hpowpos).2.1 + intro x hx + change x ∈ orderAdherence (iteratedOrderAdherence (unitBallFor p) m) at hx + have hxscaled : x ∈ orderAdherence (scaleSet (K ^ m) (unitBallFor p)) := + orderAdherence_mono (ih hm1) hx + rw [hscale] at hxscaled + rcases hxscaled with ⟨y, hy, hyx⟩ + rcases hstep hy with ⟨z, hz, hzy⟩ + refine ⟨z, hz, ?_⟩ + calc + K ^ (m + 1) • z = K ^ m • (K • z) := by rw [pow_succ, mul_smul] + _ = K ^ m • y := congrArg (fun w ↦ K ^ m • w) hzy + _ = x := hyx + +/-- Paper Lemma `lem:fatou-order`, part (b). -/ +theorem fatou_iterated_unitBall + (p : PaperLatticeNorm X) (hp : HasFatouProperty p) : + ∀ m ≥ 1, iteratedOrderAdherence (unitBallFor p) m = unitBallFor p := by + have hsolid : LatticeOrderedAddCommGroup.IsSolid (unitBallFor p) := by + intro y hy x hxy + exact (p.solid hxy).trans hy + have hstep : orderAdherence (unitBallFor p) = unitBallFor p := by + apply Set.Subset.antisymm + · rw [orderAdherence_eq_solidOrderAdherence hsolid] + rintro x ⟨z, hz, hxz⟩ + rcases hz with ⟨hz0, B, hB, hBne, hBdir, hBlub⟩ + let : Nonempty B := hBne.to_subtype + let : IsDirectedOrder B := hBdir.isDirectedOrder + let f : B → X := fun b ↦ b.1 + have hfmono : Monotone f := fun _ _ h ↦ h + have hfrange : Set.range f = B := by + ext y + simp [f] + have hpnorm := hp f z hfmono (fun b ↦ (hB b.2).2) + (by simpa [hfrange] using hBlub) + have hpz : p z ≤ 1 := hpnorm.2 (by + rintro _ ⟨_, ⟨b, rfl⟩, rfl⟩ + exact (hB b.2).1) + exact (p.solid hxz).trans hpz + · exact subset_orderAdherence (unitBallFor p) + have hall : ∀ m, iteratedOrderAdherence (unitBallFor p) m = unitBallFor p := by + intro m + induction m with + | zero => rfl + | succ m ih => + simp only [iteratedOrderAdherence] + rw [ih, hstep] + exact fun m _ ↦ hall m + +/-- Weak sequential Nakano constant, Definition 3(a) in the paper. -/ +def IsWeakSequentialNakanoConstant (p : X → ℝ) (K : ℝ) : Prop := + 1 ≤ K ∧ ∀ (x : ℕ → X), Monotone x → (∀ m, 0 ≤ x m) → + BddAbove (Set.range x) → (∀ m, p (x m) ≤ 1) → + ∀ ε > 0, ∃ y : X, 0 ≤ y ∧ (∀ m, x m ≤ y) ∧ p y ≤ K + ε + +/-- Weak Nakano constant, Definition 3(b) in the paper. -/ +def IsWeakNakanoConstant (p : X → ℝ) (K : ℝ) : Prop := + 1 ≤ K ∧ ∀ A : Set X, A ⊆ Ici 0 → DirectedOn (· ≤ ·) A → BddAbove A → + (∀ x ∈ A, p x ≤ 1) → ∀ ε > 0, + ∃ y : X, 0 ≤ y ∧ (∀ x ∈ A, x ≤ y) ∧ p y ≤ K + ε + +/-- Fremlin's question, as a predicate on a vector lattice: every complete +weakly Fatou lattice norm admits an equivalent Fatou lattice norm. -/ +def FremlinProperty : Prop := + ∀ p : PaperLatticeNorm X, IsCompleteFor p → + (∃ K, HasWeakFatouProperty p K) → + ∃ q : PaperLatticeNorm X, HasFatouProperty q ∧ EquivalentNorms p q + +/-- Promotes the sequential weak Nakano estimate to directed sets in a +separable normed lattice; the paper-norm version below reduces to this lemma. -/ +theorem weakNakano_of_weakSequentialNakano + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] + {K : ℝ} (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : + IsWeakNakanoConstant (X := Y) norm K := by + refine ⟨hseq.1, ?_⟩ + intro A hApos hAdir hAbdd hAnorm ε hε + classical + by_cases hAempty : A = ∅ + · subst A + refine ⟨0, le_rfl, ?_, ?_⟩ + · simp + · norm_num + linarith [hseq.1] + have hAne : A.Nonempty := Set.nonempty_iff_ne_empty.mpr hAempty + let : Nonempty ↥A := ⟨⟨Classical.choose hAne, Classical.choose_spec hAne⟩⟩ + let : TopologicalSpace.SeparableSpace ↥A := inferInstance + obtain ⟨d, hdense⟩ := TopologicalSpace.exists_dense_seq ↥A + let join : ↥A → ↥A → ↥A := fun a b ↦ + ⟨Classical.choose (hAdir a.1 a.2 b.1 b.2), + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).1⟩ + have hjoin_left (a b : ↥A) : a.1 ≤ (join a b).1 := + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.1 + have hjoin_right (a b : ↥A) : b.1 ≤ (join a b).1 := + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.2 + let z : ℕ → ↥A := fun m ↦ + Nat.rec (d 0) (fun k a ↦ join a (d (k + 1))) m + have hz_succ (m : ℕ) : z (m + 1) = join (z m) (d (m + 1)) := by + simp [z] + have hzmono : Monotone (fun m ↦ (z m).1) := by + apply monotone_nat_of_le_succ + intro m + rw [hz_succ] + exact hjoin_left _ _ + have hd_le_z : ∀ m, (d m).1 ≤ (z m).1 := by + intro m + cases m with + | zero => simp [z] + | succ m => + rw [hz_succ] + exact hjoin_right _ _ + have hzpos : ∀ m, 0 ≤ (z m).1 := fun m ↦ hApos (z m).2 + have hzbdd : BddAbove (Set.range fun m ↦ (z m).1) := by + rcases hAbdd with ⟨b, hb⟩ + exact ⟨b, by rintro _ ⟨m, rfl⟩; exact hb (z m).2⟩ + have hznorm : ∀ m, ‖(z m).1‖ ≤ 1 := fun m ↦ hAnorm _ (z m).2 + obtain ⟨y, hypos, hyupper, hynorm⟩ := + hseq.2 (fun m ↦ (z m).1) hzmono hzpos hzbdd hznorm ε hε + refine ⟨y, hypos, ?_, hynorm⟩ + have hd_upper : ∀ m, (d m).1 ≤ y := + fun m ↦ (hd_le_z m).trans (hyupper m) + have hclosed : IsClosed {a : ↥A | a.1 ≤ y} := + isClosed_Iic.preimage continuous_subtype_val + have hclosure : closure (Set.range d) ⊆ {a : ↥A | a.1 ≤ y} := by + apply closure_minimal + · rintro _ ⟨m, rfl⟩ + exact hd_upper m + · exact hclosed + intro x hx + let xA : ↥A := ⟨x, hx⟩ + exact hclosure (by rw [hdense.closure_eq]; exact Set.mem_univ xA) + +/-- Converts the directed weak Nakano estimate into the weak Fatou inequality +for an ambient norm; reused after transporting a paper lattice norm. -/ +theorem weakFatou_of_weakNakano_norm + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] {K : ℝ} + (hNak : IsWeakNakanoConstant (X := Y) norm K) : + HasWeakFatouProperty (norm : Y → ℝ) K := by + refine ⟨hNak.1, ?_⟩ + intro ι _ _ _ f x hfmono hfpos hflub c hfc + classical + let i₀ : ι := Classical.choice inferInstance + have hc : 0 ≤ c := (norm_nonneg (f i₀)).trans (hfc i₀) + by_cases hc0 : c = 0 + · subst c + have hfzero : ∀ i, f i = 0 := by + intro i + exact norm_eq_zero.mp (le_antisymm (hfc i) (norm_nonneg _)) + have hxzero : x = 0 := by + apply le_antisymm + · apply hflub.2 + rintro _ ⟨i, rfl⟩ + simp [hfzero i] + · simpa [hfzero i₀] using hflub.1 ⟨i₀, rfl⟩ + simp [hxzero] + have hcpos : 0 < c := lt_of_le_of_ne hc (Ne.symm hc0) + apply le_of_forall_pos_le_add + intro δ hδ + let A : Set Y := Set.range fun i ↦ c⁻¹ • f i + have hApos : A ⊆ Set.Ici 0 := by + rintro _ ⟨i, rfl⟩ + exact smul_nonneg (inv_nonneg.mpr hc) (hfpos i) + have hAdir : DirectedOn (· ≤ ·) A := by + rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ + obtain ⟨k, hik, hjk⟩ := directed_of (· ≤ ·) i j + refine ⟨c⁻¹ • f k, ⟨k, rfl⟩, ?_, ?_⟩ + · exact smul_le_smul_of_nonneg_left (hfmono hik) (inv_nonneg.mpr hc) + · exact smul_le_smul_of_nonneg_left (hfmono hjk) (inv_nonneg.mpr hc) + have hAbdd : BddAbove A := by + refine ⟨c⁻¹ • x, ?_⟩ + rintro _ ⟨i, rfl⟩ + exact smul_le_smul_of_nonneg_left (hflub.1 ⟨i, rfl⟩) (inv_nonneg.mpr hc) + have hAnorm : ∀ z ∈ A, ‖z‖ ≤ 1 := by + rintro _ ⟨i, rfl⟩ + rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hcpos)] + have hi := hfc i + rw [inv_mul_le_one₀ hcpos] + exact hi + obtain ⟨y, hypos, hyupper, hynorm⟩ := + hNak.2 A hApos hAdir hAbdd hAnorm (δ / c) (div_pos hδ hcpos) + have hxy : x ≤ c • y := by + apply hflub.2 + rintro _ ⟨i, rfl⟩ + have hi := hyupper (c⁻¹ • f i) ⟨i, rfl⟩ + have := smul_le_smul_of_nonneg_left hi hc + simpa [smul_smul, hc0] using this + have hxpos : 0 ≤ x := (hfpos i₀).trans (hflub.1 ⟨i₀, rfl⟩) + have hcyp : 0 ≤ c • y := smul_nonneg hc hypos + have hnormxy : ‖x‖ ≤ ‖c • y‖ := by + apply norm_le_norm_of_abs_le_abs + simpa [abs_of_nonneg hxpos, abs_of_nonneg hcyp] using hxy + calc + ‖x‖ ≤ ‖c • y‖ := hnormxy + _ = c * ‖y‖ := by rw [norm_smul, Real.norm_eq_abs, abs_of_pos hcpos] + _ ≤ c * (K + δ / c) := mul_le_mul_of_nonneg_left hynorm hc + _ = K * c + δ := by field_simp + +/-- Paper Proposition `prop:separable-reduction`. -/ +theorem separable_weakSequentialNakano_implies_weakNakano + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] + {K : ℝ} (_hK : 1 ≤ K) + (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : + IsWeakNakanoConstant (X := Y) norm K ∧ + HasWeakFatouProperty (norm : Y → ℝ) K := by + have hNak := weakNakano_of_weakSequentialNakano hseq + exact ⟨hNak, weakFatou_of_weakNakano_norm hNak⟩ + +/-- Extends the separable sequential-to-directed reduction to an arbitrary +`PaperLatticeNorm`; used to prove `component_weakFatou`. -/ +theorem weakNakano_of_weakSequentialNakano_p + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] + (p : PaperLatticeNorm Y) {K : ℝ} + (hseq : IsWeakSequentialNakanoConstant (X := Y) p K) : + IsWeakNakanoConstant (X := Y) p K := by + refine ⟨hseq.1, ?_⟩ + intro A hApos hAdir hAbdd hAp ε hε + classical + by_cases hAempty : A = ∅ + · subst A + refine ⟨0, le_rfl, by simp, ?_⟩ + rw [show p 0 = 0 from p.eq_zero_iff 0 |>.2 rfl] + linarith [hseq.1] + have hAne : A.Nonempty := Set.nonempty_iff_ne_empty.mpr hAempty + let : Nonempty ↥A := ⟨⟨Classical.choose hAne, Classical.choose_spec hAne⟩⟩ + let : TopologicalSpace.SeparableSpace ↥A := inferInstance + obtain ⟨d, hdense⟩ := TopologicalSpace.exists_dense_seq ↥A + let join : ↥A → ↥A → ↥A := fun a b ↦ + ⟨Classical.choose (hAdir a.1 a.2 b.1 b.2), + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).1⟩ + have hjoin_left (a b : ↥A) : a.1 ≤ (join a b).1 := + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.1 + have hjoin_right (a b : ↥A) : b.1 ≤ (join a b).1 := + (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.2 + let z : ℕ → ↥A := fun m ↦ + Nat.rec (d 0) (fun k a ↦ join a (d (k + 1))) m + have hz_succ (m : ℕ) : z (m + 1) = join (z m) (d (m + 1)) := by simp [z] + have hzmono : Monotone (fun m ↦ (z m).1) := by + apply monotone_nat_of_le_succ + intro m + rw [hz_succ] + exact hjoin_left _ _ + have hd_le_z : ∀ m, (d m).1 ≤ (z m).1 := by + intro m + cases m with + | zero => simp [z] + | succ m => rw [hz_succ]; exact hjoin_right _ _ + have hzpos : ∀ m, 0 ≤ (z m).1 := fun m ↦ hApos (z m).2 + have hzbdd : BddAbove (Set.range fun m ↦ (z m).1) := by + rcases hAbdd with ⟨b, hb⟩ + exact ⟨b, by rintro _ ⟨m, rfl⟩; exact hb (z m).2⟩ + have hzp : ∀ m, p (z m).1 ≤ 1 := fun m ↦ hAp _ (z m).2 + obtain ⟨y, hypos, hyupper, hyp⟩ := + hseq.2 (fun m ↦ (z m).1) hzmono hzpos hzbdd hzp ε hε + refine ⟨y, hypos, ?_, hyp⟩ + have hd_upper : ∀ m, (d m).1 ≤ y := fun m ↦ (hd_le_z m).trans (hyupper m) + have hclosed : IsClosed {a : ↥A | a.1 ≤ y} := + isClosed_Iic.preimage continuous_subtype_val + have hclosure : closure (Set.range d) ⊆ {a : ↥A | a.1 ≤ y} := by + apply closure_minimal + · rintro _ ⟨m, rfl⟩ + exact hd_upper m + · exact hclosed + intro q hq + exact hclosure (by rw [hdense.closure_eq]; exact Set.mem_univ ⟨q, hq⟩) + +/-- Extends the weak-Nakano-to-weak-Fatou implication to a +`PaperLatticeNorm`; used for the component norm in `component_weakFatou`. -/ +theorem weakFatou_of_weakNakano_p + {Y : Type u} [AddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [VectorLattice Y] (p : PaperLatticeNorm Y) {K : ℝ} + (hNak : IsWeakNakanoConstant (X := Y) p K) : + HasWeakFatouProperty p K := by + refine ⟨hNak.1, ?_⟩ + intro ι _ _ _ f x hfmono hfpos hflub c hfc + classical + let i₀ : ι := Classical.choice inferInstance + have hc : 0 ≤ c := (p.nonneg (f i₀)).trans (hfc i₀) + by_cases hc0 : c = 0 + · subst c + have hfzero : ∀ i, f i = 0 := by + intro i + apply p.eq_zero_iff (f i) |>.1 + exact le_antisymm (hfc i) (p.nonneg _) + have hxzero : x = 0 := by + apply le_antisymm + · apply hflub.2 + rintro _ ⟨i, rfl⟩ + simp [hfzero i] + · simpa [hfzero i₀] using hflub.1 ⟨i₀, rfl⟩ + rw [hxzero] + rw [p.eq_zero_iff 0 |>.2 rfl] + simp + have hcpos : 0 < c := lt_of_le_of_ne hc (Ne.symm hc0) + apply le_of_forall_pos_le_add + intro δ hδ + let A : Set Y := Set.range fun i ↦ c⁻¹ • f i + have hApos : A ⊆ Set.Ici 0 := by + rintro _ ⟨i, rfl⟩ + exact smul_nonneg (inv_nonneg.mpr hc) (hfpos i) + have hAdir : DirectedOn (· ≤ ·) A := by + rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ + obtain ⟨k, hik, hjk⟩ := directed_of (· ≤ ·) i j + refine ⟨c⁻¹ • f k, ⟨k, rfl⟩, ?_, ?_⟩ + · exact smul_le_smul_of_nonneg_left (hfmono hik) (inv_nonneg.mpr hc) + · exact smul_le_smul_of_nonneg_left (hfmono hjk) (inv_nonneg.mpr hc) + have hAbdd : BddAbove A := by + refine ⟨c⁻¹ • x, ?_⟩ + rintro _ ⟨i, rfl⟩ + exact smul_le_smul_of_nonneg_left (hflub.1 ⟨i, rfl⟩) (inv_nonneg.mpr hc) + have hAp : ∀ z ∈ A, p z ≤ 1 := by + rintro _ ⟨i, rfl⟩ + rw [p.smul, abs_of_pos (inv_pos.mpr hcpos), inv_mul_le_one₀ hcpos] + exact hfc i + obtain ⟨y, hypos, hyupper, hyp⟩ := + hNak.2 A hApos hAdir hAbdd hAp (δ / c) (div_pos hδ hcpos) + have hxy : x ≤ c • y := by + apply hflub.2 + rintro _ ⟨i, rfl⟩ + have hi := hyupper (c⁻¹ • f i) ⟨i, rfl⟩ + have := smul_le_smul_of_nonneg_left hi hc + simpa [smul_smul, hc0] using this + have hxpos : 0 ≤ x := (hfpos i₀).trans (hflub.1 ⟨i₀, rfl⟩) + have hcyp : 0 ≤ c • y := smul_nonneg hc hypos + have hpxy : p x ≤ p (c • y) := by + apply p.solid + simpa [abs_of_nonneg hxpos, abs_of_nonneg hcyp] using hxy + calc + p x ≤ p (c • y) := hpxy + _ = c * p y := by rw [p.smul, abs_of_pos hcpos] + _ ≤ c * (K + δ / c) := mul_le_mul_of_nonneg_left hyp hc + _ = K * c + δ := by field_simp + +end Reductions + +end OrderClosures diff --git a/LeanPool/OrderClosures/WeaklyFatou/TreeNorm.lean b/LeanPool/OrderClosures/WeaklyFatou/TreeNorm.lean new file mode 100644 index 0000000000..ea6f1909f9 --- /dev/null +++ b/LeanPool/OrderClosures/WeaklyFatou/TreeNorm.lean @@ -0,0 +1,690 @@ +/- +Copyright (c) 2026 Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Antonio Avilés, Mitchell A. Taylor, Pedro Tradacete +-/ + +module + +public import LeanPool.OrderClosures.WeaklyFatou.FiniteTree + + +/-! +# The induced tree seminorm and component lattice +-/ + +@[expose] public section + +namespace OrderClosures + +open Set Filter Topology +open scoped NNReal Topology + +universe u + +/-! ## The induced seminorm -/ + +/-- `W_n = c₀₀(G_n)`. -/ +abbrev TreeCoefficients (n : ℕ) := TreeNode n →₀ ℝ + +/-- The basis vector `e_t`. -/ +noncomputable def treeBasis {n : ℕ} (t : TreeNode n) : TreeCoefficients n := + Finsupp.single t 1 + +/-- The weighted `ℓ¹` functional `ρ_n`. -/ +noncomputable def treeRho (n : ℕ) (w : TreeCoefficients n) : ℝ := + w.sum fun t a ↦ (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) * |a| + +/-- The positive operator `T_n`. -/ +noncomputable def treeOperator (n : ℕ) (w : TreeCoefficients n) : + BoundedContinuousFunction (TreeProduct n) ℝ := + w.sum fun t a ↦ a • treeFunction n t + +/-- The infimum formula defining `p_n`. -/ +noncomputable def treeSeminorm (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : ℝ := + sInf {r : ℝ | ∃ w : TreeCoefficients n, + 0 ≤ w ∧ |x| ≤ treeOperator n w ∧ treeRho n w = r} + +/-- Records nonnegativity of the weighted coefficient functional; used in all +seminorm and band-mass estimates. -/ +theorem treeRho_nonneg (n : ℕ) (w : TreeCoefficients n) : + 0 ≤ treeRho n w := by + classical + exact Finsupp.sum_nonneg' fun t ↦ + mul_nonneg (zpow_nonneg (by norm_num) _) (abs_nonneg _) + +/-- Shows that `treeRho` is invariant under negation; used for symmetry of the +bundled lattice seminorm. -/ +theorem treeRho_neg (n : ℕ) (w : TreeCoefficients n) : + treeRho n (-w) = treeRho n w := by + classical + rw [treeRho, treeRho, Finsupp.sum, Finsupp.sum, Finsupp.support_neg] + simp + +/-- Computes `treeRho` under scalar multiplication; used for homogeneity of +the tree seminorm. -/ +theorem treeRho_smul (n : ℕ) (a : ℝ) (w : TreeCoefficients n) : + treeRho n (a • w) = |a| * treeRho n w := by + classical + unfold treeRho + rw [Finsupp.sum_of_support_subset (a • w) Finsupp.support_smul _ (by simp)] + simp only [Finsupp.sum, Finsupp.smul_apply, smul_eq_mul, abs_mul, Finset.mul_sum] + apply Finset.sum_congr rfl + intro t _ + ring + +/-- Gives the triangle inequality for `treeRho`; used to prove subadditivity +of the induced seminorm. -/ +theorem treeRho_add_le (n : ℕ) (u v : TreeCoefficients n) : + treeRho n (u + v) ≤ treeRho n u + treeRho n v := by + classical + rw [treeRho, treeRho, treeRho] + rw [Finsupp.sum_of_support_subset (u + v) Finsupp.support_add _ (by simp)] + rw [Finsupp.sum_of_support_subset u + (show u.support ⊆ u.support ∪ v.support from Finset.subset_union_left) _ (by simp)] + rw [Finsupp.sum_of_support_subset v + (show v.support ⊆ u.support ∪ v.support from Finset.subset_union_right) _ (by simp)] + simp only [Finsupp.add_apply, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro t _ + simpa [mul_add] using + (mul_le_mul_of_nonneg_left (abs_add_le (u t) (v t)) + (zpow_nonneg (show (0 : ℝ) ≤ 2 by norm_num) + (-(TreeNode.level t : ℤ)))) + +/-- Shows coefficientwise monotonicity of `treeRho` on the positive cone; +used to compare band projections and trimmed coefficients. -/ +theorem treeRho_mono_of_nonneg (n : ℕ) {u v : TreeCoefficients n} + (hu : 0 ≤ u) (huv : u ≤ v) : treeRho n u ≤ treeRho n v := by + classical + have hv : 0 ≤ v := hu.trans huv + rw [treeRho, treeRho] + rw [Finsupp.sum_of_support_subset u + (show u.support ⊆ u.support ∪ v.support from Finset.subset_union_left) _ (by simp)] + rw [Finsupp.sum_of_support_subset v + (show v.support ⊆ u.support ∪ v.support from Finset.subset_union_right) _ (by simp)] + apply Finset.sum_le_sum + intro t _ + rw [abs_of_nonneg (hu t), abs_of_nonneg (hv t)] + exact mul_le_mul_of_nonneg_left (huv t) (zpow_nonneg (by norm_num) _) + +/-- Computes the tree operator at zero; used in the zero law for the induced +seminorm and generated sublattice. -/ +theorem treeOperator_zero (n : ℕ) : + treeOperator n (0 : TreeCoefficients n) = 0 := by + simp [treeOperator] + +/-- Records additivity of the tree operator; used in seminorm subadditivity +and the moderatedness decomposition. -/ +theorem treeOperator_add (n : ℕ) (u v : TreeCoefficients n) : + treeOperator n (u + v) = treeOperator n u + treeOperator n v := by + classical + simp only [treeOperator] + exact Finsupp.sum_add_index (by simp) (by simp [add_smul]) + +/-- Records homogeneity of the tree operator; used to scale majorants in the +seminorm and component constructions. -/ +theorem treeOperator_smul (n : ℕ) (a : ℝ) (w : TreeCoefficients n) : + treeOperator n (a • w) = a • treeOperator n w := by + classical + simp only [treeOperator] + rw [Finsupp.sum_smul_index (by simp)] + change (∑ t ∈ w.support, (a * w t) • treeFunction n t) = + a • ∑ t ∈ w.support, w t • treeFunction n t + rw [Finset.smul_sum] + apply Finset.sum_congr rfl + intro t _ + simp [smul_smul] + +/-- A coefficientwise positive vector has a positive tree image; used whenever +an operator majorant is treated as a positive component. -/ +theorem treeOperator_nonneg (n : ℕ) (w : TreeCoefficients n) (hw : 0 ≤ w) : + 0 ≤ treeOperator n w := by + classical + change 0 ≤ w.sum fun t a ↦ a • treeFunction n t + apply Finsupp.sum_nonneg' + intro t α + change 0 ≤ w t * treeFunction n t α + exact mul_nonneg (hw t) (by + by_cases h : α ∈ treeCylinder n t <;> simp [treeFunction, + BoundedContinuousFunction.indicator, Set.indicator, h]) + +/-- Evaluates the tree operator on a single basis coefficient; used to place +tree functions in the generated component. -/ +theorem treeOperator_single (n : ℕ) (t : TreeNode n) (a : ℝ) : + treeOperator n (Finsupp.single t a) = a • treeFunction n t := by + simp [treeOperator] + +/-- Expands pointwise evaluation of the tree operator as a finite sum; used in +support-vanishing and root estimates. -/ +theorem treeOperator_apply (n : ℕ) (w : TreeCoefficients n) + (α : TreeProduct n) : + treeOperator n w α = w.sum (fun t a ↦ a * treeFunction n t α) := by + classical + rw [treeOperator, Finsupp.sum, Finsupp.sum] + change (BoundedContinuousFunction.evalCLM ℝ α) + (∑ t ∈ w.support, w t • treeFunction n t) = + ∑ t ∈ w.support, w t * treeFunction n t α + rw [map_sum] + apply Finset.sum_congr rfl + intro t _ + simp + +/-- Identifies the root tree function with the constant one function; used as +the universal positive order majorant. -/ +theorem treeFunction_root (n : ℕ) : + treeFunction n (TreeNode.root n) = 1 := by + ext α + simp [treeFunction, BoundedContinuousFunction.indicator, treeCylinder, + TreeNode.root, TreeNode.level] + +/-- Dominates any continuous function by its uniform norm times the root; +used to prove that the admissible-majorant set is nonempty. -/ +theorem abs_le_norm_smul_root (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + |x| ≤ ‖x‖ • treeFunction n (TreeNode.root n) := by + rw [treeFunction_root] + intro α + change |x α| ≤ ‖x‖ * 1 + simpa using x.norm_coe_le_norm α + +/-- Supplies a coefficient majorant for every function; needed to define the +infimum in `treeSeminorm`. -/ +theorem treeAdmissible_nonempty (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + {r : ℝ | ∃ w : TreeCoefficients n, + 0 ≤ w ∧ |x| ≤ treeOperator n w ∧ treeRho n w = r}.Nonempty := by + let w : TreeCoefficients n := Finsupp.single (TreeNode.root n) ‖x‖ + refine ⟨treeRho n w, w, ?_, ?_, rfl⟩ + · exact Finsupp.single_nonneg.mpr (norm_nonneg x) + · rw [treeOperator_single] + exact abs_le_norm_smul_root n x + +/-- Bounds all admissible `treeRho` values below by zero; used to justify +order properties of the defining infimum. -/ +theorem treeAdmissible_bddBelow (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + BddBelow {r : ℝ | ∃ w : TreeCoefficients n, + 0 ≤ w ∧ |x| ≤ treeOperator n w ∧ treeRho n w = r} := by + refine ⟨0, ?_⟩ + rintro r ⟨w, _, _, rfl⟩ + exact treeRho_nonneg n w + +/-- Proves nonnegativity of `treeSeminorm`; used as a field of the bundled +lattice seminorm. -/ +theorem treeSeminorm_nonneg (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + 0 ≤ treeSeminorm n x := by + apply le_csInf (treeAdmissible_nonempty n x) + rintro r ⟨w, _, _, rfl⟩ + exact treeRho_nonneg n w + +/-- Bounds the seminorm by any admissible coefficient majorant; used throughout +the exact-basis and moderatedness estimates. -/ +theorem treeSeminorm_le_of_majorant (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) (w : TreeCoefficients n) + (hw : 0 ≤ w) (hxw : |x| ≤ treeOperator n w) : + treeSeminorm n x ≤ treeRho n w := by + exact csInf_le (treeAdmissible_bddBelow n x) ⟨w, hw, hxw, rfl⟩ + +/-- Evaluates the tree seminorm at zero; used for the zero field of +`treeLatticeSeminorm`. -/ +theorem treeSeminorm_zero (n : ℕ) : + treeSeminorm n (0 : BoundedContinuousFunction (TreeProduct n) ℝ) = 0 := by + apply le_antisymm + · simpa [treeRho] using + (treeSeminorm_le_of_majorant n 0 0 (by simp) + (by simp [treeOperator_zero])) + · exact treeSeminorm_nonneg n 0 + +/-- Approximates the infimum defining `treeSeminorm` by a strict majorant; +used to prove seminorm laws and to select coefficients in `component_moderated`. -/ +theorem exists_treeMajorant_lt (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) {ε : ℝ} (hε : 0 < ε) : + ∃ w : TreeCoefficients n, 0 ≤ w ∧ |x| ≤ treeOperator n w ∧ + treeRho n w < treeSeminorm n x + ε := by + obtain ⟨r, ⟨w, hw, hxw, hwr⟩, hr⟩ := + exists_lt_of_csInf_lt (treeAdmissible_nonempty n x) + (lt_add_of_pos_right (treeSeminorm n x) hε) + exact ⟨w, hw, hxw, by simpa [hwr] using hr⟩ + +/-- Gives the difficult direction of seminorm homogeneity; used together with +rescaling to prove equality in the bundled seminorm. -/ +theorem treeSeminorm_smul_le (n : ℕ) (a : ℝ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + treeSeminorm n (a • x) ≤ |a| * treeSeminorm n x := by + by_cases ha : a = 0 + · subst a + simpa using (treeSeminorm_zero n).le + apply le_of_forall_pos_le_add + intro ε hε + have habs : 0 < |a| := abs_pos.mpr ha + obtain ⟨w, hw, hxw, hrho⟩ := exists_treeMajorant_lt n x (div_pos hε habs) + have hmajor : |a • x| ≤ treeOperator n (|a| • w) := by + rw [treeOperator_smul] + intro α + change |a * x α| ≤ |a| * treeOperator n w α + rw [abs_mul] + exact mul_le_mul_of_nonneg_left (hxw α) (abs_nonneg a) + have hwscale : 0 ≤ |a| • w := by + intro t + change 0 ≤ |a| * w t + exact mul_nonneg (abs_nonneg a) (hw t) + calc + treeSeminorm n (a • x) ≤ treeRho n (|a| • w) := + treeSeminorm_le_of_majorant n _ _ hwscale hmajor + _ = |a| * treeRho n w := by rw [treeRho_smul, abs_of_nonneg (abs_nonneg a)] + _ ≤ |a| * treeSeminorm n x + ε := by + have := mul_lt_mul_of_pos_left hrho habs + rw [mul_add, mul_div_cancel₀ _ habs.ne'] at this + exact this.le + +/-- Bounds every tree function in uniform norm; used to control finite tree +operators by their coefficient sums. -/ +theorem treeFunction_norm_le_one (n : ℕ) (t : TreeNode n) : + ‖treeFunction n t‖ ≤ 1 := by + rw [BoundedContinuousFunction.norm_le zero_le_one] + intro α + by_cases h : α ∈ treeCylinder n t + · rw [treeFunction_apply_of_mem n t h] + norm_num + · rw [treeFunction_apply_of_notMem n t h] + norm_num + +/-- Bounds the uniform norm of a tree operator by the absolute coefficient +sum; used in the comparison between uniform and tree norms. -/ +theorem treeOperator_norm_le_sum (n : ℕ) (w : TreeCoefficients n) : + ‖treeOperator n w‖ ≤ ∑ t ∈ w.support, |w t| := by + classical + rw [treeOperator, Finsupp.sum] + calc + ‖∑ t ∈ w.support, w t • treeFunction n t‖ ≤ + ∑ t ∈ w.support, ‖w t • treeFunction n t‖ := norm_sum_le _ _ + _ ≤ ∑ t ∈ w.support, |w t| := by + apply Finset.sum_le_sum + intro t _ + rw [norm_smul, Real.norm_eq_abs] + nlinarith [abs_nonneg (w t), treeFunction_norm_le_one n t] + +/-- Controls the unweighted coefficient sum by `treeRho`; combined with the +operator estimate to obtain the norm comparison. -/ +theorem treeRho_controls_sum (n : ℕ) (w : TreeCoefficients n) : + (∑ t ∈ w.support, |w t|) ≤ (2 : ℝ) ^ n * treeRho n w := by + classical + rw [treeRho, Finsupp.sum, Finset.mul_sum] + apply Finset.sum_le_sum + intro t _ + have hc : (1 : ℝ) ≤ + (2 : ℝ) ^ n * (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) := by + rw [← zpow_natCast, ← zpow_add₀ (by norm_num)] + apply one_le_zpow₀ (by norm_num) + exact sub_nonneg.mpr (by exact_mod_cast t.2) + nlinarith [abs_nonneg (w t)] + +/-- Combines the preceding estimates into the main operator norm bound; used +to prove definiteness and equivalence of the component norm. -/ +theorem norm_le_pow_mul_treeRho (n : ℕ) + (x : BoundedContinuousFunction (TreeProduct n) ℝ) (w : TreeCoefficients n) + (hw : 0 ≤ w) (hxw : |x| ≤ treeOperator n w) : + ‖x‖ ≤ (2 : ℝ) ^ n * treeRho n w := by + calc + ‖x‖ ≤ ‖treeOperator n w‖ := by + apply norm_le_norm_of_abs_le_abs + simpa [abs_of_nonneg (treeOperator_nonneg n w hw)] using hxw + _ ≤ ∑ t ∈ w.support, |w t| := treeOperator_norm_le_sum n w + _ ≤ (2 : ℝ) ^ n * treeRho n w := treeRho_controls_sum n w + +/-- Dominates a positive tree operator by its total coefficient mass times the +root; used in the upper norm comparison. -/ +theorem treeOperator_le_root_of_nonneg (n : ℕ) (w : TreeCoefficients n) + (hw : 0 ≤ w) : + treeOperator n w ≤ + ((2 : ℝ) ^ n * treeRho n w) • treeFunction n (TreeNode.root n) := by + calc + treeOperator n w = |treeOperator n w| := + (abs_of_nonneg (treeOperator_nonneg n w hw)).symm + _ ≤ ‖treeOperator n w‖ • treeFunction n (TreeNode.root n) := + abs_le_norm_smul_root n (treeOperator n w) + _ ≤ ((2 : ℝ) ^ n * treeRho n w) • treeFunction n (TreeNode.root n) := by + intro α + simpa [treeFunction_root] using + (treeOperator_norm_le_sum n w).trans (treeRho_controls_sum n w) + +/-- Paper Lemma `lem:pn-seminorm`, bundled using BanLat's `LatticeSeminorm`. -/ +noncomputable def treeLatticeSeminorm (n : ℕ) : + LatticeSeminorm (BoundedContinuousFunction (TreeProduct n) ℝ) where + toFun := treeSeminorm n + map_zero' := by + exact treeSeminorm_zero n + add_le' := by + intro x y + apply le_of_forall_pos_le_add + intro ε hε + obtain ⟨u, hu, hxu, hρu⟩ := exists_treeMajorant_lt n x (half_pos hε) + obtain ⟨v, hv, hyv, hρv⟩ := exists_treeMajorant_lt n y (half_pos hε) + have hmajor : |x + y| ≤ treeOperator n (u + v) := by + rw [treeOperator_add] + exact (abs_add_le x y).trans (add_le_add hxu hyv) + calc + treeSeminorm n (x + y) ≤ treeRho n (u + v) := + treeSeminorm_le_of_majorant n _ _ (add_nonneg hu hv) hmajor + _ ≤ treeRho n u + treeRho n v := treeRho_add_le n u v + _ ≤ treeSeminorm n x + treeSeminorm n y + ε := by linarith + neg' := by + intro x + simp [treeSeminorm] + smul' := by + intro a x + apply le_antisymm + · exact treeSeminorm_smul_le n a x + · by_cases ha : a = 0 + · subst a + simp [treeSeminorm_zero] + have hinv := treeSeminorm_smul_le n a⁻¹ (a • x) + have habs : 0 < |a| := abs_pos.mpr ha + calc + |a| * treeSeminorm n x = + |a| * treeSeminorm n (a⁻¹ • (a • x)) := by + simp [smul_smul, ha] + _ ≤ |a| * (|a⁻¹| * treeSeminorm n (a • x)) := + mul_le_mul_of_nonneg_left hinv habs.le + _ = treeSeminorm n (a • x) := by + rw [abs_inv, ← mul_assoc, mul_inv_cancel₀ (abs_ne_zero.mpr ha), one_mul] + monotone_abs' := by + intro x y hxy + apply le_csInf (treeAdmissible_nonempty n y) + rintro r ⟨w, hw, hyw, rfl⟩ + exact treeSeminorm_le_of_majorant n x w hw (hxy.trans hyw) + +/-- Paper Lemma `lem:norm-comparison`. -/ +theorem treeSeminorm_norm_comparison + (n : ℕ) (x : BoundedContinuousFunction (TreeProduct n) ℝ) : + treeSeminorm n x ≤ ‖x‖ ∧ ‖x‖ ≤ (2 : ℝ) ^ n * treeSeminorm n x := by + constructor + · let w : TreeCoefficients n := Finsupp.single (TreeNode.root n) ‖x‖ + have hw : 0 ≤ w := Finsupp.single_nonneg.mpr (norm_nonneg x) + have hxw : |x| ≤ treeOperator n w := by + rw [treeOperator_single] + exact abs_le_norm_smul_root n x + calc + treeSeminorm n x ≤ treeRho n w := treeSeminorm_le_of_majorant n x w hw hxw + _ = ‖x‖ := by simp [w, treeRho, TreeNode.root, TreeNode.level] + · apply le_of_forall_pos_le_add + intro ε hε + have hpow : 0 < (2 : ℝ) ^ n := pow_pos (by norm_num) n + obtain ⟨w, hw, hxw, hrho⟩ := + exists_treeMajorant_lt n x (div_pos hε hpow) + have hnorm := norm_le_pow_mul_treeRho n x w hw hxw + have hscaled := mul_lt_mul_of_pos_left hrho hpow + rw [mul_add, mul_div_cancel₀ _ hpow.ne'] at hscaled + exact hnorm.trans hscaled.le + +/-- Computes the level of a strict prefix; used to compare nodes from nested +tree cylinders in the exact-basis proof. -/ +theorem level_strictPrefix {n : ℕ} (t : TreeNode n) + (j : Fin (TreeNode.level t)) : + TreeNode.level (strictPrefix t j).1 = j := by + simp [strictPrefix, TreeNode.restrict, TreeNode.level] + +/-- Shows that inclusion of nonempty tree cylinders forces the corresponding +level inequality; used to isolate the maximal-weight basis term. -/ +theorem level_le_of_treeCylinder_subset {n : ℕ} {t u : TreeNode n} + (hsub : treeCylinder n t ⊆ treeCylinder n u) : + TreeNode.level u ≤ TreeNode.level t := by + classical + by_contra h + have hlt : TreeNode.level t < TreeNode.level u := Nat.lt_of_not_ge h + let j : Fin (TreeNode.level u) := ⟨TreeNode.level t, hlt⟩ + let q : TreeNonterminal n := strictPrefix u j + let α : TreeProduct n := fun r ↦ if r = q then u.1.get j + 1 else 0 + have hαt : α ∈ treeCylinder n t := by + intro k + have hne : strictPrefix t k ≠ q := by + intro heq + have hlevel := congrArg (fun r : TreeNonterminal n ↦ TreeNode.level r.1) heq + change TreeNode.level (strictPrefix t k).1 = TreeNode.level q.1 at hlevel + rw [level_strictPrefix t k, show TreeNode.level q.1 = j by + exact level_strictPrefix u j] at hlevel + exact (Nat.ne_of_lt k.isLt) hlevel + simp [α, hne] + have hαu := hsub hαt j + simp [α, q] at hαu + +/-- Records positivity of every tree function; used for lattice estimates and +for the positive terminal family in the component construction. -/ +theorem treeFunction_nonneg (n : ℕ) (t : TreeNode n) : + 0 ≤ treeFunction n t := by + intro α + change (0 : ℝ) ≤ treeFunction n t α + by_cases hα : α ∈ treeCylinder n t + · rw [treeFunction_apply_of_mem n t hα] + norm_num + · rw [treeFunction_apply_of_notMem n t hα] + +/-- Paper Lemma `lem:exact-basis`. -/ +theorem treeSeminorm_exact_basis (n : ℕ) (t : TreeNode n) : + (∀ w : TreeCoefficients n, 0 ≤ w → treeFunction n t ≤ treeOperator n w → + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) ≤ treeRho n w) ∧ + treeSeminorm n (treeFunction n t) = + (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) := by + classical + let a : ℝ := (2 : ℝ) ^ (-(TreeNode.level t : ℤ)) + have ha : 0 < a := zpow_pos (by norm_num) _ + have hlower : ∀ w : TreeCoefficients n, 0 ≤ w → + treeFunction n t ≤ treeOperator n w → a ≤ treeRho n w := by + intro w hw hdom + let C := w.support.filter fun u ↦ treeCylinder n t ⊆ treeCylinder n u + let N := w.support.filter fun u ↦ ¬treeCylinder n t ⊆ treeCylinder n u + have hnotcover : ¬(∀ α ∈ treeCylinder n t, + ∃ u ∈ N, α ∈ treeCylinder n u) := by + intro hcover + obtain ⟨u, huN, hsub⟩ := treeCylinder_finite_cover n t N hcover + exact (Finset.mem_filter.mp huN).2 hsub + push Not at hnotcover + obtain ⟨α, hαt, hαN⟩ := hnotcover + have hoperator : treeOperator n w α = ∑ u ∈ C, w u := by + rw [treeOperator_apply, Finsupp.sum] + change (∑ u ∈ w.support, w u * treeFunction n u α) = ∑ u ∈ C, w u + rw [Finset.sum_filter] + apply Finset.sum_congr rfl + intro u hu + by_cases hsub : treeCylinder n t ⊆ treeCylinder n u + · rw [ite_eq_left hsub, treeFunction_apply_of_mem n u (hsub hαt), mul_one] + · have huN : u ∈ N := Finset.mem_filter.mpr ⟨hu, hsub⟩ + rw [ite_eq_right hsub, treeFunction_apply_of_notMem n u (hαN u huN), mul_zero] + have hsum : 1 ≤ ∑ u ∈ C, w u := by + have hdomα := hdom α + change treeFunction n t α ≤ treeOperator n w α at hdomα + rw [treeFunction_apply_of_mem n t hαt, hoperator] at hdomα + exact hdomα + calc + a ≤ a * ∑ u ∈ C, w u := by nlinarith + _ = ∑ u ∈ C, a * w u := by rw [Finset.mul_sum] + _ ≤ ∑ u ∈ C, + (2 : ℝ) ^ (-(TreeNode.level u : ℤ)) * |w u| := by + apply Finset.sum_le_sum + intro u huC + have hsub := (Finset.mem_filter.mp huC).2 + have hlevel := level_le_of_treeCylinder_subset hsub + have hweight : a ≤ (2 : ℝ) ^ (-(TreeNode.level u : ℤ)) := by + apply zpow_le_zpow_right₀ (by norm_num) + exact neg_le_neg (by exact_mod_cast hlevel) + rw [abs_of_nonneg (hw u)] + exact mul_le_mul_of_nonneg_right hweight (hw u) + _ ≤ ∑ u ∈ w.support, + (2 : ℝ) ^ (-(TreeNode.level u : ℤ)) * |w u| := by + apply Finset.sum_le_sum_of_subset_of_nonneg (Finset.filter_subset _ _) + intro u _ _ + exact mul_nonneg (zpow_nonneg (by norm_num) _) (abs_nonneg _) + _ = treeRho n w := by rw [treeRho, Finsupp.sum] + refine ⟨hlower, ?_⟩ + apply le_antisymm + · let w : TreeCoefficients n := treeBasis t + have hw : 0 ≤ w := by simp [w, treeBasis] + have hmajor : |treeFunction n t| ≤ treeOperator n w := by + rw [abs_of_nonneg (treeFunction_nonneg n t)] + change treeFunction n t ≤ treeOperator n (treeBasis t) + rw [treeBasis, treeOperator_single, one_smul] + calc + treeSeminorm n (treeFunction n t) ≤ treeRho n w := + treeSeminorm_le_of_majorant n _ w hw hmajor + _ = a := by simp [w, treeBasis, treeRho, a] + · apply le_csInf (treeAdmissible_nonempty n (treeFunction n t)) + rintro r ⟨w, hw, hmajor, rfl⟩ + apply hlower w hw + simpa [abs_of_nonneg (treeFunction_nonneg n t)] using hmajor + +/-- The closed vector sublattice generated by the tree functions. -/ +noncomputable def treeSublattice (n : ℕ) : + VectorSublattice (BoundedContinuousFunction (TreeProduct n) ℝ) := + (VectorSublattice.generated (Set.range (treeFunction n))).topologicalClosure + +/-- Places every finitely supported tree operator in the generated closed +sublattice; used to turn coefficient majorants into component elements. -/ +theorem treeOperator_mem_treeSublattice (n : ℕ) (w : TreeCoefficients n) : + treeOperator n w ∈ treeSublattice n := by + classical + apply subset_closure + change treeOperator n w ∈ + VectorSublattice.generated (Set.range (treeFunction n)) + rw [treeOperator, Finsupp.sum] + apply Submodule.sum_mem + intro t ht + exact (VectorSublattice.generated (Set.range (treeFunction n))).toSubmodule.smul_mem + _ (VectorSublattice.subset_generated _ ⟨t, rfl⟩) + +/-- The component space `X_n`, using the underlying submodule carrier. -/ +abbrev TreeComponent (n : ℕ) := ↥(treeSublattice n).toSubmodule + +/-- Pointwise lattice operations on the component subspace. -/ +noncomputable instance treeComponentLattice (n : ℕ) : Lattice (TreeComponent n) where + le := fun x y ↦ x.1 ≤ y.1 + le_refl := fun _ ↦ le_rfl + le_trans := fun _ _ _ hxy hyz ↦ hxy.trans hyz + le_antisymm := fun x y hxy hyx ↦ Subtype.ext (le_antisymm hxy hyx) + sup := fun x y ↦ ⟨x.1 ⊔ y.1, (treeSublattice n).sup_mem x.2 y.2⟩ + le_sup_left := fun _ _ ↦ le_sup_left + le_sup_right := fun _ _ ↦ le_sup_right + sup_le := fun _ _ _ hx hz ↦ sup_le hx hz + inf := fun x y ↦ ⟨x.1 ⊓ y.1, (treeSublattice n).inf_mem x.2 y.2⟩ + inf_le_left := fun _ _ ↦ inf_le_left + inf_le_right := fun _ _ ↦ inf_le_right + le_inf := fun _ _ _ hx hz ↦ le_inf hx hz + +/-- Compatibility of the inherited addition with the pointwise order. -/ +instance treeComponentIsOrderedAddMonoid (n : ℕ) : + IsOrderedAddMonoid (TreeComponent n) where + add_le_add_left a b hab c := by + intro p + simpa [add_comm] using add_le_add_right (hab p) (c.1 p) + +/-- The component subspace is a real vector lattice. -/ +noncomputable instance treeComponentVectorLattice (n : ℕ) : + VectorLattice (TreeComponent n) where + smul_le_smul_of_nonneg_left := by + intro a ha x y hxy + exact smul_le_smul_of_nonneg_left hxy ha + +/-- The norm `p_n` restricted to `X_n`. -/ +noncomputable def componentLatticeNorm (n : ℕ) : PaperLatticeNorm (TreeComponent n) where + toFun := fun x ↦ treeSeminorm n x.1 + nonneg := by + intro x + exact apply_nonneg (treeLatticeSeminorm n).toSeminorm x.1 + eq_zero_iff := by + intro x + constructor + · intro hx + apply Subtype.ext + apply norm_eq_zero.mp + have hle := (treeSeminorm_norm_comparison n x.1).2 + rw [hx, mul_zero] at hle + exact le_antisymm hle (norm_nonneg _) + · rintro rfl + exact map_zero (treeLatticeSeminorm n).toSeminorm + add_le := by + intro x y + exact map_add_le_add (treeLatticeSeminorm n).toSeminorm x.1 y.1 + smul := by + intro a x + rw [← Real.norm_eq_abs] + exact map_smul_eq_mul (treeLatticeSeminorm n).toSeminorm a x.1 + solid := by + intro x y hxy + exact (treeLatticeSeminorm n).monotone_abs' hxy + +/-- The constant function `1`, as an element of `X_n`. -/ +noncomputable def componentRoot (n : ℕ) : TreeComponent n := + ⟨treeFunction n (TreeNode.root n), by + change treeFunction n (TreeNode.root n) ∈ + closure (VectorSublattice.generated (Set.range (treeFunction n)) : + Set (BoundedContinuousFunction (TreeProduct n) ℝ)) + apply subset_closure + exact VectorSublattice.subset_generated _ ⟨TreeNode.root n, rfl⟩⟩ + +/-- Any tree function, viewed in the generated component. -/ +noncomputable def componentTreeFunction (n : ℕ) (t : TreeNode n) : TreeComponent n := + ⟨treeFunction n t, by + change treeFunction n t ∈ + closure (VectorSublattice.generated (Set.range (treeFunction n)) : + Set (BoundedContinuousFunction (TreeProduct n) ℝ)) + apply subset_closure + exact VectorSublattice.subset_generated _ ⟨t, rfl⟩⟩ + +/-- Paper Corollary `cor:Yn-basic`. -/ +theorem component_basic (n : ℕ) : + TopologicalSpace.IsSeparable (Set.univ : Set (TreeComponent n)) ∧ + IsCompleteFor (componentLatticeNorm n) ∧ + componentLatticeNorm n (componentRoot n) = 1 ∧ + (∀ t : TreeNode n, TreeNode.level t = n → + componentLatticeNorm n (componentTreeFunction n t) = + (2 : ℝ) ^ (-(n : ℤ))) := by + have hseparable : TopologicalSpace.IsSeparable + (Set.univ : Set (TreeComponent n)) := by + let : Countable (TreeNode n) := by + unfold TreeNode + infer_instance + let : TopologicalSpace.SeparableSpace (TreeComponent n) := + VectorSublattice.separableSpace_topologicalClosure_generated_of_countable + (Set.countable_range (treeFunction n)) + exact TopologicalSpace.isSeparable_univ_iff.mpr inferInstance + have hcomplete : IsCompleteFor (componentLatticeNorm n) := by + intro f hf + have hnormCauchy : CauchySeq (fun m ↦ (f m).1) := by + rw [Metric.cauchySeq_iff] + intro ε hε + have hpow : 0 < (2 : ℝ) ^ n := pow_pos (by norm_num) n + obtain ⟨N, hN⟩ := hf (ε / (2 : ℝ) ^ n) (div_pos hε hpow) + refine ⟨N, fun m hm k hk ↦ ?_⟩ + have hp := hN m hm k hk + have hnorm := (treeSeminorm_norm_comparison n ((f m).1 - (f k).1)).2 + rw [dist_eq_norm_sub] + change treeSeminorm n ((f m).1 - (f k).1) < ε / (2 : ℝ) ^ n at hp + have hscaled := mul_lt_mul_of_pos_left hp hpow + rw [mul_div_cancel₀ _ hpow.ne'] at hscaled + exact hnorm.trans_lt hscaled + obtain ⟨y, hy⟩ := cauchySeq_tendsto_of_complete hnormCauchy + have hymem : y ∈ treeSublattice n := by + apply isClosed_closure.mem_of_tendsto hy + exact Eventually.of_forall fun m ↦ (f m).2 + let z : TreeComponent n := ⟨y, hymem⟩ + refine ⟨z, ?_⟩ + rw [Metric.tendsto_atTop] at hy + intro ε hε + obtain ⟨N, hN⟩ := hy ε hε + refine ⟨N, fun m hm ↦ ?_⟩ + have hp := (treeSeminorm_norm_comparison n ((f m).1 - y)).1 + have hdist := hN m hm + rw [dist_eq_norm_sub] at hdist + change treeSeminorm n ((f m).1 - y) < ε + exact hp.trans_lt hdist + refine ⟨hseparable, hcomplete, ?_, ?_⟩ + · change treeSeminorm n (treeFunction n (TreeNode.root n)) = 1 + simpa [TreeNode.root, TreeNode.level] using + (treeSeminorm_exact_basis n (TreeNode.root n)).2 + · intro t ht + change treeSeminorm n (treeFunction n t) = (2 : ℝ) ^ (-(n : ℤ)) + simpa [ht] using (treeSeminorm_exact_basis n t).2 + +end OrderClosures diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index 32cdb74d91..ac5d3fb2d8 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -1,4 +1,81 @@ projects: + - slug: order-closures + title: Order closure, order adherence and Fatou norms + summary: >- + Formalizes order and unbounded-order adherence in vector lattices, + the Gao-Leung characterization of order-continuous norms on + sigma-order-complete Banach lattices, and the Solovay/Stone-space + construction of order-complete C(K) spaces with arbitrarily large + density and separable order-dense sublattices. Constructs solid sets + with a prescribed infinite number kappa of solid generators whose + adherence towers are strict below any ordinal at most kappa's + successor cardinal. Constructs a complete weakly Fatou lattice norm + with constant 2 that is not equivalent to any Fatou lattice norm. + Includes reusable vector-lattice, net-convergence, sublattice, + seminorm, Boolean-algebra and transfinite-iteration infrastructure. + branch: functional analysis + entry_module: LeanPool.OrderClosures + authors: + - Antonio Avilés + - Mitchell A. Taylor + - Pedro Tradacete + - David Muñoz-Lahoz + source: + title: Order closure, order adherence and Fatou norms + arxiv: '2609.06689' + url: https://github.com/pedrotradacete/OrderClosures/tree/6189ba7134f6975e7d8e4c8c093a9869d03a769c + github_repo: pedrotradacete/OrderClosures + commit: 6189ba7134f6975e7d8e4c8c093a9869d03a769c + license: Apache-2.0 + status: verified + provenance: AI + main_declarations: + - OrderClosures.exists_weaklyFatou_not_equivalent_fatou + main_results: + - declaration: OrderClosures.gaoLeung_orderContinuous_characterization + informal: >- + For a sigma-order-complete Banach lattice X, the following are + equivalent: every vector sublattice has order-closed order + adherence; every vector sublattice has equal order and + unbounded-order adherence; and the norm of X is order continuous. + source_ref: Paper Theorem 1.1, recalling Gao-Leung Theorem 2.7. + - declaration: OrderClosures.gao_counterexample + informal: >- + For every cardinal kappa there is a compact Hausdorff space K + such that C(K, R) is order complete and has density at least + kappa, with a norm-closed separable vector sublattice Y whose + only order-closed vector-sublattice extension is all of C(K, R). + source_ref: Paper Theorem 2.1, via the Solovay Boolean algebra. + - declaration: OrderClosures.solid_sets_require_arbitrarily_many_iterations + informal: >- + For every infinite cardinal kappa and ordinal xi at most the + initial ordinal of kappa's successor cardinal, there is a + vector lattice and a solid set with solid generator number + kappa whose order-adherence tower has a proper step at every + stage below xi. The witness and cardinal/ordinal parameters + are lifted one universe in Lean. + source_ref: Paper Theorem 2.6; explicit infinite-cardinal hypothesis. + - declaration: OrderClosures.exists_weaklyFatou_not_equivalent_fatou + informal: >- + There is a real vector lattice with a complete lattice norm p + satisfying the weak Fatou property with constant 2, such that + no lattice norm q with the Fatou property is equivalent to p. + Norms, completeness and equivalence are represented explicitly + by PaperLatticeNorm, IsCompleteFor and EquivalentNorms. + source_ref: >- + Paper Theorem 3.1; self-contained construction of the result + previously announced by Anthony Wickstead and credited to + Michael Elliott. The paper credits Jaume de Dios Pont for an + earlier Lean formalization of this result. + tags: + - banach-lattices + - order-convergence + - fatou-norms + - transfinite-constructions + msc: + - 46B42 + - 46A40 + - 46A19 - slug: block-spectral-sensitivity title: Block sensitivity can exceed spectral sensitivity squared summary: >- From 2afd841870a7cbf7dd73ae889df475be8324e85c Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 04:22:20 +0000 Subject: [PATCH 2/4] perf: supply the shifted summable family explicitly --- LeanPool/OrderClosures/GaoLeungCharacterization.lean | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/LeanPool/OrderClosures/GaoLeungCharacterization.lean b/LeanPool/OrderClosures/GaoLeungCharacterization.lean index e18daebd27..2ce5c9e7ab 100644 --- a/LeanPool/OrderClosures/GaoLeungCharacterization.lean +++ b/LeanPool/OrderClosures/GaoLeungCharacterization.lean @@ -69,7 +69,8 @@ private theorem norm_tendsto_has_order_convergent_subsequence apply squeeze_zero_norm · intro k change ‖∑' j, v (j + k)‖ ≤ ∑' j, ‖v (j + k)‖ - exact norm_tsum_le_tsum_norm ((summable_nat_add_iff k).2 hv_norm_sum) + exact norm_tsum_le_tsum_norm + ((summable_nat_add_iff (f := fun n ↦ ‖v n‖) k).2 hv_norm_sum) · exact tendsto_sum_nat_add (fun n ↦ ‖v n‖) refine ⟨φ, hφ, ?_⟩ let K := ULift.{u} ℕ From 1708a9a315dd323bc6aec9493b2f5695a1e4a38a Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 04:30:56 +0000 Subject: [PATCH 3/4] fix: share norm reductions and test lattice tactic transfers --- .../OrderClosures/BanLat/Tactic/LLexpr.lean | 39 ++++ .../OrderClosures/WeaklyFatou/Reductions.lean | 171 +++--------------- 2 files changed, 69 insertions(+), 141 deletions(-) diff --git a/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean index 2d083da913..e1621838da 100644 --- a/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean +++ b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean @@ -402,6 +402,15 @@ def closeByTransfer (type : Expr) (lhsQ rhsQ : Quoted) (atoms : Array Expr) (asL let (_, goal) ← (← (← getMainGoal).assert transferName proofType proof).intro1P setGoals [goal] let hIdent := mkIdent transferName + if hasSigns then + let savedState ← saveState + try + evalTactic (← `(tactic| + simpa [*, LLexpr.eval_zero, LLexpr.eval_var, LLexpr.eval_add, LLexpr.eval_smul, + LLexpr.eval_sup, LLexpr.eval_inf, posPart_def, negPart_def, abs, sub_eq_add_neg, + neg_one_smul, add_assoc, add_comm, add_left_comm] using $hIdent:ident)) + return + catch _ => savedState.restore if !hasSigns then if asLe then evalTactic (← `(tactic| @@ -450,6 +459,9 @@ def closeByTransfer (type : Expr) (lhsQ rhsQ : Quoted) (atoms : Array Expr) (asL /-- Implementation of the user-facing `llarith` tactic. -/ def evalLlarith : TacticM Unit := withMainContext do + let goal ← getMainGoal + evalTactic (← `(tactic| try rfl)) + if ← goal.isAssigned then return let target ← instantiateMVars (← getMainTarget) let targetWhnf ← whnf target if let some (_, lhs, rhs) := targetWhnf.eq? <|> target.eq? then @@ -499,6 +511,33 @@ end Tactic end LLexpr +end + section Tests +variable {E : Type*} [AddCommGroup E] [Lattice E] [IsOrderedAddMonoid E] + [VectorLattice E] + +example (x y : E) : (x ⊔ y) + (x ⊓ y) = x + y := by llarith + +example (x y : E) : |x + y| ≤ |x| + |y| := by llarith + +example (x y : E) : (2 : ℝ) • (x ⊔ y) = (2 : ℝ) • x ⊔ (2 : ℝ) • y := by llarith + +example (x : E) (hx : 0 ≤ x) : |x| = x := by llarith + +example (x : E) (hx : x ≤ 0) : |x| = -x := by llarith + +example (x : E) (hx : 0 < x) : |x| = x := by llarith + +example (x : E) (hx : x < 0) : |x| = -x := by llarith + +example (x y : E) (hx : 0 ≤ x) (hy : y ≤ 0) : |x - y| = x - y := by llarith + +example (x y : E) (hx : 0 ≤ x) (hy : y ≤ 0) : y ≤ x := by llarith + +example (x : E) : x⁺ - x⁻ = x := by llarith + +example : (0 : E) = 0 := by llarith + end Tests diff --git a/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean b/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean index 936881105f..23e46dac05 100644 --- a/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean +++ b/LeanPool/OrderClosures/WeaklyFatou/Reductions.lean @@ -194,147 +194,6 @@ def FremlinProperty : Prop := (∃ K, HasWeakFatouProperty p K) → ∃ q : PaperLatticeNorm X, HasFatouProperty q ∧ EquivalentNorms p q -/-- Promotes the sequential weak Nakano estimate to directed sets in a -separable normed lattice; the paper-norm version below reduces to this lemma. -/ -theorem weakNakano_of_weakSequentialNakano - {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] - [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] - {K : ℝ} (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : - IsWeakNakanoConstant (X := Y) norm K := by - refine ⟨hseq.1, ?_⟩ - intro A hApos hAdir hAbdd hAnorm ε hε - classical - by_cases hAempty : A = ∅ - · subst A - refine ⟨0, le_rfl, ?_, ?_⟩ - · simp - · norm_num - linarith [hseq.1] - have hAne : A.Nonempty := Set.nonempty_iff_ne_empty.mpr hAempty - let : Nonempty ↥A := ⟨⟨Classical.choose hAne, Classical.choose_spec hAne⟩⟩ - let : TopologicalSpace.SeparableSpace ↥A := inferInstance - obtain ⟨d, hdense⟩ := TopologicalSpace.exists_dense_seq ↥A - let join : ↥A → ↥A → ↥A := fun a b ↦ - ⟨Classical.choose (hAdir a.1 a.2 b.1 b.2), - (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).1⟩ - have hjoin_left (a b : ↥A) : a.1 ≤ (join a b).1 := - (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.1 - have hjoin_right (a b : ↥A) : b.1 ≤ (join a b).1 := - (Classical.choose_spec (hAdir a.1 a.2 b.1 b.2)).2.2 - let z : ℕ → ↥A := fun m ↦ - Nat.rec (d 0) (fun k a ↦ join a (d (k + 1))) m - have hz_succ (m : ℕ) : z (m + 1) = join (z m) (d (m + 1)) := by - simp [z] - have hzmono : Monotone (fun m ↦ (z m).1) := by - apply monotone_nat_of_le_succ - intro m - rw [hz_succ] - exact hjoin_left _ _ - have hd_le_z : ∀ m, (d m).1 ≤ (z m).1 := by - intro m - cases m with - | zero => simp [z] - | succ m => - rw [hz_succ] - exact hjoin_right _ _ - have hzpos : ∀ m, 0 ≤ (z m).1 := fun m ↦ hApos (z m).2 - have hzbdd : BddAbove (Set.range fun m ↦ (z m).1) := by - rcases hAbdd with ⟨b, hb⟩ - exact ⟨b, by rintro _ ⟨m, rfl⟩; exact hb (z m).2⟩ - have hznorm : ∀ m, ‖(z m).1‖ ≤ 1 := fun m ↦ hAnorm _ (z m).2 - obtain ⟨y, hypos, hyupper, hynorm⟩ := - hseq.2 (fun m ↦ (z m).1) hzmono hzpos hzbdd hznorm ε hε - refine ⟨y, hypos, ?_, hynorm⟩ - have hd_upper : ∀ m, (d m).1 ≤ y := - fun m ↦ (hd_le_z m).trans (hyupper m) - have hclosed : IsClosed {a : ↥A | a.1 ≤ y} := - isClosed_Iic.preimage continuous_subtype_val - have hclosure : closure (Set.range d) ⊆ {a : ↥A | a.1 ≤ y} := by - apply closure_minimal - · rintro _ ⟨m, rfl⟩ - exact hd_upper m - · exact hclosed - intro x hx - let xA : ↥A := ⟨x, hx⟩ - exact hclosure (by rw [hdense.closure_eq]; exact Set.mem_univ xA) - -/-- Converts the directed weak Nakano estimate into the weak Fatou inequality -for an ambient norm; reused after transporting a paper lattice norm. -/ -theorem weakFatou_of_weakNakano_norm - {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] - [NormedVectorLattice Y] {K : ℝ} - (hNak : IsWeakNakanoConstant (X := Y) norm K) : - HasWeakFatouProperty (norm : Y → ℝ) K := by - refine ⟨hNak.1, ?_⟩ - intro ι _ _ _ f x hfmono hfpos hflub c hfc - classical - let i₀ : ι := Classical.choice inferInstance - have hc : 0 ≤ c := (norm_nonneg (f i₀)).trans (hfc i₀) - by_cases hc0 : c = 0 - · subst c - have hfzero : ∀ i, f i = 0 := by - intro i - exact norm_eq_zero.mp (le_antisymm (hfc i) (norm_nonneg _)) - have hxzero : x = 0 := by - apply le_antisymm - · apply hflub.2 - rintro _ ⟨i, rfl⟩ - simp [hfzero i] - · simpa [hfzero i₀] using hflub.1 ⟨i₀, rfl⟩ - simp [hxzero] - have hcpos : 0 < c := lt_of_le_of_ne hc (Ne.symm hc0) - apply le_of_forall_pos_le_add - intro δ hδ - let A : Set Y := Set.range fun i ↦ c⁻¹ • f i - have hApos : A ⊆ Set.Ici 0 := by - rintro _ ⟨i, rfl⟩ - exact smul_nonneg (inv_nonneg.mpr hc) (hfpos i) - have hAdir : DirectedOn (· ≤ ·) A := by - rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ - obtain ⟨k, hik, hjk⟩ := directed_of (· ≤ ·) i j - refine ⟨c⁻¹ • f k, ⟨k, rfl⟩, ?_, ?_⟩ - · exact smul_le_smul_of_nonneg_left (hfmono hik) (inv_nonneg.mpr hc) - · exact smul_le_smul_of_nonneg_left (hfmono hjk) (inv_nonneg.mpr hc) - have hAbdd : BddAbove A := by - refine ⟨c⁻¹ • x, ?_⟩ - rintro _ ⟨i, rfl⟩ - exact smul_le_smul_of_nonneg_left (hflub.1 ⟨i, rfl⟩) (inv_nonneg.mpr hc) - have hAnorm : ∀ z ∈ A, ‖z‖ ≤ 1 := by - rintro _ ⟨i, rfl⟩ - rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hcpos)] - have hi := hfc i - rw [inv_mul_le_one₀ hcpos] - exact hi - obtain ⟨y, hypos, hyupper, hynorm⟩ := - hNak.2 A hApos hAdir hAbdd hAnorm (δ / c) (div_pos hδ hcpos) - have hxy : x ≤ c • y := by - apply hflub.2 - rintro _ ⟨i, rfl⟩ - have hi := hyupper (c⁻¹ • f i) ⟨i, rfl⟩ - have := smul_le_smul_of_nonneg_left hi hc - simpa [smul_smul, hc0] using this - have hxpos : 0 ≤ x := (hfpos i₀).trans (hflub.1 ⟨i₀, rfl⟩) - have hcyp : 0 ≤ c • y := smul_nonneg hc hypos - have hnormxy : ‖x‖ ≤ ‖c • y‖ := by - apply norm_le_norm_of_abs_le_abs - simpa [abs_of_nonneg hxpos, abs_of_nonneg hcyp] using hxy - calc - ‖x‖ ≤ ‖c • y‖ := hnormxy - _ = c * ‖y‖ := by rw [norm_smul, Real.norm_eq_abs, abs_of_pos hcpos] - _ ≤ c * (K + δ / c) := mul_le_mul_of_nonneg_left hynorm hc - _ = K * c + δ := by field_simp - -/-- Paper Proposition `prop:separable-reduction`. -/ -theorem separable_weakSequentialNakano_implies_weakNakano - {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] - [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] - {K : ℝ} (_hK : 1 ≤ K) - (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : - IsWeakNakanoConstant (X := Y) norm K ∧ - HasWeakFatouProperty (norm : Y → ℝ) K := by - have hNak := weakNakano_of_weakSequentialNakano hseq - exact ⟨hNak, weakFatou_of_weakNakano_norm hNak⟩ - /-- Extends the separable sequential-to-directed reduction to an arbitrary `PaperLatticeNorm`; used to prove `component_weakFatou`. -/ theorem weakNakano_of_weakSequentialNakano_p @@ -461,6 +320,36 @@ theorem weakFatou_of_weakNakano_p _ ≤ c * (K + δ / c) := mul_le_mul_of_nonneg_left hyp hc _ = K * c + δ := by field_simp +/-- Promotes the sequential weak Nakano estimate to directed sets in a +separable normed lattice, by specializing the paper-norm reduction. -/ +theorem weakNakano_of_weakSequentialNakano + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] + {K : ℝ} (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : + IsWeakNakanoConstant (X := Y) norm K := by + exact weakNakano_of_weakSequentialNakano_p ambientLatticeNorm hseq + +/-- Converts the directed weak Nakano estimate into the weak Fatou inequality +for an ambient norm, by specializing the paper-norm reduction. -/ +theorem weakFatou_of_weakNakano_norm + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] {K : ℝ} + (hNak : IsWeakNakanoConstant (X := Y) norm K) : + HasWeakFatouProperty (norm : Y → ℝ) K := by + exact weakFatou_of_weakNakano_p ambientLatticeNorm hNak + +/-- Paper Proposition `prop:separable-reduction`. -/ +theorem separable_weakSequentialNakano_implies_weakNakano + {Y : Type u} [NormedAddCommGroup Y] [Lattice Y] [IsOrderedAddMonoid Y] + [NormedVectorLattice Y] [TopologicalSpace.SeparableSpace Y] + {K : ℝ} (_hK : 1 ≤ K) + (hseq : IsWeakSequentialNakanoConstant (X := Y) norm K) : + IsWeakNakanoConstant (X := Y) norm K ∧ + HasWeakFatouProperty (norm : Y → ℝ) K := by + have hNak := weakNakano_of_weakSequentialNakano hseq + exact ⟨hNak, weakFatou_of_weakNakano_norm hNak⟩ + + end Reductions end OrderClosures From 0e45643ca8923ea5249d4de936e8219983c082b1 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Sat, 26 Sep 2026 09:56:33 +0000 Subject: [PATCH 4/4] fix(OrderClosures): preserve tactic goals and correct scope --- LeanPool/OrderClosures.lean | 5 ++- .../OrderClosures/BanLat/Tactic/LLexpr.lean | 41 ++++++++++++++++++- .../GaoLeungProblem/Counterexample.lean | 5 ++- LeanPool/projects.yml | 7 ++-- 4 files changed, 50 insertions(+), 8 deletions(-) diff --git a/LeanPool/OrderClosures.lean b/LeanPool/OrderClosures.lean index fba4b39bec..a63c1dc7f6 100644 --- a/LeanPool/OrderClosures.lean +++ b/LeanPool/OrderClosures.lean @@ -50,8 +50,9 @@ precise human/AI fraction is claimed. The Lean Pool port and proof repairs were performed with Codex. `gao_counterexample` states the order-complete `C(K)` construction with a -norm-closed separable order-dense sublattice. It does not itself state the -negation of the Gao-Leung conjecture: the paper derives that consequence by a +norm-closed separable sublattice whose only order-closed vector-sublattice +extension is all of `C(K)`. It does not itself state the negation of the +Gao-Leung conjecture: the paper derives that consequence by a cardinality argument. The registered informal statement describes the actual Lean endpoint. -/ diff --git a/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean index e1621838da..b328371d6a 100644 --- a/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean +++ b/LeanPool/OrderClosures/BanLat/Tactic/LLexpr.lean @@ -458,7 +458,7 @@ def closeByTransfer (type : Expr) (lhsQ rhsQ : Quoted) (atoms : Array Expr) (asL | convert $hIdent:ident using 1 <;> abel_nf)) /-- Implementation of the user-facing `llarith` tactic. -/ -def evalLlarith : TacticM Unit := withMainContext do +def evalLlarith : TacticM Unit := focus <| withMainContext do let goal ← getMainGoal evalTactic (← `(tactic| try rfl)) if ← goal.isAssigned then return @@ -540,4 +540,43 @@ example (x : E) : x⁺ - x⁻ = x := by llarith example : (0 : E) = 0 := by llarith +-- The evaluator sees all three goals and must return precisely the original two siblings. +example (x y : E) (P Q : Prop) (hP : P) (hQ : Q) : + (x ⊔ y) + (x ⊓ y) = x + y ∧ P ∧ Q := by + run_tac + let [mainGoal, rest] ← (← Lean.Elab.Tactic.getMainGoal).applyConst ``And.intro + | Lean.throwError "expected the main goal and sibling conjunction" + let [pGoal, qGoal] ← rest.applyConst ``And.intro + | Lean.throwError "expected two sibling goals" + Lean.Elab.Tactic.setGoals [mainGoal, pGoal, qGoal] + LLexpr.Tactic.evalLlarith + unless ← mainGoal.isAssigned do + Lean.throwError "llarith did not close its main goal" + unless (← Lean.Elab.Tactic.getGoals) == [pGoal, qGoal] do + Lean.throwError "llarith changed or reordered its sibling goals" + pGoal.withContext do + pGoal.assign (← Lean.Meta.getFVarFromUserName `hP) + qGoal.withContext do + qGoal.assign (← Lean.Meta.getFVarFromUserName `hQ) + Lean.Elab.Tactic.setGoals [] + +example (x y : E) (hx : 0 ≤ x) (hy : y ≤ 0) (P Q : Prop) (hP : P) (hQ : Q) : + y ≤ x ∧ P ∧ Q := by + run_tac + let [mainGoal, rest] ← (← Lean.Elab.Tactic.getMainGoal).applyConst ``And.intro + | Lean.throwError "expected the main goal and sibling conjunction" + let [pGoal, qGoal] ← rest.applyConst ``And.intro + | Lean.throwError "expected two sibling goals" + Lean.Elab.Tactic.setGoals [mainGoal, pGoal, qGoal] + LLexpr.Tactic.evalLlarith + unless ← mainGoal.isAssigned do + Lean.throwError "llarith did not close its main goal" + unless (← Lean.Elab.Tactic.getGoals) == [pGoal, qGoal] do + Lean.throwError "llarith changed or reordered its sibling goals" + pGoal.withContext do + pGoal.assign (← Lean.Meta.getFVarFromUserName `hP) + qGoal.withContext do + qGoal.assign (← Lean.Meta.getFVarFromUserName `hQ) + Lean.Elab.Tactic.setGoals [] + end Tests diff --git a/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean b/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean index 116d09ce5b..c445e26190 100644 --- a/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean +++ b/LeanPool/OrderClosures/GaoLeungProblem/Counterexample.lean @@ -39,8 +39,9 @@ end GaoLeungTheorem section Counterexample -/-- Paper Theorem 2.1: an order-complete `C(K)` of arbitrarily large density, -with a closed separable sublattice whose order closure is all of `C(K)`. -/ +/-- Paper Proposition 2.1: an order-complete `C(K)` of arbitrarily large density, +with a closed separable sublattice whose only order-closed vector-sublattice +extension is all of `C(K)`. -/ theorem gao_counterexample (κ : Cardinal.{u}) : ∃ (K : Type u) (_ : TopologicalSpace K) (_ : CompactSpace K) (_ : T2Space K), IsOrderComplete C(K, ℝ) ∧ κ ≤ densityCharacter C(K, ℝ) ∧ diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index 76b3035bf9..0b7ed059c2 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -6,8 +6,9 @@ projects: the Gao-Leung characterization of order-continuous norms on sigma-order-complete Banach lattices, and the Solovay/Stone-space construction of order-complete C(K) spaces with arbitrarily large - density and separable order-dense sublattices. Constructs solid sets - with a prescribed infinite number kappa of solid generators whose + density and norm-closed separable sublattices whose only order-closed + vector-sublattice extension is the whole C(K) space. Constructs solid + sets with a prescribed infinite number kappa of solid generators whose adherence towers are strict below any ordinal at most kappa's successor cardinal. Constructs a complete weakly Fatou lattice norm with constant 2 that is not equivalent to any Fatou lattice norm. @@ -45,7 +46,7 @@ projects: such that C(K, R) is order complete and has density at least kappa, with a norm-closed separable vector sublattice Y whose only order-closed vector-sublattice extension is all of C(K, R). - source_ref: Paper Theorem 2.1, via the Solovay Boolean algebra. + source_ref: Paper Proposition 2.1, via the Solovay Boolean algebra. - declaration: OrderClosures.solid_sets_require_arbitrarily_many_iterations informal: >- For every infinite cardinal kappa and ordinal xi at most the