diff --git a/LeanPool.lean b/LeanPool.lean index 5d8750accd..2d0a141f03 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -281,6 +281,106 @@ public import LeanPool.AsymptoticTrianglePacking.NibbleRounding public import LeanPool.BannaiBannaiStanton public import LeanPool.BannaiBannaiStanton.BoundOnDistanceSet public import LeanPool.Basic +public import LeanPool.Besicovitch +public import LeanPool.Besicovitch.BesicovitchPairCondition.Basic +public import LeanPool.Besicovitch.BesicovitchPairCondition.Definitions +public import LeanPool.Besicovitch.BesicovitchPairCondition.Extraction +public import LeanPool.Besicovitch.BesicovitchPairCondition.PackingMeasure +public import LeanPool.Besicovitch.BesicovitchPairCondition.Parameters +public import LeanPool.Besicovitch.BesicovitchPairCondition.Rectifiability +public import LeanPool.Besicovitch.BesicovitchPairCondition.RootBalls +public import LeanPool.Besicovitch.BesicovitchPairCondition.SixPointTransfer +public import LeanPool.Besicovitch.Certificates.DensePolynomial +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.Certificates.EndpointIsolation +public import LeanPool.Besicovitch.Certificates.Krawczyk +public import LeanPool.Besicovitch.Certificates.RadicalInterval +public import LeanPool.Besicovitch.Certificates.RationalInterval +public import LeanPool.Besicovitch.Example.Avoid +public import LeanPool.Besicovitch.Example.Cover +public import LeanPool.Besicovitch.Example.Density +public import LeanPool.Besicovitch.Example.Graph +public import LeanPool.Besicovitch.Example.Hull +public import LeanPool.Besicovitch.Example.LowerBound +public import LeanPool.Besicovitch.Example.LowerDensity +public import LeanPool.Besicovitch.Example.Measurable +public import LeanPool.Besicovitch.Example.Plane +public import LeanPool.Besicovitch.Example.Recursion +public import LeanPool.Besicovitch.Example.Reduction +public import LeanPool.Besicovitch.Example.Zero +public import LeanPool.Besicovitch.Geometry.BallUnion +public import LeanPool.Besicovitch.Geometry.ConvexEnlargement +public import LeanPool.Besicovitch.Main.Bound +public import LeanPool.Besicovitch.Main.RationalBound +public import LeanPool.Besicovitch.Measure.CompactExhaustion +public import LeanPool.Besicovitch.Measure.DensityBasic +public import LeanPool.Besicovitch.Measure.DensityLocalization +public import LeanPool.Besicovitch.Measure.UniformDensity +public import LeanPool.Besicovitch.Measure.UniformDensityCompact +public import LeanPool.Besicovitch.Rectifiability.AttachmentLocalization +public import LeanPool.Besicovitch.Rectifiability.BadConvexLocalization +public import LeanPool.Besicovitch.Rectifiability.BadConvexPacking +public import LeanPool.Besicovitch.Rectifiability.BadConvexSets +public import LeanPool.Besicovitch.Rectifiability.BadConvexThickening +public import LeanPool.Besicovitch.Rectifiability.Basic +public import LeanPool.Besicovitch.Rectifiability.CompactAttachmentUnion +public import LeanPool.Besicovitch.Rectifiability.ComponentDiameter +public import LeanPool.Besicovitch.Rectifiability.Continuum +public import LeanPool.Besicovitch.Rectifiability.ContinuumSurgery +public import LeanPool.Besicovitch.Rectifiability.ConvexAttachment +public import LeanPool.Besicovitch.Rectifiability.Decomposition +public import LeanPool.Besicovitch.Rectifiability.DensityPoint +public import LeanPool.Besicovitch.Rectifiability.FiniteContinuum +public import LeanPool.Besicovitch.Rectifiability.HoleMerging +public import LeanPool.Besicovitch.Rectifiability.Selection +public import LeanPool.Besicovitch.Rectifiability.Straight +public import LeanPool.Besicovitch.Rectifiability.StraightReduction +public import LeanPool.Besicovitch.Sigma.Basic +public import LeanPool.Besicovitch.SixPoint.AlgebraicBasic +public import LeanPool.Besicovitch.SixPoint.BlueChildSwap +public import LeanPool.Besicovitch.SixPoint.CanonicalTriangle +public import LeanPool.Besicovitch.SixPoint.ChildSwapPacking +public import LeanPool.Besicovitch.SixPoint.Configuration +public import LeanPool.Besicovitch.SixPoint.EndpointFailureClosed +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry +public import LeanPool.Besicovitch.SixPoint.EndpointPacking +public import LeanPool.Besicovitch.SixPoint.EndpointWeights +public import LeanPool.Besicovitch.SixPoint.FailureTree +public import LeanPool.Besicovitch.SixPoint.FiniteProperty +public import LeanPool.Besicovitch.SixPoint.FourChildren +public import LeanPool.Besicovitch.SixPoint.GramCertificateCore +public import LeanPool.Besicovitch.SixPoint.GramCertificateCover +public import LeanPool.Besicovitch.SixPoint.GramCertificateData +public import LeanPool.Besicovitch.SixPoint.GramWeightedBound +public import LeanPool.Besicovitch.SixPoint.LensEndpointBalancedE0S0 +public import LeanPool.Besicovitch.SixPoint.MatrixCorrections +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.SixPoint.Normalization +public import LeanPool.Besicovitch.SixPoint.Packing +public import LeanPool.Besicovitch.SixPoint.PackingRelabel +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.Realization +public import LeanPool.Besicovitch.SixPoint.RootEdge +public import LeanPool.Besicovitch.SixPoint.RootEdgeClosed +public import LeanPool.Besicovitch.SixPoint.RootEdgeFailureTree +public import LeanPool.Besicovitch.SixPoint.RootEdgeType12 +public import LeanPool.Besicovitch.SixPoint.RowColumnRescue +public import LeanPool.Besicovitch.SixPoint.Scaling +public import LeanPool.Besicovitch.SixPoint.Score +public import LeanPool.Besicovitch.SixPoint.SiblingFailureTree +public import LeanPool.Besicovitch.SixPoint.SiblingIncidence +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceClosed +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger +public import LeanPool.Besicovitch.SixPoint.SiblingLens +public import LeanPool.Besicovitch.SixPoint.SiblingLensE1S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S3 +public import LeanPool.Besicovitch.SixPoint.SiblingTangent +public import LeanPool.Besicovitch.SixPoint.SiblingTriangle +public import LeanPool.Besicovitch.SixPoint.WeightedFailure +public import LeanPool.Besicovitch.SixPoint.WeightedReduction +public import LeanPool.Besicovitch.Statement +public import LeanPool.Besicovitch.Topology.ConnectedComponent public import LeanPool.Biswal public import LeanPool.Biswal.Theorem1 public import LeanPool.Biswal.Theorem23 diff --git a/LeanPool/Besicovitch.lean b/LeanPool/Besicovitch.lean new file mode 100644 index 0000000000..1ab66e0eef --- /dev/null +++ b/LeanPool/Besicovitch.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ + +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Basic +public import LeanPool.Besicovitch.BesicovitchPairCondition.Definitions +public import LeanPool.Besicovitch.BesicovitchPairCondition.Extraction +public import LeanPool.Besicovitch.BesicovitchPairCondition.PackingMeasure +public import LeanPool.Besicovitch.BesicovitchPairCondition.Parameters +public import LeanPool.Besicovitch.BesicovitchPairCondition.Rectifiability +public import LeanPool.Besicovitch.BesicovitchPairCondition.RootBalls +public import LeanPool.Besicovitch.BesicovitchPairCondition.SixPointTransfer +public import LeanPool.Besicovitch.Certificates.DensePolynomial +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.Certificates.EndpointIsolation +public import LeanPool.Besicovitch.Certificates.Krawczyk +public import LeanPool.Besicovitch.Certificates.RadicalInterval +public import LeanPool.Besicovitch.Certificates.RationalInterval +public import LeanPool.Besicovitch.Example.Avoid +public import LeanPool.Besicovitch.Example.Cover +public import LeanPool.Besicovitch.Example.Density +public import LeanPool.Besicovitch.Example.Graph +public import LeanPool.Besicovitch.Example.Hull +public import LeanPool.Besicovitch.Example.LowerBound +public import LeanPool.Besicovitch.Example.LowerDensity +public import LeanPool.Besicovitch.Example.Measurable +public import LeanPool.Besicovitch.Example.Plane +public import LeanPool.Besicovitch.Example.Recursion +public import LeanPool.Besicovitch.Example.Reduction +public import LeanPool.Besicovitch.Example.Zero +public import LeanPool.Besicovitch.Geometry.BallUnion +public import LeanPool.Besicovitch.Geometry.ConvexEnlargement +public import LeanPool.Besicovitch.Main.Bound +public import LeanPool.Besicovitch.Main.RationalBound +public import LeanPool.Besicovitch.Measure.CompactExhaustion +public import LeanPool.Besicovitch.Measure.DensityBasic +public import LeanPool.Besicovitch.Measure.DensityLocalization +public import LeanPool.Besicovitch.Measure.UniformDensity +public import LeanPool.Besicovitch.Measure.UniformDensityCompact +public import LeanPool.Besicovitch.Rectifiability.AttachmentLocalization +public import LeanPool.Besicovitch.Rectifiability.BadConvexLocalization +public import LeanPool.Besicovitch.Rectifiability.BadConvexPacking +public import LeanPool.Besicovitch.Rectifiability.BadConvexSets +public import LeanPool.Besicovitch.Rectifiability.BadConvexThickening +public import LeanPool.Besicovitch.Rectifiability.Basic +public import LeanPool.Besicovitch.Rectifiability.CompactAttachmentUnion +public import LeanPool.Besicovitch.Rectifiability.ComponentDiameter +public import LeanPool.Besicovitch.Rectifiability.Continuum +public import LeanPool.Besicovitch.Rectifiability.ContinuumSurgery +public import LeanPool.Besicovitch.Rectifiability.ConvexAttachment +public import LeanPool.Besicovitch.Rectifiability.Decomposition +public import LeanPool.Besicovitch.Rectifiability.DensityPoint +public import LeanPool.Besicovitch.Rectifiability.FiniteContinuum +public import LeanPool.Besicovitch.Rectifiability.HoleMerging +public import LeanPool.Besicovitch.Rectifiability.Selection +public import LeanPool.Besicovitch.Rectifiability.Straight +public import LeanPool.Besicovitch.Rectifiability.StraightReduction +public import LeanPool.Besicovitch.Sigma.Basic +public import LeanPool.Besicovitch.SixPoint.AlgebraicBasic +public import LeanPool.Besicovitch.SixPoint.BlueChildSwap +public import LeanPool.Besicovitch.SixPoint.CanonicalTriangle +public import LeanPool.Besicovitch.SixPoint.ChildSwapPacking +public import LeanPool.Besicovitch.SixPoint.Configuration +public import LeanPool.Besicovitch.SixPoint.EndpointFailureClosed +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry +public import LeanPool.Besicovitch.SixPoint.EndpointPacking +public import LeanPool.Besicovitch.SixPoint.EndpointWeights +public import LeanPool.Besicovitch.SixPoint.FailureTree +public import LeanPool.Besicovitch.SixPoint.FiniteProperty +public import LeanPool.Besicovitch.SixPoint.FourChildren +public import LeanPool.Besicovitch.SixPoint.GramCertificateCore +public import LeanPool.Besicovitch.SixPoint.GramCertificateCover +public import LeanPool.Besicovitch.SixPoint.GramCertificateData +public import LeanPool.Besicovitch.SixPoint.GramWeightedBound +public import LeanPool.Besicovitch.SixPoint.LensEndpointBalancedE0S0 +public import LeanPool.Besicovitch.SixPoint.Normalization +public import LeanPool.Besicovitch.SixPoint.Packing +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.Realization +public import LeanPool.Besicovitch.SixPoint.RootEdge +public import LeanPool.Besicovitch.SixPoint.RootEdgeClosed +public import LeanPool.Besicovitch.SixPoint.RootEdgeFailureTree +public import LeanPool.Besicovitch.SixPoint.RootEdgeType12 +public import LeanPool.Besicovitch.SixPoint.RowColumnRescue +public import LeanPool.Besicovitch.SixPoint.Scaling +public import LeanPool.Besicovitch.SixPoint.Score +public import LeanPool.Besicovitch.SixPoint.SiblingFailureTree +public import LeanPool.Besicovitch.SixPoint.SiblingIncidence +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceClosed +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger +public import LeanPool.Besicovitch.SixPoint.SiblingLens +public import LeanPool.Besicovitch.SixPoint.SiblingLensE1S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S3 +public import LeanPool.Besicovitch.SixPoint.SiblingTangent +public import LeanPool.Besicovitch.SixPoint.SiblingTriangle +public import LeanPool.Besicovitch.SixPoint.WeightedFailure +public import LeanPool.Besicovitch.SixPoint.WeightedReduction +public import LeanPool.Besicovitch.Statement +public import LeanPool.Besicovitch.Topology.ConnectedComponent + +/-! +# A machine-checked bound of 0.6934 for Besicovitch's 1/2-problem + +Source: url:https://github.com/CoolRmal/Besicovitchs-1-2 +Authors: Yongxi Lin +Status: verified +Main declarations: `LeanPool.Besicovitch.sigmaOne_plane_le_barS` +Tags: besicovitch-problem, measure-theory, rectifiability, finite-certificates, gram-matrices +MSC: 28A75, 28A78, 49Q15, 68V20, 90C05 +-/ diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/Basic.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/Basic.lean new file mode 100644 index 0000000000..a1fc11bf92 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/Basic.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Definitions + +/-! +# Basic facts about the Besicovitch pair condition + +This file develops the elementary set-distance API needed by the six-point transfer. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal + +namespace LeanPool.Besicovitch + +variable {X : Type*} [PseudoEMetricSpace X] {s t : Set X} + +/-- The set distance is bounded by the distance between any selected pair of points. -/ +theorem setEDist_le_edist_of_mem {x y : X} (hx : x ∈ s) (hy : y ∈ t) : + setEDist s t ≤ edist x y := by + exact iInf_le_of_le x <| iInf_le_of_le hx <| iInf_le_of_le y <| iInf_le_of_le hy le_rfl + +/-- Extended set distance is symmetric. -/ +theorem setEDist_comm (s t : Set X) : setEDist s t = setEDist t s := by + apply le_antisymm + · refine le_iInf fun y ↦ le_iInf fun hy ↦ le_iInf fun x ↦ le_iInf fun hx ↦ ?_ + simpa [edist_comm] using setEDist_le_edist_of_mem (s := s) (t := t) hx hy + · refine le_iInf fun x ↦ le_iInf fun hx ↦ le_iInf fun y ↦ le_iInf fun hy ↦ ?_ + simpa [edist_comm] using setEDist_le_edist_of_mem (s := t) (t := s) hy hx + +@[simp] +theorem setEDist_empty_left (t : Set X) : setEDist ∅ t = ∞ := by + simp [setEDist] + +/-- Two nonempty sets in a metric space have finite extended distance. -/ +theorem setEDist_ne_top {Y : Type*} [PseudoMetricSpace Y] {u v : Set Y} + (hu : u.Nonempty) (hv : v.Nonempty) : setEDist u v ≠ ∞ := by + obtain ⟨x, hx⟩ := hu + obtain ⟨y, hy⟩ := hv + exact ne_top_of_le_ne_top (edist_ne_top x y) (setEDist_le_edist_of_mem hx hy) + +/-- A positive finite set distance has a positive real value. -/ +theorem setEDist_toReal_pos {Y : Type*} [PseudoMetricSpace Y] {u v : Set Y} + (hu : u.Nonempty) (hv : v.Nonempty) (hpos : 0 < setEDist u v) : + 0 < (setEDist u v).toReal := by + exact ENNReal.toReal_pos hpos.ne' (setEDist_ne_top hu hv) + +/-- The real set distance is no larger than any distance between the two sets. -/ +theorem setEDist_toReal_le_dist {Y : Type*} [PseudoMetricSpace Y] {u v : Set Y} + (hu : u.Nonempty) (hv : v.Nonempty) {x y : Y} (hx : x ∈ u) (hy : y ∈ v) : + (setEDist u v).toReal ≤ dist x y := by + have h := setEDist_le_edist_of_mem hx hy + have hfinite := setEDist_ne_top hu hv + rw [← ENNReal.toReal_le_toReal hfinite (edist_ne_top x y)] at h + simpa [edist_dist] using h + +/-- A ball whose radius is at most the set distance misses the opposite set. -/ +theorem ball_disjoint_of_le_setEDist_toReal {Y : Type*} [PseudoMetricSpace Y] + {u v : Set Y} (hu : u.Nonempty) (hv : v.Nonempty) {x : Y} (hx : x ∈ u) + {r : ℝ} (hr : r ≤ (setEDist u v).toReal) : Disjoint (Metric.ball x r) v := by + rw [Set.disjoint_left] + intro y hy hyMem + have hlower := setEDist_toReal_le_dist hu hv hx hyMem + rw [Metric.mem_ball'] at hy + exact (not_lt_of_ge hlower) (hy.trans_le hr) + +/-- A strict upper bound on set distance is witnessed by an actual pair of points. -/ +theorem exists_edist_lt_of_setEDist_lt {r : ℝ≥0∞} (h : setEDist s t < r) : + ∃ x ∈ s, ∃ y ∈ t, edist x y < r := by + rw [setEDist, iInf_lt_iff] at h + obtain ⟨x, hx⟩ := h + rw [iInf_lt_iff] at hx + obtain ⟨hxs, hx⟩ := hx + rw [iInf_lt_iff] at hx + obtain ⟨y, hy⟩ := hx + rw [iInf_lt_iff] at hy + obtain ⟨hyt, hy⟩ := hy + exact ⟨x, hxs, y, hyt, hy⟩ + +/-- A real number above the finite set distance bounds some actual pair distance. -/ +theorem exists_dist_lt_of_setEDist_toReal_lt {Y : Type*} [PseudoMetricSpace Y] + {u v : Set Y} (hu : u.Nonempty) (hv : v.Nonempty) {r : ℝ} + (h : (setEDist u v).toReal < r) : ∃ x ∈ u, ∃ y ∈ v, dist x y < r := by + have hr : 0 < r := (ENNReal.toReal_nonneg.trans_lt h) + have hfinite := setEDist_ne_top hu hv + have hed : setEDist u v < ENNReal.ofReal r := by + rw [← ENNReal.toReal_lt_toReal hfinite (by simp)] + simpa [ENNReal.toReal_ofReal hr.le] using h + obtain ⟨x, hx, y, hy, hxy⟩ := exists_edist_lt_of_setEDist_lt hed + refine ⟨x, hx, y, hy, ?_⟩ + rw [edist_dist, ENNReal.ofReal_lt_ofReal_iff hr] at hxy + exact hxy + +/-- Raising the density parameter preserves the Besicovitch pair condition. -/ +theorem BesicovitchPairCondition.mono {β γ : ℝ} (hβγ : β ≤ γ) + (hβ : BesicovitchPairCondition β) : BesicovitchPairCondition γ := by + intro μ hμ + obtain ⟨τ, hτ, hβ⟩ := hβ μ hμ + refine ⟨τ, hτ, fun scale hscale ↦ ?_⟩ + obtain ⟨δ, hδ, hβ⟩ := hβ scale hscale + refine ⟨δ, hδ, fun e₁ e₂ he₁ he₂ he₁n he₂n hpos hlt hdensity ↦ ?_⟩ + apply hβ e₁ e₂ he₁ he₂ he₁n he₂n hpos hlt + intro x hx r hr hrscale + refine lt_of_le_of_lt (ENNReal.ofReal_le_ofReal ?_) (hdensity x hx r hr hrscale) + exact mul_le_mul_of_nonneg_right (mul_le_mul_of_nonneg_left hβγ (by norm_num)) hr.le + +/-- A straight set whose mass exceeds `a` contains two points more than `a` apart. -/ +theorem IsStraightMeasure.exists_dist_gt {μ : Measure (EuclideanSpace ℝ (Fin 2))} + (hμ : IsStraightMeasure μ) {s : Set (EuclideanSpace ℝ (Fin 2))} + (hs : MeasurableSet s) {a : ℝ} (ha : ENNReal.ofReal a < μ s) : + ∃ x ∈ s, ∃ y ∈ s, a < dist x y := by + by_contra h + have hall : ∀ x ∈ s, ∀ y ∈ s, dist x y ≤ a := by + intro x hx y hy + by_contra hxy + exact h ⟨x, hx, y, hy, lt_of_not_ge hxy⟩ + have hed : Metric.ediam s ≤ ENNReal.ofReal a := + Metric.ediam_le_of_forall_dist_le hall + exact (not_lt_of_ge hed) (ha.trans_le (hμ s hs)) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/Definitions.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/Definitions.lean new file mode 100644 index 0000000000..84627f8a64 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/Definitions.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement + +/-! +# The Besicovitch pair condition + +This file defines straight measures and the pair condition in the Euclidean plane. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal + +namespace LeanPool.Besicovitch + +/-- The extended distance between two sets; it is infinite when either set is empty. -/ +def setEDist {X : Type*} [PseudoEMetricSpace X] (s t : Set X) : ℝ≥0∞ := + ⨅ x ∈ s, ⨅ y ∈ t, edist x y + +/-- A measure is straight if every measurable set has mass at most its extended diameter. -/ +def IsStraightMeasure (μ : Measure (EuclideanSpace ℝ (Fin 2))) : Prop := + ∀ s, MeasurableSet s → μ s ≤ Metric.ediam s + +/-- The Besicovitch pair condition at density parameter `β`. -/ +def BesicovitchPairCondition (β : ℝ) : Prop := + ∀ μ : Measure (EuclideanSpace ℝ (Fin 2)), IsStraightMeasure μ → + ∃ τ : ℝ, 0 < τ ∧ ∀ scale : ℝ, 0 < scale → + ∃ δ : ℝ, 0 < δ ∧ + ∀ e₁ e₂ : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet e₁ → MeasurableSet e₂ → + e₁.Nonempty → e₂.Nonempty → 0 < setEDist e₁ e₂ → + setEDist e₁ e₂ < ENNReal.ofReal δ → + (∀ x ∈ e₁ ∪ e₂, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * β * r) < μ (Metric.ball x r)) → + ∃ v : Set (EuclideanSpace ℝ (Fin 2)), + IsOpen v ∧ (v ∩ e₁).Nonempty ∧ (v ∩ e₂).Nonempty ∧ + ENNReal.ofReal τ * Metric.ediam v < μ (v \ (e₁ ∪ e₂)) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/Extraction.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/Extraction.lean new file mode 100644 index 0000000000..360b97be12 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/Extraction.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Basic + +/-! +# Extracting separated children from density + +This file isolates the measure estimate that turns a dense root ball into two well-separated +points of the same set. The missing mass is charged to one common leakage set. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal + +namespace LeanPool.Besicovitch + +/-- After paying for a leakage set, the part of a ball in its own color retains the remaining +mass. -/ +theorem measure_inter_gt_of_ball_gt_of_leakage {X : Type*} [MeasurableSpace X] + (μ : Measure X) {e other ball ambient : Set X} {a b : ℝ} + (ha : 0 ≤ a) (hb : 0 ≤ b) (hball : ball ⊆ ambient) + (hdisjoint : Disjoint ball other) + (hdensity : ENNReal.ofReal (a + b) < μ ball) + (hleakage : μ (ambient \ (e ∪ other)) ≤ ENNReal.ofReal b) : + ENNReal.ofReal a < μ (e ∩ ball) := by + have hsubset : ball ⊆ (e ∩ ball) ∪ (ambient \ (e ∪ other)) := by + intro x hx + by_cases hxe : x ∈ e + · exact Or.inl ⟨hxe, hx⟩ + · refine Or.inr ⟨hball hx, ?_⟩ + rintro (hxe' | hxo) + · exact hxe hxe' + · exact Set.disjoint_left.1 hdisjoint hx hxo + have hmeasure : μ ball ≤ μ (e ∩ ball) + μ (ambient \ (e ∪ other)) := + (measure_mono hsubset).trans (measure_union_le _ _) + by_contra h + have hinter : μ (e ∩ ball) ≤ ENNReal.ofReal a := le_of_not_gt h + have hsum : μ (e ∩ ball) + μ (ambient \ (e ∪ other)) ≤ + ENNReal.ofReal a + ENNReal.ofReal b := add_le_add hinter hleakage + have hab : ENNReal.ofReal (a + b) = ENNReal.ofReal a + ENNReal.ofReal b := + ENNReal.ofReal_add ha hb + exact (not_lt_of_ge (hmeasure.trans (hsum.trans_eq hab.symm))) hdensity + +/-- Straightness converts enough mass in one color of a root ball into two separated children. -/ +theorem IsStraightMeasure.exists_children {μ : Measure (EuclideanSpace ℝ (Fin 2))} + (hμ : IsStraightMeasure μ) {e : Set (EuclideanSpace ℝ (Fin 2))} + (he : MeasurableSet e) {root : (EuclideanSpace ℝ (Fin 2))} {d γ : ℝ} + (hmass : ENNReal.ofReal (2 * γ * d) < μ (e ∩ Metric.ball root d)) : + ∃ left ∈ e ∩ Metric.ball root d, ∃ right ∈ e ∩ Metric.ball root d, + 2 * γ * d < dist left right := by + exact hμ.exists_dist_gt (he.inter Metric.isOpen_ball.measurableSet) hmass + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/PackingMeasure.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/PackingMeasure.lean new file mode 100644 index 0000000000..27b1f28a01 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/PackingMeasure.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Basic +public import LeanPool.Besicovitch.Geometry.BallUnion +public import LeanPool.Besicovitch.SixPoint.Configuration + +/-! +# Measure estimates for two-color ball packings + +This file bounds the mass of a finite two-color ball packing by its union and leakage. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped BigOperators ENNReal + +namespace LeanPool.Besicovitch + +/-- The union of the supported balls of one color. -/ +def colorBallUnion (support : Finset SixPointIndex) + (center : support → (EuclideanSpace ℝ (Fin 2))) + (radius : support → ℝ) (color : SixPointColor) : Set (EuclideanSpace ℝ (Fin 2)) := + ⋃ i : {i : support // i.1.1 = color}, Metric.ball (center i.1) (radius i.1) + +/-- Membership in a color ball union is witnessed by a supported index of that color. -/ +@[simp] +theorem mem_colorBallUnion {support : Finset SixPointIndex} + {center : support → (EuclideanSpace ℝ (Fin 2))} + {radius : support → ℝ} {color : SixPointColor} {x : (EuclideanSpace ℝ (Fin 2))} : + x ∈ colorBallUnion support center radius color ↔ + ∃ i : support, i.1.1 = color ∧ x ∈ Metric.ball (center i) (radius i) := by + constructor + · intro hx + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact ⟨i.1, i.2, hi⟩ + · rintro ⟨i, hcolor, hi⟩ + exact Set.mem_iUnion.mpr ⟨⟨i, hcolor⟩, hi⟩ + +/-- The full ball union is the union of its red and blue parts. -/ +theorem finiteBallUnion_eq_union_colorBallUnion (support : Finset SixPointIndex) + (center : support → (EuclideanSpace ℝ (Fin 2))) (radius : support → ℝ) : + finiteBallUnion support center radius = colorBallUnion support center radius .red ∪ + colorBallUnion support center radius .blue := by + ext x + simp only [mem_finiteBallUnion, mem_union, mem_colorBallUnion] + constructor + · rintro ⟨i, hi⟩ + cases hcolor : i.1.1 + · exact Or.inl ⟨i, hcolor, hi⟩ + · exact Or.inr ⟨i, hcolor, hi⟩ + · rintro (⟨i, _, hi⟩ | ⟨i, _, hi⟩) <;> exact ⟨i, hi⟩ + +/-- A single-color finite ball union is open. -/ +theorem isOpen_colorBallUnion (support : Finset SixPointIndex) + (center : support → (EuclideanSpace ℝ (Fin 2))) + (radius : support → ℝ) (color : SixPointColor) : + IsOpen (colorBallUnion support center radius color) := + isOpen_iUnion fun _ ↦ Metric.isOpen_ball + +/-- A single-color finite ball union is measurable. -/ +theorem measurableSet_colorBallUnion (support : Finset SixPointIndex) + (center : support → (EuclideanSpace ℝ (Fin 2))) (radius : support → ℝ) + (color : SixPointColor) : + MeasurableSet (colorBallUnion support center radius color) := + (isOpen_colorBallUnion support center radius color).measurableSet + +/-- The measure of a disjoint single-color ball union is the sum of its ball measures. -/ +theorem measure_colorBallUnion {support : Finset SixPointIndex} + (center : support → (EuclideanSpace ℝ (Fin 2))) + (radius : support → ℝ) (color : SixPointColor) (μ : Measure (EuclideanSpace ℝ (Fin 2))) + (hdisjoint : ∀ i j : support, i ≠ j → i.1.1 = j.1.1 → + Disjoint (Metric.ball (center i) (radius i)) (Metric.ball (center j) (radius j))) : + μ (colorBallUnion support center radius color) = + ∑ i : {i : support // i.1.1 = color}, μ (Metric.ball (center i.1) (radius i.1)) := by + rw [colorBallUnion, measure_iUnion] + · exact tsum_fintype _ + · intro i j hij + apply hdisjoint i.1 j.1 + · exact fun h ↦ hij (Subtype.ext h) + · exact i.2.trans j.2.symm + · exact fun _ ↦ measurableSet_ball + +/-- Red-blue ball overlap lies outside both center sets. -/ +theorem inter_colorBallUnion_subset_sdiff {support : Finset SixPointIndex} + (center : support → (EuclideanSpace ℝ (Fin 2))) (radius : support → ℝ) + (e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))) + (he : ∀ color, (e color).Nonempty) (hcenter : ∀ i, center i ∈ e i.1.1) + (hradius : ∀ i, radius i ≤ (setEDist (e .red) (e .blue)).toReal) : + colorBallUnion support center radius .red ∩ colorBallUnion support center radius .blue ⊆ + finiteBallUnion support center radius \ (e .red ∪ e .blue) := by + rintro x ⟨hxred, hxblue⟩ + obtain ⟨i, hired, hxi⟩ := mem_colorBallUnion.mp hxred + obtain ⟨j, hjblue, hxj⟩ := mem_colorBallUnion.mp hxblue + have hred : Disjoint (Metric.ball (center i) (radius i)) (e .blue) := by + apply ball_disjoint_of_le_setEDist_toReal (he .red) (he .blue) + · simpa [hired] using hcenter i + · exact hradius i + have hblue : Disjoint (Metric.ball (center j) (radius j)) (e .red) := by + apply ball_disjoint_of_le_setEDist_toReal (he .blue) (he .red) + · simpa [hjblue] using hcenter j + · rw [setEDist_comm] + exact hradius j + refine ⟨mem_finiteBallUnion.mpr ⟨i, hxi⟩, ?_⟩ + rw [mem_union, not_or] + exact ⟨hblue.notMem_of_mem_left hxj, hred.notMem_of_mem_left hxi⟩ + +/-- The total ball mass is bounded by the union mass plus the mass outside both center sets. -/ +theorem sum_measure_ball_le_union_add_leakage {support : Finset SixPointIndex} + (center : support → (EuclideanSpace ℝ (Fin 2))) (radius : support → ℝ) + (e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))) + (μ : Measure (EuclideanSpace ℝ (Fin 2))) (he : ∀ color, (e color).Nonempty) + (hcenter : ∀ i, center i ∈ e i.1.1) + (hradius : ∀ i, radius i ≤ (setEDist (e .red) (e .blue)).toReal) + (hdisjoint : ∀ i j : support, i ≠ j → i.1.1 = j.1.1 → + Disjoint (Metric.ball (center i) (radius i)) (Metric.ball (center j) (radius j))) : + (∑ i : support, μ (Metric.ball (center i) (radius i))) ≤ + μ (finiteBallUnion support center radius) + + μ (finiteBallUnion support center radius \ (e .red ∪ e .blue)) := by + have hmeasure (color : SixPointColor) := + measure_colorBallUnion center radius color μ hdisjoint + have hsum : (∑ i : support, μ (Metric.ball (center i) (radius i))) = + μ (colorBallUnion support center radius .red) + + μ (colorBallUnion support center radius .blue) := by + calc + _ = ∑ color : SixPointColor, ∑ i : {i : support // i.1.1 = color}, + μ (Metric.ball (center i.1) (radius i.1)) := + (Fintype.sum_fiberwise (fun i : support ↦ i.1.1) + (fun i ↦ μ (Metric.ball (center i) (radius i)))).symm + _ = ∑ color : SixPointColor, μ (colorBallUnion support center radius color) := by + apply Finset.sum_congr rfl + intro color _ + exact (hmeasure color).symm + _ = _ := by + rw [show (Finset.univ : Finset SixPointColor) = {.red, .blue} by + ext color + cases color <;> simp] + simp + rw [hsum, ← measure_union_add_inter _ + (measurableSet_colorBallUnion support center radius .blue)] + rw [← finiteBallUnion_eq_union_colorBallUnion] + exact add_le_add le_rfl (measure_mono <| + inter_colorBallUnion_subset_sdiff center radius e he hcenter hradius) + +/-- Density, straightness, and a leakage bound control the total supported radius. -/ +theorem density_sum_lt_one_add_leakage_mul_ediam {support : Finset SixPointIndex} + (hsupport : support.Nonempty) (center : support → (EuclideanSpace ℝ (Fin 2))) + (radius : support → ℝ) (e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))) + (μ : Measure (EuclideanSpace ℝ (Fin 2))) {β scale : ℝ} {leakage : ℝ≥0∞} + (hβ : 0 ≤ β) (he : ∀ color, (e color).Nonempty) + (hcenter : ∀ i, center i ∈ e i.1.1) (hradius_pos : ∀ i, 0 < radius i) + (hradius_lt : ∀ i, radius i < scale) + (hradius_le : ∀ i, radius i ≤ (setEDist (e .red) (e .blue)).toReal) + (hdisjoint : ∀ i j : support, i ≠ j → i.1.1 = j.1.1 → + Disjoint (Metric.ball (center i) (radius i)) (Metric.ball (center j) (radius j))) + (hdensity : ∀ x ∈ e .red ∪ e .blue, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * β * r) < μ (Metric.ball x r)) (hμ : IsStraightMeasure μ) + (hleakage : μ (finiteBallUnion support center radius \ (e .red ∪ e .blue)) ≤ + leakage * Metric.ediam (finiteBallUnion support center radius)) : + ENNReal.ofReal (2 * β * ∑ i : support, radius i) < + (1 + leakage) * Metric.ediam (finiteBallUnion support center radius) := by + have hdensity_ball (i : support) : ENNReal.ofReal (2 * β * radius i) < + μ (Metric.ball (center i) (radius i)) := by + apply hdensity (center i) + · cases hcolor : i.1.1 + · exact Or.inl (by simpa [hcolor] using hcenter i) + · exact Or.inr (by simpa [hcolor] using hcenter i) + · exact hradius_pos i + · exact hradius_lt i + have hdensity_sum : (∑ i : support, ENNReal.ofReal (2 * β * radius i)) < + ∑ i : support, μ (Metric.ball (center i) (radius i)) := by + apply ENNReal.sum_lt_sum_of_nonempty + · obtain ⟨index, hindex⟩ := hsupport + exact ⟨⟨index, hindex⟩, Finset.mem_univ _⟩ + · exact fun i _ ↦ hdensity_ball i + have hmass := sum_measure_ball_le_union_add_leakage center radius e μ he hcenter + hradius_le hdisjoint + have hupper : (∑ i : support, μ (Metric.ball (center i) (radius i))) ≤ + (1 + leakage) * Metric.ediam (finiteBallUnion support center radius) := by + calc + _ ≤ μ (finiteBallUnion support center radius) + + μ (finiteBallUnion support center radius \ (e .red ∪ e .blue)) := hmass + _ ≤ Metric.ediam (finiteBallUnion support center radius) + + leakage * Metric.ediam (finiteBallUnion support center radius) := + add_le_add (hμ _ <| measurableSet_finiteBallUnion center radius) hleakage + _ = _ := by ring + have hofReal : ENNReal.ofReal (2 * β * ∑ i : support, radius i) = + ∑ i : support, ENNReal.ofReal (2 * β * radius i) := by + rw [← ENNReal.ofReal_sum_of_nonneg] + · rw [Finset.mul_sum] + · exact fun i _ ↦ mul_nonneg (mul_nonneg (by norm_num) hβ) (hradius_pos i).le + rw [hofReal] + exact hdensity_sum.trans_le hupper + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/Parameters.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/Parameters.lean new file mode 100644 index 0000000000..945321f661 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/Parameters.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Basic.Real.Basic + +/-! +# Parameters for the six-point transfer + +The approximate-root ratio and the sibling-density parameter are chosen strictly between the +finite endpoint and the target density. +-/ + +@[expose] public section + +namespace LeanPool.Besicovitch + +/-- Between positive parameters `s < β`, choose an approximate-root ratio `q` and a sibling +parameter `γ` with `s < γq`. -/ +theorem exists_transfer_parameters {s β : ℝ} (hs : 0 < s) (hsβ : s < β) : + ∃ q γ : ℝ, 0 < q ∧ q < 1 ∧ s / β < q ∧ 0 < γ ∧ γ < β ∧ s < γ * q := by + have hβ : 0 < β := hs.trans hsβ + have hs_div_beta : 0 < s / β := div_pos hs hβ + have hs_div_beta_lt_one : s / β < 1 := (div_lt_one hβ).2 hsβ + obtain ⟨q, hsq, hq1⟩ := exists_between hs_div_beta_lt_one + have hq : 0 < q := hs_div_beta.trans hsq + have hs_lt_beta_q : s < β * q := by + simpa [mul_comm] using (div_lt_iff₀ hβ).1 hsq + have hs_div_q_lt_beta : s / q < β := (div_lt_iff₀ hq).2 <| by + simpa [mul_comm] using hs_lt_beta_q + obtain ⟨γ, hsγ, hγβ⟩ := exists_between hs_div_q_lt_beta + refine ⟨q, γ, hq, hq1, hsq, ?_, hγβ, ?_⟩ + · exact (div_pos hs hq).trans hsγ + · exact (div_lt_iff₀ hq).1 hsγ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/Rectifiability.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/Rectifiability.lean new file mode 100644 index 0000000000..0883da1ab7 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/Rectifiability.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.AttachmentLocalization +public import LeanPool.Besicovitch.Rectifiability.FiniteContinuum +public import LeanPool.Besicovitch.Rectifiability.ContinuumSurgery +public import LeanPool.Besicovitch.Rectifiability.StraightReduction +public import LeanPool.Besicovitch.Measure.UniformDensityCompact +public import LeanPool.Besicovitch.Sigma.Basic + +/-! +# The pair condition forces rectifiability + +The Besicovitch pair condition rules out a positive straight purely unrectifiable set whose lower +density is strictly above the pair-condition parameter. +-/ + +@[expose] public section + +noncomputable section + +open Bornology MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- The Besicovitch pair condition at `sigma < 1` forces rectifiability at every strictly larger +density threshold. -/ +theorem BesicovitchPairCondition.forcesOneRectifiability + {sigma gamma : ℝ} (hpairCondition : BesicovitchPairCondition sigma) + (hsigma : 0 < sigma) (hsigma_one : sigma < 1) (hsigma_gamma : sigma < gamma) : + ForcesOneRectifiability (EuclideanSpace ℝ (Fin 2)) (ENNReal.ofReal gamma) := by + intro E hE hE_finite hE_density + by_contra hE_not_rectifiable + obtain ⟨A, hA, hAE, hA_pos, hA_finite, hA_pure, hA_straight, hA_density⟩ := + exists_pure_straight_subset_of_not_rectifiable hE hE_finite hE_not_rectifiable + hsigma.le hsigma_gamma hE_density + let mu := μH[1].restrict A + let : IsFiniteMeasure mu := isFiniteMeasure_restrict.mpr hA_finite.ne + obtain ⟨tau, htau, hpair⟩ := hpairCondition mu hA_straight + let alpha := min tau (sigma / 2) + have halpha : 0 < alpha := by + simpa only [alpha, lt_min_iff] using ⟨htau, half_pos hsigma⟩ + have halpha_tau : alpha ≤ tau := min_le_left _ _ + have halpha_28 : alpha < 28 := by + calc + alpha ≤ sigma / 2 := min_le_right _ _ + _ < 1 / 2 := (div_lt_div_iff_of_pos_right (by norm_num)).2 hsigma_one + _ < 28 := by norm_num + obtain ⟨density, m, F, hsigma_density, hF_compact, hF_uniform_A, houtside_A⟩ := + exists_compact_uniformDensitySet_above hA hA_pos hA_finite.ne hsigma.le + (div_pos halpha (by norm_num : (0 : ℝ) < 15)) hA_density + have hF_measurable : MeasurableSet F := hF_compact.isClosed.measurableSet + have hFA : F ⊆ A := fun _ hx ↦ (hF_uniform_A hx).1 + have hF_uniform : F ⊆ uniformDensitySet mu F density m := by + intro x hx + exact ⟨hx, (hF_uniform_A hx).2⟩ + have hmu_F : mu F = μH[1] F := by + rw [Measure.restrict_apply hF_measurable] + congr 1 + exact inter_eq_left.mpr hFA + have hmu_compl : mu Fᶜ = μH[1] (A \ F) := by + rw [Measure.restrict_apply hF_measurable.compl] + congr 1 + ext x + simp only [mem_inter_iff, mem_compl_iff, mem_sdiff] + tauto + have houtside : mu Fᶜ < ENNReal.ofReal (alpha / 15) * mu F := by + rwa [hmu_compl, hmu_F] + obtain ⟨chosen, hchosen, hdisjoint, hcountable, hselect⟩ := + exists_countable_disjoint_badConvexSets (mu := mu) F halpha + have hsum_lt : + (∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) < + ENNReal.ofReal (1 / 15 : ℝ) * mu F := + tsum_ediam_badConvexSets_lt hF_measurable halpha (by norm_num) hchosen + hcountable hdisjoint houtside + have hsum : (∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) ≠ ∞ := + ne_top_of_lt hsum_lt + let lossRate := sigma * alpha / 28 + have hlossRate : 0 < lossRate := by + dsimp only [lossRate] + positivity + obtain ⟨z, hzF, hzHoles, densityScale, hdensityScale, hloss⟩ := + exists_densityPoint_not_mem_sevenDiameterThickening hA_straight hF_measurable + halpha hchosen hcountable hdisjoint houtside hlossRate + have huniformScale : 0 < 1 / (m + 1 : ℝ) := by positivity + obtain ⟨delta, hdelta, hpair⟩ := hpair (1 / (m + 1 : ℝ)) huniformScale + let bound := min delta (min (1 / (m + 1 : ℝ)) (densityScale / 2)) + let rho := bound / 2 + have hbound : 0 < bound := by + dsimp only [bound] + simp only [lt_min_iff] + exact ⟨hdelta, huniformScale, half_pos hdensityScale⟩ + have hrho : 0 < rho := half_pos hbound + have hrho_bound : rho < bound := by + dsimp only [rho] + linarith + have hrho_delta : rho < delta := hrho_bound.trans_le (min_le_left _ _) + have hrho_uniform : rho < 1 / (m + 1 : ℝ) := + hrho_bound.trans_le <| (min_le_right _ _).trans (min_le_left _ _) + have htwo_rho_densityScale : 2 * rho < densityScale := by + have : rho < densityScale / 2 := + hrho_bound.trans_le <| (min_le_right _ _).trans (min_le_right _ _) + linarith + have hball : ENNReal.ofReal (2 * sigma * rho) < mu (Metric.ball z rho) := + uniformDensitySet_ball_measure_gt hsigma.le hsigma_density (hF_uniform hzF) + hrho hrho_uniform + have hloss_rho : + mu (Metric.ball z rho \ F) < ENNReal.ofReal (sigma * alpha / 28 * rho) := by + have hrho_densityScale : rho < densityScale := by + have : rho < densityScale / 2 := + hrho_bound.trans_le <| (min_le_right _ _).trans (min_le_right _ _) + linarith + simpa only [lossRate] using hloss rho hrho hrho_densityScale + have hannulus := annulus_inter_nonempty hA_straight hsigma halpha halpha_28 hrho + hball hloss_rho + let C := localAttachmentComponent F chosen z rho + have hCdiam_real : sigma * rho / 2 ≤ Metric.diam C := + sigma_mul_radius_div_two_le_diam_localAttachmentComponent hF_compact halpha + halpha_tau hsigma.le hsigma_one hsigma_density hF_uniform hchosen hselect hsum hzF + hrho hrho_delta hannulus hpair + let Q := compactAttachmentUnion F chosen + have hQ_compact : IsCompact Q := + isCompact_compactAttachmentUnion hF_compact halpha hchosen hsum + have hC_compact : IsCompact C := by + exact isCompact_connectedComponentIn + (hQ_compact.inter_right Metric.isClosed_closedBall) z + have hC_subset_ball : C ⊆ Metric.closedBall z rho := + (connectedComponentIn_subset _ _).trans inter_subset_right + have hCdiam : ENNReal.ofReal (sigma * rho / 2) ≤ Metric.ediam C := by + calc + ENNReal.ofReal (sigma * rho / 2) ≤ ENNReal.ofReal (Metric.diam C) := + ENNReal.ofReal_le_ofReal hCdiam_real + _ = Metric.ediam C := by + rw [Metric.diam, ENNReal.ofReal_toReal hC_compact.isBounded.ediam_ne_top] + have hloss_two_rho : + mu (Metric.ball z (2 * rho) \ F) < + ENNReal.ofReal alpha * ENNReal.ofReal (sigma * rho / 14) := by + have h := hloss (2 * rho) (by positivity) htwo_rho_densityScale + calc + mu (Metric.ball z (2 * rho) \ F) < + ENNReal.ofReal (lossRate * (2 * rho)) := h + _ = ENNReal.ofReal alpha * ENNReal.ofReal (sigma * rho / 14) := by + rw [← ENNReal.ofReal_mul halpha.le] + congr 1 + dsimp only [lossRate] + ring + have hlocalSum : + ∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))) < + Metric.ediam C := + tsum_ediam_touchingBadConvexSets_lt_ediam hF_measurable halpha hsigma hchosen + hcountable hdisjoint hrho hzHoles hC_subset_ball hloss_two_rho hCdiam + have hzQ : z ∈ Q := Or.inl hzF + have hzlocal : z ∈ Q ∩ Metric.closedBall z rho := + ⟨hzQ, Metric.mem_closedBall_self hrho.le⟩ + have hC_connected : IsConnected C := by + simpa only [C, localAttachmentComponent, Q] using + (isConnected_connectedComponentIn_iff.mpr hzlocal) + obtain ⟨x, hxC, y, hyC, hxy⟩ := + hC_compact.exists_edist_eq_ediam hC_connected.nonempty + have htouching_countable : (touchingBadConvexSets 3 chosen C).Countable := + hcountable.mono fun _ hV ↦ hV.1 + let : Countable (touchingBadConvexSets 3 chosen C) := + htouching_countable.to_subtype + obtain ⟨D, hD_compact, hD_connected, _, _, hD_ediam, _, hD_charged, _, hD_measure⟩ := + exists_continuum_surgery_open_holes hC_compact hC_connected hxC hyC hxy + (fun V : touchingBadConvexSets 3 chosen C ↦ + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))) + (fun V ↦ isOpen_diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))) hlocalSum + have hC_subset_Q : C ⊆ Q := by + simpa only [C, localAttachmentComponent, Q] using + ((connectedComponentIn_subset + (compactAttachmentUnion F chosen ∩ Metric.closedBall z rho) z).trans + inter_subset_left) + have hcore_subset_F : + C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))) ⊆ F := + sdiff_iUnion_touchingBadConvexSets_subset_core halpha hchosen hC_subset_Q + have hF_finite : μH[1] F ≠ ∞ := + ne_top_of_le_ne_top hA_finite.ne (measure_mono hFA) + have hcore_finite : + μH[1] (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))) ≠ ∞ := + ne_top_of_le_ne_top hF_finite (measure_mono hcore_subset_F) + have hD_finite : μH[1] D ≠ ∞ := by + apply ne_top_of_le_ne_top _ hD_measure + exact ENNReal.add_ne_top.mpr + ⟨hcore_finite, hC_compact.isBounded.ediam_ne_top⟩ + have hD_rectifiable : IsCountablyOneRectifiable D := + LeanPool.Besicovitch.IsConnected.isCountablyOneRectifiable_of_isCompact + hD_connected hD_compact hD_finite + have hcore_null : + μH[1] (D ∩ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) = 0 := by + apply measure_mono_null _ (hA_pure D hD_rectifiable) + rintro q ⟨hqD, hqcore⟩ + exact ⟨hFA (hcore_subset_F hqcore), hqD⟩ + have hD_measure_lt : μH[1] D < Metric.ediam C := by + calc + μH[1] D = μH[1] + ((D ∩ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) ∪ + (D \ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))))) := by + rw [inter_union_sdiff] + _ ≤ μH[1] (D ∩ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) + + μH[1] (D \ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) := measure_union_le _ _ + _ = μH[1] (D \ (C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) := by + rw [hcore_null, zero_add] + _ < Metric.ediam C := hD_charged + have hD_lower : Metric.ediam C ≤ μH[1] D := by + rw [← hD_ediam] + exact ediam_le_hausdorffMeasure_one_of_isPreconnected hD_connected.isPreconnected + exact (not_lt_of_ge hD_lower) hD_measure_lt + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/RootBalls.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/RootBalls.lean new file mode 100644 index 0000000000..77c3240a39 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/RootBalls.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement + +/-! +# The common pair of root balls + +The direct pair-condition transfer charges both child extractions to one union of root balls. +-/ + +@[expose] public section + +namespace LeanPool.Besicovitch + +/-- The common open neighborhood formed by two balls of the same radius. -/ +def rootBallUnion (x y : (EuclideanSpace ℝ (Fin 2))) (r : ℝ) : + Set (EuclideanSpace ℝ (Fin 2)) := + Metric.ball x r ∪ Metric.ball y r + +/-- The common root-ball union is open. -/ +theorem isOpen_rootBallUnion (x y : (EuclideanSpace ℝ (Fin 2))) (r : ℝ) : + IsOpen (rootBallUnion x y r) := + Metric.isOpen_ball.union Metric.isOpen_ball + +/-- The diameter of the common root-ball union is bounded by root distance plus two radii. -/ +theorem ediam_rootBallUnion_le (x y : (EuclideanSpace ℝ (Fin 2))) (r : ℝ) : + Metric.ediam (rootBallUnion x y r) ≤ ENNReal.ofReal (dist x y + 2 * r) := by + apply Metric.ediam_le_of_forall_dist_le + intro a ha b hb + rcases ha with ha | ha <;> rcases hb with hb | hb + · have hab : dist a b < 2 * r := by + calc + dist a b ≤ dist a x + dist x b := dist_triangle _ _ _ + _ < r + r := add_lt_add (Metric.mem_ball.mp ha) (Metric.mem_ball'.mp hb) + _ = 2 * r := by ring + exact hab.le.trans (le_add_of_nonneg_left dist_nonneg) + · have hab : dist a b < dist x y + 2 * r := by + calc + dist a b ≤ dist a x + dist x y + dist y b := dist_triangle4 _ _ _ _ + _ < r + dist x y + r := by + gcongr + · exact Metric.mem_ball.mp ha + · exact Metric.mem_ball'.mp hb + _ = dist x y + 2 * r := by ring + exact hab.le + · have hab : dist a b < dist x y + 2 * r := by + rw [dist_comm] + calc + dist b a ≤ dist b x + dist x y + dist y a := dist_triangle4 _ _ _ _ + _ < r + dist x y + r := by + gcongr + · exact Metric.mem_ball.mp hb + · exact Metric.mem_ball'.mp ha + _ = dist x y + 2 * r := by ring + exact hab.le + · have hab : dist a b < 2 * r := by + calc + dist a b ≤ dist a y + dist y b := dist_triangle _ _ _ + _ < r + r := add_lt_add (Metric.mem_ball.mp ha) (Metric.mem_ball'.mp hb) + _ = 2 * r := by ring + exact hab.le.trans (le_add_of_nonneg_left dist_nonneg) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/BesicovitchPairCondition/SixPointTransfer.lean b/LeanPool/Besicovitch/BesicovitchPairCondition/SixPointTransfer.lean new file mode 100644 index 0000000000..c10b5886e6 --- /dev/null +++ b/LeanPool/Besicovitch/BesicovitchPairCondition/SixPointTransfer.lean @@ -0,0 +1,544 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Extraction +public import LeanPool.Besicovitch.BesicovitchPairCondition.PackingMeasure +public import LeanPool.Besicovitch.BesicovitchPairCondition.Parameters +public import LeanPool.Besicovitch.BesicovitchPairCondition.RootBalls +public import LeanPool.Besicovitch.SixPoint.FiniteProperty +public import LeanPool.Besicovitch.SixPoint.Normalization +public import LeanPool.Besicovitch.SixPoint.Realization +public import LeanPool.Besicovitch.SixPoint.Scaling + +/-! +# From the six-point property to the Besicovitch pair condition + +This file turns a finite two-color packing theorem into the Besicovitch pair condition. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped BigOperators ENNReal + +namespace LeanPool.Besicovitch + +private theorem SixPointConfiguration.dist_root_le_one {configuration : SixPointConfiguration} + {s : ℝ} (h : configuration.IsAdmissibleAt s) (color : SixPointColor) + (label : SixPointLabel) : + dist (configuration color .root) (configuration color label) ≤ 1 := by + cases label + · simp + · exact h.child_distance color .left (by simp) + · exact h.child_distance color .right (by simp) + +private theorem SixPointConfiguration.dist_roots_le_one + {configuration : SixPointConfiguration} {s : ℝ} (h : configuration.IsAdmissibleAt s) + (color₁ color₂ : SixPointColor) : + dist (configuration color₁ .root) (configuration color₂ .root) ≤ 1 := by + cases color₁ <;> cases color₂ + · simp + · exact h.root_distance.le + · simpa [dist_comm] using h.root_distance.le + · simp + +private theorem SixPointConfiguration.dist_le_three + {configuration : SixPointConfiguration} {s : ℝ} (h : configuration.IsAdmissibleAt s) + (color₁ color₂ : SixPointColor) (label₁ label₂ : SixPointLabel) : + dist (configuration color₁ label₁) (configuration color₂ label₂) ≤ 3 := by + calc + _ ≤ dist (configuration color₁ label₁) (configuration color₁ .root) + + dist (configuration color₁ .root) (configuration color₂ .root) + + dist (configuration color₂ .root) (configuration color₂ label₂) := + dist_triangle4 _ _ _ _ + _ ≤ 1 + 1 + 1 := by + gcongr + · simpa [dist_comm] using + SixPointConfiguration.dist_root_le_one h color₁ label₁ + · exact SixPointConfiguration.dist_roots_le_one h color₁ color₂ + · exact SixPointConfiguration.dist_root_le_one h color₂ label₂ + _ = 3 := by norm_num + +private theorem SixPointPacking.virtualDiameter_le_five + {configuration : SixPointConfiguration} {s : ℝ} (packing : SixPointPacking configuration) + (h : configuration.IsAdmissibleAt s) : packing.virtualDiameter ≤ 5 := by + unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + calc + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ 3 + 1 + 1 := by + gcongr + · exact SixPointConfiguration.dist_le_three h i.1.1 j.1.1 i.1.2 j.1.2 + · exact (packing.radius i).property.2 + · exact (packing.radius j).property.2 + _ = 5 := by norm_num + +private theorem root_leakage_real_bound {beta gamma q d length tau : ℝ} (hq : 0 < q) + (hq_one : q < 1) (hgamma : gamma < beta) (hd : 0 < d) (hd_length : d ≤ length) + (hlength : length < d / q) (htau_le : tau ≤ (beta - gamma) * q / 4) : + tau * (length + 2 * d) ≤ 2 * (beta - gamma) * d := by + have hgap : 0 < beta - gamma := sub_pos.mpr hgamma + have hlength_pos : 0 < length := hd.trans_le hd_length + have hq_length : q * length < d := by + nlinarith [(lt_div_iff₀ hq).1 hlength] + have htau_length : tau * length ≤ ((beta - gamma) * q / 4) * length := + mul_le_mul_of_nonneg_right htau_le hlength_pos.le + have hscaled_length : ((beta - gamma) * q / 4) * length < + (beta - gamma) * d / 4 := by + nlinarith [mul_lt_mul_of_pos_left hq_length hgap] + have htau_gap : tau < (beta - gamma) / 4 := by + calc + tau ≤ (beta - gamma) * q / 4 := htau_le + _ < (beta - gamma) / 4 := by nlinarith [mul_lt_mul_of_pos_left hq_one hgap] + have htau_d : tau * d < (beta - gamma) * d / 4 := + lt_of_lt_of_eq (mul_lt_mul_of_pos_right htau_gap hd) (by ring) + nlinarith + +private theorem measure_rootBallUnion_sdiff_le + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {outside : Set (EuclideanSpace ℝ (Fin 2))} + {x y : (EuclideanSpace ℝ (Fin 2))} {beta gamma q d length tau : ℝ} + (hq : 0 < q) (hq_one : q < 1) + (hgamma : gamma < beta) (hd : 0 < d) (hd_length : d ≤ length) + (hlength_eq : dist x y = length) (hlength : length < d / q) + (htau : 0 < tau) (htau_le : tau ≤ (beta - gamma) * q / 4) + (hnot : ¬ENNReal.ofReal tau * Metric.ediam (rootBallUnion x y d) < + mu (rootBallUnion x y d \ outside)) : + mu (rootBallUnion x y d \ outside) ≤ ENNReal.ofReal (2 * (beta - gamma) * d) := by + calc + _ ≤ ENNReal.ofReal tau * Metric.ediam (rootBallUnion x y d) := le_of_not_gt hnot + _ ≤ ENNReal.ofReal tau * ENNReal.ofReal (length + 2 * d) := by + gcongr + simpa only [hlength_eq] using ediam_rootBallUnion_le x y d + _ = ENNReal.ofReal (tau * (length + 2 * d)) := by rw [ENNReal.ofReal_mul htau.le] + _ ≤ _ := ENNReal.ofReal_le_ofReal <| + root_leakage_real_bound hq hq_one hgamma hd hd_length hlength htau_le + +private theorem exists_approximate_roots {e₁ e₂ : Set (EuclideanSpace ℝ (Fin 2))} {d q : ℝ} + (he₁ : e₁.Nonempty) (he₂ : e₂.Nonempty) (hd : 0 < d) (hq : 0 < q) + (hq_one : q < 1) (hd_set : d = (setEDist e₁ e₂).toReal) : + ∃ x ∈ e₁, ∃ y ∈ e₂, d ≤ dist x y ∧ dist x y < d / q := by + have hd_div : (setEDist e₁ e₂).toReal < d / q := by + rw [← hd_set] + apply (lt_div_iff₀ hq).2 + nlinarith + obtain ⟨x, hx, y, hy, hxy⟩ := exists_dist_lt_of_setEDist_toReal_lt he₁ he₂ hd_div + exact ⟨x, hx, y, hy, hd_set.trans_le (setEDist_toReal_le_dist he₁ he₂ hx hy), hxy⟩ + +private theorem score_gap_lt {total diameter beta margin : ℝ} (hbeta : 0 < beta) + (hscore : margin < total - diameter / (2 * beta)) : + diameter + 2 * beta * margin < 2 * beta * total := by + have hmul := mul_lt_mul_of_pos_left hscore (show 0 < 2 * beta by positivity) + field_simp at hmul + nlinarith + +private theorem leakage_factor_lt_of_score {total diameter beta margin tau : ℝ} + (hbeta : 0 < beta) (htau : 0 ≤ tau) (htau_le : tau ≤ beta * margin / 10) + (hdiameter : diameter ≤ 5) + (hscore : margin < total - diameter / (2 * beta)) : + (1 + tau) * diameter < 2 * beta * total := by + have htau_diameter : tau * diameter ≤ tau * 5 := + mul_le_mul_of_nonneg_left hdiameter htau + have htau_five : tau * 5 ≤ beta * margin / 2 := by nlinarith + have hgap := score_gap_lt hbeta hscore + nlinarith + +private theorem configuration_of_children {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + (root : SixPointColor → (EuclideanSpace ℝ (Fin 2))) {d gamma : ℝ} + {redLeft redRight blueLeft blueRight : (EuclideanSpace ℝ (Fin 2))} + (hroot : ∀ color, root color ∈ e color) + (hredLeft : redLeft ∈ e .red ∩ Metric.ball (root .red) d) + (hredRight : redRight ∈ e .red ∩ Metric.ball (root .red) d) + (hblueLeft : blueLeft ∈ e .blue ∩ Metric.ball (root .blue) d) + (hblueRight : blueRight ∈ e .blue ∩ Metric.ball (root .blue) d) + (hredSibling : 2 * gamma * d < dist redLeft redRight) + (hblueSibling : 2 * gamma * d < dist blueLeft blueRight) : + ∃ configuration : SixPointConfiguration, + configuration .red .root = root .red ∧ configuration .blue .root = root .blue ∧ + (∀ color label, configuration color label ∈ e color) ∧ + (∀ color label, label ≠ .root → + dist (configuration color .root) (configuration color label) ≤ d) ∧ + ∀ color, 2 * gamma * d < + dist (configuration color .left) (configuration color .right) := by + let configuration := SixPointConfiguration.ofPoints (root .red) redLeft redRight + (root .blue) blueLeft blueRight + refine ⟨configuration, rfl, rfl, ?_, ?_, ?_⟩ + · intro color label + cases color <;> cases label <;> simp_all [configuration, SixPointConfiguration.ofPoints] + · intro color label hlabel + cases color <;> cases label + · exact (hlabel rfl).elim + · simpa [configuration, SixPointConfiguration.ofPoints, dist_comm] using + (Metric.mem_ball.mp hredLeft.2).le + · simpa [configuration, SixPointConfiguration.ofPoints, dist_comm] using + (Metric.mem_ball.mp hredRight.2).le + · exact (hlabel rfl).elim + · simpa [configuration, SixPointConfiguration.ofPoints, dist_comm] using + (Metric.mem_ball.mp hblueLeft.2).le + · simpa [configuration, SixPointConfiguration.ofPoints, dist_comm] using + (Metric.mem_ball.mp hblueRight.2).le + · intro color + cases color + · exact hredSibling + · exact hblueSibling + +private theorem exists_physical_configuration + {mu : Measure (EuclideanSpace ℝ (Fin 2))} (hmu : IsStraightMeasure mu) + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + (hmeasurable : ∀ color, MeasurableSet (e color)) + (hnonempty : ∀ color, (e color).Nonempty) {beta gamma d : ℝ} (hd : 0 < d) + (hgamma_pos : 0 < gamma) (hgamma : gamma < beta) + (hdistance : d = (setEDist (e .red) (e .blue)).toReal) + (root : SixPointColor → (EuclideanSpace ℝ (Fin 2))) + (hroot : ∀ color, root color ∈ e color) + (hdensity : ∀ color, + ENNReal.ofReal (2 * beta * d) < mu (Metric.ball (root color) d)) + (hleakage : mu (rootBallUnion (root .red) (root .blue) d \ (e .red ∪ e .blue)) ≤ + ENNReal.ofReal (2 * (beta - gamma) * d)) : + ∃ configuration : SixPointConfiguration, + configuration .red .root = root .red ∧ configuration .blue .root = root .blue ∧ + (∀ color label, configuration color label ∈ e color) ∧ + (∀ color label, label ≠ .root → + dist (configuration color .root) (configuration color label) ≤ d) ∧ + ∀ color, 2 * gamma * d < + dist (configuration color .left) (configuration color .right) := by + have ha : 0 ≤ 2 * gamma * d := by positivity + have hb : 0 ≤ 2 * (beta - gamma) * d := by positivity + have red_disjoint : Disjoint (Metric.ball (root .red) d) (e .blue) := by + apply ball_disjoint_of_le_setEDist_toReal (hnonempty .red) (hnonempty .blue) (hroot .red) + rw [← hdistance] + have blue_disjoint : Disjoint (Metric.ball (root .blue) d) (e .red) := by + apply ball_disjoint_of_le_setEDist_toReal (hnonempty .blue) (hnonempty .red) (hroot .blue) + rw [setEDist_comm, ← hdistance] + have red_mass : ENNReal.ofReal (2 * gamma * d) < + mu (e .red ∩ Metric.ball (root .red) d) := by + apply measure_inter_gt_of_ball_gt_of_leakage mu (e := e .red) (other := e .blue) + (ball := Metric.ball (root .red) d) + (ambient := rootBallUnion (root .red) (root .blue) d) ha hb subset_union_left red_disjoint + · simpa only [show 2 * gamma * d + 2 * (beta - gamma) * d = 2 * beta * d by ring] + using hdensity .red + · exact hleakage + have blue_mass : ENNReal.ofReal (2 * gamma * d) < + mu (e .blue ∩ Metric.ball (root .blue) d) := by + apply measure_inter_gt_of_ball_gt_of_leakage mu (e := e .blue) (other := e .red) + (ball := Metric.ball (root .blue) d) + (ambient := rootBallUnion (root .red) (root .blue) d) ha hb subset_union_right blue_disjoint + · simpa only [show 2 * gamma * d + 2 * (beta - gamma) * d = 2 * beta * d by ring] + using hdensity .blue + · simpa [union_comm] using hleakage + obtain ⟨redLeft, hredLeft, redRight, hredRight, hredSibling⟩ := + hmu.exists_children (hmeasurable .red) red_mass + obtain ⟨blueLeft, hblueLeft, blueRight, hblueRight, hblueSibling⟩ := + hmu.exists_children (hmeasurable .blue) blue_mass + exact configuration_of_children root hroot hredLeft hredRight hblueLeft hblueRight + hredSibling hblueSibling + +private theorem exists_uniform_positive_packing {configuration : SixPointConfiguration} + {s beta q₀ q : ℝ} (hfinite : SixPointFiniteProperty s) (hs : 0 < s) + (hbeta : 0 < beta) (hq₀ : 0 < q₀) (hq₀q : q₀ < q) (hq_one : q ≤ 1) + (hgain₀ : s < beta * q₀) + (hadmissible : configuration.IsAdmissibleAt s) + (hcross : ∀ redLabel blueLabel, + q₀ ≤ dist (configuration .red redLabel) (configuration .blue blueLabel)) : + ∃ packing : SixPointPacking configuration, packing.HasPositiveRadii ∧ + (∀ i : packing.support, (packing.radius i : ℝ) ≤ q) ∧ + q₀ * (beta * q₀ - s) / (4 * s * beta) < packing.score beta := by + obtain ⟨packing, hscore⟩ := hfinite configuration hadmissible + have hlower : q₀ ≤ packing.virtualDiameter := + packing.crossColor_le_virtualDiameter fun redLabel blueLabel _ _ ↦ + hcross redLabel blueLabel + have hq : 0 < q := hq₀.trans hq₀q + let scaled := packing.scaleRadii q hq.le hq_one + have hcap : ∀ i : scaled.support, (scaled.radius i : ℝ) ≤ q := by + intro i + dsimp only [scaled, SixPointPacking.scaleRadii] + exact mul_le_of_le_one_right hq.le (packing.radius i).property.2 + have hscore_scaled : q₀ * (beta * q₀ - s) / (4 * s * beta) < + scaled.score beta := by + apply lt_of_lt_of_le ?_ + (packing.scaleRadii_score_ge hs hbeta hq.le hq_one (by nlinarith) hscore hlower) + have hden : 0 < 4 * s * beta := by positivity + have hqq := mul_lt_mul_of_pos_left hq₀q hbeta + apply (div_lt_iff₀ hden).2 + field_simp + nlinarith [mul_pos hq₀ hden] + exact scaled.exists_positiveRadii_score_gt hbeta hq hq_one hcap hscore_scaled + +private theorem normalized_admissible_and_cross {physical : SixPointConfiguration} + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + {s q₀ gamma d length q : ℝ} {origin : (EuclideanSpace ℝ (Fin 2))} + (hlength : 0 < length) (hq_eq : q = d / length) (hq₀q : q₀ < q) (hq_one : q ≤ 1) + (hgamma : 0 < gamma) (hs_gamma : s < gamma * q₀) + (hroot : dist (physical .red .root) (physical .blue .root) = length) + (hchild : ∀ color label, label ≠ .root → + dist (physical color .root) (physical color label) ≤ d) + (hsibling : ∀ color, + 2 * gamma * d < dist (physical color .left) (physical color .right)) + (hnonempty : ∀ color, (e color).Nonempty) + (hcenter : ∀ color label, physical color label ∈ e color) + (hd_set : d = (setEDist (e .red) (e .blue)).toReal) : + (physical.normalize origin length).IsAdmissibleAt s ∧ + ∀ redLabel blueLabel, q₀ ≤ + dist (physical.normalize origin length .red redLabel) + (physical.normalize origin length .blue blueLabel) := by + have hs_gamma_q : s ≤ gamma * q := by + have hscaled := mul_lt_mul_of_pos_left hq₀q hgamma + exact (hs_gamma.trans hscaled).le + constructor + · exact physical.isAdmissibleAt_normalize_of_distances origin hlength hroot hchild hsibling + hq_eq hq_one hs_gamma_q + · intro redLabel blueLabel + rw [physical.dist_normalize origin hlength] + apply hq₀q.le.trans + rw [hq_eq] + apply div_le_div_of_nonneg_right _ hlength.le + exact hd_set.trans_le <| setEDist_toReal_le_dist (hnonempty .red) (hnonempty .blue) + (hcenter .red redLabel) (hcenter .blue blueLabel) + +private theorem SixPointPacking.ballUnionAt_inter_nonempty + {normalized physical : SixPointConfiguration} (packing : SixPointPacking normalized) + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} {length : ℝ} (hlength : 0 < length) + (hpositive : packing.HasPositiveRadii) + (hcenter : ∀ color label, physical color label ∈ e color) (color : SixPointColor) : + (packing.ballUnionAt physical length ∩ e color).Nonempty := by + obtain ⟨label, hlabel⟩ := packing.meets_color color + let i : packing.support := ⟨(color, label), hlabel⟩ + refine ⟨physical color label, ?_, hcenter color label⟩ + exact mem_finiteBallUnion.mpr ⟨i, Metric.mem_ball_self (mul_pos hlength (hpositive i))⟩ + +private theorem packing_leakage_gt {normalized physical : SixPointConfiguration} + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {s beta tau margin length d scale : ℝ} + (hadmissible : normalized.IsAdmissibleAt s) (hmu : IsStraightMeasure mu) + (hbeta : 0 < beta) (htau : 0 < tau) (htau_le : tau ≤ beta * margin / 10) + (hlength : 0 < length) (hd_scale : d < scale) + (hd_set : d = (setEDist (e .red) (e .blue)).toReal) + (hnonempty : ∀ color, (e color).Nonempty) + (hcenter : ∀ color label, physical color label ∈ e color) + (hdistance : ∀ i j : SixPointIndex, + dist (physical i.1 i.2) (physical j.1 j.2) = + length * dist (normalized i.1 i.2) (normalized j.1 j.2)) + (hdensity : ∀ x ∈ e .red ∪ e .blue, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * beta * r) < mu (Metric.ball x r)) + (packing : SixPointPacking normalized) (hpositive : packing.HasPositiveRadii) + (hradius : ∀ i : packing.support, length * (packing.radius i : ℝ) ≤ d) + (hscore : margin < packing.score beta) : + ENNReal.ofReal tau * Metric.ediam (packing.ballUnionAt physical length) < + mu (packing.ballUnionAt physical length \ (e .red ∪ e .blue)) := by + by_contra hleakage + have hmeasure := density_sum_lt_one_add_leakage_mul_ediam packing.support_nonempty + (fun i ↦ physical i.1.1 i.1.2) (fun i ↦ length * (packing.radius i : ℝ)) e mu hbeta.le + hnonempty (fun i ↦ hcenter i.1.1 i.1.2) (fun i ↦ mul_pos hlength (hpositive i)) + (fun i ↦ (hradius i).trans_lt hd_scale) (fun i ↦ (hradius i).trans_eq hd_set) + (fun i j hij hcolor ↦ packing.disjoint_ballAt physical hlength.le + (fun i j ↦ hdistance i j) i j hij hcolor) hdensity hmu (le_of_not_gt hleakage) + have hsum : (∑ i : packing.support, length * (packing.radius i : ℝ)) = + length * packing.totalRadius := by + simpa using packing.sum_radiusAt length + change ENNReal.ofReal + (2 * beta * ∑ i : packing.support, length * (packing.radius i : ℝ)) < + (1 + ENNReal.ofReal tau) * Metric.ediam (packing.ballUnionAt physical length) at hmeasure + rw [hsum] at hmeasure + have hed := packing.ediam_ballUnionAt_le physical hlength.le fun i j ↦ hdistance i j + have hmeasure' : ENNReal.ofReal (2 * beta * (length * packing.totalRadius)) < + ENNReal.ofReal ((1 + tau) * (length * packing.virtualDiameter)) := by + calc + _ < (1 + ENNReal.ofReal tau) * Metric.ediam + (packing.ballUnionAt physical length) := hmeasure + _ ≤ (1 + ENNReal.ofReal tau) * + ENNReal.ofReal (length * packing.virtualDiameter) := by gcongr + _ = _ := by + rw [ENNReal.ofReal_mul (by positivity : 0 ≤ 1 + tau), + ENNReal.ofReal_add zero_le_one htau.le] + simp + have hreal_measure : 2 * beta * (length * packing.totalRadius) < + (1 + tau) * (length * packing.virtualDiameter) := by + have hlhs : 0 ≤ 2 * beta * (length * packing.totalRadius) := by + positivity [packing.totalRadius_nonneg] + rw [ENNReal.ofReal_lt_ofReal_iff_of_nonneg hlhs] at hmeasure' + exact hmeasure' + have hfactor := leakage_factor_lt_of_score hbeta htau.le htau_le + (packing.virtualDiameter_le_five hadmissible) hscore + have hreal_score : (1 + tau) * (length * packing.virtualDiameter) < + 2 * beta * (length * packing.totalRadius) := by + have hscaled := mul_lt_mul_of_pos_left hfactor hlength + nlinarith + exact (not_lt_of_ge hreal_measure.le) hreal_score + +private theorem exists_packing_neighborhood {normalized physical : SixPointConfiguration} + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {s beta q₀ q tau length d scale : ℝ} (hfinite : SixPointFiniteProperty s) + (hs : 0 < s) (hbeta : 0 < beta) (hq₀ : 0 < q₀) (hq₀q : q₀ < q) (hq_one : q ≤ 1) + (hgain₀ : s < beta * q₀) (htau : 0 < tau) + (htau_score : tau ≤ beta * (q₀ * (beta * q₀ - s) / (4 * s * beta)) / 10) + (hlength : 0 < length) (hq_eq : q = d / length) (hd_scale : d < scale) + (hd_set : d = (setEDist (e .red) (e .blue)).toReal) + (hadmissible : normalized.IsAdmissibleAt s) + (hcross : ∀ redLabel blueLabel, + q₀ ≤ dist (normalized .red redLabel) (normalized .blue blueLabel)) + (hmu : IsStraightMeasure mu) (hnonempty : ∀ color, (e color).Nonempty) + (hcenter : ∀ color label, physical color label ∈ e color) + (hdistance : ∀ i j : SixPointIndex, + dist (physical i.1 i.2) (physical j.1 j.2) = + length * dist (normalized i.1 i.2) (normalized j.1 j.2)) + (hdensity : ∀ x ∈ e .red ∪ e .blue, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * beta * r) < mu (Metric.ball x r)) : + ∃ v : Set (EuclideanSpace ℝ (Fin 2)), IsOpen v ∧ + (v ∩ e .red).Nonempty ∧ (v ∩ e .blue).Nonempty ∧ + ENNReal.ofReal tau * Metric.ediam v < mu (v \ (e .red ∪ e .blue)) := by + obtain ⟨packing, hpositive, hradius_q, hscore⟩ := + exists_uniform_positive_packing hfinite hs hbeta hq₀ hq₀q hq_one hgain₀ + hadmissible hcross + have hradius_d : ∀ i : packing.support, length * (packing.radius i : ℝ) ≤ d := by + intro i + calc + length * (packing.radius i : ℝ) ≤ length * q := + mul_le_mul_of_nonneg_left (hradius_q i) hlength.le + _ = d := by + rw [hq_eq] + field_simp + let union := packing.ballUnionAt physical length + refine ⟨union, packing.isOpen_ballUnionAt physical length, ?_, ?_, ?_⟩ + · exact packing.ballUnionAt_inter_nonempty hlength hpositive hcenter .red + · exact packing.ballUnionAt_inter_nonempty hlength hpositive hcenter .blue + · exact packing_leakage_gt hadmissible hmu hbeta htau htau_score hlength hd_scale hd_set + hnonempty hcenter hdistance hdensity packing hpositive hradius_d hscore + +private theorem exists_neighborhood_of_root_bound + {e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2))} + {mu : Measure (EuclideanSpace ℝ (Fin 2))} {s beta q₀ gamma tau scale d length q : ℝ} + (hfinite : SixPointFiniteProperty s) (hs : 0 < s) (hbeta : 0 < beta) + (hgain₀ : s < beta * q₀) (hq₀ : 0 < q₀) (hq₀q : q₀ < q) (hq_one : q ≤ 1) + (hgamma : 0 < gamma) (hgamma_beta : gamma < beta) + (hs_gamma : s < gamma * q₀) (htau : 0 < tau) + (htau_score : tau ≤ beta * (q₀ * (beta * q₀ - s) / (4 * s * beta)) / 10) + (hmu : IsStraightMeasure mu) (hmeasurable : ∀ color, MeasurableSet (e color)) + (hnonempty : ∀ color, (e color).Nonempty) (hd : 0 < d) (hd_scale : d < scale) + (hlength : 0 < length) (hq_eq : q = d / length) + (hd_set : d = (setEDist (e .red) (e .blue)).toReal) + (root : SixPointColor → (EuclideanSpace ℝ (Fin 2))) + (hroot : ∀ color, root color ∈ e color) + (hroot_length : dist (root .red) (root .blue) = length) + (hdensity_root : ∀ color, + ENNReal.ofReal (2 * beta * d) < mu (Metric.ball (root color) d)) + (hroot_bound : mu (rootBallUnion (root .red) (root .blue) d \ (e .red ∪ e .blue)) ≤ + ENNReal.ofReal (2 * (beta - gamma) * d)) + (hdensity : ∀ x ∈ e .red ∪ e .blue, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * beta * r) < mu (Metric.ball x r)) : + ∃ v : Set (EuclideanSpace ℝ (Fin 2)), IsOpen v ∧ + (v ∩ e .red).Nonempty ∧ (v ∩ e .blue).Nonempty ∧ + ENNReal.ofReal tau * Metric.ediam v < mu (v \ (e .red ∪ e .blue)) := by + obtain ⟨physical, hphysical_red, hphysical_blue, hcenter, hchild, hsibling⟩ := + exists_physical_configuration hmu hmeasurable hnonempty hd hgamma hgamma_beta + hd_set root hroot hdensity_root hroot_bound + let normalized := physical.normalize (root .red) length + have hphysical_root : dist (physical .red .root) (physical .blue .root) = length := by + rw [hphysical_red, hphysical_blue, hroot_length] + obtain ⟨hadmissible, hcross⟩ := normalized_admissible_and_cross hlength hq_eq hq₀q + hq_one hgamma hs_gamma hphysical_root hchild hsibling hnonempty hcenter hd_set + apply exists_packing_neighborhood hfinite hs hbeta hq₀ hq₀q hq_one hgain₀ htau + htau_score hlength hq_eq hd_scale hd_set hadmissible hcross hmu hnonempty hcenter + · intro i j + exact physical.dist_eq_scale_mul_dist_normalize (root .red) hlength i.1 j.1 i.2 j.2 + · exact hdensity + +private theorem exists_pair_neighborhood {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {s beta q₀ gamma tau scale : ℝ} (hfinite : SixPointFiniteProperty s) (hs : 0 < s) + (hbeta : 0 < beta) (hgain₀ : s < beta * q₀) (hq₀ : 0 < q₀) (hq₀_one : q₀ < 1) + (hgamma : 0 < gamma) (hgamma_beta : gamma < beta) (hs_gamma : s < gamma * q₀) + (htau : 0 < tau) (htau_root : tau ≤ (beta - gamma) * q₀ / 4) + (htau_score : tau ≤ beta * (q₀ * (beta * q₀ - s) / (4 * s * beta)) / 10) + (hmu : IsStraightMeasure mu) {e₁ e₂ : Set (EuclideanSpace ℝ (Fin 2))} + (he₁ : MeasurableSet e₁) (he₂ : MeasurableSet e₂) (he₁_nonempty : e₁.Nonempty) + (he₂_nonempty : e₂.Nonempty) (hset_pos : 0 < setEDist e₁ e₂) + (hset_lt : setEDist e₁ e₂ < ENNReal.ofReal scale) + (hdensity : ∀ x ∈ e₁ ∪ e₂, ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * beta * r) < mu (Metric.ball x r)) : + ∃ v : Set (EuclideanSpace ℝ (Fin 2)), IsOpen v ∧ + (v ∩ e₁).Nonempty ∧ (v ∩ e₂).Nonempty ∧ + ENNReal.ofReal tau * Metric.ediam v < mu (v \ (e₁ ∪ e₂)) := by + let e : SixPointColor → Set (EuclideanSpace ℝ (Fin 2)) | .red => e₁ | .blue => e₂ + have he_nonempty : ∀ color, (e color).Nonempty := by + intro color + cases color <;> simp_all [e] + have he_measurable : ∀ color, MeasurableSet (e color) := by + intro color + cases color <;> simp_all [e] + let d := (setEDist e₁ e₂).toReal + have hd : 0 < d := setEDist_toReal_pos he₁_nonempty he₂_nonempty hset_pos + have hd_scale : d < scale := ENNReal.toReal_lt_of_lt_ofReal hset_lt + obtain ⟨redRoot, hredRoot, blueRoot, hblueRoot, hd_length, hroot_length⟩ := + exists_approximate_roots he₁_nonempty he₂_nonempty hd hq₀ hq₀_one (by rfl) + let length := dist redRoot blueRoot + change d ≤ length at hd_length + change length < d / q₀ at hroot_length + have hlength : 0 < length := hd.trans_le hd_length + let q := d / length + have hq₀q : q₀ < q := (lt_div_iff₀ hlength).2 <| by + simpa [mul_comm] using (lt_div_iff₀ hq₀).1 hroot_length + have hq_one : q ≤ 1 := (div_le_one hlength).2 hd_length + let root : SixPointColor → (EuclideanSpace ℝ (Fin 2)) | .red => redRoot | .blue => blueRoot + let rootUnion := rootBallUnion redRoot blueRoot d + by_cases hleakage : ENNReal.ofReal tau * Metric.ediam rootUnion < + mu (rootUnion \ (e₁ ∪ e₂)) + · exact ⟨rootUnion, isOpen_rootBallUnion _ _ _, + ⟨redRoot, Or.inl (Metric.mem_ball_self hd), hredRoot⟩, + ⟨blueRoot, Or.inr (Metric.mem_ball_self hd), hblueRoot⟩, hleakage⟩ + · have hroot_bound := measure_rootBallUnion_sdiff_le hq₀ hq₀_one hgamma_beta hd + hd_length rfl hroot_length htau htau_root (by simpa [rootUnion] using hleakage) + have hroot_mem : ∀ color, root color ∈ e color := by + intro color + cases color <;> simp_all [root, e] + have hroot_density : ∀ color, + ENNReal.ofReal (2 * beta * d) < mu (Metric.ball (root color) d) := by + intro color + cases color + · exact hdensity redRoot (Or.inl hredRoot) d hd hd_scale + · exact hdensity blueRoot (Or.inr hblueRoot) d hd hd_scale + apply exists_neighborhood_of_root_bound hfinite hs hbeta hgain₀ hq₀ hq₀q hq_one + hgamma hgamma_beta hs_gamma htau htau_score hmu he_measurable he_nonempty hd hd_scale + hlength rfl (by simp [d, e]) root hroot_mem rfl hroot_density + · simpa [root, rootUnion, e] using hroot_bound + · simpa [e] using hdensity + +/-- The finite six-point property at `s` implies the Besicovitch pair condition above `s`. -/ +theorem SixPointFiniteProperty.besicovitchPairCondition {s beta : ℝ} (hs : 0 < s) + (hsbeta : s < beta) (hfinite : SixPointFiniteProperty s) : + BesicovitchPairCondition beta := by + obtain ⟨q₀, gamma, hq₀, hq₀_one, hs_div, hgamma, hgamma_beta, hs_gamma⟩ := + exists_transfer_parameters hs hsbeta + have hbeta : 0 < beta := hs.trans hsbeta + have hgain₀ : s < beta * q₀ := by + simpa [mul_comm] using (div_lt_iff₀ hbeta).1 hs_div + let margin := q₀ * (beta * q₀ - s) / (4 * s * beta) + have hmargin : 0 < margin := by + dsimp only [margin] + positivity + let tau := min ((beta - gamma) * q₀ / 4) (beta * margin / 10) + have htau : 0 < tau := by + dsimp only [tau] + rw [lt_min_iff] + exact ⟨by positivity, by positivity⟩ + have htau_root : tau ≤ (beta - gamma) * q₀ / 4 := min_le_left _ _ + have htau_score : tau ≤ beta * margin / 10 := min_le_right _ _ + intro mu hmu + refine ⟨tau, htau, ?_⟩ + intro scale hscale + refine ⟨scale, hscale, ?_⟩ + intro e₁ e₂ he₁ he₂ he₁_nonempty he₂_nonempty hset_pos hset_lt hdensity + exact exists_pair_neighborhood hfinite hs hbeta hgain₀ hq₀ hq₀_one hgamma hgamma_beta + hs_gamma htau htau_root (by simpa only [margin] using htau_score) hmu he₁ he₂ + he₁_nonempty he₂_nonempty hset_pos hset_lt hdensity + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/DensePolynomial.lean b/LeanPool/Besicovitch/Certificates/DensePolynomial.lean new file mode 100644 index 0000000000..36887587cf --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/DensePolynomial.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.Calculus.MeanValue +public import Mathlib.Data.Rat.Cast.Order + +/-! +# Dense exact bivariate polynomials + +The outer list records increasing powers of `x`; each inner list records increasing powers of +`y`. Transparent list arithmetic lets the kernel normalize small polynomial certificates. +-/ + +@[expose] public section + +namespace LeanPool.Besicovitch + +/-- A dense univariate polynomial with coefficients in increasing degree order. -/ +abbrev DenseUnivariate := List ℚ + +namespace DenseUnivariate + +/-- Add coefficient lists, padding the shorter list by zeros. -/ +def add : DenseUnivariate → DenseUnivariate → DenseUnivariate + | [], q => q + | p, [] => p + | a :: p, b :: q => (a + b) :: add p q + +/-- Multiply every coefficient by a rational scalar. -/ +def scale (a : ℚ) (p : DenseUnivariate) : DenseUnivariate := + p.map (a * ·) + +/-- Negate every coefficient. -/ +def neg (p : DenseUnivariate) : DenseUnivariate := + p.map (-·) + +/-- Exact polynomial multiplication by coefficient convolution. -/ +def mul : DenseUnivariate → DenseUnivariate → DenseUnivariate + | [], _ => [] + | a :: p, q => add (scale a q) (0 :: mul p q) + +/-- Evaluate a dense polynomial over the reals by Horner's rule. -/ +noncomputable def eval : DenseUnivariate → ℝ → ℝ + | [], _ => 0 + | a :: p, x => a + x * eval p x + +/-- The sum of the absolute values of the coefficients. -/ +def coefficientL1Norm (p : DenseUnivariate) : ℚ := + (p.map abs).sum + +/-- Formal differentiation, using `P = a + x Q` and `P' = Q + x Q'`. -/ +def deriv : DenseUnivariate → DenseUnivariate + | [] => [] + | _ :: p => add p (0 :: deriv p) + +theorem coefficientL1Norm_nonneg (p : DenseUnivariate) : 0 ≤ coefficientL1Norm p := by + apply List.sum_nonneg + intro a ha + rw [List.mem_map] at ha + obtain ⟨b, -, rfl⟩ := ha + exact abs_nonneg b + +theorem eval_add (p q : DenseUnivariate) (x : ℝ) : + eval (add p q) x = eval p x + eval q x := by + induction p generalizing q with + | nil => simp [add, eval] + | cons a p hp => + cases q with + | nil => simp [add, eval] + | cons b q => simp [add, eval, hp]; ring + +theorem eval_scale (a : ℚ) (p : DenseUnivariate) (x : ℝ) : + eval (scale a p) x = a * eval p x := by + induction p with + | nil => simp [scale, eval] + | cons b p hp => + simp only [scale] at hp + simp [scale, eval, hp] + ring + +theorem eval_neg (p : DenseUnivariate) (x : ℝ) : eval (neg p) x = -eval p x := by + induction p with + | nil => simp [neg, eval] + | cons a p hp => + simp only [neg] at hp + simp [neg, eval, hp] + ring + +theorem eval_mul (p q : DenseUnivariate) (x : ℝ) : + eval (mul p q) x = eval p x * eval q x := by + induction p with + | nil => simp [mul, eval] + | cons a p hp => simp [mul, eval, eval_add, eval_scale, hp]; ring + +theorem eval_deriv_cons (a : ℚ) (p : DenseUnivariate) (x : ℝ) : + eval (deriv (a :: p)) x = eval p x + x * eval (deriv p) x := by + simp [deriv, eval_add, eval] + +/-- Formal differentiation computes the derivative of dense evaluation. -/ +theorem hasDerivAt_eval (p : DenseUnivariate) (x : ℝ) : + letI : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + letI : Module ℝ ℝ := NormedField.toNormedSpace.toModule + HasDerivAt (eval p) (eval (deriv p) x) x := by + let : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + let : Module ℝ ℝ := NormedField.toNormedSpace.toModule + induction p with + | nil => simpa [eval, deriv] using hasDerivAt_const x (0 : ℝ) + | cons a p hp => + convert (hasDerivAt_const x (a : ℝ)).add ((hasDerivAt_id x).mul hp) using 1 + · ext z + simp [eval] + · simp [eval_deriv_cons] + +/-- The coefficient norm bounds evaluation on the unit interval. -/ +theorem abs_eval_le_coefficientL1Norm (p : DenseUnivariate) {x : ℝ} (hx : |x| ≤ 1) : + |eval p x| ≤ (coefficientL1Norm p : ℝ) := by + induction p with + | nil => simp [eval, coefficientL1Norm] + | cons a p hp => + rw [eval, coefficientL1Norm, List.map_cons, List.sum_cons, Rat.cast_add, Rat.cast_abs] + calc + |(a : ℝ) + x * eval p x| ≤ |(a : ℝ)| + |x| * |eval p x| := by + simpa only [abs_mul] using abs_add_le (a : ℝ) (x * eval p x) + _ ≤ |(a : ℝ)| + |eval p x| := by + gcongr + exact mul_le_of_le_one_left (abs_nonneg _) hx + _ ≤ |(a : ℝ)| + (coefficientL1Norm p : ℝ) := add_le_add_right hp _ + +end DenseUnivariate + +/-- A dense bivariate polynomial, with the outer index giving the first-variable degree. -/ +abbrev DenseBivariatePolynomial := List DenseUnivariate + +namespace DenseBivariatePolynomial + +/-- Add two dense bivariate polynomials. -/ +def add : DenseBivariatePolynomial → DenseBivariatePolynomial → DenseBivariatePolynomial + | [], q => q + | p, [] => p + | a :: p, b :: q => DenseUnivariate.add a b :: add p q + +/-- Multiply by a rational scalar. -/ +def scale (a : ℚ) (p : DenseBivariatePolynomial) : DenseBivariatePolynomial := + p.map (DenseUnivariate.scale a) + +/-- Negate a dense bivariate polynomial. -/ +def neg (p : DenseBivariatePolynomial) : DenseBivariatePolynomial := + p.map DenseUnivariate.neg + +/-- Multiply each outer coefficient by a univariate polynomial. -/ +def scaleRow (a : DenseUnivariate) (p : DenseBivariatePolynomial) : DenseBivariatePolynomial := + p.map (DenseUnivariate.mul a) + +/-- Exact bivariate polynomial multiplication. -/ +def mul : DenseBivariatePolynomial → DenseBivariatePolynomial → DenseBivariatePolynomial + | [], _ => [] + | a :: p, q => add (scaleRow a q) ([] :: mul p q) + +/-- A constant bivariate polynomial. -/ +def literal (a : ℚ) : DenseBivariatePolynomial := [[a]] + +/-- The first variable. -/ +def first : DenseBivariatePolynomial := [[0], [1]] + +/-- The second variable. -/ +def second : DenseBivariatePolynomial := [[0, 1]] + +/-- Natural powers of a dense bivariate polynomial. -/ +def pow (p : DenseBivariatePolynomial) : ℕ → DenseBivariatePolynomial + | 0 => literal 1 + | n + 1 => mul (pow p n) p + +/-- Evaluate a dense bivariate polynomial by nested Horner rules. -/ +noncomputable def eval : DenseBivariatePolynomial → ℝ → ℝ → ℝ + | [], _, _ => 0 + | a :: p, x, y => DenseUnivariate.eval a y + x * eval p x y + +/-- The sum of the absolute values of all coefficients. -/ +def coefficientL1Norm (p : DenseBivariatePolynomial) : ℚ := + (p.map DenseUnivariate.coefficientL1Norm).sum + +/-- Formal differentiation with respect to the first variable. -/ +def derivFirst : DenseBivariatePolynomial → DenseBivariatePolynomial + | [] => [] + | _ :: p => add p ([] :: derivFirst p) + +/-- Formal differentiation with respect to the second variable. -/ +def derivSecond (p : DenseBivariatePolynomial) : DenseBivariatePolynomial := + p.map DenseUnivariate.deriv + +theorem coefficientL1Norm_nonneg (p : DenseBivariatePolynomial) : 0 ≤ coefficientL1Norm p := by + apply List.sum_nonneg + intro a ha + rw [List.mem_map] at ha + obtain ⟨b, -, rfl⟩ := ha + exact DenseUnivariate.coefficientL1Norm_nonneg b + +theorem eval_add (p q : DenseBivariatePolynomial) (x y : ℝ) : + eval (add p q) x y = eval p x y + eval q x y := by + induction p generalizing q with + | nil => simp [add, eval] + | cons a p hp => + cases q with + | nil => simp [add, eval] + | cons b q => simp [add, eval, DenseUnivariate.eval_add, hp]; ring + +theorem eval_scale (a : ℚ) (p : DenseBivariatePolynomial) (x y : ℝ) : + eval (scale a p) x y = a * eval p x y := by + induction p with + | nil => simp [scale, eval] + | cons b p hp => + simp only [scale] at hp + simp [scale, eval, DenseUnivariate.eval_scale, hp] + ring + +theorem eval_neg (p : DenseBivariatePolynomial) (x y : ℝ) : + eval (neg p) x y = -eval p x y := by + induction p with + | nil => simp [neg, eval] + | cons a p hp => + simp only [neg] at hp + simp [neg, eval, DenseUnivariate.eval_neg, hp] + ring + +theorem eval_scaleRow (a : DenseUnivariate) (p : DenseBivariatePolynomial) (x y : ℝ) : + eval (scaleRow a p) x y = DenseUnivariate.eval a y * eval p x y := by + induction p with + | nil => simp [scaleRow, eval] + | cons b p hp => + simp only [scaleRow] at hp + simp [scaleRow, eval, DenseUnivariate.eval_mul, hp] + ring + +theorem eval_mul (p q : DenseBivariatePolynomial) (x y : ℝ) : + eval (mul p q) x y = eval p x y * eval q x y := by + induction p with + | nil => simp [mul, eval] + | cons a p hp => simp [mul, eval, eval_add, eval_scaleRow, hp, DenseUnivariate.eval]; ring + +theorem eval_constant (a : ℚ) (x y : ℝ) : eval (literal a) x y = a := by + simp [literal, eval, DenseUnivariate.eval] + +theorem eval_first (x y : ℝ) : eval first x y = x := by + simp [first, eval, DenseUnivariate.eval] + +theorem eval_second (x y : ℝ) : eval second x y = y := by + simp [second, eval, DenseUnivariate.eval] + +theorem eval_pow (p : DenseBivariatePolynomial) (n : ℕ) (x y : ℝ) : + eval (pow p n) x y = eval p x y ^ n := by + induction n with + | zero => simp [pow, eval_constant] + | succ n hn => simp [pow, eval_mul, hn, pow_succ] + +theorem eval_derivFirst_cons (a : DenseUnivariate) (p : DenseBivariatePolynomial) + (x y : ℝ) : + eval (derivFirst (a :: p)) x y = eval p x y + x * eval (derivFirst p) x y := by + simp [derivFirst, eval_add, eval, DenseUnivariate.eval] + +/-- `derivFirst` computes the derivative along a first-coordinate line. -/ +theorem hasDerivAt_eval_first (p : DenseBivariatePolynomial) (x y : ℝ) : + letI : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + letI : Module ℝ ℝ := NormedField.toNormedSpace.toModule + HasDerivAt (fun u ↦ eval p u y) (eval (derivFirst p) x y) x := by + let : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + let : Module ℝ ℝ := NormedField.toNormedSpace.toModule + induction p with + | nil => simpa [eval, derivFirst] using hasDerivAt_const x (0 : ℝ) + | cons a p hp => + convert (hasDerivAt_const x (DenseUnivariate.eval a y)).add + ((hasDerivAt_id x).mul hp) using 1 + · ext z + simp [eval] + · simp [eval_derivFirst_cons] + +/-- `derivSecond` computes the derivative along a second-coordinate line. -/ +theorem hasDerivAt_eval_second (p : DenseBivariatePolynomial) (x y : ℝ) : + letI : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + letI : Module ℝ ℝ := NormedField.toNormedSpace.toModule + HasDerivAt (fun v ↦ eval p x v) (eval (derivSecond p) x y) y := by + let : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + let : Module ℝ ℝ := NormedField.toNormedSpace.toModule + induction p with + | nil => simpa [eval, derivSecond] using hasDerivAt_const y (0 : ℝ) + | cons a p hp => + convert (DenseUnivariate.hasDerivAt_eval a y).add ((hasDerivAt_const y x).mul hp) using 1 + · ext z + simp [eval] + · simp [derivSecond, eval] + +/-- The coefficient norm bounds evaluation on the real unit square. -/ +theorem abs_eval_le_coefficientL1Norm (p : DenseBivariatePolynomial) {x y : ℝ} + (hx : |x| ≤ 1) (hy : |y| ≤ 1) : |eval p x y| ≤ (coefficientL1Norm p : ℝ) := by + induction p with + | nil => simp [eval, coefficientL1Norm] + | cons a p hp => + rw [eval, coefficientL1Norm, List.map_cons, List.sum_cons, Rat.cast_add] + calc + |DenseUnivariate.eval a y + x * eval p x y| ≤ + |DenseUnivariate.eval a y| + |x| * |eval p x y| := by + simpa only [abs_mul] using abs_add_le (DenseUnivariate.eval a y) (x * eval p x y) + _ ≤ (DenseUnivariate.coefficientL1Norm a : ℝ) + |eval p x y| := by + gcongr + · exact DenseUnivariate.abs_eval_le_coefficientL1Norm a hy + · exact mul_le_of_le_one_left (abs_nonneg _) hx + _ ≤ (DenseUnivariate.coefficientL1Norm a : ℝ) + + (coefficientL1Norm p : ℝ) := add_le_add_right hp _ + +/-- The first formal derivative bounds variation along a horizontal line in the unit square. -/ +theorem abs_eval_sub_le_derivFirst (p : DenseBivariatePolynomial) {x₁ x₂ y : ℝ} + (hx₁ : |x₁| ≤ 1) (hx₂ : |x₂| ≤ 1) (hy : |y| ≤ 1) : + |eval p x₂ y - eval p x₁ y| ≤ + (coefficientL1Norm (derivFirst p) : ℝ) * |x₂ - x₁| := by + let : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + let : Module ℝ ℝ := NormedField.toNormedSpace.toModule + have h := (convex_Icc (-1 : ℝ) 1).norm_image_sub_le_of_norm_hasDerivWithin_le + (f := fun u ↦ eval p u y) (f' := fun u ↦ eval (derivFirst p) u y) + (fun u _ ↦ (hasDerivAt_eval_first p u y).hasDerivWithinAt) + (fun u hu ↦ abs_eval_le_coefficientL1Norm (derivFirst p) + (abs_le.mpr ⟨by linarith [hu.1], hu.2⟩) hy) (abs_le.mp hx₁) (abs_le.mp hx₂) + simpa only [Real.norm_eq_abs] using h + +/-- The second formal derivative bounds variation along a vertical line in the unit square. -/ +theorem abs_eval_sub_le_derivSecond (p : DenseBivariatePolynomial) {x y₁ y₂ : ℝ} + (hx : |x| ≤ 1) (hy₁ : |y₁| ≤ 1) (hy₂ : |y₂| ≤ 1) : + |eval p x y₂ - eval p x y₁| ≤ + (coefficientL1Norm (derivSecond p) : ℝ) * |y₂ - y₁| := by + let : AddCommGroup ℝ := Real.normedAddCommGroup.toAddCommGroup + let : Module ℝ ℝ := NormedField.toNormedSpace.toModule + have h := (convex_Icc (-1 : ℝ) 1).norm_image_sub_le_of_norm_hasDerivWithin_le + (f := fun v ↦ eval p x v) (f' := fun v ↦ eval (derivSecond p) x v) + (fun v _ ↦ (hasDerivAt_eval_second p x v).hasDerivWithinAt) + (fun v hv ↦ abs_eval_le_coefficientL1Norm (derivSecond p) hx + (abs_le.mpr ⟨by linarith [hv.1], hv.2⟩)) (abs_le.mp hy₁) (abs_le.mp hy₂) + simpa only [Real.norm_eq_abs] using h + +end DenseBivariatePolynomial + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/EndpointBridge.lean b/LeanPool/Besicovitch/Certificates/EndpointBridge.lean new file mode 100644 index 0000000000..cec6dc30e7 --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/EndpointBridge.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Certificates.EndpointIsolation + +/-! +# The certified six-point endpoint + +This file transfers the exact polynomial certificate to the natural radical endpoint and +identifies the constants defined from that endpoint. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The unique endpoint pair isolated by the exact polynomial certificate. -/ +def certifiedEndpointPair : ℝ × ℝ := + Classical.choose existsUnique_isEndpointPolynomialPair.exists + +/-- The certified pair satisfies the signed polynomial endpoint system. -/ +theorem certifiedEndpointPair_isEndpointPolynomialPair : + IsEndpointPolynomialPair certifiedEndpointPair.1 certifiedEndpointPair.2 := + Classical.choose_spec existsUnique_isEndpointPolynomialPair.exists + +/-- The certified polynomial pair is a solution of the natural radical system. -/ +theorem certifiedEndpointPair_isEndpointPair : + IsEndpointPair certifiedEndpointPair.1 certifiedEndpointPair.2 := + isEndpointPair_of_isEndpointPolynomialPair certifiedEndpointPair_isEndpointPolynomialPair + +/-- Every signed polynomial endpoint pair is the certified pair. -/ +theorem IsEndpointPolynomialPair.eq_certifiedEndpointPair {c B : ℝ} + (h : IsEndpointPolynomialPair c B) : (c, B) = certifiedEndpointPair := by + apply existsUnique_isEndpointPolynomialPair.unique + · exact h + · exact certifiedEndpointPair_isEndpointPolynomialPair + +/-- Every natural radical endpoint pair is the certified pair. -/ +theorem IsEndpointPair.eq_certifiedEndpointPair {c B : ℝ} (h : IsEndpointPair c B) : + (c, B) = certifiedEndpointPair := + h.isEndpointPolynomialPair.eq_certifiedEndpointPair + +/-- A natural radical endpoint pair exists. -/ +theorem exists_isEndpointPair : ∃ c B : ℝ, IsEndpointPair c B := + ⟨certifiedEndpointPair.1, certifiedEndpointPair.2, certifiedEndpointPair_isEndpointPair⟩ + +/-- The first coordinate of the certified pair is exactly `cStar`. -/ +theorem cStar_eq_certifiedEndpointPair_fst : cStar = certifiedEndpointPair.1 := by + apply cStar_eq_of_isEndpointPair_of_unique certifiedEndpointPair_isEndpointPair + intro c B h + exact congrArg Prod.fst h.eq_certifiedEndpointPair + +/-- The certified endpoint radicands are strictly positive. -/ +theorem certifiedEndpointPair_radicands_pos : + 0 < (certifiedEndpointPair.2 ^ 2 - 1) / 2 ∧ + 0 < (certifiedEndpointPair.2 ^ 2 + + (4 * certifiedEndpointPair.1 ^ 2 - 2 * certifiedEndpointPair.1 - + certifiedEndpointPair.2) ^ 2) / 2 - certifiedEndpointPair.1 ^ 2 := + certifiedEndpointPair_isEndpointPair.radicands_pos + +/-- The certified second coordinate lies in its strict rational isolation interval. -/ +theorem certifiedEndpointPair_second_mem_isolation_box : + 2873744161801659 / 10 ^ 15 < certifiedEndpointPair.2 ∧ + certifiedEndpointPair.2 < 2873744161801662 / 10 ^ 15 := + certifiedEndpointPair_isEndpointPair.second_mem_isolation_box + +/-- `cStar` lies strictly inside the certified rational isolation interval. -/ +theorem cStar_mem_isolation_box : + 13866128436518096 / 10 ^ 16 < cStar ∧ + cStar < 13866128436518100 / 10 ^ 16 := by + rw [cStar_eq_certifiedEndpointPair_fst] + exact certifiedEndpointPair_isEndpointPair.c_mem_isolation_box + +/-- `sStar` lies strictly inside the half-coordinate isolation interval. -/ +theorem sStar_mem_isolation_box : + 6933064218259048 / 10 ^ 16 < sStar ∧ + sStar < 6933064218259050 / 10 ^ 16 := by + apply sStar_mem_isolation_box_of_unique certifiedEndpointPair_isEndpointPair + intro c B h + exact congrArg Prod.fst h.eq_certifiedEndpointPair + +/-- The exact isolation interval puts `sStar` below `0.6934`. -/ +theorem sStar_le_6934_div_10000_certified : sStar ≤ 6934 / 10000 := by + exact sStar_mem_isolation_box.2.le.trans (by norm_num) + +/-- The certified endpoint lies in the elementary range needed by the six-point argument. -/ +theorem half_lt_sStar_and_sStar_lt_one_certified : 1 / 2 < sStar ∧ sStar < 1 := + half_lt_sStar_and_sStar_lt_one exists_isEndpointPair + +/-- The six-point endpoint is larger than one half. -/ +theorem half_lt_sStar : 1 / 2 < sStar := + half_lt_sStar_and_sStar_lt_one_certified.1 + +/-- The six-point endpoint is smaller than one. -/ +theorem sStar_lt_one : sStar < 1 := + half_lt_sStar_and_sStar_lt_one_certified.2 + +/-- Twice the endpoint lies strictly between one and two. -/ +theorem one_lt_cStar_and_cStar_lt_two : 1 < cStar ∧ cStar < 2 := by + rcases cStar_mem_isolation_box with ⟨hl, hu⟩ + constructor <;> norm_num at hl hu ⊢ <;> linarith + +/-- The six-point endpoint is positive. -/ +theorem sStar_pos : 0 < sStar := + (by norm_num : (0 : ℝ) < 1 / 2).trans half_lt_sStar + +/-- Twice the six-point endpoint is positive. -/ +theorem cStar_pos : 0 < cStar := zero_lt_one.trans one_lt_cStar_and_cStar_lt_two.1 + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/EndpointIsolation.lean b/LeanPool/Besicovitch/Certificates/EndpointIsolation.lean new file mode 100644 index 0000000000..e84820b86e --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/EndpointIsolation.lean @@ -0,0 +1,690 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Certificates.Krawczyk +public import LeanPool.Besicovitch.Certificates.DensePolynomial +public import LeanPool.Besicovitch.SixPoint.AlgebraicBasic + +/-! +# Isolation of the six-point endpoint + +This file encodes the two polynomial equations in centered coordinates. All numbers in the +preconditioner are rational, and the coefficient-norm estimates are checked by the kernel. +-/ + +@[expose] public section + +noncomputable section + +open Function NNReal Set + +namespace LeanPool.Besicovitch + +namespace DenseEndpoint + +open DenseBivariatePolynomial + +/-- The centered half-coordinate as a transparent dense polynomial. -/ +def scaledS : DenseBivariatePolynomial := + add (literal (6933064218259049 / 10 ^ 16)) (scale (1 / 10 ^ 16) first) + +/-- The centered distance coordinate as a transparent dense polynomial. -/ +def scaledB : DenseBivariatePolynomial := + add (literal (5747488323603321 / (2 * 10 ^ 15))) + (scale (3 / (2 * 10 ^ 15)) second) + +/-- The cleared balance polynomial in transparent dense form. -/ +def balance : DenseBivariatePolynomial := + let s := scaledS + let B := scaledB + let q := add (scale 2 s) (literal 1) + let p := add (add (add (scale 2 B) (neg (scale 12 (pow s 2)))) (scale 4 s)) + (literal (-1)) + let D := add (add (scale 16 (pow s 2)) (neg (scale 4 s))) (neg B) + let A2 := scale (1 / 2) (add (pow B 2) (literal (-1))) + let C2 := add (scale (1 / 2) (add (pow B 2) (pow D 2))) (neg (scale 4 (pow s 2))) + let K := add (scale 6 (mul s p)) (mul (add (scale 4 (pow s 2)) (literal (-1))) q) + add (pow (add (pow K 2) (neg (mul (add A2 C2) (pow q 2)))) 2) + (neg (scale 4 (mul (mul A2 C2) (pow q 4)))) + +/-- The cleared Gram polynomial in transparent dense form. -/ +def gram : DenseBivariatePolynomial := + let s := scaledS + let B := scaledB + let q := add (scale 2 s) (literal 1) + let p := add (add (add (scale 2 B) (neg (scale 12 (pow s 2)))) (scale 4 s)) + (literal (-1)) + let D := add (add (scale 16 (pow s 2)) (neg (scale 4 s))) (neg B) + let x := add (literal 5) (neg (pow B 2)) + let z := add (add (pow q 2) (scale 4 (pow p 2))) (neg (mul (pow D 2) (pow q 2))) + let k := add (mul (add (literal 1) (neg (scale 4 (pow s 2)))) (pow q 2)) (pow p 2) + scale (1 / 64) <| + add (pow (add (scale 8 k) (neg (mul x z))) 2) + (neg (mul (add (literal 16) (neg (pow x 2))) + (add (scale 16 (mul (pow p 2) (pow q 2))) (neg (pow z 2))))) + +/-- The preconditioned fixed-point map in transparent dense form. -/ +def fixedMap : Fin 2 → DenseBivariatePolynomial := + ![add first (neg (add (scale 68748375835 balance) (scale 4033169260133 gram))), + add second (neg (add (scale 104924796527 balance) (scale 2365005784960 gram)))] + +end DenseEndpoint + +/-- Each coordinate of the fixed-point map is strictly inside the unit interval. -/ +private theorem endpointMapPolynomial_coefficientL1Norm_lt_one_0 (j : Fin 2) (hj : j = 0) : + DenseBivariatePolynomial.coefficientL1Norm (DenseEndpoint.fixedMap j) < 1 := by + fin_cases j <;> cases hj + all_goals norm_num [DenseBivariatePolynomial.coefficientL1Norm, DenseEndpoint.fixedMap, + DenseEndpoint.balance, DenseEndpoint.gram, DenseEndpoint.scaledS, DenseEndpoint.scaledB, + DenseBivariatePolynomial.add, DenseBivariatePolynomial.neg, DenseBivariatePolynomial.scale, + DenseBivariatePolynomial.mul, DenseBivariatePolynomial.scaleRow, DenseBivariatePolynomial.pow, + DenseBivariatePolynomial.literal, DenseBivariatePolynomial.first, + DenseBivariatePolynomial.second, DenseUnivariate.add, DenseUnivariate.neg, + DenseUnivariate.scale, DenseUnivariate.mul, DenseUnivariate.coefficientL1Norm] + +private theorem endpointMapPolynomial_coefficientL1Norm_lt_one_1 (j : Fin 2) (hj : j = 1) : + DenseBivariatePolynomial.coefficientL1Norm (DenseEndpoint.fixedMap j) < 1 := by + fin_cases j <;> cases hj + all_goals norm_num [DenseBivariatePolynomial.coefficientL1Norm, DenseEndpoint.fixedMap, + DenseEndpoint.balance, DenseEndpoint.gram, DenseEndpoint.scaledS, DenseEndpoint.scaledB, + DenseBivariatePolynomial.add, DenseBivariatePolynomial.neg, DenseBivariatePolynomial.scale, + DenseBivariatePolynomial.mul, DenseBivariatePolynomial.scaleRow, DenseBivariatePolynomial.pow, + DenseBivariatePolynomial.literal, DenseBivariatePolynomial.first, + DenseBivariatePolynomial.second, DenseUnivariate.add, DenseUnivariate.neg, + DenseUnivariate.scale, DenseUnivariate.mul, DenseUnivariate.coefficientL1Norm] + +theorem endpointMapPolynomial_coefficientL1Norm_lt_one (i : Fin 2) : + DenseBivariatePolynomial.coefficientL1Norm (DenseEndpoint.fixedMap i) < 1 := by + fin_cases i + · exact endpointMapPolynomial_coefficientL1Norm_lt_one_0 _ rfl + · exact endpointMapPolynomial_coefficientL1Norm_lt_one_1 _ rfl + +/-- The exact derivative certificate makes the fixed-point map a strict contraction. -/ +private theorem endpointMapPolynomial_derivative_coefficientL1Norm_lt_0 (j : Fin 2) (hj : j = 0) : + DenseBivariatePolynomial.coefficientL1Norm (DenseBivariatePolynomial.derivFirst + (DenseEndpoint.fixedMap j)) + + DenseBivariatePolynomial.coefficientL1Norm (DenseBivariatePolynomial.derivSecond + (DenseEndpoint.fixedMap j)) < + 1 / 10 ^ 9 := by + fin_cases j <;> cases hj + all_goals norm_num [DenseBivariatePolynomial.coefficientL1Norm, DenseEndpoint.fixedMap, + DenseEndpoint.balance, DenseEndpoint.gram, DenseEndpoint.scaledS, DenseEndpoint.scaledB, + DenseBivariatePolynomial.add, DenseBivariatePolynomial.neg, DenseBivariatePolynomial.scale, + DenseBivariatePolynomial.mul, DenseBivariatePolynomial.scaleRow, DenseBivariatePolynomial.pow, + DenseBivariatePolynomial.literal, DenseBivariatePolynomial.first, + DenseBivariatePolynomial.second, DenseBivariatePolynomial.derivFirst, + DenseBivariatePolynomial.derivSecond, DenseUnivariate.add, DenseUnivariate.neg, + DenseUnivariate.scale, DenseUnivariate.mul, DenseUnivariate.deriv, + DenseUnivariate.coefficientL1Norm] + +private theorem endpointMapPolynomial_derivative_coefficientL1Norm_lt_1 (j : Fin 2) (hj : j = 1) : + DenseBivariatePolynomial.coefficientL1Norm (DenseBivariatePolynomial.derivFirst + (DenseEndpoint.fixedMap j)) + + DenseBivariatePolynomial.coefficientL1Norm (DenseBivariatePolynomial.derivSecond + (DenseEndpoint.fixedMap j)) < + 1 / 10 ^ 9 := by + fin_cases j <;> cases hj + all_goals norm_num [DenseBivariatePolynomial.coefficientL1Norm, DenseEndpoint.fixedMap, + DenseEndpoint.balance, DenseEndpoint.gram, DenseEndpoint.scaledS, DenseEndpoint.scaledB, + DenseBivariatePolynomial.add, DenseBivariatePolynomial.neg, DenseBivariatePolynomial.scale, + DenseBivariatePolynomial.mul, DenseBivariatePolynomial.scaleRow, DenseBivariatePolynomial.pow, + DenseBivariatePolynomial.literal, DenseBivariatePolynomial.first, + DenseBivariatePolynomial.second, DenseBivariatePolynomial.derivFirst, + DenseBivariatePolynomial.derivSecond, DenseUnivariate.add, DenseUnivariate.neg, + DenseUnivariate.scale, DenseUnivariate.mul, DenseUnivariate.deriv, + DenseUnivariate.coefficientL1Norm] + +theorem endpointMapPolynomial_derivative_coefficientL1Norm_lt (i : Fin 2) : + DenseBivariatePolynomial.coefficientL1Norm + (DenseBivariatePolynomial.derivFirst (DenseEndpoint.fixedMap i)) + + DenseBivariatePolynomial.coefficientL1Norm + (DenseBivariatePolynomial.derivSecond (DenseEndpoint.fixedMap i)) < + 1 / 10 ^ 9 := by + fin_cases i + · exact endpointMapPolynomial_derivative_coefficientL1Norm_lt_0 _ rfl + · exact endpointMapPolynomial_derivative_coefficientL1Norm_lt_1 _ rfl + +/-- The two normalized coordinates used by the endpoint certificate. -/ +abbrev EndpointCertificateSpace := Fin 2 → ℝ + +/-- The cleared endpoint equations evaluated in normalized coordinates. -/ +def endpointCertificateSystem (x : EndpointCertificateSpace) : EndpointCertificateSpace := + ![DenseBivariatePolynomial.eval DenseEndpoint.balance (x 0) (x 1), + DenseBivariatePolynomial.eval DenseEndpoint.gram (x 0) (x 1)] + +/-- The preconditioned endpoint fixed-point map in normalized coordinates. -/ +def endpointCertificateMap (x : EndpointCertificateSpace) : EndpointCertificateSpace := fun i ↦ + DenseBivariatePolynomial.eval (DenseEndpoint.fixedMap i) (x 0) (x 1) + +/-- The closed unit box in the normalized coordinates. -/ +def endpointCertificateBox : Set EndpointCertificateSpace := Metric.closedBall 0 1 + +/-- Decode the normalized first coordinate into the half-coordinate `s`. -/ +def endpointCertificateS (u : EndpointCertificateSpace) : ℝ := + 6933064218259049 / 10 ^ 16 + (1 / 10 ^ 16) * u 0 + +/-- Decode the normalized second coordinate into the distance coordinate `B`. -/ +def endpointCertificateB (u : EndpointCertificateSpace) : ℝ := + 5747488323603321 / (2 * 10 ^ 15) + (3 / (2 * 10 ^ 15)) * u 1 + +/-- The endpoint balance residual with its denominator cleared in half-coordinates. -/ +def endpointBalanceCleared (s B : ℝ) : ℝ := + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - 4 * s ^ 2 + let K := 6 * s * p + (4 * s ^ 2 - 1) * q + (K ^ 2 - (A2 + C2) * q ^ 2) ^ 2 - 4 * A2 * C2 * q ^ 4 + +/-- The endpoint Gram residual with its denominator cleared in half-coordinates. -/ +def endpointGramCleared (s B : ℝ) : ℝ := + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let x := 5 - B ^ 2 + let z := q ^ 2 + 4 * p ^ 2 - D ^ 2 * q ^ 2 + let k := (1 - 4 * s ^ 2) * q ^ 2 + p ^ 2 + ((8 * k - x * z) ^ 2 - (16 - x ^ 2) * (16 * p ^ 2 * q ^ 2 - z ^ 2)) / 64 + +theorem DenseEndpoint.eval_scaledS (u : EndpointCertificateSpace) : + DenseBivariatePolynomial.eval DenseEndpoint.scaledS (u 0) (u 1) = + endpointCertificateS u := by + simp [DenseEndpoint.scaledS, endpointCertificateS, DenseBivariatePolynomial.eval_add, + DenseBivariatePolynomial.eval_scale, DenseBivariatePolynomial.eval_constant, + DenseBivariatePolynomial.eval_first] + +theorem DenseEndpoint.eval_scaledB (u : EndpointCertificateSpace) : + DenseBivariatePolynomial.eval DenseEndpoint.scaledB (u 0) (u 1) = + endpointCertificateB u := by + simp [DenseEndpoint.scaledB, endpointCertificateB, DenseBivariatePolynomial.eval_add, + DenseBivariatePolynomial.eval_scale, DenseBivariatePolynomial.eval_constant, + DenseBivariatePolynomial.eval_second] + +theorem DenseEndpoint.eval_balance (u : EndpointCertificateSpace) : + DenseBivariatePolynomial.eval DenseEndpoint.balance (u 0) (u 1) = + endpointBalanceCleared (endpointCertificateS u) (endpointCertificateB u) := by + simp only [DenseEndpoint.balance, DenseBivariatePolynomial.eval_add, + DenseBivariatePolynomial.eval_neg, DenseBivariatePolynomial.eval_scale, + DenseBivariatePolynomial.eval_mul, DenseBivariatePolynomial.eval_pow, + DenseBivariatePolynomial.eval_constant, DenseEndpoint.eval_scaledS, + DenseEndpoint.eval_scaledB, endpointBalanceCleared] + ring + +theorem DenseEndpoint.eval_gram (u : EndpointCertificateSpace) : + DenseBivariatePolynomial.eval DenseEndpoint.gram (u 0) (u 1) = + endpointGramCleared (endpointCertificateS u) (endpointCertificateB u) := by + simp only [DenseEndpoint.gram, DenseBivariatePolynomial.eval_add, + DenseBivariatePolynomial.eval_neg, DenseBivariatePolynomial.eval_scale, + DenseBivariatePolynomial.eval_mul, DenseBivariatePolynomial.eval_pow, + DenseBivariatePolynomial.eval_constant, DenseEndpoint.eval_scaledS, + DenseEndpoint.eval_scaledB, endpointGramCleared] + ring + +private theorem balance_clear_denominator (q K A C : ℝ) (hq : q ≠ 0) : + q ^ 4 * (((K / q) ^ 2 - A - C) ^ 2 - 4 * A * C) = + (K ^ 2 - (A + C) * q ^ 2) ^ 2 - 4 * A * C * q ^ 4 := by + field_simp [hq] + ring + +theorem endpointBalanceCleared_eq (s B : ℝ) (hq : 2 * s + 1 ≠ 0) : + endpointBalanceCleared s B = + (2 * s + 1) ^ 4 * endpointBalanceResidual (2 * s) B := by + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - 4 * s ^ 2 + let K := 6 * s * p + (4 * s ^ 2 - 1) * q + have hR : 6 * s * (p / q) + 4 * s ^ 2 - 1 = K / q := by + field_simp [q, hq] + simp only [K, p] + ring + have hb₀ : 2 * B - 3 * (2 * s) ^ 2 + 2 * (2 * s) - 1 = p := by + simp only [p] + ring + have hD₀ : 4 * (2 * s) ^ 2 - 2 * (2 * s) - B = D := by + simp only [D] + ring + have hc₀ : (2 * s) ^ 2 = 4 * s ^ 2 := by ring + rw [endpointBalanceResidual, hb₀, hD₀, hc₀] + rw [show 3 * (2 * s) * (p / (2 * s + 1)) + 4 * s ^ 2 - 1 = + 6 * s * (p / q) + 4 * s ^ 2 - 1 by simp only [q]; ring] + change endpointBalanceCleared s B = q ^ 4 * + (((6 * s * (p / q) + 4 * s ^ 2 - 1) ^ 2 - A2 - C2) ^ 2 - 4 * A2 * C2) + rw [hR, endpointBalanceCleared] + exact (balance_clear_denominator q K A2 C2 hq).symm + +private theorem gram_clear_denominator (q p x z k : ℝ) (hq : q ≠ 0) : + 4 * q ^ 4 * ((k / (2 * q ^ 2) - x / 4 * (z / (4 * q ^ 2))) ^ 2 - + (1 - (x / 4) ^ 2) * ((p / q) ^ 2 - (z / (4 * q ^ 2)) ^ 2)) = + ((8 * k - x * z) ^ 2 - (16 - x ^ 2) * (16 * p ^ 2 * q ^ 2 - z ^ 2)) / 64 := by + field_simp [hq] + ring + +theorem endpointGramCleared_eq (s B : ℝ) (hq : 2 * s + 1 ≠ 0) : + endpointGramCleared s B = 4 * (2 * s + 1) ^ 4 * endpointGramResidual (2 * s) B := by + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let x := 5 - B ^ 2 + let z := q ^ 2 + 4 * p ^ 2 - D ^ 2 * q ^ 2 + let k := (1 - 4 * s ^ 2) * q ^ 2 + p ^ 2 + have hz : (1 + 4 * (p / q) ^ 2 - D ^ 2) / 4 = z / (4 * q ^ 2) := by + field_simp [q, hq] + simp only [z] + ring + have hk : (1 + (p / q) ^ 2 - 4 * s ^ 2) / 2 = k / (2 * q ^ 2) := by + field_simp [q, hq] + simp only [k] + ring + have hb₀ : 2 * B - 3 * (2 * s) ^ 2 + 2 * (2 * s) - 1 = p := by + simp only [p] + ring + have hD₀ : 4 * (2 * s) ^ 2 - 2 * (2 * s) - B = D := by + simp only [D] + ring + have hc₀ : (2 * s) ^ 2 = 4 * s ^ 2 := by ring + rw [endpointGramResidual, hb₀, hD₀, hc₀] + change endpointGramCleared s B = 4 * q ^ 4 * + (((1 + (p / q) ^ 2 - 4 * s ^ 2) / 2 - (x / 4) * + ((1 + 4 * (p / q) ^ 2 - D ^ 2) / 4)) ^ 2 - + (1 - (x / 4) ^ 2) * ((p / q) ^ 2 - + ((1 + 4 * (p / q) ^ 2 - D ^ 2) / 4) ^ 2)) + rw [hz, hk, endpointGramCleared] + exact (gram_clear_denominator q p x z k hq).symm + +private theorem endpoint_auxiliary_bounds {s B : ℝ} (hsL : (6933 / 10000 : ℝ) < s) + (hsU : s < (6934 / 10000 : ℝ)) (hBL : (28737 / 10000 : ℝ) < B) + (hBU : B < (28738 / 10000 : ℝ)) : + let D := 16 * s ^ 2 - 4 * s - B + let b := (2 * B - 12 * s ^ 2 + 4 * s - 1) / (2 * s + 1) + (73 / 100 : ℝ) < b ∧ b < 74 / 100 ∧ 2 < D ∧ D < 21 / 10 := by + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let b := p / q + have hq : 0 < q := by dsimp [q]; linarith + have hpL : (73 / 100 : ℝ) * q < p := by + dsimp [p, q] + nlinarith [sq_nonneg (s - 6934 / 10000)] + have hpU : p < (74 / 100 : ℝ) * q := by + dsimp [p, q] + nlinarith [sq_nonneg (s - 6933 / 10000)] + have hbL : (73 / 100 : ℝ) < b := (lt_div_iff₀ hq).2 hpL + have hbU : b < (74 / 100 : ℝ) := (div_lt_iff₀ hq).2 hpU + have hDL : (2 : ℝ) < D := by + dsimp [D] + nlinarith [sq_nonneg (s - 6933 / 10000)] + have hDU : D < (21 / 10 : ℝ) := by + dsimp [D] + nlinarith [sq_nonneg (s - 6934 / 10000)] + exact ⟨hbL, hbU, hDL, hDU⟩ + +private theorem endpoint_signs {s B : ℝ} (hsL : (6933 / 10000 : ℝ) < s) + (hsU : s < (6934 / 10000 : ℝ)) (hBL : (28737 / 10000 : ℝ) < B) + (hBU : B < (28738 / 10000 : ℝ)) : + let D := 16 * s ^ 2 - 4 * s - B + let b := (2 * B - 12 * s ^ 2 + 4 * s - 1) / (2 * s + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - 4 * s ^ 2 + let R := 6 * s * b + 4 * s ^ 2 - 1 + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - 4 * s ^ 2) / 2 + 0 < A2 ∧ 0 < C2 ∧ 0 < R ∧ 0 < R ^ 2 - A2 - C2 ∧ + x < 0 ∧ z < 0 ∧ k - x * z < 0 := by + let q := 2 * s + 1 + let p := 2 * B - 12 * s ^ 2 + 4 * s - 1 + let D := 16 * s ^ 2 - 4 * s - B + let b := p / q + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - 4 * s ^ 2 + let R := 6 * s * b + 4 * s ^ 2 - 1 + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - 4 * s ^ 2) / 2 + have hbounds := endpoint_auxiliary_bounds hsL hsU hBL hBU + change (73 / 100 : ℝ) < b ∧ b < 74 / 100 ∧ 2 < D ∧ D < 21 / 10 at hbounds + rcases hbounds with ⟨hbL, hbU, hDL, hDU⟩ + have hA : 0 < A2 := by + dsimp [A2] + nlinarith [sq_nonneg (B - 28737 / 10000)] + have hC : 0 < C2 := by + dsimp [C2] + nlinarith [sq_nonneg B, sq_nonneg D, sq_nonneg s] + have hR : (19 / 5 : ℝ) < R := by + dsimp [R] + nlinarith [mul_pos (sub_pos.mpr hsL) (sub_pos.mpr hbL), sq_nonneg s] + have hAupper : A2 < 4 := by + dsimp [A2] + nlinarith [sq_nonneg (B - 28738 / 10000)] + have hCupper : C2 < (9 / 2 : ℝ) := by + dsimp [C2] + nlinarith [sq_nonneg (B - 28738 / 10000), sq_nonneg (D - 21 / 10), + sq_nonneg (s - 6933 / 10000)] + have hQ : 0 < R ^ 2 - A2 - C2 := by + nlinarith [sq_nonneg (R - 19 / 5)] + have hx : x < 0 := by + dsimp [x] + nlinarith [sq_nonneg (B - 28737 / 10000)] + have hz : z < 0 := by + dsimp [z] + nlinarith [sq_nonneg (b - 74 / 100), sq_nonneg (D - 2)] + have hk : k < 0 := by + dsimp [k] + nlinarith [sq_nonneg (b - 74 / 100), sq_nonneg (s - 6933 / 10000)] + have hkxz : k - x * z < 0 := by + nlinarith [mul_pos (neg_pos.mpr hx) (neg_pos.mpr hz)] + dsimp only [D, b, A2, C2, R, x, z, k] + exact ⟨hA, hC, (by norm_num : (0 : ℝ) < 19 / 5).trans hR, hQ, hx, hz, hkxz⟩ + +private theorem abs_apply_le_one_of_mem_endpointCertificateBox {x : EndpointCertificateSpace} + (hx : x ∈ endpointCertificateBox) (i : Fin 2) : |x i| ≤ 1 := by + rw [← Real.norm_eq_abs] + exact (norm_le_pi_norm x i).trans (by simpa [endpointCertificateBox] using hx) + +/-- The exact coefficient enclosure makes the certificate map preserve its unit box. -/ +theorem endpointCertificateMap_mapsTo : + MapsTo endpointCertificateMap endpointCertificateBox endpointCertificateBox := by + intro x hx + have hx₀ := abs_apply_le_one_of_mem_endpointCertificateBox hx 0 + have hx₁ := abs_apply_le_one_of_mem_endpointCertificateBox hx 1 + rw [endpointCertificateBox, Metric.mem_closedBall, dist_zero_right, + pi_norm_le_iff_of_nonneg zero_le_one] + intro i + rw [Real.norm_eq_abs] + refine (DenseBivariatePolynomial.abs_eval_le_coefficientL1Norm + (DenseEndpoint.fixedMap i) hx₀ hx₁).trans ?_ + exact_mod_cast (endpointMapPolynomial_coefficientL1Norm_lt_one i).le + +private theorem endpointCertificateMap_coordinate_sub_le (i : Fin 2) + {x y : EndpointCertificateSpace} (hx : x ∈ endpointCertificateBox) + (hy : y ∈ endpointCertificateBox) : + |endpointCertificateMap y i - endpointCertificateMap x i| ≤ + (1 / 10 ^ 9 : ℝ) * ‖y - x‖ := by + let p := DenseEndpoint.fixedMap i + let a : ℝ := DenseBivariatePolynomial.coefficientL1Norm + (DenseBivariatePolynomial.derivFirst p) + let b : ℝ := DenseBivariatePolynomial.coefficientL1Norm + (DenseBivariatePolynomial.derivSecond p) + have hx₀ := abs_apply_le_one_of_mem_endpointCertificateBox hx 0 + have hx₁ := abs_apply_le_one_of_mem_endpointCertificateBox hx 1 + have hy₀ := abs_apply_le_one_of_mem_endpointCertificateBox hy 0 + have hy₁ := abs_apply_le_one_of_mem_endpointCertificateBox hy 1 + have h₀ : |y 0 - x 0| ≤ ‖y - x‖ := by + rw [← Real.norm_eq_abs] + simpa only [Pi.sub_apply] using norm_le_pi_norm (y - x) 0 + have h₁ : |y 1 - x 1| ≤ ‖y - x‖ := by + rw [← Real.norm_eq_abs] + simpa only [Pi.sub_apply] using norm_le_pi_norm (y - x) 1 + have ha : |DenseBivariatePolynomial.eval p (y 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (y 1)| ≤ a * |y 0 - x 0| := + DenseBivariatePolynomial.abs_eval_sub_le_derivFirst p hx₀ hy₀ hy₁ + have hb : |DenseBivariatePolynomial.eval p (x 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (x 1)| ≤ b * |y 1 - x 1| := + DenseBivariatePolynomial.abs_eval_sub_le_derivSecond p hx₀ hx₁ hy₁ + have hab : a + b < (1 / 10 ^ 9 : ℝ) := by + dsimp [a, b, p] + have h := endpointMapPolynomial_derivative_coefficientL1Norm_lt i + have h' := (Rat.cast_lt (K := ℝ)).mpr h + norm_num only [Rat.cast_add, Rat.cast_div, Rat.cast_one, Rat.cast_pow, Rat.cast_ofNat] at h' + norm_num at h' ⊢ + exact h' + have ha₀ : 0 ≤ a := by + dsimp [a] + exact_mod_cast DenseBivariatePolynomial.coefficientL1Norm_nonneg + (DenseBivariatePolynomial.derivFirst p) + have hb₀ : 0 ≤ b := by + dsimp [b] + exact_mod_cast DenseBivariatePolynomial.coefficientL1Norm_nonneg + (DenseBivariatePolynomial.derivSecond p) + rw [endpointCertificateMap] + change |DenseBivariatePolynomial.eval p (y 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (x 1)| ≤ _ + calc + _ = |(DenseBivariatePolynomial.eval p (y 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (y 1)) + + (DenseBivariatePolynomial.eval p (x 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (x 1))| := by ring_nf + _ ≤ |DenseBivariatePolynomial.eval p (y 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (y 1)| + + |DenseBivariatePolynomial.eval p (x 0) (y 1) - + DenseBivariatePolynomial.eval p (x 0) (x 1)| := abs_add_le _ _ + _ ≤ a * |y 0 - x 0| + b * |y 1 - x 1| := add_le_add ha hb + _ ≤ a * ‖y - x‖ + b * ‖y - x‖ := add_le_add + (mul_le_mul_of_nonneg_left h₀ ha₀) (mul_le_mul_of_nonneg_left h₁ hb₀) + _ = (a + b) * ‖y - x‖ := by ring + _ ≤ (1 / 10 ^ 9 : ℝ) * ‖y - x‖ := + mul_le_mul_of_nonneg_right hab.le (norm_nonneg _) + +/-- The normalized fixed-point map is Lipschitz with exact constant `10⁻⁹`. -/ +theorem endpointCertificateMap_lipschitzOn : + LipschitzOnWith (1 / 10 ^ 9 : ℝ≥0) endpointCertificateMap endpointCertificateBox := by + apply LipschitzOnWith.of_dist_le_mul + intro x hx y hy + rw [dist_eq_norm, dist_eq_norm] + apply (pi_norm_le_iff_of_nonneg (by positivity)).mpr + intro i + rw [Real.norm_eq_abs, Pi.sub_apply] + exact endpointCertificateMap_coordinate_sub_le i hy hx + +/-- The normalized fixed-point map is a certified strict contraction. -/ +theorem endpointCertificateMap_contracting : + ContractingWith (1 / 10 ^ 9 : ℝ≥0) + (endpointCertificateMap_mapsTo.restrict endpointCertificateMap + endpointCertificateBox endpointCertificateBox) := by + exact ⟨by norm_num, endpointCertificateMap_lipschitzOn.mapsToRestrict + endpointCertificateMap_mapsTo⟩ + +/-- The rational preconditioner as a real linear map. -/ +def endpointCertificatePreconditioner : + EndpointCertificateSpace →ₗ[ℝ] EndpointCertificateSpace where + toFun y := ![68748375835 * y 0 + 4033169260133 * y 1, + 104924796527 * y 0 + 2365005784960 * y 1] + map_add' := by + intro x y + funext i + fin_cases i <;> simp <;> ring + map_smul' := by + intro a x + funext i + fin_cases i <;> simp <;> ring + +theorem endpointCertificateMap_eq_update (x : EndpointCertificateSpace) : + endpointCertificateMap x = + x - endpointCertificatePreconditioner (endpointCertificateSystem x) := by + funext i + fin_cases i <;> + simp [endpointCertificateMap, endpointCertificateSystem, endpointCertificatePreconditioner, + DenseEndpoint.fixedMap, DenseBivariatePolynomial.eval_add, + DenseBivariatePolynomial.eval_neg, DenseBivariatePolynomial.eval_scale, + DenseBivariatePolynomial.eval_first, DenseBivariatePolynomial.eval_second] <;> ring + +theorem endpointCertificatePreconditioner_injective : + Function.Injective endpointCertificatePreconditioner := by + intro x y h + have h₀ := congrFun h 0 + have h₁ := congrFun h 1 + change 68748375835 * x 0 + 4033169260133 * x 1 = + 68748375835 * y 0 + 4033169260133 * y 1 at h₀ + change 104924796527 * x 0 + 2365005784960 * x 1 = + 104924796527 * y 0 + 2365005784960 * y 1 at h₁ + funext i + fin_cases i + · change x 0 = y 0 + linarith [h₀, h₁] + · change x 1 = y 1 + linarith [h₀, h₁] + +/-- The exact contraction certificate isolates a unique normalized fixed point. -/ +theorem existsUnique_endpointCertificate_fixedPoint : + ∃! x, x ∈ endpointCertificateBox ∧ IsFixedPt endpointCertificateMap x := by + refine existsUnique_fixedPoint_mem (K := (1 / 10 ^ 9 : ℝ≥0)) + ⟨0, by simp [endpointCertificateBox]⟩ + Metric.isClosed_closedBall.isComplete endpointCertificateMap_mapsTo ?_ + simpa only using endpointCertificateMap_contracting + +/-- The exact certificate isolates a unique zero of the cleared endpoint system. -/ +theorem existsUnique_endpointCertificate_zero : + ∃! x, x ∈ endpointCertificateBox ∧ endpointCertificateSystem x = 0 := by + refine existsUnique_zero_of_contracting_preconditioner + (K := (1 / 10 ^ 9 : ℝ≥0)) ⟨0, by simp [endpointCertificateBox]⟩ + Metric.isClosed_closedBall.isComplete endpointCertificateMap_mapsTo ?_ + (fun x _ ↦ endpointCertificateMap_eq_update x) + endpointCertificatePreconditioner_injective + simpa only using endpointCertificateMap_contracting + +private theorem endpointCertificate_coordinate_lt_one {u : EndpointCertificateSpace} + (hu : u ∈ endpointCertificateBox) (hfixed : endpointCertificateMap u = u) (i : Fin 2) : + |u i| < 1 := by + rw [← congrFun hfixed i] + exact (DenseBivariatePolynomial.abs_eval_le_coefficientL1Norm + (DenseEndpoint.fixedMap i) (abs_apply_le_one_of_mem_endpointCertificateBox hu 0) + (abs_apply_le_one_of_mem_endpointCertificateBox hu 1)).trans_lt + (by exact_mod_cast endpointMapPolynomial_coefficientL1Norm_lt_one i) + +private theorem isEndpointPolynomialPair_of_endpointCertificate_zero + {u : EndpointCertificateSpace} (hu : u ∈ endpointCertificateBox) + (hzero : endpointCertificateSystem u = 0) : + IsEndpointPolynomialPair (2 * endpointCertificateS u) (endpointCertificateB u) := by + let s := endpointCertificateS u + let B := endpointCertificateB u + have hfixed : endpointCertificateMap u = u := by + rw [endpointCertificateMap_eq_update, hzero, map_zero, sub_zero] + have hu₀ := abs_lt.mp (endpointCertificate_coordinate_lt_one hu hfixed 0) + have hu₁ := abs_lt.mp (endpointCertificate_coordinate_lt_one hu hfixed 1) + have hsL : 6933064218259048 / 10 ^ 16 < s := by + dsimp [s, endpointCertificateS] + norm_num at hu₀ ⊢ + linarith + have hsU : s < 6933064218259050 / 10 ^ 16 := by + dsimp [s, endpointCertificateS] + norm_num at hu₀ ⊢ + linarith + have hBL : 2873744161801659 / 10 ^ 15 < B := by + dsimp [B, endpointCertificateB] + norm_num at hu₁ ⊢ + linarith + have hBU : B < 2873744161801662 / 10 ^ 15 := by + dsimp [B, endpointCertificateB] + norm_num at hu₁ ⊢ + linarith + have hq : 2 * s + 1 ≠ 0 := by + have : 0 < s := by norm_num at hsL ⊢; linarith + positivity + have hbalance := congrFun hzero 0 + have hgram := congrFun hzero 1 + change DenseBivariatePolynomial.eval DenseEndpoint.balance (u 0) (u 1) = 0 at hbalance + change DenseBivariatePolynomial.eval DenseEndpoint.gram (u 0) (u 1) = 0 at hgram + rw [DenseEndpoint.eval_balance, endpointBalanceCleared_eq _ _ hq] at hbalance + rw [DenseEndpoint.eval_gram, endpointGramCleared_eq _ _ hq] at hgram + have hbalance' : endpointBalanceResidual (2 * s) B = 0 := by + exact (mul_eq_zero.mp hbalance).resolve_left (pow_ne_zero 4 hq) + have hgram' : endpointGramResidual (2 * s) B = 0 := by + rcases mul_eq_zero.mp hgram with hcoeff | hres + · have hpow := (mul_eq_zero.mp hcoeff).resolve_left (by norm_num : (4 : ℝ) ≠ 0) + exact (pow_ne_zero 4 hq hpow).elim + · exact hres + have hsigns := endpoint_signs (s := s) (B := B) + (by norm_num at hsL ⊢; linarith) (by norm_num at hsU ⊢; linarith) + (by norm_num at hBL ⊢; linarith) (by norm_num at hBU ⊢; linarith) + dsimp only [IsEndpointPolynomialPair] + refine ⟨by nlinarith [hsL], by nlinarith [hsU], hBL, hBU, ?_, ?_, ?_, ?_, + hbalance', hgram', ?_, ?_, ?_⟩ + · exact hsigns.1 + · convert hsigns.2.1 using 1; ring + · convert hsigns.2.2.1 using 1; ring + · convert hsigns.2.2.2.1 using 1; ring + · exact hsigns.2.2.2.2.1 + · convert hsigns.2.2.2.2.2.1 using 1; ring + · convert hsigns.2.2.2.2.2.2 using 1; ring + +/-- There exists an endpoint polynomial pair in the stated strict rational box. -/ +theorem exists_isEndpointPolynomialPair : ∃ c B : ℝ, IsEndpointPolynomialPair c B := by + obtain ⟨u, hu, -⟩ := existsUnique_endpointCertificate_zero + exact ⟨2 * endpointCertificateS u, endpointCertificateB u, + isEndpointPolynomialPair_of_endpointCertificate_zero hu.1 hu.2⟩ + +/-- Normalize a pair `(c, B)` into the centered certificate coordinates. -/ +def endpointCertificateCoordinates (c B : ℝ) : EndpointCertificateSpace := + ![10 ^ 16 * (c / 2 - 6933064218259049 / 10 ^ 16), + (2 * 10 ^ 15 / 3) * (B - 5747488323603321 / (2 * 10 ^ 15))] + +@[simp] +theorem endpointCertificateS_coordinates (c B : ℝ) : + endpointCertificateS (endpointCertificateCoordinates c B) = c / 2 := by + simp [endpointCertificateS, endpointCertificateCoordinates] + +@[simp] +theorem endpointCertificateB_coordinates (c B : ℝ) : + endpointCertificateB (endpointCertificateCoordinates c B) = B := by + simp [endpointCertificateB, endpointCertificateCoordinates] + ring + +private theorem endpointCertificateCoordinates_mem_box {c B : ℝ} + (hcL : 13866128436518096 / 10 ^ 16 < c) + (hcU : c < 13866128436518100 / 10 ^ 16) + (hBL : 2873744161801659 / 10 ^ 15 < B) + (hBU : B < 2873744161801662 / 10 ^ 15) : + endpointCertificateCoordinates c B ∈ endpointCertificateBox := by + rw [endpointCertificateBox, Metric.mem_closedBall, dist_zero_right, + pi_norm_le_iff_of_nonneg zero_le_one] + intro i + fin_cases i <;> rw [Real.norm_eq_abs, abs_le] <;> + constructor <;> simp only [endpointCertificateCoordinates] <;> + norm_num at hcL hcU hBL hBU ⊢ <;> linarith + +private theorem endpointCertificateSystem_coordinates_eq_zero {c B : ℝ} (hc : 0 < c) + (hbalance : endpointBalanceResidual c B = 0) + (hgram : endpointGramResidual c B = 0) : + endpointCertificateSystem (endpointCertificateCoordinates c B) = 0 := by + have hq : 2 * (c / 2) + 1 ≠ 0 := by nlinarith + have hc₂ : 2 * (c / 2) = c := by ring + funext i + fin_cases i + · change DenseBivariatePolynomial.eval DenseEndpoint.balance + (endpointCertificateCoordinates c B 0) (endpointCertificateCoordinates c B 1) = 0 + rw [DenseEndpoint.eval_balance, endpointCertificateS_coordinates, + endpointCertificateB_coordinates, endpointBalanceCleared_eq _ _ hq, hc₂, hbalance, + mul_zero] + · change DenseBivariatePolynomial.eval DenseEndpoint.gram + (endpointCertificateCoordinates c B 0) (endpointCertificateCoordinates c B 1) = 0 + rw [DenseEndpoint.eval_gram, endpointCertificateS_coordinates, + endpointCertificateB_coordinates, endpointGramCleared_eq _ _ hq, hc₂, hgram, mul_zero] + +private theorem endpointCertificate_of_isEndpointPolynomialPair {c B : ℝ} + (h : IsEndpointPolynomialPair c B) : + endpointCertificateCoordinates c B ∈ endpointCertificateBox ∧ + endpointCertificateSystem (endpointCertificateCoordinates c B) = 0 := by + simp only [IsEndpointPolynomialPair] at h + rcases h with ⟨hcL, hcU, hBL, hBU, -, -, -, -, hbalance, hgram, -, -, -⟩ + exact ⟨endpointCertificateCoordinates_mem_box hcL hcU hBL hBU, + endpointCertificateSystem_coordinates_eq_zero + (by norm_num at hcL ⊢; linarith) hbalance hgram⟩ + +/-- The signed polynomial endpoint system has exactly one solution in its stated box. -/ +theorem existsUnique_isEndpointPolynomialPair : + ∃! p : ℝ × ℝ, IsEndpointPolynomialPair p.1 p.2 := by + obtain ⟨u, hu, hunique⟩ := existsUnique_endpointCertificate_zero + let p : ℝ × ℝ := (2 * endpointCertificateS u, endpointCertificateB u) + have hp : IsEndpointPolynomialPair p.1 p.2 := + isEndpointPolynomialPair_of_endpointCertificate_zero hu.1 hu.2 + refine ⟨p, hp, ?_⟩ + intro q hq + have heq := hunique (endpointCertificateCoordinates q.1 q.2) + (endpointCertificate_of_isEndpointPolynomialPair hq) + apply Prod.ext + · have hs := congrArg endpointCertificateS heq + rw [endpointCertificateS_coordinates] at hs + change q.1 = 2 * endpointCertificateS u + nlinarith + · have hB := congrArg endpointCertificateB heq + rw [endpointCertificateB_coordinates] at hB + exact hB + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/Krawczyk.lean b/LeanPool/Besicovitch/Certificates/Krawczyk.lean new file mode 100644 index 0000000000..9730002783 --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/Krawczyk.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.Normed.Module.Basic +public import Mathlib.Topology.MetricSpace.Contracting + +/-! +# Contraction certificates + +This file gives the small fixed-point argument used by a Krawczyk certificate. A contraction +which preserves a complete nonempty set has a unique fixed point there. If the contraction is a +preconditioned Newton map, that fixed point is the unique zero in the set. +-/ + +@[expose] public section + +open Function NNReal Set + +namespace LeanPool.Besicovitch + +section FixedPoint + +variable {E : Type*} [MetricSpace E] {K : ℝ≥0} {T : E → E} {box : Set E} + +/-- A contraction preserving a complete nonempty set has exactly one fixed point in that set. -/ +theorem existsUnique_fixedPoint_mem (hbox : box.Nonempty) (hcomplete : IsComplete box) + (hmaps : MapsTo T box box) + (hcontract : ContractingWith K (hmaps.restrict T box box)) : + ∃! x, x ∈ box ∧ IsFixedPt T x := by + obtain ⟨x, hx⟩ := hbox + obtain ⟨y, hy, hy_fixed, -, -⟩ := + hcontract.exists_fixedPoint' hcomplete hmaps hx (edist_ne_top x (T x)) + refine ⟨y, ⟨hy, hy_fixed⟩, ?_⟩ + intro z hz + let y' : box := ⟨y, hy⟩ + let z' : box := ⟨z, hz.1⟩ + have hy' : IsFixedPt (hmaps.restrict T box box) y' := by + apply Subtype.ext + exact hy_fixed + have hz' : IsFixedPt (hmaps.restrict T box box) z' := by + apply Subtype.ext + exact hz.2 + exact congrArg Subtype.val (hcontract.fixedPoint_unique' hz' hy') + +end FixedPoint + +section PreconditionedZero + +variable {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] + {K : ℝ≥0} {F T : E → E} {R : E →ₗ[ℝ] E} {box : Set E} + +/-- A certified preconditioned contraction isolates a unique zero of `F` in `box`. -/ +theorem existsUnique_zero_of_contracting_preconditioner (hbox : box.Nonempty) + (hcomplete : IsComplete box) (hmaps : MapsTo T box box) + (hcontract : ContractingWith K (hmaps.restrict T box box)) + (hupdate : ∀ x ∈ box, T x = x - R (F x)) (hR : Injective R) : + ∃! x, x ∈ box ∧ F x = 0 := by + obtain ⟨x, hx, hx_unique⟩ := + existsUnique_fixedPoint_mem hbox hcomplete hmaps hcontract + have hzero : F x = 0 := by + apply hR + rw [map_zero] + exact sub_eq_self.mp ((hupdate x hx.1).symm.trans hx.2) + refine ⟨x, ⟨hx.1, hzero⟩, ?_⟩ + intro y hy + apply hx_unique y + refine ⟨hy.1, ?_⟩ + change T y = y + rw [hupdate y hy.1, hy.2, map_zero, sub_zero] + +end PreconditionedZero + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/RadicalInterval.lean b/LeanPool/Besicovitch/Certificates/RadicalInterval.lean new file mode 100644 index 0000000000..f9214dd7c0 --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/RadicalInterval.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Certificates.RationalInterval +public import Mathlib.Analysis.Real.Sqrt + +/-! +# Exact interval arithmetic for radical expressions + +A square-root node carries rational lower and upper witnesses. The evaluator checks their +squares exactly, so every successful enclosure has a kernel-checked real-number semantics. +-/ + +@[expose] public section + +open Set + +namespace LeanPool.Besicovitch + +/-- Rational expressions with explicitly certified square-root bounds. -/ +inductive RadicalExpression (n : ℕ) where + | var : Fin n → RadicalExpression n + | literal : ℚ → RadicalExpression n + | add : RadicalExpression n → RadicalExpression n → RadicalExpression n + | neg : RadicalExpression n → RadicalExpression n + | mul : RadicalExpression n → RadicalExpression n → RadicalExpression n + | inv : RadicalExpression n → RadicalExpression n + | sqrt : RadicalExpression n → ℚ → ℚ → RadicalExpression n + +namespace RadicalExpression + +/-- Evaluate a radical expression in a real environment. -/ +noncomputable def eval {n : ℕ} : RadicalExpression n → (Fin n → ℝ) → ℝ + | .var i, x => x i + | .literal q, _ => q + | .add f g, x => f.eval x + g.eval x + | .neg f, x => -f.eval x + | .mul f g, x => f.eval x * g.eval x + | .inv f, x => (f.eval x)⁻¹ + | .sqrt f _ _, x => Real.sqrt (f.eval x) + +/-- Evaluate by exact rational intervals, rejecting unsafe inverses or square-root witnesses. -/ +def enclosure {n : ℕ} : RadicalExpression n → (Fin n → RationalInterval) → + Option RationalInterval + | .var i, X => some (X i) + | .literal q, _ => some (.singleton q) + | .add f g, X => do + let I ← f.enclosure X + let J ← g.enclosure X + return I.add J + | .neg f, X => do + let I ← f.enclosure X + return I.neg + | .mul f g, X => do + let I ← f.enclosure X + let J ← g.enclosure X + return I.mul J + | .inv f, X => do + let I ← f.enclosure X + if h : 0 < I.lower ∨ I.upper < 0 then return I.inv h else none + | .sqrt f lower upper, X => do + let I ← f.enclosure X + if h : 0 ≤ I.lower ∧ 0 ≤ lower ∧ lower ≤ upper ∧ + lower * lower ≤ I.lower ∧ I.upper ≤ upper * upper then + return ⟨lower, upper, h.2.2.1⟩ + else none + +/-- Check an enclosure and widen it to a simpler rational target interval. -/ +def enclosureWithin {n : ℕ} (f : RadicalExpression n) (X : Fin n → RationalInterval) + (target : RationalInterval) : Option RationalInterval := do + let I ← f.enclosure X + if target.lower ≤ I.lower ∧ I.upper ≤ target.upper then some target else none + +/-- Decide whether the computed enclosure lies in a given rational target interval. -/ +def certifiesWithin {n : ℕ} (f : RadicalExpression n) (X : Fin n → RationalInterval) + (target : RationalInterval) : Bool := + match f.enclosure X with + | none => false + | some I => decide (target.lower ≤ I.lower ∧ I.upper ≤ target.upper) + +/-- Every successful radical enclosure contains the real value of the expression. -/ +theorem enclosure_sound {n : ℕ} {f : RadicalExpression n} + {X : Fin n → RationalInterval} {x : Fin n → ℝ} + (hx : ∀ i, (X i).Contains (x i)) {I : RationalInterval} (hI : f.enclosure X = some I) : + I.Contains (f.eval x) := by + induction f generalizing I with + | var i => + simp only [enclosure, Option.some.injEq] at hI + subst I + exact hx i + | literal q => + simp only [enclosure, Option.some.injEq] at hI + subst I + exact RationalInterval.singleton_contains q + | add f g hf hg => + change ((f.enclosure X).bind fun If ↦ + (g.enclosure X).bind fun Ig ↦ some (If.add Ig)) = some I at hI + obtain ⟨If, hfI, hI⟩ := Option.bind_eq_some_iff.mp hI + obtain ⟨Ig, hgI, hI⟩ := Option.bind_eq_some_iff.mp hI + cases Option.some.inj hI + exact RationalInterval.add_contains (hf hfI) (hg hgI) + | neg f hf => + change ((f.enclosure X).bind fun If ↦ some If.neg) = some I at hI + obtain ⟨If, hfI, hI⟩ := Option.bind_eq_some_iff.mp hI + cases Option.some.inj hI + exact RationalInterval.neg_contains (hf hfI) + | mul f g hf hg => + change ((f.enclosure X).bind fun If ↦ + (g.enclosure X).bind fun Ig ↦ some (If.mul Ig)) = some I at hI + obtain ⟨If, hfI, hI⟩ := Option.bind_eq_some_iff.mp hI + obtain ⟨Ig, hgI, hI⟩ := Option.bind_eq_some_iff.mp hI + cases Option.some.inj hI + exact RationalInterval.mul_contains (hf hfI) (hg hgI) + | inv f hf => + simp only [enclosure] at hI + cases hfI : f.enclosure X with + | none => simp [hfI] at hI + | some If => + rw [hfI] at hI + dsimp at hI + split at hI + · rename_i h + simp only [Option.some.injEq] at hI + subst I + exact RationalInterval.inv_contains (hf hfI) h + · contradiction + | sqrt f lower upper hf => + simp only [enclosure] at hI + cases hfI : f.enclosure X with + | none => simp [hfI] at hI + | some If => + rw [hfI] at hI + dsimp at hI + split at hI + · rename_i h + simp only [Option.some.injEq] at hI + subst I + have hfx := hf hfI + constructor + · norm_num [RationalInterval.Contains] at hfx ⊢ + apply Real.le_sqrt_of_sq_le + have hlower : (↑lower : ℝ) ^ 2 ≤ ↑If.lower := by + norm_num [pow_two] + exact_mod_cast h.2.2.2.1 + exact hlower.trans hfx.1 + · apply (Real.sqrt_le_iff).2 + constructor + · exact_mod_cast h.2.1.trans h.2.2.1 + · norm_num [RationalInterval.Contains] at hfx ⊢ + have hupper : (↑If.upper : ℝ) ≤ (↑upper : ℝ) ^ 2 := by + norm_num [pow_two] + exact_mod_cast h.2.2.2.2 + exact hfx.2.trans hupper + · contradiction + +/-- A successful widened enclosure contains the real value of the expression. -/ +theorem enclosureWithin_sound {n : ℕ} {f : RadicalExpression n} + {X : Fin n → RationalInterval} {x : Fin n → ℝ} (hx : ∀ i, (X i).Contains (x i)) + {target : RationalInterval} (h : f.enclosureWithin X target = some target) : + target.Contains (f.eval x) := by + unfold enclosureWithin at h + cases hI : f.enclosure X with + | none => simp [hI] at h + | some I => + rw [hI] at h + dsimp at h + split at h + · rename_i hsub + have hvalue := enclosure_sound hx hI + constructor + · have hlower : (target.lower : ℝ) ≤ I.lower := by exact_mod_cast hsub.1 + exact hlower.trans hvalue.1 + · have hupper : (I.upper : ℝ) ≤ target.upper := by exact_mod_cast hsub.2 + exact hvalue.2.trans hupper + · contradiction + +/-- A successful Boolean certificate encloses the real value of the expression. -/ +theorem certifiesWithin_sound {n : ℕ} {f : RadicalExpression n} + {X : Fin n → RationalInterval} {x : Fin n → ℝ} (hx : ∀ i, (X i).Contains (x i)) + {target : RationalInterval} (h : f.certifiesWithin X target = true) : + target.Contains (f.eval x) := by + unfold certifiesWithin at h + cases hI : f.enclosure X with + | none => simp [hI] at h + | some I => + rw [hI] at h + have hsub := of_decide_eq_true h + have hvalue := enclosure_sound hx hI + constructor + · have hlower : (target.lower : ℝ) ≤ I.lower := by exact_mod_cast hsub.1 + exact hlower.trans hvalue.1 + · have hupper : (I.upper : ℝ) ≤ target.upper := by exact_mod_cast hsub.2 + exact hvalue.2.trans hupper + +end RadicalExpression + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Certificates/RationalInterval.lean b/LeanPool/Besicovitch/Certificates/RationalInterval.lean new file mode 100644 index 0000000000..3ed6303357 --- /dev/null +++ b/LeanPool/Besicovitch/Certificates/RationalInterval.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Basic.Real.Basic +public import Mathlib.Tactic.Linarith +public import Mathlib.Tactic.NormNum + +/-! +# Exact rational interval arithmetic + +The intervals in this file have rational endpoints, while their semantics is over the real +numbers. The operations provide the enclosure primitives used by the radical-expression evaluator, +with soundness checked by the kernel. +-/ + +@[expose] public section + +open Set + +namespace LeanPool.Besicovitch + +/-- A nonempty closed interval with rational endpoints. -/ +structure RationalInterval where + /-- The lower rational endpoint. -/ + lower : ℚ + /-- The upper rational endpoint. -/ + upper : ℚ + lower_le_upper : lower ≤ upper + +namespace RationalInterval + +/-- A real number belongs to a rational interval. -/ +def Contains (I : RationalInterval) (x : ℝ) : Prop := + (I.lower : ℝ) ≤ x ∧ x ≤ (I.upper : ℝ) + +/-- The degenerate interval containing one rational number. -/ +def singleton (q : ℚ) : RationalInterval := + ⟨q, q, le_rfl⟩ + +/-- The interval sum. -/ +def add (I J : RationalInterval) : RationalInterval := + ⟨I.lower + J.lower, I.upper + J.upper, add_le_add I.lower_le_upper J.lower_le_upper⟩ + +/-- The additive inverse of an interval. -/ +def neg (I : RationalInterval) : RationalInterval := + ⟨-I.upper, -I.lower, neg_le_neg I.lower_le_upper⟩ + +/-- The smallest interval whose endpoints include all four endpoint products. -/ +def mul (I J : RationalInterval) : RationalInterval where + lower := min (min (I.lower * J.lower) (I.lower * J.upper)) + (min (I.upper * J.lower) (I.upper * J.upper)) + upper := max (max (I.lower * J.lower) (I.lower * J.upper)) + (max (I.upper * J.lower) (I.upper * J.upper)) + lower_le_upper := + (min_le_left _ _).trans <| (min_le_left _ _).trans <| + (le_max_left _ _).trans (le_max_left _ _) + +/-- Natural powers of a rational interval. -/ +def pow (I : RationalInterval) : ℕ → RationalInterval + | 0 => singleton 1 + | n + 1 => (pow I n).mul I + +/-- An interval which avoids zero has a well-defined reciprocal interval. -/ +def inv (I : RationalInterval) (h : 0 < I.lower ∨ I.upper < 0) : RationalInterval where + lower := 1 / I.upper + upper := 1 / I.lower + lower_le_upper := by + rcases h with h | h + · exact one_div_le_one_div_of_le h I.lower_le_upper + · exact one_div_le_one_div_of_neg_of_le h I.lower_le_upper + +theorem singleton_contains (q : ℚ) : (singleton q).Contains q := by + simp [Contains, singleton] + +theorem add_contains {I J : RationalInterval} {x y : ℝ} + (hx : I.Contains x) (hy : J.Contains y) : (I.add J).Contains (x + y) := by + constructor <;> norm_num [Contains, add] at hx hy ⊢ <;> linarith + +theorem neg_contains {I : RationalInterval} {x : ℝ} (hx : I.Contains x) : + I.neg.Contains (-x) := by + constructor <;> norm_num [Contains, neg] at hx ⊢ <;> linarith + +private theorem mul_mem_Icc {a b c d x y : ℝ} (hx : x ∈ Icc a b) (hy : y ∈ Icc c d) : + min (min (a * c) (a * d)) (min (b * c) (b * d)) ≤ x * y ∧ + x * y ≤ max (max (a * c) (a * d)) (max (b * c) (b * d)) := by + have hLac : min (min (a * c) (a * d)) (min (b * c) (b * d)) ≤ a * c := + (min_le_left _ _).trans (min_le_left _ _) + have hLad : min (min (a * c) (a * d)) (min (b * c) (b * d)) ≤ a * d := + (min_le_left _ _).trans (min_le_right _ _) + have hLbc : min (min (a * c) (a * d)) (min (b * c) (b * d)) ≤ b * c := + (min_le_right _ _).trans (min_le_left _ _) + have hLbd : min (min (a * c) (a * d)) (min (b * c) (b * d)) ≤ b * d := + (min_le_right _ _).trans (min_le_right _ _) + have hUac : a * c ≤ max (max (a * c) (a * d)) (max (b * c) (b * d)) := + (le_max_left _ _).trans (le_max_left _ _) + have hUad : a * d ≤ max (max (a * c) (a * d)) (max (b * c) (b * d)) := + (le_max_right _ _).trans (le_max_left _ _) + have hUbc : b * c ≤ max (max (a * c) (a * d)) (max (b * c) (b * d)) := + (le_max_left _ _).trans (le_max_right _ _) + have hUbd : b * d ≤ max (max (a * c) (a * d)) (max (b * c) (b * d)) := + (le_max_right _ _).trans (le_max_right _ _) + constructor + · by_cases hy0 : 0 ≤ y + · have haxy : a * y ≤ x * y := mul_le_mul_of_nonneg_right hx.1 hy0 + by_cases ha0 : 0 ≤ a + · exact hLac.trans <| (mul_le_mul_of_nonneg_left hy.1 ha0).trans haxy + · exact hLad.trans <| (mul_le_mul_of_nonpos_left hy.2 (le_of_not_ge ha0)).trans haxy + · have hbxy : b * y ≤ x * y := mul_le_mul_of_nonpos_right hx.2 (le_of_not_ge hy0) + by_cases hb0 : 0 ≤ b + · exact hLbc.trans <| (mul_le_mul_of_nonneg_left hy.1 hb0).trans hbxy + · exact hLbd.trans <| (mul_le_mul_of_nonpos_left hy.2 (le_of_not_ge hb0)).trans hbxy + · by_cases hy0 : 0 ≤ y + · have hxyb : x * y ≤ b * y := mul_le_mul_of_nonneg_right hx.2 hy0 + by_cases hb0 : 0 ≤ b + · exact hxyb.trans <| (mul_le_mul_of_nonneg_left hy.2 hb0).trans hUbd + · exact hxyb.trans <| (mul_le_mul_of_nonpos_left hy.1 (le_of_not_ge hb0)).trans hUbc + · have hxya : x * y ≤ a * y := mul_le_mul_of_nonpos_right hx.1 (le_of_not_ge hy0) + by_cases ha0 : 0 ≤ a + · exact hxya.trans <| (mul_le_mul_of_nonneg_left hy.2 ha0).trans hUad + · exact hxya.trans <| (mul_le_mul_of_nonpos_left hy.1 (le_of_not_ge ha0)).trans hUac + +theorem mul_contains {I J : RationalInterval} {x y : ℝ} + (hx : I.Contains x) (hy : J.Contains y) : (I.mul J).Contains (x * y) := by + simpa only [Contains, mul, Rat.cast_min, Rat.cast_max, Rat.cast_mul] using + mul_mem_Icc hx hy + +/-- Interval powers contain the corresponding real powers. -/ +theorem pow_contains {I : RationalInterval} {x : ℝ} (hx : I.Contains x) : + ∀ n, (I.pow n).Contains (x ^ n) + | 0 => by simpa [pow] using singleton_contains 1 + | n + 1 => by + simpa [pow, pow_succ] using mul_contains (pow_contains hx n) hx + +theorem inv_contains {I : RationalInterval} {x : ℝ} (hx : I.Contains x) + (h : 0 < I.lower ∨ I.upper < 0) : (I.inv h).Contains x⁻¹ := by + change (↑(1 / I.upper) : ℝ) ≤ x⁻¹ ∧ x⁻¹ ≤ ↑(1 / I.lower) + norm_num only [Rat.cast_div, Rat.cast_one] + norm_num [Contains] at hx + rcases h with h | h + · have hl : 0 < x := lt_of_lt_of_le (by exact_mod_cast h) hx.1 + constructor + · simpa [one_div] using one_div_le_one_div_of_le hl hx.2 + · simpa [one_div] using one_div_le_one_div_of_le (by exact_mod_cast h) hx.1 + · have hu : x < 0 := lt_of_le_of_lt hx.2 (by exact_mod_cast h) + constructor + · simpa [one_div] using + one_div_le_one_div_of_neg_of_le (by exact_mod_cast h) hx.2 + · simpa [one_div] using one_div_le_one_div_of_neg_of_le hu hx.1 + +end RationalInterval + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Example/Avoid.lean b/LeanPool/Besicovitch/Example/Avoid.lean new file mode 100644 index 0000000000..fa7215fbc6 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Avoid.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Plane +public import Mathlib.Topology.MetricSpace.Lipschitz + +/-! +# Where a Lipschitz piece of the graph can live + +If `g` is `L`-Lipschitz on a set `A`, then `A` cannot meet both sides of a level-`n` grid point +within `margin L n = cellLength n / (2 n (L + 1))`: two such points sit in adjacent cells, so `g` +jumps by at least `cellLength n / n` between them by (E2), while the Lipschitz bound allows less. + +`avoid L n` is the set of points at distance at least `margin L n` from every level-`n` grid +point. Its intersection with any cell of level `m ≥ n` is order-connected, because every +level-`n` grid point is a level-`m` grid point and hence lies outside the interior of that cell. +-/ + +@[expose] public section + +noncomputable section + +open Set +open scoped NNReal + +namespace LeanPool.Besicovitch.Example + +/-- Half the width of the strip around a level-`n` grid point that `A` cannot straddle. -/ +def margin (L : ℝ) (n : ℕ) : ℝ := cellLength n / (2 * n * (L + 1)) + +/-- The level-`n` grid point with index `i`. -/ +def gridPoint (n : ℕ) (i : ℤ) : ℝ := i * cellLength n + +/-- Points at distance at least `margin L n` from every level-`n` grid point. -/ +def avoid (L : ℝ) (n : ℕ) : Set ℝ := {x | ∀ i : ℤ, margin L n ≤ |x - gridPoint n i|} + +theorem margin_pos {L : ℝ} (hL : 0 ≤ L) {n : ℕ} (hn : 1 ≤ n) : 0 < margin L n := by + unfold margin + have : (0 : ℝ) < n := by exact_mod_cast hn + exact div_pos (cellLength_pos n) (by positivity) + +theorem margin_le_half {L : ℝ} (hL : 0 ≤ L) {n : ℕ} (hn : 1 ≤ n) : + margin L n ≤ cellLength n / 2 := by + unfold margin + have hn' : (1 : ℝ) ≤ n := by exact_mod_cast hn + have hpos := cellLength_pos n + have h2 : (2 : ℝ) ≤ 2 * n * (L + 1) := by + nlinarith [mul_nonneg (by linarith : (0 : ℝ) ≤ n) hL] + exact div_le_div_of_nonneg_left hpos.le (by norm_num) h2 + +/-- The Lipschitz bound across a strip of width `2 * margin` is below the jump +`cellLength n / n`. -/ +theorem lipschitz_strip_lt {L : ℝ} (hL : 0 ≤ L) {n : ℕ} (hn : 1 ≤ n) : + L * (2 * margin L n) < cellLength n / n := by + have hn' : (0 : ℝ) < n := by exact_mod_cast hn + have hpos := cellLength_pos n + have hL1 : (0 : ℝ) < L + 1 := by linarith + have h : L * (2 * margin L n) = cellLength n / n * (L / (L + 1)) := by + unfold margin; field_simp + rw [h] + have : L / (L + 1) < 1 := (div_lt_one hL1).mpr (by linarith) + exact mul_lt_of_lt_one_right (by positivity) this + +/-- **Key lemma.** A set on which `g` is `L`-Lipschitz meets at most one side of a grid point. -/ +theorem not_both_sides {L : ℝ≥0} {A : Set ℝ} (hg : LipschitzOnWith L besicovitchFun A) + {n : ℕ} (hn : 1 ≤ n) (i : ℤ) {x y : ℝ} (hx : x ∈ A) (hy : y ∈ A) + (hx' : x ∈ Ioo (gridPoint n i - margin L n) (gridPoint n i)) + (hy' : y ∈ Ico (gridPoint n i) (gridPoint n i + margin L n)) : False := by + have hL : (0 : ℝ) ≤ L := L.coe_nonneg + have hm := margin_le_half hL hn + have hpos := cellLength_pos n + -- `x` lies in cell `i - 1` and `y` in cell `i` + have hcx : cellIndex n x = i - 1 := by + rw [← mem_cell_iff, cell, mem_Ico] + simp only [gridPoint, mem_Ioo] at hx' + push_cast + constructor <;> nlinarith + have hcy : cellIndex n y = i := by + rw [← mem_cell_iff, cell, mem_Ico] + simp only [gridPoint, mem_Ico] at hy' + constructor <;> nlinarith + have hadj : cellIndex n y = cellIndex n x + 1 ∨ cellIndex n x = cellIndex n y + 1 := + Or.inl (by rw [hcx, hcy]; ring) + have hjump := le_abs_besicovitchFun_sub hn hadj + have hlip := hg.dist_le_mul x hx y hy + rw [Real.dist_eq, Real.dist_eq] at hlip + have hxy : |x - y| < 2 * margin L n := by + simp only [gridPoint, mem_Ioo, mem_Ico] at hx' hy' + rw [abs_lt]; constructor <;> linarith + have := lipschitz_strip_lt hL hn + have hL' : (L : ℝ) * |x - y| ≤ L * (2 * margin L n) := by gcongr + linarith + +/-! ### Order-connectedness inside coarser cells -/ + +/-- A level-`n` grid point is a level-`m` grid point for every `m ≥ n`. -/ +theorem gridPoint_eq_gridPoint {n m : ℕ} (hnm : n ≤ m) (i : ℤ) : + ∃ k : ℤ, gridPoint n i = gridPoint m k := by + refine ⟨i * (2 ^ (m ^ 2 - n ^ 2) : ℕ), ?_⟩ + unfold gridPoint + rw [cellLength_eq_mul hnm] + push_cast + ring + +/-- A level-`m` grid point is not strictly inside a level-`m` cell. -/ +theorem gridPoint_le_or_ge (m : ℕ) (k j : ℤ) : + gridPoint m k ≤ j * cellLength m ∨ (j + 1) * cellLength m ≤ gridPoint m k := by + unfold gridPoint + have hpos := cellLength_pos m + rcases le_or_gt k j with h | h + · left; exact mul_le_mul_of_nonneg_right (by exact_mod_cast h) hpos.le + · right; exact mul_le_mul_of_nonneg_right (by exact_mod_cast h) hpos.le + +/-- The avoided set meets every coarser cell in an order-connected set. -/ +theorem ordConnected_avoid_inter_cell (L : ℝ) {n m : ℕ} (hnm : n ≤ m) (j : ℤ) : + (avoid L n ∩ cell m j).OrdConnected := by + refine ⟨fun x hx z hz y hy ↦ ⟨fun i ↦ ?_, ?_⟩⟩ + · -- the grid point lies to the left of `x` or to the right of `z` + obtain ⟨k, hk⟩ := gridPoint_eq_gridPoint hnm i + have hx1 := hx.1 i + have hz1 := hz.1 i + have hxc := hx.2; have hzc := hz.2 + simp only [cell, mem_Ico] at hxc hzc + rcases hy with ⟨hxy, hyz⟩ + rcases gridPoint_le_or_ge m k j with h | h <;> rw [← hk] at h + · -- `p ≤ j α ≤ x ≤ y`, so `|y - p| ≥ |x - p|` + have : gridPoint n i ≤ x := h.trans hxc.1 + rw [abs_of_nonneg (by linarith)] at hx1 ⊢ + linarith + · -- `y ≤ z < (j+1) α ≤ p`, so `|y - p| ≥ |z - p|` + have : z ≤ gridPoint n i := hzc.2.le.trans h + rw [abs_of_nonpos (by linarith)] at hz1 ⊢ + linarith + · exact ordConnected_Ico.out hx.2 hz.2 hy + +theorem isClosed_avoid (L : ℝ) (n : ℕ) : IsClosed (avoid L n) := by + unfold avoid + rw [ofPred_forall] + exact isClosed_iInter fun i ↦ + isClosed_le continuous_const (continuous_id.sub continuous_const).abs + +theorem measurableSet_avoid (L : ℝ) (n : ℕ) : MeasurableSet (avoid L n) := + (isClosed_avoid L n).measurableSet + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Cover.lean b/LeanPool/Besicovitch/Example/Cover.lean new file mode 100644 index 0000000000..e0cc5b37c2 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Cover.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Plane + +/-! +# Covering the graph over an interval + +The graph over `[a, b)` is covered, at level `n`, by the graphs over the level-`n` cells meeting +`[a, b)`. There are at most `(b - a) / cellLength n + 2` of them, each of diameter at most +`2 * cellLength n`, so the Hausdorff measure of the graph over `[a, b)` is at most `2 (b - a)`. +The constant `2` is crude but is all that is needed: the sharp value `1` is never used. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal + +namespace LeanPool.Besicovitch.Example + +/-- The number of level-`n` cells meeting `[a, b)`: from the cell of `a` to the cell of `b`. -/ +def cellCount (n : ℕ) (a b : ℝ) : ℕ := (cellIndex n b - cellIndex n a + 1).toNat + +theorem cellCount_le (n : ℕ) {a b : ℝ} (hab : a ≤ b) : + (cellCount n a b : ℝ) ≤ (b - a) / cellLength n + 2 := by + have hpos := cellLength_pos n + have h1 := Int.floor_le (b / cellLength n) + have h2 := Int.lt_floor_add_one (a / cellLength n) + have hdiv : a / cellLength n ≤ b / cellLength n := by gcongr + have hnn : 0 ≤ cellIndex n b - cellIndex n a + 1 := by + have : cellIndex n a ≤ cellIndex n b := Int.floor_mono hdiv + omega + have hcast : (cellCount n a b : ℝ) = ((cellIndex n b - cellIndex n a + 1 : ℤ) : ℝ) := by + rw [cellCount, ← Int.cast_natCast, Int.toNat_of_nonneg hnn] + rw [hcast] + unfold cellIndex + push_cast + rw [sub_div] + linarith + +/-- Every point of `[a, b)` lies in one of the counted cells. -/ +theorem exists_cell_of_mem {n : ℕ} {a b x : ℝ} (hx : x ∈ Ico a b) : + ∃ k : Fin (cellCount n a b), x ∈ cell n (cellIndex n a + k) := by + have hpos := cellLength_pos n + have hlo : cellIndex n a ≤ cellIndex n x := Int.floor_mono (by gcongr; exact hx.1) + have hhi : cellIndex n x ≤ cellIndex n b := Int.floor_mono (by gcongr; exact hx.2.le) + refine ⟨⟨(cellIndex n x - cellIndex n a).toNat, ?_⟩, ?_⟩ + · unfold cellCount; omega + · rw [mem_cell_iff] + simp only + rw [Int.toNat_of_nonneg (by omega)] + ring + +/-- The graph over `[a, b)` at level `n ≥ 1` is covered by `cellCount` cylinders. -/ +theorem graphMap_image_Ico_subset {n : ℕ} (a b : ℝ) : + graphMap '' Ico a b ⊆ + ⋃ k : Fin (cellCount n a b), graphMap '' cell n (cellIndex n a + k) := by + rintro _ ⟨x, hx, rfl⟩ + obtain ⟨k, hk⟩ := exists_cell_of_mem (n := n) hx + exact mem_iUnion.mpr ⟨k, mem_image_of_mem _ hk⟩ + +/-- **(B≤ on intervals)** The graph over `[a, b)` has Hausdorff measure at most `2 (b - a)`. -/ +theorem hausdorffMeasure_graphMap_image_Ico_le {a b : ℝ} (hab : a ≤ b) : + μH[1] (graphMap '' Ico a b) ≤ ENNReal.ofReal (2 * (b - a)) := by + -- covering at level `n`, with diameters `≤ 2 * cellLength n → 0` + have hr : Tendsto (fun n : ℕ ↦ ENNReal.ofReal (2 * cellLength n)) atTop (𝓝 0) := by + rw [← ENNReal.ofReal_zero] + refine ENNReal.tendsto_ofReal ?_ + simpa using tendsto_cellLength.const_mul 2 + have key := Measure.hausdorffMeasure_le_liminf_sum 1 (graphMap '' Ico a b) + (fun n : ℕ ↦ ENNReal.ofReal (2 * cellLength n)) hr + (fun n (k : Fin (cellCount n a b)) ↦ graphMap '' cell n (cellIndex n a + k)) + ((eventually_ge_atTop 1).mono fun n hn k ↦ diam_graphMap_image_cell_le hn _) + (Eventually.of_forall fun n ↦ graphMap_image_Ico_subset a b) + refine key.trans ?_ + -- each level-`n` sum is at most `cellCount * 2 cellLength ≤ 2 (b - a) + 4 cellLength n` + have hsum : ∀ n : ℕ, 1 ≤ n → + ∑ k : Fin (cellCount n a b), + Metric.ediam (graphMap '' cell n (cellIndex n a + k)) ^ (1 : ℝ) ≤ + ENNReal.ofReal (2 * (b - a) + 4 * cellLength n) := by + intro n hn + calc ∑ k : Fin (cellCount n a b), + Metric.ediam (graphMap '' cell n (cellIndex n a + k)) ^ (1 : ℝ) + ≤ ∑ _k : Fin (cellCount n a b), ENNReal.ofReal (2 * cellLength n) := by + gcongr with k + rw [ENNReal.rpow_one]; exact diam_graphMap_image_cell_le hn _ + _ = (cellCount n a b : ℝ≥0∞) * ENNReal.ofReal (2 * cellLength n) := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + _ = ENNReal.ofReal ((cellCount n a b : ℝ) * (2 * cellLength n)) := by + rw [ENNReal.ofReal_mul (Nat.cast_nonneg _), ENNReal.ofReal_natCast] + _ ≤ ENNReal.ofReal (2 * (b - a) + 4 * cellLength n) := by + refine ENNReal.ofReal_le_ofReal ?_ + have hc := cellCount_le n hab + have hpos := cellLength_pos n + calc (cellCount n a b : ℝ) * (2 * cellLength n) + ≤ ((b - a) / cellLength n + 2) * (2 * cellLength n) := by gcongr + _ = 2 * (b - a) + 4 * cellLength n := by field_simp; ring + -- and the right-hand sides tend to `2 (b - a)` + have hlim : Tendsto (fun n : ℕ ↦ ENNReal.ofReal (2 * (b - a) + 4 * cellLength n)) atTop + (𝓝 (ENNReal.ofReal (2 * (b - a)))) := by + refine ENNReal.tendsto_ofReal ?_ + simpa using (tendsto_cellLength.const_mul 4).const_add (2 * (b - a)) + calc liminf (fun n : ℕ ↦ ∑ k : Fin (cellCount n a b), + Metric.ediam (graphMap '' cell n (cellIndex n a + k)) ^ (1 : ℝ)) atTop + ≤ liminf (fun n : ℕ ↦ ENNReal.ofReal (2 * (b - a) + 4 * cellLength n)) atTop := + liminf_le_liminf ((eventually_ge_atTop 1).mono hsum) + _ = ENNReal.ofReal (2 * (b - a)) := hlim.liminf_eq + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Density.lean b/LeanPool/Besicovitch/Example/Density.lean new file mode 100644 index 0000000000..ab62788ae0 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Density.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Avoid +public import Mathlib.MeasureTheory.Covering.Besicovitch +public import Mathlib.MeasureTheory.Covering.BesicovitchVectorSpace +public import Mathlib.MeasureTheory.Measure.Lebesgue.Basic + +/-! +# From a one-sided hole to two-sided avoidance + +If `g` is `L`-Lipschitz on `A`, then near every level-`n` grid point `A` misses an interval of +length `margin L n` on one of the two sides. A single such hole is a vanishing fraction of any +ball, so it cannot by itself force `A` to be null. What it does force is that a *density point* +of `A` cannot sit within `margin L n` of a level-`n` grid point for infinitely many `n`: such a +point has a hole of relative size `1/4` in the ball of radius `2 * margin L n` about it, so its +density along that sequence of radii is at most `3/4`. + +Hence almost every point of `A` eventually avoids the grid on *both* sides, and the nested +recursion of `LeanPool.Besicovitch.Example.Zero` applies to the resulting sets. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-- A point within `margin` of a grid point has a hole of relative size `1/4` about it. -/ +theorem measure_inter_closedBall_le {L : ℝ≥0} {A : Set ℝ} + (hg : LipschitzOnWith L besicovitchFun A) {n : ℕ} (hn : 1 ≤ n) {x : ℝ} {i : ℤ} + (hx : |x - gridPoint n i| < margin L n) : + volume (A ∩ Metric.closedBall x (2 * margin L n)) ≤ + ENNReal.ofReal (3 * margin L n) := by + set m := margin L n with hm + set p := gridPoint n i with hp + have hmpos : 0 < m := margin_pos L.coe_nonneg hn + have hball : Metric.closedBall x (2 * m) = Icc (x - 2 * m) (x + 2 * m) := by + rw [Real.closedBall_eq_Icc] + -- one of the two sides of `p` misses `A` + have hside : A ∩ Ioo (p - m) p = ∅ ∨ A ∩ Ico p (p + m) = ∅ := by + by_contra hcon + rw [not_or, ← Ne, ← Ne, ← Set.nonempty_iff_ne_empty, + ← Set.nonempty_iff_ne_empty] at hcon + obtain ⟨⟨y, hy⟩, ⟨z, hz⟩⟩ := hcon + exact not_both_sides hg hn i hy.1 hz.1 hy.2 hz.2 + rw [abs_lt] at hx + -- in either case a set `J` of measure `m` inside the ball misses `A` + obtain ⟨J, hJmeas, hJvol, hJsub, hJdisj⟩ : + ∃ J : Set ℝ, MeasurableSet J ∧ volume J = ENNReal.ofReal m ∧ + J ⊆ Metric.closedBall x (2 * m) ∧ Disjoint A J := by + rcases hside with h | h + · refine ⟨Ioo (p - m) p, measurableSet_Ioo, ?_, ?_, ?_⟩ + · rw [Real.volume_Ioo]; congr 1; ring + · rw [hball]; rintro y ⟨hy1, hy2⟩; constructor <;> [linarith; linarith] + · rw [Set.disjoint_iff_inter_eq_empty]; exact h + · refine ⟨Ico p (p + m), measurableSet_Ico, ?_, ?_, ?_⟩ + · rw [Real.volume_Ico]; congr 1; ring + · rw [hball]; rintro y ⟨hy1, hy2⟩; constructor <;> [linarith; linarith] + · rw [Set.disjoint_iff_inter_eq_empty]; exact h + -- so `A ∩ ball` and `J` are disjoint subsets of the ball + have hunion : volume (A ∩ Metric.closedBall x (2 * m)) + volume J ≤ + volume (Metric.closedBall x (2 * m)) := by + rw [← measure_union (hJdisj.mono_left inter_subset_left) hJmeas] + exact measure_mono (union_subset inter_subset_right hJsub) + rw [hJvol, Real.volume_closedBall] at hunion + have hcalc : ENNReal.ofReal (2 * (2 * m)) = ENNReal.ofReal (3 * m) + ENNReal.ofReal m := by + rw [← ENNReal.ofReal_add (by positivity) hmpos.le]; congr 1; ring + rw [hcalc] at hunion + exact ENNReal.le_of_add_le_add_right ENNReal.ofReal_ne_top hunion + +/-- The margins tend to zero. -/ +theorem tendsto_margin (L : ℝ) (hL : 0 ≤ L) : Tendsto (margin L) atTop (𝓝 0) := by + refine squeeze_zero' ((eventually_ge_atTop 1).mono fun n hn ↦ (margin_pos hL hn).le) + ((eventually_ge_atTop 1).mono fun n hn ↦ ?_) tendsto_cellLength + have hn' : (1 : ℝ) ≤ n := by exact_mod_cast hn + have h2 : (1 : ℝ) ≤ 2 * n * (L + 1) := by nlinarith + exact div_le_self (cellLength_pos n).le h2 + +/-- Almost every point of a set on which `g` is Lipschitz eventually avoids the grid. -/ +theorem ae_eventually_mem_avoid {L : ℝ≥0} {A : Set ℝ} + (hg : LipschitzOnWith L besicovitchFun A) : + ∀ᵐ x ∂(volume.restrict A), ∀ᶠ n in atTop, x ∈ avoid (L : ℝ) n := by + filter_upwards [_root_.Besicovitch.ae_tendsto_measure_inter_div volume A] with x hx + by_contra hcon + rw [not_eventually] at hcon + -- the density exceeds `4/5` at all small radii + have hdens : ∀ᶠ r in 𝓝[>] (0 : ℝ), ENNReal.ofReal (4 / 5) < + volume (A ∩ Metric.closedBall x r) / volume (Metric.closedBall x r) := + hx.eventually (eventually_gt_nhds (ENNReal.ofReal_lt_one.mpr (by norm_num))) + obtain ⟨ρ, hρ, hsub⟩ := mem_nhdsGT_iff_exists_Ioo_subset.mp hdens + rw [mem_Ioi] at hρ + -- pick a bad level whose margin is small + have hsmall : ∀ᶠ n in atTop, 1 ≤ n ∧ 2 * margin (L : ℝ) n < ρ := by + refine (eventually_ge_atTop 1).and ?_ + have := (tendsto_margin (L : ℝ) L.coe_nonneg).const_mul 2 + rw [mul_zero] at this + exact this.eventually (eventually_lt_nhds (by linarith)) + obtain ⟨n, hbad, hn1, hnρ⟩ := (hcon.and_eventually hsmall).exists + set m := margin (L : ℝ) n with hm + have hmpos : 0 < m := margin_pos L.coe_nonneg hn1 + -- at radius `2 * m` the density is at most `3/4` + obtain ⟨i, hi⟩ : ∃ i : ℤ, |x - gridPoint n i| < m := by + simpa [avoid, not_forall, not_le] using hbad + have hkey := measure_inter_closedBall_le hg hn1 hi + have hballvol : volume (Metric.closedBall x (2 * m)) = ENNReal.ofReal (4 * m) := by + rw [Real.volume_closedBall]; congr 1; ring + have hmem : 2 * m ∈ Ioo 0 ρ := ⟨by linarith, hnρ⟩ + have hlt := hsub hmem + simp only [Set.mem_ofPred_eq] at hlt + rw [hballvol, ENNReal.lt_div_iff_mul_lt (Or.inl (by simp [hmpos])) + (Or.inl ENNReal.ofReal_ne_top)] at hlt + rw [← ENNReal.ofReal_mul (by norm_num)] at hlt + have hcontra := hlt.trans_le hkey + rw [ENNReal.ofReal_lt_ofReal_iff (by positivity)] at hcontra + linarith + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Graph.lean b/LeanPool/Besicovitch/Example/Graph.lean new file mode 100644 index 0000000000..ba747d9364 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Graph.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.SpecificLimits.Basic +public import Mathlib.Analysis.SpecificLimits.Normed +public import Mathlib.Topology.Algebra.InfiniteSum.NatInt + +/-! +# Besicovitch's function + +Besicovitch's purely unrectifiable set with lower density `1/2` is the graph of the function +`g = ∑ₙ fₙ`, where `fₙ` is a square wave of period `2 * 2^(-n²)` and amplitude +`2^(-n²) / n`. This file defines the function and proves the two estimates that everything +else rests on: inside a level-`n` cell `g` varies by at most `4 * 2^(-(n+1)²) / (n+1)`, and +across a level-`n` cell boundary it jumps by at least `2^(-n²) / n`. + +The construction follows Capdevila, *Besicovitch's example in higher dimensions*, +arXiv:2607.05206, §2, which in turn follows Besicovitch (1938) and Dickinson (1939). +-/ + +@[expose] public section + +noncomputable section + +open Finset + +namespace LeanPool.Besicovitch.Example + +/-- The length `2^(-n²)` of a level-`n` cell. -/ +def cellLength (n : ℕ) : ℝ := (1 / 2) ^ (n ^ 2) + +/-- The amplitude `2^(-n²) / n` of the level-`n` square wave. -/ +def jumpHeight (n : ℕ) : ℝ := cellLength n / n + +/-- The index of the level-`n` cell `[i * cellLength n, (i + 1) * cellLength n)` containing `x`. -/ +def cellIndex (n : ℕ) (x : ℝ) : ℤ := ⌊x / cellLength n⌋ + +/-- The level-`n` square wave: `-jumpHeight n` on even cells, `+jumpHeight n` on odd cells. -/ +def squareWave (n : ℕ) (x : ℝ) : ℝ := + if Even (cellIndex n x) then -jumpHeight n else jumpHeight n + +/-- Besicovitch's function, the sum of the square waves of every level `n ≥ 1`. -/ +def besicovitchFun (x : ℝ) : ℝ := ∑' n : ℕ, squareWave (n + 1) x + +/-! ### The cell lengths -/ + +theorem cellLength_pos (n : ℕ) : 0 < cellLength n := by + unfold cellLength; positivity + +theorem cellLength_le_one (n : ℕ) : cellLength n ≤ 1 := by + unfold cellLength; exact pow_le_one₀ (by norm_num) (by norm_num) + +/-- Consecutive cell lengths shrink by a factor of at least two. -/ +theorem cellLength_succ_le (n : ℕ) : cellLength (n + 1) ≤ cellLength n / 2 := by + unfold cellLength + have h : n ^ 2 + 1 ≤ (n + 1) ^ 2 := by ring_nf; omega + calc ((1 : ℝ) / 2) ^ ((n + 1) ^ 2) ≤ (1 / 2) ^ (n ^ 2 + 1) := + pow_le_pow_of_le_one (by norm_num) (by norm_num) h + _ = (1 / 2) ^ (n ^ 2) / 2 := by rw [pow_succ]; ring + +/-- At level `n ≥ 1` consecutive cell lengths shrink by a factor of at least eight. -/ +theorem cellLength_succ_le_of_pos {n : ℕ} (hn : 1 ≤ n) : + cellLength (n + 1) ≤ cellLength n / 8 := by + unfold cellLength + have h : n ^ 2 + 3 ≤ (n + 1) ^ 2 := by ring_nf; omega + calc ((1 : ℝ) / 2) ^ ((n + 1) ^ 2) ≤ (1 / 2) ^ (n ^ 2 + 3) := + pow_le_pow_of_le_one (by norm_num) (by norm_num) h + _ = (1 / 2) ^ (n ^ 2) / 8 := by rw [pow_add]; ring + +theorem cellLength_add_le (n m : ℕ) : cellLength (n + m) ≤ cellLength n * (1 / 2) ^ m := by + induction m with + | zero => simp + | succ m ih => + calc cellLength (n + (m + 1)) ≤ cellLength (n + m) / 2 := cellLength_succ_le _ + _ ≤ cellLength n * (1 / 2) ^ m / 2 := by gcongr + _ = cellLength n * (1 / 2) ^ (m + 1) := by rw [pow_succ]; ring + +theorem cellLength_antitone : Antitone cellLength := by + refine antitone_nat_of_succ_le fun n ↦ ?_ + have := cellLength_succ_le n + have := cellLength_pos n + linarith + +/-- A coarser cell length is a natural multiple of a finer one. -/ +theorem cellLength_eq_mul {j n : ℕ} (h : j ≤ n) : + cellLength j = cellLength n * ((2 ^ (n ^ 2 - j ^ 2) : ℕ) : ℝ) := by + have hle : j ^ 2 ≤ n ^ 2 := Nat.pow_le_pow_left h 2 + obtain ⟨d, hd⟩ : ∃ d, n ^ 2 = j ^ 2 + d := ⟨n ^ 2 - j ^ 2, by omega⟩ + unfold cellLength + rw [hd, Nat.add_sub_cancel_left, pow_add] + push_cast + rw [mul_assoc, ← mul_pow] + norm_num + +theorem jumpHeight_nonneg (n : ℕ) : 0 ≤ jumpHeight n := + div_nonneg (cellLength_pos n).le (Nat.cast_nonneg n) + +theorem jumpHeight_le_cellLength (n : ℕ) : jumpHeight n ≤ cellLength n := by + unfold jumpHeight + rcases Nat.eq_zero_or_pos n with rfl | hn + · simp [(cellLength_pos 0).le] + · exact div_le_self (cellLength_pos n).le (by exact_mod_cast hn) + +/-! ### The square waves -/ + +theorem abs_squareWave (n : ℕ) (x : ℝ) : |squareWave n x| = jumpHeight n := by + unfold squareWave + split_ifs + · rw [abs_neg, abs_of_nonneg (jumpHeight_nonneg n)] + · rw [abs_of_nonneg (jumpHeight_nonneg n)] + +theorem squareWave_eq_of_cellIndex_eq {n : ℕ} {x y : ℝ} (h : cellIndex n x = cellIndex n y) : + squareWave n x = squareWave n y := by + simp [squareWave, h] + +/-- On adjacent cells the square waves have opposite signs. -/ +theorem squareWave_add_squareWave_of_adjacent {n : ℕ} {x y : ℝ} + (h : cellIndex n y = cellIndex n x + 1 ∨ cellIndex n x = cellIndex n y + 1) : + squareWave n x + squareWave n y = 0 := by + have key : ∀ a : ℤ, (if Even a then -jumpHeight n else jumpHeight n) + + (if Even (a + 1) then -jumpHeight n else jumpHeight n) = 0 := by + intro a + by_cases ha : Even a + · have h1 : ¬ Even (a + 1) := by rw [Int.even_add_one]; exact not_not.mpr ha + simp [ha, h1] + · have h1 : Even (a + 1) := Int.even_add_one.mpr ha + simp [ha, h1] + unfold squareWave + rcases h with h | h + · rw [h]; exact key _ + · rw [h, add_comm]; exact key _ + +/-- Points less than a cell length apart lie in the same or in adjacent cells. -/ +theorem cellIndex_sub_le {n : ℕ} {x y : ℝ} (h : |x - y| < cellLength n) : + |cellIndex n x - cellIndex n y| ≤ 1 := by + unfold cellIndex + have hpos := cellLength_pos n + have hxy : |x / cellLength n - y / cellLength n| < 1 := by + rw [← sub_div, abs_div, abs_of_pos hpos, div_lt_one hpos]; exact h + rw [abs_lt] at hxy + have h1 := Int.floor_le (x / cellLength n) + have h2 := Int.lt_floor_add_one (x / cellLength n) + have h3 := Int.floor_le (y / cellLength n) + have h4 := Int.lt_floor_add_one (y / cellLength n) + have hu : (⌊x / cellLength n⌋ : ℝ) < ⌊y / cellLength n⌋ + 2 := by linarith + have hl : (⌊y / cellLength n⌋ : ℝ) < ⌊x / cellLength n⌋ + 2 := by linarith + have hu' : ⌊x / cellLength n⌋ < ⌊y / cellLength n⌋ + 2 := by exact_mod_cast hu + have hl' : ⌊y / cellLength n⌋ < ⌊x / cellLength n⌋ + 2 := by exact_mod_cast hl + rw [abs_le]; omega + +/-- Cells of a coarser level are unions of cells of a finer level. -/ +theorem cellIndex_eq_of_le {j n : ℕ} (hjn : j ≤ n) {x y : ℝ} + (h : cellIndex n x = cellIndex n y) : cellIndex j x = cellIndex j y := by + unfold cellIndex at * + have hcell := cellLength_eq_mul hjn + have key : ∀ z : ℝ, + z / cellLength j = z / cellLength n / ((2 ^ (n ^ 2 - j ^ 2) : ℕ) : ℝ) := + fun z ↦ by rw [hcell, div_mul_eq_div_div] + rw [key x, key y, Int.floor_div_natCast, Int.floor_div_natCast, h] + +/-! ### Summability and the tail bound -/ + +theorem cellLength_le_geom (n : ℕ) : cellLength n ≤ (1 / 2) ^ n := by + unfold cellLength + exact pow_le_pow_of_le_one (by norm_num) (by norm_num) (Nat.le_self_pow two_ne_zero n) + +theorem tendsto_cellLength : Filter.Tendsto cellLength Filter.atTop (nhds 0) := + squeeze_zero (fun n ↦ (cellLength_pos n).le) cellLength_le_geom + (tendsto_pow_atTop_nhds_zero_of_lt_one (by norm_num) (by norm_num)) + +theorem cellLength_succ_le_geom (n : ℕ) : cellLength (n + 1) ≤ (1 / 2) ^ n := by + unfold cellLength + exact pow_le_pow_of_le_one (by norm_num) (by norm_num) (by nlinarith) + +theorem summable_squareWave (x : ℝ) : Summable fun n : ℕ ↦ squareWave (n + 1) x := by + refine Summable.of_norm_bounded summable_geometric_two fun n ↦ ?_ + rw [Real.norm_eq_abs, abs_squareWave] + exact (jumpHeight_le_cellLength _).trans (cellLength_succ_le_geom n) + +theorem summable_jumpHeight (n : ℕ) : Summable fun m : ℕ ↦ jumpHeight (n + 1 + m) := by + refine Summable.of_nonneg_of_le (fun m ↦ jumpHeight_nonneg _) (fun m ↦ ?_) + (summable_geometric_two.mul_left (cellLength (n + 1))) + calc jumpHeight (n + 1 + m) ≤ cellLength (n + 1 + m) := jumpHeight_le_cellLength _ + _ ≤ cellLength (n + 1) * (1 / 2) ^ m := cellLength_add_le _ _ + +/-- The amplitudes beyond level `n` sum to at most `2 * cellLength (n+1) / (n+1)`. -/ +theorem tsum_jumpHeight_tail_le (n : ℕ) : + ∑' m : ℕ, jumpHeight (n + 1 + m) ≤ 2 * cellLength (n + 1) / (n + 1) := by + have hn : (0 : ℝ) < (n : ℝ) + 1 := by positivity + have hbound : ∀ m : ℕ, + jumpHeight (n + 1 + m) ≤ cellLength (n + 1) / (n + 1) * (1 / 2) ^ m := by + intro m + unfold jumpHeight + have h1 : cellLength (n + 1 + m) ≤ cellLength (n + 1) * (1 / 2) ^ m := cellLength_add_le _ _ + have h2 : (n : ℝ) + 1 ≤ ((n + 1 + m : ℕ) : ℝ) := by + push_cast; linarith [Nat.cast_nonneg (α := ℝ) m] + calc cellLength (n + 1 + m) / ((n + 1 + m : ℕ) : ℝ) + ≤ cellLength (n + 1 + m) / ((n : ℝ) + 1) := + div_le_div_of_nonneg_left (cellLength_pos _).le hn h2 + _ ≤ cellLength (n + 1) * (1 / 2) ^ m / ((n : ℝ) + 1) := by gcongr + _ = cellLength (n + 1) / (n + 1) * (1 / 2) ^ m := by ring + calc ∑' m : ℕ, jumpHeight (n + 1 + m) + ≤ ∑' m : ℕ, cellLength (n + 1) / (n + 1) * (1 / 2) ^ m := + Summable.tsum_le_tsum hbound (summable_jumpHeight n) (summable_geometric_two.mul_left _) + _ = cellLength (n + 1) / (n + 1) * 2 := by rw [tsum_mul_left, tsum_geometric_two] + _ = 2 * cellLength (n + 1) / (n + 1) := by ring + +/-! ### The two estimates -/ + +/-- The difference of `g` at two points, with the first `n` levels separated off. -/ +theorem besicovitchFun_sub_eq (n : ℕ) (x y : ℝ) : + besicovitchFun x - besicovitchFun y = + (∑ m ∈ range n, (squareWave (m + 1) x - squareWave (m + 1) y)) + + ∑' m : ℕ, (squareWave (n + 1 + m) x - squareWave (n + 1 + m) y) := by + have hx := summable_squareWave x + have hy := summable_squareWave y + have h1 : besicovitchFun x - besicovitchFun y = + ∑' m : ℕ, (squareWave (m + 1) x - squareWave (m + 1) y) := by + unfold besicovitchFun + exact (hx.tsum_sub hy).symm + have h2 : ∑' m : ℕ, (squareWave (m + 1) x - squareWave (m + 1) y) = + (∑ m ∈ range n, (squareWave (m + 1) x - squareWave (m + 1) y)) + + ∑' m : ℕ, (squareWave (m + n + 1) x - squareWave (m + n + 1) y) := + ((hx.sub hy).sum_add_tsum_nat_add n).symm + have h3 : ∑' m : ℕ, (squareWave (m + n + 1) x - squareWave (m + n + 1) y) = + ∑' m : ℕ, (squareWave (n + 1 + m) x - squareWave (n + 1 + m) y) := + tsum_congr fun m ↦ by rw [show m + n + 1 = n + 1 + m by ring] + rw [h1, h2, h3] + +theorem abs_squareWave_sub_le (n : ℕ) (x y : ℝ) : + |squareWave n x - squareWave n y| ≤ 2 * jumpHeight n := by + calc |squareWave n x - squareWave n y| ≤ |squareWave n x| + |squareWave n y| := abs_sub _ _ + _ = 2 * jumpHeight n := by rw [abs_squareWave, abs_squareWave]; ring + +/-- The tail beyond level `n` contributes at most `4 * cellLength (n+1) / (n+1)`. -/ +theorem abs_tail_le (n : ℕ) (x y : ℝ) : + |∑' m : ℕ, (squareWave (n + 1 + m) x - squareWave (n + 1 + m) y)| ≤ + 4 * cellLength (n + 1) / (n + 1) := by + have hsum : Summable fun m : ℕ ↦ 2 * jumpHeight (n + 1 + m) := + (summable_jumpHeight n).mul_left 2 + have hle : ∀ m : ℕ, ‖squareWave (n + 1 + m) x - squareWave (n + 1 + m) y‖ ≤ + 2 * jumpHeight (n + 1 + m) := fun m ↦ by + rw [Real.norm_eq_abs]; exact abs_squareWave_sub_le _ x y + have hnorm : Summable fun m : ℕ ↦ ‖squareWave (n + 1 + m) x - squareWave (n + 1 + m) y‖ := + Summable.of_nonneg_of_le (fun m ↦ norm_nonneg _) hle hsum + have h1 := norm_tsum_le_tsum_norm hnorm + have h2 : ∑' m : ℕ, ‖squareWave (n + 1 + m) x - squareWave (n + 1 + m) y‖ ≤ + ∑' m : ℕ, 2 * jumpHeight (n + 1 + m) := Summable.tsum_le_tsum hle hnorm hsum + have h3 : ∑' m : ℕ, 2 * jumpHeight (n + 1 + m) ≤ + 2 * (2 * cellLength (n + 1) / (n + 1)) := by + rw [tsum_mul_left]; gcongr; exact tsum_jumpHeight_tail_le n + simp only [Real.norm_eq_abs] at h1 h2 + calc |∑' m : ℕ, (squareWave (n + 1 + m) x - squareWave (n + 1 + m) y)| + ≤ ∑' m : ℕ, |squareWave (n + 1 + m) x - squareWave (n + 1 + m) y| := h1 + _ ≤ ∑' m : ℕ, 2 * jumpHeight (n + 1 + m) := h2 + _ ≤ 2 * (2 * cellLength (n + 1) / (n + 1)) := h3 + _ = 4 * cellLength (n + 1) / (n + 1) := by ring + +/-- **(E1)** Inside a level-`n` cell, `g` varies by at most `4 * cellLength (n+1) / (n+1)`. -/ +theorem abs_besicovitchFun_sub_le {n : ℕ} {x y : ℝ} (h : cellIndex n x = cellIndex n y) : + |besicovitchFun x - besicovitchFun y| ≤ 4 * cellLength (n + 1) / (n + 1) := by + rw [besicovitchFun_sub_eq n] + have hzero : ∑ m ∈ range n, (squareWave (m + 1) x - squareWave (m + 1) y) = 0 := by + refine sum_eq_zero fun m hm ↦ ?_ + rw [squareWave_eq_of_cellIndex_eq (cellIndex_eq_of_le (by simpa using hm) h), sub_self] + rw [hzero, zero_add] + exact abs_tail_le n x y + +/-- Adjacent cells at level `n` are less than two cell lengths apart. -/ +theorem abs_sub_lt_of_adjacent {n : ℕ} {x y : ℝ} + (h : cellIndex n y = cellIndex n x + 1 ∨ cellIndex n x = cellIndex n y + 1) : + |x - y| < 2 * cellLength n := by + unfold cellIndex at h + have hpos := cellLength_pos n + have h1 := Int.floor_le (x / cellLength n) + have h2 := Int.lt_floor_add_one (x / cellLength n) + have h3 := Int.floor_le (y / cellLength n) + have h4 := Int.lt_floor_add_one (y / cellLength n) + have key : |x - y| = |x / cellLength n - y / cellLength n| * cellLength n := by + rw [← sub_div, abs_div, abs_of_pos hpos, div_mul_cancel₀ _ hpos.ne'] + have hlt : |x / cellLength n - y / cellLength n| < 2 := by + rw [abs_lt] + rcases h with h | h + · have : (⌊y / cellLength n⌋ : ℝ) = ⌊x / cellLength n⌋ + 1 := by exact_mod_cast h + constructor <;> linarith + · have : (⌊x / cellLength n⌋ : ℝ) = ⌊y / cellLength n⌋ + 1 := by exact_mod_cast h + constructor <;> linarith + rw [key] + exact mul_lt_mul_of_pos_right hlt hpos + +/-- **(E2)** Across a level-`n` cell boundary, `g` jumps by at least `cellLength n / n`. -/ +theorem le_abs_besicovitchFun_sub {n : ℕ} (hn : 1 ≤ n) {x y : ℝ} + (h : cellIndex n y = cellIndex n x + 1 ∨ cellIndex n x = cellIndex n y + 1) : + cellLength n / n ≤ |besicovitchFun x - besicovitchFun y| := by + have hne : cellIndex n x ≠ cellIndex n y := by rcases h with h | h <;> omega + -- the least level `k ≥ 1` at which `x` and `y` separate + classical + have hex : ∃ k, 1 ≤ k ∧ cellIndex k x ≠ cellIndex k y := ⟨n, hn, hne⟩ + obtain ⟨k, hk1, hkne, hkn, hmin⟩ : + ∃ k, 1 ≤ k ∧ cellIndex k x ≠ cellIndex k y ∧ k ≤ n ∧ + ∀ j, 1 ≤ j → j < k → cellIndex j x = cellIndex j y := + ⟨Nat.find hex, (Nat.find_spec hex).1, (Nat.find_spec hex).2, Nat.find_min' hex ⟨hn, hne⟩, + fun j hj hjk ↦ by_contra fun hc ↦ Nat.find_min hex hjk ⟨hj, hc⟩⟩ + -- `x` and `y` are adjacent at level `k` + have hadj : cellIndex k y = cellIndex k x + 1 ∨ cellIndex k x = cellIndex k y + 1 := by + rcases hkn.lt_or_eq with hlt | heq + · have hdist : |x - y| < cellLength k := + calc |x - y| < 2 * cellLength n := abs_sub_lt_of_adjacent h + _ ≤ 2 * cellLength (k + 1) := by gcongr; exact cellLength_antitone hlt + _ ≤ cellLength k := by linarith [cellLength_succ_le k] + have := cellIndex_sub_le hdist + rw [abs_le] at this + omega + · rw [heq]; exact h + -- split off the levels below `k`, which cancel, and level `k` itself + obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := ⟨k - 1, by omega⟩ + have hsplit := besicovitchFun_sub_eq (k' + 1) x y + rw [sum_range_succ] at hsplit + have hlow : ∑ m ∈ range k', (squareWave (m + 1) x - squareWave (m + 1) y) = 0 := by + refine sum_eq_zero fun m hm ↦ ?_ + rw [squareWave_eq_of_cellIndex_eq (hmin (m + 1) (by omega) (by simpa using hm)), sub_self] + rw [hlow, zero_add] at hsplit + have hlevel : squareWave (k' + 1) x - squareWave (k' + 1) y = 2 * squareWave (k' + 1) x := by + have := squareWave_add_squareWave_of_adjacent hadj; linarith + set T := ∑' m : ℕ, (squareWave (k' + 1 + 1 + m) x - squareWave (k' + 1 + 1 + m) y) with hT + have htail := abs_tail_le (k' + 1) x y + rw [← hT] at htail + push_cast at htail + -- numerics, with `K = k' + 1 ≥ 1` + have hK : (1 : ℝ) ≤ (k' : ℝ) + 1 := by linarith [Nat.cast_nonneg (α := ℝ) k'] + have hKpos : (0 : ℝ) < (k' : ℝ) + 1 := by linarith + have hratio := cellLength_succ_le_of_pos hk1 + have hpos := cellLength_pos (k' + 1) + have hpos' := cellLength_pos (k' + 1 + 1) + have hT' : 4 * cellLength (k' + 1 + 1) / ((k' : ℝ) + 1 + 1) ≤ + cellLength (k' + 1) / (2 * ((k' : ℝ) + 1)) := by + rw [div_le_div_iff₀ (by positivity) (by positivity)] + nlinarith + have hjump : jumpHeight (k' + 1) = cellLength (k' + 1) / ((k' : ℝ) + 1) := by + rw [jumpHeight, Nat.cast_add, Nat.cast_one] + have hA : 0 ≤ cellLength (k' + 1) / ((k' : ℝ) + 1) := div_nonneg hpos.le hKpos.le + have hn' : (0 : ℝ) < n := by exact_mod_cast hn + have hkn' : (k' : ℝ) + 1 ≤ n := by exact_mod_cast hkn + have hcl : cellLength n ≤ cellLength (k' + 1) := cellLength_antitone hkn + calc cellLength n / n ≤ cellLength (k' + 1) / n := div_le_div_of_nonneg_right hcl hn'.le + _ ≤ cellLength (k' + 1) / ((k' : ℝ) + 1) := + div_le_div_of_nonneg_left hpos.le hKpos hkn' + _ ≤ 2 * jumpHeight (k' + 1) - |T| := by + rw [hjump] + have : cellLength (k' + 1) / (2 * ((k' : ℝ) + 1)) = + cellLength (k' + 1) / ((k' : ℝ) + 1) / 2 := by rw [div_div, mul_comm] + linarith + _ = |2 * squareWave (k' + 1) x| - |-T| := by rw [abs_mul, abs_two, abs_squareWave, abs_neg] + _ ≤ |2 * squareWave (k' + 1) x - -T| := abs_sub_abs_le_abs_sub _ _ + _ = |besicovitchFun x - besicovitchFun y| := by rw [sub_neg_eq_add, hsplit, hlevel] + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Hull.lean b/LeanPool/Besicovitch/Example/Hull.lean new file mode 100644 index 0000000000..091814a3c1 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Hull.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Cover +public import Mathlib.MeasureTheory.Measure.Regular + +/-! +# The Hausdorff measure of the graph over an arbitrary set + +An open set is the increasing union of the cells it contains; the graph over such a union of +level-`n` cells has Hausdorff measure at most twice its Lebesgue measure by the cell bound, and +the monotone-union limit carries this to the open set. Outer regularity of Lebesgue measure +then gives `μH[1] (graphMap '' A) ≤ 2 * volume A` for every `A ⊆ ℝ`; in particular the +graph over a Lebesgue-null set is `μH[1]`-null. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal + +namespace LeanPool.Besicovitch.Example + +/-- The union of the level-`n` cells contained in `U`. -/ +def cellHull (n : ℕ) (U : Set ℝ) : Set ℝ := ⋃ i ∈ {i : ℤ | cell n i ⊆ U}, cell n i + +theorem cellHull_subset (n : ℕ) (U : Set ℝ) : cellHull n U ⊆ U := by + intro x hx + simp only [cellHull, mem_iUnion, mem_ofPred_eq, exists_prop] at hx + obtain ⟨i, hi, hx⟩ := hx + exact hi hx + +/-- A finer cell meeting a coarser one is contained in it. -/ +theorem cell_subset_of_mem {m n : ℕ} (hmn : m ≤ n) {i j : ℤ} {x : ℝ} + (hx : x ∈ cell n j) (hx' : x ∈ cell m i) : cell n j ⊆ cell m i := by + intro y hy + rw [mem_cell_iff] at hx hx' hy ⊢ + rw [← hx'] + exact cellIndex_eq_of_le hmn (hy.trans hx.symm) + +theorem cellHull_subset_succ (n : ℕ) (U : Set ℝ) : cellHull n U ⊆ cellHull (n + 1) U := by + intro x hx + simp only [cellHull, mem_iUnion, mem_ofPred_eq, exists_prop] at hx ⊢ + obtain ⟨i, hi, hx⟩ := hx + exact ⟨cellIndex (n + 1) x, + (cell_subset_of_mem (Nat.le_succ n) (mem_cell_cellIndex _ _) hx).trans hi, + mem_cell_cellIndex _ _⟩ + +theorem monotone_cellHull (U : Set ℝ) : Monotone fun n ↦ cellHull n U := + monotone_nat_of_le_succ fun n ↦ cellHull_subset_succ n U + +/-- The cell of `x` lies within `cellLength n` of `x`. -/ +theorem cell_subset_ball (n : ℕ) (x : ℝ) : + cell n (cellIndex n x) ⊆ Metric.ball x (cellLength n) := by + intro y hy + have hx := mem_cell_cellIndex n x + simp only [cell, mem_Ico] at hx hy + rw [Metric.mem_ball, Real.dist_eq, abs_lt] + constructor <;> linarith + +theorem iUnion_cellHull_of_isOpen {U : Set ℝ} (hU : IsOpen U) : ⋃ n, cellHull n U = U := by + refine subset_antisymm (iUnion_subset fun n ↦ cellHull_subset n U) fun x hx ↦ ?_ + obtain ⟨ε, hε, hball⟩ := Metric.isOpen_iff.mp hU x hx + obtain ⟨n, hn⟩ := (tendsto_cellLength.eventually (gt_mem_nhds hε)).exists + refine mem_iUnion.mpr ⟨n, ?_⟩ + simp only [cellHull, mem_iUnion, mem_ofPred_eq, exists_prop] + exact ⟨cellIndex n x, + (cell_subset_ball n x).trans ((Metric.ball_subset_ball hn.le).trans hball), + mem_cell_cellIndex n x⟩ + +theorem volume_cellHull (n : ℕ) (U : Set ℝ) : + volume (cellHull n U) = ∑' i : {i : ℤ // cell n i ⊆ U}, volume (cell n i) := by + unfold cellHull + refine measure_biUnion (Set.to_countable _) ?_ fun i _ ↦ measurableSet_Ico + intro i _ j _ hij + exact cell_disjoint hij + +/-- The graph over a level-`n ≥ 1` cell has Hausdorff measure at most twice the cell's length. -/ +theorem hausdorffMeasure_graphMap_image_cell_le {n : ℕ} (i : ℤ) : + μH[1] (graphMap '' cell n i) ≤ 2 * volume (cell n i) := by + have hpos := cellLength_pos n + have h := hausdorffMeasure_graphMap_image_Ico_le + (a := i * cellLength n) (b := (i + 1) * cellLength n) (by nlinarith) + have h2 : (2 : ℝ≥0∞) * ENNReal.ofReal (cellLength n) = + ENNReal.ofReal (2 * cellLength n) := by + rw [ENNReal.ofReal_mul (by norm_num), ENNReal.ofReal_ofNat] + rw [volume_cell, h2] + refine h.trans (le_of_eq ?_) + congr 1; ring + +theorem hausdorffMeasure_graphMap_image_cellHull_le (n : ℕ) (U : Set ℝ) : + μH[1] (graphMap '' cellHull n U) ≤ 2 * volume (cellHull n U) := by + unfold cellHull + rw [image_iUnion₂] + calc μH[1] (⋃ i ∈ {i : ℤ | cell n i ⊆ U}, graphMap '' cell n i) + ≤ ∑' i : {i : ℤ // cell n i ⊆ U}, μH[1] (graphMap '' cell n i) := + measure_biUnion_le _ (Set.to_countable _) _ + _ ≤ ∑' i : {i : ℤ // cell n i ⊆ U}, 2 * volume (cell n i) := by + gcongr with i; exact hausdorffMeasure_graphMap_image_cell_le _ + _ = 2 * volume (⋃ i ∈ {i : ℤ | cell n i ⊆ U}, cell n i) := by + rw [ENNReal.tsum_mul_left, ← volume_cellHull]; rfl + +/-- **(B≤ on open sets)** -/ +theorem hausdorffMeasure_graphMap_image_le_of_isOpen {U : Set ℝ} (hU : IsOpen U) : + μH[1] (graphMap '' U) ≤ 2 * volume U := by + have hmono : Monotone fun n ↦ graphMap '' cellHull n U := + fun m n hmn ↦ image_mono (monotone_cellHull U hmn) + have hlim := tendsto_measure_iUnion_atTop (μ := μH[1]) hmono + rw [← image_iUnion, iUnion_cellHull_of_isOpen hU] at hlim + refine le_of_tendsto' hlim fun n ↦ ?_ + calc μH[1] (graphMap '' cellHull n U) ≤ 2 * volume (cellHull n U) := + hausdorffMeasure_graphMap_image_cellHull_le n U + _ ≤ 2 * volume U := by gcongr; exact cellHull_subset n U + +/-- **(B≤)** The graph over any set has Hausdorff measure at most twice its Lebesgue measure. -/ +theorem hausdorffMeasure_graphMap_image_le (A : Set ℝ) : + μH[1] (graphMap '' A) ≤ 2 * volume A := by + refine ENNReal.le_of_forall_pos_le_add fun ε hε hfin ↦ ?_ + have hA : volume A ≠ ∞ := by + intro h + rw [h, ENNReal.mul_top (by norm_num)] at hfin + exact absurd hfin (lt_irrefl _) + have hε' : (ε : ℝ≥0∞) / 2 ≠ 0 := + (ENNReal.div_pos_iff.mpr ⟨(ENNReal.coe_pos.mpr hε).ne', by norm_num⟩).ne' + have hlt : volume A < volume A + ε / 2 := ENNReal.lt_add_right hA hε' + obtain ⟨U, hAU, hUopen, hU⟩ := Set.exists_isOpen_lt_of_lt A _ hlt + calc μH[1] (graphMap '' A) ≤ μH[1] (graphMap '' U) := measure_mono (image_mono hAU) + _ ≤ 2 * volume U := hausdorffMeasure_graphMap_image_le_of_isOpen hUopen + _ ≤ 2 * (volume A + ε / 2) := by gcongr + _ = 2 * volume A + ε := by + have h2 : (2 : ℝ≥0∞) * ((ε : ℝ≥0∞) / 2) = ε := + ENNReal.mul_div_cancel' (by norm_num) (by norm_num) + rw [mul_add, h2] + +/-- The graph over a Lebesgue-null set is `μH[1]`-null. -/ +theorem hausdorffMeasure_graphMap_image_eq_zero {A : Set ℝ} (hA : volume A = 0) : + μH[1] (graphMap '' A) = 0 := by + have := hausdorffMeasure_graphMap_image_le A + rw [hA, mul_zero] at this + exact nonpos_iff_eq_zero.mp this + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/LowerBound.lean b/LeanPool/Besicovitch/Example/LowerBound.lean new file mode 100644 index 0000000000..2503d74a06 --- /dev/null +++ b/LeanPool/Besicovitch/Example/LowerBound.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.LowerDensity +public import LeanPool.Besicovitch.Example.Reduction +public import LeanPool.Besicovitch.Example.Zero +public import LeanPool.Besicovitch.Main.RationalBound +public import LeanPool.Besicovitch.Sigma.Basic + +/-! +# The planar threshold is at least `1/2` + +Besicovitch's set `Π`, the graph of `g` over `[0, 1]`, is measurable and has positive finite +length. It is purely unrectifiable: a Lipschitz curve meeting it in positive length would make +`g` Lipschitz on a set of positive Lebesgue measure (`LeanPool.Besicovitch.Example.Reduction`), + which is +impossible (`LeanPool.Besicovitch.Example.Zero`). On the other hand its lower one-density is + at least +`1/2` at every interior point (`LeanPool.Besicovitch.Example.LowerDensity`), hence almost + everywhere. +So no threshold below `1/2` forces one-rectifiability in the plane, and `sigmaOne ℝ² ≥ 1/2`. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-- Besicovitch's set has positive length. -/ +theorem hausdorffMeasure_besicovitchSet_pos : 0 < μH[1] besicovitchSet := by + have h := volume_le_hausdorffMeasure_graphMap_image (Icc (0:ℝ) 1) + rw [Real.volume_Icc, sub_zero, ENNReal.ofReal_one] at h + exact lt_of_lt_of_le zero_lt_one h + +/-- Besicovitch's set has finite length. -/ +theorem hausdorffMeasure_besicovitchSet_lt_top : μH[1] besicovitchSet < ∞ := by + have h := hausdorffMeasure_graphMap_image_le (Icc (0:ℝ) 1) + rw [Real.volume_Icc, sub_zero, ENNReal.ofReal_one, mul_one] at h + exact lt_of_le_of_lt h ENNReal.ofNat_lt_top + +/-- A Lipschitz curve meets Besicovitch's set in a null set. -/ +theorem hausdorffMeasure_range_inter_besicovitchSet {K : ℝ≥0} {f : ℝ → Plane} + (hf : LipschitzWith K f) : μH[1] (range f ∩ besicovitchSet) = 0 := by + by_contra hne + obtain ⟨L, A, hA, hvol, hg⟩ := + exists_lipschitzOnWith_of_hausdorffMeasure_pos hf (pos_iff_ne_zero.mpr hne) + exact hvol.ne' (volume_eq_zero_of_lipschitzOnWith hA hg) + +/-- Besicovitch's set is not countably one-rectifiable. -/ +theorem not_isCountablyOneRectifiable_besicovitchSet : + ¬ IsCountablyOneRectifiable besicovitchSet := by + rintro ⟨f, hf, hnull⟩ + have hcover : besicovitchSet ⊆ + (besicovitchSet \ ⋃ i, range (f i)) ∪ ⋃ i, (range (f i) ∩ besicovitchSet) := by + intro p hp + by_cases h : p ∈ ⋃ i, range (f i) + · obtain ⟨i, hi⟩ := mem_iUnion.mp h + exact Or.inr (mem_iUnion.mpr ⟨i, hi, hp⟩) + · exact Or.inl ⟨hp, h⟩ + have hzero : μH[1] besicovitchSet = 0 := by + refine measure_mono_null hcover (measure_union_null hnull (measure_iUnion_null fun i ↦ ?_)) + obtain ⟨K, hK⟩ := hf i + exact hausdorffMeasure_range_inter_besicovitchSet hK + exact hausdorffMeasure_besicovitchSet_pos.ne' hzero + +/-- Almost every point of Besicovitch's set has lower density at least `1/2`. -/ +theorem ae_one_half_le_lowerOneDensity : + ∀ᵐ p ∂(μH[1].restrict besicovitchSet), + ENNReal.ofReal (1 / 2) ≤ lowerOneDensity besicovitchSet p := by + rw [ae_restrict_iff' measurableSet_besicovitchSet, ae_iff] + refine measure_mono_null ?_ + (hausdorffMeasure_graphMap_image_eq_zero (A := {0, 1}) + (((Set.finite_singleton (1:ℝ)).insert 0).measure_zero volume)) + intro p hp + simp only [mem_ofPred_eq, Classical.not_imp] at hp + obtain ⟨⟨x, hx, rfl⟩, hbad⟩ := hp + refine ⟨x, ?_, rfl⟩ + by_contra hx01 + simp only [mem_insert_iff, mem_singleton_iff, not_or] at hx01 + exact hbad (one_half_le_lowerOneDensity_graphMap + ⟨lt_of_le_of_ne hx.1 (Ne.symm hx01.1), lt_of_le_of_ne hx.2 hx01.2⟩) + +/-- No threshold below `1/2` forces one-rectifiability in the plane. -/ +theorem not_forcesOneRectifiability_of_lt_half {β : ℝ} (hβ : β < 1 / 2) : + ¬ ForcesOneRectifiability (EuclideanSpace ℝ (Fin 2)) (ENNReal.ofReal β) := by + intro h + apply not_isCountablyOneRectifiable_besicovitchSet + refine h besicovitchSet measurableSet_besicovitchSet + hausdorffMeasure_besicovitchSet_lt_top ?_ + exact ae_one_half_le_lowerOneDensity.mono fun p hp ↦ + (ENNReal.ofReal_le_ofReal hβ.le).trans hp + +/-- The planar threshold is at least `1/2`. -/ +theorem one_half_le_sigmaOne_plane : + (1 / 2 : ℝ) ≤ sigmaOne (EuclideanSpace ℝ (Fin 2)) := by + unfold sigmaOne + apply le_csInf + · refine ⟨7 / 10, by norm_num, ?_⟩ + exact forcesOneRectifiability_plane_of_barS_lt (by rw [barS_eq]; norm_num) + · rintro β ⟨_, hβ⟩ + by_contra hlt + exact not_forcesOneRectifiability_of_lt_half (not_le.mp hlt) hβ + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/LowerDensity.lean b/LeanPool/Besicovitch/Example/LowerDensity.lean new file mode 100644 index 0000000000..b5c98ddc3a --- /dev/null +++ b/LeanPool/Besicovitch/Example/LowerDensity.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Plane +public import LeanPool.Besicovitch.Statement + +/-! +# The lower density of Besicovitch's set is at least `1/2` + +At an interior point `graphMap x` of the graph, the ball of radius `r` contains the graph over an +interval of length at least `θ * r`, for every `θ < 1` and every small `r`: let `n` be the last +level with `r ≤ cellLength n`; inside the level-`n` cell of `x` the function `g` varies by at +most `4 * cellLength (n+1) / (n+1) < 4 * r / (n+1)`, which is below `(1 - θ) * r` once `n` is +large. Since the first-coordinate projection is `1`-Lipschitz, the Hausdorff measure of the +graph over that interval is at least `θ * r`, so the lower density (normalised by the diameter +`2 * r` of the ball) is at least `θ / 2`. Letting `θ → 1` gives `1/2`. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-- Below any positive radius `r ≤ cellLength n₀` there is a level `n ≥ n₀` with +`cellLength (n + 1) < r ≤ cellLength n`. -/ +theorem exists_cellLength_lt_le {r : ℝ} (hr : 0 < r) {n₀ : ℕ} + (hr₀ : r ≤ cellLength n₀) : + ∃ n, n₀ ≤ n ∧ cellLength (n + 1) < r ∧ r ≤ cellLength n := by + classical + have hex : ∃ m, cellLength m < r := (tendsto_cellLength.eventually (gt_mem_nhds hr)).exists + have hspec := Nat.find_spec hex + have hlt : n₀ < Nat.find hex := by + by_contra h + have h' := cellLength_antitone (not_lt.mp h) + exact lt_irrefl _ (hspec.trans_le (hr₀.trans h')) + obtain ⟨n, hn⟩ : ∃ n, Nat.find hex = n + 1 := ⟨Nat.find hex - 1, by omega⟩ + refine ⟨n, by omega, ?_, not_lt.mp (Nat.find_min hex (by omega))⟩ + rwa [hn] at hspec + +/-- A point of the level-`n` cell of `x` at horizontal distance `< θ * r` from `x` lies within +distance `r` of `graphMap x` on the graph, once `4 / (n + 1) ≤ 1 - θ` and +`cellLength (n + 1) < r`. -/ +theorem dist_graphMap_lt {θ r : ℝ} (hθ : θ ∈ Ioo (0 : ℝ) 1) (hr : 0 < r) {n : ℕ} + (hn : 4 / ((n : ℝ) + 1) ≤ 1 - θ) (hrn : cellLength (n + 1) < r) {x y : ℝ} + (hxy : cellIndex n x = cellIndex n y) (hd : |x - y| < θ * r) : + dist (graphMap x) (graphMap y) < r := by + obtain ⟨hθ0, hθ1⟩ := hθ + have hpos := cellLength_pos (n + 1) + have h1 := abs_besicovitchFun_sub_le hxy + have h2 : 4 * cellLength (n + 1) / (n + 1) < (1 - θ) * r := by + calc 4 * cellLength (n + 1) / (n + 1) = 4 / ((n : ℝ) + 1) * cellLength (n + 1) := by ring + _ ≤ (1 - θ) * cellLength (n + 1) := mul_le_mul_of_nonneg_right hn hpos.le + _ < (1 - θ) * r := mul_lt_mul_of_pos_left hrn (by linarith) + have ha : (x - y) ^ 2 < (θ * r) ^ 2 := by + rw [← sq_abs]; exact pow_lt_pow_left₀ hd (abs_nonneg _) two_ne_zero + have hb : (besicovitchFun x - besicovitchFun y) ^ 2 < ((1 - θ) * r) ^ 2 := by + rw [← sq_abs]; exact pow_lt_pow_left₀ (h1.trans_lt h2) (abs_nonneg _) two_ne_zero + rw [dist_graphMap, Real.sqrt_lt' hr] + nlinarith [mul_pos (mul_pos hr hr) (mul_pos hθ0 (sub_pos.2 hθ1))] + +/-- **The key estimate.** For every `θ < 1` and every sufficiently small `r`, the ball of radius +`r` about the interior graph point `graphMap x` meets the graph in a set of Hausdorff measure at +least `θ * r`. -/ +theorem eventually_ofReal_le_hausdorffMeasure_inter_ball {x : ℝ} (hx : x ∈ Ioo (0 : ℝ) 1) + {θ : ℝ} (hθ : θ ∈ Ioo (0 : ℝ) 1) : + ∀ᶠ r in 𝓝[>] (0 : ℝ), + ENNReal.ofReal (θ * r) ≤ μH[1] (besicovitchSet ∩ Metric.ball (graphMap x) r) := by + obtain ⟨hx0, hx1⟩ := hx + obtain ⟨hθ0, hθ1⟩ := hθ + have hs : 0 < 1 - θ := by linarith + -- a level beyond which `4 / (n + 1) ≤ 1 - θ` + obtain ⟨n₀, hn₀⟩ := exists_nat_gt (4 / (1 - θ)) + have hn₀' : 4 / ((n₀ : ℝ) + 1) ≤ 1 - θ := by + rw [div_lt_iff₀ hs] at hn₀ + rw [div_le_iff₀ (by positivity)] + linarith + -- all the smallness conditions hold below `r₀` + have hr₀pos : 0 < min (cellLength n₀) (min x (1 - x)) := by + simp only [lt_min_iff] + exact ⟨cellLength_pos n₀, hx0, by linarith⟩ + filter_upwards [Ioo_mem_nhdsGT hr₀pos] with r hr + obtain ⟨hr0, hrr₀⟩ := hr + have hr1 : r ≤ cellLength n₀ := hrr₀.le.trans (min_le_left _ _) + have hrx : r < x := hrr₀.trans_le ((min_le_right _ _).trans (min_le_left _ _)) + have hrx' : r < 1 - x := hrr₀.trans_le ((min_le_right _ _).trans (min_le_right _ _)) + have hθr' : θ * r ≤ r := mul_le_of_le_one_left hr0.le hθ1.le + have hθr0 : 0 < θ * r := mul_pos hθ0 hr0 + -- the last level `n` with `r ≤ cellLength n` + obtain ⟨n, hn₀n, hlt, hle⟩ := exists_cellLength_lt_le hr0 hr1 + have hn : 4 / ((n : ℝ) + 1) ≤ 1 - θ := by + refine le_trans ?_ hn₀' + have : (n₀ : ℝ) ≤ n := by exact_mod_cast hn₀n + exact div_le_div_of_nonneg_left (by norm_num) (by positivity) (by linarith) + have hθr : θ * r ≤ cellLength n := hθr'.trans hle + -- the part of the cell of `x` within `θ * r` of `x` is the interval `Ioo a b` + have hxc := mem_cell_cellIndex n x + simp only [cell, mem_Ico] at hxc + obtain ⟨a, ha⟩ : ∃ a, a = max (x - θ * r) (cellIndex n x * cellLength n) := ⟨_, rfl⟩ + obtain ⟨b, hb⟩ : ∃ b, b = min (x + θ * r) ((cellIndex n x + 1) * cellLength n) := + ⟨_, rfl⟩ + have ha1 : x - θ * r ≤ a := by rw [ha]; exact le_max_left _ _ + have ha2 : cellIndex n x * cellLength n ≤ a := by rw [ha]; exact le_max_right _ _ + have hb1 : b ≤ x + θ * r := by rw [hb]; exact min_le_left _ _ + have hb2 : b ≤ (cellIndex n x + 1) * cellLength n := by rw [hb]; exact min_le_right _ _ + -- its length is at least `θ * r` + have hab : θ * r ≤ b - a := by + rw [ha, hb] + rcases le_total (x - θ * r) (cellIndex n x * cellLength n) with h1 | h1 <;> + rcases le_total (x + θ * r) ((cellIndex n x + 1) * cellLength n) with h2 | h2 + · rw [max_eq_right h1, min_eq_left h2]; linarith + · rw [max_eq_right h1, min_eq_right h2]; linarith + · rw [max_eq_left h1, min_eq_left h2]; linarith + · rw [max_eq_left h1, min_eq_right h2]; linarith + -- the graph over it lies in the set and in the ball + have hsub : graphMap '' Ioo a b ⊆ besicovitchSet ∩ Metric.ball (graphMap x) r := by + rintro _ ⟨y, ⟨hya, hyb⟩, rfl⟩ + refine ⟨⟨y, ⟨by linarith, by linarith⟩, rfl⟩, ?_⟩ + rw [Metric.mem_ball, dist_comm] + refine dist_graphMap_lt ⟨hθ0, hθ1⟩ hr0 hn hlt ?_ ?_ + · have hy : y ∈ cell n (cellIndex n x) := by + simp only [cell, mem_Ico]; constructor <;> linarith + exact (mem_cell_iff.mp hy).symm + · rw [abs_lt]; constructor <;> linarith + calc ENNReal.ofReal (θ * r) ≤ ENNReal.ofReal (b - a) := ENNReal.ofReal_le_ofReal hab + _ = volume (Ioo a b) := Real.volume_Ioo.symm + _ ≤ μH[1] (graphMap '' Ioo a b) := volume_le_hausdorffMeasure_graphMap_image _ + _ ≤ μH[1] (besicovitchSet ∩ Metric.ball (graphMap x) r) := measure_mono hsub + +/-- For every `θ < 1`, the lower density of the graph at an interior graph point is at least +`θ / 2`. -/ +theorem ofReal_half_le_lowerOneDensity_graphMap {x : ℝ} (hx : x ∈ Ioo (0 : ℝ) 1) {θ : ℝ} + (hθ : θ ∈ Ioo (0 : ℝ) 1) : + ENNReal.ofReal (θ / 2) ≤ lowerOneDensity besicovitchSet (graphMap x) := by + refine le_liminf_of_le (by isBoundedDefault) ?_ + filter_upwards [eventually_ofReal_le_hausdorffMeasure_inter_ball hx hθ, + self_mem_nhdsWithin] with r hr hr0 + rw [mem_Ioi] at hr0 + have h2r : ENNReal.ofReal (2 * r) ≠ 0 := (ENNReal.ofReal_pos.mpr (by linarith)).ne' + rw [ENNReal.le_div_iff_mul_le (Or.inl h2r) (Or.inl ENNReal.ofReal_ne_top), + ← ENNReal.ofReal_mul (by linarith [hθ.1])] + calc ENNReal.ofReal (θ / 2 * (2 * r)) = ENNReal.ofReal (θ * r) := by congr 1; ring + _ ≤ _ := hr + +/-- **The lower density of Besicovitch's set is at least `1/2`** at every interior point of the +graph. -/ +theorem one_half_le_lowerOneDensity_graphMap {x : ℝ} (hx : x ∈ Ioo (0 : ℝ) 1) : + ENNReal.ofReal (1 / 2) ≤ lowerOneDensity besicovitchSet (graphMap x) := by + refine le_of_forall_lt_imp_le_of_dense fun c hc ↦ ?_ + have hct : c ≠ ⊤ := ne_top_of_lt hc + have hcr : c.toReal < 1 / 2 := (ENNReal.lt_ofReal_iff_toReal_lt hct).mp hc + have hc0 : 0 ≤ c.toReal := ENNReal.toReal_nonneg + -- a `θ < 1` with `c ≤ θ / 2` + have hθ : (2 * c.toReal + 1) / 2 ∈ Ioo (0 : ℝ) 1 := ⟨by positivity, by linarith⟩ + calc c = ENNReal.ofReal c.toReal := (ENNReal.ofReal_toReal hct).symm + _ ≤ ENNReal.ofReal ((2 * c.toReal + 1) / 2 / 2) := ENNReal.ofReal_le_ofReal (by linarith) + _ ≤ lowerOneDensity besicovitchSet (graphMap x) := + ofReal_half_le_lowerOneDensity_graphMap hx hθ + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Measurable.lean b/LeanPool/Besicovitch/Example/Measurable.lean new file mode 100644 index 0000000000..f22ed6abc0 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Measurable.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Graph +public import Mathlib.MeasureTheory.Constructions.BorelSpace.Metrizable +public import Mathlib.MeasureTheory.Constructions.BorelSpace.Real +public import Mathlib.MeasureTheory.Function.Floor + +/-! +# Measurability of Besicovitch's function + +Each square wave is a step function, hence measurable, and `g` is a pointwise limit of finite +sums of them. +-/ + +@[expose] public section + +noncomputable section + +open Filter Topology + +namespace LeanPool.Besicovitch.Example + +theorem measurable_cellIndex (n : ℕ) : Measurable (cellIndex n) := + Measurable.comp Int.measurable_floor (measurable_id.div_const _) + +theorem measurable_squareWave (n : ℕ) : Measurable (squareWave n) := by + unfold squareWave + refine Measurable.ite ?_ measurable_const measurable_const + exact (measurable_cellIndex n) (show MeasurableSet {i : ℤ | Even i} from trivial) + +theorem measurable_besicovitchFun : Measurable besicovitchFun := by + have hpartial : ∀ N : ℕ, + Measurable fun x ↦ ∑ n ∈ Finset.range N, squareWave (n + 1) x := + fun N ↦ Finset.measurable_sum _ fun n _ ↦ measurable_squareWave (n + 1) + refine measurable_of_tendsto_metrizable hpartial ?_ + rw [tendsto_pi_nhds] + intro x + exact (summable_squareWave x).hasSum.tendsto_sum_nat + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Plane.lean b/LeanPool/Besicovitch/Example/Plane.lean new file mode 100644 index 0000000000..714c409527 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Plane.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Graph +public import Mathlib.Analysis.InnerProductSpace.PiL2 +public import Mathlib.Analysis.Normed.Lp.MeasurableSpace +public import Mathlib.MeasureTheory.Measure.Hausdorff +public import Mathlib.MeasureTheory.Measure.Lebesgue.Basic + +/-! +# Besicovitch's set in the plane + +The graph `Π = {(x, g x) : x ∈ [0, 1]}` of Besicovitch's function, as a subset of +`EuclideanSpace ℝ (Fin 2)`, together with the elementary metric facts used later: the distance +formula on the graph, the first-coordinate projection is `1`-Lipschitz (so the Hausdorff measure +of a piece of the graph is at least the Lebesgue measure of its base), and the graph over a +level-`n` cell has diameter at most twice the cell length. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-- The plane. -/ +abbrev Plane := EuclideanSpace ℝ (Fin 2) + +/-- The graph map `x ↦ (x, g x)`. -/ +def graphMap (x : ℝ) : Plane := !₂[x, besicovitchFun x] + +/-- Besicovitch's set: the graph of `g` over `[0, 1]`. -/ +def besicovitchSet : Set Plane := graphMap '' Icc 0 1 + +@[simp] theorem graphMap_apply_zero (x : ℝ) : graphMap x 0 = x := by simp [graphMap] + +@[simp] theorem graphMap_apply_one (x : ℝ) : graphMap x 1 = besicovitchFun x := by simp [graphMap] + +theorem graphMap_injective : Function.Injective graphMap := fun x y h ↦ by + simpa using congrArg (· 0) h + +/-- The distance between two points of the graph. -/ +theorem dist_graphMap (x y : ℝ) : + dist (graphMap x) (graphMap y) = + √((x - y) ^ 2 + (besicovitchFun x - besicovitchFun y) ^ 2) := by + rw [EuclideanSpace.dist_eq] + simp [Fin.sum_univ_two, Real.dist_eq, sq_abs] + +/-- The first coordinate is `1`-Lipschitz. -/ +theorem lipschitzWith_proj : LipschitzWith 1 (fun p : Plane ↦ p 0) := by + refine LipschitzWith.of_dist_le_mul fun p q ↦ ?_ + rw [EuclideanSpace.dist_eq, NNReal.coe_one, one_mul, Real.dist_eq] + simp only [Fin.sum_univ_two] + rw [Real.le_sqrt (abs_nonneg _) (by positivity), sq_abs, Real.dist_eq, Real.dist_eq, + sq_abs, sq_abs] + nlinarith [sq_nonneg (p 1 - q 1)] + +/-- The first coordinate recovers the base of a piece of the graph. -/ +theorem proj_image_graphMap_image (A : Set ℝ) : + (fun p : Plane ↦ p 0) '' (graphMap '' A) = A := by + rw [image_image]; simp + +/-- **(B≥)** The Hausdorff measure of a piece of the graph is at least the measure of its base. -/ +theorem volume_le_hausdorffMeasure_graphMap_image (A : Set ℝ) : + volume A ≤ μH[1] (graphMap '' A) := by + calc volume A = μH[1] A := by rw [hausdorffMeasure_real] + _ = μH[1] ((fun p : Plane ↦ p 0) '' (graphMap '' A)) := by rw [proj_image_graphMap_image] + _ ≤ ((1 : ℝ≥0) : ℝ≥0∞) ^ (1 : ℝ) * μH[1] (graphMap '' A) := + lipschitzWith_proj.hausdorffMeasure_image_le zero_le_one _ + _ = μH[1] (graphMap '' A) := by simp + +/-! ### Cells -/ + +/-- The level-`n` cell with index `i`. -/ +def cell (n : ℕ) (i : ℤ) : Set ℝ := Ico (i * cellLength n) ((i + 1) * cellLength n) + +theorem mem_cell_iff {n : ℕ} {i : ℤ} {x : ℝ} : x ∈ cell n i ↔ cellIndex n x = i := by + have hpos := cellLength_pos n + rw [cell, cellIndex, mem_Ico, Int.floor_eq_iff, le_div_iff₀ hpos, div_lt_iff₀ hpos] + +theorem mem_cell_cellIndex (n : ℕ) (x : ℝ) : x ∈ cell n (cellIndex n x) := + mem_cell_iff.mpr rfl + +theorem volume_cell (n : ℕ) (i : ℤ) : volume (cell n i) = ENNReal.ofReal (cellLength n) := by + rw [cell, Real.volume_Ico]; congr 1; ring + +theorem cell_disjoint {n : ℕ} {i j : ℤ} (h : i ≠ j) : Disjoint (cell n i) (cell n j) := by + rw [Set.disjoint_left] + intro x hx hx' + rw [mem_cell_iff] at hx hx' + exact h (hx.symm.trans hx') + +/-- The graph over a level-`n ≥ 1` cell has diameter at most twice the cell length. -/ +theorem diam_graphMap_image_cell_le {n : ℕ} (hn : 1 ≤ n) (i : ℤ) : + Metric.ediam (graphMap '' cell n i) ≤ ENNReal.ofReal (2 * cellLength n) := by + refine Metric.ediam_le ?_ + rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + rw [edist_dist, dist_graphMap] + refine ENNReal.ofReal_le_ofReal ?_ + have hxy : cellIndex n x = cellIndex n y := by + rw [mem_cell_iff] at hx hy; rw [hx, hy] + have h1 : |x - y| < cellLength n := by + -- both lie in an interval of length `cellLength n` + simp only [cell, mem_Ico] at hx hy + rw [abs_lt]; constructor <;> nlinarith + have h2 := abs_besicovitchFun_sub_le hxy + have h3 : 4 * cellLength (n + 1) / (n + 1) ≤ cellLength n := by + have hr := cellLength_succ_le_of_pos hn + have hpos' := cellLength_pos (n + 1) + have hn' : (1 : ℝ) ≤ (n : ℝ) + 1 := by linarith [Nat.cast_nonneg (α := ℝ) n] + calc 4 * cellLength (n + 1) / (n + 1) ≤ 4 * cellLength (n + 1) := + div_le_self (by linarith) hn' + _ ≤ cellLength n := by linarith + have hpos := cellLength_pos n + have ha : (x - y) ^ 2 ≤ cellLength n ^ 2 := by + rw [← sq_abs]; exact pow_le_pow_left₀ (abs_nonneg _) h1.le 2 + have hb : (besicovitchFun x - besicovitchFun y) ^ 2 ≤ cellLength n ^ 2 := by + rw [← sq_abs]; exact pow_le_pow_left₀ (abs_nonneg _) (h2.trans h3) 2 + calc √((x - y) ^ 2 + (besicovitchFun x - besicovitchFun y) ^ 2) + ≤ √((2 * cellLength n) ^ 2) := Real.sqrt_le_sqrt (by nlinarith) + _ = 2 * cellLength n := Real.sqrt_sq (by positivity) + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Recursion.lean b/LeanPool/Besicovitch/Example/Recursion.lean new file mode 100644 index 0000000000..d140ff2ca3 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Recursion.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.SpecialFunctions.Exp +public import Mathlib.Analysis.SpecificLimits.Basic +public import Mathlib.Analysis.SumOverResidueClass + +/-! +# A recursion that forces a sequence to zero + +If `u (n+1) ≤ (1 - a (n+1)) * u n + e (n+1)` with `0 ≤ a n ≤ 1`, the partial sums of `a` +unbounded and `e` summable, then `u n → 0`. This drives the hole argument: the measure of what +survives the level-`n` holes contracts by a factor `1 - c/n` at each level, up to a summable +error, and `∑ 1/n = ∞`. +-/ + +@[expose] public section + +open Filter Finset Topology + +namespace LeanPool.Besicovitch.Example + +variable {u a e : ℕ → ℝ} + +/-- Unrolling the recursion from level `N` to level `n`. -/ +theorem le_prod_mul_add_sum_of_recursive (ha : ∀ n, 0 ≤ a n) + (ha1 : ∀ n, a n ≤ 1) (he : ∀ n, 0 ≤ e n) + (h : ∀ n, u (n + 1) ≤ (1 - a (n + 1)) * u n + e (n + 1)) (N : ℕ) : + ∀ n, N ≤ n → + u n ≤ (∏ k ∈ Ioc N n, (1 - a k)) * u N + ∑ k ∈ Ioc N n, e k := by + intro n hn + induction n, hn using Nat.le_induction with + | base => simp + | succ n hNn ih => + have hprod : 0 ≤ ∏ k ∈ Ioc N n, (1 - a k) := prod_nonneg fun k _ ↦ by linarith [ha1 k] + have h1a : 0 ≤ 1 - a (n + 1) := by linarith [ha1 (n + 1)] + rw [Finset.prod_Ioc_succ_top hNn, Finset.sum_Ioc_succ_top hNn] + calc u (n + 1) ≤ (1 - a (n + 1)) * u n + e (n + 1) := h n + _ ≤ (1 - a (n + 1)) * ((∏ k ∈ Ioc N n, (1 - a k)) * u N + ∑ k ∈ Ioc N n, e k) + + e (n + 1) := by gcongr + _ ≤ (∏ k ∈ Ioc N n, (1 - a k)) * (1 - a (n + 1)) * u N + + (∑ k ∈ Ioc N n, e k + e (n + 1)) := by + have hsum : 0 ≤ ∑ k ∈ Ioc N n, e k := sum_nonneg fun k _ ↦ he k + have : (1 - a (n + 1)) * ∑ k ∈ Ioc N n, e k ≤ ∑ k ∈ Ioc N n, e k := + mul_le_of_le_one_left hsum (by linarith [ha (n + 1)]) + nlinarith + +/-- A product of `1 - a k` is at most `exp (-∑ a k)`. -/ +theorem prod_one_sub_le_exp_neg_sum (ha1 : ∀ n, a n ≤ 1) (s : Finset ℕ) : + ∏ k ∈ s, (1 - a k) ≤ Real.exp (-∑ k ∈ s, a k) := by + rw [← Finset.sum_neg_distrib, Real.exp_sum] + refine Finset.prod_le_prod₀ (fun k _ ↦ by linarith [ha1 k]) fun k _ ↦ ?_ + have := Real.add_one_le_exp (-a k) + linarith + +/-- The sums `∑_{k ∈ Ioc N n} a k` tend to infinity when the partial sums of `a` do. -/ +theorem tendsto_sum_Ioc_atTop (hasum : Tendsto (fun n ↦ ∑ k ∈ range n, a k) atTop atTop) (N : ℕ) : + Tendsto (fun n ↦ ∑ k ∈ Ioc N n, a k) atTop atTop := by + have hsplit : ∀ n, N ≤ n → + ∑ k ∈ Ioc N n, a k = ∑ k ∈ range (n + 1), a k - ∑ k ∈ range (N + 1), a k := by + intro n hn + have hIoc : Ioc N n = Ico (N + 1) (n + 1) := by + ext k; simp only [Finset.mem_Ioc, Finset.mem_Ico]; omega + rw [hIoc, Finset.sum_Ico_eq_sub _ (by omega)] + have h1 : Tendsto (fun n ↦ ∑ k ∈ range (n + 1), a k - ∑ k ∈ range (N + 1), a k) + atTop atTop := by + have h0 : Tendsto (fun n ↦ ∑ k ∈ range (n + 1), a k) atTop atTop := + hasum.comp (tendsto_add_atTop_nat 1) + have := tendsto_atTop_add_const_right atTop (-∑ k ∈ range (N + 1), a k) h0 + exact this.congr fun n ↦ (sub_eq_add_neg _ _).symm + exact h1.congr' ((eventually_ge_atTop N).mono fun n hn ↦ (hsplit n hn).symm) + +/-- The main recursion lemma. -/ +theorem tendsto_zero_of_recursive (hu : ∀ n, 0 ≤ u n) (ha : ∀ n, 0 ≤ a n) + (ha1 : ∀ n, a n ≤ 1) + (he : ∀ n, 0 ≤ e n) (hasum : Tendsto (fun n ↦ ∑ k ∈ range n, a k) atTop atTop) + (hesum : Summable e) + (h : ∀ n, u (n + 1) ≤ (1 - a (n + 1)) * u n + e (n + 1)) : + Tendsto u atTop (𝓝 0) := by + rw [tendsto_order] + refine ⟨fun b hb ↦ Eventually.of_forall fun n ↦ hb.trans_le (hu n), fun ε hε ↦ ?_⟩ + -- choose `N` with the tail of `e` from `N` on at most `ε / 2` + obtain ⟨N, hN⟩ : ∃ N, ∑' k, e (k + N) ≤ ε / 2 := + ((tendsto_sum_nat_add e).eventually (ge_mem_nhds (half_pos hε))).exists + -- the product from `N` on decays to zero + have hprod : Tendsto (fun n ↦ ∏ k ∈ Ioc N n, (1 - a k)) atTop (𝓝 0) := by + have hexp : Tendsto (fun n ↦ Real.exp (-∑ k ∈ Ioc N n, a k)) atTop (𝓝 0) := + Real.tendsto_exp_atBot.comp (tendsto_neg_atTop_atBot.comp (tendsto_sum_Ioc_atTop hasum N)) + exact squeeze_zero (fun n ↦ prod_nonneg fun k _ ↦ by linarith [ha1 k]) + (fun n ↦ prod_one_sub_le_exp_neg_sum ha1 _) hexp + -- the tail of `e` over `Ioc N n` is at most the tail sum from `N` + have htail : ∀ n, ∑ k ∈ Ioc N n, e k ≤ ∑' k, e (k + N) := by + intro n + have hsub : Ioc N n ⊆ (range (n + 1)).image (· + N) := by + intro k hk + rw [Finset.mem_Ioc] at hk + exact Finset.mem_image.mpr ⟨k - N, Finset.mem_range.mpr (by omega), by omega⟩ + calc ∑ k ∈ Ioc N n, e k ≤ ∑ k ∈ (range (n + 1)).image (· + N), e k := + Finset.sum_le_sum_of_subset_of_nonneg hsub fun k _ _ ↦ he k + _ = ∑ k ∈ range (n + 1), e (k + N) := + Finset.sum_image fun _ _ _ _ hxy ↦ by omega + _ ≤ ∑' k, e (k + N) := + Summable.sum_le_tsum _ (fun k _ ↦ he _) ((summable_nat_add_iff N).mpr hesum) + -- combine + have hbound := le_prod_mul_add_sum_of_recursive ha ha1 he h N + have hsmall : ∀ᶠ n in atTop, (∏ k ∈ Ioc N n, (1 - a k)) * u N < ε / 2 := by + rcases (hu N).eq_or_lt with hN0 | hN0 + · exact Eventually.of_forall fun n ↦ by rw [← hN0, mul_zero]; exact half_pos hε + · have := hprod.eventually (gt_mem_nhds (div_pos (half_pos hε) hN0)) + exact this.mono fun n hn ↦ by rwa [lt_div_iff₀ hN0] at hn + filter_upwards [hsmall, eventually_ge_atTop N] with n hn hNn + calc u n ≤ (∏ k ∈ Ioc N n, (1 - a k)) * u N + ∑ k ∈ Ioc N n, e k := hbound n hNn + _ < ε / 2 + ε / 2 := by linarith [htail n] + _ = ε := by ring + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Reduction.lean b/LeanPool/Besicovitch/Example/Reduction.lean new file mode 100644 index 0000000000..7cfad91cac --- /dev/null +++ b/LeanPool/Besicovitch/Example/Reduction.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Hull +public import LeanPool.Besicovitch.Example.Measurable +public import Mathlib.Analysis.Calculus.Rademacher +public import Mathlib.MeasureTheory.Function.Jacobian + +/-! +# Reduction from Lipschitz curves to Lipschitz pieces of `g` + +If a Lipschitz curve `f : ℝ → ℝ²` meets Besicovitch's set `Π` in positive `μH[1]`-measure, +then `g` is Lipschitz on a subset of `[0, 1]` of positive Lebesgue measure. + +Let `f₁ = π₁ ∘ f` be the first coordinate of the curve and `B = f ⁻¹ Π`. By Rademacher's +theorem `f₁` is differentiable almost everywhere, and the curve over the null set of +non-differentiability points carries no `μH[1]`-measure. Over the points where `f₁' = 0` the +image of `f₁` is Lebesgue-null (the one-dimensional area formula), so the graph over it, which +contains the curve there, is `μH[1]`-null by `LeanPool.Besicovitch.Example.Hull`. Hence the + curve over +the points with `f₁' ≠ 0` has positive measure; a countable partition of these into pieces on +which `f₁` is well approximated by a nonzero linear map produces a piece `P` on which `f₁` is +bi-Lipschitz. On `A = f₁ '' P` the function `g` is then Lipschitz, since `g (f₁ t) = f₂ t` +is Lipschitz in `t` and `t` is Lipschitz in `f₁ t`; and `A` has positive Lebesgue measure since +the graph over `A` contains `f '' P`. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-! ### Besicovitch's set as a graph -/ + +/-- A point whose second coordinate is `g` of its first lies on the graph over that first +coordinate. -/ +theorem graphMap_eq_of_apply_one {p : Plane} (h : p 1 = besicovitchFun (p 0)) : + graphMap (p 0) = p := by + refine PiLp.ext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) + · simp + · simpa using h.symm + +/-- Membership in Besicovitch's set in terms of coordinates. -/ +theorem mem_besicovitchSet_iff {p : Plane} : + p ∈ besicovitchSet ↔ p 0 ∈ Icc (0:ℝ) 1 ∧ p 1 = besicovitchFun (p 0) := by + constructor + · rintro ⟨x, hx, rfl⟩ + simpa using hx + · rintro ⟨h0, h1⟩ + exact ⟨p 0, h0, graphMap_eq_of_apply_one h1⟩ + +/-- A point of Besicovitch's set is the graph point over its first coordinate. -/ +theorem graphMap_eq_of_mem {p : Plane} (hp : p ∈ besicovitchSet) : graphMap (p 0) = p := + graphMap_eq_of_apply_one (mem_besicovitchSet_iff.mp hp).2 + +/-- Besicovitch's set is measurable. -/ +theorem measurableSet_besicovitchSet : MeasurableSet besicovitchSet := by + have hset : besicovitchSet = + {p : Plane | p 0 ∈ Icc (0:ℝ) 1} ∩ {p : Plane | p 1 = besicovitchFun (p 0)} := + Set.ext fun _ ↦ mem_besicovitchSet_iff + have h0 : Measurable fun p : Plane ↦ p 0 := (PiLp.continuous_apply 2 _ 0).measurable + have h1 : Measurable fun p : Plane ↦ p 1 := (PiLp.continuous_apply 2 _ 1).measurable + rw [hset] + exact (h0 measurableSet_Icc).inter + (measurableSet_eq_fun h1 (measurable_besicovitchFun.comp h0)) + +/-! ### Coordinates of a Lipschitz curve -/ + +/-- Each coordinate of the plane is `1`-Lipschitz. -/ +theorem lipschitzWith_coord (i : Fin 2) : LipschitzWith 1 (fun p : Plane ↦ p i) := by + refine LipschitzWith.of_dist_le_mul fun p q ↦ ?_ + rw [NNReal.coe_one, one_mul, dist_eq_norm, dist_eq_norm] + simpa using PiLp.norm_apply_le (p - q) i + +/-- A coordinate of a `K`-Lipschitz curve is `K`-Lipschitz. -/ +theorem lipschitzWith_curve_coord {K : ℝ≥0} {f : ℝ → Plane} (hf : LipschitzWith K f) + (i : Fin 2) : LipschitzWith K fun t ↦ f t i := by + have := (lipschitzWith_coord i).comp hf + rwa [one_mul] at this + +/-- The curve over a set of its preimage of `Π` lies in the graph over the first coordinates. -/ +theorem image_subset_graphMap_image {f : ℝ → Plane} {S : Set ℝ} + (hS : S ⊆ f ⁻¹' besicovitchSet) : + f '' S ⊆ graphMap '' ((fun t ↦ f t 0) '' S) := by + rintro _ ⟨t, ht, rfl⟩ + exact ⟨f t 0, ⟨t, ht, rfl⟩, graphMap_eq_of_mem (hS ht)⟩ + +/-- The curve over a piece of its preimage of `Π` has `μH[1]`-measure at most twice the Lebesgue +measure of the first coordinates. -/ +theorem hausdorffMeasure_image_le_volume_image {f : ℝ → Plane} {S : Set ℝ} + (hS : S ⊆ f ⁻¹' besicovitchSet) : + μH[1] (f '' S) ≤ 2 * volume ((fun t ↦ f t 0) '' S) := + (measure_mono (image_subset_graphMap_image hS)).trans + (hausdorffMeasure_graphMap_image_le _) + +/-- A Lipschitz curve over a Lebesgue-null set is `μH[1]`-null. -/ +theorem hausdorffMeasure_image_eq_zero_of_volume_eq_zero {K : ℝ≥0} {f : ℝ → Plane} + (hf : LipschitzWith K f) {N : Set ℝ} (hN : volume N = 0) : μH[1] (f '' N) = 0 := by + have h := hf.hausdorffMeasure_image_le zero_le_one N + rw [hausdorffMeasure_real, hN, mul_zero] at h + exact nonpos_iff_eq_zero.mp h + +/-- The image of a set on which a real function has zero derivative is Lebesgue-null. -/ +theorem volume_image_eq_zero_of_fderiv_eq_zero {f₁ : ℝ → ℝ} {S : Set ℝ} + (hS : ∀ t ∈ S, DifferentiableAt ℝ f₁ t ∧ fderiv ℝ f₁ t = 0) : + volume (f₁ '' S) = 0 := + addHaar_image_eq_zero_of_det_fderivWithin_eq_zero volume (f' := fun t ↦ fderiv ℝ f₁ t) + (fun t ht ↦ (hS t ht).1.hasFDerivAt.hasFDerivWithinAt) + (fun t ht ↦ by rw [(hS t ht).2]; simp) + +/-! ### Pieces on which the first coordinate is bi-Lipschitz -/ + +/-- A linear map `ℝ → ℝ` is multiplication by its value at `1`. -/ +theorem clm_apply_eq_mul (A : ℝ →L[ℝ] ℝ) (z : ℝ) : A z = z * A 1 := by + simpa using A.map_smul z 1 + +/-- The operator norm of a linear map `ℝ → ℝ` is at most its value at `1`. -/ +theorem clm_norm_le_abs_apply_one (A : ℝ →L[ℝ] ℝ) : ‖A‖ ≤ |A 1| := + A.opNorm_le_bound (abs_nonneg _) fun z ↦ by + rw [clm_apply_eq_mul, Real.norm_eq_abs, Real.norm_eq_abs, abs_mul, mul_comm] + +/-- A nonzero linear map `ℝ → ℝ` has nonzero value at `1`. -/ +theorem clm_abs_apply_one_pos {A : ℝ →L[ℝ] ℝ} (hA : A ≠ 0) : 0 < |A 1| := by + refine abs_pos.mpr fun h ↦ hA ?_ + ext + rw [clm_apply_eq_mul, h] + simp + +/-- A function approximated by a nonzero linear map `A` on `P` within `‖A‖ / 2` is bi-Lipschitz +from below on `P` with constant `|A 1| / 2`. -/ +theorem abs_sub_le_of_approximatesLinearOn {f₁ : ℝ → ℝ} {A : ℝ →L[ℝ] ℝ} + {P : Set ℝ} (happ : ApproximatesLinearOn f₁ A P (‖A‖₊ / 2)) {x y : ℝ} + (hx : x ∈ P) (hy : y ∈ P) : + |A 1| / 2 * |x - y| ≤ |f₁ x - f₁ y| := by + have h1 := happ x hx y hy + have hc : ((‖A‖₊ / 2 : ℝ≥0) : ℝ) = ‖A‖ / 2 := by push_cast; rfl + rw [hc, Real.norm_eq_abs, Real.norm_eq_abs] at h1 + have h2 : |A (x - y)| = |x - y| * |A 1| := by rw [clm_apply_eq_mul, abs_mul] + have h3 := clm_norm_le_abs_apply_one A + have h4 := abs_sub_abs_le_abs_sub (A (x - y)) (f₁ x - f₁ y) + have h5 := mul_le_mul_of_nonneg_right h3 (abs_nonneg (x - y)) + have h6 := abs_sub_comm (A (x - y)) (f₁ x - f₁ y) + linarith + +/-- The conclusion on a single piece: if the curve over `P ⊆ f ⁻¹' Π` has positive +`μH[1]`-measure and the first coordinate is well approximated on `P` by a nonzero linear map, +then `g` is Lipschitz on the first coordinates of `P`, a set of positive measure. -/ +theorem exists_lipschitzOnWith_of_piece {K : ℝ≥0} {f : ℝ → Plane} (hf : LipschitzWith K f) + {P : Set ℝ} (hP : P ⊆ f ⁻¹' besicovitchSet) {A : ℝ →L[ℝ] ℝ} (hA : A ≠ 0) + (happ : ApproximatesLinearOn (fun t ↦ f t 0) A P (‖A‖₊ / 2)) + (hpos : 0 < μH[1] (f '' P)) : + ∃ (L : ℝ≥0) (S : Set ℝ), S ⊆ Icc 0 1 ∧ 0 < volume S ∧ + LipschitzOnWith L besicovitchFun S := by + set a := |A 1| + have ha : 0 < a := clm_abs_apply_one_pos hA + refine ⟨⟨2 * K / a, by positivity⟩, (fun t ↦ f t 0) '' P, ?_, ?_, ?_⟩ + · rintro _ ⟨t, ht, rfl⟩ + exact (mem_besicovitchSet_iff.mp (hP ht)).1 + · by_contra h + rw [not_lt, nonpos_iff_eq_zero] at h + have := hausdorffMeasure_image_le_volume_image hP + rw [h, mul_zero] at this + exact absurd (hpos.trans_le this) (lt_irrefl _) + · refine LipschitzOnWith.of_dist_le_mul ?_ + rintro _ ⟨s, hs, rfl⟩ _ ⟨s', hs', rfl⟩ + change |besicovitchFun (f s 0) - besicovitchFun (f s' 0)| ≤ 2 * K / a * |f s 0 - f s' 0| + rw [← (mem_besicovitchSet_iff.mp (hP hs)).2, ← (mem_besicovitchSet_iff.mp (hP hs')).2] + have hK := (lipschitzWith_curve_coord hf 1).dist_le_mul s s' + rw [Real.dist_eq, Real.dist_eq] at hK + have hl := abs_sub_le_of_approximatesLinearOn happ hs hs' + calc |f s 1 - f s' 1| ≤ K * |s - s'| := hK + _ = 2 * K / a * (a / 2 * |s - s'|) := by field_simp + _ ≤ 2 * K / a * |f s 0 - f s' 0| := by gcongr + +/-! ### The reduction -/ + +/-- **Reduction.** A Lipschitz curve meeting Besicovitch's set in positive `μH[1]`-measure +yields a subset of `[0, 1]` of positive Lebesgue measure on which `g` is Lipschitz. -/ +theorem exists_lipschitzOnWith_of_hausdorffMeasure_pos {K : ℝ≥0} {f : ℝ → Plane} + (hf : LipschitzWith K f) (hpos : 0 < μH[1] (range f ∩ besicovitchSet)) : + ∃ (L : ℝ≥0) (A : Set ℝ), A ⊆ Icc 0 1 ∧ 0 < volume A ∧ + LipschitzOnWith L besicovitchFun A := by + classical + rw [← image_preimage_eq_range_inter] at hpos + set B := f ⁻¹' besicovitchSet + set f₁ : ℝ → ℝ := fun t ↦ f t 0 + have hf₁lip : LipschitzWith K f₁ := lipschitzWith_curve_coord hf 0 + set D := {t | DifferentiableAt ℝ f₁ t} + have hDc : volume {t | ¬ DifferentiableAt ℝ f₁ t} = 0 := + ae_iff.mp (hf₁lip.ae_differentiableAt (μ := volume)) + set B₀ := B ∩ D ∩ {t | fderiv ℝ f₁ t = 0} + set B₁ := B ∩ D ∩ {t | fderiv ℝ f₁ t ≠ 0} + -- the curve over the non-differentiability points is null + have h1 : μH[1] (f '' (B \ D)) = 0 := + hausdorffMeasure_image_eq_zero_of_volume_eq_zero hf + (measure_mono_null (fun t ht ↦ ht.2) hDc) + -- the curve over the zero-derivative points is null + have h2 : μH[1] (f '' B₀) = 0 := by + refine measure_mono_null (image_subset_graphMap_image fun t ht ↦ ht.1.1) + (hausdorffMeasure_graphMap_image_eq_zero ?_) + exact volume_image_eq_zero_of_fderiv_eq_zero fun t ht ↦ ⟨ht.1.2, ht.2⟩ + -- so the curve over the nonzero-derivative points has positive measure + have hcover : B ⊆ (B \ D) ∪ B₀ ∪ B₁ := by + intro t ht + by_cases hDt : t ∈ D + · by_cases h0 : fderiv ℝ f₁ t = 0 + · exact Or.inl (Or.inr ⟨⟨ht, hDt⟩, h0⟩) + · exact Or.inr ⟨⟨ht, hDt⟩, h0⟩ + · exact Or.inl (Or.inl ⟨ht, hDt⟩) + have hpos' : 0 < μH[1] (f '' B₁) := by + by_contra h + rw [not_lt, nonpos_iff_eq_zero] at h + have hle : μH[1] (f '' B) ≤ + μH[1] (f '' (B \ D)) + μH[1] (f '' B₀) + μH[1] (f '' B₁) := + calc μH[1] (f '' B) ≤ μH[1] (f '' ((B \ D) ∪ B₀ ∪ B₁)) := + measure_mono (image_mono hcover) + _ = μH[1] (f '' (B \ D) ∪ f '' B₀ ∪ f '' B₁) := by rw [image_union, image_union] + _ ≤ _ := (measure_union_le _ _).trans (add_le_add (measure_union_le _ _) le_rfl) + rw [h1, h2, h, add_zero, add_zero] at hle + exact absurd (hpos.trans_le hle) (lt_irrefl _) + -- partition the nonzero-derivative points into pieces with good linear approximations + have hderiv : ∀ t ∈ B₁, HasFDerivWithinAt f₁ (fderiv ℝ f₁ t) B₁ t := + fun t ht ↦ ht.1.2.hasFDerivAt.hasFDerivWithinAt + obtain ⟨t, A, -, -, hcov, happrox, hA⟩ := + exists_partition_approximatesLinearOn_of_hasFDerivWithinAt f₁ B₁ + (fun t ↦ fderiv ℝ f₁ t) hderiv (fun A ↦ if A = 0 then 1 else ‖A‖₊ / 2) + fun A ↦ by + split_ifs with h + · exact one_ne_zero + · exact div_ne_zero (nnnorm_ne_zero_iff.mpr h) two_ne_zero + -- some piece carries positive measure + obtain ⟨n, hn⟩ : ∃ n, 0 < μH[1] (f '' (B₁ ∩ t n)) := by + by_contra h + have hsum : ∑' n, μH[1] (f '' (B₁ ∩ t n)) = 0 := + ENNReal.tsum_eq_zero.mpr fun n ↦ + nonpos_iff_eq_zero.mp (not_lt.mp (not_exists.mp h n)) + have hle : μH[1] (f '' B₁) ≤ ∑' n, μH[1] (f '' (B₁ ∩ t n)) := + calc μH[1] (f '' B₁) ≤ μH[1] (f '' ⋃ n, B₁ ∩ t n) := by + refine measure_mono (image_mono ?_) + rw [← inter_iUnion] + exact subset_inter subset_rfl hcov + _ = μH[1] (⋃ n, f '' (B₁ ∩ t n)) := by rw [image_iUnion] + _ ≤ _ := measure_iUnion_le _ + rw [hsum] at hle + exact absurd (hpos'.trans_le hle) (lt_irrefl _) + -- the linear map of that piece is nonzero + have hne : B₁.Nonempty := + (Set.image_nonempty.mp (nonempty_of_measure_ne_zero hn.ne')).mono inter_subset_left + obtain ⟨y, hy, hAy⟩ := hA hne n + have hAne : A n ≠ 0 := by rw [hAy]; exact hy.2 + have happ := happrox n + simp only [hAne, ↓reduceIte] at happ + exact exists_lipschitzOnWith_of_piece hf (fun s hs ↦ hs.1.1.1) hAne happ hn + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Example/Zero.lean b/LeanPool/Besicovitch/Example/Zero.lean new file mode 100644 index 0000000000..d6d43fe761 --- /dev/null +++ b/LeanPool/Besicovitch/Example/Zero.lean @@ -0,0 +1,426 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Example.Density +public import LeanPool.Besicovitch.Example.Recursion +public import Mathlib.Analysis.PSeries + +/-! +# The Lipschitz pieces of Besicovitch's graph are null + +A point of `[0, 1]` that avoids every grid of level `N, N + 1, …` on both sides lies in a +set of measure zero. Indeed, inside a level-`M` cell the survivors of the levels up to `M` form +an interval, and the level-`M + 1` grid punches holes of total relative size `1 / ((M+1) (L+1))` +into every interval, up to an error of a few holes per cell. The errors are summable while +`∑ 1 / ((M + 1) (L + 1))` diverges, so the recursion of + `LeanPool.Besicovitch.Example.Recursion` forces +the surviving measure to zero. + +Combined with `ae_eventually_mem_avoid`, every subset of `[0, 1]` on which `g` is Lipschitz is +Lebesgue-null. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set Filter Topology +open scoped ENNReal NNReal + +namespace LeanPool.Besicovitch.Example + +/-- A subset of `[0, 1]` has finite Lebesgue measure. -/ +theorem volume_ne_top_of_subset_Icc {S : Set ℝ} (hS : S ⊆ Icc 0 1) : volume S ≠ ⊤ := + ne_top_of_le_ne_top (by rw [Real.volume_Icc]; exact ENNReal.ofReal_ne_top) (measure_mono hS) + +/-! ### Holes around grid points -/ + +/-- The relative width `2 * margin L m / cellLength m` of a hole is `1 / (m (L + 1))`. -/ +theorem two_mul_margin_div_cellLength {L : ℝ} (hL : 0 ≤ L) {m : ℕ} (hm : 1 ≤ m) : + 2 * margin L m / cellLength m = 1 / (m * (L + 1)) := by + have hm' : (0 : ℝ) < m := by exact_mod_cast hm + have hpos := cellLength_pos m + have hL1 : (0 : ℝ) < L + 1 := by linarith + unfold margin + field_simp + +/-- The open hole of radius `margin L m` around the level-`m` grid point with index `k`. -/ +def hole (L : ℝ) (m : ℕ) (k : ℤ) : Set ℝ := + Ioo (gridPoint m k - margin L m) (gridPoint m k + margin L m) + +/-- A hole is measurable. -/ +theorem measurableSet_hole (L : ℝ) (m : ℕ) (k : ℤ) : MeasurableSet (hole L m k) := + measurableSet_Ioo + +/-- A hole has measure `2 * margin L m`. -/ +theorem volume_hole (L : ℝ) (m : ℕ) (k : ℤ) : + volume (hole L m k) = ENNReal.ofReal (2 * margin L m) := by + rw [hole, Real.volume_Ioo]; congr 1; ring + +/-- A hole misses the avoided set. -/ +theorem disjoint_hole_avoid (L : ℝ) (m : ℕ) (k : ℤ) : Disjoint (hole L m k) (avoid L m) := by + rw [Set.disjoint_left] + intro x hx hx' + simp only [hole, mem_Ioo] at hx + have h := hx' k + have : |x - gridPoint m k| < margin L m := by rw [abs_lt]; constructor <;> linarith + linarith + +/-- Distinct holes of the same level are disjoint. -/ +theorem pairwiseDisjoint_hole {L : ℝ} (hL : 0 ≤ L) {m : ℕ} (hm : 1 ≤ m) (I : Finset ℤ) : + (I : Set ℤ).PairwiseDisjoint (hole L m) := by + intro k _ k' _ hkk' + have hμ := margin_le_half hL hm + have hpos := cellLength_pos m + change Disjoint (hole L m k) (hole L m k') + rw [Set.disjoint_left] + intro x hx hx' + simp only [hole, gridPoint, mem_Ioo] at hx hx' + have h1 : ((k : ℝ) - k') * cellLength m < 1 * cellLength m := by linarith + have h2 : ((k' : ℝ) - k) * cellLength m < 1 * cellLength m := by linarith + have h1' : (k : ℝ) - k' < 1 := lt_of_mul_lt_mul_right h1 hpos.le + have h2' : (k' : ℝ) - k < 1 := lt_of_mul_lt_mul_right h2 hpos.le + have h3 : k - k' < 1 := by exact_mod_cast h1' + have h4 : k' - k < 1 := by exact_mod_cast h2' + omega + +/-! ### The estimate on one interval -/ + +/-- **Per-interval estimate.** An order-connected subset `S` of `[0, 1]` loses the fraction +`1 / (m (L + 1))` of its measure, up to an error of `4 * margin L m`, when the level-`m` grid +is avoided: the holes around the level-`m` grid points inside `S` are disjoint, are removed, +and number at least `volume S / cellLength m - 2`. -/ +theorem volume_inter_avoid_le {L : ℝ} (hL : 0 ≤ L) {m : ℕ} (hm : 1 ≤ m) {S : Set ℝ} + (hS : S.OrdConnected) (hS1 : S ⊆ Icc 0 1) : + (volume (S ∩ avoid L m)).toReal ≤ + (1 - 1 / (m * (L + 1))) * (volume S).toReal + 4 * margin L m := by + have hαpos := cellLength_pos m + have hμpos := margin_pos hL hm + have hμα := margin_le_half hL hm + have hm' : (1 : ℝ) ≤ m := by exact_mod_cast hm + have hratio := two_mul_margin_div_cellLength hL hm + have hfin := volume_ne_top_of_subset_Icc hS1 + have hfin' : volume (S ∩ avoid L m) ≠ ⊤ := + volume_ne_top_of_subset_Icc (inter_subset_left.trans hS1) + have hcpos : 0 ≤ 1 / ((m : ℝ) * (L + 1)) := by positivity + have hc : 1 / ((m : ℝ) * (L + 1)) ≤ 1 := by + rw [div_le_one (by positivity)]; nlinarith + rcases S.eq_empty_or_nonempty with rfl | hne + · simp only [empty_inter, measure_empty, ENNReal.toReal_zero, mul_zero, zero_add] + positivity + -- the endpoints of `S` + have hbb : BddBelow S := ⟨0, fun x hx ↦ (hS1 hx).1⟩ + have hba : BddAbove S := ⟨1, fun x hx ↦ (hS1 hx).2⟩ + have huv : sInf S ≤ sSup S := csInf_le_csSup hne hbb hba + have hSuv : S ⊆ Icc (sInf S) (sSup S) := fun x hx ↦ ⟨csInf_le hbb hx, le_csSup hba hx⟩ + have huvS : Ioo (sInf S) (sSup S) ⊆ S := by + rintro y ⟨hy1, hy2⟩ + obtain ⟨a, ha, hay⟩ := exists_lt_of_csInf_lt hne hy1 + obtain ⟨b, hb, hyb⟩ := exists_lt_of_lt_csSup hne hy2 + exact hS.out ha hb ⟨hay.le, hyb.le⟩ + have hℓ : (volume S).toReal ≤ sSup S - sInf S := by + refine ENNReal.toReal_le_of_le_ofReal (by linarith) ?_ + rw [← Real.volume_Icc]; exact measure_mono hSuv + -- the holes inside `S`: indices `k` with `sInf S + margin ≤ k α ≤ sSup S - margin` + obtain ⟨A, hA⟩ : ∃ A : ℝ, A = (sInf S + margin L m) / cellLength m := ⟨_, rfl⟩ + obtain ⟨B, hB⟩ : ∃ B : ℝ, B = (sSup S - margin L m) / cellLength m := ⟨_, rfl⟩ + obtain ⟨I, hI⟩ : ∃ I : Finset ℤ, I = Finset.Icc ⌈A⌉ ⌊B⌋ := ⟨_, rfl⟩ + have hIS : ∀ k ∈ I, hole L m k ⊆ S := by + intro k hk + rw [hI, Finset.mem_Icc, Int.ceil_le, Int.le_floor, hA, hB, div_le_iff₀ hαpos, + le_div_iff₀ hαpos] at hk + intro x hx + simp only [hole, gridPoint, mem_Ioo] at hx + exact huvS ⟨by linarith [hk.1, hx.1], by linarith [hk.2, hx.2]⟩ + have hmeas : MeasurableSet (⋃ k ∈ I, hole L m k) := + Finset.measurableSet_biUnion _ fun k _ ↦ measurableSet_hole L m k + have hdisj : Disjoint (S ∩ avoid L m) (⋃ k ∈ I, hole L m k) := by + rw [disjoint_iUnion₂_right] + intro k _ + exact (disjoint_hole_avoid L m k).symm.mono_left inter_subset_right + have hvolU : volume (⋃ k ∈ I, hole L m k) = I.card * ENNReal.ofReal (2 * margin L m) := by + rw [measure_biUnion_finset (pairwiseDisjoint_hole hL hm I) fun k _ ↦ measurableSet_hole L m k] + simp only [volume_hole, Finset.sum_const, nsmul_eq_mul] + have hU : volume (⋃ k ∈ I, hole L m k) ≠ ⊤ := by + rw [hvolU]; exact ENNReal.mul_ne_top (ENNReal.natCast_ne_top _) ENNReal.ofReal_ne_top + have hunion : volume (S ∩ avoid L m) + volume (⋃ k ∈ I, hole L m k) ≤ volume S := by + rw [← measure_union hdisj hmeas] + exact measure_mono (union_subset inter_subset_left (iUnion₂_subset hIS)) + -- in real numbers: the removed holes account for `card I * 2 * margin` + have hreal : (volume (S ∩ avoid L m)).toReal + I.card * (2 * margin L m) ≤ + (volume S).toReal := by + have := ENNReal.toReal_mono hfin hunion + rwa [ENNReal.toReal_add hfin' hU, hvolU, ENNReal.toReal_mul, ENNReal.toReal_natCast, + ENNReal.toReal_ofReal (by positivity)] at this + -- counting the holes + have hcard : B - A - 1 ≤ I.card := by + have h1 : ((⌊B⌋ + 1 - ⌈A⌉ : ℤ) : ℝ) ≤ I.card := by + rw [hI, Int.card_Icc]; exact_mod_cast Int.self_le_toNat _ + push_cast at h1 + linarith [Int.lt_floor_add_one B, Int.ceil_lt_add_one A] + have hBA : B - A = (sSup S - sInf S) / cellLength m - 2 * margin L m / cellLength m := by + rw [hA, hB]; ring + rw [hratio] at hBA + have hkey : (sSup S - sInf S) * (1 / ((m : ℝ) * (L + 1))) - 4 * margin L m ≤ + I.card * (2 * margin L m) := by + have h3 : ((sSup S - sInf S) / cellLength m - 2) * (2 * margin L m) ≤ + I.card * (2 * margin L m) := + mul_le_mul_of_nonneg_right (by linarith) (by positivity) + have h4 : (sSup S - sInf S) / cellLength m * (2 * margin L m) = + (sSup S - sInf S) * (1 / ((m : ℝ) * (L + 1))) := by + rw [← hratio]; ring + linarith + have hℓc : (volume S).toReal * (1 / ((m : ℝ) * (L + 1))) ≤ + (sSup S - sInf S) * (1 / ((m : ℝ) * (L + 1))) := mul_le_mul_of_nonneg_right hℓ hcpos + linarith + +/-! ### Summing over the cells of the previous level -/ + +/-- `[0, 1]` is covered by the level-`M` cells with indices `0, …, cellIndex M 1`. -/ +theorem Icc_subset_biUnion_cell (M : ℕ) : + Icc (0 : ℝ) 1 ⊆ ⋃ i ∈ Finset.Icc (0 : ℤ) (cellIndex M 1), cell M i := by + intro x hx + have hpos := cellLength_pos M + refine mem_iUnion₂.mpr ⟨cellIndex M x, ?_, mem_cell_cellIndex M x⟩ + rw [Finset.mem_Icc] + unfold cellIndex + exact ⟨Int.floor_nonneg.mpr (div_nonneg hx.1 hpos.le), + Int.floor_mono (div_le_div_of_nonneg_right hx.2 hpos.le)⟩ + +/-- There are at most `1 / cellLength M + 1` level-`M` cells meeting `[0, 1]`. -/ +theorem card_Icc_cellIndex_le (M : ℕ) : + ((Finset.Icc (0 : ℤ) (cellIndex M 1)).card : ℝ) ≤ 1 / cellLength M + 1 := by + have hpos := cellLength_pos M + have h0 : 0 ≤ cellIndex M 1 := Int.floor_nonneg.mpr (by positivity) + have hcard : ((Finset.Icc (0 : ℤ) (cellIndex M 1)).card : ℤ) = cellIndex M 1 + 1 := by + rw [Int.card_Icc, sub_zero, Int.toNat_of_nonneg (by omega)] + have hle : (cellIndex M 1 : ℝ) ≤ 1 / cellLength M := Int.floor_le _ + have hcardR : ((Finset.Icc (0 : ℤ) (cellIndex M 1)).card : ℝ) = cellIndex M 1 + 1 := by + exact_mod_cast hcard + linarith + +/-- Consecutive cell lengths: `cellLength (M + 1) = cellLength M * (1/2) ^ (2 M + 1)`. -/ +theorem cellLength_succ_eq (M : ℕ) : + cellLength (M + 1) = cellLength M * (1 / 2) ^ (2 * M + 1) := by + unfold cellLength; rw [← pow_add]; congr 1; ring + +/-- The total error from the `1 / cellLength M + 1` cells of level `M` is geometrically small. -/ +theorem error_le {L : ℝ} (hL : 0 ≤ L) (M : ℕ) : + (1 / cellLength M + 1) * margin L (M + 1) ≤ (1 / 2) ^ (M + 1) := by + have hpos := cellLength_pos M + have hle1 := cellLength_le_one M + have hμ := margin_le_half hL (Nat.le_add_left 1 M) + rw [cellLength_succ_eq] at hμ + have h1 : (1 / cellLength M + 1) * margin L (M + 1) ≤ + (1 / cellLength M + 1) * (cellLength M * (1 / 2) ^ (2 * M + 1) / 2) := + mul_le_mul_of_nonneg_left hμ (by positivity) + have h2 : (1 / cellLength M + 1) * (cellLength M * (1 / 2) ^ (2 * M + 1) / 2) = + (1 + cellLength M) / 2 * (1 / 2) ^ (2 * M + 1) := by + field_simp + have h3 : (1 + cellLength M) / 2 ≤ 1 := by linarith + have h4 : ((1 : ℝ) / 2) ^ (2 * M + 1) ≤ (1 / 2) ^ (M + 1) := + pow_le_pow_of_le_one (by norm_num) (by norm_num) (by omega) + have h5 : (0 : ℝ) ≤ (1 / 2) ^ (2 * M + 1) := by positivity + calc (1 / cellLength M + 1) * margin L (M + 1) + ≤ (1 / cellLength M + 1) * (cellLength M * (1 / 2) ^ (2 * M + 1) / 2) := h1 + _ = (1 + cellLength M) / 2 * (1 / 2) ^ (2 * M + 1) := h2 + _ ≤ 1 * (1 / 2) ^ (2 * M + 1) := mul_le_mul_of_nonneg_right h3 h5 + _ ≤ (1 / 2) ^ (M + 1) := by rw [one_mul]; exact h4 + +/-- **One level of the recursion.** If `S ⊆ [0, 1]` meets every level-`M` cell in an +order-connected set, then avoiding the level-`M + 1` grid removes the fraction +`1 / ((M + 1) (L + 1))` of its measure, up to an error `4 * (1/2) ^ (M + 1)`. -/ +theorem volume_inter_avoid_succ_le {L : ℝ} (hL : 0 ≤ L) (M : ℕ) {S : Set ℝ} + (hS1 : S ⊆ Icc 0 1) (hS : ∀ i : ℤ, (S ∩ cell M i).OrdConnected) : + (volume (S ∩ avoid L (M + 1))).toReal ≤ + (1 - 1 / (((M : ℝ) + 1) * (L + 1))) * (volume S).toReal + 4 * (1 / 2) ^ (M + 1) := by + obtain ⟨I, hI⟩ : ∃ I : Finset ℤ, I = Finset.Icc (0 : ℤ) (cellIndex M 1) := ⟨_, rfl⟩ + have hm : 1 ≤ M + 1 := Nat.le_add_left 1 M + have hμpos := margin_pos hL hm + have hc0 : 0 ≤ 1 - 1 / (((M : ℝ) + 1) * (L + 1)) := by + have : 1 / (((M : ℝ) + 1) * (L + 1)) ≤ 1 := by + rw [div_le_one (by positivity)]; nlinarith [Nat.cast_nonneg (α := ℝ) M] + linarith + have hfin : ∀ i ∈ I, volume (S ∩ cell M i ∩ avoid L (M + 1)) ≠ ⊤ := fun i _ ↦ + volume_ne_top_of_subset_Icc ((inter_subset_left.trans inter_subset_left).trans hS1) + have hfin2 : ∀ i ∈ I, volume (S ∩ cell M i) ≠ ⊤ := fun i _ ↦ + volume_ne_top_of_subset_Icc (inter_subset_left.trans hS1) + -- the measure is at most the sum over the cells + have hcover : S ∩ avoid L (M + 1) ⊆ ⋃ i ∈ I, (S ∩ cell M i ∩ avoid L (M + 1)) := by + rintro x ⟨hxS, hxa⟩ + obtain ⟨i, hi, hxi⟩ := mem_iUnion₂.mp (Icc_subset_biUnion_cell M (hS1 hxS)) + exact mem_iUnion₂.mpr ⟨i, hI ▸ hi, ⟨hxS, hxi⟩, hxa⟩ + have h1 : (volume (S ∩ avoid L (M + 1))).toReal ≤ + ∑ i ∈ I, (volume (S ∩ cell M i ∩ avoid L (M + 1))).toReal := by + rw [← ENNReal.toReal_sum hfin] + exact ENNReal.toReal_mono (ENNReal.sum_ne_top.mpr hfin) + ((measure_mono hcover).trans (measure_biUnion_finset_le I _)) + -- each cell loses the fraction `1 / ((M + 1) (L + 1))` + have h2 : ∀ i ∈ I, (volume (S ∩ cell M i ∩ avoid L (M + 1))).toReal ≤ + (1 - 1 / (((M : ℝ) + 1) * (L + 1))) * (volume (S ∩ cell M i)).toReal + + 4 * margin L (M + 1) := fun i _ ↦ by + have := volume_inter_avoid_le hL hm (hS i) (inter_subset_left.trans hS1) + push_cast at this + exact this + -- the cells' measures add up to at most the measure of `S` + have h3 : ∑ i ∈ I, (volume (S ∩ cell M i)).toReal ≤ (volume S).toReal := by + rw [← ENNReal.toReal_sum hfin2] + refine ENNReal.toReal_mono (volume_ne_top_of_subset_Icc hS1) ?_ + have hr : ∀ i ∈ I, volume (S ∩ cell M i) = (volume.restrict S) (cell M i) := + fun i _ ↦ by rw [Measure.restrict_apply (t := cell M i) measurableSet_Ico, inter_comm] + have hU : (volume.restrict S) (⋃ i ∈ I, cell M i) = + ∑ i ∈ I, (volume.restrict S) (cell M i) := + measure_biUnion_finset (fun i _ j _ hij ↦ cell_disjoint hij) fun i _ ↦ measurableSet_Ico + rw [Finset.sum_congr rfl hr, ← hU] + exact (measure_mono (subset_univ _)).trans (Measure.restrict_apply_univ S).le + -- the number of cells times the error per cell + have h4 : (I.card : ℝ) * (4 * margin L (M + 1)) ≤ 4 * (1 / 2) ^ (M + 1) := by + have hc := card_Icc_cellIndex_le M + rw [← hI] at hc + have he := error_le hL M + have h6 : (I.card : ℝ) * margin L (M + 1) ≤ (1 / cellLength M + 1) * margin L (M + 1) := + mul_le_mul_of_nonneg_right hc hμpos.le + linarith + calc (volume (S ∩ avoid L (M + 1))).toReal + ≤ ∑ i ∈ I, (volume (S ∩ cell M i ∩ avoid L (M + 1))).toReal := h1 + _ ≤ ∑ i ∈ I, ((1 - 1 / (((M : ℝ) + 1) * (L + 1))) * (volume (S ∩ cell M i)).toReal + + 4 * margin L (M + 1)) := Finset.sum_le_sum h2 + _ = (1 - 1 / (((M : ℝ) + 1) * (L + 1))) * ∑ i ∈ I, (volume (S ∩ cell M i)).toReal + + I.card * (4 * margin L (M + 1)) := by + rw [Finset.sum_add_distrib, Finset.mul_sum, Finset.sum_const, nsmul_eq_mul] + _ ≤ (1 - 1 / (((M : ℝ) + 1) * (L + 1))) * (volume S).toReal + 4 * (1 / 2) ^ (M + 1) := + add_le_add (mul_le_mul_of_nonneg_left h3 hc0) h4 + +/-! ### The survivors of the first `n` levels -/ + +/-- The points of `[0, 1]` avoiding the grids of levels `N + 1, …, N + n`. -/ +def survivors (L : ℝ) (N : ℕ) : ℕ → Set ℝ + | 0 => Icc 0 1 + | n + 1 => survivors L N n ∩ avoid L (N + n + 1) + +/-- The survivors lie in `[0, 1]`. -/ +theorem survivors_subset_Icc (L : ℝ) (N : ℕ) (n : ℕ) : survivors L N n ⊆ Icc 0 1 := by + induction n with + | zero => exact subset_rfl + | succ n ih => exact inter_subset_left.trans ih + +/-- The survivors have finite measure. -/ +theorem volume_survivors_ne_top (L : ℝ) (N n : ℕ) : volume (survivors L N n) ≠ ⊤ := + volume_ne_top_of_subset_Icc (survivors_subset_Icc L N n) + +/-- Inside a cell of level `M ≥ N + n` the survivors of `n` levels form an order-connected set. -/ +theorem ordConnected_survivors_inter_cell (L : ℝ) (N : ℕ) (n : ℕ) : + ∀ M : ℕ, N + n ≤ M → ∀ i : ℤ, (survivors L N n ∩ cell M i).OrdConnected := by + induction n with + | zero => intro M _ i; exact ordConnected_Icc.inter ordConnected_Ico + | succ n ih => + intro M hM i + change (survivors L N n ∩ avoid L (N + n + 1) ∩ cell M i).OrdConnected + rw [inter_inter_distrib_right] + exact (ih M (by omega) i).inter + (ordConnected_avoid_inter_cell L (n := N + n + 1) (m := M) (by omega) i) + +/-- The recursive estimate for the measure of the survivors. -/ +theorem volume_survivors_succ_le {L : ℝ} (hL : 0 ≤ L) (N n : ℕ) : + (volume (survivors L N (n + 1))).toReal ≤ + (1 - 1 / (((N : ℝ) + n + 1) * (L + 1))) * (volume (survivors L N n)).toReal + + 4 * (1 / 2) ^ (n + 1) := by + have h := volume_inter_avoid_succ_le hL (N + n) (survivors_subset_Icc L N n) + (ordConnected_survivors_inter_cell L N n (N + n) le_rfl) + push_cast at h + have h5 : ((1 : ℝ) / 2) ^ (N + n + 1) ≤ (1 / 2) ^ (n + 1) := + pow_le_pow_of_le_one (by norm_num) (by norm_num) (by omega) + change (volume (survivors L N n ∩ avoid L (N + n + 1))).toReal ≤ _ + linarith + +/-- The sums `∑_{k < n} 1 / ((N + k) (L + 1))` diverge, by comparison with the harmonic series. -/ +theorem tendsto_sum_one_div_atTop {L : ℝ} (hL : 0 ≤ L) {N : ℕ} (hN : 1 ≤ N) : + Tendsto (fun n ↦ ∑ k ∈ Finset.range n, 1 / (((N : ℝ) + k) * (L + 1))) atTop atTop := by + have hN' : (1 : ℝ) ≤ N := by exact_mod_cast hN + have hc : (0 : ℝ) < 1 / (((N : ℝ) + 1) * (L + 1)) := by positivity + have hterm : ∀ k : ℕ, 1 / (((N : ℝ) + 1) * (L + 1)) * (1 / ((k : ℝ) + 1)) ≤ + 1 / (((N : ℝ) + k) * (L + 1)) := by + intro k + have hk : (0 : ℝ) ≤ k := Nat.cast_nonneg k + rw [one_div_mul_one_div] + refine one_div_le_one_div_of_le (by positivity) ?_ + nlinarith [mul_nonneg (mul_nonneg (Nat.cast_nonneg (α := ℝ) N) hk) hL] + refine tendsto_atTop_mono (fun n ↦ ?_) + (Tendsto.const_mul_atTop hc Real.tendsto_sum_range_one_div_nat_succ_atTop) + rw [Finset.mul_sum] + exact Finset.sum_le_sum fun k _ ↦ hterm k + +/-- The measure of the survivors tends to zero. -/ +theorem tendsto_volume_survivors {L : ℝ} (hL : 0 ≤ L) {N : ℕ} (hN : 1 ≤ N) : + Tendsto (fun n ↦ (volume (survivors L N n)).toReal) atTop (𝓝 0) := by + have hN' : (1 : ℝ) ≤ N := by exact_mod_cast hN + refine tendsto_zero_of_recursive (a := fun k : ℕ ↦ 1 / (((N : ℝ) + k) * (L + 1))) + (e := fun k : ℕ ↦ 4 * (1 / 2) ^ k) (fun n ↦ ENNReal.toReal_nonneg) + (fun k ↦ show (0 : ℝ) ≤ 1 / (((N : ℝ) + k) * (L + 1)) by positivity) (fun k ↦ ?_) + (fun k ↦ show (0 : ℝ) ≤ 4 * (1 / 2) ^ k by positivity) (tendsto_sum_one_div_atTop hL hN) + (summable_geometric_two.mul_left 4) (fun n ↦ ?_) + · show 1 / (((N : ℝ) + k) * (L + 1)) ≤ 1 + have hk : (0 : ℝ) ≤ k := Nat.cast_nonneg k + rw [div_le_one (by positivity)] + nlinarith + · show (volume (survivors L N (n + 1))).toReal ≤ + (1 - 1 / (((N : ℝ) + ((n + 1 : ℕ) : ℝ)) * (L + 1))) * + (volume (survivors L N n)).toReal + 4 * (1 / 2) ^ (n + 1) + push_cast + rw [← add_assoc] + exact volume_survivors_succ_le hL N n + +/-! ### The main theorems -/ + +/-- **The two-sided avoiders are null.** The points of `[0, 1]` at distance at least +`margin L n` from every level-`n` grid point, for all `n ≥ N`, form a null set. -/ +theorem volume_Icc_inter_iInter_avoid_eq_zero (L : ℝ) (hL : 0 ≤ L) (N : ℕ) : + volume (Icc (0:ℝ) 1 ∩ ⋂ n : ℕ, avoid L (N + n)) = 0 := by + have hsub : ∀ n, Icc (0:ℝ) 1 ∩ ⋂ n : ℕ, avoid L (N + n) ⊆ survivors L (N + 1) n := by + intro n + induction n with + | zero => exact inter_subset_left + | succ n ih => + change _ ⊆ survivors L (N + 1) n ∩ avoid L (N + 1 + n + 1) + refine subset_inter ih fun x hx ↦ ?_ + have h := mem_iInter.mp hx.2 (n + 2) + rwa [show N + 1 + n + 1 = N + (n + 2) by omega] + have hfin : volume (Icc (0:ℝ) 1 ∩ ⋂ n : ℕ, avoid L (N + n)) ≠ ⊤ := + volume_ne_top_of_subset_Icc inter_subset_left + have hle : ∀ n, (volume (Icc (0:ℝ) 1 ∩ ⋂ n : ℕ, avoid L (N + n))).toReal ≤ + (volume (survivors L (N + 1) n)).toReal := fun n ↦ + ENNReal.toReal_mono (volume_survivors_ne_top _ _ _) (measure_mono (hsub n)) + have h0 := ge_of_tendsto' (tendsto_volume_survivors hL (N := N + 1) (by omega)) hle + have h0' : (volume (Icc (0:ℝ) 1 ∩ ⋂ n : ℕ, avoid L (N + n))).toReal = 0 := + le_antisymm h0 ENNReal.toReal_nonneg + rcases (ENNReal.toReal_eq_zero_iff _).mp h0' with h | h + · exact h + · exact absurd h hfin + +/-- **Lipschitz pieces are null.** A subset of `[0, 1]` on which Besicovitch's function is +Lipschitz has Lebesgue measure zero. -/ +theorem volume_eq_zero_of_lipschitzOnWith {L : ℝ≥0} {A : Set ℝ} (hA : A ⊆ Icc 0 1) + (hg : LipschitzOnWith L besicovitchFun A) : volume A = 0 := by + have hae := ae_eventually_mem_avoid hg + rw [ae_iff] at hae + -- the points of `A` that do not eventually avoid the grids are null + have h1 : volume ({x | ¬ ∀ᶠ n in atTop, x ∈ avoid (L : ℝ) n} ∩ A) = 0 := + nonpos_iff_eq_zero.mp ((Measure.le_restrict_apply A _).trans hae.le) + -- the points of `A` that eventually avoid the grids are null by the main theorem + have h2 : volume ({x | ∀ᶠ n in atTop, x ∈ avoid (L : ℝ) n} ∩ A) = 0 := by + refine measure_mono_null ?_ + (measure_iUnion_null fun N ↦ volume_Icc_inter_iInter_avoid_eq_zero L L.coe_nonneg N) + rintro x ⟨hx, hxA⟩ + obtain ⟨N, hN⟩ := eventually_atTop.mp hx + exact mem_iUnion.mpr ⟨N, hA hxA, mem_iInter.mpr fun n ↦ hN (N + n) (Nat.le_add_right N n)⟩ + have hA' : A = {x | ¬ ∀ᶠ n in atTop, x ∈ avoid (L : ℝ) n} ∩ A ∪ + {x | ∀ᶠ n in atTop, x ∈ avoid (L : ℝ) n} ∩ A := by + ext x; simp only [mem_union, mem_inter_iff, mem_ofPred_eq]; tauto + rw [hA'] + exact measure_union_null h1 h2 + +end LeanPool.Besicovitch.Example diff --git a/LeanPool/Besicovitch/Geometry/BallUnion.lean b/LeanPool/Besicovitch/Geometry/BallUnion.lean new file mode 100644 index 0000000000..cd72fee389 --- /dev/null +++ b/LeanPool/Besicovitch/Geometry/BallUnion.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Data.Finset.Lattice.Fold +public import Mathlib.MeasureTheory.Constructions.BorelSpace.Metric + +/-! +# Finite unions of metric balls + +This file collects the finite-ball estimates used in the packing-to-measure transfer. +-/ + +@[expose] public section + +noncomputable section + +open Set + +namespace LeanPool.Besicovitch + +variable {X ι : Type*} [PseudoMetricSpace X] + +/-- The union of open balls indexed by a finite support. -/ +def finiteBallUnion (support : Finset ι) (center : support → X) (radius : support → ℝ) : + Set X := + ⋃ i : support, Metric.ball (center i) (radius i) + +/-- Membership in a finite ball union is witnessed by one supported ball. -/ +@[simp] +theorem mem_finiteBallUnion {support : Finset ι} {center : support → X} + {radius : support → ℝ} {x : X} : + x ∈ finiteBallUnion support center radius ↔ + ∃ i : support, x ∈ Metric.ball (center i) (radius i) := by + simp [finiteBallUnion] + +/-- Every supported ball lies in the corresponding finite ball union. -/ +theorem ball_subset_finiteBallUnion {support : Finset ι} (center : support → X) + (radius : support → ℝ) (i : support) : + Metric.ball (center i) (radius i) ⊆ finiteBallUnion support center radius := + subset_iUnion (fun j : support ↦ Metric.ball (center j) (radius j)) i + +/-- A finite ball union is open. -/ +theorem isOpen_finiteBallUnion {support : Finset ι} (center : support → X) + (radius : support → ℝ) : IsOpen (finiteBallUnion support center radius) := + isOpen_iUnion fun _ ↦ Metric.isOpen_ball + +/-- A finite ball union is nonempty exactly when one supported radius is positive. -/ +@[simp] +theorem finiteBallUnion_nonempty {support : Finset ι} {center : support → X} + {radius : support → ℝ} : + (finiteBallUnion support center radius).Nonempty ↔ ∃ i : support, 0 < radius i := by + simp [finiteBallUnion] + +/-- Open balls satisfying the pairwise separation inequalities are pairwise disjoint. -/ +theorem pairwise_disjoint_ball_of_add_le_dist {support : Finset ι} + (center : support → X) (radius : support → ℝ) + (hsep : ∀ i j, i ≠ j → radius i + radius j ≤ dist (center i) (center j)) : + Pairwise fun i j ↦ + Disjoint (Metric.ball (center i) (radius i)) (Metric.ball (center j) (radius j)) := + fun i j hij ↦ Metric.ball_disjoint_ball (hsep i j hij) + +/-- The extended diameter of a finite ball union is bounded by its center-radius maximum. -/ +theorem ediam_finiteBallUnion_le {support : Finset ι} (hsupport : support.Nonempty) + (center : support → X) (radius : support → ℝ) : + Metric.ediam (finiteBallUnion support center radius) ≤ + ENNReal.ofReal (support.attach.sup' hsupport.attach fun i ↦ + support.attach.sup' hsupport.attach fun j ↦ + dist (center i) (center j) + radius i + radius j) := by + apply Metric.ediam_le_of_forall_dist_le + intro x hx y hy + obtain ⟨i, hi⟩ := mem_finiteBallUnion.mp hx + obtain ⟨j, hj⟩ := mem_finiteBallUnion.mp hy + calc + dist x y ≤ dist x (center i) + dist (center i) (center j) + dist (center j) y := + dist_triangle4 _ _ _ _ + _ ≤ radius i + dist (center i) (center j) + radius j := by + exact add_le_add (add_le_add hi.le le_rfl) (Metric.mem_ball'.mp hj).le + _ = dist (center i) (center j) + radius i + radius j := by ring + _ ≤ support.attach.sup' hsupport.attach (fun i ↦ + support.attach.sup' hsupport.attach fun j ↦ + dist (center i) (center j) + radius i + radius j) := by + calc + _ ≤ support.attach.sup' hsupport.attach (fun j ↦ + dist (center i) (center j) + radius i + radius j) := + Finset.le_sup' _ (Finset.mem_attach _ j) + _ ≤ _ := Finset.le_sup' + (fun i ↦ support.attach.sup' hsupport.attach fun j ↦ + dist (center i) (center j) + radius i + radius j) + (Finset.mem_attach _ i) + +/-- A finite ball union is measurable in the Borel measurable structure. -/ +theorem measurableSet_finiteBallUnion {support : Finset ι} [MeasurableSpace X] + [OpensMeasurableSpace X] (center : support → X) (radius : support → ℝ) : + MeasurableSet (finiteBallUnion support center radius) := + (isOpen_finiteBallUnion center radius).measurableSet + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Geometry/ConvexEnlargement.lean b/LeanPool/Besicovitch/Geometry/ConvexEnlargement.lean new file mode 100644 index 0000000000..3dd156cf46 --- /dev/null +++ b/LeanPool/Besicovitch/Geometry/ConvexEnlargement.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement +public import Mathlib.Analysis.Normed.Module.Convex +public import Mathlib.Topology.MetricSpace.Thickening + +/-! +# Convex enlargements + +This file records the two elementary enlargements used in the continuum argument: thickening a +set by a multiple of its diameter, and replacing an open set by its open convex hull. +-/ + +@[expose] public section + +noncomputable section + +open Bornology Set + +namespace LeanPool.Besicovitch + +/-- The `p`-diameter thickening of a set. -/ +def diameterThickening (p : ℝ) (s : Set (EuclideanSpace ℝ (Fin 2))) : + Set (EuclideanSpace ℝ (Fin 2)) := + Metric.thickening (p * Metric.diam s) s + +/-- Diameter thickenings are open. -/ +theorem isOpen_diameterThickening (p : ℝ) (s : Set (EuclideanSpace ℝ (Fin 2))) : + IsOpen (diameterThickening p s) := + Metric.isOpen_thickening + +/-- A nonnegative `p`-diameter thickening has diameter at most `(2p + 1)` times the original. -/ +theorem diam_diameterThickening_le {p : ℝ} (hp : 0 ≤ p) (s : Set (EuclideanSpace ℝ (Fin 2))) : + Metric.diam (diameterThickening p s) ≤ (2 * p + 1) * Metric.diam s := by + rw [diameterThickening] + calc + Metric.diam (Metric.thickening (p * Metric.diam s) s) ≤ + Metric.diam s + 2 * (p * Metric.diam s) := + Metric.diam_thickening_le s (mul_nonneg hp Metric.diam_nonneg) + _ = (2 * p + 1) * Metric.diam s := by ring + +/-- The extended diameter of a nonnegative diameter thickening obeys the same linear bound. -/ +theorem ediam_diameterThickening_le {p : ℝ} (hp : 0 ≤ p) {s : Set (EuclideanSpace ℝ (Fin 2))} + (hs : IsBounded s) : + Metric.ediam (diameterThickening p s) ≤ + ENNReal.ofReal (2 * p + 1) * Metric.ediam s := by + have hthickening : IsBounded (diameterThickening p s) := hs.thickening + rw [← ENNReal.ofReal_toReal hthickening.ediam_ne_top, + ← ENNReal.ofReal_toReal hs.ediam_ne_top] + rw [← ENNReal.ofReal_mul (by positivity : 0 ≤ 2 * p + 1)] + exact ENNReal.ofReal_le_ofReal (diam_diameterThickening_le hp s) + +/-- A set is contained in every positive-radius diameter thickening. -/ +theorem subset_diameterThickening {p : ℝ} {s : Set (EuclideanSpace ℝ (Fin 2))} + (hpositive : 0 < p * Metric.diam s) : s ⊆ diameterThickening p s := by + exact Metric.self_subset_thickening hpositive s + +/-- A bounded set meeting `s` lies in the `p`-diameter thickening of `s` when its diameter is +smaller than the thickening radius. -/ +theorem subset_diameterThickening_of_inter_nonempty + {u s : Set (EuclideanSpace ℝ (Fin 2))} {p : ℝ} + (hu : IsBounded u) (hus : (u ∩ s).Nonempty) + (hdiam : Metric.diam u < p * Metric.diam s) : u ⊆ diameterThickening p s := by + obtain ⟨y, hyu, hys⟩ := hus + intro x hxu + rw [diameterThickening, Metric.mem_thickening_iff] + exact ⟨y, hys, (Metric.dist_le_diam_of_mem hu hxu hyu).trans_lt hdiam⟩ + +/-- The interior of the convex hull of a set. -/ +def openConvexHull (s : Set (EuclideanSpace ℝ (Fin 2))) : Set (EuclideanSpace ℝ (Fin 2)) := + interior (convexHull ℝ s) + +/-- The open convex hull is open. -/ +theorem isOpen_openConvexHull (s : Set (EuclideanSpace ℝ (Fin 2))) : IsOpen (openConvexHull s) := + isOpen_interior + +/-- The open convex hull is convex. -/ +theorem convex_openConvexHull (s : Set (EuclideanSpace ℝ (Fin 2))) : + Convex ℝ (openConvexHull s) := + (convex_convexHull ℝ s).interior + +/-- An open set is contained in its open convex hull. -/ +theorem subset_openConvexHull {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsOpen s) : + s ⊆ openConvexHull s := by + exact hs.subset_interior_iff.mpr (subset_convexHull ℝ s) + +/-- Passing from an open set to its open convex hull does not change its extended diameter. -/ +theorem ediam_openConvexHull {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsOpen s) : + Metric.ediam (openConvexHull s) = Metric.ediam s := by + apply le_antisymm + · exact (Metric.ediam_mono interior_subset).trans_eq (convexHull_ediam s) + · exact Metric.ediam_mono (subset_openConvexHull hs) + +/-- Passing from an open set to its open convex hull does not change its diameter. -/ +theorem diam_openConvexHull {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsOpen s) : + Metric.diam (openConvexHull s) = Metric.diam s := by + have hsubset : s ⊆ openConvexHull s := subset_openConvexHull hs + by_cases hbounded : IsBounded s + · have hconvexHull_bounded : IsBounded (convexHull ℝ s) := by simpa using hbounded + have hopen_bounded : IsBounded (openConvexHull s) := + hconvexHull_bounded.subset interior_subset + apply le_antisymm + · calc + Metric.diam (openConvexHull s) ≤ Metric.diam (convexHull ℝ s) := + Metric.diam_mono interior_subset hconvexHull_bounded + _ = Metric.diam s := convexHull_diam s + · exact Metric.diam_mono hsubset hopen_bounded + · have hopen_unbounded : ¬IsBounded (openConvexHull s) := fun h ↦ hbounded (h.subset hsubset) + rw [Metric.diam_eq_zero_of_unbounded hbounded, + Metric.diam_eq_zero_of_unbounded hopen_unbounded] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Main/Bound.lean b/LeanPool/Besicovitch/Main/Bound.lean new file mode 100644 index 0000000000..9166abae99 --- /dev/null +++ b/LeanPool/Besicovitch/Main/Bound.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.BesicovitchPairCondition.Rectifiability +public import LeanPool.Besicovitch.BesicovitchPairCondition.SixPointTransfer +public import LeanPool.Besicovitch.Certificates.EndpointBridge + +/-! +# The six-point bound for the planar density threshold + +This file contains the analytic bridge from the finite six-point property to the upper bound on +the planar rectifiability threshold. The finite property itself remains the sole geometric input. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- A positive subunit parameter satisfying the Besicovitch pair condition bounds the planar +rectifiability threshold. -/ +theorem BesicovitchPairCondition.sigmaOne_plane_le {s : ℝ} + (hpair : BesicovitchPairCondition s) (hs : 0 < s) (hs_one : s < 1) : + sigmaOne (EuclideanSpace ℝ (Fin 2)) ≤ s := by + apply sigmaOne_le_of_forall_gt (EuclideanSpace ℝ (Fin 2)) hs.le + intro gamma hs_gamma + exact hpair.forcesOneRectifiability hs hs_one hs_gamma + +/-- The finite six-point property at a positive subunit parameter forces one-rectifiability +at every larger threshold. -/ +theorem SixPointFiniteProperty.forcesOneRectifiability_of_gt {s : ℝ} + (hfinite : SixPointFiniteProperty s) (hs : 0 < s) (hs_one : s < 1) {gamma : ℝ} + (hs_gamma : s < gamma) : + ForcesOneRectifiability (EuclideanSpace ℝ (Fin 2)) (ENNReal.ofReal gamma) := by + let beta := (s + min gamma 1) / 2 + have hs_min : s < min gamma 1 := lt_min_iff.mpr ⟨hs_gamma, hs_one⟩ + have hs_beta : s < beta := by + dsimp only [beta] + linarith + have hbeta_min : beta < min gamma 1 := by + dsimp only [beta] + linarith + have hbeta_gamma : beta < gamma := hbeta_min.trans_le (min_le_left _ _) + have hbeta_one : beta < 1 := hbeta_min.trans_le (min_le_right _ _) + have hpair : BesicovitchPairCondition beta := + hfinite.besicovitchPairCondition hs hs_beta + exact hpair.forcesOneRectifiability (hs.trans hs_beta) hbeta_one hbeta_gamma + +/-- The finite six-point property at a positive subunit parameter bounds the planar +rectifiability threshold by that parameter. -/ +theorem SixPointFiniteProperty.sigmaOne_plane_le {s : ℝ} + (hfinite : SixPointFiniteProperty s) (hs : 0 < s) (hs_one : s < 1) : + sigmaOne (EuclideanSpace ℝ (Fin 2)) ≤ s := + sigmaOne_le_of_forall_gt (EuclideanSpace ℝ (Fin 2)) hs.le + fun _ hs_gamma ↦ hfinite.forcesOneRectifiability_of_gt hs hs_one hs_gamma + +/-- The desired planar bound follows from the finite six-point property at the certified +endpoint. -/ +theorem sigmaOne_plane_le_barS_of_sixPointFiniteProperty + (hfinite : SixPointFiniteProperty barS) : + sigmaOne (EuclideanSpace ℝ (Fin 2)) ≤ barS := + hfinite.sigmaOne_plane_le barS_pos barS_lt_one + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Main/RationalBound.lean b/LeanPool/Besicovitch/Main/RationalBound.lean new file mode 100644 index 0000000000..48ba4635f8 --- /dev/null +++ b/LeanPool/Besicovitch/Main/RationalBound.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Main.Bound +public import LeanPool.Besicovitch.SixPoint.GramWeightedBound + +/-! +# The rational planar bound + +The Gram certificates give the weighted geometric bound at the small rational weights, the finite +failure tree turns that into the six-point finite property at `barS = 6934/10000`, and the +six-point transfer turns that into the planar rectifiability bound. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Every threshold above `barS` forces one-rectifiability in the plane. -/ +theorem forcesOneRectifiability_plane_of_barS_lt {β : ℝ} (hβ : barS < β) : + ForcesOneRectifiability (EuclideanSpace ℝ (Fin 2)) (ENNReal.ofReal β) := + (sixPointFiniteProperty_barS_of_weightedGeometricBound gramLambda_pos gramMu_pos + weightedGeometricBound_gram).forcesOneRectifiability_of_gt barS_pos barS_lt_one hβ + +/-- The planar one-dimensional rectifiability threshold is at most `6934/10000`. -/ +theorem sigmaOne_plane_le_barS : + sigmaOne (EuclideanSpace ℝ (Fin 2)) ≤ 6934 / 10000 := by + have hfinite : SixPointFiniteProperty barS := + sixPointFiniteProperty_barS_of_weightedGeometricBound gramLambda_pos gramMu_pos + weightedGeometricBound_gram + have hbound := hfinite.sigmaOne_plane_le barS_pos barS_lt_one + rwa [barS_eq] at hbound + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Measure/CompactExhaustion.lean b/LeanPool/Besicovitch/Measure/CompactExhaustion.lean new file mode 100644 index 0000000000..6147c9dfae --- /dev/null +++ b/LeanPool/Besicovitch/Measure/CompactExhaustion.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.MeasureTheory.Measure.RegularityCompacts + +/-! +# Compact cores of measurable exhaustions + +An increasing measurable exhaustion which covers a finite-measure set almost everywhere contains +a compact core with arbitrarily small discarded mass. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal Topology + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MeasurableSpace X] + +/-- A monotone measurable cover has an arbitrarily small exceptional set at a finite stage. -/ +theorem exists_in_monotone_ae_cover_measure_sdiff_lt {mu : Measure X} + {A : Set X} (hA : MeasurableSet A) (hA_finite : mu A ≠ ∞) {G : ℕ → Set X} + (hG_measurable : ∀ n, MeasurableSet (G n)) (hG_mono : Monotone G) + (hcovered : ∀ᵐ x ∂mu.restrict A, x ∈ ⋃ n, G n) + {epsilon : ℝ≥0∞} (hepsilon : 0 < epsilon) : + ∃ n, mu (A \ G n) < epsilon := by + have hnull : mu (⋂ n, A \ G n) = 0 := by + have hnull_restrict : (mu.restrict A) (⋂ n, A \ G n) = 0 := by + rw [← ae_eq_empty] + refine eventuallyEqSet_iff.2 ?_ + filter_upwards [hcovered] with x hx + obtain ⟨n, hn⟩ := mem_iUnion.1 hx + constructor + · intro hx_inter + have hxn : x ∈ A \ G n := mem_iInter.1 hx_inter n + exact (hxn.2 hn).elim + · simp + rw [Measure.restrict_apply' hA] at hnull_restrict + have hinter_subset : (⋂ n, A \ G n) ⊆ A := by + intro x hx + have hx0 : x ∈ A \ G 0 := mem_iInter.1 hx 0 + exact hx0.1 + simpa only [inter_eq_self_of_subset_left hinter_subset] using hnull_restrict + have hanti : Antitone fun n ↦ A \ G n := by + intro m n hmn x hx + exact ⟨hx.1, fun hxG ↦ hx.2 (hG_mono hmn hxG)⟩ + have hmeasurable (n : ℕ) : NullMeasurableSet (A \ G n) mu := + (hA.diff (hG_measurable n)).nullMeasurableSet + have hfinite : ∃ n : ℕ, mu (A \ G n) ≠ ∞ := + ⟨0, ne_top_of_le_ne_top hA_finite (measure_mono sdiff_subset)⟩ + have hinf : (⨅ n, mu (A \ G n)) = 0 := by + rw [← hanti.measure_iInter hmeasurable hfinite, hnull] + by_contra h + push Not at h + have : epsilon ≤ (⨅ n, mu (A \ G n)) := le_iInf h + rw [hinf] at this + exact (not_le_of_gt hepsilon) this + +variable [TopologicalSpace X] [OpensMeasurableSpace X] [T2Space X] + +/-- An almost-everywhere increasing measurable exhaustion contains a compact core losing less than +any prescribed positive mass. -/ +theorem exists_compact_in_monotone_ae_cover_measure_sdiff_lt {mu : Measure X} + [Measure.InnerRegularCompactLTTop mu] {A : Set X} (hA : MeasurableSet A) + (hA_finite : mu A ≠ ∞) {G : ℕ → Set X} (hG_measurable : ∀ n, MeasurableSet (G n)) + (hG_subset : ∀ n, G n ⊆ A) (hG_mono : Monotone G) + (hcovered : ∀ᵐ x ∂mu.restrict A, x ∈ ⋃ n, G n) + {epsilon : ℝ≥0∞} (hepsilon : 0 < epsilon) : + ∃ (n : ℕ) (F : Set X), IsCompact F ∧ F ⊆ G n ∧ mu (A \ F) < epsilon := by + have hhalf : 0 < epsilon / 2 := ENNReal.div_pos hepsilon.ne' (by norm_num) + obtain ⟨m, hm⟩ := + exists_in_monotone_ae_cover_measure_sdiff_lt hA hA_finite hG_measurable hG_mono + hcovered hhalf + have hG_finite : mu (G m) ≠ ∞ := + ne_top_of_le_ne_top hA_finite (measure_mono (hG_subset m)) + obtain ⟨F, hFG, hF_compact, hGF⟩ := + (hG_measurable m).exists_isCompact_sdiff_lt hG_finite hhalf.ne' + refine ⟨m, F, hF_compact, hFG, ?_⟩ + have hsubset : A \ F ⊆ (A \ G m) ∪ (G m \ F) := by + intro x hx + by_cases hxG : x ∈ G m + · exact Or.inr ⟨hxG, hx.2⟩ + · exact Or.inl ⟨hx.1, hxG⟩ + calc + mu (A \ F) ≤ mu ((A \ G m) ∪ (G m \ F)) := measure_mono hsubset + _ ≤ mu (A \ G m) + mu (G m \ F) := measure_union_le _ _ + _ < epsilon / 2 + epsilon / 2 := ENNReal.add_lt_add hm hGF + _ = epsilon := ENNReal.add_halves epsilon + +/-- The compact core can be chosen so that the discarded mass is a prescribed positive fraction +of the retained mass. -/ +theorem exists_compact_in_monotone_ae_cover_measure_sdiff_lt_mul {mu : Measure X} + [Measure.InnerRegularCompactLTTop mu] {A : Set X} (hA : MeasurableSet A) + (hA_pos : 0 < mu A) (hA_finite : mu A ≠ ∞) {G : ℕ → Set X} + (hG_measurable : ∀ n, MeasurableSet (G n)) (hG_subset : ∀ n, G n ⊆ A) + (hG_mono : Monotone G) (hcovered : ∀ᵐ x ∂mu.restrict A, x ∈ ⋃ n, G n) + {coefficient : ℝ≥0∞} (hcoefficient_pos : 0 < coefficient) + (hcoefficient_finite : coefficient ≠ ∞) : + ∃ (n : ℕ) (F : Set X), IsCompact F ∧ F ⊆ G n ∧ + mu (A \ F) < coefficient * mu F := by + let halfMass := mu A / 2 + let tolerance := min halfMass (coefficient * halfMass) + have hhalf_pos : 0 < halfMass := ENNReal.div_pos hA_pos.ne' (by norm_num) + have htolerance_pos : 0 < tolerance := by + rw [lt_min_iff] + exact ⟨hhalf_pos, ENNReal.mul_pos hcoefficient_pos.ne' hhalf_pos.ne'⟩ + obtain ⟨n, F, hF_compact, hFG, herror⟩ := + exists_compact_in_monotone_ae_cover_measure_sdiff_lt hA hA_finite hG_measurable + hG_subset hG_mono hcovered htolerance_pos + refine ⟨n, F, hF_compact, hFG, ?_⟩ + have hFA : F ⊆ A := hFG.trans (hG_subset n) + have hF_measurable : MeasurableSet F := hF_compact.isClosed.measurableSet + have herror_half : mu (A \ F) < halfMass := herror.trans_le (min_le_left _ _) + have herror_scaled : mu (A \ F) < coefficient * halfMass := + herror.trans_le (min_le_right _ _) + have hdecomposition : mu (A \ F) + mu F = mu A := by + simpa only [inter_eq_right.mpr hFA] using + measure_sdiff_add_inter (μ := mu) A hF_measurable + have hhalf_lt : halfMass < mu F := by + by_contra h + have hF_le : mu F ≤ halfMass := le_of_not_gt h + have hF_finite : mu F ≠ ∞ := + ne_top_of_le_ne_top hA_finite (measure_mono hFA) + have hsum_lt : mu (A \ F) + mu F < halfMass + halfMass := + ENNReal.add_lt_add_of_lt_of_le hF_finite herror_half hF_le + have : mu A < mu A := by + calc + mu A = mu (A \ F) + mu F := hdecomposition.symm + _ < halfMass + halfMass := hsum_lt + _ = mu A := ENNReal.add_halves (mu A) + exact this.false + exact herror_scaled.trans <| + ENNReal.mul_lt_mul_right hcoefficient_pos.ne' hcoefficient_finite hhalf_lt + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Measure/DensityBasic.lean b/LeanPool/Besicovitch/Measure/DensityBasic.lean new file mode 100644 index 0000000000..6a81fcda8a --- /dev/null +++ b/LeanPool/Besicovitch/Measure/DensityBasic.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement +public import Mathlib.Topology.Instances.ENNReal.Lemmas + +/-! +# Elementary lower-density consequences + +Strictly exceeding a lower-density level gives the corresponding ball-mass estimate at every +sufficiently small positive radius. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- Hausdorff measure restricted to a set evaluates balls by intersection with that set. -/ +theorem restrict_hausdorffMeasure_ball (s : Set X) (x : X) (r : ℝ) : + (μH[1].restrict s) (Metric.ball x r) = μH[1] (s ∩ Metric.ball x r) := by + rw [Measure.restrict_apply measurableSet_ball, inter_comm] + +/-- A strict lower-density bound holds as a mass bound on every sufficiently small ball. -/ +theorem lowerOneDensity_eventually_ball_measure_gt {s : Set X} {x : X} {β : ℝ} + (hβ : 0 ≤ β) (h : ENNReal.ofReal β < lowerOneDensity s x) : + ∃ scale : ℝ, 0 < scale ∧ ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * β * r) < μH[1] (s ∩ Metric.ball x r) := by + have heventually : ∀ᶠ r in 𝓝[>] 0, + ENNReal.ofReal β < + μH[1] (s ∩ Metric.ball x r) / ENNReal.ofReal (2 * r) := by + exact eventually_lt_of_lt_liminf h + obtain ⟨neighborhood, hneighborhood, hsubset⟩ := + mem_nhdsWithin_iff_exists_mem_nhds_inter.mp heventually + obtain ⟨scale, hscale, hball⟩ := Metric.mem_nhds_iff.mp hneighborhood + refine ⟨scale, hscale, fun r hr hrscale ↦ ?_⟩ + have hr_mem : r ∈ neighborhood ∩ Ioi (0 : ℝ) := by + refine ⟨hball ?_, hr⟩ + simpa [Real.dist_eq, abs_of_pos hr] using hrscale + have hratio := hsubset hr_mem + change ENNReal.ofReal β < + μH[1] (s ∩ Metric.ball x r) / ENNReal.ofReal (2 * r) at hratio + have hden_pos : 0 < ENNReal.ofReal (2 * r) := ENNReal.ofReal_pos.2 (by positivity) + rw [ENNReal.lt_div_iff_mul_lt (Or.inl hden_pos.ne') (Or.inl ENNReal.ofReal_ne_top)] + at hratio + calc + ENNReal.ofReal (2 * β * r) = ENNReal.ofReal (β * (2 * r)) := by ring_nf + _ = ENNReal.ofReal β * ENNReal.ofReal (2 * r) := ENNReal.ofReal_mul hβ + _ < _ := hratio + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Measure/DensityLocalization.lean b/LeanPool/Besicovitch/Measure/DensityLocalization.lean new file mode 100644 index 0000000000..e546879853 --- /dev/null +++ b/LeanPool/Besicovitch/Measure/DensityLocalization.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.DensityPoint +public import LeanPool.Besicovitch.Rectifiability.Straight +public import LeanPool.Besicovitch.Measure.DensityBasic + +/-! +# Localizing lower density to a straight subset + +At almost every point of a measurable subset, the complementary restriction is negligible +relative to the restricted measure. Straightness turns this relative differentiation statement +into preservation of every strictly smaller lower-density bound. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- An eventual lower ball-mass bound gives the corresponding lower-density bound. -/ +theorem le_lowerOneDensity_of_eventually_ball_measure_ge + {s : Set (EuclideanSpace ℝ (Fin 2))} {x : (EuclideanSpace ℝ (Fin 2))} + {beta scale : ℝ} (hbeta : 0 ≤ beta) (hscale : 0 < scale) + (hmass : ∀ r : ℝ, 0 < r → r < scale → + ENNReal.ofReal (2 * beta * r) ≤ μH[1] (s ∩ Metric.ball x r)) : + ENNReal.ofReal beta ≤ lowerOneDensity s x := by + rw [lowerOneDensity] + apply le_liminf_of_le (by isBoundedDefault) + filter_upwards [Ioc_mem_nhdsGT (half_pos hscale)] with r hr + have hr_scale : r < scale := hr.2.trans_lt (half_lt_self hscale) + have hden_pos : ENNReal.ofReal (2 * r) ≠ 0 := + (ENNReal.ofReal_pos.2 (mul_pos (by norm_num) hr.1)).ne' + rw [ENNReal.le_div_iff_mul_le (Or.inl hden_pos) (Or.inl ENNReal.ofReal_ne_top)] + calc + ENNReal.ofReal beta * ENNReal.ofReal (2 * r) = + ENNReal.ofReal (2 * beta * r) := by + rw [← ENNReal.ofReal_mul hbeta] + congr 1 + ring + _ ≤ μH[1] (s ∩ Metric.ball x r) := hmass r hr.1 hr_scale + +/-- A straight measurable subset inherits every strictly smaller lower-density threshold almost +everywhere from a finite measurable ambient set. -/ +theorem ae_lt_lowerOneDensity_of_subset_of_straight + {e a : Set (EuclideanSpace ℝ (Fin 2))} (ha : MeasurableSet a) (hae : a ⊆ e) + (he_fin : μH[1] e < ∞) (ha_straight : IsStraightMeasure (μH[1].restrict a)) + {beta gamma : ℝ} (hbeta : 0 ≤ beta) (hbeta_gamma : beta < gamma) + (hdensity : ∀ᵐ x ∂μH[1].restrict a, + ENNReal.ofReal gamma ≤ lowerOneDensity e x) : + ∀ᵐ x ∂μH[1].restrict a, + ENNReal.ofReal beta < lowerOneDensity a x := by + let mu : Measure (EuclideanSpace ℝ (Fin 2)) := μH[1].restrict a + let nu : Measure (EuclideanSpace ℝ (Fin 2)) := μH[1].restrict (e \ a) + have hmu_fin : mu Set.univ < ∞ := by + simpa only [mu, Measure.restrict_apply_univ] using + (measure_mono hae).trans_lt he_fin + have hnu_fin : nu Set.univ < ∞ := by + simpa only [nu, Measure.restrict_apply_univ] using + (measure_mono sdiff_subset).trans_lt he_fin + let : IsFiniteMeasure mu := ⟨hmu_fin⟩ + let : IsFiniteMeasure nu := ⟨hnu_fin⟩ + have hsingular : nu ⟂ₘ mu := by + refine Measure.MutuallySingular.mk (s := a) (t := aᶜ) ?_ ?_ (by simp) + · simp [nu, Measure.restrict_apply ha] + · simp [mu, Measure.restrict_apply ha.compl] + have hderiv_zero : nu.rnDeriv mu =ᵐ[mu] 0 := + Measure.rnDeriv_eq_zero_of_mutuallySingular hsingular + Measure.AbsolutelyContinuous.rfl + have hratio := _root_.Besicovitch.ae_tendsto_rnDeriv nu mu + change ∀ᵐ x ∂mu, ENNReal.ofReal beta < lowerOneDensity a x + have hdensity_mu : ∀ᵐ x ∂mu, + ENNReal.ofReal gamma ≤ lowerOneDensity e x := hdensity + filter_upwards [hratio, hderiv_zero, hdensity_mu] with x hxratio hxzero hxe + have hxratio_zero : Tendsto + (fun r ↦ nu (Metric.closedBall x r) / mu (Metric.closedBall x r)) + (𝓝[>] 0) (𝓝 0) := by + have hxzero' : nu.rnDeriv mu x = 0 := by simpa using hxzero + simpa only [hxzero'] using hxratio + let theta := (beta + gamma) / 2 + let eta := (beta + theta) / 2 + let epsilon := theta - eta + have hbeta_theta : beta < theta := by + dsimp only [theta] + linarith + have htheta_gamma : theta < gamma := by + dsimp only [theta] + linarith + have hbeta_eta : beta < eta := by + dsimp only [eta] + linarith + have heta_theta : eta < theta := by + dsimp only [eta] + linarith + have htheta_nonneg : 0 ≤ theta := hbeta.trans hbeta_theta.le + have heta_nonneg : 0 ≤ eta := hbeta.trans hbeta_eta.le + have hepsilon_pos : 0 < epsilon := by + dsimp only [epsilon] + linarith + have htheta_density : ENNReal.ofReal theta < lowerOneDensity e x := + ((ENNReal.ofReal_lt_ofReal_iff (hbeta.trans_lt hbeta_gamma)).2 htheta_gamma).trans_le hxe + obtain ⟨densityScale, hdensityScale, hmass_e⟩ := + lowerOneDensity_eventually_ball_measure_gt htheta_nonneg htheta_density + have hratio_eventually : ∀ᶠ r in 𝓝[>] (0 : ℝ), + nu (Metric.closedBall x r) / mu (Metric.closedBall x r) < + ENNReal.ofReal epsilon := + hxratio_zero.eventually (Iio_mem_nhds (ENNReal.ofReal_pos.2 hepsilon_pos)) + obtain ⟨neighborhood, hneighborhood, hratio_on⟩ := + mem_nhdsWithin_iff_exists_mem_nhds_inter.mp hratio_eventually + obtain ⟨ratioScale, hratioScale, hball_ratio⟩ := + Metric.mem_nhds_iff.mp hneighborhood + have hmass_a : ∀ r : ℝ, 0 < r → r < min densityScale ratioScale → + ENNReal.ofReal (2 * eta * r) < μH[1] (a ∩ Metric.ball x r) := by + intro r hr hrscale + have hr_density : r < densityScale := hrscale.trans_le (min_le_left _ _) + have hr_ratio : r < ratioScale := hrscale.trans_le (min_le_right _ _) + have hr_mem : r ∈ neighborhood ∩ Ioi (0 : ℝ) := by + refine ⟨hball_ratio ?_, hr⟩ + simpa [Real.dist_eq, abs_of_pos hr] using hr_ratio + have hratio_le : nu (Metric.closedBall x r) ≤ + ENNReal.ofReal epsilon * mu (Metric.closedBall x r) := by + apply (ENNReal.div_le_iff_le_mul + (Or.inr ENNReal.ofReal_ne_top) + (Or.inr (ENNReal.ofReal_pos.2 hepsilon_pos).ne')).mp + exact (hratio_on hr_mem).le + have hnu_le : nu (Metric.closedBall x r) ≤ ENNReal.ofReal (2 * epsilon * r) := by + calc + nu (Metric.closedBall x r) ≤ + ENNReal.ofReal epsilon * mu (Metric.closedBall x r) := hratio_le + _ ≤ ENNReal.ofReal epsilon * ENNReal.ofReal (2 * r) := by + gcongr + exact ha_straight.measure_closedBall_le x r + _ = ENNReal.ofReal (2 * epsilon * r) := by + rw [← ENNReal.ofReal_mul hepsilon_pos.le] + congr 1 + ring + have he_subset : e ∩ Metric.ball x r ⊆ + (a ∩ Metric.ball x r) ∪ ((e \ a) ∩ Metric.closedBall x r) := by + intro y hy + by_cases hya : y ∈ a + · exact Or.inl ⟨hya, hy.2⟩ + · exact Or.inr ⟨⟨hy.1, hya⟩, Metric.ball_subset_closedBall hy.2⟩ + have he_measure : μH[1] (e ∩ Metric.ball x r) ≤ + μH[1] (a ∩ Metric.ball x r) + nu (Metric.closedBall x r) := by + calc + μH[1] (e ∩ Metric.ball x r) ≤ + μH[1] ((a ∩ Metric.ball x r) ∪ + ((e \ a) ∩ Metric.closedBall x r)) := measure_mono he_subset + _ ≤ μH[1] (a ∩ Metric.ball x r) + + μH[1] ((e \ a) ∩ Metric.closedBall x r) := measure_union_le _ _ + _ = μH[1] (a ∩ Metric.ball x r) + nu (Metric.closedBall x r) := by + change μH[1] (a ∩ Metric.ball x r) + + μH[1] ((e \ a) ∩ Metric.closedBall x r) = + μH[1] (a ∩ Metric.ball x r) + + (μH[1].restrict (e \ a)) (Metric.closedBall x r) + rw [Measure.restrict_apply measurableSet_closedBall] + congr 1 + exact congrArg μH[1] (inter_comm _ _) + by_contra hnot + have ha_upper : μH[1] (a ∩ Metric.ball x r) ≤ + ENNReal.ofReal (2 * eta * r) := le_of_not_gt hnot + have he_upper : μH[1] (e ∩ Metric.ball x r) ≤ + ENNReal.ofReal (2 * theta * r) := by + calc + μH[1] (e ∩ Metric.ball x r) ≤ + μH[1] (a ∩ Metric.ball x r) + nu (Metric.closedBall x r) := he_measure + _ ≤ ENNReal.ofReal (2 * eta * r) + ENNReal.ofReal (2 * epsilon * r) := + add_le_add ha_upper hnu_le + _ = ENNReal.ofReal (2 * theta * r) := by + rw [← ENNReal.ofReal_add (by positivity) (by positivity)] + congr 1 + dsimp only [epsilon] + ring + exact (not_le_of_gt (hmass_e r hr hr_density)) he_upper + have hscale : 0 < min densityScale ratioScale := lt_min hdensityScale hratioScale + exact ((ENNReal.ofReal_lt_ofReal_iff (hbeta.trans_lt hbeta_eta)).2 hbeta_eta).trans_le + (le_lowerOneDensity_of_eventually_ball_measure_ge heta_nonneg hscale fun r hr hrs ↦ + (hmass_a r hr hrs).le) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Measure/UniformDensity.lean b/LeanPool/Besicovitch/Measure/UniformDensity.lean new file mode 100644 index 0000000000..b9a923a71a --- /dev/null +++ b/LeanPool/Besicovitch/Measure/UniformDensity.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Measure.DensityBasic +public import Mathlib.MeasureTheory.Measure.Prod + +/-! +# Uniform lower-density sets + +The set `uniformDensitySet μ A γ m` consists of the points of `A` where the lower ball-mass +bound at level `γ` holds at every positive rational radius below `1 / (m + 1)`. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- Ball mass is a measurable function of the center for an s-finite measure on the plane. -/ +theorem measurable_measure_ball (mu : Measure (EuclideanSpace ℝ (Fin 2))) [SFinite mu] (r : ℝ) : + Measurable fun x ↦ mu (Metric.ball x r) := by + let ballRelation : Set ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))) := + {p | dist p.1 p.2 < r} + have relation_measurable : MeasurableSet ballRelation := by + exact measurableSet_lt measurable_dist measurable_const + have h := measurable_measure_prodMk_left (ν := mu) relation_measurable + convert h using 1 + funext x + congr 1 + ext y + simp only [ballRelation, mem_ofPred_eq, mem_preimage, Metric.mem_ball] + rw [dist_comm] + +/-- Points with a uniform rational-radius lower mass bound. -/ +def uniformDensitySet (mu : Measure (EuclideanSpace ℝ (Fin 2))) + (A : Set (EuclideanSpace ℝ (Fin 2))) (γ : ℝ) (m : ℕ) : + Set (EuclideanSpace ℝ (Fin 2)) := + {x ∈ A | ∀ q : ℚ, 0 < (q : ℝ) → (q : ℝ) < 1 / (m + 1 : ℝ) → + ENNReal.ofReal (2 * γ * (q : ℝ)) ≤ mu (Metric.ball x q)} + +/-- Uniform density sets are measurable. -/ +theorem measurableSet_uniformDensitySet (mu : Measure (EuclideanSpace ℝ (Fin 2))) [SFinite mu] + {A : Set (EuclideanSpace ℝ (Fin 2))} (hA : MeasurableSet A) (γ : ℝ) (m : ℕ) : + MeasurableSet (uniformDensitySet mu A γ m) := by + rw [show uniformDensitySet mu A γ m = + A ∩ ⋂ q : ℚ, ⋂ (_ : 0 < (q : ℝ)), ⋂ (_ : (q : ℝ) < 1 / (m + 1 : ℝ)), + {x | ENNReal.ofReal (2 * γ * (q : ℝ)) ≤ mu (Metric.ball x q)} by + ext x + simp only [uniformDensitySet, mem_ofPred_eq, mem_inter_iff, mem_iInter]] + refine hA.inter <| MeasurableSet.iInter fun q ↦ MeasurableSet.iInter fun _ ↦ + MeasurableSet.iInter fun _ ↦ ?_ + exact measurableSet_le measurable_const (measurable_measure_ball mu q) + +/-- A strict lower-density bound places a point in some uniform density set. -/ +theorem exists_mem_uniformDensitySet_of_lt_lowerOneDensity + {A : Set (EuclideanSpace ℝ (Fin 2))} {x : (EuclideanSpace ℝ (Fin 2))} {γ : ℝ} + (hx : x ∈ A) (hγ : 0 ≤ γ) (hdensity : ENNReal.ofReal γ < lowerOneDensity A x) : + ∃ m : ℕ, x ∈ uniformDensitySet (μH[1].restrict A) A γ m := by + obtain ⟨scale, hscale, hmass⟩ := + lowerOneDensity_eventually_ball_measure_gt hγ hdensity + obtain ⟨m, hm⟩ := exists_nat_one_div_lt hscale + refine ⟨m, hx, fun q hq hq_small ↦ ?_⟩ + rw [restrict_hausdorffMeasure_ball] + exact (hmass q hq (hq_small.trans hm)).le + +/-- Membership at level `γ` gives strict ball bounds at every lower nonnegative level. -/ +theorem uniformDensitySet_ball_measure_gt {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {A : Set (EuclideanSpace ℝ (Fin 2))} {β γ : ℝ} + {m : ℕ} {x : (EuclideanSpace ℝ (Fin 2))} (hβ : 0 ≤ β) (hβγ : β < γ) + (hx : x ∈ uniformDensitySet mu A γ m) {r : ℝ} (hr : 0 < r) + (hr_small : r < 1 / (m + 1 : ℝ)) : + ENNReal.ofReal (2 * β * r) < mu (Metric.ball x r) := by + have hγ : 0 < γ := hβ.trans_lt hβγ + have hratio : β / γ < 1 := (div_lt_one hγ).2 hβγ + have hlower : β / γ * r < r := by + nlinarith [mul_lt_mul_of_pos_right hratio hr] + obtain ⟨q : ℚ, hq_lower, hq_upper⟩ := exists_rat_btwn hlower + have hq_pos : 0 < (q : ℝ) := by + have hratio_nonneg : 0 ≤ β / γ := div_nonneg hβ hγ.le + nlinarith [mul_nonneg hratio_nonneg hr.le] + have hq_small : (q : ℝ) < 1 / (m + 1 : ℝ) := hq_upper.trans hr_small + have hreal : 2 * β * r < 2 * γ * (q : ℝ) := by + have hscaled := mul_lt_mul_of_pos_left hq_lower hγ + field_simp at hscaled + nlinarith + have hofReal : ENNReal.ofReal (2 * β * r) < + ENNReal.ofReal (2 * γ * (q : ℝ)) := by + exact (ENNReal.ofReal_lt_ofReal_iff_of_nonneg (by positivity)).2 hreal + exact hofReal.trans_le <| (hx.2 q hq_pos hq_small).trans <| + measure_mono (Metric.ball_subset_ball hq_upper.le) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Measure/UniformDensityCompact.lean b/LeanPool/Besicovitch/Measure/UniformDensityCompact.lean new file mode 100644 index 0000000000..041361ad5f --- /dev/null +++ b/LeanPool/Besicovitch/Measure/UniformDensityCompact.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Measure.UniformDensity +public import LeanPool.Besicovitch.Measure.CompactExhaustion + +/-! +# Compact uniform-density pieces + +An almost-everywhere strict lower-density bound can be made uniform on a compact subset, +while losing arbitrarily little Hausdorff measure. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- Increasing the scale index only weakens the defining radius restriction. -/ +theorem monotone_uniformDensitySet (mu : Measure (EuclideanSpace ℝ (Fin 2))) + (A : Set (EuclideanSpace ℝ (Fin 2))) (gamma : ℝ) : + Monotone fun m ↦ uniformDensitySet mu A gamma m := by + intro m n hmn x hx + refine ⟨hx.1, fun q hq hq_small ↦ hx.2 q hq ?_⟩ + refine hq_small.trans_le <| one_div_le_one_div_of_le (by positivity) ?_ + exact_mod_cast Nat.add_le_add_right hmn 1 + +/-- Lowering the density level enlarges a uniform density set. -/ +theorem uniformDensitySet_mono_level {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {A : Set (EuclideanSpace ℝ (Fin 2))} {beta gamma : ℝ} + {m : ℕ} (hbeta_gamma : beta ≤ gamma) : + uniformDensitySet mu A gamma m ⊆ uniformDensitySet mu A beta m := by + intro x hx + refine ⟨hx.1, fun q hq hq_small ↦ ?_⟩ + apply (ENNReal.ofReal_le_ofReal ?_).trans (hx.2 q hq hq_small) + exact mul_le_mul_of_nonneg_right + (mul_le_mul_of_nonneg_left hbeta_gamma (by norm_num)) hq.le + +/-- A point strictly above level `sigma` belongs to the diagonal uniform-density exhaustion. -/ +theorem exists_mem_diagonal_uniformDensitySet_of_lt_lowerOneDensity + {A : Set (EuclideanSpace ℝ (Fin 2))} + {x : (EuclideanSpace ℝ (Fin 2))} {sigma : ℝ} (hx : x ∈ A) (hsigma : 0 ≤ sigma) + (hdensity : ENNReal.ofReal sigma < lowerOneDensity A x) : + ∃ n : ℕ, x ∈ uniformDensitySet (μH[1].restrict A) A + (sigma + 1 / (n + 1 : ℝ)) n := by + have hgap : ∃ k : ℕ, + ENNReal.ofReal (sigma + 1 / (k + 1 : ℝ)) < lowerOneDensity A x := by + by_cases htop : lowerOneDensity A x = ∞ + · refine ⟨0, ?_⟩ + rw [htop] + exact ENNReal.ofReal_lt_top + · have hsigma_real : sigma < (lowerOneDensity A x).toReal := by + have hreal := (ENNReal.toReal_lt_toReal (by simp) htop).2 hdensity + simpa [ENNReal.toReal_ofReal hsigma] using hreal + obtain ⟨k, hk⟩ := exists_nat_one_div_lt (sub_pos.2 hsigma_real) + refine ⟨k, ?_⟩ + apply (ENNReal.toReal_lt_toReal (by simp) htop).1 + rw [ENNReal.toReal_ofReal (by positivity)] + linarith + obtain ⟨k, hk⟩ := hgap + have hlevel_nonneg : 0 ≤ sigma + 1 / (k + 1 : ℝ) := by positivity + obtain ⟨m, hm⟩ := + exists_mem_uniformDensitySet_of_lt_lowerOneDensity hx hlevel_nonneg hk + let n := max k m + refine ⟨n, ?_⟩ + apply monotone_uniformDensitySet _ _ _ (le_max_right k m) + apply uniformDensitySet_mono_level ?_ hm + have hone : 1 / (n + 1 : ℝ) ≤ 1 / (k + 1 : ℝ) := by + apply one_div_le_one_div_of_le (by positivity) + exact_mod_cast Nat.add_le_add_right (le_max_left k m) 1 + linarith + +/-- Almost every point lies in a uniform-density set when its lower density exceeds the level. -/ +theorem ae_mem_iUnion_uniformDensitySet + {A : Set (EuclideanSpace ℝ (Fin 2))} (hA : MeasurableSet A) + {gamma : ℝ} (hgamma : 0 ≤ gamma) + (hdensity : ∀ᵐ x ∂μH[1].restrict A, + ENNReal.ofReal gamma < lowerOneDensity A x) : + ∀ᵐ x ∂μH[1].restrict A, x ∈ ⋃ m, uniformDensitySet (μH[1].restrict A) A gamma m := by + filter_upwards [ae_restrict_mem hA, hdensity] with x hxA hxDensity + obtain ⟨m, hm⟩ := + exists_mem_uniformDensitySet_of_lt_lowerOneDensity hxA hgamma hxDensity + exact mem_iUnion.2 ⟨m, hm⟩ + +/-- Almost-everywhere density gives an arbitrarily small exceptional set at one uniform scale. -/ +theorem exists_uniformDensitySet_measure_sdiff_lt + {A : Set (EuclideanSpace ℝ (Fin 2))} (hA : MeasurableSet A) + {gamma : ℝ} (hgamma : 0 ≤ gamma) + (hdensity : ∀ᵐ x ∂μH[1].restrict A, + ENNReal.ofReal gamma < lowerOneDensity A x) + (hfinite : μH[1] A ≠ ∞) + {epsilon : ℝ≥0∞} (hepsilon : 0 < epsilon) : + ∃ m : ℕ, μH[1] (A \ uniformDensitySet (μH[1].restrict A) A gamma m) < epsilon := by + let : IsFiniteMeasure (μH[1].restrict A) := isFiniteMeasure_restrict.mpr hfinite + exact exists_in_monotone_ae_cover_measure_sdiff_lt hA hfinite + (fun _ ↦ measurableSet_uniformDensitySet _ hA _ _) + (monotone_uniformDensitySet _ _ _) + (ae_mem_iUnion_uniformDensitySet hA hgamma hdensity) hepsilon + +/-- A compact uniform-density piece can retain all but any prescribed positive mass. -/ +theorem exists_compact_uniformDensitySet_measure_sdiff_lt {A : Set (EuclideanSpace ℝ (Fin 2))} + (hA : MeasurableSet A) {gamma : ℝ} (hgamma : 0 ≤ gamma) + (hdensity : ∀ᵐ x ∂μH[1].restrict A, + ENNReal.ofReal gamma < lowerOneDensity A x) + (hfinite : μH[1] A ≠ ∞) {epsilon : ℝ≥0∞} (hepsilon : 0 < epsilon) : + ∃ (m : ℕ) (F : Set (EuclideanSpace ℝ (Fin 2))), IsCompact F ∧ + F ⊆ uniformDensitySet (μH[1].restrict A) A gamma m ∧ μH[1] (A \ F) < epsilon := by + let : IsFiniteMeasure (μH[1].restrict A) := isFiniteMeasure_restrict.mpr hfinite + exact exists_compact_in_monotone_ae_cover_measure_sdiff_lt hA hfinite + (fun _ ↦ measurableSet_uniformDensitySet _ hA _ _) + (fun _ _ hx ↦ hx.1) (monotone_uniformDensitySet _ _ _) + (ae_mem_iUnion_uniformDensitySet hA hgamma hdensity) hepsilon + +/-- The compact core can be chosen so that the discarded mass is a prescribed fraction of it. -/ +theorem exists_compact_uniformDensitySet_measure_sdiff_lt_mul {A : Set (EuclideanSpace ℝ (Fin 2))} + (hA : MeasurableSet A) (hA_pos : 0 < μH[1] A) (hA_finite : μH[1] A ≠ ∞) + {gamma alpha : ℝ} (hgamma : 0 ≤ gamma) (halpha : 0 < alpha) + (hdensity : ∀ᵐ x ∂μH[1].restrict A, + ENNReal.ofReal gamma < lowerOneDensity A x) : + ∃ (m : ℕ) (F : Set (EuclideanSpace ℝ (Fin 2))), IsCompact F ∧ + F ⊆ uniformDensitySet (μH[1].restrict A) A gamma m ∧ + μH[1] (A \ F) < ENNReal.ofReal alpha * μH[1] F := by + let : IsFiniteMeasure (μH[1].restrict A) := isFiniteMeasure_restrict.mpr hA_finite + exact exists_compact_in_monotone_ae_cover_measure_sdiff_lt_mul hA hA_pos hA_finite + (fun _ ↦ measurableSet_uniformDensitySet _ hA _ _) + (fun _ _ hx ↦ hx.1) (monotone_uniformDensitySet _ _ _) + (ae_mem_iUnion_uniformDensitySet hA hgamma hdensity) + (ENNReal.ofReal_pos.2 halpha) ENNReal.ofReal_ne_top + +/-- An almost-everywhere density bound strictly above `sigma` is uniform at a common higher level +on a compact core whose discarded mass is a prescribed fraction of the retained mass. -/ +theorem exists_compact_uniformDensitySet_above + {A : Set (EuclideanSpace ℝ (Fin 2))} (hA : MeasurableSet A) + (hA_pos : 0 < μH[1] A) (hA_finite : μH[1] A ≠ ∞) {sigma alpha : ℝ} + (hsigma : 0 ≤ sigma) (halpha : 0 < alpha) + (hdensity : ∀ᵐ x ∂μH[1].restrict A, + ENNReal.ofReal sigma < lowerOneDensity A x) : + ∃ (gamma : ℝ) (m : ℕ) (F : Set (EuclideanSpace ℝ (Fin 2))), + sigma < gamma ∧ IsCompact F ∧ + F ⊆ uniformDensitySet (μH[1].restrict A) A gamma m ∧ + μH[1] (A \ F) < ENNReal.ofReal alpha * μH[1] F := by + let : IsFiniteMeasure (μH[1].restrict A) := isFiniteMeasure_restrict.mpr hA_finite + let G : ℕ → Set (EuclideanSpace ℝ (Fin 2)) := fun n ↦ + uniformDensitySet (μH[1].restrict A) A (sigma + 1 / (n + 1 : ℝ)) n + have hG_measurable (n : ℕ) : MeasurableSet (G n) := + measurableSet_uniformDensitySet _ hA _ _ + have hG_subset (n : ℕ) : G n ⊆ A := fun _ hx ↦ hx.1 + have hG_mono : Monotone G := by + intro m n hmn x hx + apply monotone_uniformDensitySet _ _ _ hmn + apply uniformDensitySet_mono_level ?_ hx + have hone : 1 / (n + 1 : ℝ) ≤ 1 / (m + 1 : ℝ) := by + apply one_div_le_one_div_of_le (by positivity) + exact_mod_cast Nat.add_le_add_right hmn 1 + linarith + have hcovered : ∀ᵐ x ∂μH[1].restrict A, x ∈ ⋃ n, G n := by + filter_upwards [ae_restrict_mem hA, hdensity] with x hxA hxDensity + obtain ⟨n, hn⟩ := + exists_mem_diagonal_uniformDensitySet_of_lt_lowerOneDensity hxA hsigma hxDensity + exact mem_iUnion.2 ⟨n, hn⟩ + obtain ⟨n, F, hF_compact, hFG, herror⟩ := + exists_compact_in_monotone_ae_cover_measure_sdiff_lt_mul hA hA_pos hA_finite + hG_measurable hG_subset hG_mono hcovered (ENNReal.ofReal_pos.2 halpha) + ENNReal.ofReal_ne_top + refine ⟨sigma + 1 / (n + 1 : ℝ), n, F, ?_, hF_compact, ?_, herror⟩ + · have : 0 < 1 / (n + 1 : ℝ) := by positivity + linarith + exact hFG + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/AttachmentLocalization.lean b/LeanPool/Besicovitch/Rectifiability/AttachmentLocalization.lean new file mode 100644 index 0000000000..d8fd929cc8 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/AttachmentLocalization.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexLocalization +public import LeanPool.Besicovitch.Rectifiability.ComponentDiameter + +/-! +# Removing the local attachment holes + +Every point of the compact attachment union outside the core lies in an attachment. If that +point also lies in a local set `C`, the attachment's three-diameter enlargement is one of the +holes recorded as touching `C`. +-/ + +@[expose] public section + +noncomputable section + +open Set + +namespace LeanPool.Besicovitch + +/-- Removing every three-diameter enlargement which touches `C` leaves only points of the compact +core `F`. -/ +theorem sdiff_iUnion_touchingBadConvexSets_subset_core + {mu : MeasureTheory.Measure (EuclideanSpace ℝ (Fin 2))} + {F C : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} (halpha : 0 < alpha) + {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) + (hC : C ⊆ compactAttachmentUnion F chosen) : + C \ ⋃ V : touchingBadConvexSets 3 chosen C, + diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))) ⊆ F := by + intro x hx + rcases hC hx.1 with hxF | hxAttachment + · exact hxF + · obtain ⟨V, hxV⟩ := mem_iUnion.1 hxAttachment + have hVbad := hchosen V.property + have hxThickening : x ∈ diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))) := + convexAttachment_subset_diameterThickening_three hVbad.2.1 + (diam_pos_of_mem_badConvexSets halpha hVbad) hxV + let W : touchingBadConvexSets 3 chosen C := + ⟨V, V.property, ⟨x, hxThickening, hx.1⟩⟩ + exact (hx.2 (mem_iUnion_of_mem W hxThickening)).elim + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/BadConvexLocalization.lean b/LeanPool/Besicovitch/Rectifiability/BadConvexLocalization.lean new file mode 100644 index 0000000000..99fcc4ee1f --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/BadConvexLocalization.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexThickening + +/-! +# Localizing bad convex sets + +A selected bad set whose three-diameter enlargement meets a small continuum must itself lie in +the doubled ball, provided the centre was chosen outside its seven-diameter enlargement. +-/ + +@[expose] public section + +noncomputable section + +open Bornology Set + +namespace LeanPool.Besicovitch + +/-- Selected holes whose `p`-diameter enlargements meet a set. -/ +def touchingBadConvexSets (p : ℝ) + (chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))) + (C : Set (EuclideanSpace ℝ (Fin 2))) : + Set (Set (EuclideanSpace ℝ (Fin 2))) := + {V | V ∈ chosen ∧ (diameterThickening p V ∩ C).Nonempty} + +/-- A hole touching the local continuum is contained in the doubled localization ball. -/ +theorem subset_ball_two_mul_of_diameterThickening_three_inter + {V C : Set (EuclideanSpace ℝ (Fin 2))} + (hV : IsBounded V) {z : (EuclideanSpace ℝ (Fin 2))} {rho : ℝ} + (hz : z ∉ diameterThickening 7 V) (hC : C ⊆ Metric.closedBall z rho) + (htouch : (diameterThickening 3 V ∩ C).Nonempty) : + V ⊆ Metric.ball z (2 * rho) := by + obtain ⟨x, hxthickening, hxC⟩ := htouch + rw [diameterThickening, Metric.mem_thickening_iff] at hxthickening + obtain ⟨w₂, hw₂V, hxw₂⟩ := hxthickening + have hxz : dist x z ≤ rho := by + simpa [dist_comm] using hC hxC + intro w₁ hw₁V + rw [Metric.mem_ball] + by_contra hw₁ + have hzw₁ : 2 * rho ≤ dist z w₁ := by simpa [dist_comm] using not_lt.mp hw₁ + have hw₂w₁ : dist w₂ w₁ ≤ Metric.diam V := + Metric.dist_le_diam_of_mem hV hw₂V hw₁V + have hxw₁ : dist x w₁ < 4 * Metric.diam V := by + calc + dist x w₁ ≤ dist x w₂ + dist w₂ w₁ := dist_triangle _ _ _ + _ < 3 * Metric.diam V + Metric.diam V := add_lt_add_of_lt_of_le hxw₂ hw₂w₁ + _ = 4 * Metric.diam V := by ring + have hrho_diam : rho < 4 * Metric.diam V := by + have htriangle : dist z w₁ ≤ dist z x + dist x w₁ := dist_triangle _ _ _ + rw [dist_comm z x] at htriangle + nlinarith + have hzw₂ : dist z w₂ < 7 * Metric.diam V := by + have htriangle : dist z w₂ ≤ dist z x + dist x w₂ := dist_triangle _ _ _ + rw [dist_comm z x] at htriangle + nlinarith + apply hz + rw [diameterThickening, Metric.mem_thickening_iff] + exact ⟨w₂, hw₂V, hzw₂⟩ + +/-- The selected holes touching the local continuum charge only the doubled ball. -/ +theorem mul_tsum_ediam_touchingBadConvexSets_le + {mu : MeasureTheory.Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : MeasurableSet F) + {alpha : ℝ} (halpha : 0 < alpha) {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) + {C : Set (EuclideanSpace ℝ (Fin 2))} {z : (EuclideanSpace ℝ (Fin 2))} {rho : ℝ} + (hz : ∀ V : chosen, z ∉ diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2)))) + (hC : C ⊆ Metric.closedBall z rho) : + ENNReal.ofReal alpha * + ∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) ≤ + mu (Metric.ball z (2 * rho) \ F) := by + let touching := touchingBadConvexSets 3 chosen C + have hlocal_subset : touching ⊆ chosen := fun _ hV ↦ hV.1 + have hlocal_bad : touching ⊆ badConvexSets mu F alpha := hlocal_subset.trans hchosen + have hlocal_countable : touching.Countable := hcountable.mono hlocal_subset + have hlocal_disjoint : touching.PairwiseDisjoint id := by + intro V hV W hW hVW + exact hdisjoint hV.1 hW.1 hVW + apply mul_tsum_ediam_badConvexSets_le_measure hF hlocal_bad hlocal_countable + hlocal_disjoint + intro V hV + apply subset_ball_two_mul_of_diameterThickening_three_inter + (isBounded_of_mem_badConvexSets halpha (hchosen hV.1)) + · exact hz ⟨V, hV.1⟩ + · exact hC + · exact hV.2 + +/-- The three-diameter enlargements touching the local continuum have total diameter smaller than +the continuum itself. -/ +theorem tsum_ediam_touchingBadConvexSets_lt_ediam + {mu : MeasureTheory.Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : MeasurableSet F) + {alpha sigma : ℝ} (halpha : 0 < alpha) (hsigma : 0 < sigma) + {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) + (hcountable : chosen.Countable) (hdisjoint : chosen.PairwiseDisjoint id) + {C : Set (EuclideanSpace ℝ (Fin 2))} {z : (EuclideanSpace ℝ (Fin 2))} {rho : ℝ} + (hrho : 0 < rho) + (hz : ∀ V : chosen, z ∉ diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2)))) + (hC : C ⊆ Metric.closedBall z rho) + (houtside : mu (Metric.ball z (2 * rho) \ F) < + ENNReal.ofReal alpha * ENNReal.ofReal (sigma * rho / 14)) + (hCdiam : ENNReal.ofReal (sigma * rho / 2) ≤ Metric.ediam C) : + ∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2)))) < + Metric.ediam C := by + have hpacking := mul_tsum_ediam_touchingBadConvexSets_le hF halpha hchosen hcountable + hdisjoint hz hC + have hsum : (∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) < ENNReal.ofReal (sigma * rho / 14) := by + exact lt_of_mul_lt_mul_left (hpacking.trans_lt houtside) (by positivity) + calc + (∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (diameterThickening 3 (V : Set (EuclideanSpace ℝ (Fin 2))))) ≤ + ∑' V : touchingBadConvexSets 3 chosen C, + ENNReal.ofReal 7 * Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := + ENNReal.tsum_le_tsum fun V ↦ by + convert ediam_diameterThickening_le (by norm_num : (0 : ℝ) ≤ 3) + (isBounded_of_mem_badConvexSets halpha (hchosen V.property.1)) using 1 + all_goals norm_num + _ = ENNReal.ofReal 7 * + ∑' V : touchingBadConvexSets 3 chosen C, + Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := + ENNReal.tsum_mul_left + _ < ENNReal.ofReal 7 * ENNReal.ofReal (sigma * rho / 14) := + ENNReal.mul_lt_mul_right (by norm_num) ENNReal.ofReal_ne_top hsum + _ = ENNReal.ofReal (sigma * rho / 2) := by + rw [← ENNReal.ofReal_mul (by norm_num : (0 : ℝ) ≤ 7)] + congr 1 + field_simp + ring + _ ≤ Metric.ediam C := hCdiam + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/BadConvexPacking.lean b/LeanPool/Besicovitch/Rectifiability/BadConvexPacking.lean new file mode 100644 index 0000000000..a4a7d92724 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/BadConvexPacking.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexSets + +/-! +# Packing bad convex sets + +For a disjoint countable family of bad convex sets, the sum of their diameters is controlled by +the mass outside the compact core. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal MeasureTheory + +namespace LeanPool.Besicovitch + +/-- Disjoint bad convex sets contained in an ambient set charge only its mass outside the core. -/ +theorem mul_tsum_ediam_badConvexSets_le_measure + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F ambient : Set (EuclideanSpace ℝ (Fin 2))} + (hF : MeasurableSet F) {alpha : ℝ} {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) + (hcontained : ∀ V ∈ chosen, V ⊆ ambient) : + ENNReal.ofReal alpha * + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) ≤ + mu (ambient \ F) := by + let : Countable chosen := hcountable.to_subtype + have hpair : Pairwise fun V W : chosen ↦ + Disjoint ((V : Set (EuclideanSpace ℝ (Fin 2))) \ F) + ((W : Set (EuclideanSpace ℝ (Fin 2))) \ F) := by + intro V W hVW + have hne : (V : Set (EuclideanSpace ℝ (Fin 2))) ≠ + (W : Set (EuclideanSpace ℝ (Fin 2))) := + fun h ↦ hVW (Subtype.ext h) + exact (hdisjoint V.property W.property hne).mono sdiff_subset sdiff_subset + have hmeasurable (V : chosen) : MeasurableSet ((V : Set (EuclideanSpace ℝ (Fin 2))) \ F) := + (hchosen V.property).1.measurableSet.diff hF + rw [← ENNReal.tsum_mul_left] + calc + (∑' V : chosen, + ENNReal.ofReal alpha * Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ∑' V : chosen, mu ((V : Set (EuclideanSpace ℝ (Fin 2))) \ F) := + ENNReal.tsum_le_tsum fun V ↦ (hchosen V.property).2.2.2.le + _ = mu (⋃ V : chosen, (V : Set (EuclideanSpace ℝ (Fin 2))) \ F) := + (measure_iUnion hpair hmeasurable).symm + _ ≤ mu (ambient \ F) := measure_mono <| iUnion_subset fun V x hx ↦ + ⟨hcontained V V.property hx.1, hx.2⟩ + +/-- Disjoint bad convex sets have total extended diameter controlled by the mass outside the +compact core. -/ +theorem mul_tsum_ediam_badConvexSets_le + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} + (hF : MeasurableSet F) {alpha : ℝ} {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) : + ENNReal.ofReal alpha * + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) ≤ mu Fᶜ := by + simpa only [← compl_eq_univ_sdiff] using + mul_tsum_ediam_badConvexSets_le_measure hF hchosen hcountable hdisjoint + (ambient := univ) (fun _ _ ↦ subset_univ _) + +/-- If the outside mass is less than `alpha / enlargement` times the retained mass, then the +diameter sum is less than `1 / enlargement` times the retained mass. -/ +theorem tsum_ediam_badConvexSets_lt + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} + (hF : MeasurableSet F) {alpha enlargement : ℝ} (halpha : 0 < alpha) + (henlargement : 0 < enlargement) {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) + (houtside : mu Fᶜ < ENNReal.ofReal (alpha / enlargement) * mu F) : + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) < + ENNReal.ofReal (1 / enlargement) * mu F := by + have hpacking := mul_tsum_ediam_badConvexSets_le hF hchosen hcountable hdisjoint + have hcombined := hpacking.trans_lt houtside + have hfactor : ENNReal.ofReal (alpha / enlargement) = + ENNReal.ofReal alpha * ENNReal.ofReal (1 / enlargement) := by + rw [ENNReal.ofReal_div_of_pos henlargement, ENNReal.ofReal_div_of_pos henlargement] + simp [div_eq_mul_inv] + have hcombined' : ENNReal.ofReal alpha * + (∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) < + ENNReal.ofReal alpha * (ENNReal.ofReal (1 / enlargement) * mu F) := by + rw [hfactor, mul_assoc] at hcombined + exact hcombined + exact lt_of_mul_lt_mul_left hcombined' (by positivity) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/BadConvexSets.lean b/LeanPool/Besicovitch/Rectifiability/BadConvexSets.lean new file mode 100644 index 0000000000..0197268048 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/BadConvexSets.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Definitions +public import LeanPool.Besicovitch.Geometry.ConvexEnlargement +public import LeanPool.Besicovitch.Rectifiability.Selection + +/-! +# Bad convex sets + +A bad convex set meets the compact density core but contains disproportionately much measure +outside it. These are the holes used in the continuum construction. +-/ + +@[expose] public section + +noncomputable section + +open Bornology MeasureTheory Set +open scoped ENNReal MeasureTheory + +namespace LeanPool.Besicovitch + +/-- Open convex sets meeting `F` whose mass outside `F` exceeds `alpha` times their diameter. -/ +def badConvexSets (mu : Measure (EuclideanSpace ℝ (Fin 2))) + (F : Set (EuclideanSpace ℝ (Fin 2))) (alpha : ℝ) : + Set (Set (EuclideanSpace ℝ (Fin 2))) := + {V | IsOpen V ∧ Convex ℝ V ∧ (V ∩ F).Nonempty ∧ + ENNReal.ofReal alpha * Metric.ediam V < mu (V \ F)} + +@[simp] +theorem mem_badConvexSets {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F V : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} : + V ∈ badConvexSets mu F alpha ↔ IsOpen V ∧ Convex ℝ V ∧ (V ∩ F).Nonempty ∧ + ENNReal.ofReal alpha * Metric.ediam V < mu (V \ F) := + Iff.rfl + +/-- A bad convex set with positive leakage coefficient is bounded. -/ +theorem isBounded_of_mem_badConvexSets {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F V : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} (halpha : 0 < alpha) + (hV : V ∈ badConvexSets mu F alpha) : IsBounded V := by + rcases hV with ⟨_, _, _, hleakage⟩ + rw [Metric.isBounded_iff_ediam_ne_top] + intro htop + have hcoefficient : ENNReal.ofReal alpha ≠ 0 := ENNReal.ofReal_ne_zero_iff.2 halpha + have hproduct : ENNReal.ofReal alpha * Metric.ediam V = ∞ := by + simp [htop, hcoefficient] + rw [hproduct] at hleakage + exact (not_lt_of_ge le_top) hleakage + +/-- A nonempty open bad convex set has positive diameter. -/ +theorem diam_pos_of_mem_badConvexSets {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F V : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} (halpha : 0 < alpha) + (hV : V ∈ badConvexSets mu F alpha) : 0 < Metric.diam V := by + have hV_nonempty : V.Nonempty := hV.2.2.1.mono inter_subset_left + obtain ⟨x, hx⟩ := hV_nonempty + obtain ⟨y, hy, hyx⟩ := + preperfect_iff_nhds.mp hV.1.preperfect x hx univ (by simp) + exact Metric.diam_pos (nontrivial_of_mem_mem_ne hx hy.2 hyx.symm) + (isBounded_of_mem_badConvexSets halpha hV) + +/-- The total mass supplies a uniform real diameter bound for all bad convex sets. -/ +theorem diam_lt_measure_univ_div_of_mem_badConvexSets {mu : Measure (EuclideanSpace ℝ (Fin 2))} + [IsFiniteMeasure mu] {F V : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} (halpha : 0 < alpha) + (hV : V ∈ badConvexSets mu F alpha) : + Metric.diam V < (mu Set.univ).toReal / alpha := by + have hbounded := isBounded_of_mem_badConvexSets halpha hV + have hed_finite : Metric.ediam V ≠ ∞ := Metric.isBounded_iff_ediam_ne_top.mp hbounded + have hproduct_finite : ENNReal.ofReal alpha * Metric.ediam V ≠ ∞ := + ENNReal.mul_ne_top ENNReal.ofReal_ne_top hed_finite + have hmass_finite : mu (V \ F) ≠ ∞ := measure_ne_top mu _ + have hreal : alpha * Metric.diam V < (mu (V \ F)).toReal := by + have h := (ENNReal.toReal_lt_toReal hproduct_finite hmass_finite).2 hV.2.2.2 + simpa [ENNReal.toReal_ofReal halpha.le, Metric.diam] using h + have hmass_le : (mu (V \ F)).toReal ≤ (mu Set.univ).toReal := by + exact ENNReal.toReal_mono (measure_ne_top mu _) (measure_mono (subset_univ _)) + apply (lt_div_iff₀ halpha).2 + nlinarith + +/-- A BPC witness becomes bad after replacing it by its open convex hull and lowering the +coefficient. -/ +theorem openConvexHull_mem_badConvexSets {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F U : Set (EuclideanSpace ℝ (Fin 2))} + {alpha tau : ℝ} (halpha_tau : alpha ≤ tau) (hU_open : IsOpen U) + (hUF : (U ∩ F).Nonempty) + (hleakage : ENNReal.ofReal tau * Metric.ediam U < mu (U \ F)) : + openConvexHull U ∈ badConvexSets mu F alpha := by + have hsubset : U ⊆ openConvexHull U := subset_openConvexHull hU_open + refine ⟨isOpen_openConvexHull U, convex_openConvexHull U, ?_, ?_⟩ + · exact hUF.mono (inter_subset_inter hsubset Subset.rfl) + calc + ENNReal.ofReal alpha * Metric.ediam (openConvexHull U) = + ENNReal.ofReal alpha * Metric.ediam U := by rw [ediam_openConvexHull hU_open] + _ ≤ ENNReal.ofReal tau * Metric.ediam U := by + exact mul_le_mul_left (ENNReal.ofReal_le_ofReal halpha_tau) _ + _ < mu (U \ F) := hleakage + _ ≤ mu (openConvexHull U \ F) := + measure_mono (sdiff_subset_sdiff hsubset Subset.rfl) + +/-- The bad convex sets have a countable disjoint scale-dominating subfamily. -/ +theorem exists_countable_disjoint_badConvexSets + {mu : Measure (EuclideanSpace ℝ (Fin 2))} [IsFiniteMeasure mu] + (F : Set (EuclideanSpace ℝ (Fin 2))) {alpha : ℝ} (halpha : 0 < alpha) : + ∃ chosen ⊆ badConvexSets mu F alpha, chosen.PairwiseDisjoint id ∧ chosen.Countable ∧ + ∀ V ∈ badConvexSets mu F alpha, ∃ W ∈ chosen, + (V ∩ W).Nonempty ∧ Metric.diam V < 2 * Metric.diam W := by + exact exists_countable_disjoint_subfamily (badConvexSets mu F alpha) + (fun _ hV ↦ hV.1) (fun _ hV ↦ hV.2.2.1.mono inter_subset_left) + (fun _ hV ↦ isBounded_of_mem_badConvexSets halpha hV) + ((mu Set.univ).toReal / alpha) + (fun _ hV ↦ (diam_lt_measure_univ_div_of_mem_badConvexSets halpha hV).le) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/BadConvexThickening.lean b/LeanPool/Besicovitch/Rectifiability/BadConvexThickening.lean new file mode 100644 index 0000000000..04b7a6172a --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/BadConvexThickening.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexPacking + +/-! +# Enlarging bad convex sets + +The seven-diameter enlargements of a disjoint family of bad convex sets still leave a point of +the compact core uncovered. The number `15 = 2 * 7 + 1` is exactly the diameter expansion +factor. +-/ + +@[expose] public section + +noncomputable section + +open Bornology MeasureTheory Set +open scoped ENNReal MeasureTheory + +namespace LeanPool.Besicovitch + +/-- Straightness bounds the mass of all diameter thickenings by their total expanded diameter. -/ +theorem measure_iUnion_diameterThickening_le {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) {alpha p : ℝ} (halpha : 0 < alpha) (hp : 0 ≤ p) + {F : Set (EuclideanSpace ℝ (Fin 2))} {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) : + mu (⋃ V : chosen, diameterThickening p (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ENNReal.ofReal (2 * p + 1) * + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := by + let : Countable chosen := hcountable.to_subtype + calc + mu (⋃ V : chosen, diameterThickening p (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ∑' V : chosen, mu (diameterThickening p (V : Set (EuclideanSpace ℝ (Fin 2)))) := + measure_iUnion_le _ + _ ≤ ∑' V : chosen, + Metric.ediam (diameterThickening p (V : Set (EuclideanSpace ℝ (Fin 2)))) := + ENNReal.tsum_le_tsum fun V ↦ + hmu _ (isOpen_diameterThickening p (V : Set (EuclideanSpace ℝ (Fin 2)))).measurableSet + _ ≤ ∑' V : chosen, + ENNReal.ofReal (2 * p + 1) * Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := + ENNReal.tsum_le_tsum fun V ↦ + ediam_diameterThickening_le hp (isBounded_of_mem_badConvexSets halpha + (hchosen V.property)) + _ = ENNReal.ofReal (2 * p + 1) * + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := + ENNReal.tsum_mul_left + +/-- The seven-diameter enlargements have less mass than the retained core. -/ +theorem measure_iUnion_sevenDiameterThickening_lt {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : MeasurableSet F) + {alpha : ℝ} (halpha : 0 < alpha) {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) + (houtside : mu Fᶜ < ENNReal.ofReal (alpha / 15) * mu F) : + mu (⋃ V : chosen, diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2)))) < mu F := by + have hsum := tsum_ediam_badConvexSets_lt hF halpha (by norm_num : (0 : ℝ) < 15) + hchosen hcountable hdisjoint houtside + calc + mu (⋃ V : chosen, diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ENNReal.ofReal 15 * + ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := by + convert measure_iUnion_diameterThickening_le hmu halpha + (by norm_num : (0 : ℝ) ≤ 7) hchosen hcountable using 1 + all_goals norm_num + _ < ENNReal.ofReal 15 * (ENNReal.ofReal (1 / 15) * mu F) := + ENNReal.mul_lt_mul_right (by norm_num) ENNReal.ofReal_ne_top hsum + _ = mu F := by + rw [← mul_assoc, ← ENNReal.ofReal_mul (by norm_num : (0 : ℝ) ≤ 15)] + norm_num + +/-- Consequently, some point of the retained core lies outside every seven-diameter +enlargement. -/ +theorem exists_mem_not_mem_sevenDiameterThickening {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : MeasurableSet F) + {alpha : ℝ} (halpha : 0 < alpha) {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) (hcountable : chosen.Countable) + (hdisjoint : chosen.PairwiseDisjoint id) + (houtside : mu Fᶜ < ENNReal.ofReal (alpha / 15) * mu F) : + ∃ z ∈ F, + ∀ V : chosen, z ∉ diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2))) := by + have hmeasure := measure_iUnion_sevenDiameterThickening_lt hmu hF halpha hchosen hcountable + hdisjoint houtside + have hnot_subset : + ¬F ⊆ ⋃ V : chosen, diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2))) := by + intro hsubset + exact (not_le_of_gt hmeasure) (measure_mono hsubset) + obtain ⟨z, hzF, hz⟩ := Set.not_subset.mp hnot_subset + exact ⟨z, hzF, fun V hzV ↦ hz (mem_iUnion_of_mem V hzV)⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/Basic.lean b/LeanPool/Besicovitch/Rectifiability/Basic.lean new file mode 100644 index 0000000000..137710e980 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/Basic.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement +public import Mathlib.Data.Nat.Pairing + +/-! +# Basic facts about one-dimensional rectifiability + +Countable one-rectifiability is inherited by subsets and countable unions. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped MeasureTheory NNReal + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- A set is purely one-unrectifiable if it meets every rectifiable set in a null set. -/ +def IsPurelyOneUnrectifiable (s : Set X) : Prop := + ∀ t, IsCountablyOneRectifiable t → μH[1] (s ∩ t) = 0 + +/-- A subset of a countably one-rectifiable set is countably one-rectifiable. -/ +theorem IsCountablyOneRectifiable.mono {s t : Set X} (hs : IsCountablyOneRectifiable s) + (ht : t ⊆ s) : IsCountablyOneRectifiable t := by + obtain ⟨f, hf, hnull⟩ := hs + refine ⟨f, hf, measure_mono_null ?_ hnull⟩ + intro x hx + exact ⟨ht hx.1, hx.2⟩ + +/-- A set of zero Hausdorff one-measure is countably one-rectifiable. -/ +theorem isCountablyOneRectifiable_of_measure_zero [Nonempty X] {s : Set X} + (hs : μH[1] s = 0) : IsCountablyOneRectifiable s := by + let ⟨x⟩ := ‹Nonempty X› + let f : ℕ → ℝ → X := fun _ _ ↦ x + refine ⟨f, fun _ ↦ ⟨0, LipschitzWith.const _⟩, ?_⟩ + exact measure_mono_null sdiff_subset hs + +/-- The empty set is countably one-rectifiable in a nonempty metric space. -/ +@[simp] +theorem isCountablyOneRectifiable_empty [Nonempty X] : + IsCountablyOneRectifiable (∅ : Set X) := by + exact isCountablyOneRectifiable_of_measure_zero (measure_empty : μH[1] (∅ : Set X) = 0) + +/-- A countable union of countably one-rectifiable sets is countably one-rectifiable. -/ +theorem isCountablyOneRectifiable_iUnion {s : ℕ → Set X} + (hs : ∀ i, IsCountablyOneRectifiable (s i)) : + IsCountablyOneRectifiable (⋃ i, s i) := by + classical + choose f hf hnull using hs + let g : ℕ → ℝ → X := fun n ↦ f n.unpair.1 n.unpair.2 + refine ⟨g, fun n ↦ hf n.unpair.1 n.unpair.2, ?_⟩ + apply measure_mono_null ?_ (measure_iUnion_null hnull) + intro x hx + obtain ⟨i, hxi⟩ := mem_iUnion.mp hx.1 + refine mem_iUnion.mpr ⟨i, hxi, ?_⟩ + intro hxrange + obtain ⟨j, hxj⟩ := mem_iUnion.mp hxrange + apply hx.2 + refine mem_iUnion.mpr ⟨Nat.pair i j, ?_⟩ + simpa [g] using hxj + +/-- The union of two countably one-rectifiable sets is countably one-rectifiable. -/ +theorem IsCountablyOneRectifiable.union {s t : Set X} (hs : IsCountablyOneRectifiable s) + (ht : IsCountablyOneRectifiable t) : IsCountablyOneRectifiable (s ∪ t) := by + rw [show s ∪ t = (⋃ n : ℕ, if n = 0 then s else t) by + ext x + constructor + · rintro (hxs | hxt) + · exact mem_iUnion_of_mem 0 (by simpa using hxs) + · exact mem_iUnion_of_mem 1 (by simpa using hxt) + · intro hx + obtain ⟨n, hxn⟩ := mem_iUnion.mp hx + by_cases hn : n = 0 + · exact Or.inl (by simpa [hn] using hxn) + · exact Or.inr (by simpa [hn] using hxn)] + apply isCountablyOneRectifiable_iUnion + intro n + split_ifs <;> assumption + +/-- Pure one-unrectifiability is inherited by subsets. -/ +theorem IsPurelyOneUnrectifiable.mono {s t : Set X} (hs : IsPurelyOneUnrectifiable s) + (ht : t ⊆ s) : IsPurelyOneUnrectifiable t := by + intro u hu + exact measure_mono_null (inter_subset_inter_left u ht) (hs u hu) + +/-- A rectifiable subset of a purely unrectifiable set has zero Hausdorff one-measure. -/ +theorem IsPurelyOneUnrectifiable.measure_zero_of_rectifiable_subset {s t : Set X} + (hs : IsPurelyOneUnrectifiable s) (ht : IsCountablyOneRectifiable t) (hts : t ⊆ s) : + μH[1] t = 0 := by + simpa [inter_eq_right.mpr hts] using hs t ht + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/CompactAttachmentUnion.lean b/LeanPool/Besicovitch/Rectifiability/CompactAttachmentUnion.lean new file mode 100644 index 0000000000..a3dcd13718 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/CompactAttachmentUnion.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.ConvexAttachment +public import Mathlib.Topology.Algebra.InfiniteSum.ENNReal + +/-! +# The compact union of convex attachments + +If the selected holes have finite total diameter, their compact attachments accumulate only on +the compact core. Consequently the core together with all attachments is compact. +-/ + +@[expose] public section + +noncomputable section + +open Bornology Set +open scoped ENNReal Topology + +namespace LeanPool.Besicovitch + +/-- The compact core together with all convex pieces attached along selected holes. -/ +def compactAttachmentUnion (F : Set (EuclideanSpace ℝ (Fin 2))) + (chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))) : + Set (EuclideanSpace ℝ (Fin 2)) := + F ∪ ⋃ V : chosen, convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2))) + +/-- Finite total hole diameter makes the full attachment union compact. -/ +theorem isCompact_compactAttachmentUnion {mu : MeasureTheory.Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : IsCompact F) + {alpha : ℝ} (halpha : 0 < alpha) {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) + (hsum : ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) ≠ ∞) : + IsCompact (compactAttachmentUnion F chosen) := by + classical + rw [isCompact_iff_finite_subcover] + intro ι U hU_open hcover + have hcoverF : F ⊆ ⋃ i, U i := fun x hx ↦ hcover (Or.inl hx) + obtain ⟨coreCover, hcoreCover⟩ := hF.elim_finite_subcover U hU_open hcoverF + let O := ⋃ i ∈ coreCover, U i + have hO_open : IsOpen O := isOpen_biUnion fun i _ ↦ hU_open i + obtain ⟨epsilon, hepsilon, hthickening⟩ := + hF.exists_thickening_subset_open hO_open hcoreCover + let large : Set chosen := + {V | ENNReal.ofReal (epsilon / 5) ≤ Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))} + have hlarge_finite : large.Finite := by + exact ENNReal.finite_const_le_of_tsum_ne_top hsum + (ENNReal.ofReal_ne_zero_iff.mpr (by positivity)) + let : Fintype large := hlarge_finite.fintype + have hattachment_compact (V : large) : + IsCompact (convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2)))) := + isCompact_convexAttachment hF + have hattachment_cover (V : large) : + convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2))) ⊆ ⋃ i, U i := by + intro x hx + exact hcover (Or.inr (mem_iUnion_of_mem (V : chosen) hx)) + choose attachmentCover hattachmentCover using fun V : large ↦ + (hattachment_compact V).elim_finite_subcover U hU_open (hattachment_cover V) + let cover := coreCover ∪ Finset.univ.biUnion attachmentCover + refine ⟨cover, ?_⟩ + have hsmall {V : chosen} (hVsmall : V ∉ large) : + convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2))) ⊆ O := by + have hVbad := hchosen V.property + have hVbounded := isBounded_of_mem_badConvexSets halpha hVbad + have hVdiam := diam_pos_of_mem_badConvexSets halpha hVbad + have hedV : + Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) < ENNReal.ofReal (epsilon / 5) := by + exact lt_of_not_ge hVsmall + have hattachment_ediam : + Metric.ediam (convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2)))) < + ENNReal.ofReal epsilon := by + calc + Metric.ediam (convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ENNReal.ofReal 5 * Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) := + ediam_convexAttachment_le hVbounded + _ < ENNReal.ofReal 5 * ENNReal.ofReal (epsilon / 5) := + ENNReal.mul_lt_mul_right (by norm_num) ENNReal.ofReal_ne_top hedV + _ = ENNReal.ofReal epsilon := by + rw [← ENNReal.ofReal_mul (by norm_num : (0 : ℝ) ≤ 5)] + congr 1 + field_simp + intro x hx + apply hthickening + obtain ⟨f, hfV, hfF⟩ := hVbad.2.2.1 + have hfattachment : f ∈ convexAttachment F (V : Set (EuclideanSpace ℝ (Fin 2))) := + inter_subset_convexAttachment hVdiam ⟨hfF, hfV⟩ + have hdist : dist x f < epsilon := by + have hedist := (Metric.edist_le_ediam_of_mem hx hfattachment).trans_lt + hattachment_ediam + rw [edist_dist, ENNReal.ofReal_lt_ofReal_iff hepsilon] at hedist + exact hedist + rw [Metric.mem_thickening_iff] + exact ⟨f, hfF, hdist⟩ + intro x hx + rcases hx with hxF | hxattachment + · obtain ⟨i, hi, hxi⟩ := mem_iUnion₂.mp (hcoreCover hxF) + exact mem_iUnion₂.mpr ⟨i, Finset.mem_union_left _ hi, hxi⟩ + · obtain ⟨V, hxV⟩ := mem_iUnion.mp hxattachment + by_cases hVlarge : V ∈ large + · let W : large := ⟨V, hVlarge⟩ + obtain ⟨i, hi, hxi⟩ := mem_iUnion₂.mp (hattachmentCover W hxV) + apply mem_iUnion₂.mpr + refine ⟨i, ?_, hxi⟩ + exact Finset.mem_union_right _ <| Finset.mem_biUnion.mpr ⟨W, Finset.mem_univ _, hi⟩ + · obtain ⟨i, hi, hxi⟩ := mem_iUnion₂.mp (hsmall hVlarge hxV) + exact mem_iUnion₂.mpr ⟨i, Finset.mem_union_left _ hi, hxi⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/ComponentDiameter.lean b/LeanPool/Besicovitch/Rectifiability/ComponentDiameter.lean new file mode 100644 index 0000000000..3df06d7f2b --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/ComponentDiameter.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Basic +public import LeanPool.Besicovitch.Measure.UniformDensity +public import LeanPool.Besicovitch.Rectifiability.CompactAttachmentUnion +public import LeanPool.Besicovitch.Topology.ConnectedComponent +public import Mathlib.Topology.MetricSpace.HausdorffDistance + +/-! +# Diameter of the local attachment component + +The BPC witness prevents the component through the selected density point from remaining inside +the small inner ball. Any hypothetical clopen separation would be crossed by one convex +attachment. +-/ + +@[expose] public section + +noncomputable section + +open Bornology MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- The connected component through `z` in the attachment union localized to a closed ball. -/ +def localAttachmentComponent (F : Set (EuclideanSpace ℝ (Fin 2))) + (chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))) + (z : (EuclideanSpace ℝ (Fin 2))) (rho : ℝ) : Set (EuclideanSpace ℝ (Fin 2)) := + connectedComponentIn + (compactAttachmentUnion F chosen ∩ Metric.closedBall z rho) z + +/-- A BPC separation forces the local attachment component to have diameter at least +`sigma * rho / 2`. -/ +theorem sigma_mul_radius_div_two_le_diam_localAttachmentComponent + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + {F : Set (EuclideanSpace ℝ (Fin 2))} (hF : IsCompact F) {alpha tau sigma gamma : ℝ} + (halpha : 0 < alpha) (halpha_tau : alpha ≤ tau) (hsigma : 0 ≤ sigma) + (hsigma_one : sigma < 1) (hsigma_gamma : sigma < gamma) {m : ℕ} + (huniform : F ⊆ uniformDensitySet mu F gamma m) + {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) + (hselect : ∀ V ∈ badConvexSets mu F alpha, ∃ W ∈ chosen, + (V ∩ W).Nonempty ∧ Metric.diam V < 2 * Metric.diam W) + (hsum : ∑' V : chosen, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2))) ≠ ∞) + {z : (EuclideanSpace ℝ (Fin 2))} (hzF : z ∈ F) {rho delta : ℝ} (hrho : 0 < rho) + (hrho_delta : rho < delta) + (hannulus : ((Metric.ball z rho \ Metric.ball z (sigma * rho / 2)) ∩ F).Nonempty) + (hpair : ∀ e₁ e₂ : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet e₁ → MeasurableSet e₂ → + e₁.Nonempty → e₂.Nonempty → 0 < setEDist e₁ e₂ → + setEDist e₁ e₂ < ENNReal.ofReal delta → + (∀ x ∈ e₁ ∪ e₂, ∀ r : ℝ, 0 < r → r < 1 / (m + 1 : ℝ) → + ENNReal.ofReal (2 * sigma * r) < mu (Metric.ball x r)) → + ∃ v : Set (EuclideanSpace ℝ (Fin 2)), + IsOpen v ∧ (v ∩ e₁).Nonempty ∧ (v ∩ e₂).Nonempty ∧ + ENNReal.ofReal tau * Metric.ediam v < mu (v \ (e₁ ∪ e₂))) : + sigma * rho / 2 ≤ Metric.diam (localAttachmentComponent F chosen z rho) := by + let Q := compactAttachmentUnion F chosen + let C := localAttachmentComponent F chosen z rho + have hQ : IsCompact Q := isCompact_compactAttachmentUnion hF halpha hchosen hsum + have hzQ : z ∈ Q := Or.inl hzF + have hR_nonneg : 0 ≤ sigma * rho / 2 := by positivity + have hR_rho : sigma * rho / 2 < rho := by nlinarith + by_contra hdiam + have hdiam_lt : Metric.diam C < sigma * rho / 2 := lt_of_not_ge hdiam + have hzK : z ∈ Q ∩ Metric.closedBall z rho := + ⟨hzQ, Metric.mem_closedBall_self hrho.le⟩ + have hzC : z ∈ C := mem_connectedComponentIn hzK + have hC_bounded : IsBounded C := + (hQ.inter_right Metric.isClosed_closedBall).isBounded.subset + (connectedComponentIn_subset _ _) + have hC_inner : C ⊆ Metric.ball z (sigma * rho / 2) := by + intro x hxC + rw [Metric.mem_ball] + exact (Metric.dist_le_diam_of_mem hC_bounded hxC hzC).trans_lt hdiam_lt + obtain ⟨H, hCH, hHQ, hH_clopen, hH_compact⟩ := + exists_isClopenWithin_between_connectedComponentIn_closedBall hQ hzQ hR_nonneg + hR_rho hC_inner + let e₁ := F ∩ H + let e₂ := F \ H + have hzH : z ∈ H := hCH hzC + have he₁_nonempty : e₁.Nonempty := ⟨z, hzF, hzH⟩ + obtain ⟨w, ⟨hw_outer, hw_inner⟩, hwF⟩ := hannulus + have hwH : w ∉ H := fun hw ↦ hw_inner (hHQ hw).2 + have he₂_nonempty : e₂.Nonempty := ⟨w, hwF, hwH⟩ + have he₁_compact : IsCompact e₁ := hF.inter_right hH_compact.isClosed + rcases isOpen_induced_iff.mp hH_clopen.isOpen with ⟨O, hO_open, hO_preimage⟩ + have he₂_eq : e₂ = F \ O := by + ext x + constructor + · intro hx + refine ⟨hx.1, ?_⟩ + intro hxO + apply hx.2 + have hxQ : x ∈ Q := Or.inl hx.1 + have : (⟨x, hxQ⟩ : Q) ∈ Subtype.val ⁻¹' O := hxO + have hxHsub : (⟨x, hxQ⟩ : Q) ∈ Subtype.val ⁻¹' H := hO_preimage ▸ this + exact hxHsub + · intro hx + refine ⟨hx.1, ?_⟩ + intro hxH + have hxQ : x ∈ Q := Or.inl hx.1 + have : (⟨x, hxQ⟩ : Q) ∈ Subtype.val ⁻¹' H := hxH + have hxOsub : (⟨x, hxQ⟩ : Q) ∈ Subtype.val ⁻¹' O := hO_preimage.symm ▸ this + have hxO : x ∈ O := hxOsub + exact hx.2 hxO + have he₂_compact : IsCompact e₂ := by + rw [he₂_eq] + exact hF.diff hO_open + have he_disjoint : Disjoint e₁ e₂ := by + rw [disjoint_left] + intro x hx₁ hx₂ + exact hx₂.2 hx₁.2 + obtain ⟨separation, hseparation_pos, hseparation⟩ := + Metric.exists_pos_forall_lt_edist he₁_compact he₂_compact.isClosed he_disjoint + have hsetEDist_lower : (separation : ℝ≥0∞) ≤ setEDist e₁ e₂ := by + refine le_iInf fun x ↦ le_iInf fun hx ↦ le_iInf fun y ↦ le_iInf fun hy ↦ ?_ + exact (hseparation x hx y hy).le + have hsetEDist_pos : 0 < setEDist e₁ e₂ := + (ENNReal.coe_pos.mpr hseparation_pos).trans_le hsetEDist_lower + have hz_e₁ : z ∈ e₁ := ⟨hzF, hzH⟩ + have hw_e₂ : w ∈ e₂ := ⟨hwF, hwH⟩ + have hzw : dist z w < rho := by simpa [dist_comm] using hw_outer + have hsetEDist_delta : setEDist e₁ e₂ < ENNReal.ofReal delta := by + calc + setEDist e₁ e₂ ≤ edist z w := setEDist_le_edist_of_mem hz_e₁ hw_e₂ + _ < ENNReal.ofReal rho := by + rw [edist_dist, ENNReal.ofReal_lt_ofReal_iff hrho] + exact hzw + _ < ENNReal.ofReal delta := by + exact (ENNReal.ofReal_lt_ofReal_iff (hrho.trans hrho_delta)).2 hrho_delta + have he_partition : e₁ ∪ e₂ = F := by + ext x + simp only [e₁, e₂, mem_union, mem_inter_iff, mem_sdiff] + tauto + have he₁_measurable : MeasurableSet e₁ := he₁_compact.isClosed.measurableSet + have he₂_measurable : MeasurableSet e₂ := he₂_compact.isClosed.measurableSet + have hdensity : ∀ x ∈ e₁ ∪ e₂, ∀ r : ℝ, 0 < r → r < 1 / (m + 1 : ℝ) → + ENNReal.ofReal (2 * sigma * r) < mu (Metric.ball x r) := by + intro x hx r hr hrscale + apply uniformDensitySet_ball_measure_gt hsigma hsigma_gamma + · exact huniform (he_partition ▸ hx) + · exact hr + · exact hrscale + obtain ⟨U, hU_open, hUe₁, hUe₂, hU_leak⟩ := + hpair e₁ e₂ he₁_measurable he₂_measurable he₁_nonempty he₂_nonempty + hsetEDist_pos hsetEDist_delta hdensity + have hU_leak_F : ENNReal.ofReal tau * Metric.ediam U < mu (U \ F) := by + rwa [he_partition] at hU_leak + have hUF : (U ∩ F).Nonempty := hUe₁.mono <| by + intro x hx + exact ⟨hx.1, hx.2.1⟩ + let V := openConvexHull U + have hV_bad : V ∈ badConvexSets mu F alpha := + openConvexHull_mem_badConvexSets halpha_tau hU_open hUF hU_leak_F + obtain ⟨W, hWchosen, hVW, hdiamVW⟩ := hselect V hV_bad + have hV_bounded := isBounded_of_mem_badConvexSets halpha hV_bad + have hV_subset : V ⊆ diameterThickening 2 W := + subset_diameterThickening_of_inter_nonempty hV_bounded hVW hdiamVW + let A := convexAttachment F W + have hA_subset_Q : A ⊆ Q := by + intro x hx + exact Or.inr (mem_iUnion_of_mem ⟨W, hWchosen⟩ hx) + have hU_subset_V : U ⊆ V := subset_openConvexHull hU_open + have hUF_subset_A : U ∩ F ⊆ A := by + intro x hx + apply subset_closure + apply subset_convexHull ℝ + exact ⟨hx.2, hV_subset (hU_subset_V hx.1)⟩ + obtain ⟨x₁, hx₁U, hx₁e₁⟩ := hUe₁ + have hx₁A : x₁ ∈ A := hUF_subset_A ⟨hx₁U, hx₁e₁.1⟩ + have hx₁H : x₁ ∈ H := hx₁e₁.2 + obtain ⟨x₂, hx₂U, hx₂e₂⟩ := hUe₂ + have hx₂A : x₂ ∈ A := hUF_subset_A ⟨hx₂U, hx₂e₂.1⟩ + have hx₂H : x₂ ∉ H := hx₂e₂.2 + have hA_preconnected : IsPreconnected A := (convex_convexAttachment F W).isPreconnected + have hA_preconnected_Q : IsPreconnected ((↑) ⁻¹' A : Set Q) := + LeanPool.Besicovitch.IsPreconnected.preimage_subtype_of_subset hA_preconnected hA_subset_Q + have hA_meets_H : (((↑) ⁻¹' A : Set Q) ∩ (↑) ⁻¹' H).Nonempty := by + let xQ : Q := ⟨x₁, hA_subset_Q hx₁A⟩ + exact ⟨xQ, hx₁A, hx₁H⟩ + have hA_subset_H := hA_preconnected_Q.subset_isClopen hH_clopen hA_meets_H + let x₂Q : Q := ⟨x₂, hA_subset_Q hx₂A⟩ + have hx₂A_Q : x₂Q ∈ ((↑) ⁻¹' A : Set Q) := hx₂A + exact hx₂H (hA_subset_H hx₂A_Q) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/Continuum.lean b/LeanPool/Besicovitch/Rectifiability/Continuum.lean new file mode 100644 index 0000000000..e1fc82bad7 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/Continuum.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.MeasureTheory.Measure.Hausdorff +public import Mathlib.Topology.Order.IntermediateValue + +/-! +# Hausdorff measure of connected sets + +A preconnected set has one-dimensional Hausdorff measure at least its extended diameter. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped MeasureTheory + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- The Hausdorff one-measure of a preconnected set bounds the distance between its points. -/ +theorem edist_le_hausdorffMeasure_one_of_isPreconnected {s : Set X} (hs : IsPreconnected s) + {x y : X} (hx : x ∈ s) (hy : y ∈ s) : edist x y ≤ μH[1] s := by + let f : X → ℝ := fun z ↦ dist x z + have hf : LipschitzWith 1 f := LipschitzWith.dist_right x + have hIcc : Icc 0 (dist x y) ⊆ f '' s := by + simpa [f] using hs.intermediate_value hx hy hf.continuous.continuousOn + calc + edist x y = μH[1] (Icc 0 (dist x y)) := by + rw [hausdorffMeasure_real, Real.volume_Icc] + simp [edist_dist] + _ ≤ μH[1] (f '' s) := measure_mono hIcc + _ ≤ μH[1] s := by simpa using hf.hausdorffMeasure_image_le (d := 1) zero_le_one s + +/-- The Hausdorff one-measure of a preconnected set bounds its extended diameter. -/ +theorem ediam_le_hausdorffMeasure_one_of_isPreconnected {s : Set X} (hs : IsPreconnected s) : + Metric.ediam s ≤ μH[1] s := by + exact Metric.ediam_le fun _ hx _ hy ↦ + edist_le_hausdorffMeasure_one_of_isPreconnected hs hx hy + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/ContinuumSurgery.lean b/LeanPool/Besicovitch/Rectifiability/ContinuumSurgery.lean new file mode 100644 index 0000000000..4ba0251e24 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/ContinuumSurgery.lean @@ -0,0 +1,1354 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.Continuum +public import LeanPool.Besicovitch.Statement +public import Mathlib.Analysis.Convex.Hull +import LeanPool.Besicovitch.Topology.ConnectedComponent +import LeanPool.Besicovitch.Rectifiability.HoleMerging +import Mathlib.Topology.MetricSpace.Closeds +import Mathlib.Analysis.Convex.Caratheodory + +/-! +# Surgery on continua + +This file develops the continuum-surgery argument for countably many open convex holes. +-/ + +@[expose] public section + +noncomputable section + +open Bornology MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- A nonempty compact set in a metric space contains two points realizing its extended diameter. -/ +theorem _root_.IsCompact.exists_edist_eq_ediam {X : Type*} [MetricSpace X] {C : Set X} + (hC : IsCompact C) (hCne : C.Nonempty) : + ∃ x ∈ C, ∃ y ∈ C, edist x y = Metric.ediam C := by + obtain ⟨p, hpC, hpmax⟩ := (hC.prod hC).exists_isMaxOn (hCne.prod hCne) + continuous_dist.continuousOn + have hdist : dist p.1 p.2 = Metric.diam C := by + apply le_antisymm (Metric.dist_le_diam_of_mem hC.isBounded hpC.1 hpC.2) + apply Metric.diam_le_of_forall_dist_le dist_nonneg + intro x hx y hy + exact @hpmax (x, y) ⟨hx, hy⟩ + exact ⟨p.1, hpC.1, p.2, hpC.2, by + rw [edist_dist, hdist, Metric.diam, + ENNReal.ofReal_toReal hC.isBounded.ediam_ne_top]⟩ + +/-- The two-segment bridge through an interior point of a convex hole. -/ +def brokenSegment (a c b : (EuclideanSpace ℝ (Fin 2))) : Set (EuclideanSpace ℝ (Fin 2)) := + segment ℝ a c ∪ segment ℝ c b + +/-- A one-hole surgery preserves a continuum's diameter and changes it only inside the hole. -/ +def IsOneHoleSurgery (K U : Set (EuclideanSpace ℝ (Fin 2))) + (x y : (EuclideanSpace ℝ (Fin 2))) (epsilon : ℝ) + (D bridge : Set (EuclideanSpace ℝ (Fin 2))) : Prop := + IsCompact D ∧ IsConnected D ∧ x ∈ D ∧ y ∈ D ∧ + Metric.ediam D = Metric.ediam K ∧ D ⊆ convexHull ℝ K ∧ + D \ U ⊆ K \ U ∧ D ∩ U ⊆ bridge ∧ + bridge ⊆ D ∧ IsCompact bridge ∧ IsPreconnected bridge ∧ + bridge ⊆ closure U ∧ + (bridge.Nonempty → (D ∩ (bridge \ U)).Nonempty) ∧ + μH[1] bridge < Metric.ediam U + ENNReal.ofReal epsilon + +private theorem isCompact_brokenSegment (a c b : (EuclideanSpace ℝ (Fin 2))) : + IsCompact (brokenSegment a c b) := by + have hsegment (u v : (EuclideanSpace ℝ (Fin 2))) : IsCompact (segment ℝ u v) := by + rw [← affineSegment_eq_segment] + exact isCompact_Icc.image (by fun_prop) + exact (hsegment a c).union (hsegment c b) + +private theorem isConnected_brokenSegment (a c b : (EuclideanSpace ℝ (Fin 2))) : + IsConnected (brokenSegment a c b) := by + refine ⟨⟨c, Or.inl (right_mem_segment ℝ a c)⟩, ?_⟩ + exact IsPreconnected.union c (right_mem_segment ℝ a c) (left_mem_segment ℝ c b) + (convex_segment a c).isPreconnected (convex_segment c b).isPreconnected + +private theorem brokenSegment_subset_convexHull + {K : Set (EuclideanSpace ℝ (Fin 2))} + {a c b : (EuclideanSpace ℝ (Fin 2))} + (ha : a ∈ K) (hc : c ∈ K) (hb : b ∈ K) : + brokenSegment a c b ⊆ convexHull ℝ K := by + exact union_subset (segment_subset_convexHull ha hc) (segment_subset_convexHull hc hb) + +private theorem brokenSegment_sdiff_subset_endpoints + {U : Set (EuclideanSpace ℝ (Fin 2))} (hUopen : IsOpen U) + (hUconvex : Convex ℝ U) {a c b : (EuclideanSpace ℝ (Fin 2))} + (ha : a ∈ closure U) (hc : c ∈ U) + (hb : b ∈ closure U) : brokenSegment a c b \ U ⊆ {a, b} := by + have hcinterior : c ∈ interior U := by rwa [hUopen.interior_eq] + have hac : openSegment ℝ a c ⊆ U := by + simpa only [hUopen.interior_eq] using + hUconvex.openSegment_closure_interior_subset_interior ha hcinterior + have hcb : openSegment ℝ c b ⊆ U := by + simpa only [hUopen.interior_eq] using + hUconvex.openSegment_interior_closure_subset_interior hcinterior hb + rintro z ⟨hz, hzU⟩ + rcases hz with hz | hz + · rw [← insert_endpoints_openSegment] at hz + rcases hz with rfl | rfl | hz + · exact mem_insert _ _ + · exact (hzU hc).elim + · exact (hzU (hac hz)).elim + · rw [← insert_endpoints_openSegment] at hz + rcases hz with rfl | rfl | hz + · exact (hzU hc).elim + · exact mem_insert_iff.mpr (Or.inr (mem_singleton _)) + · exact (hzU (hcb hz)).elim + +private theorem hausdorffMeasure_brokenSegment_lt + {U : Set (EuclideanSpace ℝ (Fin 2))} (hUbounded : IsBounded U) + {a c b : (EuclideanSpace ℝ (Fin 2))} + (ha : a ∈ closure U) (hb : b ∈ closure U) {epsilon : ℝ} + (hepsilon : 0 < epsilon) (hac : dist a c < epsilon / 2) : + μH[1] (brokenSegment a c b) < Metric.ediam U + ENNReal.ofReal epsilon := by + have hab : dist a b ≤ Metric.diam U := by + rw [← Metric.diam_closure] + exact Metric.dist_le_diam_of_mem hUbounded.closure ha hb + have hdist : dist a c + dist c b < Metric.diam U + epsilon := by + calc + dist a c + dist c b ≤ dist a c + (dist c a + dist a b) := by + gcongr + exact dist_triangle _ _ _ + _ = 2 * dist a c + dist a b := by rw [dist_comm c a]; ring + _ < epsilon + dist a b := by linarith + _ ≤ epsilon + Metric.diam U := by gcongr + _ = Metric.diam U + epsilon := add_comm _ _ + calc + μH[1] (brokenSegment a c b) ≤ μH[1] (segment ℝ a c) + μH[1] (segment ℝ c b) := + measure_union_le _ _ + _ = ENNReal.ofReal (dist a c + dist c b) := by + rw [hausdorffMeasure_segment, hausdorffMeasure_segment, edist_dist, edist_dist, + ENNReal.ofReal_add dist_nonneg dist_nonneg] + _ < ENNReal.ofReal (Metric.diam U + epsilon) := by + exact (ENNReal.ofReal_lt_ofReal_iff (by positivity)).2 hdist + _ = Metric.ediam U + ENNReal.ofReal epsilon := by + rw [ENNReal.ofReal_add Metric.diam_nonneg hepsilon.le, Metric.diam, + ENNReal.ofReal_toReal hUbounded.ediam_ne_top] + +private theorem isCompact_connectedComponentIn_of_isCompact {F : Set (EuclideanSpace ℝ (Fin 2))} + (hF : IsCompact F) {x : (EuclideanSpace ℝ (Fin 2))} (hx : x ∈ F) : + IsCompact (connectedComponentIn F x) := by + let : CompactSpace F := isCompact_iff_compactSpace.mp hF + rw [connectedComponentIn_eq_image hx] + exact isClosed_connectedComponent.isCompact.image continuous_subtype_val + +private theorem connectedComponentIn_inter_closure_inter_of_not_mem + {K U : Set (EuclideanSpace ℝ (Fin 2))} (hKcompact : IsCompact K) (hKconnected : IsConnected K) + (hU : IsOpen U) {x y : (EuclideanSpace ℝ (Fin 2))} + (hxK : x ∈ K) (hxU : x ∉ U) (hyK : y ∈ K) + (hycomponent : y ∉ connectedComponentIn (K \ U) x) : + (connectedComponentIn (K \ U) x ∩ closure (K ∩ U)).Nonempty := by + classical + by_contra hnonempty + have hinter : connectedComponentIn (K \ U) x ∩ closure (K ∩ U) = ∅ := + not_nonempty_iff_eq_empty.mp hnonempty + let S := K \ U + have hScompact : IsCompact S := hKcompact.inter_right hU.isClosed_compl + have hxS : x ∈ S := ⟨hxK, hxU⟩ + let xS : S := ⟨x, hxS⟩ + let O : Set (EuclideanSpace ℝ (Fin 2)) := (closure (K ∩ U))ᶜ ∩ {y}ᶜ + have hOopen : IsOpen O := isOpen_compl_iff.mpr isClosed_closure |>.inter isOpen_compl_singleton + have hcomponent_O : connectedComponent xS ⊆ ((↑) ⁻¹' O : Set S) := by + intro z hz + have hzcomponent : (z : (EuclideanSpace ℝ (Fin 2))) ∈ connectedComponentIn S x := by + rw [connectedComponentIn_eq_image hxS] + exact ⟨z, hz, rfl⟩ + have hzclosure : (z : (EuclideanSpace ℝ (Fin 2))) ∉ closure (K ∩ U) := by + intro hz + have : (z : (EuclideanSpace ℝ (Fin 2))) ∈ + connectedComponentIn (K \ U) x ∩ closure (K ∩ U) := + ⟨hzcomponent, hz⟩ + rw [hinter] at this + exact this + have hzy : (z : (EuclideanSpace ℝ (Fin 2))) ≠ y := by + intro hzy + apply hycomponent + simpa [S, hzy] using hzcomponent + exact ⟨hzclosure, hzy⟩ + let : CompactSpace S := isCompact_iff_compactSpace.mp hScompact + obtain ⟨H, hHclopen, hcomponent_H, hH_O⟩ := + exists_isClopen_between_connectedComponent + (hOopen.preimage continuous_subtype_val) hcomponent_O + let Hplane : Set (EuclideanSpace ℝ (Fin 2)) := Subtype.val '' H + have hHplane_compact : IsCompact Hplane := + hHclopen.isClosed.isCompact.image continuous_subtype_val + have hHplane_O : Hplane ⊆ O := by + rintro z ⟨w, hwH, rfl⟩ + exact hH_O hwH + have hHplane_clopen_in_K : IsClopen ((↑) ⁻¹' Hplane : Set K) := by + constructor + · exact hHplane_compact.isClosed.preimage continuous_subtype_val + · rcases isOpen_induced_iff.mp hHclopen.isOpen with ⟨V, hVopen, hpreimage⟩ + apply isOpen_induced_iff.mpr + refine ⟨V ∩ O, hVopen.inter hOopen, ?_⟩ + ext z + constructor + · rintro ⟨hzV, hzO⟩ + have hzU : (z : (EuclideanSpace ℝ (Fin 2))) ∉ U := by + intro hzU + exact hzO.1 (subset_closure ⟨z.property, hzU⟩) + let w : S := ⟨z, z.property, hzU⟩ + have hwH : w ∈ H := by + rw [← hpreimage] + exact hzV + exact ⟨w, hwH, rfl⟩ + · rintro ⟨w, hwH, hwz⟩ + have hwV : (w : (EuclideanSpace ℝ (Fin 2))) ∈ V := by + change w ∈ Subtype.val ⁻¹' V + rw [hpreimage] + exact hwH + have hw : (w : (EuclideanSpace ℝ (Fin 2))) ∈ V ∩ O := + ⟨hwV, hHplane_O ⟨w, hwH, rfl⟩⟩ + change (z : (EuclideanSpace ℝ (Fin 2))) ∈ V ∩ O + exact hwz ▸ hw + let xK : K := ⟨x, hxK⟩ + have hxHplane : xK ∈ ((↑) ⁻¹' Hplane : Set K) := by + refine ⟨xS, hcomponent_H ?_, rfl⟩ + exact mem_connectedComponent + let yK : K := ⟨y, hyK⟩ + have hyHplane : yK ∉ ((↑) ⁻¹' Hplane : Set K) := by + intro hyH + exact (hHplane_O hyH).2 rfl + let : PreconnectedSpace K := Subtype.preconnectedSpace hKconnected.isPreconnected + exact hyHplane (isPreconnected_univ.subset_isClopen hHplane_clopen_in_K + ⟨xK, mem_univ _, hxHplane⟩ <| mem_univ yK) + +private theorem isOneHoleSurgery_of_connected_subset + {K U A : Set (EuclideanSpace ℝ (Fin 2))} + {x y : (EuclideanSpace ℝ (Fin 2))} + (hxy : edist x y = Metric.ediam K) (hAcompact : IsCompact A) + (hAconnected : IsConnected A) (hxA : x ∈ A) (hyA : y ∈ A) + (hAKU : A ⊆ K \ U) {epsilon : ℝ} (hepsilon : 0 < epsilon) : + IsOneHoleSurgery K U x y epsilon A ∅ := by + have hAconvexHull : A ⊆ convexHull ℝ K := + hAKU.trans <| (inter_subset_left.trans <| subset_convexHull ℝ K) + have hediam : Metric.ediam A = Metric.ediam K := by + apply le_antisymm (Metric.ediam_mono hAconvexHull |>.trans_eq (convexHull_ediam K)) + rw [← hxy] + exact Metric.edist_le_ediam_of_mem hxA hyA + refine ⟨hAcompact, hAconnected, hxA, hyA, hediam, hAconvexHull, + ?_, ?_, empty_subset _, isCompact_empty, isPreconnected_empty, empty_subset _, ?_, ?_⟩ + · exact fun _ hz ↦ hAKU hz.1 + · rintro z ⟨hzA, hzU⟩ + exact ((hAKU hzA).2 hzU).elim + · simp + · rw [measure_empty] + positivity + +private theorem isOneHoleSurgery_of_component_union_bridge + {K U A bridge : Set (EuclideanSpace ℝ (Fin 2))} + {x y q : (EuclideanSpace ℝ (Fin 2))} {epsilon : ℝ} + (hxy : edist x y = Metric.ediam K) + (hAcompact : IsCompact A) (hAconnected : IsConnected A) (hyA : y ∈ A) + (hqA : q ∈ A) (hAKU : A ⊆ K \ U) (hbridgeCompact : IsCompact bridge) + (hbridgeConnected : IsConnected bridge) (hxbridge : x ∈ bridge) (hqbridge : q ∈ bridge) + (hbridgeHull : bridge ⊆ convexHull ℝ K) (hbridgeClosure : bridge ⊆ closure U) + (hbridgeSdiff : bridge \ U ⊆ K \ U) + (hbridgeMeasure : μH[1] bridge < Metric.ediam U + ENNReal.ofReal epsilon) : + IsOneHoleSurgery K U x y epsilon (A ∪ bridge) bridge := by + have hconnected : IsConnected (A ∪ bridge) := + IsConnected.union ⟨q, hqA, hqbridge⟩ hAconnected hbridgeConnected + have hsubset : A ∪ bridge ⊆ convexHull ℝ K := + union_subset (hAKU.trans <| inter_subset_left.trans <| subset_convexHull ℝ K) hbridgeHull + have hediam : Metric.ediam (A ∪ bridge) = Metric.ediam K := by + apply le_antisymm (Metric.ediam_mono hsubset |>.trans_eq (convexHull_ediam K)) + rw [← hxy] + exact Metric.edist_le_ediam_of_mem (Or.inr hxbridge) (Or.inl hyA) + refine ⟨hAcompact.union hbridgeCompact, hconnected, Or.inr hxbridge, Or.inl hyA, + hediam, hsubset, ?_, ?_, ?_, hbridgeCompact, hbridgeConnected.2, hbridgeClosure, + fun _ ↦ ⟨q, Or.inl hqA, hqbridge, (hAKU hqA).2⟩, hbridgeMeasure⟩ + · rintro z ⟨hzA | hzbridge, hzU⟩ + · exact hAKU hzA + · exact hbridgeSdiff ⟨hzbridge, hzU⟩ + · rintro z ⟨hzA | hzbridge, hzU⟩ + · exact (hAKU hzA).2 hzU |>.elim + · exact hzbridge + · exact fun _ hz ↦ Or.inr hz + +private theorem isOneHoleSurgery_of_two_components + {K U A B bridge : Set (EuclideanSpace ℝ (Fin 2))} + {x y a b : (EuclideanSpace ℝ (Fin 2))} {epsilon : ℝ} + (hxy : edist x y = Metric.ediam K) + (hAcompact : IsCompact A) (hAconnected : IsConnected A) (hxA : x ∈ A) (haA : a ∈ A) + (hBcompact : IsCompact B) (hBconnected : IsConnected B) (hyB : y ∈ B) (hbB : b ∈ B) + (hAKU : A ⊆ K \ U) (hBKU : B ⊆ K \ U) (hbridgeCompact : IsCompact bridge) + (hbridgeConnected : IsConnected bridge) (habridge : a ∈ bridge) (hbbridge : b ∈ bridge) + (hbridgeHull : bridge ⊆ convexHull ℝ K) (hbridgeClosure : bridge ⊆ closure U) + (hbridgeSdiff : bridge \ U ⊆ K \ U) + (hbridgeMeasure : μH[1] bridge < Metric.ediam U + ENNReal.ofReal epsilon) : + IsOneHoleSurgery K U x y epsilon ((A ∪ bridge) ∪ B) bridge := by + have hAbridge : IsConnected (A ∪ bridge) := + IsConnected.union ⟨a, haA, habridge⟩ hAconnected hbridgeConnected + have hconnected : IsConnected ((A ∪ bridge) ∪ B) := + IsConnected.union ⟨b, Or.inr hbbridge, hbB⟩ hAbridge hBconnected + have hsubset : (A ∪ bridge) ∪ B ⊆ convexHull ℝ K := by + exact union_subset (union_subset + (hAKU.trans <| inter_subset_left.trans <| subset_convexHull ℝ K) hbridgeHull) + (hBKU.trans <| inter_subset_left.trans <| subset_convexHull ℝ K) + have hediam : Metric.ediam ((A ∪ bridge) ∪ B) = Metric.ediam K := by + apply le_antisymm (Metric.ediam_mono hsubset |>.trans_eq (convexHull_ediam K)) + rw [← hxy] + exact Metric.edist_le_ediam_of_mem (Or.inl (Or.inl hxA)) (Or.inr hyB) + refine ⟨(hAcompact.union hbridgeCompact).union hBcompact, hconnected, + Or.inl (Or.inl hxA), Or.inr hyB, hediam, hsubset, ?_, ?_, ?_, hbridgeCompact, + hbridgeConnected.2, hbridgeClosure, + fun _ ↦ ⟨a, Or.inl (Or.inl haA), habridge, (hAKU haA).2⟩, + hbridgeMeasure⟩ + · rintro z ⟨(hzA | hzbridge) | hzB, hzU⟩ + · exact hAKU hzA + · exact hbridgeSdiff ⟨hzbridge, hzU⟩ + · exact hBKU hzB + · rintro z ⟨(hzA | hzbridge) | hzB, hzU⟩ + · exact (hAKU hzA).2 hzU |>.elim + · exact hzbridge + · exact (hBKU hzB).2 hzU |>.elim + · exact fun _ hz ↦ Or.inl (Or.inr hz) + +private theorem IsOneHoleSurgery.swap + {K U D bridge : Set (EuclideanSpace ℝ (Fin 2))} + {x y : (EuclideanSpace ℝ (Fin 2))} + {epsilon : ℝ} (h : IsOneHoleSurgery K U x y epsilon D bridge) : + IsOneHoleSurgery K U y x epsilon D bridge := by + rcases h with ⟨hDcompact, hDconnected, hxD, hyD, hdiam, hDhull, + hDoutside, hDinside, hbridgeD, hbridgeCompact, hbridgeConnected, hbridgeClosure, + hbridgeAnchor, hbridgeMeasure⟩ + exact ⟨hDcompact, hDconnected, hyD, hxD, hdiam, hDhull, + hDoutside, hDinside, hbridgeD, hbridgeCompact, hbridgeConnected, hbridgeClosure, + hbridgeAnchor, hbridgeMeasure⟩ + +private theorem exists_oneHoleSurgery_of_left_mem + {K U : Set (EuclideanSpace ℝ (Fin 2))} (hKcompact : IsCompact K) (hKconnected : IsConnected K) + {x y : (EuclideanSpace ℝ (Fin 2))} (hxK : x ∈ K) (hyK : y ∈ K) + (hxy : edist x y = Metric.ediam K) (hUopen : IsOpen U) + (hUconvex : Convex ℝ U) (hUbounded : IsBounded U) (hxU : x ∈ U) + (hyU : y ∉ U) {epsilon : ℝ} (hepsilon : 0 < epsilon) : + ∃ D bridge, IsOneHoleSurgery K U x y epsilon D bridge := by + let B := connectedComponentIn (K \ U) y + have hyKU : y ∈ K \ U := ⟨hyK, hyU⟩ + have hyB : y ∈ B := mem_connectedComponentIn hyKU + have hxB : x ∉ B := by + intro hxB + exact (connectedComponentIn_subset (K \ U) y hxB).2 hxU + obtain ⟨b, hbB, hbClosure⟩ := + connectedComponentIn_inter_closure_inter_of_not_mem hKcompact hKconnected + hUopen hyK hyU hxK hxB + have hBKU : B ⊆ K \ U := connectedComponentIn_subset _ _ + have hbKU : b ∈ K \ U := hBKU hbB + have hbClosureU : b ∈ closure U := closure_mono inter_subset_right hbClosure + let bridge := brokenSegment x x b + have hxbridge : x ∈ bridge := Or.inl (left_mem_segment ℝ x x) + have hbbridge : b ∈ bridge := Or.inr (right_mem_segment ℝ x b) + have hbridgeSdiff : bridge \ U ⊆ K \ U := by + intro z hz + have hzxb : z ∈ ({x, b} : Set (EuclideanSpace ℝ (Fin 2))) := + brokenSegment_sdiff_subset_endpoints hUopen hUconvex + (subset_closure hxU) hxU hbClosureU hz + rcases hzxb with rfl | hzxb + · exact (hz.2 hxU).elim + · simpa only [mem_singleton_iff] using hzxb ▸ hbKU + refine ⟨B ∪ bridge, bridge, + isOneHoleSurgery_of_component_union_bridge hxy + (isCompact_connectedComponentIn (hKcompact.inter_right hUopen.isClosed_compl) y) + ((isConnected_connectedComponentIn_iff).2 hyKU) hyB hbB hBKU + (isCompact_brokenSegment x x b) (isConnected_brokenSegment x x b) + hxbridge hbbridge ?_ ?_ hbridgeSdiff ?_⟩ + · exact brokenSegment_subset_convexHull hxK hxK hbKU.1 + · exact union_subset (hUconvex.closure.segment_subset + (subset_closure hxU) (subset_closure hxU)) + (hUconvex.closure.segment_subset (subset_closure hxU) hbClosureU) + · exact hausdorffMeasure_brokenSegment_lt hUbounded + (subset_closure hxU) hbClosureU hepsilon (by simp [hepsilon]) + +/-- A continuum can be surgically changed inside one open convex hole while preserving a +diameter-realizing pair. The bridge inserted in the hole has length at most the hole diameter, +up to an arbitrarily small error. -/ +theorem exists_oneHoleSurgery + {K U : Set (EuclideanSpace ℝ (Fin 2))} (hKcompact : IsCompact K) (hKconnected : IsConnected K) + {x y : (EuclideanSpace ℝ (Fin 2))} (hxK : x ∈ K) (hyK : y ∈ K) + (hxy : edist x y = Metric.ediam K) (hUopen : IsOpen U) + (hUconvex : Convex ℝ U) (hUbounded : IsBounded U) + (hUdiam : Metric.ediam U < Metric.ediam K) {epsilon : ℝ} (hepsilon : 0 < epsilon) : + ∃ D bridge, IsOneHoleSurgery K U x y epsilon D bridge := by + by_cases hxU : x ∈ U + · have hyU : y ∉ U := by + intro hyU + have hxyU : edist x y ≤ Metric.ediam U := + Metric.edist_le_ediam_of_mem hxU hyU + exact (not_lt_of_ge (hxy.symm ▸ hxyU)) hUdiam + exact exists_oneHoleSurgery_of_left_mem hKcompact hKconnected hxK hyK hxy + hUopen hUconvex hUbounded hxU hyU hepsilon + · by_cases hyU : y ∈ U + · obtain ⟨D, bridge, hD⟩ := + exists_oneHoleSurgery_of_left_mem hKcompact hKconnected hyK hxK + (edist_comm x y ▸ hxy) hUopen hUconvex hUbounded hyU hxU hepsilon + exact ⟨D, bridge, hD.swap⟩ + · let A := connectedComponentIn (K \ U) x + let B := connectedComponentIn (K \ U) y + have hxKU : x ∈ K \ U := ⟨hxK, hxU⟩ + have hyKU : y ∈ K \ U := ⟨hyK, hyU⟩ + have hxA : x ∈ A := mem_connectedComponentIn hxKU + have hyB : y ∈ B := mem_connectedComponentIn hyKU + by_cases hyA : y ∈ A + · exact ⟨A, ∅, isOneHoleSurgery_of_connected_subset hxy + (isCompact_connectedComponentIn (hKcompact.inter_right hUopen.isClosed_compl) x) + ((isConnected_connectedComponentIn_iff).2 hxKU) hxA hyA + (connectedComponentIn_subset _ _) hepsilon⟩ + · have hxB : x ∉ B := by + intro hxB + have hBA : B = A := connectedComponentIn_eq hxB + exact hyA (hBA ▸ hyB) + obtain ⟨a, haA, haClosure⟩ := + connectedComponentIn_inter_closure_inter_of_not_mem hKcompact hKconnected + hUopen hxK hxU hyK hyA + obtain ⟨b, hbB, hbClosure⟩ := + connectedComponentIn_inter_closure_inter_of_not_mem hKcompact hKconnected + hUopen hyK hyU hxK hxB + have hAKU : A ⊆ K \ U := connectedComponentIn_subset _ _ + have hBKU : B ⊆ K \ U := connectedComponentIn_subset _ _ + have haKU : a ∈ K \ U := hAKU haA + have hbKU : b ∈ K \ U := hBKU hbB + have haClosureU : a ∈ closure U := closure_mono inter_subset_right haClosure + have hbClosureU : b ∈ closure U := closure_mono inter_subset_right hbClosure + obtain ⟨c, hcKU, hac⟩ := Metric.mem_closure_iff.mp haClosure + (epsilon / 2) (half_pos hepsilon) + let bridge := brokenSegment a c b + have habridge : a ∈ bridge := Or.inl (left_mem_segment ℝ a c) + have hbbridge : b ∈ bridge := Or.inr (right_mem_segment ℝ c b) + have hbridgeSdiff : bridge \ U ⊆ K \ U := by + intro z hz + have hzab : z ∈ ({a, b} : Set (EuclideanSpace ℝ (Fin 2))) := + brokenSegment_sdiff_subset_endpoints hUopen hUconvex + haClosureU hcKU.2 hbClosureU hz + rcases hzab with rfl | hzab + · exact haKU + · simpa only [mem_singleton_iff] using hzab ▸ hbKU + refine ⟨(A ∪ bridge) ∪ B, bridge, + isOneHoleSurgery_of_two_components hxy + (isCompact_connectedComponentIn + (hKcompact.inter_right hUopen.isClosed_compl) x) + ((isConnected_connectedComponentIn_iff).2 hxKU) hxA haA + (isCompact_connectedComponentIn + (hKcompact.inter_right hUopen.isClosed_compl) y) + ((isConnected_connectedComponentIn_iff).2 hyKU) hyB hbB hAKU hBKU + (isCompact_brokenSegment a c b) (isConnected_brokenSegment a c b) + habridge hbbridge ?_ ?_ hbridgeSdiff ?_⟩ + · exact brokenSegment_subset_convexHull haKU.1 hcKU.1 hbKU.1 + · exact union_subset (hUconvex.closure.segment_subset + haClosureU (subset_closure hcKU.2)) + (hUconvex.closure.segment_subset + (subset_closure hcKU.2) hbClosureU) + · exact hausdorffMeasure_brokenSegment_lt hUbounded + haClosureU hbClosureU hepsilon hac + +private def threePointBarycenters (C : Set (EuclideanSpace ℝ (Fin 2))) : + Set (EuclideanSpace ℝ (Fin 2)) := + (fun p : Convexity.StdSimplex ℝ (Fin 3) × (Fin 3 → C) ↦ + ∑ i, p.1.weights i • (p.2 i : (EuclideanSpace ℝ (Fin 2)))) '' univ + +private theorem exists_threePointBarycenter {C : Set (EuclideanSpace ℝ (Fin 2))} (hC : C.Nonempty) + {t : Finset (EuclideanSpace ℝ (Fin 2))} + (htC : (t : Set (EuclideanSpace ℝ (Fin 2))) ⊆ C) + {w : (EuclideanSpace ℝ (Fin 2)) → ℝ} + (hw : ∀ y ∈ t, 0 ≤ w y) (hwsum : ∑ y ∈ t, w y = 1) + (hcard : Fintype.card t ≤ 3) : + ∃ p : Convexity.StdSimplex ℝ (Fin 3) × (Fin 3 → C), + ∑ i, p.1.weights i • (p.2 i : (EuclideanSpace ℝ (Fin 2))) = ∑ y ∈ t, w y • y := by + let e : t ↪ Fin 3 := Classical.choice (Function.Embedding.nonempty_of_card_le hcard) + let weight : Fin 3 → ℝ := Function.extend e (fun q : t ↦ w q) 0 + let point : Fin 3 → C := + Function.extend e (fun q : t ↦ ⟨q, htC q.property⟩) (fun _ ↦ ⟨hC.some, hC.some_mem⟩) + have hweight_apply (q : t) : weight (e q) = w q := by simp [weight, Function.extend] + have hpoint_apply (q : t) : (point (e q) : (EuclideanSpace ℝ (Fin 2))) = q := by + simp [point, Function.extend] + have hweight_zero {i : Fin 3} (hi : i ∉ Finset.univ.map e) : weight i = 0 := by + apply Function.extend_apply' + simpa only [Finset.mem_map, Finset.mem_univ, true_and, not_exists] using hi + have hweightsum : ∑ i, weight i = 1 := by + calc + (∑ i, weight i) = (∑ i ∈ Finset.univ.map e, weight i) := by + symm + apply Finset.sum_subset (by simp) + intro i _ hi + exact hweight_zero hi + _ = (∑ q : t, weight (e q)) := Finset.sum_map (Finset.univ : Finset t) e weight + _ = (∑ q : t, w q) := by simp only [hweight_apply] + _ = (∑ y ∈ t, w y) := Finset.sum_coe_sort t w + _ = 1 := hwsum + have hweight_nonneg (i : Fin 3) : 0 ≤ weight i := by + by_cases hi : i ∈ Finset.univ.map e + · obtain ⟨q, -, rfl⟩ := Finset.mem_map.mp hi + exact hweight_apply q ▸ hw q q.property + · rw [hweight_zero hi] + let weights : Convexity.StdSimplex ℝ (Fin 3) := + ⟨Finsupp.equivFunOnFinite.symm weight, hweight_nonneg, + by simpa [Finsupp.sum_fintype] using hweightsum⟩ + refine ⟨(weights, point), ?_⟩ + calc + (∑ i, weight i • (point i : (EuclideanSpace ℝ (Fin 2)))) = + (∑ i ∈ Finset.univ.map e, weight i • (point i : (EuclideanSpace ℝ (Fin 2)))) := by + symm + apply Finset.sum_subset (by simp) + intro i _ hi + rw [hweight_zero hi, zero_smul] + _ = (∑ q : t, weight (e q) • (point (e q) : (EuclideanSpace ℝ (Fin 2)))) := + Finset.sum_map (Finset.univ : Finset t) e _ + _ = (∑ q : t, w q • (q : (EuclideanSpace ℝ (Fin 2)))) := by + apply Finset.sum_congr rfl + intro q _ + rw [hweight_apply, hpoint_apply] + _ = (∑ y ∈ t, w y • y) := by + simpa using Finset.sum_coe_sort t (fun y : (EuclideanSpace ℝ (Fin 2)) ↦ w y • y) + +private theorem convexHull_eq_threePointBarycenters + {C : Set (EuclideanSpace ℝ (Fin 2))} (hC : C.Nonempty) : + convexHull ℝ C = threePointBarycenters C := by + apply Subset.antisymm + · intro z hz + rw [convexHull_eq_union] at hz + simp only [mem_iUnion, exists_prop] at hz + obtain ⟨t, htC, htAffine, hzt⟩ := hz + rw [Finset.mem_convexHull'] at hzt + obtain ⟨w, hw, hwsum, hwz⟩ := hzt + have hcard : Fintype.card t ≤ 3 := by + calc + Fintype.card t ≤ + Module.finrank ℝ + (vectorSpan ℝ (range ((↑) : t → (EuclideanSpace ℝ (Fin 2))))) + 1 := + htAffine.card_le_finrank_succ + _ ≤ Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) + 1 := + Nat.add_le_add_right (Submodule.finrank_le _) 1 + _ = 3 := by simp [finrank_euclideanSpace] + obtain ⟨p, hp⟩ := exists_threePointBarycenter hC htC hw hwsum hcard + exact ⟨p, mem_univ _, by simpa [threePointBarycenters, hwz] using hp⟩ + · rintro z ⟨p, -, rfl⟩ + change (∑ i, p.1.weights i • (p.2 i : (EuclideanSpace ℝ (Fin 2)))) ∈ convexHull ℝ C + rw [← Finset.centerMass_eq_of_sum_1 Finset.univ + (fun i ↦ (p.2 i : (EuclideanSpace ℝ (Fin 2)))) p.1.total_of_fintype] + exact Finset.univ.centerMass_mem_convexHull (fun i _ ↦ p.1.weights_nonneg i) + (by rw [p.1.total_of_fintype]; exact zero_lt_one) (fun i _ ↦ (p.2 i).property) + +private theorem isCompact_convexHull_plane + {C : Set (EuclideanSpace ℝ (Fin 2))} (hC : IsCompact C) : + IsCompact (convexHull ℝ C) := by + by_cases hCne : C.Nonempty + · rw [convexHull_eq_threePointBarycenters hCne, threePointBarycenters] + let : CompactSpace C := isCompact_iff_compactSpace.mp hC + apply IsCompact.image isCompact_univ + apply continuous_finsetSum Finset.univ + intro i _ + exact ((Convexity.StdSimplex.continuous_weights_apply ℝ i).comp continuous_fst).smul + (continuous_subtype_val.comp ((continuous_apply i).comp continuous_snd)) + · rw [not_nonempty_iff_eq_empty.mp hCne, convexHull_empty] + exact isCompact_empty + +private def holesBefore (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (n : ℕ) : + Set (EuclideanSpace ℝ (Fin 2)) := + ⋃ i : Fin n, U i + +@[simp] +private theorem holesBefore_zero (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) : + holesBefore U 0 = ∅ := by + simp [holesBefore] + +private theorem holesBefore_succ (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (n : ℕ) : + holesBefore U (n + 1) = holesBefore U n ∪ U n := by + ext z + simp only [holesBefore, mem_iUnion, mem_union] + constructor + · rintro ⟨i, hi⟩ + by_cases hin : (i : ℕ) = n + · exact Or.inr (hin ▸ hi) + · exact Or.inl ⟨⟨i, Nat.lt_of_le_of_ne (Nat.le_of_lt_succ i.2) hin⟩, hi⟩ + · rintro (⟨i, hi⟩ | hn) + · exact ⟨i.castSucc, hi⟩ + · exact ⟨Fin.last n, hn⟩ + +private structure SurgeryStage (C : Set (EuclideanSpace ℝ (Fin 2))) + (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (eta : ℕ → ℝ) (x y : (EuclideanSpace ℝ (Fin 2))) (n : ℕ) where + carrier : Set (EuclideanSpace ℝ (Fin 2)) + bridges : Fin n → Set (EuclideanSpace ℝ (Fin 2)) + isCompact_carrier : IsCompact carrier + isConnected_carrier : IsConnected carrier + left_mem : x ∈ carrier + right_mem : y ∈ carrier + ediam_eq : Metric.ediam carrier = Metric.ediam C + subset_convexHull : carrier ⊆ convexHull ℝ C + outside : carrier \ holesBefore U n ⊆ C \ holesBefore U n + inside : ∀ i : Fin n, carrier ∩ U i ⊆ bridges i + isCompact_bridge : ∀ i : Fin n, IsCompact (bridges i) + isPreconnected_bridge : ∀ i : Fin n, IsPreconnected (bridges i) + bridge_subset_closure : ∀ i : Fin n, bridges i ⊆ closure (U i) + bridge_outside : ∀ i : Fin n, bridges i \ U i ⊆ C + bridge_anchor : ∀ i : Fin n, (bridges i).Nonempty → (bridges i ∩ C).Nonempty + bridge_measure : ∀ i : Fin n, μH[1] (bridges i) < + Metric.ediam (U i) + ENNReal.ofReal (eta i) + +private def initialSurgeryStage {C : Set (EuclideanSpace ℝ (Fin 2))} + (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (eta : ℕ → ℝ) {x y : (EuclideanSpace ℝ (Fin 2))} (hCcompact : IsCompact C) + (hCconnected : IsConnected C) (hxC : x ∈ C) (hyC : y ∈ C) : + SurgeryStage C U eta x y 0 where + carrier := C + bridges := Fin.elim0 + isCompact_carrier := hCcompact + isConnected_carrier := hCconnected + left_mem := hxC + right_mem := hyC + ediam_eq := rfl + subset_convexHull := subset_convexHull ℝ C + outside := by simp + inside := fun i ↦ Fin.elim0 i + isCompact_bridge := fun i ↦ Fin.elim0 i + isPreconnected_bridge := fun i ↦ Fin.elim0 i + bridge_subset_closure := fun i ↦ Fin.elim0 i + bridge_outside := fun i ↦ Fin.elim0 i + bridge_anchor := fun i ↦ Fin.elim0 i + bridge_measure := fun i ↦ Fin.elim0 i + +private theorem SurgeryStage.exists_succ + {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} {n : ℕ} + (S : SurgeryStage C U eta x y n) (hxy : edist x y = Metric.ediam C) + (hUopen : ∀ i, IsOpen (U i)) (hUconvex : ∀ i, Convex ℝ (U i)) + (hUbounded : ∀ i, IsBounded (U i)) + (hUdisjoint : Pairwise fun i j ↦ Disjoint (U i) (U j)) + (hsum : ∑' i, Metric.ediam (U i) < Metric.ediam C) (heta : ∀ i, 0 < eta i) : + ∃ T : SurgeryStage C U eta x y (n + 1), + T.carrier ⊆ S.carrier ∪ T.bridges (Fin.last n) ∧ + (∀ i : Fin n, T.bridges i.castSucc = S.bridges i) := by + have hdiam : Metric.ediam (U n) < Metric.ediam S.carrier := by + calc + Metric.ediam (U n) ≤ ∑' i, Metric.ediam (U i) := + ENNReal.le_tsum (f := fun i ↦ Metric.ediam (U i)) n + _ < Metric.ediam C := hsum + _ = Metric.ediam S.carrier := S.ediam_eq.symm + obtain ⟨D, bridge, hD⟩ := exists_oneHoleSurgery S.isCompact_carrier + S.isConnected_carrier S.left_mem S.right_mem (hxy.trans S.ediam_eq.symm) + (hUopen n) (hUconvex n) (hUbounded n) hdiam (heta n) + rcases hD with ⟨hDcompact, hDconnected, hxD, hyD, hDediam, hDhull, + hDoutside, hDinside, hbridgeD, hbridgeCompact, hbridgePreconnected, hbridgeClosure, + hbridgeAnchor, hbridgeMeasure⟩ + let bridges : Fin (n + 1) → Set (EuclideanSpace ℝ (Fin 2)) := Fin.lastCases bridge S.bridges + have hDsubset : D ⊆ S.carrier ∪ bridge := by + intro z hzD + by_cases hzU : z ∈ U n + · exact Or.inr (hDinside ⟨hzD, hzU⟩) + · exact Or.inl (hDoutside ⟨hzD, hzU⟩).1 + have hDhullC : D ⊆ convexHull ℝ C := by + calc + D ⊆ convexHull ℝ S.carrier := hDhull + _ ⊆ convexHull ℝ (convexHull ℝ C) := convexHull_mono S.subset_convexHull + _ = convexHull ℝ C := (convex_convexHull ℝ C).convexHull_eq + have hDoutsideBefore : D \ holesBefore U (n + 1) ⊆ C \ holesBefore U (n + 1) := by + rw [holesBefore_succ] + rintro z ⟨hzD, hzoutside⟩ + have hzold : z ∉ holesBefore U n := fun hz ↦ hzoutside (Or.inl hz) + have hzn : z ∉ U n := fun hz ↦ hzoutside (Or.inr hz) + have hzS : z ∈ S.carrier := (hDoutside ⟨hzD, hzn⟩).1 + exact ⟨(S.outside ⟨hzS, hzold⟩).1, hzoutside⟩ + have hbridgeAnchorC : bridge.Nonempty → (bridge ∩ C).Nonempty := by + intro hbridge + obtain ⟨q, hqD, hqbridge, hqn⟩ := hbridgeAnchor hbridge + have hqold : q ∉ holesBefore U n := by + rw [holesBefore] + intro hq + obtain ⟨i, hqi⟩ := mem_iUnion.mp hq + have hne : n ≠ (i : ℕ) := by omega + exact Set.disjoint_left.1 ((hUdisjoint hne).closure_left (hUopen i)) + (hbridgeClosure hqbridge) hqi + have hqS : q ∈ S.carrier := (hDoutside ⟨hqD, hqn⟩).1 + exact ⟨q, hqbridge, (S.outside ⟨hqS, hqold⟩).1⟩ + have hbridgeOutsideC : bridge \ U n ⊆ C := by + rintro q ⟨hqbridge, hqn⟩ + have hqold : q ∉ holesBefore U n := by + rw [holesBefore] + intro hq + obtain ⟨i, hqi⟩ := mem_iUnion.mp hq + have hne : n ≠ (i : ℕ) := by omega + exact Set.disjoint_left.1 ((hUdisjoint hne).closure_left (hUopen i)) + (hbridgeClosure hqbridge) hqi + have hqS : q ∈ S.carrier := (hDoutside ⟨hbridgeD hqbridge, hqn⟩).1 + exact (S.outside ⟨hqS, hqold⟩).1 + refine ⟨{ + carrier := D + bridges := bridges + isCompact_carrier := hDcompact + isConnected_carrier := hDconnected + left_mem := hxD + right_mem := hyD + ediam_eq := hDediam.trans S.ediam_eq + subset_convexHull := hDhullC + outside := hDoutsideBefore + inside := ?_ + isCompact_bridge := ?_ + isPreconnected_bridge := ?_ + bridge_subset_closure := ?_ + bridge_outside := ?_ + bridge_anchor := ?_ + bridge_measure := ?_ }, ?_, ?_⟩ + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hDinside + · intro j + have hdisjoint : Disjoint (U j) (U n) := hUdisjoint (by omega) + rintro z ⟨hzD, hzj⟩ + have hzn : z ∉ U n := Set.disjoint_left.1 hdisjoint hzj + simpa [bridges] using S.inside j ⟨(hDoutside ⟨hzD, hzn⟩).1, hzj⟩ + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgeCompact + · intro j + simpa [bridges] using S.isCompact_bridge j + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgePreconnected + · intro j + simpa [bridges] using S.isPreconnected_bridge j + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgeClosure + · intro j + simpa [bridges] using S.bridge_subset_closure j + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgeOutsideC + · intro j + simpa [bridges] using S.bridge_outside j + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgeAnchorC + · intro j + simpa [bridges] using S.bridge_anchor j + · intro i + refine Fin.lastCases ?_ ?_ i + · simpa [bridges] using hbridgeMeasure + · intro j + simpa [bridges] using S.bridge_measure j + · simpa [bridges] using hDsubset + · intro i + simp [bridges] + +private structure SurgeryData (C : Set (EuclideanSpace ℝ (Fin 2))) + (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (eta : ℕ → ℝ) (x y : (EuclideanSpace ℝ (Fin 2))) where + isCompact_core : IsCompact C + isConnected_core : IsConnected C + left_mem_core : x ∈ C + right_mem_core : y ∈ C + realizes_ediam : edist x y = Metric.ediam C + isOpen_hole : ∀ i, IsOpen (U i) + convex_hole : ∀ i, Convex ℝ (U i) + isBounded_hole : ∀ i, IsBounded (U i) + disjoint_holes : Pairwise fun i j ↦ Disjoint (U i) (U j) + sum_ediam_lt : ∑' i, Metric.ediam (U i) < Metric.ediam C + error_pos : ∀ i, 0 < eta i + +namespace SurgeryData + +private noncomputable def next {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + {eta : ℕ → ℝ} {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) {n : ℕ} + (S : SurgeryStage C U eta x y n) : SurgeryStage C U eta x y (n + 1) := + Classical.choose <| S.exists_succ P.realizes_ediam P.isOpen_hole P.convex_hole + P.isBounded_hole P.disjoint_holes P.sum_ediam_lt P.error_pos + +private theorem next_subset {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + {eta : ℕ → ℝ} {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) {n : ℕ} + (S : SurgeryStage C U eta x y n) : + (P.next S).carrier ⊆ S.carrier ∪ (P.next S).bridges (Fin.last n) := + (Classical.choose_spec <| S.exists_succ P.realizes_ediam P.isOpen_hole P.convex_hole + P.isBounded_hole P.disjoint_holes P.sum_ediam_lt P.error_pos).1 + +private theorem next_bridge_castSucc {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + {eta : ℕ → ℝ} {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) {n : ℕ} + (S : SurgeryStage C U eta x y n) (i : Fin n) : + (P.next S).bridges i.castSucc = S.bridges i := + (Classical.choose_spec <| S.exists_succ P.realizes_ediam P.isOpen_hole P.convex_hole + P.isBounded_hole P.disjoint_holes P.sum_ediam_lt P.error_pos).2 i + +private noncomputable def stages {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + {eta : ℕ → ℝ} {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) : + (n : ℕ) → SurgeryStage C U eta x y n + | 0 => initialSurgeryStage U eta P.isCompact_core P.isConnected_core + P.left_mem_core P.right_mem_core + | n + 1 => P.next (P.stages n) + +private def bridge {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + Set (EuclideanSpace ℝ (Fin 2)) := + (P.stages (i + 1)).bridges (Fin.last i) + +private theorem stage_bridge_eq {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + {eta : ℕ → ℝ} {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (n : ℕ) + (i : Fin n) : (P.stages n).bridges i = P.bridge i := by + induction n with + | zero => exact Fin.elim0 i + | succ n ih => + refine Fin.lastCases ?_ (fun j ↦ ?_) i + · rfl + · rw [stages, next_bridge_castSucc] + exact ih j + +private theorem stage_subset_core_union_bridges + {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (n : ℕ) : + (P.stages n).carrier ⊆ C ∪ ⋃ i : Fin n, P.bridge i := by + induction n with + | zero => + intro z hz + exact Or.inl hz + | succ n ih => + intro z hz + have hz' := next_subset P (P.stages n) hz + rcases hz' with hzold | hznew + · rcases ih hzold with hzC | hzi + · exact Or.inl hzC + · obtain ⟨i, hi⟩ := mem_iUnion.mp hzi + exact Or.inr (mem_iUnion.2 ⟨i.castSucc, hi⟩) + · apply Or.inr + apply mem_iUnion.2 + exact ⟨Fin.last n, hznew⟩ + +private theorem isCompact_bridge {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + IsCompact (P.bridge i) := + (P.stages (i + 1)).isCompact_bridge (Fin.last i) + +private theorem bridge_subset_closure {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + P.bridge i ⊆ closure (U i) := + (P.stages (i + 1)).bridge_subset_closure (Fin.last i) + +private theorem bridge_outside {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + P.bridge i \ U i ⊆ C := + (P.stages (i + 1)).bridge_outside (Fin.last i) + +private theorem bridge_anchor {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + (P.bridge i).Nonempty → (P.bridge i ∩ C).Nonempty := + (P.stages (i + 1)).bridge_anchor (Fin.last i) + +private theorem bridge_measure {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (i : ℕ) : + μH[1] (P.bridge i) < Metric.ediam (U i) + ENNReal.ofReal (eta i) := + (P.stages (i + 1)).bridge_measure (Fin.last i) + +private theorem closure_core_union_bridges_sdiff + {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) : + closure (C ∪ ⋃ i, P.bridge i) \ ⋃ i, U i ⊆ C := by + rintro z ⟨hzclosure, hzholes⟩ + by_contra hzC + let delta := Metric.infDist z C + have hCnonempty : C.Nonempty := ⟨x, P.left_mem_core⟩ + have hdelta : 0 < delta := + (P.isCompact_core.isClosed.notMem_iff_infDist_pos hCnonempty).1 hzC + have hsum_ne : ∑' i, Metric.ediam (U i) ≠ ∞ := + ne_top_of_lt (P.sum_ediam_lt.trans_le le_top) + have hdiam_tendsto : Filter.Tendsto (fun i ↦ Metric.diam (U i)) Filter.atTop (nhds 0) := by + have hed := ENNReal.tendsto_atTop_zero_of_tsum_ne_top hsum_ne + have hreal := (ENNReal.tendsto_toReal ENNReal.zero_ne_top).comp hed + change Filter.Tendsto (fun i ↦ (Metric.ediam (U i)).toReal) + Filter.atTop (nhds 0) at hreal + simpa only [Metric.diam] using hreal + have heventually : ∀ᶠ i in Filter.atTop, Metric.diam (U i) < delta / 3 := + (tendsto_order.1 hdiam_tendsto).2 _ (by linarith) + obtain ⟨N, hN⟩ := Filter.eventually_atTop.1 heventually + let F := C ∪ ⋃ i : Fin N, P.bridge i + have hFcompact : IsCompact F := + P.isCompact_core.union (isCompact_iUnion fun i ↦ P.isCompact_bridge i) + have hFnonempty : F.Nonempty := hCnonempty.mono subset_union_left + have hzF : z ∉ F := by + rintro (hzC' | hzbridge) + · exact hzC hzC' + · obtain ⟨i, hzi⟩ := mem_iUnion.mp hzbridge + have hzUi : z ∉ U i := fun h ↦ hzholes (mem_iUnion.2 ⟨(i : ℕ), h⟩) + exact hzC (P.bridge_outside i ⟨hzi, hzUi⟩) + have hdistF : 0 < Metric.infDist z F := + (hFcompact.isClosed.notMem_iff_infDist_pos hFnonempty).1 hzF + let rho := min (delta / 3) (Metric.infDist z F / 2) + have hrho : 0 < rho := lt_min (by linarith) (by linarith) + obtain ⟨w, hw, hzw⟩ := Metric.mem_closure_iff.mp hzclosure rho hrho + have hwF : w ∉ F := by + apply Metric.notMem_of_dist_lt_infDist + exact hzw.trans_le (min_le_right _ _ |>.trans (by linarith)) + rcases hw with hwC | hwbridge + · exact (hwF (Or.inl hwC)).elim + · obtain ⟨i, hwi⟩ := mem_iUnion.mp hwbridge + have hiN : N ≤ i := by + by_contra hiN + apply hwF + exact Or.inr (mem_iUnion.2 ⟨⟨i, Nat.lt_of_not_ge hiN⟩, hwi⟩) + obtain ⟨a, haBridge, haC⟩ := P.bridge_anchor i ⟨w, hwi⟩ + have hwa : dist w a ≤ Metric.diam (U i) := by + rw [← Metric.diam_closure] + exact Metric.dist_le_diam_of_mem (P.isBounded_hole i).closure + (P.bridge_subset_closure i hwi) (P.bridge_subset_closure i haBridge) + have hdelta_le : delta ≤ dist z a := Metric.infDist_le_dist_of_mem haC + have hcontradiction : delta < delta := calc + delta ≤ dist z a := hdelta_le + _ ≤ dist z w + dist w a := dist_triangle _ _ _ + _ < rho + delta / 3 := add_lt_add hzw (hwa.trans_lt (hN i hiN)) + _ ≤ delta / 3 + delta / 3 := add_le_add (min_le_left _ _) le_rfl + _ < delta := by linarith + exact (lt_irrefl _ hcontradiction).elim + +private noncomputable def compactStage {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (n : ℕ) : + TopologicalSpace.NonemptyCompacts (convexHull ℝ C) := by + letI : CompactSpace (convexHull ℝ C) := + isCompact_iff_compactSpace.mp (isCompact_convexHull_plane P.isCompact_core) + exact { + carrier := {q | (q : (EuclideanSpace ℝ (Fin 2))) ∈ (P.stages n).carrier} + isCompact' := + ((P.stages n).isCompact_carrier.isClosed.preimage continuous_subtype_val).isCompact + nonempty' := + ⟨⟨x, (P.stages n).subset_convexHull (P.stages n).left_mem⟩, + (P.stages n).left_mem⟩ } + +private theorem isConnected_compactStage {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) (n : ℕ) : + IsConnected (P.compactStage n : Set (convexHull ℝ C)) := by + refine ⟨⟨⟨x, (P.stages n).subset_convexHull (P.stages n).left_mem⟩, + (P.stages n).left_mem⟩, ?_⟩ + exact LeanPool.Besicovitch.IsPreconnected.preimage_subtype_of_subset + (P.stages n).isConnected_carrier.isPreconnected (P.stages n).subset_convexHull + +end SurgeryData + +private theorem isConnected_nonemptyCompacts_limit + {Q : Type*} [MetricSpace Q] + (K : ℕ → TopologicalSpace.NonemptyCompacts Q) + (L : TopologicalSpace.NonemptyCompacts Q) + (hK : ∀ n, IsConnected (K n : Set Q)) + (hlim : Filter.Tendsto K Filter.atTop (nhds L)) : IsConnected (L : Set Q) := by + refine ⟨L.nonempty, ?_⟩ + rintro O P hO hP hcover hLO hLP + by_contra hdisjoint + obtain ⟨A, B, hAcompact, hBcompact, hAO, hBP, hLAB⟩ := + L.isCompact.binary_compact_cover hO hP hcover + have hAB : Disjoint A B := by + refine Set.disjoint_left.2 fun z hzA hzB ↦ hdisjoint ?_ + have hzL : z ∈ (L : Set Q) := by rw [hLAB]; exact Or.inl hzA + exact ⟨z, hzL, hAO hzA, hBP hzB⟩ + have hAne : A.Nonempty := by + obtain ⟨z, hzL, hzO⟩ := hLO + rcases hLAB ▸ hzL with hzA | hzB + · exact ⟨z, hzA⟩ + · exact (hdisjoint ⟨z, hzL, hzO, hBP hzB⟩).elim + have hBne : B.Nonempty := by + obtain ⟨z, hzL, hzP⟩ := hLP + rcases hLAB ▸ hzL with hzA | hzB + · exact (hdisjoint ⟨z, hzL, hAO hzA, hzP⟩).elim + · exact ⟨z, hzB⟩ + obtain ⟨V, W, hV, hW, hAV, hBW, hVW⟩ := + SeparatedNhds.of_isCompact_isCompact_isClosed + hAcompact hBcompact hBcompact.isClosed hAB + have hLsub : (L : Set Q) ⊆ V ∪ W := by + rw [hLAB] + exact union_subset_union hAV hBW + have hLmeetV : ((L : Set Q) ∩ V).Nonempty := + hAne.mono fun z hz ↦ ⟨by rw [hLAB]; exact Or.inl hz, hAV hz⟩ + have hLmeetW : ((L : Set Q) ∩ W).Nonempty := + hBne.mono fun z hz ↦ ⟨by rw [hLAB]; exact Or.inr hz, hBW hz⟩ + have heventuallySub : ∀ᶠ n in Filter.atTop, (K n : Set Q) ⊆ V ∪ W := + hlim.eventually <| + (TopologicalSpace.NonemptyCompacts.isOpen_subsets_of_isOpen (hV.union hW)).mem_nhds hLsub + have heventuallyV : ∀ᶠ n in Filter.atTop, ((K n : Set Q) ∩ V).Nonempty := + hlim.eventually <| + (TopologicalSpace.NonemptyCompacts.isOpen_inter_nonempty_of_isOpen hV).mem_nhds hLmeetV + have heventuallyW : ∀ᶠ n in Filter.atTop, ((K n : Set Q) ∩ W).Nonempty := + hlim.eventually <| + (TopologicalSpace.NonemptyCompacts.isOpen_inter_nonempty_of_isOpen hW).mem_nhds hLmeetW + obtain ⟨n, hnSub, hnV, hnW⟩ := + (heventuallySub.and (heventuallyV.and heventuallyW)).exists + obtain ⟨z, -, hzV, hzW⟩ := (hK n).2 V W hV hW hnSub hnV hnW + exact Set.disjoint_left.1 hVW hzV hzW + +namespace SurgeryData + +private theorem exists_limit {C : Set (EuclideanSpace ℝ (Fin 2))} + {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {eta : ℕ → ℝ} + {x y : (EuclideanSpace ℝ (Fin 2))} (P : SurgeryData C U eta x y) : + ∃ D : Set (EuclideanSpace ℝ (Fin 2)), + IsCompact D ∧ IsConnected D ∧ x ∈ D ∧ y ∈ D ∧ D ⊆ convexHull ℝ C ∧ + D ⊆ closure (C ∪ ⋃ i, P.bridge i) ∧ ∀ i, D ∩ U i ⊆ P.bridge i := by + let : CompactSpace (convexHull ℝ C) := + isCompact_iff_compactSpace.mp (isCompact_convexHull_plane P.isCompact_core) + obtain ⟨L, phi, hphi, hlimit⟩ := CompactSpace.tendsto_subseq P.compactStage + let D : Set (EuclideanSpace ℝ (Fin 2)) := Subtype.val '' (L : Set (convexHull ℝ C)) + have hLconnected : IsConnected (L : Set (convexHull ℝ C)) := + isConnected_nonemptyCompacts_limit (fun n ↦ P.compactStage (phi n)) L + (fun n ↦ P.isConnected_compactStage (phi n)) hlimit + have hDcompact : IsCompact D := L.isCompact.image continuous_subtype_val + have hDconnected : IsConnected D := + hLconnected.image Subtype.val continuous_subtype_val.continuousOn + let xHull : convexHull ℝ C := ⟨x, subset_convexHull ℝ C P.left_mem_core⟩ + let yHull : convexHull ℝ C := ⟨y, subset_convexHull ℝ C P.right_mem_core⟩ + have hxL : xHull ∈ L := by + have hhit : ((L : Set (convexHull ℝ C)) ∩ {xHull}).Nonempty := + (TopologicalSpace.NonemptyCompacts.isClosed_inter_nonempty_of_isClosed + isClosed_singleton).mem_of_tendsto hlimit <| Filter.Eventually.of_forall fun n ↦ + ⟨xHull, (P.stages (phi n)).left_mem, rfl⟩ + obtain ⟨q, hqL, hqx⟩ := hhit + exact (mem_singleton_iff.mp hqx) ▸ hqL + have hyL : yHull ∈ L := by + have hhit : ((L : Set (convexHull ℝ C)) ∩ {yHull}).Nonempty := + (TopologicalSpace.NonemptyCompacts.isClosed_inter_nonempty_of_isClosed + isClosed_singleton).mem_of_tendsto hlimit <| Filter.Eventually.of_forall fun n ↦ + ⟨yHull, (P.stages (phi n)).right_mem, rfl⟩ + obtain ⟨q, hqL, hqy⟩ := hhit + exact (mem_singleton_iff.mp hqy) ▸ hqL + have hDclosure : D ⊆ closure (C ∪ ⋃ i, P.bridge i) := by + let F : Set (convexHull ℝ C) := + Subtype.val ⁻¹' closure (C ∪ ⋃ i, P.bridge i) + have hFclosed : IsClosed F := isClosed_closure.preimage continuous_subtype_val + have hLsubset : (L : Set (convexHull ℝ C)) ⊆ F := + (TopologicalSpace.NonemptyCompacts.isClosed_subsets_of_isClosed + hFclosed).mem_of_tendsto hlimit <| Filter.Eventually.of_forall fun n q hq ↦ by + apply subset_closure + rcases P.stage_subset_core_union_bridges (phi n) hq with hqC | hqbridge + · exact Or.inl hqC + · obtain ⟨j, hj⟩ := mem_iUnion.mp hqbridge + exact Or.inr (mem_iUnion.2 ⟨(j : ℕ), hj⟩) + rintro z ⟨q, hqL, rfl⟩ + exact hLsubset hqL + have hDinside : ∀ i, D ∩ U i ⊆ P.bridge i := by + intro i z hz + obtain ⟨q, hqL, rfl⟩ := hz.1 + by_contra hqbridge + let V : Set (convexHull ℝ C) := Subtype.val ⁻¹' (U i \ P.bridge i) + have hVopen : IsOpen V := + ((P.isOpen_hole i).sdiff (P.isCompact_bridge i).isClosed).preimage + continuous_subtype_val + have hLmeet : ((L : Set (convexHull ℝ C)) ∩ V).Nonempty := + ⟨q, hqL, hz.2, hqbridge⟩ + have hmeet : ∀ᶠ n in Filter.atTop, + (((P.compactStage (phi n) : Set (convexHull ℝ C)) ∩ V).Nonempty) := + hlimit.eventually <| + (TopologicalSpace.NonemptyCompacts.isOpen_inter_nonempty_of_isOpen hVopen).mem_nhds + hLmeet + have hindex : ∀ᶠ n in Filter.atTop, i + 1 ≤ phi n := + (Filter.tendsto_atTop.1 hphi.tendsto_atTop) (i + 1) + obtain ⟨n, hnmeet, hni⟩ := (hmeet.and hindex).exists + obtain ⟨r, hrstage, hrU, hrbridge⟩ := hnmeet + let j : Fin (phi n) := ⟨i, Nat.lt_of_succ_le hni⟩ + have hrnew := (P.stages (phi n)).inside j ⟨hrstage, hrU⟩ + rw [P.stage_bridge_eq (phi n) j] at hrnew + exact hrbridge hrnew + exact ⟨D, hDcompact, hDconnected, ⟨xHull, hxL, rfl⟩, ⟨yHull, hyL, rfl⟩, + fun _ ⟨q, _, hq⟩ ↦ hq ▸ q.property, hDclosure, hDinside⟩ + +end SurgeryData + +/-- Countably many disjoint open convex holes can be bypassed without changing a +diameter-realizing pair, at a total length cost bounded by their diameters. -/ +theorem exists_continuum_surgery {C : Set (EuclideanSpace ℝ (Fin 2))} (hCcompact : IsCompact C) + (hCconnected : IsConnected C) {x y : (EuclideanSpace ℝ (Fin 2))} + (hxC : x ∈ C) (hyC : y ∈ C) + (hxy : edist x y = Metric.ediam C) (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) (hUconvex : ∀ i, Convex ℝ (U i)) + (hUbounded : ∀ i, IsBounded (U i)) + (hUdisjoint : Pairwise fun i j ↦ Disjoint (U i) (U j)) + (hsum : (∑' i, Metric.ediam (U i)) < Metric.ediam C) {epsilon : ℝ} + (hepsilon : 0 < epsilon) : + ∃ D : Set (EuclideanSpace ℝ (Fin 2)), + IsCompact D ∧ IsConnected D ∧ x ∈ D ∧ y ∈ D ∧ + Metric.ediam D = Metric.ediam C ∧ D ⊆ convexHull ℝ C ∧ + D \ ⋃ i, U i ⊆ C \ ⋃ i, U i ∧ + μH[1] (D ∩ ⋃ i, U i) ≤ (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon ∧ + μH[1] D ≤ μH[1] C + (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := by + let eta : ℕ → ℝ := fun i ↦ epsilon / 2 / 2 ^ i + let P : SurgeryData C U eta x y := { + isCompact_core := hCcompact + isConnected_core := hCconnected + left_mem_core := hxC + right_mem_core := hyC + realizes_ediam := hxy + isOpen_hole := hUopen + convex_hole := hUconvex + isBounded_hole := hUbounded + disjoint_holes := hUdisjoint + sum_ediam_lt := hsum + error_pos := fun _ ↦ by dsimp [eta]; positivity } + obtain ⟨D, hDcompact, hDconnected, hxD, hyD, hDhull, hDclosure, hDinside⟩ := + P.exists_limit + have hDediam : Metric.ediam D = Metric.ediam C := by + apply le_antisymm (Metric.ediam_mono hDhull |>.trans_eq (convexHull_ediam C)) + rw [← hxy] + exact Metric.edist_le_ediam_of_mem hxD hyD + have hDoutside : D \ ⋃ i, U i ⊆ C \ ⋃ i, U i := by + intro z hz + exact ⟨P.closure_core_union_bridges_sdiff ⟨hDclosure hz.1, hz.2⟩, hz.2⟩ + have hDholes : D ∩ ⋃ i, U i ⊆ ⋃ i, P.bridge i := by + rintro z ⟨hzD, hzU⟩ + obtain ⟨i, hzi⟩ := mem_iUnion.mp hzU + exact mem_iUnion.2 ⟨i, hDinside i ⟨hzD, hzi⟩⟩ + have hetaSum : ∑' i, ENNReal.ofReal (eta i) = ENNReal.ofReal epsilon := by + rw [← ENNReal.ofReal_tsum_of_nonneg (fun i ↦ (P.error_pos i).le) + (summable_geometric_two' epsilon), tsum_geometric_two'] + have hinsideMeasure : + μH[1] (D ∩ ⋃ i, U i) ≤ (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := by + calc + μH[1] (D ∩ ⋃ i, U i) ≤ μH[1] (⋃ i, P.bridge i) := measure_mono hDholes + _ ≤ ∑' i, μH[1] (P.bridge i) := measure_iUnion_le _ + _ ≤ ∑' i, (Metric.ediam (U i) + ENNReal.ofReal (eta i)) := + ENNReal.tsum_le_tsum fun i ↦ (P.bridge_measure i).le + _ = (∑' i, Metric.ediam (U i)) + ∑' i, ENNReal.ofReal (eta i) := + ENNReal.tsum_add + _ = (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := by rw [hetaSum] + have hDdecomp : D ⊆ C ∪ (D ∩ ⋃ i, U i) := by + intro z hzD + by_cases hzU : z ∈ ⋃ i, U i + · exact Or.inr ⟨hzD, hzU⟩ + · exact Or.inl (hDoutside ⟨hzD, hzU⟩).1 + have htotalMeasure : + μH[1] D ≤ μH[1] C + (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := by + calc + μH[1] D ≤ μH[1] (C ∪ (D ∩ ⋃ i, U i)) := measure_mono hDdecomp + _ ≤ μH[1] C + μH[1] (D ∩ ⋃ i, U i) := measure_union_le _ _ + _ ≤ μH[1] C + ((∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon) := by + gcongr + _ = μH[1] C + (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := + (add_assoc _ _ _).symm + exact ⟨D, hDcompact, hDconnected, hxD, hyD, hDediam, hDhull, hDoutside, + hinsideMeasure, htotalMeasure⟩ + +/-- The continuum-surgery theorem for a countable index type. -/ +theorem exists_continuum_surgery_countable {iota : Type*} [Countable iota] + {C : Set (EuclideanSpace ℝ (Fin 2))} (hCcompact : IsCompact C) (hCconnected : IsConnected C) + {x y : (EuclideanSpace ℝ (Fin 2))} (hxC : x ∈ C) (hyC : y ∈ C) + (hxy : edist x y = Metric.ediam C) (U : iota → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) (hUconvex : ∀ i, Convex ℝ (U i)) + (hUbounded : ∀ i, IsBounded (U i)) + (hUdisjoint : Pairwise fun i j ↦ Disjoint (U i) (U j)) + (hsum : (∑' i, Metric.ediam (U i)) < Metric.ediam C) {epsilon : ℝ} + (hepsilon : 0 < epsilon) : + ∃ D : Set (EuclideanSpace ℝ (Fin 2)), + IsCompact D ∧ IsConnected D ∧ x ∈ D ∧ y ∈ D ∧ + Metric.ediam D = Metric.ediam C ∧ D ⊆ convexHull ℝ C ∧ + D \ ⋃ i, U i ⊆ C \ ⋃ i, U i ∧ + μH[1] (D ∩ ⋃ i, U i) ≤ (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon ∧ + μH[1] D ≤ μH[1] C + (∑' i, Metric.ediam (U i)) + ENNReal.ofReal epsilon := by + let : Encodable iota := Encodable.ofCountable iota + let e : iota → ℕ := Encodable.encode + let V : ℕ → Set (EuclideanSpace ℝ (Fin 2)) := Function.extend e U ⊥ + have he : Function.Injective e := Encodable.encode_injective + have hVencode (i : iota) : V (e i) = U i := by + exact he.extend_apply U ⊥ i + have hVoutside {n : ℕ} (hn : ¬ ∃ i, e i = n) : V n = ∅ := by + dsimp only [V] + rw [Function.extend_apply' U ⊥ n hn] + rfl + have hVopen : ∀ n, IsOpen (V n) := by + intro n + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + rw [hVencode] + exact hUopen i + · rw [hVoutside hn] + exact isOpen_empty + have hVconvex : ∀ n, Convex ℝ (V n) := by + intro n + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + rw [hVencode] + exact hUconvex i + · rw [hVoutside hn] + exact convex_empty + have hVbounded : ∀ n, IsBounded (V n) := by + intro n + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + rw [hVencode] + exact hUbounded i + · rw [hVoutside hn] + exact Bornology.isBounded_empty + have hVdisjoint : Pairwise fun m n ↦ Disjoint (V m) (V n) := by + simpa only [V] using + hUdisjoint.disjoint_extend_bot (he.factorsThrough U) + have hUnion : (⋃ n, V n) = ⋃ i, U i := by + ext z + constructor + · intro hz + obtain ⟨n, hzn⟩ := mem_iUnion.mp hz + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + exact mem_iUnion.2 ⟨i, by simpa only [hVencode] using hzn⟩ + · rw [hVoutside hn] at hzn + exact hzn.elim + · intro hz + obtain ⟨i, hzi⟩ := mem_iUnion.mp hz + exact mem_iUnion.2 ⟨e i, by simpa only [hVencode] using hzi⟩ + have hsupport : + Function.support (fun n ↦ Metric.ediam (V n)) ⊆ Set.range e := by + intro n hn + by_contra hnrange + apply hn + change Metric.ediam (V n) = 0 + rw [hVoutside, Metric.ediam_empty] + simpa only [Set.mem_range] using hnrange + have hsumV : (∑' n, Metric.ediam (V n)) = ∑' i, Metric.ediam (U i) := by + symm + simpa only [hVencode] using he.tsum_eq hsupport + simpa only [hUnion, hsumV] using + exists_continuum_surgery hCcompact hCconnected hxC hyC hxy V hVopen hVconvex + hVbounded hVdisjoint (by simpa only [hsumV] using hsum) hepsilon + +/-- A countable family of open holes has a pairwise-disjoint open convex enlargement whose +total diameter is no larger. -/ +theorem exists_pairwiseDisjoint_convex_hole_cover_countable + {iota : Type*} [Countable iota] (U : iota → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) + (hsum : (∑' i, Metric.ediam (U i)) ≠ ∞) : + ∃ W : Set (Set (EuclideanSpace ℝ (Fin 2))), + W.Countable ∧ W.PairwiseDisjoint id ∧ + (∀ V : W, IsOpen (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + Convex ℝ (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + IsBounded (V : Set (EuclideanSpace ℝ (Fin 2)))) ∧ + (⋃ i, U i) ⊆ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + (∑' V : W, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ∑' i, Metric.ediam (U i) := by + let : Encodable iota := Encodable.ofCountable iota + let e : iota → ℕ := Encodable.encode + let V : ℕ → Set (EuclideanSpace ℝ (Fin 2)) := Function.extend e U ⊥ + have he : Function.Injective e := Encodable.encode_injective + have hVencode (i : iota) : V (e i) = U i := he.extend_apply U ⊥ i + have hVoutside {n : ℕ} (hn : ¬ ∃ i, e i = n) : V n = ∅ := by + dsimp only [V] + rw [Function.extend_apply' U ⊥ n hn] + rfl + have hVopen : ∀ n, IsOpen (V n) := by + intro n + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + rw [hVencode] + exact hUopen i + · rw [hVoutside hn] + exact isOpen_empty + have hUnion : (⋃ n, V n) = ⋃ i, U i := by + ext z + constructor + · intro hz + obtain ⟨n, hzn⟩ := mem_iUnion.mp hz + by_cases hn : ∃ i, e i = n + · obtain ⟨i, rfl⟩ := hn + exact mem_iUnion.2 ⟨i, by simpa only [hVencode] using hzn⟩ + · rw [hVoutside hn] at hzn + exact hzn.elim + · intro hz + obtain ⟨i, hzi⟩ := mem_iUnion.mp hz + exact mem_iUnion.2 ⟨e i, by simpa only [hVencode] using hzi⟩ + have hsupport : + Function.support (fun n ↦ Metric.ediam (V n)) ⊆ Set.range e := by + intro n hn + by_contra hnrange + apply hn + change Metric.ediam (V n) = 0 + rw [hVoutside, Metric.ediam_empty] + simpa only [Set.mem_range] using hnrange + have hsumV : (∑' n, Metric.ediam (V n)) = ∑' i, Metric.ediam (U i) := by + symm + simpa only [hVencode] using he.tsum_eq hsupport + simpa only [hUnion, hsumV] using + exists_pairwiseDisjoint_convex_hole_cover V hVopen (by simpa only [hsumV] using hsum) + +/-- Surgery for arbitrary countably many open holes. The part not inherited from the old +continuum outside the holes has measure strictly smaller than the preserved diameter. -/ +theorem exists_continuum_surgery_open_holes {iota : Type*} [Countable iota] + {C : Set (EuclideanSpace ℝ (Fin 2))} (hCcompact : IsCompact C) (hCconnected : IsConnected C) + {x y : (EuclideanSpace ℝ (Fin 2))} (hxC : x ∈ C) (hyC : y ∈ C) + (hxy : edist x y = Metric.ediam C) (U : iota → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) + (hsum : (∑' i, Metric.ediam (U i)) < Metric.ediam C) : + ∃ D : Set (EuclideanSpace ℝ (Fin 2)), + IsCompact D ∧ IsConnected D ∧ x ∈ D ∧ y ∈ D ∧ + Metric.ediam D = Metric.ediam C ∧ D ⊆ convexHull ℝ C ∧ + μH[1] (D \ (C \ ⋃ i, U i)) < Metric.ediam C ∧ + μH[1] (D ∩ ⋃ i, U i) < Metric.ediam C ∧ + μH[1] D ≤ μH[1] (C \ ⋃ i, U i) + Metric.ediam C := by + obtain ⟨W, hWcountable, hWdisjoint, hWproperties, hcover, hWsum⟩ := + exists_pairwiseDisjoint_convex_hole_cover_countable U hUopen + (ne_top_of_lt (hsum.trans_le le_top)) + let : Countable W := hWcountable.to_subtype + have hWpairwise : Pairwise fun V Z : W ↦ + Disjoint (V : Set (EuclideanSpace ℝ (Fin 2))) (Z : Set (EuclideanSpace ℝ (Fin 2))) := by + intro V Z hVZ + simpa only [Function.onFun, id_eq] using + hWdisjoint V.property Z.property (fun h ↦ hVZ (Subtype.ext h)) + obtain ⟨error, herror, hbudget⟩ := + ENNReal.lt_iff_exists_add_pos_lt.mp hsum + obtain ⟨D, hDcompact, hDconnected, hxD, hyD, hDediam, hDhull, + hDoutside, hDinside, -⟩ := + exists_continuum_surgery_countable hCcompact hCconnected hxC hyC hxy + (fun V : W ↦ (V : Set (EuclideanSpace ℝ (Fin 2)))) (fun V ↦ (hWproperties V).1) + (fun V ↦ (hWproperties V).2.1) (fun V ↦ (hWproperties V).2.2) + hWpairwise (hWsum.trans_lt hsum) (NNReal.coe_pos.mpr herror) + have hinsideStrict : + μH[1] (D ∩ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2)))) < Metric.ediam C := by + calc + μH[1] (D ∩ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + (∑' V : W, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) + + ENNReal.ofReal (error : ℝ) := + hDinside + _ ≤ (∑' i, Metric.ediam (U i)) + (error : ℝ≥0∞) := by + simpa only [ENNReal.ofReal_coe_nnreal, add_comm] using + add_le_add_right hWsum (error : ℝ≥0∞) + _ < Metric.ediam C := hbudget + have hchargedSubset : + D \ (C \ ⋃ i, U i) ⊆ D ∩ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2))) := by + rintro z ⟨hzD, hzcore⟩ + refine ⟨hzD, ?_⟩ + by_contra hzW + have hzoutside := hDoutside ⟨hzD, hzW⟩ + apply hzcore + exact ⟨hzoutside.1, fun hzU ↦ hzW (hcover hzU)⟩ + have hcharged : μH[1] (D \ (C \ ⋃ i, U i)) < Metric.ediam C := + (measure_mono hchargedSubset).trans_lt hinsideStrict + have hinsideOriginal : μH[1] (D ∩ ⋃ i, U i) < Metric.ediam C := by + apply (measure_mono ?_).trans_lt hcharged + rintro z ⟨hzD, hzU⟩ + exact ⟨hzD, fun hzcore ↦ hzcore.2 hzU⟩ + have hdecomp : D ⊆ (C \ ⋃ i, U i) ∪ (D \ (C \ ⋃ i, U i)) := by + intro z hzD + by_cases hzcore : z ∈ C \ ⋃ i, U i + · exact Or.inl hzcore + · exact Or.inr ⟨hzD, hzcore⟩ + have htotal : μH[1] D ≤ μH[1] (C \ ⋃ i, U i) + Metric.ediam C := by + calc + μH[1] D ≤ μH[1] ((C \ ⋃ i, U i) ∪ (D \ (C \ ⋃ i, U i))) := + measure_mono hdecomp + _ ≤ μH[1] (C \ ⋃ i, U i) + μH[1] (D \ (C \ ⋃ i, U i)) := + measure_union_le _ _ + _ ≤ μH[1] (C \ ⋃ i, U i) + Metric.ediam C := by + gcongr + exact ⟨D, hDcompact, hDconnected, hxD, hyD, hDediam, hDhull, + hcharged, hinsideOriginal, htotal⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/ConvexAttachment.lean b/LeanPool/Besicovitch/Rectifiability/ConvexAttachment.lean new file mode 100644 index 0000000000..17dcd475f4 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/ConvexAttachment.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexSets +public import Mathlib.Topology.MetricSpace.Bounded + +/-! +# Compact convex attachments + +For each selected hole, the continuum construction attaches the closed convex hull of the core +points in its two-diameter enlargement. +-/ + +@[expose] public section + +noncomputable section + +open Bornology Set + +namespace LeanPool.Besicovitch + +/-- The compact convex piece attached to the core near a selected hole. -/ +def convexAttachment (F V : Set (EuclideanSpace ℝ (Fin 2))) : Set (EuclideanSpace ℝ (Fin 2)) := + closure (convexHull ℝ (F ∩ diameterThickening 2 V)) + +/-- A convex attachment is closed and convex. -/ +theorem isClosed_convexAttachment (F V : Set (EuclideanSpace ℝ (Fin 2))) : + IsClosed (convexAttachment F V) := + isClosed_closure + +theorem convex_convexAttachment (F V : Set (EuclideanSpace ℝ (Fin 2))) : + Convex ℝ (convexAttachment F V) := + (convex_convexHull ℝ (F ∩ diameterThickening 2 V)).closure + +/-- Attachments to a compact core are compact. -/ +theorem isCompact_convexAttachment {F V : Set (EuclideanSpace ℝ (Fin 2))} (hF : IsCompact F) : + IsCompact (convexAttachment F V) := by + apply Metric.isCompact_iff_isClosed_bounded.2 + refine ⟨isClosed_convexAttachment F V, ?_⟩ + apply Bornology.IsBounded.closure + rw [isBounded_convexHull] + exact hF.isBounded.subset inter_subset_left + +/-- Every core point already in a hole belongs to its attachment. -/ +theorem inter_subset_convexAttachment {F V : Set (EuclideanSpace ℝ (Fin 2))} + (hdiam : 0 < Metric.diam V) : + F ∩ V ⊆ convexAttachment F V := by + intro x hx + apply subset_closure + apply subset_convexHull ℝ + exact ⟨hx.1, subset_diameterThickening (by positivity) hx.2⟩ + +/-- An attachment has diameter at most five times the diameter of its hole. -/ +theorem diam_convexAttachment_le {F V : Set (EuclideanSpace ℝ (Fin 2))} (hV : IsBounded V) : + Metric.diam (convexAttachment F V) ≤ 5 * Metric.diam V := by + calc + Metric.diam (convexAttachment F V) = + Metric.diam (convexHull ℝ (F ∩ diameterThickening 2 V)) := + Metric.diam_closure _ + _ = Metric.diam (F ∩ diameterThickening 2 V) := convexHull_diam _ + _ ≤ Metric.diam (diameterThickening 2 V) := + Metric.diam_mono inter_subset_right hV.thickening + _ ≤ 5 * Metric.diam V := by + convert diam_diameterThickening_le (by norm_num : (0 : ℝ) ≤ 2) V using 1 + all_goals norm_num + +/-- The same five-fold bound holds for extended diameter. -/ +theorem ediam_convexAttachment_le {F V : Set (EuclideanSpace ℝ (Fin 2))} (hV : IsBounded V) : + Metric.ediam (convexAttachment F V) ≤ ENNReal.ofReal 5 * Metric.ediam V := by + calc + Metric.ediam (convexAttachment F V) = + Metric.ediam (convexHull ℝ (F ∩ diameterThickening 2 V)) := + Metric.ediam_closure _ + _ = Metric.ediam (F ∩ diameterThickening 2 V) := convexHull_ediam _ + _ ≤ Metric.ediam (diameterThickening 2 V) := Metric.ediam_mono inter_subset_right + _ ≤ ENNReal.ofReal 5 * Metric.ediam V := by + convert ediam_diameterThickening_le (by norm_num : (0 : ℝ) ≤ 2) hV using 1 + all_goals norm_num + +/-- For a positive-diameter convex hole, its attachment lies in the three-diameter enlargement. -/ +theorem convexAttachment_subset_diameterThickening_three {F V : Set (EuclideanSpace ℝ (Fin 2))} + (hV_convex : Convex ℝ V) (hdiam : 0 < Metric.diam V) : + convexAttachment F V ⊆ diameterThickening 3 V := by + rw [convexAttachment, diameterThickening] + calc + closure (convexHull ℝ (F ∩ diameterThickening 2 V)) ⊆ + closure (diameterThickening 2 V) := by + apply closure_mono + apply convexHull_min inter_subset_right + exact hV_convex.thickening _ + _ ⊆ Metric.cthickening (2 * Metric.diam V) V := by + exact Metric.closure_thickening_subset_cthickening _ _ + _ ⊆ Metric.thickening (3 * Metric.diam V) V := by + apply Metric.cthickening_subset_thickening' + · positivity + · nlinarith + +/-- A bad hole has a nonempty compact connected attachment. -/ +theorem convexAttachment_isCompact_isConnected + {mu : MeasureTheory.Measure (EuclideanSpace ℝ (Fin 2))} + {F V : Set (EuclideanSpace ℝ (Fin 2))} {alpha : ℝ} (hF : IsCompact F) + (halpha : 0 < alpha) (hV : V ∈ badConvexSets mu F alpha) : + IsCompact (convexAttachment F V) ∧ IsConnected (convexAttachment F V) := by + have hdiam := diam_pos_of_mem_badConvexSets halpha hV + have hnonempty : (convexAttachment F V).Nonempty := by + obtain ⟨x, hxV, hxF⟩ := hV.2.2.1 + exact ⟨x, inter_subset_convexAttachment hdiam ⟨hxF, hxV⟩⟩ + exact ⟨isCompact_convexAttachment hF, + ⟨hnonempty, (convex_convexAttachment F V).isPreconnected⟩⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/Decomposition.lean b/LeanPool/Besicovitch/Rectifiability/Decomposition.lean new file mode 100644 index 0000000000..eca3cf2a88 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/Decomposition.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.Basic +public import Mathlib.Topology.Compactness.SigmaCompact +public import Mathlib.Topology.Order.IsLUB + +/-! +# Rectifiable and purely unrectifiable parts + +A finite measurable set splits into a countably one-rectifiable part and a measurable purely +one-unrectifiable remainder. The proof maximizes the measure captured by countably many +Lipschitz curves; it does not assume a decomposition theorem from outside Mathlib. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory NNReal Topology + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- A countable union of ranges of Lipschitz curves is measurable. -/ +theorem measurableSet_iUnion_range_of_lipschitz {f : ℕ → ℝ → X} + (hf : ∀ i, ∃ K : ℝ≥0, LipschitzWith K (f i)) : + MeasurableSet (⋃ i, range (f i)) := by + apply MeasurableSet.iUnion + intro i + obtain ⟨K, hK⟩ := hf i + have hcompact : IsSigmaCompact (range (f i)) := by + rw [← image_univ] + exact isSigmaCompact_univ.image hK.continuous + obtain ⟨sets, sets_compact, hsets⟩ := hcompact + rw [← hsets] + exact MeasurableSet.iUnion fun n ↦ (sets_compact n).isClosed.measurableSet + +/-- A rectifiable set is covered up to a null set by a measurable rectifiable set. -/ +theorem IsCountablyOneRectifiable.exists_measurable_cover {s : Set X} + (hs : IsCountablyOneRectifiable s) : + ∃ t : Set X, MeasurableSet t ∧ IsCountablyOneRectifiable t ∧ μH[1] (s \ t) = 0 := by + obtain ⟨f, hf, hnull⟩ := hs + refine ⟨⋃ i, range (f i), measurableSet_iUnion_range_of_lipschitz hf, ?_, hnull⟩ + exact ⟨f, hf, by simp⟩ + +/-- Every finite measurable set is the disjoint union of a rectifiable part and a purely +unrectifiable part. -/ +theorem exists_rectifiable_pure_decomposition [Nonempty X] {s : Set X} + (hs : MeasurableSet s) (hfinite : μH[1] s < ∞) : + ∃ r p : Set X, + MeasurableSet r ∧ MeasurableSet p ∧ r ⊆ s ∧ p = s \ r ∧ + IsCountablyOneRectifiable r ∧ IsPurelyOneUnrectifiable p := by + let candidates : Set (Set X) := + {t | MeasurableSet t ∧ t ⊆ s ∧ IsCountablyOneRectifiable t} + let masses : Set ℝ := {a | ∃ t ∈ candidates, a = (μH[1] t).toReal} + have candidates_empty : (∅ : Set X) ∈ candidates := by + exact ⟨MeasurableSet.empty, empty_subset s, isCountablyOneRectifiable_empty⟩ + have masses_nonempty : masses.Nonempty := by + exact ⟨0, ∅, candidates_empty, by simp⟩ + have masses_bddAbove : BddAbove masses := by + refine ⟨(μH[1] s).toReal, ?_⟩ + rintro a ⟨t, ht, rfl⟩ + exact ENNReal.toReal_mono (ne_of_lt hfinite) (measure_mono ht.2.1) + obtain ⟨u, -, hu_tendsto, hu_mem⟩ := + exists_seq_tendsto_sSup masses_nonempty masses_bddAbove + choose pieces hpieces hu_eq using hu_mem + have pieces_candidate (n : ℕ) : pieces n ∈ candidates := hpieces n + let r : Set X := ⋃ n, pieces n + have r_measurable : MeasurableSet r := by + exact MeasurableSet.iUnion fun n ↦ (pieces_candidate n).1 + have r_subset : r ⊆ s := by + exact iUnion_subset fun n ↦ (pieces_candidate n).2.1 + have r_rectifiable : IsCountablyOneRectifiable r := by + exact isCountablyOneRectifiable_iUnion fun n ↦ (pieces_candidate n).2.2 + have r_finite : μH[1] r ≠ ∞ := by + exact ne_of_lt ((measure_mono r_subset).trans_lt hfinite) + have r_mass_mem : (μH[1] r).toReal ∈ masses := by + exact ⟨r, ⟨r_measurable, r_subset, r_rectifiable⟩, rfl⟩ + have supremum_eq : sSup masses = (μH[1] r).toReal := by + apply le_antisymm + · apply le_of_tendsto hu_tendsto + filter_upwards [] with n + rw [hu_eq n] + exact ENNReal.toReal_mono r_finite (measure_mono (subset_iUnion pieces n)) + · exact le_csSup masses_bddAbove r_mass_mem + let p : Set X := s \ r + have p_measurable : MeasurableSet p := hs.diff r_measurable + have p_pure : IsPurelyOneUnrectifiable p := by + intro t ht + obtain ⟨cover, cover_measurable, cover_rectifiable, ht_null⟩ := ht.exists_measurable_cover + have p_inter_cover_rectifiable : IsCountablyOneRectifiable (p ∩ cover) := + cover_rectifiable.mono inter_subset_right + have p_inter_cover_subset : p ∩ cover ⊆ s := by + intro x hx + exact hx.1.1 + have union_candidate : r ∪ (p ∩ cover) ∈ candidates := by + refine ⟨r_measurable.union (p_measurable.inter cover_measurable), ?_, + r_rectifiable.union p_inter_cover_rectifiable⟩ + exact union_subset r_subset p_inter_cover_subset + have union_mass_le : (μH[1] (r ∪ (p ∩ cover))).toReal ≤ (μH[1] r).toReal := by + rw [← supremum_eq] + exact le_csSup masses_bddAbove ⟨_, union_candidate, rfl⟩ + have p_inter_cover_finite : μH[1] (p ∩ cover) ≠ ∞ := by + exact ne_of_lt ((measure_mono p_inter_cover_subset).trans_lt hfinite) + have disjoint_parts : Disjoint r (p ∩ cover) := by + rw [disjoint_left] + intro x hxr hxp + exact hxp.1.2 hxr + have p_inter_cover_null : μH[1] (p ∩ cover) = 0 := by + rw [measure_union disjoint_parts (p_measurable.inter cover_measurable), + ENNReal.toReal_add r_finite p_inter_cover_finite] at union_mass_le + have : (μH[1] (p ∩ cover)).toReal = 0 := by + linarith [ENNReal.toReal_nonneg (a := μH[1] (p ∩ cover))] + exact ((ENNReal.toReal_eq_zero_iff _).mp this).resolve_right p_inter_cover_finite + apply measure_mono_null ?_ (measure_union_null p_inter_cover_null ht_null) + intro x hx + by_cases hxc : x ∈ cover + · exact Or.inl ⟨hx.1, hxc⟩ + · exact Or.inr ⟨hx.2, hxc⟩ + exact ⟨r, p, r_measurable, p_measurable, r_subset, rfl, r_rectifiable, p_pure⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/DensityPoint.lean b/LeanPool/Besicovitch/Rectifiability/DensityPoint.lean new file mode 100644 index 0000000000..48fedabf58 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/DensityPoint.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.BadConvexThickening +public import Mathlib.MeasureTheory.Covering.BesicovitchVectorSpace + +/-! +# A density point outside the enlarged holes + +Lebesgue differentiation lets us choose the point outside the seven-diameter enlargements so that +the mass missing from the compact core is linearly small in every sufficiently small ball. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory Topology + +namespace LeanPool.Besicovitch + +/-- A straight measure assigns at most `2r` mass to a closed ball of radius `r`. -/ +theorem IsStraightMeasure.measure_closedBall_le {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) (z : (EuclideanSpace ℝ (Fin 2))) (r : ℝ) : + mu (Metric.closedBall z r) ≤ ENNReal.ofReal (2 * r) := by + apply (hmu _ measurableSet_closedBall).trans + apply Metric.ediam_le_of_forall_dist_le + intro x hx y hy + have hxz : dist x z ≤ r := Metric.mem_closedBall.mp hx + have hzy : dist z y ≤ r := by simpa [dist_comm] using Metric.mem_closedBall.mp hy + exact (dist_triangle x z y).trans (by linarith) + +/-- A lower ball-mass bound and a small loss outside the core leave a core point in the outer +annulus. -/ +theorem annulus_inter_nonempty {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) {F : Set (EuclideanSpace ℝ (Fin 2))} + {z : (EuclideanSpace ℝ (Fin 2))} {sigma alpha rho : ℝ} + (hsigma : 0 < sigma) (halpha_pos : 0 < alpha) (halpha : alpha < 28) (hrho : 0 < rho) + (hball : ENNReal.ofReal (2 * sigma * rho) < mu (Metric.ball z rho)) + (hloss : mu (Metric.ball z rho \ F) < ENNReal.ofReal (sigma * alpha / 28 * rho)) : + ((Metric.ball z rho \ Metric.ball z (sigma * rho / 2)) ∩ F).Nonempty := by + by_contra hempty + rw [not_nonempty_iff_eq_empty] at hempty + have hsubset : Metric.ball z rho ⊆ + (Metric.ball z rho \ F) ∪ Metric.ball z (sigma * rho / 2) := by + intro x hx + by_cases hxF : x ∈ F + · by_cases hxinner : x ∈ Metric.ball z (sigma * rho / 2) + · exact Or.inr hxinner + · have : x ∈ (Metric.ball z rho \ Metric.ball z (sigma * rho / 2)) ∩ F := + ⟨⟨hx, hxinner⟩, hxF⟩ + rw [hempty] at this + exact this.elim + · exact Or.inl ⟨hx, hxF⟩ + have hinner : mu (Metric.ball z (sigma * rho / 2)) ≤ ENNReal.ofReal (sigma * rho) := by + calc + mu (Metric.ball z (sigma * rho / 2)) ≤ + mu (Metric.closedBall z (sigma * rho / 2)) := + measure_mono Metric.ball_subset_closedBall + _ ≤ ENNReal.ofReal (2 * (sigma * rho / 2)) := + hmu.measure_closedBall_le z (sigma * rho / 2) + _ = ENNReal.ofReal (sigma * rho) := by ring_nf + have hupper : mu (Metric.ball z rho) < ENNReal.ofReal (2 * sigma * rho) := by + calc + mu (Metric.ball z rho) ≤ + mu (Metric.ball z rho \ F) + mu (Metric.ball z (sigma * rho / 2)) := + (measure_mono hsubset).trans (measure_union_le _ _) + _ < ENNReal.ofReal (sigma * alpha / 28 * rho) + + ENNReal.ofReal (sigma * rho) := + ENNReal.add_lt_add_of_lt_of_le (ne_top_of_le_ne_top ENNReal.ofReal_ne_top hinner) + hloss hinner + _ = ENNReal.ofReal (sigma * alpha / 28 * rho + sigma * rho) := by + rw [ENNReal.ofReal_add (by positivity) (by positivity)] + _ < ENNReal.ofReal (2 * sigma * rho) := by + apply (ENNReal.ofReal_lt_ofReal_iff_of_nonneg (by positivity)).2 + have halpha' : alpha / 28 < 1 := (div_lt_one (by norm_num)).2 halpha + nlinarith [mul_lt_mul_of_pos_left halpha' (mul_pos hsigma hrho)] + exact (not_lt_of_ge hball.le) hupper + +/-- At a density point of `F`, straightness makes the mass outside `F` smaller than any prescribed +positive linear function of the radius. -/ +theorem exists_scale_measure_ball_sdiff_lt + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + (hmu : IsStraightMeasure mu) {F : Set (EuclideanSpace ℝ (Fin 2))} + {z : (EuclideanSpace ℝ (Fin 2))} + (hdensity : Tendsto + (fun r ↦ mu (Fᶜ ∩ Metric.closedBall z r) / mu (Metric.closedBall z r)) + (𝓝[>] 0) (𝓝 0)) {k : ℝ} (hk : 0 < k) : + ∃ scale : ℝ, 0 < scale ∧ ∀ r : ℝ, 0 < r → r < scale → + mu (Metric.ball z r \ F) < ENNReal.ofReal (k * r) := by + have hepsilon : 0 < ENNReal.ofReal (k / 2) := ENNReal.ofReal_pos.2 (by positivity) + have heventually : ∀ᶠ r in 𝓝[>] (0 : ℝ), + mu (Fᶜ ∩ Metric.closedBall z r) / mu (Metric.closedBall z r) < + ENNReal.ofReal (k / 2) := + hdensity.eventually (Iio_mem_nhds hepsilon) + obtain ⟨neighborhood, hneighborhood, hsubset⟩ := + mem_nhdsWithin_iff_exists_mem_nhds_inter.mp heventually + obtain ⟨scale, hscale, hball⟩ := Metric.mem_nhds_iff.mp hneighborhood + refine ⟨scale, hscale, fun r hr hrscale ↦ ?_⟩ + have hr_mem : r ∈ neighborhood ∩ Ioi (0 : ℝ) := by + refine ⟨hball ?_, hr⟩ + simpa [Real.dist_eq, abs_of_pos hr] using hrscale + have hratio := hsubset hr_mem + have hset : Metric.ball z r \ F ⊆ Fᶜ ∩ Metric.closedBall z r := by + intro x hx + exact ⟨hx.2, Metric.ball_subset_closedBall hx.1⟩ + by_cases hball_zero : mu (Metric.closedBall z r) = 0 + · have houtside_zero : mu (Metric.ball z r \ F) = 0 := + measure_mono_null hset (measure_mono_null inter_subset_right hball_zero) + rw [houtside_zero] + exact ENNReal.ofReal_pos.2 (mul_pos hk hr) + · have hnumerator : mu (Fᶜ ∩ Metric.closedBall z r) < + ENNReal.ofReal (k / 2) * mu (Metric.closedBall z r) := by + exact (ENNReal.div_lt_iff (Or.inl hball_zero) + (Or.inl (ne_top_of_le_ne_top ENNReal.ofReal_ne_top + (hmu.measure_closedBall_le z r)))).mp hratio + calc + mu (Metric.ball z r \ F) ≤ mu (Fᶜ ∩ Metric.closedBall z r) := measure_mono hset + _ < ENNReal.ofReal (k / 2) * mu (Metric.closedBall z r) := hnumerator + _ ≤ ENNReal.ofReal (k / 2) * ENNReal.ofReal (2 * r) := by + gcongr + exact hmu.measure_closedBall_le z r + _ = ENNReal.ofReal (k * r) := by + rw [← ENNReal.ofReal_mul (by positivity : 0 ≤ k / 2)] + congr 1 + ring + +/-- One may choose the point outside all seven-diameter enlargements to be a density point of the +compact core. -/ +theorem exists_densityPoint_not_mem_sevenDiameterThickening + {mu : Measure (EuclideanSpace ℝ (Fin 2))} + [IsFiniteMeasure mu] (hmu : IsStraightMeasure mu) {F : Set (EuclideanSpace ℝ (Fin 2))} + (hF : MeasurableSet F) {alpha : ℝ} (halpha : 0 < alpha) + {chosen : Set (Set (EuclideanSpace ℝ (Fin 2)))} + (hchosen : chosen ⊆ badConvexSets mu F alpha) + (hcountable : chosen.Countable) (hdisjoint : chosen.PairwiseDisjoint id) + (houtside : mu Fᶜ < ENNReal.ofReal (alpha / 15) * mu F) {k : ℝ} (hk : 0 < k) : + ∃ z ∈ F, + (∀ V : chosen, z ∉ diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2)))) ∧ + ∃ scale : ℝ, 0 < scale ∧ ∀ r : ℝ, 0 < r → r < scale → + mu (Metric.ball z r \ F) < ENNReal.ofReal (k * r) := by + let U := ⋃ V : chosen, diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2))) + have hU_open : IsOpen U := isOpen_iUnion fun V ↦ + isOpen_diameterThickening 7 (V : Set (EuclideanSpace ℝ (Fin 2))) + have hmeasure : mu U < mu F := + measure_iUnion_sevenDiameterThickening_lt hmu hF halpha hchosen hcountable + hdisjoint houtside + have hremaining_ne : mu (F \ U) ≠ 0 := by + intro hzero + have hdecomposition := measure_sdiff_add_inter (μ := mu) F hU_open.measurableSet + rw [hzero, zero_add] at hdecomposition + have hle : mu F ≤ mu U := by + rw [← hdecomposition] + exact measure_mono inter_subset_right + exact (not_le_of_gt hmeasure) hle + have hae := _root_.Besicovitch.ae_tendsto_measure_inter_div_of_measurableSet mu hF.compl + have hae_remaining : ∀ᵐ z ∂mu.restrict (F \ U), + Tendsto (fun r ↦ mu (Fᶜ ∩ Metric.closedBall z r) / mu (Metric.closedBall z r)) + (𝓝[>] 0) (𝓝 ((Fᶜ).indicator 1 z)) := + ae_mono Measure.restrict_le_self hae + obtain ⟨z, hz, hzdensity⟩ := + Measure.exists_mem_of_measure_ne_zero_of_ae hremaining_ne hae_remaining + have hindicator : (Fᶜ).indicator (1 : (EuclideanSpace ℝ (Fin 2)) → ℝ≥0∞) z = 0 := by + simp [hz.1] + rw [hindicator] at hzdensity + obtain ⟨scale, hscale, hsmall⟩ := + exists_scale_measure_ball_sdiff_lt hmu hzdensity hk + refine ⟨z, hz.1, ?_, scale, hscale, hsmall⟩ + intro V hzV + exact hz.2 (mem_iUnion_of_mem V hzV) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/FiniteContinuum.lean b/LeanPool/Besicovitch/Rectifiability/FiniteContinuum.lean new file mode 100644 index 0000000000..88ad7282c7 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/FiniteContinuum.lean @@ -0,0 +1,714 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Rectifiability.Continuum +public import LeanPool.Besicovitch.Rectifiability.Basic +public import Mathlib.Analysis.Normed.Affine.AddTorsor +public import Mathlib.Analysis.SpecificLimits.Basic +public import Mathlib.Combinatorics.SimpleGraph.Acyclic +public import Mathlib.Topology.ContinuousMap.Bounded.ArzelaAscoli +public import Mathlib.Topology.MetricSpace.CoveringNumbers + +/-! +# Finite-length continua + +Compact connected subsets of the Euclidean plane with finite Hausdorff one-measure have a +Lipschitz parametrization. This is the Eilenberg--Harrold finite-length continuum theorem. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set Topology +open scoped BoundedContinuousFunction ENNReal NNReal unitInterval + +namespace LeanPool.Besicovitch + +private theorem exists_short_closed_walk {V : Type*} [Fintype V] (G : SimpleGraph V) + (hG : G.Connected) : + ∃ v, ∃ p : G.Walk v v, (∀ w, w ∈ p.support) ∧ + p.length ≤ 2 * (Fintype.card V - 1) := by + classical + induction hn : Fintype.card V using Nat.strong_induction_on generalizing V with | h n ih => ?_ + by_cases hcard : Fintype.card V = 1 + · let v : V := Classical.choice hG.nonempty + refine ⟨v, .nil, ?_, by simp⟩ + intro w + simp only [SimpleGraph.Walk.support_nil, List.mem_singleton] + exact Fintype.card_le_one_iff.mp hcard.le w v + · have hcard_two : 2 ≤ Fintype.card V := by + have hcard_pos : 0 < Fintype.card V := Fintype.card_pos_iff.mpr hG.nonempty + omega + let : Nontrivial V := Fintype.one_lt_card_iff_nontrivial.mp hcard_two + obtain ⟨v, hv⟩ := hG.exists_connected_induce_compl_singleton_of_finite_nontrivial + let t : Set V := {v}ᶜ + let : Fintype t := Fintype.ofFinite t + have ht_card_eq : Fintype.card t = Fintype.card V - 1 := by + rw [Fintype.card_eq_nat_card, Fintype.card_eq_nat_card] + simpa [t] using Set.ncard_compl ({v} : Set V) + have ht_card : Fintype.card t < Fintype.card V := by rw [ht_card_eq]; omega + obtain ⟨r, p, hp, hp_len⟩ := ih (Fintype.card t) (hn ▸ ht_card) (G.induce t) hv rfl + have hv_support : v ∈ G.support := by simp [hG.preconnected.support_eq_univ] + obtain ⟨u, hvu⟩ : ∃ u, G.Adj v u := hv_support + have hu_ne : u ≠ v := hvu.ne' + let u' : t := ⟨u, by simp [t, hu_ne]⟩ + have hu'_mem : u' ∈ p.support := hp u' + let q : G.Walk u u := + (p.rotate u' hu'_mem).map (SimpleGraph.Embedding.induce t).toHom + let e : G.Walk u u := .cons hvu.symm (.cons hvu .nil) + refine ⟨u, q.append e, ?_, ?_⟩ + · intro w + by_cases hw : w = v + · subst w + exact SimpleGraph.Walk.support_subset_support_append_right q e (by simp [e]) + · let w' : t := ⟨w, by simp [t, hw]⟩ + apply SimpleGraph.Walk.support_subset_support_append_left q e + change w ∈ ((p.rotate u' hu'_mem).map + (SimpleGraph.Embedding.induce t).toHom).support + rw [SimpleGraph.Walk.support_map] + apply List.mem_map.mpr + exact ⟨w', (SimpleGraph.Walk.mem_support_rotate_iff p u' hu'_mem).mpr (hp w'), rfl⟩ + · rw [SimpleGraph.Walk.length_append] + have hq_len : q.length = p.length := by + change ((p.rotate u' hu'_mem).map + (SimpleGraph.Embedding.induce t).toHom).length = p.length + rw [SimpleGraph.Walk.length_map, SimpleGraph.Walk.length_rotate] + have he_len : e.length = 2 := by simp [e] + rw [hq_len, he_len] + rw [ht_card_eq, hn] at hp_len + omega + +/-- The polygonal chain through `x :: l`, with one unit of time allotted to each edge. -/ +private def polygonalChain (x : (EuclideanSpace ℝ (Fin 2))) : + List (EuclideanSpace ℝ (Fin 2)) → ℝ → (EuclideanSpace ℝ (Fin 2)) + | [], _ => x + | y :: l, t => + if t < 1 then AffineMap.lineMap x y t else polygonalChain y l (t - 1) + +@[simp] +private theorem polygonalChain_nil (x : (EuclideanSpace ℝ (Fin 2))) : + polygonalChain x [] = fun _ ↦ x := rfl + +@[simp] +private theorem polygonalChain_zero (x : (EuclideanSpace ℝ (Fin 2))) + (l : List (EuclideanSpace ℝ (Fin 2))) : + polygonalChain x l 0 = x := by + cases l <;> simp [polygonalChain] + +private theorem polygonalChain_cons_of_lt (x y : (EuclideanSpace ℝ (Fin 2))) + (l : List (EuclideanSpace ℝ (Fin 2))) {t : ℝ} + (ht : t < 1) : polygonalChain x (y :: l) t = AffineMap.lineMap x y t := by + simp [polygonalChain, ht] + +private theorem polygonalChain_cons_of_one_le (x y : (EuclideanSpace ℝ (Fin 2))) + (l : List (EuclideanSpace ℝ (Fin 2))) {t : ℝ} + (ht : 1 ≤ t) : polygonalChain x (y :: l) t = polygonalChain y l (t - 1) := by + simp [polygonalChain, ht.not_gt] + +private theorem polygonalChain_dist_le_crossing + {x y : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} {δ : ℝ≥0} + (hxy : dist x y ≤ δ) + (htail : LipschitzOnWith δ (polygonalChain y l) (Icc (0 : ℝ) l.length)) + {a b : ℝ} (ha_one : a < 1) (hb_one : 1 ≤ b) + (hb_upper : b ≤ (l.length : ℝ) + 1) : + dist (polygonalChain x (y :: l) a) (polygonalChain x (y :: l) b) ≤ δ * dist a b := by + have hb_sub_mem : b - 1 ∈ Icc (0 : ℝ) l.length := by + constructor <;> linarith + rw [polygonalChain_cons_of_lt _ _ _ ha_one, + polygonalChain_cons_of_one_le _ _ _ hb_one] + calc + dist (AffineMap.lineMap x y a) (polygonalChain y l (b - 1)) ≤ + dist (AffineMap.lineMap x y a) y + dist y (polygonalChain y l (b - 1)) := + dist_triangle _ _ _ + _ ≤ δ * (1 - a) + δ * (b - 1) := by + gcongr + · rw [dist_lineMap_right, Real.norm_eq_abs, abs_of_nonneg (by linarith)] + calc + (1 - a) * dist x y ≤ (1 - a) * δ := + mul_le_mul_of_nonneg_left hxy (by linarith) + _ = δ * (1 - a) := mul_comm _ _ + · have hdist := htail.dist_le_mul 0 (by simp) (b - 1) hb_sub_mem + rw [Real.dist_eq, abs_of_nonpos (by linarith)] at hdist + have hdist' : dist (polygonalChain y l 0) (polygonalChain y l (b - 1)) ≤ + δ * (b - 1) := by + convert hdist using 1 + ring + simpa only [polygonalChain_zero] using hdist' + _ = δ * dist a b := by + rw [Real.dist_eq, abs_of_nonpos (sub_nonpos.mpr (ha_one.le.trans hb_one))] + ring + +private theorem mem_range_polygonalChain {x z : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} (hz : z ∈ x :: l) : + ∃ t ∈ Icc (0 : ℝ) l.length, polygonalChain x l t = z := by + induction l generalizing x with + | nil => + simp only [List.mem_singleton] at hz + subst z + exact ⟨0, by simp, polygonalChain_zero x []⟩ + | cons y l ih => + rcases List.mem_cons.mp hz with hzx | hz + · subst z + refine ⟨0, ⟨le_rfl, ?_⟩, polygonalChain_zero x (y :: l)⟩ + positivity + · obtain ⟨t, ht, htz⟩ := ih hz + refine ⟨t + 1, ?_, ?_⟩ + · constructor + · linarith [ht.1] + · simpa only [List.length_cons, Nat.cast_add, Nat.cast_one, add_comm] using + add_le_add_right ht.2 1 + · rw [polygonalChain_cons_of_one_le _ _ _ (by linarith [ht.1]), + add_sub_cancel_right] + exact htz + +private theorem polygonalChain_lipschitzOn {x : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} {δ : ℝ≥0} + (hchain : List.IsChain (fun a b : (EuclideanSpace ℝ (Fin 2)) ↦ dist a b ≤ δ) (x :: l)) : + LipschitzOnWith δ (polygonalChain x l) (Icc (0 : ℝ) l.length) := by + induction l generalizing x with + | nil => + simpa [polygonalChain] using + ((LipschitzWith.const (α := ℝ) x).weaken zero_le).lipschitzOnWith + | cons y l ih => + rw [List.isChain_cons_cons] at hchain + have htail := ih hchain.2 + apply LipschitzOnWith.of_dist_le_mul + intro a ha b hb + wlog hab : a ≤ b generalizing a b + · simpa only [dist_comm a b, dist_comm (polygonalChain x (y :: l) a)] using + this b hb a ha (le_of_not_ge hab) + by_cases hb_one : b < 1 + · have ha_one : a < 1 := hab.trans_lt hb_one + rw [polygonalChain_cons_of_lt _ _ _ ha_one, + polygonalChain_cons_of_lt _ _ _ hb_one] + exact (lipschitzWith_lineMap x y).weaken (by exact_mod_cast hchain.1) |>.dist_le_mul a b + by_cases ha_one : a < 1 + · apply polygonalChain_dist_le_crossing hchain.1 htail ha_one (le_of_not_gt hb_one) + simpa only [List.length_cons, Nat.cast_add, Nat.cast_one] using hb.2 + · have ha_one' : 1 ≤ a := le_of_not_gt ha_one + have hb_one' : 1 ≤ b := ha_one'.trans hab + have ha_upper : a ≤ (l.length : ℝ) + 1 := by + simpa only [List.length_cons, Nat.cast_add, Nat.cast_one] using ha.2 + have hb_upper : b ≤ (l.length : ℝ) + 1 := by + simpa only [List.length_cons, Nat.cast_add, Nat.cast_one] using hb.2 + rw [polygonalChain_cons_of_one_le _ _ _ ha_one', + polygonalChain_cons_of_one_le _ _ _ hb_one'] + simpa only [Real.dist_eq, sub_sub_sub_cancel_right] using + htail.dist_le_mul (a - 1) (by + constructor <;> linarith) (b - 1) (by + constructor <;> linarith) + +private theorem polygonalChain_near_vertex {x : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} {δ : ℝ} + (hδ : 0 ≤ δ) + (hchain : List.IsChain + (fun a b : (EuclideanSpace ℝ (Fin 2)) ↦ dist a b ≤ δ) (x :: l)) + {t : ℝ} (ht : t ∈ Icc (0 : ℝ) l.length) : + ∃ z ∈ x :: l, dist (polygonalChain x l t) z ≤ δ := by + induction l generalizing x t with + | nil => + refine ⟨x, by simp, ?_⟩ + simp only [List.length_nil, Nat.cast_zero] at ht + have : t = 0 := le_antisymm ht.2 ht.1 + simp [this, hδ] + | cons y l ih => + rw [List.isChain_cons_cons] at hchain + by_cases ht_one : t < 1 + · refine ⟨x, by simp, ?_⟩ + rw [polygonalChain_cons_of_lt _ _ _ ht_one, dist_lineMap_left, + Real.norm_eq_abs, abs_of_nonneg ht.1] + calc + t * dist x y ≤ 1 * δ := mul_le_mul ht_one.le hchain.1 dist_nonneg zero_le_one + _ = δ := one_mul δ + · have ht_one' : 1 ≤ t := le_of_not_gt ht_one + obtain ⟨z, hz, hdist⟩ := ih hchain.2 (t := t - 1) (by + constructor <;> norm_num at ht ⊢ <;> linarith) + refine ⟨z, by simp [hz], ?_⟩ + rwa [polygonalChain_cons_of_one_le _ _ _ ht_one'] + +/-- The polygonal chain rescaled to the unit interval. -/ +private def unitPolygonalChain (x : (EuclideanSpace ℝ (Fin 2))) + (l : List (EuclideanSpace ℝ (Fin 2))) (t : I) : (EuclideanSpace ℝ (Fin 2)) := + polygonalChain x l (l.length * (t : ℝ)) + +private theorem unitPolygonalChain_lipschitz {x : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} {δ : ℝ≥0} + (hchain : List.IsChain (fun a b : (EuclideanSpace ℝ (Fin 2)) ↦ dist a b ≤ δ) (x :: l)) : + LipschitzWith (δ * l.length) (unitPolygonalChain x l) := by + have hpoly := polygonalChain_lipschitzOn hchain + apply LipschitzWith.of_dist_le_mul + intro t u + have ht : (l.length : ℝ) * (t : ℝ) ∈ Icc (0 : ℝ) l.length := by + constructor + · exact mul_nonneg (Nat.cast_nonneg _) t.2.1 + · calc + (l.length : ℝ) * (t : ℝ) ≤ l.length * 1 := + mul_le_mul_of_nonneg_left t.2.2 (Nat.cast_nonneg _) + _ = l.length := mul_one _ + have hu : (l.length : ℝ) * (u : ℝ) ∈ Icc (0 : ℝ) l.length := by + constructor + · exact mul_nonneg (Nat.cast_nonneg _) u.2.1 + · calc + (l.length : ℝ) * (u : ℝ) ≤ l.length * 1 := + mul_le_mul_of_nonneg_left u.2.2 (Nat.cast_nonneg _) + _ = l.length := mul_one _ + calc + dist (unitPolygonalChain x l t) (unitPolygonalChain x l u) ≤ + δ * dist ((l.length : ℝ) * (t : ℝ)) (l.length * (u : ℝ)) := + hpoly.dist_le_mul _ ht _ hu + _ = (δ * l.length) * dist t u := by + rw [Real.dist_eq, Subtype.dist_eq, ← mul_sub, abs_mul, + abs_of_nonneg (Nat.cast_nonneg l.length)] + rw [Real.dist_eq] + ring + +private theorem vertex_mem_range_unitPolygonalChain + {x z : (EuclideanSpace ℝ (Fin 2))} {l : List (EuclideanSpace ℝ (Fin 2))} + (hz : z ∈ x :: l) : z ∈ range (unitPolygonalChain x l) := by + obtain ⟨t, ht, htz⟩ := mem_range_polygonalChain hz + by_cases hl : l.length = 0 + · have ht_le : t ≤ 0 := by simpa [hl] using ht.2 + have ht_zero : t = 0 := le_antisymm ht_le ht.1 + have hxz : x = z := by simpa [ht_zero] using htz + refine ⟨⟨0, by simp⟩, ?_⟩ + simpa [unitPolygonalChain, hl] using hxz + · have hl_pos : (0 : ℝ) < l.length := by positivity + let u : I := ⟨t / l.length, by + constructor + · exact div_nonneg ht.1 hl_pos.le + · exact (div_le_one hl_pos).mpr ht.2⟩ + refine ⟨u, ?_⟩ + rw [unitPolygonalChain] + convert htz using 1 + dsimp only [u] + field_simp + +private theorem unitPolygonalChain_near_vertex {x : (EuclideanSpace ℝ (Fin 2))} + {l : List (EuclideanSpace ℝ (Fin 2))} {δ : ℝ} + (hδ : 0 ≤ δ) + (hchain : List.IsChain + (fun a b : (EuclideanSpace ℝ (Fin 2)) ↦ dist a b ≤ δ) (x :: l)) + (t : I) : ∃ z ∈ x :: l, dist (unitPolygonalChain x l t) z ≤ δ := by + apply polygonalChain_near_vertex hδ hchain + constructor + · exact mul_nonneg (Nat.cast_nonneg _) t.2.1 + · calc + (l.length : ℝ) * (t : ℝ) ≤ l.length * 1 := + mul_le_mul_of_nonneg_left t.2.2 (Nat.cast_nonneg _) + _ = l.length := mul_one _ + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- A connected set reaching distance `r` from `x` has at least `r` units of length inside the +closed `r`-ball about `x`. -/ +theorem hausdorffMeasure_one_inter_closedBall_ge {s : Set X} (hs : IsPreconnected s) + {x y : X} (hx : x ∈ s) (hy : y ∈ s) {r : ℝ} (hry : r ≤ dist x y) : + ENNReal.ofReal r ≤ μH[1] (s ∩ Metric.closedBall x r) := by + let f : X → ℝ := fun z ↦ dist x z + have hf : LipschitzWith 1 f := LipschitzWith.dist_right x + have hfull : Icc 0 (dist x y) ⊆ f '' s := by + simpa [f] using hs.intermediate_value hx hy hf.continuous.continuousOn + have hIcc : Icc 0 r ⊆ f '' (s ∩ Metric.closedBall x r) := by + intro t ht + have ht' : t ∈ Icc 0 (dist x y) := ⟨ht.1, ht.2.trans hry⟩ + obtain ⟨z, hz, hzt⟩ := hfull ht' + refine ⟨z, ⟨hz, ?_⟩, hzt⟩ + rw [Metric.mem_closedBall] + calc + dist z x = f z := by simp [f, dist_comm] + _ = t := hzt + _ ≤ r := ht.2 + calc + ENNReal.ofReal r = μH[1] (Icc 0 r) := by + rw [hausdorffMeasure_real, Real.volume_Icc] + simp + _ ≤ μH[1] (f '' (s ∩ Metric.closedBall x r)) := measure_mono hIcc + _ ≤ μH[1] (s ∩ Metric.closedBall x r) := by + simpa using hf.hausdorffMeasure_image_le (d := 1) zero_le_one + (s ∩ Metric.closedBall x r) + +omit [MeasurableSpace X] [BorelSpace X] in +private theorem proximityGraph_connected {s F : Set X} (hs : IsConnected s) + (hFs : F ⊆ s) {ε : ℝ≥0} (hε : 0 < ε) (hcover : Metric.IsCover (2 * ε) s F) : + (SimpleGraph.fromRel fun x y : F ↦ dist (x : X) y < 6 * ε).Connected := by + let G : SimpleGraph F := SimpleGraph.fromRel fun x y ↦ dist (x : X) y < 6 * ε + let : Nonempty F := (hcover.nonempty hs.nonempty).to_subtype + refine ⟨?_⟩ + intro u v + by_contra huv + let U : Set X := ⋃ w : F, ⋃ (_ : G.Reachable u w), Metric.ball (w : X) (3 * ε) + let V : Set X := ⋃ w : F, ⋃ (_ : ¬G.Reachable u w), Metric.ball (w : X) (3 * ε) + have hU : IsOpen U := isOpen_iUnion fun _ ↦ isOpen_iUnion fun _ ↦ Metric.isOpen_ball + have hV : IsOpen V := isOpen_iUnion fun _ ↦ isOpen_iUnion fun _ ↦ Metric.isOpen_ball + have hUV : Disjoint U V := by + rw [Set.disjoint_left] + intro z hzU hzV + obtain ⟨p, hp⟩ := Set.mem_iUnion.mp hzU + obtain ⟨hup, hzp⟩ := Set.mem_iUnion.mp hp + obtain ⟨q, hq⟩ := Set.mem_iUnion.mp hzV + obtain ⟨huq, hzq⟩ := Set.mem_iUnion.mp hq + have hpq_ne : p ≠ q := fun hpq ↦ huq (hpq ▸ hup) + have hpq_dist : dist (p : X) q < 6 * ε := calc + dist (p : X) q ≤ dist (p : X) z + dist z q := dist_triangle _ _ _ + _ < 3 * ε + 3 * ε := add_lt_add (by simpa [dist_comm] using hzp) hzq + _ = 6 * ε := by ring + have hpq : G.Adj p q := (SimpleGraph.fromRel_adj _ _ _).mpr ⟨hpq_ne, Or.inl hpq_dist⟩ + exact huq (hup.trans hpq.reachable) + have hsUV : s ⊆ U ∪ V := by + intro z hz + have hzcover := hcover.subset_iUnion_closedBall hz + simp only [Set.mem_iUnion] at hzcover + obtain ⟨w, hwF, hzw⟩ := hzcover + let w' : F := ⟨w, hwF⟩ + have hzw' : z ∈ Metric.ball (w' : X) (3 * ε) := by + rw [Metric.mem_closedBall] at hzw + rw [Metric.mem_ball] + have hε' : (0 : ℝ) < ε := by exact_mod_cast hε + norm_num at hzw ⊢ + linarith + by_cases huw : G.Reachable u w' + · left + exact Set.mem_iUnion_of_mem w' (Set.mem_iUnion_of_mem huw hzw') + · right + exact Set.mem_iUnion_of_mem w' (Set.mem_iUnion_of_mem huw hzw') + have huU : (u : X) ∈ U := by + exact Set.mem_iUnion_of_mem u (Set.mem_iUnion_of_mem (.refl u) (by + simpa only [Metric.mem_ball, dist_self] using show (0 : ℝ) < 3 * ε by positivity)) + have hvV : (v : X) ∈ V := by + exact Set.mem_iUnion_of_mem v (Set.mem_iUnion_of_mem huv (by + simpa only [Metric.mem_ball, dist_self] using show (0 : ℝ) < 3 * ε by positivity)) + rcases hs.isPreconnected.subset_or_subset hU hV hUV hsUV with hsU | hsV + · exact (Set.disjoint_left.mp hUV (hsU (hFs v.2)) hvV) + · exact (Set.disjoint_left.mp hUV huU (hsV (hFs u.2))) + +private theorem card_mul_scale_le_two_measure {s F : Set X} (hs : IsConnected s) + (hsc : IsCompact s) (hFs : F ⊆ s) (hFfin : F.Finite) {ε : ℝ≥0} + (hsep : Metric.IsSeparated (2 * ε) F) {a b : X} (ha : a ∈ s) (hb : b ∈ s) + (hε : (ε : ℝ) ≤ dist a b) (hmeasure : μH[1] s ≠ ∞) : + (F.ncard : ℝ) * ε ≤ 2 * (μH[1] s).toReal := by + let A : F → Set X := fun p ↦ s ∩ Metric.closedBall p (ε / 2) + let : Fintype F := hFfin.fintype + have hA_disjoint : Pairwise (Function.onFun Disjoint A) := by + intro p q hpq + have hpq_sep := hsep p.2 q.2 (fun hpq' ↦ hpq (Subtype.ext hpq')) + have hpq_sep' : (2 * (ε : ℝ)) < dist (p : X) q := by + have := (ENNReal.toReal_lt_toReal ENNReal.coe_ne_top + (edist_ne_top (p : X) q)).mpr hpq_sep + simpa [edist_dist] using this + apply Disjoint.mono inter_subset_right inter_subset_right + apply Metric.closedBall_disjoint_closedBall + norm_num + nlinarith [ε.coe_nonneg] + have hA_measurable (p : F) : MeasurableSet (A p) := + hsc.isClosed.measurableSet.inter measurableSet_closedBall + have hA_mass (p : F) : ENNReal.ofReal ((ε : ℝ) / 2) ≤ μH[1] (A p) := by + have hfar : (ε : ℝ) / 2 ≤ dist (p : X) a ∨ (ε : ℝ) / 2 ≤ dist (p : X) b := by + by_contra h + push Not at h + have htriangle := dist_triangle a (p : X) b + rw [dist_comm a (p : X)] at htriangle + linarith + rcases hfar with hpa | hpb + · exact hausdorffMeasure_one_inter_closedBall_ge hs.isPreconnected (hFs p.2) ha hpa + · exact hausdorffMeasure_one_inter_closedBall_ge hs.isPreconnected (hFs p.2) hb hpb + have hsum : ∑ _p : F, ENNReal.ofReal ((ε : ℝ) / 2) ≤ μH[1] s := calc + ∑ p : F, ENNReal.ofReal ((ε : ℝ) / 2) ≤ ∑ p : F, μH[1] (A p) := + Finset.sum_le_sum fun p _ ↦ hA_mass p + _ = μH[1] (⋃ p : F, A p) := by + symm + simpa only [tsum_fintype] using + MeasureTheory.measure_iUnion hA_disjoint hA_measurable + _ ≤ μH[1] s := measure_mono (by + intro z hz + simp only [Set.mem_iUnion] at hz + obtain ⟨p, hp⟩ := hz + exact hp.1) + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] at hsum + have hleft : (Fintype.card F : ℝ≥0∞) * ENNReal.ofReal ((ε : ℝ) / 2) ≠ ∞ := + ENNReal.mul_ne_top (by simp) (by simp) + have hsum' := (ENNReal.toReal_le_toReal hleft hmeasure).mpr hsum + rw [ENNReal.toReal_mul, ENNReal.toReal_natCast, + ENNReal.toReal_ofReal (by positivity)] at hsum' + have hcard : F.ncard = Fintype.card F := by + rw [← Nat.card_coe_set_eq F, Nat.card_eq_fintype_card] + rw [hcard] + linarith + +omit [MeasurableSpace X] [BorelSpace X] in +private theorem exists_finite_separated_cover (s : Set X) (hsc : IsCompact s) {ε : ℝ≥0} + (hε : 0 < ε) : ∃ F : Set X, F.Finite ∧ F ⊆ s ∧ Metric.IsSeparated (2 * ε) F ∧ + Metric.IsCover (2 * ε) s F := by + obtain ⟨N, -, hNfin, hNcover⟩ := Metric.exists_finite_isCover_of_isCompact hε.ne' hsc + have hexternal : Metric.externalCoveringNumber ε s ≠ ⊤ := + ne_top_of_le_ne_top hNfin.encard_lt_top.ne hNcover.externalCoveringNumber_le_encard + have hpacking : Metric.packingNumber (2 * ε) s ≠ ⊤ := + ne_top_of_le_ne_top hexternal (Metric.packingNumber_two_mul_le_externalCoveringNumber ε s) + let F : Set X := Metric.maximalSeparatedSet (2 * ε) s + have hFfin : F.Finite := by + simp only [F, Metric.maximalSeparatedSet, dite_eq_left hpacking] + exact (Metric.exists_set_encard_eq_packingNumber hpacking).choose_spec.2.1 + exact ⟨F, hFfin, Metric.maximalSeparatedSet_subset, Metric.isSeparated_maximalSeparatedSet, + Metric.isCover_maximalSeparatedSet hpacking⟩ + +private theorem exists_short_polygonal_tour + {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsConnected s) + (hsc : IsCompact s) {a b : (EuclideanSpace ℝ (Fin 2))} (ha : a ∈ s) (hb : b ∈ s) + (hmeasure : μH[1] s ≠ ∞) {ε : ℝ≥0} (hεpos : 0 < ε) + (hεdiam : (ε : ℝ) ≤ dist a b) : + ∃ v : (EuclideanSpace ℝ (Fin 2)), ∃ l : List (EuclideanSpace ℝ (Fin 2)), + List.IsChain (fun x y : (EuclideanSpace ℝ (Fin 2)) ↦ dist x y ≤ 6 * ε) (v :: l) ∧ + (∀ x ∈ v :: l, x ∈ s) ∧ + (∀ x ∈ s, ∃ y ∈ v :: l, dist x y ≤ 2 * ε) ∧ + (6 * (ε : ℝ)) * l.length ≤ 24 * (μH[1] s).toReal := by + obtain ⟨F, hFfin, hFs, hFsep, hFcover⟩ := exists_finite_separated_cover s hsc hεpos + let : Fintype F := hFfin.fintype + let G : SimpleGraph F := SimpleGraph.fromRel fun x y ↦ + dist (x : (EuclideanSpace ℝ (Fin 2))) y < 6 * ε + have hG : G.Connected := proximityGraph_connected hs hFs hεpos hFcover + obtain ⟨v, p, hp, hp_len⟩ := exists_short_closed_walk G hG + let l : List (EuclideanSpace ℝ (Fin 2)) := p.support.tail.map Subtype.val + have hl_len : l.length = p.length := by + simp only [l, List.length_map, List.length_tail, p.length_support] + omega + have hlist : (v : (EuclideanSpace ℝ (Fin 2))) :: l = p.support.map Subtype.val := by + rw [← p.cons_tail_support] + rfl + have hchain : List.IsChain + (fun x y : (EuclideanSpace ℝ (Fin 2)) ↦ dist x y ≤ 6 * ε) + ((v : (EuclideanSpace ℝ (Fin 2))) :: l) := by + rw [hlist, List.isChain_map] + apply p.isChain_adj_support.imp + intro x y hxy + rcases (SimpleGraph.fromRel_adj _ x y).mp hxy |>.2 with hxy | hxy + · exact hxy.le + · simpa only [dist_comm] using hxy.le + have hvertices : ∀ x ∈ (v : (EuclideanSpace ℝ (Fin 2))) :: l, x ∈ s := by + intro x hx + rw [hlist] at hx + obtain ⟨w, -, rfl⟩ := List.mem_map.mp hx + exact hFs w.2 + have hnet : ∀ x ∈ s, + ∃ y ∈ (v : (EuclideanSpace ℝ (Fin 2))) :: l, dist x y ≤ 2 * ε := by + intro x hx + have hxcover := hFcover.subset_iUnion_closedBall hx + simp only [Set.mem_iUnion] at hxcover + obtain ⟨w, hwF, hxw⟩ := hxcover + let w' : F := ⟨w, hwF⟩ + refine ⟨w, ?_, hxw⟩ + rw [hlist] + exact List.mem_map.mpr ⟨w', hp w', rfl⟩ + have hcard := card_mul_scale_le_two_measure hs hsc hFs hFfin hFsep ha hb hεdiam hmeasure + have hcard_eq : F.ncard = Fintype.card F := by + rw [← Nat.card_coe_set_eq F, Nat.card_eq_fintype_card] + rw [hcard_eq] at hcard + have hp_len' : p.length ≤ 2 * Fintype.card F := by omega + have hp_len_real : (p.length : ℝ) ≤ 2 * Fintype.card F := by exact_mod_cast hp_len' + refine ⟨v, l, hchain, hvertices, hnet, ?_⟩ + calc + (6 * (ε : ℝ)) * l.length = 6 * ε * p.length := by rw [hl_len] + _ ≤ 6 * ε * (2 * Fintype.card F) := mul_le_mul_of_nonneg_left hp_len_real (by positivity) + _ = 12 * ((Fintype.card F : ℝ) * ε) := by ring + _ ≤ 12 * (2 * (μH[1] s).toReal) := mul_le_mul_of_nonneg_left hcard (by norm_num) + _ = 24 * (μH[1] s).toReal := by ring + +private theorem exists_uniform_lipschitz_approximation + {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsConnected s) + (hsc : IsCompact s) {a b : (EuclideanSpace ℝ (Fin 2))} (ha : a ∈ s) (hb : b ∈ s) + (hmeasure : μH[1] s ≠ ∞) {ε : ℝ≥0} (hεpos : 0 < ε) + (hεdiam : (ε : ℝ) ≤ dist a b) : + ∃ f : I → (EuclideanSpace ℝ (Fin 2)), + LipschitzWith (Real.toNNReal (24 * (μH[1] s).toReal)) f ∧ + (∀ x ∈ s, ∃ t, dist x (f t) ≤ 2 * ε) ∧ + ∀ t, ∃ x ∈ s, dist (f t) x ≤ 6 * ε := by + obtain ⟨v, l, hchain, hvertices, hcover, hslope⟩ := + exists_short_polygonal_tour hs hsc ha hb hmeasure hεpos hεdiam + let f : I → (EuclideanSpace ℝ (Fin 2)) := unitPolygonalChain v l + have hf_raw : LipschitzWith ((6 * ε) * l.length) f := + unitPolygonalChain_lipschitz hchain + have hconstant : (6 * ε) * l.length ≤ + Real.toNNReal (24 * (μH[1] s).toReal) := by + apply NNReal.coe_le_coe.mp + change (6 * (ε : ℝ)) * l.length ≤ + (Real.toNNReal (24 * (μH[1] s).toReal) : ℝ) + rw [Real.coe_toNNReal _ (mul_nonneg (by norm_num) ENNReal.toReal_nonneg)] + exact hslope + have hf : LipschitzWith (Real.toNNReal (24 * (μH[1] s).toReal)) f := + hf_raw.weaken hconstant + refine ⟨f, hf, ?_, ?_⟩ + · intro x hx + obtain ⟨w, hwlist, hxw⟩ := hcover x hx + obtain ⟨t, htw⟩ := vertex_mem_range_unitPolygonalChain hwlist + refine ⟨t, ?_⟩ + rw [show f t = w by exact htw] + exact hxw + · intro t + obtain ⟨x, hxlist, htx⟩ := unitPolygonalChain_near_vertex (by positivity) hchain t + exact ⟨x, hvertices x hxlist, htx⟩ + +private theorem exists_lipschitz_uniform_subsequence + (F : ℕ → I →ᵇ (EuclideanSpace ℝ (Fin 2))) {K : ℝ≥0} + (hF : ∀ n, LipschitzWith K (F n)) {a : (EuclideanSpace ℝ (Fin 2))} {R : ℝ} + (hball : ∀ n t, F n t ∈ Metric.closedBall a R) : + ∃ g : I →ᵇ (EuclideanSpace ℝ (Fin 2)), ∃ ψ : ℕ → ℕ, StrictMono ψ ∧ + Tendsto (fun n ↦ F (ψ n)) atTop (𝓝 g) ∧ LipschitzWith K g := by + let A : Set (I →ᵇ (EuclideanSpace ℝ (Fin 2))) := range F + have hA_equi : Equicontinuous ((↑) : A → I → (EuclideanSpace ℝ (Fin 2))) := by + apply Metric.equicontinuous_of_continuity_modulus (fun r ↦ (K : ℝ) * r) (by + have hmul := (continuousAt_const.mul continuousAt_id : + ContinuousAt (fun r : ℝ ↦ (K : ℝ) * r) 0) + change Tendsto (fun r : ℝ ↦ (K : ℝ) * r) (𝓝 0) (𝓝 ((K : ℝ) * 0)) at hmul + simpa using hmul) + intro x y q + rcases q with ⟨q, ⟨n, rfl⟩⟩ + exact (hF n).dist_le_mul x y + have hA_ball (q : I →ᵇ (EuclideanSpace ℝ (Fin 2))) (t : I) (hq : q ∈ A) : + q t ∈ Metric.closedBall a R := by + obtain ⟨n, rfl⟩ := hq + exact hball n t + have hcompact : IsCompact (closure A) := + BoundedContinuousFunction.arzela_ascoli (Metric.closedBall a R) + (isCompact_closedBall a R) A hA_ball hA_equi + have hF_closure (n : ℕ) : F n ∈ closure A := subset_closure ⟨n, rfl⟩ + obtain ⟨g, -, ψ, hψ, hψlim⟩ := hcompact.tendsto_subseq hF_closure + refine ⟨g, ψ, hψ, hψlim, ?_⟩ + apply LipschitzWith.of_dist_le_mul + intro t u + apply isClosed_Iic.mem_of_tendsto ((hψlim.eval_const t).dist (hψlim.eval_const u)) + exact Filter.Eventually.of_forall fun n ↦ (hF (ψ n)).dist_le_mul t u + +private theorem range_uniform_limit_subset_of_near + {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsClosed s) + {ε : ℕ → ℝ≥0} (hε : Tendsto (fun n ↦ (ε n : ℝ)) atTop (𝓝 0)) + {F : ℕ → I →ᵇ (EuclideanSpace ℝ (Fin 2))} + {g : I →ᵇ (EuclideanSpace ℝ (Fin 2))} (hF : Tendsto F atTop (𝓝 g)) + (hnear : ∀ n t, ∃ x ∈ s, dist (F n t) x ≤ 6 * ε n) : range g ⊆ s := by + intro z hz + obtain ⟨t, rfl⟩ := hz + rw [← hs.closure_eq] + apply Metric.mem_closure_iff.mpr + intro r hr + have hclose := (Metric.tendsto_nhds.mp (hF.eval_const t)) (r / 2) (half_pos hr) + have hsmall := hε.eventually_lt_const (show (0 : ℝ) < r / 12 by positivity) + obtain ⟨n, hnclose, hnsmall⟩ := (hclose.and hsmall).exists + obtain ⟨x, hxs, hdist⟩ := hnear n t + refine ⟨x, hxs, ?_⟩ + calc + dist (g t) x ≤ dist (g t) (F n t) + dist (F n t) x := dist_triangle _ _ _ + _ < r / 2 + r / 2 := + add_lt_add (by simpa [dist_comm] using hnclose) (hdist.trans_lt (by nlinarith [hnsmall])) + _ = r := add_halves r + +private theorem subset_range_uniform_limit_of_dense + {s : Set (EuclideanSpace ℝ (Fin 2))} {ε : ℕ → ℝ≥0} + (hε : Tendsto (fun n ↦ (ε n : ℝ)) atTop (𝓝 0)) + {F : ℕ → I →ᵇ (EuclideanSpace ℝ (Fin 2))} + {g : I →ᵇ (EuclideanSpace ℝ (Fin 2))} (hF : Tendsto F atTop (𝓝 g)) + (hcover : ∀ n x, x ∈ s → ∃ t, dist x (F n t) ≤ 2 * ε n) : s ⊆ range g := by + intro x hx + let t : ℕ → I := fun n ↦ (hcover n x hx).choose + have ht_dist (n : ℕ) : dist x (F n (t n)) ≤ 2 * ε n := (hcover n x hx).choose_spec + obtain ⟨u, φ, hφ, hφlim⟩ := CompactSpace.tendsto_subseq t + have hcurve_lim : Tendsto (fun n ↦ F (φ n) (t (φ n))) atTop (𝓝 (g u)) := + (hF.comp hφ.tendsto_atTop).eval hφlim + have hpoint_lim : Tendsto (fun n ↦ F (φ n) (t (φ n))) atTop (𝓝 x) := by + rw [Metric.tendsto_nhds] + intro r hr + have hsmall := (hε.comp hφ.tendsto_atTop).eventually_lt_const + (show (0 : ℝ) < r / 2 by positivity) + filter_upwards [hsmall] with n hn + change (ε (φ n) : ℝ) < r / 2 at hn + calc + dist (F (φ n) (t (φ n))) x = dist x (F (φ n) (t (φ n))) := dist_comm _ _ + _ ≤ 2 * ε (φ n) := ht_dist (φ n) + _ < r := by linarith + exact ⟨u, tendsto_nhds_unique hcurve_lim hpoint_lim⟩ + +private theorem exists_unitInterval_lipschitz_surjection_of_not_subsingleton + {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsConnected s) + (hsc : IsCompact s) (hss : ¬s.Subsingleton) + (hmeasure : μH[1] s ≠ ∞) : + ∃ f : I → (EuclideanSpace ℝ (Fin 2)), + LipschitzWith (Real.toNNReal (24 * (μH[1] s).toReal)) f ∧ range f = s := by + push Not at hss + obtain ⟨a, ha, b, hb, hab⟩ := hss + let ε : ℕ → ℝ≥0 := fun n ↦ nndist a b / (n + 1) + have hεpos (n : ℕ) : 0 < ε n := by + apply div_pos + · apply NNReal.coe_pos.mp + simpa only [coe_nndist] using dist_pos.mpr hab + · positivity + have hεdiam (n : ℕ) : (ε n : ℝ) ≤ dist a b := by + simp only [ε, NNReal.coe_div, coe_nndist] + exact div_le_self dist_nonneg (by norm_num) + have hεlim : Filter.Tendsto (fun n ↦ (ε n : ℝ)) Filter.atTop (𝓝 0) := by + have h := (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ)).const_mul (dist a b) + convert h using 1 + · ext n + norm_num [ε, div_eq_mul_inv] + · simp + have hexists (n : ℕ) := + exists_uniform_lipschitz_approximation hs hsc ha hb hmeasure (hεpos n) (hεdiam n) + choose f hf hcover hnear using hexists + let K : ℝ≥0 := Real.toNNReal (24 * (μH[1] s).toReal) + let F : ℕ → I →ᵇ (EuclideanSpace ℝ (Fin 2)) := fun n ↦ + BoundedContinuousFunction.mkOfCompact ⟨f n, (hf n).continuous⟩ + obtain ⟨R, hR⟩ := hsc.isBounded.subset_closedBall a + have hdR : dist a b ≤ R := by + have := hR hb + simpa only [Metric.mem_closedBall, dist_comm] using this + have hF_ball (n : ℕ) (t : I) : F n t ∈ Metric.closedBall a (7 * R) := by + obtain ⟨x, hx, hfx⟩ := hnear n t + rw [Metric.mem_closedBall] + calc + dist (F n t) a ≤ dist (F n t) x + dist x a := dist_triangle _ _ _ + _ ≤ 6 * ε n + R := add_le_add hfx (hR hx) + _ ≤ 6 * dist a b + R := by gcongr; exact hεdiam n + _ ≤ 7 * R := by linarith + have hFlip (n : ℕ) : LipschitzWith K (F n) := hf n + obtain ⟨g, ψ, hψ, hψlim, hglip⟩ := + exists_lipschitz_uniform_subsequence F hFlip hF_ball + have hεψ : Tendsto (fun n ↦ (ε (ψ n) : ℝ)) atTop (𝓝 0) := + hεlim.comp hψ.tendsto_atTop + have hgs : range g ⊆ s := range_uniform_limit_subset_of_near hsc.isClosed hεψ hψlim + (fun n ↦ hnear (ψ n)) + have hsg : s ⊆ range g := subset_range_uniform_limit_of_dense hεψ hψlim + (fun n ↦ hcover (ψ n)) + exact ⟨g, hglip, Set.Subset.antisymm hgs hsg⟩ + +/-- **Eilenberg--Harrold.** A compact connected planar set of finite length is the range of a +global Lipschitz curve. -/ +theorem IsConnected.exists_lipschitzWith_range_eq + {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : IsConnected s) + (hsc : IsCompact s) (hmeasure : μH[1] s ≠ ∞) : + ∃ K : ℝ≥0, ∃ f : ℝ → (EuclideanSpace ℝ (Fin 2)), + LipschitzWith K f ∧ range f = s := by + by_cases hss : s.Subsingleton + · obtain ⟨a, ha⟩ := hs.nonempty + have hs_eq : s = {a} := Set.eq_singleton_iff_unique_mem.mpr ⟨ha, fun _ hx ↦ hss hx ha⟩ + refine ⟨0, fun _ ↦ a, LipschitzWith.const a, ?_⟩ + simp [hs_eq] + · obtain ⟨g, hg, hgs⟩ := + exists_unitInterval_lipschitz_surjection_of_not_subsingleton hs hsc hss hmeasure + let f : ℝ → (EuclideanSpace ℝ (Fin 2)) := g ∘ Set.projIcc 0 1 zero_le_one + refine ⟨Real.toNNReal (24 * (μH[1] s).toReal), f, ?_, ?_⟩ + · simpa only [mul_one] using hg.comp (LipschitzWith.projIcc zero_le_one) + · change range (g ∘ Set.projIcc 0 1 zero_le_one) = s + rw [Set.range_comp, Set.range_projIcc, image_univ, hgs] + +/-- A compact connected planar set of finite Hausdorff one-measure is countably +one-rectifiable. -/ +theorem IsConnected.isCountablyOneRectifiable_of_isCompact {s : Set (EuclideanSpace ℝ (Fin 2))} + (hs : IsConnected s) (hsc : IsCompact s) (hmeasure : μH[1] s ≠ ∞) : + IsCountablyOneRectifiable s := by + obtain ⟨K, f, hf, hfs⟩ := IsConnected.exists_lipschitzWith_range_eq hs hsc hmeasure + refine ⟨fun _ ↦ f, fun _ ↦ ⟨K, hf⟩, ?_⟩ + simp only [hfs] + rw [Set.iUnion_const, sdiff_self, measure_empty] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/HoleMerging.lean b/LeanPool/Besicovitch/Rectifiability/HoleMerging.lean new file mode 100644 index 0000000000..0c8b86b437 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/HoleMerging.lean @@ -0,0 +1,585 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Geometry.ConvexEnlargement + +import Mathlib.Order.Partition.Finpartition + +/-! +# Merging overlapping convex holes + +This file replaces a countable family of possibly overlapping open holes by a countable +pairwise-disjoint family of larger open convex holes. The sum of the extended diameters does not +increase. + +Convexifying a connected component of the original overlap graph is not sufficient: the convex +hulls can acquire new intersections. We instead repeatedly merge intersecting convex hulls at +each finite stage and then take the increasing union of every eventual cluster. +-/ + +@[expose] public section + +noncomputable section + +open Bornology Set +open scoped ENNReal + +namespace LeanPool.Besicovitch + +private def clusterUnion (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (s : Finset ℕ) : Set (EuclideanSpace ℝ (Fin 2)) := + ⋃ i ∈ s, U i + +private def clusterHull (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (s : Finset ℕ) : Set (EuclideanSpace ℝ (Fin 2)) := + openConvexHull (clusterUnion U s) + +private theorem isOpen_clusterUnion {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hU : ∀ i, IsOpen (U i)) + (s : Finset ℕ) : IsOpen (clusterUnion U s) := by + exact isOpen_biUnion fun i _ ↦ hU i + +private theorem isOpen_clusterHull (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (s : Finset ℕ) : + IsOpen (clusterHull U s) := + isOpen_openConvexHull _ + +private theorem convex_clusterHull (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (s : Finset ℕ) : + Convex ℝ (clusterHull U s) := + convex_openConvexHull _ + +private theorem clusterUnion_subset_clusterHull {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hU : ∀ i, IsOpen (U i)) (s : Finset ℕ) : + clusterUnion U s ⊆ clusterHull U s := + subset_openConvexHull (isOpen_clusterUnion hU s) + +private theorem clusterHull_mono {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} {s t : Finset ℕ} + (hst : s ⊆ t) : clusterHull U s ⊆ clusterHull U t := by + exact interior_mono (convexHull_mono (by + intro x hx + simp only [clusterUnion, mem_iUnion] at hx ⊢ + obtain ⟨i, hi, hxi⟩ := hx + exact ⟨i, hst hi, hxi⟩)) + +private theorem ediam_clusterHull {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hU : ∀ i, IsOpen (U i)) + (s : Finset ℕ) : Metric.ediam (clusterHull U s) = Metric.ediam (clusterUnion U s) := + ediam_openConvexHull (isOpen_clusterUnion hU s) + +private theorem isBounded_clusterUnion {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hU : ∀ i, IsBounded (U i)) (s : Finset ℕ) : IsBounded (clusterUnion U s) := by + exact (isBounded_biUnion_finset s).2 fun i _ ↦ hU i + +private theorem isBounded_clusterHull {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hU : ∀ i, IsBounded (U i)) (s : Finset ℕ) : IsBounded (clusterHull U s) := by + exact (isBounded_convexHull.mpr (isBounded_clusterUnion hU s)).subset interior_subset + +private theorem clusterUnion_union (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (s t : Finset ℕ) : + clusterUnion U (s ∪ t) = clusterUnion U s ∪ clusterUnion U t := by + ext x + simp only [clusterUnion, mem_iUnion, Finset.mem_union, exists_prop] + aesop + +private theorem ediam_clusterHull_union_le {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) {s t : Finset ℕ} + (hst : (clusterHull U s ∩ clusterHull U t).Nonempty) : + Metric.ediam (clusterHull U (s ∪ t)) ≤ + Metric.ediam (clusterHull U s) + Metric.ediam (clusterHull U t) := by + rw [ediam_clusterHull hUopen, clusterUnion_union] + calc + Metric.ediam (clusterUnion U s ∪ clusterUnion U t) ≤ + Metric.ediam (clusterHull U s ∪ clusterHull U t) := + Metric.ediam_mono (union_subset_union (clusterUnion_subset_clusterHull hUopen s) + (clusterUnion_subset_clusterHull hUopen t)) + _ ≤ Metric.ediam (clusterHull U s) + Metric.ediam (clusterHull U t) := + Metric.ediam_union_le hst + +private def GoodPartition (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) {s : Finset ℕ} + (P : Finpartition s) : Prop := + ∀ t ∈ P.parts, Metric.ediam (clusterHull U t) ≤ ∑ i ∈ t, Metric.ediam (U i) + +private def mergePartsFinset {s : Finset ℕ} (P : Finpartition s) (a b : Finset ℕ) : + Finset (Finset ℕ) := + insert (a ∪ b) ((P.parts.erase a).erase b) + +private theorem mergeParts_subset {s : Finset ℕ} (P : Finpartition s) {a b t : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (ht : t ∈ mergePartsFinset P a b) : t ⊆ s := by + simp only [mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at ht + rcases ht with rfl | ⟨_, _, ht⟩ + · exact Finset.union_subset (P.subset ha) (P.subset hb) + · exact P.subset ht + +private theorem mergeParts_existsUnique {s : Finset ℕ} (P : Finpartition s) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (_hab : a ≠ b) {i : ℕ} (hi : i ∈ s) : + ∃! t ∈ mergePartsFinset P a b, i ∈ t := by + obtain ⟨p, ⟨hp, hip⟩, hp_unique⟩ := P.existsUnique_mem hi + by_cases hpa : p = a + · subst p + refine ⟨a ∪ b, ⟨by simp [mergePartsFinset], Finset.mem_union_left _ hip⟩, ?_⟩ + rintro t ⟨ht, hit⟩ + simp only [mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at ht + rcases ht with rfl | ⟨htb, hta, htP⟩ + · rfl + · exact (hta (hp_unique t ⟨htP, hit⟩)).elim + · by_cases hpb : p = b + · subst p + refine ⟨a ∪ b, ⟨by simp [mergePartsFinset], Finset.mem_union_right _ hip⟩, ?_⟩ + rintro t ⟨ht, hit⟩ + simp only [mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at ht + rcases ht with rfl | ⟨htb, _, htP⟩ + · rfl + · exact (htb (hp_unique t ⟨htP, hit⟩)).elim + · have hpmerged : p ∈ mergePartsFinset P a b := by + simp [mergePartsFinset, hp, hpa, hpb] + refine ⟨p, ⟨hpmerged, hip⟩, ?_⟩ + rintro t ⟨ht, hit⟩ + simp only [mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at ht + rcases ht with rfl | ⟨_, _, htP⟩ + · rcases Finset.mem_union.mp hit with hia | hib + · exact (hpa (hp_unique a ⟨ha, hia⟩).symm).elim + · exact (hpb (hp_unique b ⟨hb, hib⟩).symm).elim + · exact hp_unique t ⟨htP, hit⟩ + +private theorem empty_notMem_mergeParts {s : Finset ℕ} (P : Finpartition s) + {a b : Finset ℕ} (ha : a ∈ P.parts) : ∅ ∉ mergePartsFinset P a b := by + intro h + simp only [mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at h + rcases h with h | ⟨_, _, hP⟩ + · exact P.ne_empty ha (Finset.union_eq_empty.mp h.symm).1 + · exact P.bot_notMem hP + +private def mergeParts {s : Finset ℕ} (P : Finpartition s) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (hab : a ≠ b) : Finpartition s := + Finpartition.ofExistsUnique (mergePartsFinset P a b) + (fun _ ht ↦ mergeParts_subset P ha hb ht) + (fun _ hi ↦ mergeParts_existsUnique P ha hb hab hi) (empty_notMem_mergeParts P ha) + +private theorem parts_mergeParts {s : Finset ℕ} (P : Finpartition s) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (hab : a ≠ b) : + (mergeParts P ha hb hab).parts = mergePartsFinset P a b := + rfl + +private theorem le_mergeParts {s : Finset ℕ} (P : Finpartition s) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (hab : a ≠ b) : + P ≤ mergeParts P ha hb hab := by + intro t ht + by_cases hta : t = a + · subst t + exact ⟨a ∪ b, by simp [parts_mergeParts, mergePartsFinset], Finset.subset_union_left⟩ + · by_cases htb : t = b + · subst t + exact ⟨a ∪ b, by simp [parts_mergeParts, mergePartsFinset], Finset.subset_union_right⟩ + · exact ⟨t, by simp [parts_mergeParts, mergePartsFinset, ht, hta, htb], Subset.rfl⟩ + +private theorem card_mergeParts {s : Finset ℕ} (P : Finpartition s) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (hab : a ≠ b) : + (mergeParts P ha hb hab).parts.card + 1 = P.parts.card := by + rw [parts_mergeParts, mergePartsFinset] + have hab_union : a ∪ b ∉ (P.parts.erase a).erase b := by + intro h + have huP : a ∪ b ∈ P.parts := (Finset.mem_erase.mp (Finset.mem_erase.mp h).2).2 + have haub : a = a ∪ b := by + apply P.disjoint.eq_of_le ha huP (P.ne_empty ha) + exact Finset.subset_union_left + have hbsub : b ⊆ a := by rw [haub]; exact Finset.subset_union_right + exact hab (P.disjoint.eq_of_le hb ha (P.ne_empty hb) hbsub).symm + have hcard : 1 < P.parts.card := + Finset.one_lt_card.mpr ⟨a, ha, b, hb, hab⟩ + rw [Finset.card_insert_of_notMem hab_union, Finset.card_erase_of_mem + (Finset.mem_erase.mpr ⟨hab.symm, hb⟩), Finset.card_erase_of_mem ha] + omega + +private theorem good_mergeParts {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {s : Finset ℕ} {P : Finpartition s} (hP : GoodPartition U P) {a b : Finset ℕ} + (ha : a ∈ P.parts) (hb : b ∈ P.parts) (hab : a ≠ b) + (hinter : (clusterHull U a ∩ clusterHull U b).Nonempty) : + GoodPartition U (mergeParts P ha hb hab) := by + intro t ht + simp only [parts_mergeParts, mergePartsFinset, Finset.mem_insert, Finset.mem_erase] at ht + rcases ht with rfl | ⟨_, _, htP⟩ + · calc + Metric.ediam (clusterHull U (a ∪ b)) ≤ + Metric.ediam (clusterHull U a) + Metric.ediam (clusterHull U b) := + ediam_clusterHull_union_le hUopen hinter + _ ≤ (∑ i ∈ a, Metric.ediam (U i)) + ∑ i ∈ b, Metric.ediam (U i) := + add_le_add (hP a ha) (hP b hb) + _ = ∑ i ∈ a ∪ b, Metric.ediam (U i) := by + have hd : Disjoint a b := by + change Disjoint (id a) (id b) + exact P.disjoint ha hb hab + exact (Finset.sum_union hd).symm + · exact hP t htP + +private def SeparatedPartition (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) {s : Finset ℕ} + (P : Finpartition s) : Prop := + ∀ a ∈ P.parts, ∀ b ∈ P.parts, a ≠ b → Disjoint (clusterHull U a) (clusterHull U b) + +private theorem exists_separated_coarsening {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) {s : Finset ℕ} (P : Finpartition s) + (hP : GoodPartition U P) : + ∃ Q : Finpartition s, P ≤ Q ∧ GoodPartition U Q ∧ SeparatedPartition U Q := by + classical + induction hn : P.parts.card using Nat.strong_induction_on generalizing P with + | h n ih => + by_cases hsep : SeparatedPartition U P + · exact ⟨P, le_rfl, hP, hsep⟩ + · simp only [SeparatedPartition] at hsep + push Not at hsep + obtain ⟨a, ha, b, hb, hab, hinter⟩ := hsep + have hinter' : (clusterHull U a ∩ clusterHull U b).Nonempty := + Set.not_disjoint_iff.mp hinter + let P' := mergeParts P ha hb hab + have hcard : P'.parts.card < n := by + change (mergeParts P ha hb hab).parts.card < n + rw [← hn] + have := card_mergeParts P ha hb hab + omega + obtain ⟨Q, hP'Q, hQgood, hQsep⟩ := + ih P'.parts.card hcard P' (good_mergeParts hUopen hP ha hb hab hinter') rfl + exact ⟨Q, (le_mergeParts P ha hb hab).trans hP'Q, hQgood, hQsep⟩ + +private theorem good_extendRange {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n : ℕ} (P : Finpartition (Finset.range n)) (hP : GoodPartition U P) : + GoodPartition U (P.extendOfLE (Finset.range_mono n.le_succ)) := by + intro t ht + rcases P.mem_parts_or_eq_sdiff_of_mem_extendOfLE (Finset.range_mono n.le_succ) ht with + htP | rfl + · exact hP t htP + · have hdiff : Finset.range (n + 1) \ Finset.range n = {n} := by + ext i + simp only [Finset.mem_sdiff, Finset.mem_range, Finset.mem_singleton] + omega + rw [hdiff, ediam_clusterHull hUopen] + simp [clusterUnion] + +private structure HoleStage (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (n : ℕ) where + partition : Finpartition (Finset.range n) + good : GoodPartition U partition + separated : SeparatedPartition U partition + +private def initialHoleStage (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) : HoleStage U 0 where + partition := Finpartition.empty _ + good := by simp [GoodPartition] + separated := by simp [SeparatedPartition] + +private noncomputable def nextHoleStage {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n : ℕ} (S : HoleStage U n) : HoleStage U (n + 1) := by + let P := S.partition.extendOfLE (Finset.range_mono n.le_succ) + have hP : GoodPartition U P := good_extendRange hUopen S.partition S.good + let Q := Classical.choose (exists_separated_coarsening hUopen P hP) + exact { + partition := Q + good := (Classical.choose_spec (exists_separated_coarsening hUopen P hP)).2.1 + separated := (Classical.choose_spec (exists_separated_coarsening hUopen P hP)).2.2 } + +private theorem extend_le_nextHoleStage {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n : ℕ} (S : HoleStage U n) : + S.partition.extendOfLE (Finset.range_mono n.le_succ) ≤ + (nextHoleStage hUopen S).partition := by + exact (Classical.choose_spec (exists_separated_coarsening hUopen + (S.partition.extendOfLE (Finset.range_mono n.le_succ)) + (good_extendRange hUopen S.partition S.good))).1 + +private noncomputable def holeStages (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) : + (n : ℕ) → HoleStage U n + | 0 => initialHoleStage U + | n + 1 => nextHoleStage hUopen (holeStages U hUopen n) + +private theorem stage_part_subset_succ {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n i : ℕ} (hi : i < n) : + (holeStages U hUopen n).partition.part i ⊆ + (holeStages U hUopen (n + 1)).partition.part i := by + let P := (holeStages U hUopen n).partition + let Q := (holeStages U hUopen (n + 1)).partition + have hiP : i ∈ Finset.range n := Finset.mem_range.mpr hi + have htP : P.part i ∈ P.parts := P.part_mem.mpr hiP + have htE : P.part i ∈ (P.extendOfLE (Finset.range_mono n.le_succ)).parts := + P.parts_subset_extendOfLE (Finset.range_mono n.le_succ) htP + have hle : P.extendOfLE (Finset.range_mono n.le_succ) ≤ Q := by + simpa only [Q, P, holeStages] using + extend_le_nextHoleStage hUopen (holeStages U hUopen n) + obtain ⟨t, htQ, hsub⟩ := hle htE + have hit : i ∈ t := hsub (P.mem_part hiP) + have hpart : Q.part i = t := Q.part_eq_of_mem htQ hit + rwa [hpart] + +private theorem stage_part_mono {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n m i : ℕ} (hi : i < n) (hnm : n ≤ m) : + (holeStages U hUopen n).partition.part i ⊆ + (holeStages U hUopen m).partition.part i := by + induction m, hnm using Nat.le_induction with + | base => exact Subset.rfl + | succ m hnm ih => + exact ih.trans (stage_part_subset_succ hUopen (hi.trans_le hnm)) + +private theorem stage_part_subset_succ_all {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) (n i : ℕ) : + (holeStages U hUopen n).partition.part i ⊆ + (holeStages U hUopen (n + 1)).partition.part i := by + by_cases hi : i < n + · exact stage_part_subset_succ hUopen hi + · have hi' : i ∉ Finset.range n := by simpa only [Finset.mem_range] using hi + rw [(holeStages U hUopen n).partition.part_eq_empty.mpr hi'] + exact Finset.empty_subset _ + +private theorem stage_part_mono_all {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n m : ℕ} (i : ℕ) (hnm : n ≤ m) : + (holeStages U hUopen n).partition.part i ⊆ + (holeStages U hUopen m).partition.part i := by + induction m, hnm using Nat.le_induction with + | base => exact Subset.rfl + | succ m _ ih => exact ih.trans (stage_part_subset_succ_all hUopen m i) + +private theorem stage_cluster_mono {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n m : ℕ} (i : ℕ) (hnm : n ≤ m) : + clusterHull U ((holeStages U hUopen n).partition.part i) ⊆ + clusterHull U ((holeStages U hUopen m).partition.part i) := + clusterHull_mono (stage_part_mono_all hUopen i hnm) + +private def mergedHole (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) (i : ℕ) : + Set (EuclideanSpace ℝ (Fin 2)) := + ⋃ n, clusterHull U ((holeStages U hUopen n).partition.part i) + +private theorem isOpen_mergedHole {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + (i : ℕ) : IsOpen (mergedHole U hUopen i) := by + exact isOpen_iUnion fun _ ↦ isOpen_clusterHull _ _ + +private theorem convex_mergedHole {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + (i : ℕ) : Convex ℝ (mergedHole U hUopen i) := by + apply (monotone_nat_of_le_succ fun n ↦ + stage_cluster_mono hUopen i n.le_succ).directed_le.convex_iUnion + exact fun _ ↦ convex_clusterHull _ _ + +private theorem subset_mergedHole {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + (i : ℕ) : U i ⊆ mergedHole U hUopen i := by + intro x hx + apply mem_iUnion.mpr + refine ⟨i + 1, clusterUnion_subset_clusterHull hUopen _ ?_⟩ + simp only [clusterUnion, mem_iUnion] + exact ⟨i, (holeStages U hUopen (i + 1)).partition.mem_part (by simp), hx⟩ + +private theorem stage_part_eq_of_inter {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n i j : ℕ} (hi : i < n) (hj : j < n) + (hinter : (clusterHull U ((holeStages U hUopen n).partition.part i) ∩ + clusterHull U ((holeStages U hUopen n).partition.part j)).Nonempty) : + (holeStages U hUopen n).partition.part i = + (holeStages U hUopen n).partition.part j := by + let P := (holeStages U hUopen n).partition + have hiP : i ∈ Finset.range n := Finset.mem_range.mpr hi + have hjP : j ∈ Finset.range n := Finset.mem_range.mpr hj + have hpi : P.part i ∈ P.parts := P.part_mem.mpr hiP + have hpj : P.part j ∈ P.parts := P.part_mem.mpr hjP + by_contra hne + have hd := (holeStages U hUopen n).separated (P.part i) hpi (P.part j) hpj hne + obtain ⟨x, hxi, hxj⟩ := hinter + exact Set.disjoint_left.mp hd hxi hxj + +private theorem stage_part_eq_mono {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) + {n m i j : ℕ} (hi : i < n) (hj : j < n) (hnm : n ≤ m) + (heq : (holeStages U hUopen n).partition.part i = + (holeStages U hUopen n).partition.part j) : + (holeStages U hUopen m).partition.part i = + (holeStages U hUopen m).partition.part j := by + let P := (holeStages U hUopen n).partition + let Q := (holeStages U hUopen m).partition + have hj_old : j ∈ P.part i := by + rw [heq] + exact P.mem_part (Finset.mem_range.mpr hj) + have hj_new : j ∈ Q.part i := stage_part_mono_all hUopen i hnm hj_old + have hiQ : i ∈ Finset.range m := Finset.mem_range.mpr (hi.trans_le hnm) + have hjQ : j ∈ Finset.range m := Finset.mem_range.mpr (hj.trans_le hnm) + exact ((Q.mem_part_iff_part_eq_part hjQ hiQ).mp hj_new).symm + +private theorem mergedHole_eq_of_inter {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) {i j : ℕ} + (hinter : (mergedHole U hUopen i ∩ mergedHole U hUopen j).Nonempty) : + mergedHole U hUopen i = mergedHole U hUopen j := by + obtain ⟨x, hxi, hxj⟩ := hinter + obtain ⟨ni, hxni⟩ := mem_iUnion.mp hxi + obtain ⟨nj, hxnj⟩ := mem_iUnion.mp hxj + let N := max (max ni nj) (max (i + 1) (j + 1)) + have hniN : ni ≤ N := by simp [N] + have hnjN : nj ≤ N := by simp [N] + have hiN : i < N := by + have : i + 1 ≤ N := by simp [N] + omega + have hjN : j < N := by + have : j + 1 ≤ N := by simp [N] + omega + have hxNi := stage_cluster_mono hUopen i hniN hxni + have hxNj := stage_cluster_mono hUopen j hnjN hxnj + have heqN := stage_part_eq_of_inter hUopen hiN hjN ⟨x, hxNi, hxNj⟩ + apply Subset.antisymm + · intro y hy + obtain ⟨k, hyk⟩ := mem_iUnion.mp hy + let M := max k N + have hkM : k ≤ M := by simp [M] + have hNM : N ≤ M := by simp [M] + have heqM := stage_part_eq_mono hUopen hiN hjN hNM heqN + apply mem_iUnion.mpr + refine ⟨M, ?_⟩ + have hyM := stage_cluster_mono hUopen i hkM hyk + rwa [heqM] at hyM + · intro y hy + obtain ⟨k, hyk⟩ := mem_iUnion.mp hy + let M := max k N + have hkM : k ≤ M := by simp [M] + have hNM : N ≤ M := by simp [M] + have heqM := stage_part_eq_mono hUopen hiN hjN hNM heqN + apply mem_iUnion.mpr + refine ⟨M, ?_⟩ + have hyM := stage_cluster_mono hUopen j hkM hyk + rwa [← heqM] at hyM + +private theorem mergedHole_eq_of_stage_part_eq {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) {n i j : ℕ} (hi : i < n) (hj : j < n) + (heq : (holeStages U hUopen n).partition.part i = + (holeStages U hUopen n).partition.part j) : + mergedHole U hUopen i = mergedHole U hUopen j := by + apply Subset.antisymm + · intro x hx + obtain ⟨k, hxk⟩ := mem_iUnion.mp hx + let m := max k n + have hkm : k ≤ m := by simp [m] + have hnm : n ≤ m := by simp [m] + have heqm := stage_part_eq_mono hUopen hi hj hnm heq + apply mem_iUnion.mpr + refine ⟨m, ?_⟩ + have hxm := stage_cluster_mono hUopen i hkm hxk + rwa [heqm] at hxm + · intro x hx + obtain ⟨k, hxk⟩ := mem_iUnion.mp hx + let m := max k n + have hkm : k ≤ m := by simp [m] + have hnm : n ≤ m := by simp [m] + have heqm := stage_part_eq_mono hUopen hi hj hnm heq + apply mem_iUnion.mpr + refine ⟨m, ?_⟩ + have hxm := stage_cluster_mono hUopen j hkm hxk + rwa [← heqm] at hxm + +private theorem ediam_mergedHole_le_fiber {U : ℕ → Set (EuclideanSpace ℝ (Fin 2))} + (hUopen : ∀ i, IsOpen (U i)) (i : ℕ) : + Metric.ediam (mergedHole U hUopen i) ≤ + ∑' j, if mergedHole U hUopen j = mergedHole U hUopen i + then Metric.ediam (U j) else 0 := by + apply Metric.ediam_le + intro x hx y hy + obtain ⟨nx, hnx⟩ := mem_iUnion.mp hx + obtain ⟨ny, hny⟩ := mem_iUnion.mp hy + let n := max (max nx ny) (i + 1) + have hnxn : nx ≤ n := by simp [n] + have hnyn : ny ≤ n := by simp [n] + have hin : i < n := by + have : i + 1 ≤ n := by simp [n] + omega + let P := (holeStages U hUopen n).partition + have hpart : P.part i ∈ P.parts := P.part_mem.mpr (Finset.mem_range.mpr hin) + calc + edist x y ≤ Metric.ediam (clusterHull U (P.part i)) := + Metric.edist_le_ediam_of_mem (stage_cluster_mono hUopen i hnxn hnx) + (stage_cluster_mono hUopen i hnyn hny) + _ ≤ ∑ j ∈ P.part i, Metric.ediam (U j) := (holeStages U hUopen n).good _ hpart + _ = ∑ j ∈ P.part i, if mergedHole U hUopen j = mergedHole U hUopen i + then Metric.ediam (U j) else 0 := by + apply Finset.sum_congr rfl + intro j hj + have hjn : j < n := Finset.mem_range.mp (P.part_subset i hj) + have heqpart : P.part j = P.part i := (P.mem_part_iff_part_eq_part + (Finset.mem_range.mpr hjn) (Finset.mem_range.mpr hin)).mp hj + have heqholes := mergedHole_eq_of_stage_part_eq hUopen hjn hin heqpart + simp only [heqholes, ite_eq_left] + _ ≤ ∑' j, if mergedHole U hUopen j = mergedHole U hUopen i + then Metric.ediam (U j) else 0 := ENNReal.sum_le_tsum _ + +private theorem tsum_range_ediam_le + (W : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (d : ℕ → ℝ≥0∞) + (hW : ∀ i, Metric.ediam (W i) ≤ ∑' j, if W j = W i then d j else 0) : + (∑' V : Set.range W, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ∑' i, d i := by + calc + _ ≤ ∑' V : Set.range W, + ∑' j, if W j = (V : Set (EuclideanSpace ℝ (Fin 2))) then d j else 0 := by + apply ENNReal.tsum_le_tsum + rintro ⟨V, i, rfl⟩ + exact hW i + _ = ∑' j, ∑' V : Set.range W, + if W j = (V : Set (EuclideanSpace ℝ (Fin 2))) then d j else 0 := + ENNReal.tsum_comm + _ = ∑' j, d j := by + congr 1 + funext j + let Vj : Set.range W := ⟨W j, mem_range_self j⟩ + rw [tsum_eq_single Vj] + · simp [Vj] + · intro V hV + rw [ite_eq_right] + intro h + apply hV + exact Subtype.ext h.symm + +/-- A countable family of open holes with finite total diameter has a pairwise-disjoint +open convex enlargement without any increase in total diameter. -/ +theorem exists_pairwiseDisjoint_convex_hole_cover (U : ℕ → Set (EuclideanSpace ℝ (Fin 2))) + (hUopen : ∀ i, IsOpen (U i)) + (hsum : (∑' i, Metric.ediam (U i)) ≠ ∞) : + ∃ W : Set (Set (EuclideanSpace ℝ (Fin 2))), + W.Countable ∧ W.PairwiseDisjoint id ∧ + (∀ V : W, IsOpen (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + Convex ℝ (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + IsBounded (V : Set (EuclideanSpace ℝ (Fin 2)))) ∧ + (⋃ i, U i) ⊆ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + (∑' V : W, Metric.ediam (V : Set (EuclideanSpace ℝ (Fin 2)))) ≤ + ∑' i, Metric.ediam (U i) := by + let Wfun : ℕ → Set (EuclideanSpace ℝ (Fin 2)) := mergedHole U hUopen + let W : Set (Set (EuclideanSpace ℝ (Fin 2))) := Set.range Wfun + have hdisjoint : W.PairwiseDisjoint id := by + rintro V ⟨i, rfl⟩ V' ⟨j, rfl⟩ hne + apply Set.disjoint_left.mpr + intro x hxi hxj + exact hne (mergedHole_eq_of_inter hUopen ⟨x, hxi, hxj⟩) + have hproperties : ∀ V : W, IsOpen (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + Convex ℝ (V : Set (EuclideanSpace ℝ (Fin 2))) ∧ + IsBounded (V : Set (EuclideanSpace ℝ (Fin 2))) := by + rintro ⟨V, i, rfl⟩ + refine ⟨isOpen_mergedHole hUopen i, convex_mergedHole hUopen i, ?_⟩ + apply Metric.isBounded_iff_ediam_ne_top.mpr + apply ne_top_of_le_ne_top hsum + calc + Metric.ediam (mergedHole U hUopen i) ≤ + ∑' j, if mergedHole U hUopen j = mergedHole U hUopen i + then Metric.ediam (U j) else 0 := ediam_mergedHole_le_fiber hUopen i + _ ≤ ∑' j, Metric.ediam (U j) := by + apply ENNReal.tsum_le_tsum + intro j + split_ifs <;> simp + have hcover : (⋃ i, U i) ⊆ ⋃ V : W, (V : Set (EuclideanSpace ℝ (Fin 2))) := by + intro x hx + obtain ⟨i, hxi⟩ := mem_iUnion.mp hx + apply mem_iUnion.mpr + refine ⟨⟨Wfun i, mem_range_self i⟩, ?_⟩ + exact subset_mergedHole hUopen i hxi + refine ⟨W, Set.countable_range Wfun, hdisjoint, hproperties, hcover, ?_⟩ + exact tsum_range_ediam_le Wfun (fun i ↦ Metric.ediam (U i)) + (ediam_mergedHole_le_fiber hUopen) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/Selection.lean b/LeanPool/Besicovitch/Rectifiability/Selection.lean new file mode 100644 index 0000000000..0acee21dc7 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/Selection.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement +public import Mathlib.MeasureTheory.Covering.Vitali +public import Mathlib.Topology.Algebra.Module.PerfectSpace + +/-! +# Maximal disjoint selection + +This file extracts a countable disjoint subfamily of uniformly bounded open sets. Every original +set meets a selected set whose diameter is more than half as large. +-/ + +@[expose] public section + +open Bornology Set + +namespace LeanPool.Besicovitch + +/-- A uniformly bounded family of nonempty bounded open sets has a countable disjoint subfamily +meeting every member at a scale larger than half its diameter. -/ +theorem exists_countable_disjoint_subfamily + (family : Set (Set (EuclideanSpace ℝ (Fin 2)))) + (hopen : ∀ V ∈ family, IsOpen V) + (hnonempty : ∀ V ∈ family, V.Nonempty) + (hbounded : ∀ V ∈ family, IsBounded V) + (R : ℝ) (hdiam : ∀ V ∈ family, Metric.diam V ≤ R) : + ∃ chosen ⊆ family, chosen.PairwiseDisjoint id ∧ chosen.Countable ∧ + ∀ V ∈ family, ∃ W ∈ chosen, + (V ∩ W).Nonempty ∧ Metric.diam V < 2 * Metric.diam W := by + obtain ⟨chosen, hchosen, hdisjoint, hcover⟩ := + Vitali.exists_disjoint_subfamily_covering_enlargement id family Metric.diam (3 / 2) + (by norm_num) (fun _ _ ↦ Metric.diam_nonneg) R hdiam hnonempty + refine ⟨chosen, hchosen, hdisjoint, ?_, fun V hV ↦ ?_⟩ + · exact hdisjoint.countable_of_isOpen + (fun W hW ↦ hopen W (hchosen hW)) (fun W hW ↦ hnonempty W (hchosen hW)) + obtain ⟨W, hW, hVW, hscale⟩ := hcover V hV + refine ⟨W, hW, hVW, ?_⟩ + have hW_nontrivial : W.Nontrivial := by + obtain ⟨x, hx⟩ := hnonempty W (hchosen hW) + obtain ⟨y, hy, hyx⟩ := + preperfect_iff_nhds.mp (hopen W (hchosen hW)).preperfect x hx univ (by simp) + exact nontrivial_of_mem_mem_ne hx hy.2 hyx.symm + have hW_diam : 0 < Metric.diam W := Metric.diam_pos hW_nontrivial (hbounded W (hchosen hW)) + norm_num at hscale ⊢ + linarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/Straight.lean b/LeanPool/Besicovitch/Rectifiability/Straight.lean new file mode 100644 index 0000000000..b2e1075287 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/Straight.lean @@ -0,0 +1,887 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.BesicovitchPairCondition.Definitions +public import Mathlib.MeasureTheory.Constructions.Polish.EmbeddingReal +public import Mathlib.MeasureTheory.Measure.ProbabilityMeasure +public import Mathlib.MeasureTheory.Measure.Hausdorff +public import Mathlib.Probability.CDF +public import Mathlib.Topology.MetricSpace.Thickening + +/-! +# Straight pieces of finite Hausdorff sets + +This file proves the positive-piece form of Delaware's straight-set theorem for Hausdorff +one-measure in the Euclidean plane. It also records the elementary restriction API used later. +-/ + +@[expose] public section + +noncomputable section + +open Filter Function MeasureTheory Metric Set TopologicalSpace +open scoped ENNReal MeasureTheory NNReal Topology + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- Straightness passes to a smaller measure. -/ +theorem IsStraightMeasure.mono {μ ν : Measure (EuclideanSpace ℝ (Fin 2))} + (hμ : IsStraightMeasure μ) + (hν : ν ≤ μ) : IsStraightMeasure ν := by + intro s hs + exact (hν s).trans (hμ s hs) + +/-- Every restriction of a straight measure is straight. -/ +theorem IsStraightMeasure.restrict {μ : Measure (EuclideanSpace ℝ (Fin 2))} + (hμ : IsStraightMeasure μ) + (s : Set (EuclideanSpace ℝ (Fin 2))) : IsStraightMeasure (μ.restrict s) := + hμ.mono Measure.restrict_le_self + +/-- Straightness of a Hausdorff restriction passes to measurable subsets. -/ +theorem isStraightMeasure_restrict_mono {s t : Set (EuclideanSpace ℝ (Fin 2))} + (hs : IsStraightMeasure (μH[1].restrict s)) (ht : t ⊆ s) : + IsStraightMeasure (μH[1].restrict t) := + hs.mono (Measure.restrict_mono ht le_rfl) + +/-- Hausdorff content with diameter cutoff `r`, before passage to infinitesimal scales. -/ +private def hausdorffPre (r : ℝ≥0∞) : OuterMeasure X := + OuterMeasure.mkMetric'.pre (fun s : Set X ↦ Metric.ediam s) r + +private theorem hausdorffPre_le {r : ℝ≥0∞} (hr : 0 < r) : + hausdorffPre (X := X) r ≤ (μH[1] : Measure X).toOuterMeasure := by + change hausdorffPre (X := X) r ≤ + (Measure.mkMetric (fun d ↦ d ^ (1 : ℝ)) : Measure X).toOuterMeasure + rw [Measure.mkMetric_toOuterMeasure] + change OuterMeasure.mkMetric'.pre (fun s : Set X ↦ Metric.ediam s) r ≤ + OuterMeasure.mkMetric (fun d ↦ d ^ (1 : ℝ)) + simpa only [OuterMeasure.mkMetric, OuterMeasure.mkMetric', ENNReal.rpow_one] using + (le_iSup₂ (f := fun q (_ : 0 < q) ↦ + OuterMeasure.mkMetric'.pre (fun s : Set X ↦ Metric.ediam s) q) r hr) + +private theorem tendsto_hausdorffPre (s : Set X) : + Tendsto (fun r ↦ hausdorffPre (X := X) r s) (𝓝[>] 0) (𝓝 (μH[1] s)) := by + convert OuterMeasure.mkMetric'.tendsto_pre (fun t : Set X ↦ Metric.ediam t) s using 1 + · rfl + · congr 1 + change μH[1] s = OuterMeasure.mkMetric (fun d ↦ d) s + rw [OuterMeasure.coe_mkMetric] + simp only [Measure.hausdorffMeasure, ENNReal.rpow_one] + +/-- An atomless finite measure on the plane has measurable subsets of every prescribed fraction. -/ +private theorem exists_subset_measure_eq_mul + {μ : Measure (EuclideanSpace ℝ (Fin 2))} [IsFiniteMeasure μ] + [NullSingletonClass μ] {s : Set (EuclideanSpace ℝ (Fin 2))} (hs : MeasurableSet s) {q : ℝ} + (hq_zero : 0 ≤ q) (hq_one : q ≤ 1) : + ∃ t : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet t ∧ t ⊆ s ∧ μ t = ENNReal.ofReal q * μ s := by + rcases eq_or_lt_of_le hq_zero with rfl | hq_pos + · exact ⟨∅, MeasurableSet.empty, empty_subset s, by simp⟩ + rcases hq_one.eq_or_lt with rfl | hq_lt + · exact ⟨s, hs, Subset.rfl, by simp⟩ + by_cases hμs : μ s = 0 + · exact ⟨∅, MeasurableSet.empty, empty_subset s, by simp [hμs]⟩ + have hμs_pos : 0 < μ s := pos_iff_ne_zero.mpr hμs + let f : (EuclideanSpace ℝ (Fin 2)) → ℝ := embeddingReal (EuclideanSpace ℝ (Fin 2)) + have hf : MeasurableEmbedding f := measurableEmbedding_embeddingReal (EuclideanSpace ℝ (Fin 2)) + let ν : Measure ℝ := (μ.restrict s).map f + have hν_univ : ν univ = μ s := by + simp only [ν, Measure.map_apply hf.measurable MeasurableSet.univ, preimage_univ, + Measure.restrict_apply_univ] + have : NullSingletonClass ν := by + refine ⟨fun x ↦ ?_⟩ + change ((μ.restrict s).map f) {x} = 0 + rw [Measure.map_apply hf.measurable (MeasurableSet.singleton x)] + have hsub : (f ⁻¹' {x}).Subsingleton := by + intro y hy z hz + apply hf.injective + simpa only [mem_preimage, mem_singleton_iff] using hy.trans hz.symm + exact hsub.measure_zero (μ.restrict s) + let νf : FiniteMeasure ℝ := ⟨ν, inferInstance⟩ + have hν_pos : 0 < ν univ := by simpa only [hν_univ] using hμs_pos + have hν_ne : νf ≠ 0 := by + intro hzero + have hzero' : ν = 0 := congrArg (fun m : FiniteMeasure ℝ ↦ (m : Measure ℝ)) hzero + have : ν univ = 0 := by rw [hzero']; rfl + exact hν_pos.ne' this + let P : ProbabilityMeasure ℝ := νf.normalize + let : IsProbabilityMeasure (P : Measure ℝ) := P.property + have : NullSingletonClass (P : Measure ℝ) := by + refine ⟨fun x ↦ ?_⟩ + have hνf_single : νf {x} = 0 := by + apply ENNReal.coe_injective + rw [νf.ennreal_coeFn_eq_coeFn_toMeasure] + change ν {x} = 0 + exact measure_singleton x + rw [← νf.normalize.ennreal_coeFn_eq_coeFn_toMeasure] + rw [νf.normalize_eq_of_nonzero hν_ne] + simp only [hνf_single, mul_zero, ENNReal.coe_zero] + let F : ℝ → ℝ := ProbabilityTheory.cdf (P : Measure ℝ) + have hF_mono : Monotone F := ProbabilityTheory.monotone_cdf _ + have hF_cont : Continuous F := by + rw [continuous_iff_continuousAt] + intro x + rw [hF_mono.continuousAt_iff_leftLim_eq_rightLim] + change leftLim (ProbabilityTheory.cdf (P : Measure ℝ)) x = + rightLim (ProbabilityTheory.cdf (P : Measure ℝ)) x + rw [(ProbabilityTheory.cdf (P : Measure ℝ)).rightLim_eq] + apply le_antisymm (hF_mono.leftLim_le le_rfl) + have hz : ENNReal.ofReal + (ProbabilityTheory.cdf (P : Measure ℝ) x - + leftLim (ProbabilityTheory.cdf (P : Measure ℝ)) x) = 0 := by + rw [← StieltjesFunction.measure_singleton, ProbabilityTheory.measure_cdf] + exact measure_singleton x + exact sub_nonpos.mp (ENNReal.ofReal_eq_zero.mp hz) + have hF_bot : Tendsto F atBot (𝓝 0) := ProbabilityTheory.tendsto_cdf_atBot _ + have hF_top : Tendsto F atTop (𝓝 1) := ProbabilityTheory.tendsto_cdf_atTop _ + obtain ⟨x₀, hx₀⟩ : ∃ x₀, F x₀ < q := + (hF_bot.eventually (eventually_lt_nhds hq_pos)).exists + obtain ⟨x₁, hx₁⟩ : ∃ x₁, q < F x₁ := + (hF_top.eventually (eventually_gt_nhds hq_lt)).exists + have hx_le : x₀ ≤ x₁ := by + by_contra hnot + exact (not_le_of_gt (hx₀.trans hx₁)) (hF_mono (not_le.mp hnot).le) + obtain ⟨x, -, hx⟩ := intermediate_value_Icc hx_le hF_cont.continuousOn + ⟨hx₀.le, hx₁.le⟩ + let t : Set (EuclideanSpace ℝ (Fin 2)) := s ∩ f ⁻¹' Iic x + refine ⟨t, hs.inter (measurableSet_Iic.preimage hf.measurable), inter_subset_left, ?_⟩ + have hmap : ν (Iic x) = μ t := by + change ((μ.restrict s).map f) (Iic x) = μ t + rw [Measure.map_apply hf.measurable measurableSet_Iic, + Measure.restrict_apply (measurableSet_Iic.preimage hf.measurable)] + exact congrArg μ (inter_comm _ _) + rw [← hmap] + change (νf : Measure ℝ) (Iic x) = ENNReal.ofReal q * μ s + rw [← νf.ennreal_coeFn_eq_coeFn_toMeasure] + have hnorm := congrArg (fun z : ℝ≥0 ↦ (z : ℝ≥0∞)) + (νf.self_eq_mass_mul_normalize (Iic x)) + rw [hnorm] + rw [ENNReal.coe_mul, νf.normalize.ennreal_coeFn_eq_coeFn_toMeasure] + change (νf.mass : ℝ≥0∞) * (P : Measure ℝ) (Iic x) = ENNReal.ofReal q * μ s + rw [← ProbabilityTheory.ofReal_cdf (P : Measure ℝ), ← hx] + rw [mul_comm] + congr 1 + rw [FiniteMeasure.ennreal_mass] + change ν univ = μ s + exact hν_univ + +private def lossWeight (n : ℕ) : ℝ≥0∞ := + (8 : ℝ≥0∞)⁻¹ * (2 : ℝ≥0∞)⁻¹ ^ n + +private theorem lossWeight_pos (n : ℕ) : 0 < lossWeight n := by + rw [lossWeight, ENNReal.mul_pos_iff] + exact ⟨by norm_num, ENNReal.pow_pos (by norm_num) n⟩ + +private theorem lossWeight_lt_one (n : ℕ) : lossWeight n < 1 := by + calc + lossWeight n ≤ (8 : ℝ≥0∞)⁻¹ * 1 := by + rw [lossWeight] + gcongr + exact pow_le_one₀ (by positivity) (by norm_num) + _ < 1 := by norm_num + +private theorem lossWeight_le_eighth (n : ℕ) : + lossWeight n ≤ (8 : ℝ≥0∞)⁻¹ := by + calc + lossWeight n ≤ (8 : ℝ≥0∞)⁻¹ * 1 := by + rw [lossWeight] + gcongr + exact pow_le_one₀ (by positivity) (by norm_num) + _ = (8 : ℝ≥0∞)⁻¹ := mul_one _ + +private def thinningFraction (n : ℕ) : ℝ≥0 := + 1 - 2 * (lossWeight n).toNNReal + +private theorem two_lossWeight_toNNReal_lt_one (n : ℕ) : + 2 * (lossWeight n).toNNReal < 1 := by + apply ENNReal.coe_lt_coe.mp + rw [ENNReal.coe_mul, ENNReal.coe_two, + ENNReal.coe_toNNReal (lossWeight_lt_one n).ne_top, ENNReal.coe_one] + calc + 2 * lossWeight n ≤ 2 * (8 : ℝ≥0∞)⁻¹ := by gcongr; exact lossWeight_le_eighth n + _ < 2 * (2 : ℝ≥0∞)⁻¹ := by + apply ENNReal.mul_lt_mul_right (by norm_num) (by norm_num) + exact ENNReal.inv_lt_inv.mpr (by norm_num) + _ = 1 := ENNReal.mul_inv_cancel (by norm_num) (by norm_num) + +private theorem thinningFraction_pos (n : ℕ) : 0 < thinningFraction n := by + rw [thinningFraction, tsub_pos_iff_lt] + exact two_lossWeight_toNNReal_lt_one n + +private theorem thinningFraction_le_one (n : ℕ) : thinningFraction n ≤ 1 := + tsub_le_self + +private theorem thinningFraction_compensates (n : ℕ) : + (thinningFraction n : ℝ≥0∞) * (1 + lossWeight n) ^ 2 ≤ 1 := by + let q : ℝ≥0 := (lossWeight n).toNNReal + have hq : (q : ℝ≥0∞) = lossWeight n := + ENNReal.coe_toNNReal (lossWeight_lt_one n).ne_top + have htwo : 2 * q ≤ 1 := (two_lossWeight_toNNReal_lt_one n).le + have hcomp : thinningFraction n * (1 + q) ^ 2 ≤ (1 : ℝ≥0) := by + change (1 - 2 * q) * (1 + q) ^ 2 ≤ 1 + rw [← NNReal.coe_le_coe] + simp only [NNReal.coe_mul, NNReal.coe_sub htwo, NNReal.coe_one, NNReal.coe_add, + NNReal.coe_pow] + have hq_nonneg : 0 ≤ (q : ℝ) := q.2 + rw [show (1 - ((2 : ℝ≥0) : ℝ) * (q : ℝ)) * (1 + q) ^ 2 = + 1 - q ^ 2 * (3 + 2 * q) by norm_num; ring] + exact sub_le_self 1 (mul_nonneg (sq_nonneg (q : ℝ)) (by positivity)) + simpa only [ENNReal.coe_mul, ENNReal.coe_pow, ENNReal.coe_add, ENNReal.coe_one, hq] using + ENNReal.coe_le_coe.mpr hcomp + +private theorem one_sub_thinningFraction (n : ℕ) : + (1 : ℝ≥0) - thinningFraction n = 2 * (lossWeight n).toNNReal := by + rw [thinningFraction, tsub_tsub_cancel_of_le (two_lossWeight_toNNReal_lt_one n).le] + +private theorem one_sub_thinningFraction_ennreal (n : ℕ) : + (1 : ℝ≥0∞) - thinningFraction n = 2 * lossWeight n := by + rw [← ENNReal.coe_one, ← ENNReal.coe_sub, one_sub_thinningFraction, + ENNReal.coe_mul, ENNReal.coe_two, + ENNReal.coe_toNNReal (lossWeight_lt_one n).ne_top] + +private theorem tsum_lossWeight : ∑' n : ℕ, lossWeight n = (4 : ℝ≥0∞)⁻¹ := by + simp_rw [lossWeight] + rw [ENNReal.tsum_mul_left] + rw [ENNReal.tsum_geometric] + rw [ENNReal.one_sub_inv_two, inv_inv] + apply ENNReal.eq_inv_of_mul_eq_one_left + rw [mul_assoc, show (2 : ℝ≥0∞) * 4 = 8 by norm_num] + exact ENNReal.inv_mul_cancel (by norm_num) (by norm_num) + +/-- The first ball in a dense enumeration that reaches a point. -/ +private def metricCell (r : ℝ≥0) (n : ℕ) : Set (EuclideanSpace ℝ (Fin 2)) := + ball (denseSeq (EuclideanSpace ℝ (Fin 2)) n) r \ + ⋃ k : Fin n, ball (denseSeq (EuclideanSpace ℝ (Fin 2)) k) r + +private theorem measurableSet_metricCell (r : ℝ≥0) (n : ℕ) : + MeasurableSet (metricCell r n) := + Metric.isOpen_ball.measurableSet.diff <| MeasurableSet.iUnion fun _ ↦ + Metric.isOpen_ball.measurableSet + +private theorem pairwiseDisjoint_metricCell (r : ℝ≥0) : + Pairwise (Disjoint on metricCell r) := by + intro m n hmn + rcases lt_or_gt_of_ne hmn with hmn | hnm + · apply Set.disjoint_left.2 + intro x hxm hxn + exact hxn.2 (mem_iUnion.2 ⟨⟨m, hmn⟩, hxm.1⟩) + · apply Set.disjoint_left.2 + intro x hxm hxn + exact hxm.2 (mem_iUnion.2 ⟨⟨n, hnm⟩, hxn.1⟩) + +private theorem iUnion_metricCell (r : ℝ≥0) (hr : 0 < r) : + ⋃ n : ℕ, metricCell r n = univ := by + classical + apply eq_univ_of_forall + intro x + have hex : ∃ n : ℕ, x ∈ ball (denseSeq (EuclideanSpace ℝ (Fin 2)) n) r := by + obtain ⟨n, hn⟩ : + ∃ n : ℕ, dist x (denseSeq (EuclideanSpace ℝ (Fin 2)) n) < (r : ℝ) := + (denseRange_denseSeq (EuclideanSpace ℝ (Fin 2))).exists_dist_lt x hr + exact ⟨n, Metric.mem_ball.mpr hn⟩ + let n := Nat.find hex + apply mem_iUnion.2 + refine ⟨n, Nat.find_spec hex, ?_⟩ + intro hx + obtain ⟨k, hk⟩ := mem_iUnion.1 hx + exact (Nat.not_lt_of_ge (Nat.find_min' hex hk)) k.isLt + +private theorem cells_meeting_subset_thickening + (r : ℝ≥0) (s : Set (EuclideanSpace ℝ (Fin 2))) : + (⋃ k : {n // (metricCell r n ∩ s).Nonempty}, metricCell r k) ⊆ + thickening (2 * r) s := by + intro x hx + obtain ⟨k, hxk⟩ := mem_iUnion.1 hx + obtain ⟨z, hzk, hzs⟩ := k.property + rw [Metric.mem_thickening_iff] + refine ⟨z, hzs, ?_⟩ + calc + dist x z ≤ + dist x (denseSeq (EuclideanSpace ℝ (Fin 2)) k) + + dist z (denseSeq (EuclideanSpace ℝ (Fin 2)) k) := + dist_triangle_right _ _ _ + _ < r + r := add_lt_add hxk.1 hzk.1 + _ = 2 * r := (two_mul (r : ℝ)).symm + +private def descendingRadius (R : ℕ → ℝ≥0) : ℕ → ℝ≥0 + | 0 => min 1 (R 0) + | n + 1 => min (descendingRadius R n / 2) (R (n + 1)) + +private theorem descendingRadius_pos {R : ℕ → ℝ≥0} (hR : ∀ n, 0 < R n) : + ∀ n, 0 < descendingRadius R n := by + intro n + induction n with + | zero => simpa only [descendingRadius, lt_min_iff, zero_lt_one, true_and] using hR 0 + | succ n ih => + rw [descendingRadius, lt_min_iff] + exact ⟨div_pos ih (by norm_num), hR (n + 1)⟩ + +private theorem descendingRadius_le (R : ℕ → ℝ≥0) (n : ℕ) : + descendingRadius R n ≤ R n := by + cases n with + | zero => exact min_le_right _ _ + | succ n => exact min_le_right _ _ + +private theorem descendingRadius_succ_lt {R : ℕ → ℝ≥0} (hR : ∀ n, 0 < R n) + (n : ℕ) : descendingRadius R (n + 1) < descendingRadius R n := by + calc + descendingRadius R (n + 1) ≤ descendingRadius R n / 2 := min_le_left _ _ + _ < descendingRadius R n := NNReal.half_lt_self (descendingRadius_pos hR n).ne' + +private theorem descendingRadius_le_invPow (R : ℕ → ℝ≥0) (n : ℕ) : + (descendingRadius R n : ℝ≥0∞) ≤ (2 : ℝ≥0∞)⁻¹ ^ n := by + induction n with + | zero => simpa only [descendingRadius, pow_zero, ENNReal.coe_one] using + ENNReal.coe_le_coe.mpr (min_le_left 1 (R 0)) + | succ n ih => + calc + (descendingRadius R (n + 1) : ℝ≥0∞) ≤ + (descendingRadius R n / 2 : ℝ≥0) := by + exact_mod_cast min_le_left (descendingRadius R n / 2) (R (n + 1)) + _ ≤ (2 : ℝ≥0∞)⁻¹ ^ n * 2⁻¹ := by + rw [ENNReal.coe_div (by norm_num), ENNReal.coe_two, div_eq_mul_inv] + gcongr + _ = (2 : ℝ≥0∞)⁻¹ ^ (n + 1) := (pow_succ _ _).symm + +private theorem exists_descendingRadius_interval {R : ℕ → ℝ≥0} {d : ℝ≥0∞} + (hd : 0 < d) (hdR : d < descendingRadius R 0) : + ∃ n : ℕ, (descendingRadius R (n + 1) : ℝ≥0∞) ≤ d ∧ + d < descendingRadius R n := by + classical + have hex : ∃ n : ℕ, (descendingRadius R n : ℝ≥0∞) ≤ d := by + obtain ⟨n, hn⟩ := ENNReal.exists_inv_two_pow_lt hd.ne' + exact ⟨n, (descendingRadius_le_invPow R n).trans hn.le⟩ + have hfind_ne : Nat.find hex ≠ 0 := by + intro hzero + exact (not_le_of_gt hdR) (by simpa only [hzero] using Nat.find_spec hex) + obtain ⟨n, hn⟩ := Nat.exists_eq_succ_of_ne_zero hfind_ne + refine ⟨n, by simpa only [hn] using Nat.find_spec hex, ?_⟩ + exact lt_of_not_ge (Nat.find_min hex (by omega : n < Nat.find hex)) + +/-- A finite Hausdorff set has an arbitrarily large subset that is straight up to any prescribed +factor larger than one, uniformly below some scale. -/ +private theorem exists_large_almostStraightSubset + {e : Set (EuclideanSpace ℝ (Fin 2))} (he : MeasurableSet e) + (he_fin : μH[1] e < ∞) {c d : ℝ≥0∞} (hd : d < μH[1] e) + (hc_pos : 0 < c) (hc_one : c < 1) : + ∃ a : Set (EuclideanSpace ℝ (Fin 2)), MeasurableSet a ∧ a ⊆ e ∧ d < μH[1] a ∧ + ∃ r : ℝ≥0∞, 0 < r ∧ ∀ s : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet s → Metric.ediam s ≤ r → + μH[1] (a ∩ s) ≤ c⁻¹ * Metric.ediam s := by + let μ : Measure (EuclideanSpace ℝ (Fin 2)) := μH[1].restrict e + have hμe : μ e = μH[1] e := Measure.restrict_apply_self μH[1] e + have hc_ne_top : c ≠ ∞ := hc_one.ne_top + have hweight_pos : 0 < 1 - c := tsub_pos_iff_lt.mpr hc_one + have hweight_ne_top : 1 - c ≠ ∞ := + ne_of_lt (lt_of_le_of_lt tsub_le_self ENNReal.one_lt_top) + have hmul : c * μH[1] e + (1 - c) * d < μH[1] e := by + calc + c * μH[1] e + (1 - c) * d < + c * μH[1] e + (1 - c) * μH[1] e := by + apply ENNReal.add_lt_add_left (ENNReal.mul_ne_top hc_ne_top he_fin.ne) + exact ENNReal.mul_lt_mul_right hweight_pos.ne' hweight_ne_top hd + _ = (c + (1 - c)) * μH[1] e := (add_mul _ _ _).symm + _ = μH[1] e := by rw [add_tsub_cancel_of_le hc_one.le, one_mul] + have hevent : ∀ᶠ r in 𝓝[>] (0 : ℝ≥0∞), + c * μH[1] e + (1 - c) * d < hausdorffPre (X := (EuclideanSpace ℝ (Fin 2))) r e := + (tendsto_hausdorffPre e).eventually (eventually_gt_nhds hmul) + obtain ⟨r, hr_pos, hr_large⟩ : + ∃ r : ℝ≥0∞, 0 < r ∧ + c * μH[1] e + (1 - c) * d < hausdorffPre (X := (EuclideanSpace ℝ (Fin 2))) r e := by + simpa only [mem_Ioi, and_comm] using (hevent.and self_mem_nhdsWithin).exists + let p : OuterMeasure (EuclideanSpace ℝ (Fin 2)) := hausdorffPre r + let Good : Set (Set (Set (EuclideanSpace ℝ (Fin 2)))) := + {C | (∀ b ∈ C, MeasurableSet b ∧ b ⊆ e ∧ p b < c * μ b) ∧ + C.PairwiseDisjoint id} + obtain ⟨C, hC⟩ : ∃ C, Maximal (fun D ↦ D ∈ Good) C := by + refine zorn_subset Good fun U hU hchain ↦ ?_ + refine ⟨⋃₀ U, ?_, fun D hD ↦ subset_sUnion_of_mem hD⟩ + refine ⟨?_, (pairwiseDisjoint_sUnion hchain.directedOn).2 fun D hD ↦ (hU hD).2⟩ + intro b hb + obtain ⟨D, hDU, hbD⟩ := hb + exact (hU hDU).1 b hbD + have hC_mem : C ∈ Good := hC.prop + have hC_pos (b : C) : 0 < μ b := by + have : 0 < c * μ b := (bot_le : 0 ≤ p b).trans_lt (hC_mem.1 b b.2).2.2 + exact (ENNReal.mul_pos_iff.mp this).2 + let : IsFiniteMeasure μ := + ⟨by simpa only [μ, Measure.restrict_apply_univ] using he_fin⟩ + have : Countable C := by + apply Set.countable_univ_iff.mp + have hcount := Measure.countable_meas_pos_of_disjoint_iUnion + (μ := μ) (As := fun b : C ↦ (b : Set (EuclideanSpace ℝ (Fin 2)))) + (fun b ↦ (hC_mem.1 b b.2).1) + (hC_mem.2.subtype _ _) + simpa only [hC_pos, ofPred_true] using hcount + have C_count : C.Countable := Set.countable_coe_iff.mp inferInstance + have hUnion_meas : MeasurableSet (⋃₀ C) := + MeasurableSet.sUnion C_count fun b hb ↦ (hC_mem.1 b hb).1 + have hUnion_sub : ⋃₀ C ⊆ e := + sUnion_subset fun b hb ↦ (hC_mem.1 b hb).2.1 + let a : Set (EuclideanSpace ℝ (Fin 2)) := e \ ⋃₀ C + have ha_meas : MeasurableSet a := he.diff hUnion_meas + have ha_sub : a ⊆ e := sdiff_subset + have no_bad {t : Set (EuclideanSpace ℝ (Fin 2))} (ht : MeasurableSet t) (hta : t ⊆ a) : + c * μ t ≤ p t := by + by_contra hnot + have ht_bad : p t < c * μ t := lt_of_not_ge hnot + have ht_pos : 0 < μ t := by + have : 0 < c * μ t := (bot_le : 0 ≤ p t).trans_lt ht_bad + exact (ENNReal.mul_pos_iff.mp this).2 + have ht_not_mem : t ∉ C := by + intro htC + have ht_empty : t = ∅ := by + apply eq_empty_iff_forall_notMem.mpr + intro x hxt + have hxa := hta hxt + exact hxa.2 (subset_sUnion_of_mem htC hxt) + rw [ht_empty, measure_empty] at ht_pos + exact (lt_irrefl 0 ht_pos) + apply ht_not_mem + apply hC.mem_of_prop_insert + refine ⟨?_, hC_mem.2.insert fun b hb hbt ↦ ?_⟩ + · intro b hb + rcases hb with rfl | hb + · exact ⟨ht, hta.trans ha_sub, ht_bad⟩ + · exact hC_mem.1 b hb + · exact Disjoint.mono hta (subset_sUnion_of_mem hb) disjoint_sdiff_left + have ha_large : d < μH[1] a := by + have hμa : μ a = μH[1] a := by + change (μH[1].restrict e) a = μH[1] a + rw [Measure.restrict_apply ha_meas, inter_eq_left.mpr ha_sub] + by_contra hnot + have hμa_le : μ a ≤ d := by simpa only [hμa] using not_lt.mp hnot + have hpa : p a ≤ μ a := by + calc + p a ≤ μH[1] a := hausdorffPre_le hr_pos a + _ = μ a := hμa.symm + have hE_union : e = ⋃₀ C ∪ a := by + change e = ⋃₀ C ∪ (e \ ⋃₀ C) + rw [union_sdiff_cancel hUnion_sub] + have hp_union : p (⋃₀ C) ≤ ∑' b : C, p b := by + rw [sUnion_eq_biUnion] + exact measure_biUnion_le p C_count id + have hμ_union : μ (⋃₀ C) = ∑' b : C, μ b := + measure_sUnion C_count hC_mem.2 fun b hb ↦ (hC_mem.1 b hb).1 + have hpμ : ∑' b : C, p b ≤ c * ∑' b : C, μ b := by + calc + (∑' b : C, p b) ≤ ∑' b : C, c * μ b := + ENNReal.tsum_le_tsum fun b ↦ (hC_mem.1 b b.2).2.2.le + _ = c * ∑' b : C, μ b := ENNReal.tsum_mul_left + have hμ_parts : μ e = μ (⋃₀ C) + μ a := by + rw [hE_union, MeasureTheory.measure_union disjoint_sdiff_right ha_meas] + have hp_total : p e ≤ c * μ (⋃₀ C) + μ a := by + calc + p e = p (⋃₀ C ∪ a) := congrArg p hE_union + p (⋃₀ C ∪ a) ≤ p (⋃₀ C) + p a := measure_union_le _ _ + _ ≤ (∑' b : C, p b) + μ a := add_le_add hp_union hpa + _ ≤ c * ∑' b : C, μ b + μ a := add_le_add hpμ le_rfl + _ = c * μ (⋃₀ C) + μ a := by rw [hμ_union] + have hbound : c * μ (⋃₀ C) + μ a ≤ + c * μ e + (1 - c) * d := by + calc + c * μ (⋃₀ C) + μ a = + c * (μ (⋃₀ C) + μ a) + (1 - c) * μ a := by + rw [mul_add, add_assoc, ← add_mul, add_tsub_cancel_of_le hc_one.le, one_mul] + _ = c * μ e + (1 - c) * μ a := by rw [← hμ_parts] + _ ≤ c * μ e + (1 - c) * d := by gcongr + exact (not_lt_of_ge (by simpa only [p, hμe] using hp_total.trans hbound)) hr_large + refine ⟨a, ha_meas, ha_sub, ha_large, r, hr_pos, ?_⟩ + intro s hs hsr + have hca : c * μ (a ∩ s) ≤ p (a ∩ s) := + no_bad (ha_meas.inter hs) inter_subset_left + have hpre : p (a ∩ s) ≤ Metric.ediam (a ∩ s) := + OuterMeasure.mkMetric'.pre_le ((Metric.ediam_mono inter_subset_right).trans hsr) + have hmass : μH[1] (a ∩ s) = μ (a ∩ s) := by + change μH[1] (a ∩ s) = (μH[1].restrict e) (a ∩ s) + rw [Measure.restrict_apply (ha_meas.inter hs)] + rw [inter_eq_left.mpr (inter_subset_left.trans ha_sub)] + rw [hmass] + calc + μ (a ∩ s) = c⁻¹ * (c * μ (a ∩ s)) := by + rw [← mul_assoc, ENNReal.inv_mul_cancel hc_pos.ne' hc_one.ne_top, one_mul] + _ ≤ c⁻¹ * p (a ∩ s) := by gcongr + _ ≤ c⁻¹ * Metric.ediam (a ∩ s) := by gcongr + _ ≤ c⁻¹ * Metric.ediam s := by + gcongr + exact inter_subset_right + +/-- A positive finite Hausdorff set has a positive subset with asymptotically sharp bounds at a +sequence of scales. -/ +private theorem exists_multiscaleAlmostStraightSubset + {e : Set (EuclideanSpace ℝ (Fin 2))} (he : MeasurableSet e) + (he_pos : 0 < μH[1] e) (he_fin : μH[1] e < ∞) : + ∃ a : Set (EuclideanSpace ℝ (Fin 2)), MeasurableSet a ∧ a ⊆ e ∧ 0 < μH[1] a ∧ + ∀ n : ℕ, ∃ r : ℝ≥0∞, 0 < r ∧ ∀ s : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet s → Metric.ediam s ≤ r → + μH[1] (a ∩ s) ≤ (1 + lossWeight n) * Metric.ediam s := by + have hexists (n : ℕ) : + ∃ a : Set (EuclideanSpace ℝ (Fin 2)), MeasurableSet a ∧ a ⊆ e ∧ + μH[1] e - lossWeight n * μH[1] e < μH[1] a ∧ + ∃ r : ℝ≥0∞, 0 < r ∧ ∀ s : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet s → Metric.ediam s ≤ r → + μH[1] (a ∩ s) ≤ (1 + lossWeight n) * Metric.ediam s := by + have hd : μH[1] e - lossWeight n * μH[1] e < μH[1] e := + ENNReal.sub_lt_self he_fin.ne he_pos.ne' + (ENNReal.mul_pos_iff.mpr ⟨lossWeight_pos n, he_pos⟩).ne' + have hc_pos : 0 < (1 + lossWeight n)⁻¹ := by + rw [ENNReal.inv_pos] + exact ENNReal.add_ne_top.mpr ⟨ENNReal.one_ne_top, (lossWeight_lt_one n).ne_top⟩ + have hc_one : (1 + lossWeight n)⁻¹ < 1 := by + rw [ENNReal.inv_lt_one] + exact ENNReal.lt_add_right ENNReal.one_ne_top (lossWeight_pos n).ne' + simpa only [inv_inv] using exists_large_almostStraightSubset he he_fin hd hc_pos hc_one + choose A hA_meas hA_sub hA_large r hr_pos hlocal using hexists + have hcomplement (n : ℕ) : + μH[1] (e \ A n) < lossWeight n * μH[1] e := by + have hA_fin : μH[1] (A n) ≠ ∞ := + (lt_of_le_of_lt (measure_mono (hA_sub n)) he_fin).ne + rw [measure_sdiff (hA_sub n) (hA_meas n).nullMeasurableSet hA_fin] + apply (ENNReal.sub_lt_iff_lt_left hA_fin (measure_mono (hA_sub n))).2 + have hweight_le : lossWeight n * μH[1] e ≤ μH[1] e := by + calc + lossWeight n * μH[1] e ≤ 1 * μH[1] e := by gcongr; exact (lossWeight_lt_one n).le + _ = μH[1] e := one_mul _ + have hweight_ne_top : lossWeight n * μH[1] e ≠ ∞ := + ENNReal.mul_ne_top (lossWeight_lt_one n).ne_top he_fin.ne + simpa only [add_comm] using + (ENNReal.sub_lt_iff_lt_left hweight_ne_top hweight_le).1 (hA_large n) + let u : Set (EuclideanSpace ℝ (Fin 2)) := ⋃ n : ℕ, e \ A n + have hu_meas : MeasurableSet u := MeasurableSet.iUnion fun n ↦ he.diff (hA_meas n) + have hu_sub : u ⊆ e := iUnion_subset fun _ ↦ sdiff_subset + have hu_lt : μH[1] u < μH[1] e := by + calc + μH[1] u ≤ ∑' n : ℕ, μH[1] (e \ A n) := measure_iUnion_le _ + _ ≤ ∑' n : ℕ, lossWeight n * μH[1] e := + ENNReal.tsum_le_tsum fun n ↦ (hcomplement n).le + _ = (∑' n : ℕ, lossWeight n) * μH[1] e := ENNReal.tsum_mul_right + _ = (4 : ℝ≥0∞)⁻¹ * μH[1] e := by rw [tsum_lossWeight] + _ < μH[1] e := by + calc + (4 : ℝ≥0∞)⁻¹ * μH[1] e < 1 * μH[1] e := + ENNReal.mul_lt_mul_left he_pos.ne' he_fin.ne + (ENNReal.inv_lt_one.mpr (by norm_num)) + _ = μH[1] e := one_mul _ + let a : Set (EuclideanSpace ℝ (Fin 2)) := e \ u + have ha_meas : MeasurableSet a := he.diff hu_meas + have ha_sub : a ⊆ e := sdiff_subset + have ha_A (n : ℕ) : a ⊆ A n := by + intro x hx + by_contra hxA + exact hx.2 (mem_iUnion.2 ⟨n, hx.1, hxA⟩) + have ha_pos : 0 < μH[1] a := by + by_contra hnot + have ha_zero : μH[1] a = 0 := nonpos_iff_eq_zero.mp (not_lt.mp hnot) + have he_union : e = u ∪ a := by + change e = u ∪ (e \ u) + rw [union_sdiff_cancel hu_sub] + have hparts : μH[1] e = μH[1] u + μH[1] a := by + rw [he_union, MeasureTheory.measure_union disjoint_sdiff_right ha_meas] + rw [ha_zero, add_zero] at hparts + exact hu_lt.ne hparts.symm + refine ⟨a, ha_meas, ha_sub, ha_pos, fun n ↦ ⟨r n, hr_pos n, ?_⟩⟩ + intro s hs hsr + exact (measure_mono (inter_subset_inter_left s (ha_A n))).trans + (hlocal n s hs hsr) + +private theorem exists_small_positive_subset + {A : Set (EuclideanSpace ℝ (Fin 2))} (hA_meas : MeasurableSet A) + (hA_pos : 0 < μH[1] A) (hA_fin : μH[1] A < ∞) + (bound : ℝ≥0) (hbound : 0 < bound) : + ∃ E, MeasurableSet E ∧ E ⊆ A ∧ 0 < μH[1] E ∧ μH[1] E < bound := by + classical + let : NullSingletonClass (μH[1] : Measure (EuclideanSpace ℝ (Fin 2))) := + Measure.nullSingletonClass_hausdorff (EuclideanSpace ℝ (Fin 2)) (by norm_num) + obtain ⟨c, hc_pos, hc_small⟩ := + ENNReal.exists_nnreal_pos_mul_lt hA_fin.ne (ENNReal.coe_pos.mpr hbound).ne' + let c' : ℝ≥0 := min c 1 + have hc'_pos : 0 < c' := lt_min hc_pos zero_lt_one + have hc'_one : c' ≤ 1 := min_le_right _ _ + let μA : Measure (EuclideanSpace ℝ (Fin 2)) := μH[1].restrict A + let : IsFiniteMeasure μA := + ⟨by simpa only [μA, Measure.restrict_apply_univ] using hA_fin⟩ + obtain ⟨E, hE_meas, hE_sub, hE_mass⟩ := exists_subset_measure_eq_mul + (μ := μA) hA_meas (q := (c' : ℝ)) c'.2 (by exact_mod_cast hc'_one) + have hμA_A : μA A = μH[1] A := Measure.restrict_apply_self μH[1] A + have hμA_E : μA E = μH[1] E := by + change (μH[1].restrict A) E = μH[1] E + rw [Measure.restrict_apply hE_meas, inter_eq_left.mpr hE_sub] + have hE_mass' : μH[1] E = (c' : ℝ≥0∞) * μH[1] A := by + simpa only [hμA_E, hμA_A, ENNReal.ofReal_coe_nnreal] using hE_mass + have hE_pos : 0 < μH[1] E := by + rw [hE_mass', ENNReal.mul_pos_iff] + exact ⟨ENNReal.coe_pos.mpr hc'_pos, hA_pos⟩ + have hE_small : μH[1] E < bound := by + rw [hE_mass'] + apply lt_of_le_of_lt _ hc_small + gcongr + exact min_le_left c 1 + exact ⟨E, hE_meas, hE_sub, hE_pos, hE_small⟩ + +private theorem measure_iUnion_cell_thinning + (μ : Measure (EuclideanSpace ℝ (Fin 2))) {E : Set (EuclideanSpace ℝ (Fin 2))} + (hE_meas : MeasurableSet E) (mesh : ℝ≥0) (fraction : ℝ≥0∞) + (S : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (hS_meas : ∀ k, MeasurableSet (S k)) + (hS_sub : ∀ k, S k ⊆ E ∩ metricCell mesh k) + (hS_mass : ∀ k, μ (S k) = fraction * μ (E ∩ metricCell mesh k)) (K : Set ℕ) : + μ (⋃ k : K, S k) = fraction * μ (⋃ k : K, E ∩ metricCell mesh k) := by + have hS_disj : Pairwise (Disjoint on fun k : K ↦ S k) := by + intro i j hij + exact Disjoint.mono (hS_sub i) (hS_sub j) <| + Disjoint.mono inter_subset_right inter_subset_right <| + pairwiseDisjoint_metricCell mesh (Subtype.coe_ne_coe.mpr hij) + have hcell_disj : Pairwise + (Disjoint on fun k : K ↦ E ∩ metricCell mesh k) := by + intro i j hij + exact Disjoint.mono inter_subset_right inter_subset_right <| + pairwiseDisjoint_metricCell mesh (Subtype.coe_ne_coe.mpr hij) + calc + μ (⋃ k : K, S k) = ∑' k : K, μ (S k) := + measure_iUnion hS_disj fun k ↦ hS_meas k + _ = ∑' k : K, fraction * + μ (E ∩ metricCell mesh k) := by + congr 1 + funext k + exact hS_mass k + _ = fraction * + ∑' k : K, μ (E ∩ metricCell mesh k) := ENNReal.tsum_mul_left + _ = fraction * + μ (⋃ k : K, E ∩ metricCell mesh k) := by + rw [measure_iUnion hcell_disj fun k ↦ + hE_meas.inter (measurableSet_metricCell _ _)] + +private theorem measure_iUnion_losses_lt + (μ : Measure (EuclideanSpace ℝ (Fin 2))) (E : Set (EuclideanSpace ℝ (Fin 2))) + (T : ℕ → Set (EuclideanSpace ℝ (Fin 2))) (hpositive : 0 < μ E) (hfinite : μ E < ∞) + (hT_loss : ∀ n, μ (E \ T n) = 2 * lossWeight n * μ E) : + μ (⋃ n : ℕ, E \ T n) < μ E := by + calc + μ (⋃ n : ℕ, E \ T n) ≤ ∑' n : ℕ, μ (E \ T n) := measure_iUnion_le _ + _ = ∑' n : ℕ, (2 * lossWeight n) * μ E := by + congr 1 + funext n + exact hT_loss n + _ = (∑' n : ℕ, 2 * lossWeight n) * μ E := ENNReal.tsum_mul_right + _ = (2 * ∑' n : ℕ, lossWeight n) * μ E := by rw [ENNReal.tsum_mul_left] + _ = (2 * (4 : ℝ≥0∞)⁻¹) * μ E := by rw [tsum_lossWeight] + _ < μ E := by + calc + (2 * (4 : ℝ≥0∞)⁻¹) * μ E < 1 * μ E := + ENNReal.mul_lt_mul_left hpositive.ne' + hfinite.ne (by + calc + 2 * (4 : ℝ≥0∞)⁻¹ < 2 * (2 : ℝ≥0∞)⁻¹ := by + apply ENNReal.mul_lt_mul_right (by norm_num) (by norm_num) + exact ENNReal.inv_lt_inv.mpr (by norm_num) + _ = 1 := ENNReal.mul_inv_cancel (by norm_num) (by norm_num)) + _ = μ E := one_mul _ + +/-- Every measurable set of positive finite Hausdorff one-measure has a positive straight piece. -/ +theorem exists_straight_measure_restrict_subset + {e : Set (EuclideanSpace ℝ (Fin 2))} (he : MeasurableSet e) + (he_pos : 0 < μH[1] e) (he_fin : μH[1] e < ∞) : + ∃ a : Set (EuclideanSpace ℝ (Fin 2)), MeasurableSet a ∧ a ⊆ e ∧ 0 < μH[1] a ∧ + IsStraightMeasure (μH[1].restrict a) := by + classical + let : NullSingletonClass (μH[1] : Measure (EuclideanSpace ℝ (Fin 2))) := + Measure.nullSingletonClass_hausdorff (EuclideanSpace ℝ (Fin 2)) (by norm_num) + obtain ⟨A, hA_meas, hA_sub, hA_pos, hscale⟩ := + exists_multiscaleAlmostStraightSubset he he_pos he_fin + choose r hr_pos hlocal using hscale + have hA_fin : μH[1] A < ∞ := (measure_mono hA_sub).trans_lt he_fin + have hR_exists (n : ℕ) : + ∃ R : ℝ≥0, 0 < R ∧ (R : ℝ≥0∞) * 2 < r n := + ENNReal.exists_nnreal_pos_mul_lt (by norm_num) (hr_pos n).ne' + choose R hR_pos hR_scale using hR_exists + let ρ : ℕ → ℝ≥0 := descendingRadius R + have hρ_pos (n : ℕ) : 0 < ρ n := descendingRadius_pos hR_pos n + have hρ_R (n : ℕ) : ρ n ≤ R n := descendingRadius_le R n + obtain ⟨E, hE_meas, hE_sub, hE_pos, hE_small⟩ := + exists_small_positive_subset hA_meas hA_pos hA_fin (ρ 0) (hρ_pos 0) + have hE_sub_e : E ⊆ e := hE_sub.trans hA_sub + have hE_fin : μH[1] E < ∞ := (measure_mono hE_sub_e).trans_lt he_fin + let μ : Measure (EuclideanSpace ℝ (Fin 2)) := μH[1].restrict E + let : IsFiniteMeasure μ := + ⟨by simpa only [μ, Measure.restrict_apply_univ] using hE_fin⟩ + let mesh (n : ℕ) : ℝ≥0 := + (lossWeight n).toNNReal * ρ (n + 1) / 4 + have hmesh_pos (n : ℕ) : 0 < mesh n := by + dsimp only [mesh] + exact div_pos (mul_pos (ENNReal.toNNReal_pos (lossWeight_pos n).ne' + (lossWeight_lt_one n).ne_top) (hρ_pos (n + 1))) (by norm_num) + have hselect (n k : ℕ) : + ∃ t : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet t ∧ t ⊆ E ∩ metricCell (mesh n) k ∧ + μ t = (thinningFraction n : ℝ≥0∞) * + μ (E ∩ metricCell (mesh n) k) := by + simpa only [ENNReal.ofReal_coe_nnreal] using exists_subset_measure_eq_mul + (μ := μ) (hE_meas.inter (measurableSet_metricCell _ _)) + (q := (thinningFraction n : ℝ)) (thinningFraction n).2 + (by exact_mod_cast thinningFraction_le_one n) + choose S hS_meas hS_sub hS_mass using hselect + have hmeasure_selected (n : ℕ) (K : Set ℕ) := + measure_iUnion_cell_thinning μ hE_meas (mesh n) (thinningFraction n) (S n) + (hS_meas n) (hS_sub n) (hS_mass n) K + let T (n : ℕ) : Set (EuclideanSpace ℝ (Fin 2)) := ⋃ k : (univ : Set ℕ), S n k + have hT_meas (n : ℕ) : MeasurableSet (T n) := + MeasurableSet.iUnion fun k ↦ hS_meas n k + have hT_sub (n : ℕ) : T n ⊆ E := + iUnion_subset fun k ↦ (hS_sub n k).trans inter_subset_left + have hcells_univ (n : ℕ) : + (⋃ k : (univ : Set ℕ), E ∩ metricCell (mesh n) k) = E := by + apply Subset.antisymm + · exact iUnion_subset fun _ ↦ inter_subset_left + · intro x hxE + have hxcell : x ∈ ⋃ k : ℕ, metricCell (mesh n) k := by + rw [iUnion_metricCell (mesh n) (hmesh_pos n)] + exact mem_univ x + obtain ⟨k, hxk⟩ := mem_iUnion.1 hxcell + exact mem_iUnion.2 ⟨⟨k, mem_univ k⟩, hxE, hxk⟩ + have hT_mass (n : ℕ) : + μ (T n) = (thinningFraction n : ℝ≥0∞) * μ E := by + change μ (⋃ k : (univ : Set ℕ), S n k) = + (thinningFraction n : ℝ≥0∞) * μ E + rw [hmeasure_selected n univ, hcells_univ] + have hμ_E : μ E = μH[1] E := Measure.restrict_apply_self μH[1] E + have hT_loss (n : ℕ) : + μ (E \ T n) = 2 * lossWeight n * μ E := by + have hT_fin : μ (T n) ≠ ∞ := + (lt_of_le_of_lt (measure_mono (hT_sub n)) (by simpa only [hμ_E] using hE_fin)).ne + rw [measure_sdiff (hT_sub n) (hT_meas n).nullMeasurableSet hT_fin, hT_mass] + calc + μ E - (thinningFraction n : ℝ≥0∞) * μ E = + (1 - thinningFraction n) * μ E := by + rw [ENNReal.sub_mul (fun _ _ ↦ (by simpa only [hμ_E] using hE_fin.ne)), one_mul] + _ = 2 * lossWeight n * μ E := by rw [one_sub_thinningFraction_ennreal] + let bad : Set (EuclideanSpace ℝ (Fin 2)) := ⋃ n : ℕ, E \ T n + have hbad_meas : MeasurableSet bad := + MeasurableSet.iUnion fun n ↦ hE_meas.diff (hT_meas n) + have hbad_sub : bad ⊆ E := iUnion_subset fun _ ↦ sdiff_subset + have hbad_lt : μ bad < μ E := + measure_iUnion_losses_lt μ E T (by simpa only [hμ_E] using hE_pos) + (by simpa only [hμ_E] using hE_fin) hT_loss + let a : Set (EuclideanSpace ℝ (Fin 2)) := E \ bad + have ha_meas : MeasurableSet a := hE_meas.diff hbad_meas + have ha_sub_E : a ⊆ E := sdiff_subset + have ha_sub_e : a ⊆ e := ha_sub_E.trans hE_sub_e + have ha_T (n : ℕ) : a ⊆ T n := by + intro x hx + by_contra hxT + exact hx.2 (mem_iUnion.2 ⟨n, hx.1, hxT⟩) + have hμ_a : μ a = μH[1] a := by + change (μH[1].restrict E) a = μH[1] a + rw [Measure.restrict_apply ha_meas, inter_eq_left.mpr ha_sub_E] + have ha_pos : 0 < μH[1] a := by + rw [← hμ_a] + by_contra hnot + have ha_zero : μ a = 0 := nonpos_iff_eq_zero.mp (not_lt.mp hnot) + have he_union : E = bad ∪ a := by + change E = bad ∪ (E \ bad) + rw [union_sdiff_cancel hbad_sub] + have hparts : μ E = μ bad + μ a := by + rw [he_union, MeasureTheory.measure_union disjoint_sdiff_right ha_meas] + rw [ha_zero, add_zero] at hparts + exact hbad_lt.ne hparts.symm + refine ⟨a, ha_meas, ha_sub_e, ha_pos, ?_⟩ + intro s hs + rw [Measure.restrict_apply hs] + have has_sub_E : s ∩ a ⊆ E := inter_subset_right.trans ha_sub_E + rcases eq_or_lt_of_le (bot_le : 0 ≤ Metric.ediam s) with hdiam | hdiam + · have hs_zero : μH[1] s = 0 := + (Metric.ediam_eq_zero_iff.mp hdiam.symm).measure_zero μH[1] + calc + μH[1] (s ∩ a) ≤ μH[1] s := measure_mono inter_subset_left + _ = 0 := hs_zero + _ = Metric.ediam s := hdiam + by_cases hlarge : (ρ 0 : ℝ≥0∞) ≤ Metric.ediam s + · calc + μH[1] (s ∩ a) ≤ μH[1] E := measure_mono has_sub_E + _ ≤ (ρ 0 : ℝ≥0∞) := hE_small.le + _ ≤ Metric.ediam s := hlarge + obtain ⟨n, hn_lower, hn_upper⟩ := + exists_descendingRadius_interval hdiam (lt_of_not_ge hlarge) + let K : Set ℕ := {k | (metricCell (mesh n) k ∩ s).Nonempty} + let V : Set (EuclideanSpace ℝ (Fin 2)) := ⋃ k : K, S n k + let W : Set (EuclideanSpace ℝ (Fin 2)) := ⋃ k : K, E ∩ metricCell (mesh n) k + have has_V : s ∩ a ⊆ V := by + intro x hx + have hxT := ha_T n hx.2 + change x ∈ ⋃ k : (univ : Set ℕ), S n k at hxT + obtain ⟨k, hxS⟩ := mem_iUnion.1 hxT + have hxcell : x ∈ metricCell (mesh n) k := (hS_sub n k hxS).2 + exact mem_iUnion.2 ⟨⟨k, ⟨x, hxcell, hx.1⟩⟩, hxS⟩ + have hW_sub : W ⊆ E ∩ thickening (2 * mesh n) s := by + intro x hx + obtain ⟨k, hxk⟩ := mem_iUnion.1 hx + refine ⟨hxk.1, cells_meeting_subset_thickening (mesh n) s ?_⟩ + exact mem_iUnion.2 ⟨k, hxk.2⟩ + have hmesh_eq : (4 : ℝ≥0∞) * mesh n = + lossWeight n * (ρ (n + 1) : ℝ≥0∞) := by + have hNN : (4 : ℝ≥0) * mesh n = + (lossWeight n).toNNReal * ρ (n + 1) := by + dsimp only [mesh] + rw [mul_comm, div_mul_cancel₀ _ (by norm_num)] + rw [← ENNReal.coe_toNNReal (lossWeight_lt_one n).ne_top] + exact_mod_cast hNN + have hmesh_bound : (4 : ℝ≥0∞) * mesh n ≤ + lossWeight n * Metric.ediam s := by + rw [hmesh_eq] + gcongr + have hed_thick : Metric.ediam (thickening (2 * mesh n) s) ≤ + (1 + lossWeight n) * Metric.ediam s := by + calc + Metric.ediam (thickening (2 * mesh n) s) ≤ + Metric.ediam s + 2 * (2 * mesh n : ℝ≥0) := + Metric.ediam_thickening_le (s := s) (2 * mesh n) + _ = Metric.ediam s + (4 : ℝ≥0∞) * mesh n := by norm_num; ring + _ ≤ Metric.ediam s + lossWeight n * Metric.ediam s := add_le_add le_rfl hmesh_bound + _ = (1 + lossWeight n) * Metric.ediam s := by rw [add_mul, one_mul] + have hed_scale : Metric.ediam (thickening (2 * mesh n) s) ≤ r n := by + exact hed_thick.trans <| le_of_lt <| by + calc + (1 + lossWeight n) * Metric.ediam s ≤ 2 * Metric.ediam s := by + gcongr + calc + 1 + lossWeight n ≤ 1 + 1 := by gcongr; exact (lossWeight_lt_one n).le + _ = 2 := one_add_one_eq_two + _ < 2 * (ρ n : ℝ≥0∞) := + ENNReal.mul_lt_mul_right (by norm_num) (by norm_num) hn_upper + _ ≤ 2 * (R n : ℝ≥0∞) := by gcongr; exact hρ_R n + _ < r n := by simpa only [mul_comm] using hR_scale n + have hμ_W : μ W ≤ μH[1] (E ∩ thickening (2 * mesh n) s) := by + calc + μ W ≤ μ (E ∩ thickening (2 * mesh n) s) := measure_mono hW_sub + _ = μH[1] (E ∩ thickening (2 * mesh n) s) := by + change (μH[1].restrict E) (E ∩ thickening (2 * mesh n) s) = _ + rw [Measure.restrict_apply + (hE_meas.inter Metric.isOpen_thickening.measurableSet)] + congr 1 + exact inter_eq_left.mpr inter_subset_left + have hlocal_thick : μH[1] (E ∩ thickening (2 * mesh n) s) ≤ + (1 + lossWeight n) * Metric.ediam (thickening (2 * mesh n) s) := + (measure_mono (inter_subset_inter_left _ hE_sub)).trans <| + hlocal n _ Metric.isOpen_thickening.measurableSet hed_scale + have hμ_sa : μH[1] (s ∩ a) = μ (s ∩ a) := by + change μH[1] (s ∩ a) = (μH[1].restrict E) (s ∩ a) + rw [Measure.restrict_apply (hs.inter ha_meas), inter_eq_left.mpr has_sub_E] + rw [hμ_sa] + calc + μ (s ∩ a) ≤ μ V := measure_mono has_V + _ = (thinningFraction n : ℝ≥0∞) * μ W := hmeasure_selected n K + _ ≤ (thinningFraction n : ℝ≥0∞) * + μH[1] (E ∩ thickening (2 * mesh n) s) := by gcongr + _ ≤ (thinningFraction n : ℝ≥0∞) * + ((1 + lossWeight n) * Metric.ediam (thickening (2 * mesh n) s)) := by gcongr + _ ≤ (thinningFraction n : ℝ≥0∞) * + ((1 + lossWeight n) * ((1 + lossWeight n) * Metric.ediam s)) := by gcongr + _ = ((thinningFraction n : ℝ≥0∞) * (1 + lossWeight n) ^ 2) * + Metric.ediam s := by ring + _ ≤ 1 * Metric.ediam s := by gcongr; exact thinningFraction_compensates n + _ = Metric.ediam s := one_mul _ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Rectifiability/StraightReduction.lean b/LeanPool/Besicovitch/Rectifiability/StraightReduction.lean new file mode 100644 index 0000000000..53ba039803 --- /dev/null +++ b/LeanPool/Besicovitch/Rectifiability/StraightReduction.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Measure.DensityLocalization +public import LeanPool.Besicovitch.Rectifiability.Decomposition + +/-! +# Reduction to a straight purely unrectifiable set + +A hypothetical nonrectifiable finite set has a positive purely unrectifiable part. A straight +piece of that part retains every strictly smaller lower-density threshold almost everywhere. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal MeasureTheory + +namespace LeanPool.Besicovitch + +/-- A nonrectifiable finite set with density at least `gamma` contains a positive straight, +purely unrectifiable subset with density strictly above every `beta < gamma`. -/ +theorem exists_pure_straight_subset_of_not_rectifiable + {e : Set (EuclideanSpace ℝ (Fin 2))} (he : MeasurableSet e) (he_fin : μH[1] e < ∞) + (he_not_rectifiable : ¬IsCountablyOneRectifiable e) + {beta gamma : ℝ} (hbeta : 0 ≤ beta) (hbeta_gamma : beta < gamma) + (hdensity : ∀ᵐ x ∂μH[1].restrict e, + ENNReal.ofReal gamma ≤ lowerOneDensity e x) : + ∃ a : Set (EuclideanSpace ℝ (Fin 2)), + MeasurableSet a ∧ a ⊆ e ∧ 0 < μH[1] a ∧ μH[1] a < ∞ ∧ + IsPurelyOneUnrectifiable a ∧ IsStraightMeasure (μH[1].restrict a) ∧ + ∀ᵐ x ∂μH[1].restrict a, + ENNReal.ofReal beta < lowerOneDensity a x := by + obtain ⟨r, p, hr_measurable, hp_measurable, hr_subset, hp_eq, + hr_rectifiable, hp_pure⟩ := + exists_rectifiable_pure_decomposition he he_fin + have hp_subset : p ⊆ e := by + rw [hp_eq] + exact sdiff_subset + have hp_fin : μH[1] p < ∞ := (measure_mono hp_subset).trans_lt he_fin + have hp_pos : 0 < μH[1] p := by + apply pos_iff_ne_zero.mpr + intro hp_zero + have hp_rectifiable : IsCountablyOneRectifiable p := + isCountablyOneRectifiable_of_measure_zero hp_zero + have he_union : e = r ∪ p := by + rw [hp_eq] + exact (union_sdiff_cancel hr_subset).symm + exact he_not_rectifiable (he_union ▸ hr_rectifiable.union hp_rectifiable) + obtain ⟨a, ha_measurable, ha_subset_p, ha_pos, ha_straight⟩ := + exists_straight_measure_restrict_subset hp_measurable hp_pos hp_fin + have ha_subset_e : a ⊆ e := ha_subset_p.trans hp_subset + have ha_fin : μH[1] a < ∞ := (measure_mono ha_subset_e).trans_lt he_fin + have ha_pure : IsPurelyOneUnrectifiable a := hp_pure.mono ha_subset_p + have hdensity_a : ∀ᵐ x ∂μH[1].restrict a, + ENNReal.ofReal gamma ≤ lowerOneDensity e x := + ae_mono (Measure.restrict_mono ha_subset_e le_rfl) hdensity + have ha_density := ae_lt_lowerOneDensity_of_subset_of_straight + ha_measurable ha_subset_e he_fin ha_straight hbeta hbeta_gamma hdensity_a + exact ⟨a, ha_measurable, ha_subset_e, ha_pos, ha_fin, ha_pure, ha_straight, ha_density⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Sigma/Basic.lean b/LeanPool/Besicovitch/Sigma/Basic.lean new file mode 100644 index 0000000000..a20bb954da --- /dev/null +++ b/LeanPool/Besicovitch/Sigma/Basic.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement + +/-! +# Basic facts about the one-dimensional rectifiability threshold + +The forcing property is monotone in its density threshold. +-/ + +@[expose] public section + +noncomputable section + +open MeasureTheory Set +open scoped ENNReal MeasureTheory + +namespace LeanPool.Besicovitch + +variable (X : Type*) [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- Forcing is monotone in the threshold: a larger density hypothesis is a stronger one. -/ +theorem ForcesOneRectifiability.mono {β β' : ℝ≥0∞} (h : β ≤ β') + (hβ : ForcesOneRectifiability X β) : ForcesOneRectifiability X β' := by + intro s hs hfinite hdensity + exact hβ s hs hfinite (hdensity.mono fun _ hx ↦ h.trans hx) + +/-- The admissible thresholds are bounded below, by `0`. -/ +theorem bddBelow_admissibleThresholds : + BddBelow {β : ℝ | 0 ≤ β ∧ ForcesOneRectifiability X (ENNReal.ofReal β)} := + ⟨0, fun _ h ↦ h.1⟩ + +/-- An admissible nonnegative threshold bounds `sigmaOne` from above. -/ +theorem sigmaOne_le_of_forces {b : ℝ} (hb : 0 ≤ b) + (hforce : ForcesOneRectifiability X (ENNReal.ofReal b)) : sigmaOne X ≤ b := by + apply csInf_le + · exact ⟨0, fun _ h ↦ h.1⟩ + · exact ⟨hb, hforce⟩ + +/-- Forcing rectifiability at every threshold above `b` proves `sigmaOne ≤ b`. -/ +theorem sigmaOne_le_of_forall_gt {b : ℝ} (hb : 0 ≤ b) + (hforce : ∀ c : ℝ, b < c → ForcesOneRectifiability X (ENNReal.ofReal c)) : + sigmaOne X ≤ b := by + apply le_of_forall_pos_le_add + intro ε hε + apply sigmaOne_le_of_forces X (add_nonneg hb hε.le) + exact hforce (b + ε) (lt_add_of_pos_right b hε) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/AlgebraicBasic.lean b/LeanPool/Besicovitch/SixPoint/AlgebraicBasic.lean new file mode 100644 index 0000000000..f2ea221291 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/AlgebraicBasic.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement + +/-! +# Basic properties of the six-point endpoint + +This file records the rational bounds built into `IsEndpointPair` and the +order-theoretic consequences of defining `cStar` as an infimum. The strict +lower bound for `sStar` requires uniqueness of the isolated first coordinate. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The polynomial residual obtained by squaring the endpoint balance equation. -/ +def endpointBalanceResidual (c B : ℝ) : ℝ := + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - c ^ 2 + let R := 3 * c * b + c ^ 2 - 1 + (R ^ 2 - A2 - C2) ^ 2 - 4 * A2 * C2 + +/-- The residual of the endpoint Gram equation. -/ +def endpointGramResidual (c B : ℝ) : ℝ := + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - c ^ 2) / 2 + (k - x * z) ^ 2 - (1 - x ^ 2) * (b ^ 2 - z ^ 2) + +/-- The signed polynomial system used to isolate the exact endpoint pair. -/ +def IsEndpointPolynomialPair (c B : ℝ) : Prop := + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - c ^ 2 + let R := 3 * c * b + c ^ 2 - 1 + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - c ^ 2) / 2 + 13866128436518096 / 10 ^ 16 < c ∧ c < 13866128436518100 / 10 ^ 16 ∧ + 2873744161801659 / 10 ^ 15 < B ∧ B < 2873744161801662 / 10 ^ 15 ∧ + 0 < A2 ∧ 0 < C2 ∧ 0 < R ∧ 0 < R ^ 2 - A2 - C2 ∧ + endpointBalanceResidual c B = 0 ∧ endpointGramResidual c B = 0 ∧ + x < 0 ∧ z < 0 ∧ k - x * z < 0 + +/-- The first coordinate of an endpoint pair lies in its rational isolation box. -/ +theorem IsEndpointPair.c_mem_isolation_box {c B : ℝ} (h : IsEndpointPair c B) : + 13866128436518096 / 10 ^ 16 < c ∧ c < 13866128436518100 / 10 ^ 16 := by + exact ⟨h.1, h.2.1⟩ + +/-- The second coordinate of an endpoint pair lies in its rational isolation box. -/ +theorem IsEndpointPair.second_mem_isolation_box {c B : ℝ} (h : IsEndpointPair c B) : + 2873744161801659 / 10 ^ 15 < B ∧ B < 2873744161801662 / 10 ^ 15 := by + exact ⟨h.2.2.1, h.2.2.2.1⟩ + +/-- Both radicands in an endpoint pair are strictly positive. -/ +theorem IsEndpointPair.radicands_pos {c B : ℝ} (h : IsEndpointPair c B) : + 0 < (B ^ 2 - 1) / 2 ∧ + 0 < (B ^ 2 + (4 * c ^ 2 - 2 * c - B) ^ 2) / 2 - c ^ 2 := by + have hcl := h.c_mem_isolation_box.1 + have hcu := h.c_mem_isolation_box.2 + have hBl := h.second_mem_isolation_box.1 + have hc0 : 0 < c := by + norm_num at hcl ⊢ + linarith + have hc : c < 7 / 5 := by + norm_num at hcu ⊢ + linarith + have hB : 14 / 5 < B := by + norm_num at hBl ⊢ + linarith + have hc_sq : c ^ 2 < (7 / 5 : ℝ) ^ 2 := by + nlinarith + have hB_sq : (14 / 5 : ℝ) ^ 2 < B ^ 2 := by + nlinarith + constructor + · nlinarith + · nlinarith [sq_nonneg (4 * c ^ 2 - 2 * c - B)] + +/-- The radical balance equation implies its exact polynomial equation. -/ +theorem IsEndpointPair.endpointBalanceResidual_eq_zero {c B : ℝ} + (h : IsEndpointPair c B) : endpointBalanceResidual c B = 0 := by + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - c ^ 2 + let A := Real.sqrt A2 + let C := Real.sqrt C2 + let R := 3 * c * b + c ^ 2 - 1 + have hA2 : 0 ≤ A2 := by + dsimp [A2] + exact h.radicands_pos.1.le + have hC2 : 0 ≤ C2 := by + dsimp [C2, D] + exact h.radicands_pos.2.le + have hA : A ^ 2 = A2 := by + simpa [A] using Real.sq_sqrt hA2 + have hC : C ^ 2 = C2 := by + simpa [C] using Real.sq_sqrt hC2 + have hR : A + C = R := by + simpa only [IsEndpointPair, D, b, A2, C2, A, C, R] using h.2.2.2.2.1 + change (R ^ 2 - A2 - C2) ^ 2 - 4 * A2 * C2 = 0 + rw [← hA, ← hC, ← hR] + ring + +/-- The Gram equation says exactly that its residual vanishes. -/ +theorem IsEndpointPair.endpointGramResidual_eq_zero {c B : ℝ} + (h : IsEndpointPair c B) : endpointGramResidual c B = 0 := by + have hg := h.2.2.2.2.2.1 + change endpointGramResidual c B = 0 + exact sub_eq_zero.mpr hg + +/-- An endpoint pair satisfies the signed polynomial isolation system. -/ +theorem IsEndpointPair.isEndpointPolynomialPair {c B : ℝ} (h : IsEndpointPair c B) : + IsEndpointPolynomialPair c B := by + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - c ^ 2 + let A := Real.sqrt A2 + let C := Real.sqrt C2 + let R := 3 * c * b + c ^ 2 - 1 + have h_data := h + simp only [IsEndpointPair] at h_data + rcases h_data with ⟨hc_lo, hc_hi, hB_lo, hB_hi, hbalance, hgram, hx, hz, hk⟩ + have hA2 : 0 < A2 := by + simpa [A2] using h.radicands_pos.1 + have hC2 : 0 < C2 := by + simpa [C2, D] using h.radicands_pos.2 + have hA_sq : A ^ 2 = A2 := by + simpa [A] using Real.sq_sqrt hA2.le + have hC_sq : C ^ 2 = C2 := by + simpa [C] using Real.sq_sqrt hC2.le + have hA : 0 < A := by + simpa [A] using Real.sqrt_pos.2 hA2 + have hC : 0 < C := by + simpa [C] using Real.sqrt_pos.2 hC2 + have hR_eq : A + C = R := by + simpa only [D, b, A2, C2, A, C, R] using hbalance + have hR : 0 < R := by + linarith + have hQ : 0 < R ^ 2 - A2 - C2 := by + rw [← hA_sq, ← hC_sq, ← hR_eq] + nlinarith [mul_pos hA hC] + dsimp only [IsEndpointPolynomialPair] + exact ⟨hc_lo, hc_hi, hB_lo, hB_hi, hA2, hC2, hR, hQ, + h.endpointBalanceResidual_eq_zero, h.endpointGramResidual_eq_zero, hx, hz, hk⟩ + +/-- The sign conditions in the polynomial system undo both squaring steps. -/ +theorem isEndpointPair_of_isEndpointPolynomialPair {c B : ℝ} + (h : IsEndpointPolynomialPair c B) : IsEndpointPair c B := by + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A2 := (B ^ 2 - 1) / 2 + let C2 := (B ^ 2 + D ^ 2) / 2 - c ^ 2 + let A := Real.sqrt A2 + let C := Real.sqrt C2 + let R := 3 * c * b + c ^ 2 - 1 + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - c ^ 2) / 2 + simp only [IsEndpointPolynomialPair] at h + rcases h with ⟨hc_lo, hc_hi, hB_lo, hB_hi, hA2, hC2, hR, hQ, + hbalance, hgram, hx, hz, hk⟩ + change 0 < A2 at hA2 + change 0 < C2 at hC2 + change 0 < R at hR + change 0 < R ^ 2 - A2 - C2 at hQ + change x < 0 at hx + change z < 0 at hz + change k - x * z < 0 at hk + have hA_sq : A ^ 2 = A2 := by + simpa [A] using Real.sq_sqrt hA2.le + have hC_sq : C ^ 2 = C2 := by + simpa [C] using Real.sq_sqrt hC2.le + have hA : 0 < A := by + simpa [A] using Real.sqrt_pos.2 hA2 + have hC : 0 < C := by + simpa [C] using Real.sqrt_pos.2 hC2 + have hbalance' : (R ^ 2 - A2 - C2) ^ 2 - 4 * A2 * C2 = 0 := by + change endpointBalanceResidual c B = 0 + exact hbalance + have hQ_eq : R ^ 2 - A2 - C2 = 2 * A * C := by + rw [← hA_sq, ← hC_sq] at hbalance' hQ + nlinarith [mul_pos hA hC] + have hR_eq : A + C = R := by + nlinarith [hQ_eq, hA_sq, hC_sq] + have hgram' : + (k - x * z) ^ 2 = (1 - x ^ 2) * (b ^ 2 - z ^ 2) := by + apply sub_eq_zero.mp + change endpointGramResidual c B = 0 + exact hgram + dsimp only [IsEndpointPair] + exact ⟨hc_lo, hc_hi, hB_lo, hB_hi, hR_eq, hgram', hx, hz, hk⟩ + +/-- The first coordinates of endpoint pairs have a uniform rational lower bound. -/ +theorem endpoint_first_coordinates_bddBelow : + BddBelow {c : ℝ | ∃ B : ℝ, IsEndpointPair c B} := by + refine ⟨13866128436518096 / 10 ^ 16, ?_⟩ + rintro c ⟨B, h⟩ + exact h.c_mem_isolation_box.1.le + +/-- The lower endpoint of the isolation box is a lower bound for `cStar`. -/ +theorem c_lower_le_cStar (h : ∃ c B : ℝ, IsEndpointPair c B) : + 13866128436518096 / 10 ^ 16 ≤ cStar := by + rw [cStar] + apply le_csInf + · rcases h with ⟨c, B, h⟩ + exact ⟨c, B, h⟩ + · rintro c ⟨B, h⟩ + exact h.c_mem_isolation_box.1.le + +/-- If an endpoint pair exists, `cStar` lies below the upper edge of its box. -/ +theorem cStar_lt_c_upper (h : ∃ c B : ℝ, IsEndpointPair c B) : + cStar < 13866128436518100 / 10 ^ 16 := by + rcases h with ⟨c, B, h⟩ + exact lt_of_le_of_lt + (csInf_le endpoint_first_coordinates_bddBelow ⟨B, h⟩) h.c_mem_isolation_box.2 + +/-- Existence of an endpoint pair places `sStar` in a closed-open rational interval. -/ +theorem sStar_mem_closedOpen_isolation_box (h : ∃ c B : ℝ, IsEndpointPair c B) : + 6933064218259048 / 10 ^ 16 ≤ sStar ∧ + sStar < 6933064218259050 / 10 ^ 16 := by + constructor + · rw [sStar] + have hc := c_lower_le_cStar h + norm_num at hc ⊢ + linarith + · rw [sStar] + have hc := cStar_lt_c_upper h + norm_num at hc ⊢ + linarith + +/-- Existence of an endpoint pair gives the elementary bounds used later. -/ +theorem half_lt_sStar_and_sStar_lt_one (h : ∃ c B : ℝ, IsEndpointPair c B) : + 1 / 2 < sStar ∧ sStar < 1 := by + rcases sStar_mem_closedOpen_isolation_box h with ⟨hl, hu⟩ + constructor <;> norm_num at hl hu ⊢ <;> linarith + +/-- A unique first coordinate of an endpoint pair is the infimum `cStar`. -/ +theorem cStar_eq_of_isEndpointPair_of_unique {c B : ℝ} (h : IsEndpointPair c B) + (h_unique : ∀ ⦃c' B' : ℝ⦄, IsEndpointPair c' B' → c' = c) : cStar = c := by + apply le_antisymm + · exact csInf_le endpoint_first_coordinates_bddBelow ⟨B, h⟩ + · rw [cStar] + apply le_csInf + · exact ⟨c, B, h⟩ + · rintro c' ⟨B', h'⟩ + exact (h_unique h').ge + +/-- A uniquely isolated endpoint pair identifies `sStar` exactly. -/ +theorem sStar_eq_of_isEndpointPair_of_unique {c B : ℝ} (h : IsEndpointPair c B) + (h_unique : ∀ ⦃c' B' : ℝ⦄, IsEndpointPair c' B' → c' = c) : sStar = c / 2 := by + rw [sStar, cStar_eq_of_isEndpointPair_of_unique h h_unique] + +/-- Uniqueness upgrades the lower endpoint bound from weak to strict. -/ +theorem sStar_mem_isolation_box_of_unique {c B : ℝ} (h : IsEndpointPair c B) + (h_unique : ∀ ⦃c' B' : ℝ⦄, IsEndpointPair c' B' → c' = c) : + 6933064218259048 / 10 ^ 16 < sStar ∧ + sStar < 6933064218259050 / 10 ^ 16 := by + rw [sStar_eq_of_isEndpointPair_of_unique h h_unique] + constructor + · have hc := h.c_mem_isolation_box.1 + norm_num at hc ⊢ + linarith + · have hc := h.c_mem_isolation_box.2 + norm_num at hc ⊢ + linarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/BlueChildSwap.lean b/LeanPool/Besicovitch/SixPoint/BlueChildSwap.lean new file mode 100644 index 0000000000..6875f41d3c --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/BlueChildSwap.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.PackingRelabel + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.SiblingFailureTree + +/-! +# Swapping the two blue children + +The four-child minimax has two matching branches. Swapping only the blue children identifies the +anti-diagonal branch with the diagonal one and preserves admissibility and every packing score. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The index permutation that interchanges the two blue children. -/ +def swapBlueIndexEquiv : SixPointIndex ≃ SixPointIndex where + toFun + | (.red, label) => (.red, label) + | (.blue, label) => (.blue, swapChildLabel label) + invFun + | (.red, label) => (.red, label) + | (.blue, label) => (.blue, swapChildLabel label) + left_inv index := by + rcases index with ⟨color, label⟩ + cases color <;> cases label <;> rfl + right_inv index := by + rcases index with ⟨color, label⟩ + cases color <;> cases label <;> rfl + +/-- Child relabelling preserves the color of each index. -/ +@[simp] theorem swapBlueIndexEquiv_color (index : SixPointIndex) : + (swapBlueIndexEquiv index).1 = index.1 := by + rcases index with ⟨color, label⟩ + cases color <;> rfl + +@[simp] private theorem swapBlueIndexEquiv_involution (index : SixPointIndex) : + swapBlueIndexEquiv (swapBlueIndexEquiv index) = index := by + rcases index with ⟨color, label⟩ + cases color <;> cases label <;> rfl + +/-- The configuration obtained by interchanging the two blue children. -/ +def swapBlueChildren (configuration : SixPointConfiguration) : SixPointConfiguration + | .red, label => configuration .red label + | .blue, label => configuration .blue (swapChildLabel label) + +/-- The permuted configuration agrees with the relabelled original centers. -/ +@[simp] theorem swapBlueChildren_eq_swapBlueIndex + (configuration : SixPointConfiguration) (index : SixPointIndex) : + swapBlueChildren configuration index.1 index.2 = + configuration (swapBlueIndexEquiv index).1 (swapBlueIndexEquiv index).2 := by + rcases index with ⟨color, label⟩ + cases color <;> cases label <;> rfl + +/-- Swapping the blue children preserves endpoint admissibility. -/ +theorem IsAdmissibleAt.swapBlueChildren {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : + (swapBlueChildren configuration).IsAdmissibleAt s where + root_distance := h.root_distance + child_distance color label hlabel := by + cases color + · exact h.child_distance .red label hlabel + · cases label with + | root => simp at hlabel + | left => exact h.child_distance .blue .right (by simp) + | right => exact h.child_distance .blue .left (by simp) + sibling_distance color := by + cases color + · exact h.sibling_distance .red + · change 2 * s ≤ + dist (configuration .blue .right) (configuration .blue .left) + simpa only [dist_comm] using h.sibling_distance .blue + +/-- After swapping the blue children, the selected diagonal is the original anti-diagonal. -/ +theorem selectedDiagonalMatchingFails_swapBlueChildren + (configuration : SixPointConfiguration) : + SelectedDiagonalMatchingFails (swapBlueChildren configuration) ↔ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .right) + + dist (configuration .red .right) (configuration .blue .left) := by + simp [SelectedDiagonalMatchingFails, incidenceCrossDistance, incidenceChild, + swapBlueChildren, swapChildLabel, dist_comm, add_comm] + +namespace SixPointPacking + +/-- Membership in a swapped support pulls back along the involution. -/ +theorem swapBlueIndex_mem_of_mem_map {support : Finset SixPointIndex} + {index : SixPointIndex} (hindex : index ∈ support.map swapBlueIndexEquiv.toEmbedding) : + swapBlueIndexEquiv index ∈ support := by + rw [Finset.mem_map] at hindex + obtain ⟨source, hsource, rfl⟩ := hindex + simpa using hsource + +/-- Transport a packing through the child permutation. -/ +def unswapBlue {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapBlueChildren configuration)) : + SixPointPacking configuration := + packing.relabel swapBlueIndexEquiv swapBlueIndexEquiv_color + (swapBlueChildren_eq_swapBlueIndex configuration) + +/-- Child relabelling preserves the total radius. -/ +theorem unswapBlue_totalRadius {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapBlueChildren configuration)) : + packing.unswapBlue.totalRadius = packing.totalRadius := by + exact packing.relabel_totalRadius swapBlueIndexEquiv swapBlueIndexEquiv_color + (swapBlueChildren_eq_swapBlueIndex configuration) + +/-- Child relabelling preserves the virtual diameter. -/ +theorem unswapBlue_virtualDiameter {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapBlueChildren configuration)) : + packing.unswapBlue.virtualDiameter = packing.virtualDiameter := by + exact packing.relabel_virtualDiameter swapBlueIndexEquiv swapBlueIndexEquiv_color + (swapBlueChildren_eq_swapBlueIndex configuration) + +/-- Child relabelling preserves the packing score. -/ +theorem unswapBlue_score {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapBlueChildren configuration)) (s : ℝ) : + packing.unswapBlue.score s = packing.score s := by + exact packing.relabel_score swapBlueIndexEquiv swapBlueIndexEquiv_color + (swapBlueChildren_eq_swapBlueIndex configuration) s + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/CanonicalTriangle.lean b/LeanPool/Besicovitch/SixPoint/CanonicalTriangle.lean new file mode 100644 index 0000000000..79986d0838 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/CanonicalTriangle.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Configuration + +/-! +# Canonical tangent radii for a triangle + +The three radii are the half-perimeter differences, indexed by the six-point labels. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +variable {X : Type*} [PseudoMetricSpace X] + +/-- The canonical mutually tangent radii attached to a labelled triangle. -/ +def canonicalTriangleRadius (root left right : X) : SixPointLabel → ℝ + | .root => (dist root left + dist root right - dist left right) / 2 + | .left => (dist root left + dist left right - dist root right) / 2 + | .right => (dist root right + dist left right - dist root left) / 2 + +/-- The root and left canonical radii sum to their center distance. -/ +theorem canonicalTriangleRadius_root_add_left (root left right : X) : + canonicalTriangleRadius root left right .root + + canonicalTriangleRadius root left right .left = dist root left := by + simp only [canonicalTriangleRadius] + ring + +/-- The root and right canonical radii sum to their center distance. -/ +theorem canonicalTriangleRadius_root_add_right (root left right : X) : + canonicalTriangleRadius root left right .root + + canonicalTriangleRadius root left right .right = dist root right := by + simp only [canonicalTriangleRadius] + ring + +/-- The left and right canonical radii sum to their center distance. -/ +theorem canonicalTriangleRadius_left_add_right (root left right : X) : + canonicalTriangleRadius root left right .left + + canonicalTriangleRadius root left right .right = dist left right := by + simp only [canonicalTriangleRadius] + ring + +/-- Every canonical triangle radius is nonnegative. -/ +theorem canonicalTriangleRadius_nonneg (root left right : X) (label : SixPointLabel) : + 0 ≤ canonicalTriangleRadius root left right label := by + cases label + · simp only [canonicalTriangleRadius] + have htriangle := dist_triangle left root right + rw [dist_comm left root] at htriangle + nlinarith + · simp only [canonicalTriangleRadius] + nlinarith [dist_triangle root left right] + · simp only [canonicalTriangleRadius] + have htriangle := dist_triangle root right left + rw [dist_comm right left] at htriangle + nlinarith + +/-- The root radius is at most the average root-to-child distance. -/ +theorem canonicalTriangleRadius_root_le_average (root left right : X) : + canonicalTriangleRadius root left right .root ≤ + (dist root left + dist root right) / 2 := by + simp only [canonicalTriangleRadius] + nlinarith [show 0 ≤ dist left right from dist_nonneg] + +/-- The left radius is at most the root-to-left distance. -/ +theorem canonicalTriangleRadius_left_le_dist (root left right : X) : + canonicalTriangleRadius root left right .left ≤ dist root left := by + simp only [canonicalTriangleRadius] + have htriangle := dist_triangle left root right + rw [dist_comm left root] at htriangle + nlinarith + +/-- The right radius is at most the root-to-right distance. -/ +theorem canonicalTriangleRadius_right_le_dist (root left right : X) : + canonicalTriangleRadius root left right .right ≤ dist root right := by + simp only [canonicalTriangleRadius] + have htriangle := dist_triangle right root left + rw [dist_comm right root, dist_comm right left] at htriangle + nlinarith + +/-- Unit root-to-child distances place every canonical radius in the unit interval. -/ +theorem canonicalTriangleRadius_le_one (root left right : X) + (hleft : dist root left ≤ 1) (hright : dist root right ≤ 1) (label : SixPointLabel) : + canonicalTriangleRadius root left right label ≤ 1 := by + cases label + · exact (canonicalTriangleRadius_root_le_average root left right).trans (by linarith) + · exact (canonicalTriangleRadius_left_le_dist root left right).trans hleft + · exact (canonicalTriangleRadius_right_le_dist root left right).trans hright + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/ChildSwapPacking.lean b/LeanPool/Besicovitch/SixPoint/ChildSwapPacking.lean new file mode 100644 index 0000000000..2eb307a248 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/ChildSwapPacking.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.PackingRelabel + +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# Relabelling a packing by the simultaneous child swap + +The sibling failure tree can select either diagonal endpoint. This file transports a packing +across the simultaneous swap of both colors, preserving its total radius, virtual diameter, and +score. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The involution on six-point indices that swaps both pairs of children. -/ +def swapChildrenIndexEquiv : SixPointIndex ≃ SixPointIndex where + toFun index := (index.1, swapChildLabel index.2) + invFun index := (index.1, swapChildLabel index.2) + left_inv index := by + rcases index with ⟨color, label⟩ + cases label <;> rfl + right_inv index := by + rcases index with ⟨color, label⟩ + cases label <;> rfl + +/-- Child relabelling preserves the color of each index. -/ +@[simp] theorem swapChildrenIndexEquiv_color (index : SixPointIndex) : + (swapChildrenIndexEquiv index).1 = index.1 := rfl + +@[simp] private theorem swapChildrenIndexEquiv_involution (index : SixPointIndex) : + swapChildrenIndexEquiv (swapChildrenIndexEquiv index) = index := by + rcases index with ⟨color, label⟩ + cases label <;> rfl + +/-- The permuted configuration agrees with the relabelled original centers. -/ +@[simp] theorem swapConfigurationChildren_eq_swapIndex + (configuration : SixPointConfiguration) (index : SixPointIndex) : + swapConfigurationChildren configuration index.1 index.2 = + configuration (swapChildrenIndexEquiv index).1 (swapChildrenIndexEquiv index).2 := by + rcases index with ⟨color, label⟩ + cases label <;> rfl + +namespace SixPointPacking + +/-- Membership in a swapped support pulls back along the child-swap involution. -/ +theorem swapChildrenIndex_mem_of_mem_map {support : Finset SixPointIndex} + {index : SixPointIndex} (hindex : index ∈ support.map swapChildrenIndexEquiv.toEmbedding) : + swapChildrenIndexEquiv index ∈ support := by + rw [Finset.mem_map] at hindex + obtain ⟨source, hsource, rfl⟩ := hindex + simpa using hsource + +/-- Transport a packing through the child permutation. -/ +def unswapChildren {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapConfigurationChildren configuration)) : + SixPointPacking configuration := + packing.relabel swapChildrenIndexEquiv swapChildrenIndexEquiv_color + (swapConfigurationChildren_eq_swapIndex configuration) + +/-- Child relabelling preserves the total radius. -/ +theorem unswapChildren_totalRadius {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapConfigurationChildren configuration)) : + packing.unswapChildren.totalRadius = packing.totalRadius := by + exact packing.relabel_totalRadius swapChildrenIndexEquiv swapChildrenIndexEquiv_color + (swapConfigurationChildren_eq_swapIndex configuration) + +/-- Child relabelling preserves the virtual diameter. -/ +theorem unswapChildren_virtualDiameter {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapConfigurationChildren configuration)) : + packing.unswapChildren.virtualDiameter = packing.virtualDiameter := by + exact packing.relabel_virtualDiameter swapChildrenIndexEquiv swapChildrenIndexEquiv_color + (swapConfigurationChildren_eq_swapIndex configuration) + +/-- Child relabelling preserves the packing score. -/ +theorem unswapChildren_score {configuration : SixPointConfiguration} + (packing : SixPointPacking (swapConfigurationChildren configuration)) (s : ℝ) : + packing.unswapChildren.score s = packing.score s := by + exact packing.relabel_score swapChildrenIndexEquiv swapChildrenIndexEquiv_color + (swapConfigurationChildren_eq_swapIndex configuration) s + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Configuration.lean b/LeanPool/Besicovitch/SixPoint/Configuration.lean new file mode 100644 index 0000000000..ceba9e640f --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Configuration.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Statement + +/-! +# Two-color six-point configurations + +This file records exactly the metric assumptions in the finite six-point problem. +-/ + +@[expose] public section + +namespace LeanPool.Besicovitch + +/-- The two colors in a six-point configuration. -/ +inductive SixPointColor + | red + | blue + deriving DecidableEq + +instance : Fintype SixPointColor where + elems := {.red, .blue} + complete := by intro color; cases color <;> simp + +/-- The root and two child labels belonging to each color. -/ +inductive SixPointLabel + | root + | left + | right + deriving DecidableEq + +instance : Fintype SixPointLabel where + elems := {.root, .left, .right} + complete := by intro label; cases label <;> simp + +/-- A label for one of the six points. -/ +abbrev SixPointIndex := SixPointColor × SixPointLabel + +/-- A two-color six-point configuration in the Euclidean plane. -/ +abbrev SixPointConfiguration := SixPointColor → SixPointLabel → (EuclideanSpace ℝ (Fin 2)) + +namespace SixPointConfiguration + +/-- The labelled configuration determined by two roots and two children of each color. -/ +def ofPoints (redRoot redLeft redRight blueRoot blueLeft blueRight : (EuclideanSpace ℝ (Fin 2))) : + SixPointConfiguration + | .red, .root => redRoot + | .red, .left => redLeft + | .red, .right => redRight + | .blue, .root => blueRoot + | .blue, .left => blueLeft + | .blue, .right => blueRight + +/-- A normalized configuration at separation parameter `s`. -/ +structure IsAdmissibleAt (configuration : SixPointConfiguration) (s : ℝ) : Prop where + root_distance : dist (configuration .red .root) (configuration .blue .root) = 1 + child_distance : ∀ color label, label ≠ .root → + dist (configuration color .root) (configuration color label) ≤ 1 + sibling_distance : ∀ color, + 2 * s ≤ dist (configuration color .left) (configuration color .right) + +/-- Raising the separation parameter only shrinks the admissible configuration class. -/ +theorem IsAdmissibleAt.mono {configuration : SixPointConfiguration} {s t : ℝ} + (hst : s ≤ t) (h : configuration.IsAdmissibleAt t) : configuration.IsAdmissibleAt s where + root_distance := h.root_distance + child_distance := h.child_distance + sibling_distance color := (mul_le_mul_of_nonneg_left hst (by norm_num)).trans + (h.sibling_distance color) + +end SixPointConfiguration + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/EndpointFailureClosed.lean b/LeanPool/Besicovitch/SixPoint/EndpointFailureClosed.lean new file mode 100644 index 0000000000..c40d30b935 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/EndpointFailureClosed.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.ChildSwapPacking +public import LeanPool.Besicovitch.SixPoint.RootEdgeClosed +public import LeanPool.Besicovitch.SixPoint.WeightedFailure + +/-! +# Closing the matched-endpoint branch + +At a matched sibling endpoint, failure of both root--edge packings makes the three active slacks +strictly incompatible with the weighted geometric bound. The other matched endpoint follows by +simultaneously swapping both pairs of children. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The weighted geometric bound closes the endpoint at the two left children. -/ +theorem exists_nonnegative_score_of_matched_endpoint_zero + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + {lambda mu : ℝ} (hlambda : 0 < lambda) (hmu : 0 < mu) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hred : redSiblingTriangleFailure configuration (.endpoint 0)) + (hblue : blueSiblingTriangleFailure configuration (.endpoint 0)) + (hweighted : weightedPairScore configuration.rootDisplacement barC lambda mu + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) ≤ 0) : + ∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS := by + rcases exists_nonnegative_score_or_rootEdge_type11_pair configuration h hmatching hred hblue with + hpacking | htype11 + · exact hpacking + · have hq₁ := firstActiveFailureSlack_nonneg h hmatching + have hq₂ := secondActiveFailureSlack_pos h hred hblue + have hq₃ := thirdActiveFailureSlack_pos h htype11.1 htype11.2 + have hpositive := activeFailureCombination_pos hlambda hmu hq₁ hq₂ hq₃ + rw [← weightedPairScore_configuration_eq_activeFailureCombination] at hpositive + exact (not_lt_of_ge hweighted hpositive).elim + +/-- The weighted geometric bound closes the endpoint at the two right children. -/ +theorem exists_nonnegative_score_of_matched_endpoint_three + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + {lambda mu : ℝ} (hlambda : 0 < lambda) (hmu : 0 < mu) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hred : redSiblingTriangleFailure configuration (.endpoint 3)) + (hblue : blueSiblingTriangleFailure configuration (.endpoint 3)) + (hweighted : + weightedPairScore (swapConfigurationChildren configuration).rootDisplacement + barC lambda mu + ((swapConfigurationChildren configuration).redDisplacement .left) + ((swapConfigurationChildren configuration).redDisplacement .right) + ((swapConfigurationChildren configuration).bluePullback .left) + ((swapConfigurationChildren configuration).bluePullback .right) ≤ 0) : + ∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS := by + let swapped := swapConfigurationChildren configuration + have hadmissible : swapped.IsAdmissibleAt barS := IsAdmissibleAt.swapChildren h + have hmatching' : SelectedDiagonalMatchingFails swapped := + (selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching + have hred' : redSiblingTriangleFailure swapped (.endpoint 0) := + (redEndpointFailure_swapChildren configuration 3).2 hred + have hblue' : blueSiblingTriangleFailure swapped (.endpoint 0) := + (blueEndpointFailure_swapChildren configuration 3).2 hblue + obtain ⟨packing, hscore⟩ := exists_nonnegative_score_of_matched_endpoint_zero swapped + hadmissible hlambda hmu hmatching' hred' hblue' hweighted + exact ⟨packing.unswapChildren, by simpa only [packing.unswapChildren_score] using hscore⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/EndpointGeometry.lean b/LeanPool/Besicovitch/SixPoint/EndpointGeometry.lean new file mode 100644 index 0000000000..639edd45b8 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/EndpointGeometry.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Configuration + +/-! +# Coordinate-free endpoint geometry + +After translating the red root to the origin, the blue children are pulled back toward their own +root. The resulting vectors are the `e`, `p`, and `w` variables in the nine-packing proof. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +namespace SixPointConfiguration + +/-- The displacement from the red root to the blue root. -/ +def rootDisplacement (configuration : SixPointConfiguration) : (EuclideanSpace ℝ (Fin 2)) := + configuration .blue .root - configuration .red .root + +/-- A red point, translated relative to the red root. -/ +def redDisplacement (configuration : SixPointConfiguration) (label : SixPointLabel) : + (EuclideanSpace ℝ (Fin 2)) := + configuration .red label - configuration .red .root + +/-- A blue point pulled back from the blue root into the red child disk. -/ +def bluePullback (configuration : SixPointConfiguration) (label : SixPointLabel) : + (EuclideanSpace ℝ (Fin 2)) := + configuration .blue .root - configuration .blue label + +/-- The root displacement of an admissible configuration has unit norm. -/ +theorem norm_rootDisplacement {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : ‖configuration.rootDisplacement‖ = 1 := by + rw [rootDisplacement, norm_sub_rev] + simpa [dist_eq_norm] using h.root_distance + +/-- Red child displacements have norm at most one. -/ +theorem norm_redDisplacement_le_one {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) {label : SixPointLabel} (hlabel : label ≠ .root) : + ‖configuration.redDisplacement label‖ ≤ 1 := by + rw [redDisplacement, norm_sub_rev] + simpa [dist_eq_norm] using h.child_distance .red label hlabel + +/-- Pulled-back blue child displacements have norm at most one. -/ +theorem norm_bluePullback_le_one {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) {label : SixPointLabel} (hlabel : label ≠ .root) : + ‖configuration.bluePullback label‖ ≤ 1 := by + simpa [bluePullback, dist_eq_norm] using h.child_distance .blue label hlabel + +/-- The distance between red children is their displacement-vector distance. -/ +theorem dist_redDisplacement (configuration : SixPointConfiguration) + (label₁ label₂ : SixPointLabel) : + dist (configuration.redDisplacement label₁) (configuration.redDisplacement label₂) = + dist (configuration .red label₁) (configuration .red label₂) := by + simp [redDisplacement, dist_eq_norm] + +/-- Pulling back both blue children preserves their distance. -/ +theorem dist_bluePullback (configuration : SixPointConfiguration) + (label₁ label₂ : SixPointLabel) : + dist (configuration.bluePullback label₁) (configuration.bluePullback label₂) = + dist (configuration .blue label₁) (configuration .blue label₂) := by + simp only [bluePullback, dist_eq_norm] + rw [show + (configuration .blue .root - configuration .blue label₁) - + (configuration .blue .root - configuration .blue label₂) = + configuration .blue label₂ - configuration .blue label₁ by abel] + exact norm_sub_rev _ _ + +/-- Admissibility gives the endpoint lower bound for the red displacement pair. -/ +theorem two_mul_le_dist_redDisplacement {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : + 2 * s ≤ dist (configuration.redDisplacement .left) + (configuration.redDisplacement .right) := by + rw [configuration.dist_redDisplacement] + exact h.sibling_distance .red + +/-- Admissibility gives the endpoint lower bound for the pulled-back blue pair. -/ +theorem two_mul_le_dist_bluePullback {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : + 2 * s ≤ dist (configuration.bluePullback .left) + (configuration.bluePullback .right) := by + rw [configuration.dist_bluePullback] + exact h.sibling_distance .blue + +/-- A red-blue child distance is the norm of `e - p - w`. -/ +theorem dist_red_blue_eq_norm (configuration : SixPointConfiguration) + (redLabel blueLabel : SixPointLabel) : + dist (configuration .red redLabel) (configuration .blue blueLabel) = + ‖configuration.rootDisplacement - configuration.redDisplacement redLabel - + configuration.bluePullback blueLabel‖ := by + simp only [rootDisplacement, redDisplacement, bluePullback, dist_eq_norm] + rw [show + (configuration .blue .root - configuration .red .root) - + (configuration .red redLabel - configuration .red .root) - + (configuration .blue .root - configuration .blue blueLabel) = + configuration .blue blueLabel - configuration .red redLabel by abel] + exact norm_sub_rev _ _ + +end SixPointConfiguration + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/EndpointPacking.lean b/LeanPool/Besicovitch/SixPoint/EndpointPacking.lean new file mode 100644 index 0000000000..384250bffc --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/EndpointPacking.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.BlueChildSwap +public import LeanPool.Besicovitch.SixPoint.EndpointFailureClosed +public import LeanPool.Besicovitch.SixPoint.FiniteProperty +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceClosed + +/-! +# The endpoint packing theorem + +This file assembles the finite failure tree. Its sole analytic input is the weighted geometric +bound for two ordered chords in the unit disk. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The weighted geometric inequality for two ordered sibling pairs in the unit disk. -/ +def WeightedGeometricBound (lambda mu : ℝ) : Prop := + ∀ e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2)), + ‖e‖ = 1 → + ‖p₁‖ ≤ 1 → ‖p₂‖ ≤ 1 → ‖w₁‖ ≤ 1 → ‖w₂‖ ≤ 1 → + barC ≤ ‖p₁ - p₂‖ → barC ≤ ‖w₁ - w₂‖ → + weightedPairScore e barC lambda mu p₁ p₂ w₁ w₂ ≤ 0 + +private theorem weightedGeometricBound_configuration {lambda mu : ℝ} + (hweighted : WeightedGeometricBound lambda mu) {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) : + weightedPairScore configuration.rootDisplacement barC lambda mu + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) ≤ 0 := by + apply hweighted + · exact configuration.norm_rootDisplacement h + · exact configuration.norm_redDisplacement_le_one h (by simp) + · exact configuration.norm_redDisplacement_le_one h (by simp) + · exact configuration.norm_bluePullback_le_one h (by simp) + · exact configuration.norm_bluePullback_le_one h (by simp) + · have hchord := configuration.two_mul_le_dist_redDisplacement h + rw [barS, dist_eq_norm] at hchord + convert hchord using 1 + ring + · have hchord := configuration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hchord + convert hchord using 1 + ring + +private theorem exists_nonnegative_score_of_selected_diagonal {lambda mu : ℝ} + (hlambda : 0 < lambda) (hmu : 0 < mu) + (hweighted : WeightedGeometricBound lambda mu) (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS := by + rcases exists_nonnegative_score_or_matched_sibling_endpoint configuration h hmatching with + hpacking | ⟨code, hcode, hred, hblue⟩ + · exact hpacking + · rcases hcode with rfl | rfl + · exact exists_nonnegative_score_of_matched_endpoint_zero configuration h hlambda hmu + hmatching hred hblue (weightedGeometricBound_configuration hweighted h) + · exact exists_nonnegative_score_of_matched_endpoint_three configuration h hlambda hmu + hmatching hred hblue + (weightedGeometricBound_configuration hweighted (IsAdmissibleAt.swapChildren h)) + +/-- The weighted geometric bound implies the finite six-point property at the exact endpoint. -/ +theorem sixPointFiniteProperty_barS_of_weightedGeometricBound {lambda mu : ℝ} + (hlambda : 0 < lambda) (hmu : 0 < mu) + (hweighted : WeightedGeometricBound lambda mu) : SixPointFiniteProperty barS := by + intro configuration h + rcases exists_nonnegative_score_or_matching_obstruction configuration h with + hpacking | hdiagonal | hantiDiagonal + · exact hpacking + · exact exists_nonnegative_score_of_selected_diagonal hlambda hmu hweighted configuration h + hdiagonal + · let swapped := swapBlueChildren configuration + have hadmissible : swapped.IsAdmissibleAt barS := IsAdmissibleAt.swapBlueChildren h + have hmatching : SelectedDiagonalMatchingFails swapped := + (selectedDiagonalMatchingFails_swapBlueChildren configuration).2 hantiDiagonal + obtain ⟨packing, hscore⟩ := + exists_nonnegative_score_of_selected_diagonal hlambda hmu hweighted swapped hadmissible + hmatching + exact ⟨packing.unswapBlue, by simpa only [packing.unswapBlue_score] using hscore⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/EndpointWeights.lean b/LeanPool/Besicovitch/SixPoint/EndpointWeights.lean new file mode 100644 index 0000000000..04d1e19503 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/EndpointWeights.lean @@ -0,0 +1,887 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.Certificates.RadicalInterval +public import LeanPool.Besicovitch.SixPoint.WeightedReduction + +/-! +# Exact endpoint weights + +This file defines the geometric quantities and Cramer weights in the weighted endpoint argument. +Small exact radical certificates prove the numerical inequalities; the stationarity identities are +proved symbolically from Cramer's rule. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The outer radius `b` in the endpoint configuration. -/ +def endpointOuterRadius (c B : ℝ) : ℝ := + (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + +/-- The distance `D` in the endpoint configuration. -/ +def endpointSecondDistance (c B : ℝ) : ℝ := + 4 * c ^ 2 - 2 * c - B + +/-- The first auxiliary distance `A` in the endpoint configuration. -/ +def endpointFirstAuxiliaryDistance (B : ℝ) : ℝ := + Real.sqrt ((B ^ 2 - 1) / 2) + +/-- The mixed auxiliary distance `C` in the endpoint configuration. -/ +def endpointMixedAuxiliaryDistance (c B : ℝ) : ℝ := + Real.sqrt ((B ^ 2 + endpointSecondDistance c B ^ 2) / 2 - c ^ 2) + +/-- The unit-circle abscissa `x` in the endpoint configuration. -/ +def endpointUnitAbscissa (B : ℝ) : ℝ := + (5 - B ^ 2) / 4 + +/-- The outer-circle abscissa `z` in the endpoint configuration. -/ +def endpointOuterAbscissa (c B : ℝ) : ℝ := + (1 + 4 * endpointOuterRadius c B ^ 2 - endpointSecondDistance c B ^ 2) / 4 + +/-- The positive unit-circle ordinate `y` in the endpoint configuration. -/ +def endpointUnitOrdinate (B : ℝ) : ℝ := + Real.sqrt (1 - endpointUnitAbscissa B ^ 2) + +/-- The negative outer-circle ordinate `w` in the endpoint configuration. -/ +def endpointOuterOrdinate (c B : ℝ) : ℝ := + -Real.sqrt (endpointOuterRadius c B ^ 2 - endpointOuterAbscissa c B ^ 2) + +/-- The chord abscissa `k` for the radial endpoint deformation. -/ +def endpointChordAbscissa (c B : ℝ) : ℝ := + (1 + endpointOuterRadius c B ^ 2 - c ^ 2) / 2 + +/-- The positive chord ordinate `r` for the radial endpoint deformation. -/ +def endpointChordOrdinate (c B : ℝ) : ℝ := + Real.sqrt (endpointOuterRadius c B ^ 2 - endpointChordAbscissa c B ^ 2) + +/-- The angular rate `rho` that keeps the endpoint chord length fixed. -/ +def endpointAngularRate (c B : ℝ) : ℝ := + endpointOuterRadius c B * (1 - endpointChordAbscissa c B) / + endpointChordOrdinate c B + +/-- The derivative `z_b` of the outer abscissa along the radial deformation. -/ +def endpointOuterAbscissaDerivative (c B : ℝ) : ℝ := + endpointOuterRadius c B * endpointUnitAbscissa B - + endpointAngularRate c B * endpointUnitOrdinate B + +/-- The derivative `D_b` of the second distance along the radial deformation. -/ +def endpointSecondDistanceDerivative (c B : ℝ) : ℝ := + (4 * endpointOuterRadius c B - 2 * endpointOuterAbscissaDerivative c B) / + endpointSecondDistance c B + +/-- The derivative `C_b` of the mixed distance along the radial deformation. -/ +def endpointMixedDistanceDerivative (c B : ℝ) : ℝ := + (2 * endpointOuterRadius c B - endpointOuterAbscissaDerivative c B) / + endpointMixedAuxiliaryDistance c B + +/-- The constant coefficient in the angular stationarity equation. -/ +def endpointBaseAngularCoefficient (c B : ℝ) : ℝ := + 2 * endpointUnitOrdinate B / B + + 2 * endpointOuterOrdinate c B / endpointSecondDistance c B + +/-- The coefficient of `lambda` in the angular stationarity equation. -/ +def endpointLambdaAngularCoefficient (B : ℝ) : ℝ := + 2 * endpointUnitOrdinate B / B + +/-- The coefficient of `mu` in the angular stationarity equation. -/ +def endpointMuAngularCoefficient (c B : ℝ) : ℝ := + endpointUnitOrdinate B / endpointFirstAuxiliaryDistance B + + (endpointUnitOrdinate B + endpointOuterOrdinate c B) / + endpointMixedAuxiliaryDistance c B + +/-- The coefficient of `lambda` in the radial stationarity equation. -/ +def endpointLambdaRadialCoefficient (c : ℝ) : ℝ := + -(c + 1) / 2 + +/-- The coefficient of `mu` in the radial stationarity equation. -/ +def endpointMuRadialCoefficient (c B : ℝ) : ℝ := + endpointMixedDistanceDerivative c B - 3 * c + +/-- The determinant of the two endpoint stationarity equations. -/ +def endpointStationarityDeterminant (c B : ℝ) : ℝ := + endpointLambdaAngularCoefficient B * endpointMuRadialCoefficient c B - + endpointMuAngularCoefficient c B * endpointLambdaRadialCoefficient c + +/-- Cramer's first weight for the two endpoint stationarity equations. -/ +def endpointCramerLambda (c B : ℝ) : ℝ := + (-endpointBaseAngularCoefficient c B * endpointMuRadialCoefficient c B + + endpointMuAngularCoefficient c B * endpointSecondDistanceDerivative c B) / + endpointStationarityDeterminant c B + +/-- Cramer's second weight for the two endpoint stationarity equations. -/ +def endpointCramerMu (c B : ℝ) : ℝ := + (-endpointLambdaAngularCoefficient B * endpointSecondDistanceDerivative c B + + endpointBaseAngularCoefficient c B * endpointLambdaRadialCoefficient c) / + endpointStationarityDeterminant c B + +/-- The exact positive multiplier of the second failure slack. -/ +def endpointLambda : ℝ := + endpointCramerLambda cStar certifiedEndpointPair.2 + +/-- The exact positive multiplier of the third failure slack. -/ +def endpointMu : ℝ := + endpointCramerMu cStar certifiedEndpointPair.2 + +private def endpointInput : Fin 2 → ℝ + | 0 => cStar + | 1 => certifiedEndpointPair.2 + +private def endpointInputBox : Fin 2 → RationalInterval + | 0 => ⟨13866128436518096 / 10 ^ 16, 13866128436518100 / 10 ^ 16, by norm_num⟩ + | 1 => ⟨2873744161801659 / 10 ^ 15, 2873744161801662 / 10 ^ 15, by norm_num⟩ + +private theorem endpointInput_mem_box : + ∀ i, (endpointInputBox i).Contains (endpointInput i) := by + intro i + fin_cases i + · simpa [endpointInputBox, endpointInput, RationalInterval.Contains] using + ⟨cStar_mem_isolation_box.1.le, cStar_mem_isolation_box.2.le⟩ + · simpa [endpointInputBox, endpointInput, RationalInterval.Contains] using + ⟨certifiedEndpointPair_second_mem_isolation_box.1.le, + certifiedEndpointPair_second_mem_isolation_box.2.le⟩ + +section + + +private theorem endpointOuterRadius_mem_interval : + (734358 : ℝ) / 1000000 ≤ endpointOuterRadius cStar certifiedEndpointPair.2 ∧ + endpointOuterRadius cStar certifiedEndpointPair.2 ≤ 734359 / 1000000 := by + let f : RadicalExpression 2 := + .mul + (.add + (.add + (.add (.mul (.literal 2) (.var 1)) + (.neg (.mul (.literal 3) (.mul (.var 0) (.var 0))))) + (.mul (.literal 2) (.var 0))) + (.neg (.literal 1))) + (.inv (.add (.var 0) (.literal 1))) + let target : RationalInterval := ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + have hf : f.certifiesWithin endpointInputBox target = true := by + norm_num [f, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound endpointInput_mem_box hf + simpa [f, endpointInput, target, endpointOuterRadius, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, pow_two, sub_eq_add_neg, add_assoc] using h + +private theorem endpointSecondDistance_mem_interval : + (2043810 : ℝ) / 1000000 ≤ endpointSecondDistance cStar certifiedEndpointPair.2 ∧ + endpointSecondDistance cStar certifiedEndpointPair.2 ≤ 2043811 / 1000000 := by + let f : RadicalExpression 2 := + .add + (.add (.mul (.literal 4) (.mul (.var 0) (.var 0))) + (.neg (.mul (.literal 2) (.var 0)))) + (.neg (.var 1)) + let target : RationalInterval := ⟨2043810 / 1000000, 2043811 / 1000000, by norm_num⟩ + have hf : f.certifiesWithin endpointInputBox target = true := by + norm_num [f, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound endpointInput_mem_box hf + simpa [f, endpointInput, target, endpointSecondDistance, RationalInterval.Contains, + RadicalExpression.eval, pow_two, sub_eq_add_neg, add_assoc] using h + +private theorem endpointFirstAuxiliaryRadicand_mem_interval : + (3629202 : ℝ) / 1000000 ≤ (certifiedEndpointPair.2 ^ 2 - 1) / 2 ∧ + (certifiedEndpointPair.2 ^ 2 - 1) / 2 ≤ 3629203 / 1000000 := by + let f : RadicalExpression 1 := + .mul (.add (.mul (.var 0) (.var 0)) (.neg (.literal 1))) (.inv (.literal 2)) + let X : Fin 1 → RationalInterval + | 0 => endpointInputBox 1 + let target : RationalInterval := ⟨3629202 / 1000000, 3629203 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (![certifiedEndpointPair.2] i) := by + intro i + fin_cases i + exact endpointInput_mem_box 1 + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, target, RationalInterval.Contains, RadicalExpression.eval, div_eq_mul_inv, + pow_two, sub_eq_add_neg] using h + +private theorem endpointFirstAuxiliaryDistance_mem_interval : + (1905046 : ℝ) / 1000000 ≤ endpointFirstAuxiliaryDistance certifiedEndpointPair.2 ∧ + endpointFirstAuxiliaryDistance certifiedEndpointPair.2 ≤ 1905047 / 1000000 := by + rw [endpointFirstAuxiliaryDistance] + constructor + · apply Real.le_sqrt_of_sq_le + nlinarith [endpointFirstAuxiliaryRadicand_mem_interval.1] + · apply (Real.sqrt_le_iff).2 + constructor + · norm_num + · nlinarith [endpointFirstAuxiliaryRadicand_mem_interval.2] + +private theorem endpointMixedAuxiliaryRadicand_mem_interval : + (4295087 : ℝ) / 1000000 ≤ + (certifiedEndpointPair.2 ^ 2 + + endpointSecondDistance cStar certifiedEndpointPair.2 ^ 2) / 2 - cStar ^ 2 ∧ + (certifiedEndpointPair.2 ^ 2 + + endpointSecondDistance cStar certifiedEndpointPair.2 ^ 2) / 2 - cStar ^ 2 ≤ + 4295090 / 1000000 := by + let f : RadicalExpression 3 := + .add + (.mul (.add (.mul (.var 1) (.var 1)) (.mul (.var 2) (.var 2))) + (.inv (.literal 2))) + (.neg (.mul (.var 0) (.var 0))) + let X : Fin 3 → RationalInterval + | 0 => endpointInputBox 0 + | 1 => endpointInputBox 1 + | 2 => ⟨2043810 / 1000000, 2043811 / 1000000, by norm_num⟩ + let value : Fin 3 → ℝ := + ![cStar, certifiedEndpointPair.2, endpointSecondDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨4295087 / 1000000, 4295090 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · exact endpointInput_mem_box 0 + · exact endpointInput_mem_box 1 + · simpa [X, value, RationalInterval.Contains] using endpointSecondDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, RationalInterval.Contains, RadicalExpression.eval, + div_eq_mul_inv, pow_two, sub_eq_add_neg] using h + +private theorem endpointMixedAuxiliaryDistance_mem_interval : + (2072459 : ℝ) / 1000000 ≤ + endpointMixedAuxiliaryDistance cStar certifiedEndpointPair.2 ∧ + endpointMixedAuxiliaryDistance cStar certifiedEndpointPair.2 ≤ 2072460 / 1000000 := by + rw [endpointMixedAuxiliaryDistance] + constructor + · apply Real.le_sqrt_of_sq_le + nlinarith [endpointMixedAuxiliaryRadicand_mem_interval.1] + · apply (Real.sqrt_le_iff).2 + constructor + · norm_num + · nlinarith [endpointMixedAuxiliaryRadicand_mem_interval.2] + +private theorem endpointUnitAbscissa_mem_interval : + (-814602 : ℝ) / 1000000 ≤ endpointUnitAbscissa certifiedEndpointPair.2 ∧ + endpointUnitAbscissa certifiedEndpointPair.2 ≤ -814601 / 1000000 := by + let f : RadicalExpression 1 := + .mul (.add (.literal 5) (.neg (.mul (.var 0) (.var 0)))) (.inv (.literal 4)) + let X : Fin 1 → RationalInterval + | 0 => endpointInputBox 1 + let target : RationalInterval := ⟨-814602 / 1000000, -814601 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (![certifiedEndpointPair.2] i) := by + intro i + fin_cases i + exact endpointInput_mem_box 1 + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, target, endpointUnitAbscissa, RationalInterval.Contains, RadicalExpression.eval, + div_eq_mul_inv, pow_two, sub_eq_add_neg] using h + +private theorem endpointOuterAbscissa_mem_interval : + (-255010 : ℝ) / 1000000 ≤ endpointOuterAbscissa cStar certifiedEndpointPair.2 ∧ + endpointOuterAbscissa cStar certifiedEndpointPair.2 ≤ -255006 / 1000000 := by + let f : RadicalExpression 2 := + .mul + (.add + (.add (.literal 1) (.mul (.literal 4) (.mul (.var 0) (.var 0)))) + (.neg (.mul (.var 1) (.var 1)))) + (.inv (.literal 4)) + let X : Fin 2 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨2043810 / 1000000, 2043811 / 1000000, by norm_num⟩ + let value : Fin 2 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointSecondDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨-255010 / 1000000, -255006 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointSecondDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointOuterAbscissa, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, pow_two, sub_eq_add_neg] using h + +private theorem endpointUnitOrdinateRadicand_mem_interval : + (3364233 : ℝ) / 10000000 ≤ 1 - endpointUnitAbscissa certifiedEndpointPair.2 ^ 2 ∧ + 1 - endpointUnitAbscissa certifiedEndpointPair.2 ^ 2 ≤ 3364253 / 10000000 := by + let f : RadicalExpression 1 := + .add (.literal 1) (.neg (.mul (.var 0) (.var 0))) + let X : Fin 1 → RationalInterval + | 0 => ⟨-814602 / 1000000, -814601 / 1000000, by norm_num⟩ + let target : RationalInterval := ⟨3364233 / 10000000, 3364253 / 10000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (![endpointUnitAbscissa certifiedEndpointPair.2] i) := by + intro i + fin_cases i + simpa [X, RationalInterval.Contains] using endpointUnitAbscissa_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, target, RationalInterval.Contains, RadicalExpression.eval, pow_two, + sub_eq_add_neg] using h + +private theorem endpointUnitOrdinate_mem_interval : + (580020 : ℝ) / 1000000 ≤ endpointUnitOrdinate certifiedEndpointPair.2 ∧ + endpointUnitOrdinate certifiedEndpointPair.2 ≤ 580023 / 1000000 := by + rw [endpointUnitOrdinate] + constructor + · apply Real.le_sqrt_of_sq_le + nlinarith [endpointUnitOrdinateRadicand_mem_interval.1] + · apply (Real.sqrt_le_iff).2 + constructor + · norm_num + · nlinarith [endpointUnitOrdinateRadicand_mem_interval.2] + +private theorem endpointOuterOrdinateRadicand_mem_interval : + (4742515 : ℝ) / 10000000 ≤ + endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointOuterAbscissa cStar certifiedEndpointPair.2 ^ 2 ∧ + endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointOuterAbscissa cStar certifiedEndpointPair.2 ^ 2 ≤ 4742552 / 10000000 := by + let f : RadicalExpression 2 := + .add (.mul (.var 0) (.var 0)) (.neg (.mul (.var 1) (.var 1))) + let X : Fin 2 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-255010 / 1000000, -255006 / 1000000, by norm_num⟩ + let value : Fin 2 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointOuterAbscissa cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨4742515 / 10000000, 4742552 / 10000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointOuterAbscissa_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, RationalInterval.Contains, RadicalExpression.eval, pow_two, + sub_eq_add_neg] using h + +private theorem endpointOuterOrdinate_mem_interval : + (-688662 : ℝ) / 1000000 ≤ endpointOuterOrdinate cStar certifiedEndpointPair.2 ∧ + endpointOuterOrdinate cStar certifiedEndpointPair.2 ≤ -688657 / 1000000 := by + rw [endpointOuterOrdinate] + constructor + · have hupper : Real.sqrt + (endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointOuterAbscissa cStar certifiedEndpointPair.2 ^ 2) ≤ + (688662 : ℝ) / 1000000 := by + apply (Real.sqrt_le_iff).2 + constructor + · norm_num + · nlinarith [endpointOuterOrdinateRadicand_mem_interval.2] + linarith + · have hlower : (688657 : ℝ) / 1000000 ≤ Real.sqrt + (endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointOuterAbscissa cStar certifiedEndpointPair.2 ^ 2) := by + apply Real.le_sqrt_of_sq_le + nlinarith [endpointOuterOrdinateRadicand_mem_interval.1] + linarith + +private theorem endpointChordAbscissa_mem_interval : + (-191708 : ℝ) / 1000000 ≤ endpointChordAbscissa cStar certifiedEndpointPair.2 ∧ + endpointChordAbscissa cStar certifiedEndpointPair.2 ≤ -191705 / 1000000 := by + let f : RadicalExpression 2 := + .mul + (.add (.add (.literal 1) (.mul (.var 1) (.var 1))) + (.neg (.mul (.var 0) (.var 0)))) + (.inv (.literal 2)) + let X : Fin 2 → RationalInterval + | 0 => endpointInputBox 0 + | 1 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + let value : Fin 2 → ℝ := ![cStar, endpointOuterRadius cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨-191708 / 1000000, -191705 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · exact endpointInput_mem_box 0 + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointChordAbscissa, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, pow_two, sub_eq_add_neg] using h + +private theorem endpointChordOrdinateRadicand_mem_interval : + (5025295 : ℝ) / 10000000 ≤ + endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointChordAbscissa cStar certifiedEndpointPair.2 ^ 2 ∧ + endpointOuterRadius cStar certifiedEndpointPair.2 ^ 2 - + endpointChordAbscissa cStar certifiedEndpointPair.2 ^ 2 ≤ 5025325 / 10000000 := by + let f : RadicalExpression 2 := + .add (.mul (.var 0) (.var 0)) (.neg (.mul (.var 1) (.var 1))) + let X : Fin 2 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-191708 / 1000000, -191705 / 1000000, by norm_num⟩ + let value : Fin 2 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointChordAbscissa cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨5025295 / 10000000, 5025325 / 10000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointChordAbscissa_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, RationalInterval.Contains, RadicalExpression.eval, pow_two, + sub_eq_add_neg] using h + +private theorem endpointChordOrdinate_mem_interval : + (708893 : ℝ) / 1000000 ≤ endpointChordOrdinate cStar certifiedEndpointPair.2 ∧ + endpointChordOrdinate cStar certifiedEndpointPair.2 ≤ 708896 / 1000000 := by + rw [endpointChordOrdinate] + constructor + · apply Real.le_sqrt_of_sq_le + nlinarith [endpointChordOrdinateRadicand_mem_interval.1] + · apply (Real.sqrt_le_iff).2 + constructor + · norm_num + · nlinarith [endpointChordOrdinateRadicand_mem_interval.2] + +private theorem endpointAngularRate_mem_interval : + (1234508 : ℝ) / 1000000 ≤ endpointAngularRate cStar certifiedEndpointPair.2 ∧ + endpointAngularRate cStar certifiedEndpointPair.2 ≤ 1234521 / 1000000 := by + let f : RadicalExpression 3 := + .mul (.mul (.var 0) (.add (.literal 1) (.neg (.var 1)))) (.inv (.var 2)) + let X : Fin 3 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-191708 / 1000000, -191705 / 1000000, by norm_num⟩ + | 2 => ⟨708893 / 1000000, 708896 / 1000000, by norm_num⟩ + let value : Fin 3 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointChordAbscissa cStar certifiedEndpointPair.2, + endpointChordOrdinate cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨1234508 / 1000000, 1234521 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointChordAbscissa_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointChordOrdinate_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointAngularRate, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, sub_eq_add_neg] using h + +private theorem endpointOuterAbscissaDerivative_mem_interval : + (-1314265 : ℝ) / 1000000 ≤ + endpointOuterAbscissaDerivative cStar certifiedEndpointPair.2 ∧ + endpointOuterAbscissaDerivative cStar certifiedEndpointPair.2 ≤ -1314242 / 1000000 := by + let f : RadicalExpression 4 := + .add (.mul (.var 0) (.var 1)) (.neg (.mul (.var 2) (.var 3))) + let X : Fin 4 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-814602 / 1000000, -814601 / 1000000, by norm_num⟩ + | 2 => ⟨1234508 / 1000000, 1234521 / 1000000, by norm_num⟩ + | 3 => ⟨580020 / 1000000, 580023 / 1000000, by norm_num⟩ + let value : Fin 4 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointUnitAbscissa certifiedEndpointPair.2, + endpointAngularRate cStar certifiedEndpointPair.2, + endpointUnitOrdinate certifiedEndpointPair.2] + let target : RationalInterval := + ⟨-1314265 / 1000000, -1314242 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointUnitAbscissa_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointAngularRate_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointUnitOrdinate_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointOuterAbscissaDerivative, RationalInterval.Contains, + RadicalExpression.eval, sub_eq_add_neg] using h + +private theorem endpointSecondDistanceDerivative_mem_interval : + (2723294 : ℝ) / 1000000 ≤ + endpointSecondDistanceDerivative cStar certifiedEndpointPair.2 ∧ + endpointSecondDistanceDerivative cStar certifiedEndpointPair.2 ≤ 2723337 / 1000000 := by + let f : RadicalExpression 3 := + .mul + (.add (.mul (.literal 4) (.var 0)) (.neg (.mul (.literal 2) (.var 1)))) + (.inv (.var 2)) + let X : Fin 3 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-1314265 / 1000000, -1314242 / 1000000, by norm_num⟩ + | 2 => ⟨2043810 / 1000000, 2043811 / 1000000, by norm_num⟩ + let value : Fin 3 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointOuterAbscissaDerivative cStar certifiedEndpointPair.2, + endpointSecondDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨2723294 / 1000000, 2723337 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointOuterAbscissaDerivative_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointSecondDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointSecondDistanceDerivative, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, sub_eq_add_neg] using h + +private theorem endpointMixedDistanceDerivative_mem_interval : + (1342822 : ℝ) / 1000000 ≤ + endpointMixedDistanceDerivative cStar certifiedEndpointPair.2 ∧ + endpointMixedDistanceDerivative cStar certifiedEndpointPair.2 ≤ 1342847 / 1000000 := by + let f : RadicalExpression 3 := + .mul (.add (.mul (.literal 2) (.var 0)) (.neg (.var 1))) (.inv (.var 2)) + let X : Fin 3 → RationalInterval + | 0 => ⟨734358 / 1000000, 734359 / 1000000, by norm_num⟩ + | 1 => ⟨-1314265 / 1000000, -1314242 / 1000000, by norm_num⟩ + | 2 => ⟨2072459 / 1000000, 2072460 / 1000000, by norm_num⟩ + let value : Fin 3 → ℝ := + ![endpointOuterRadius cStar certifiedEndpointPair.2, + endpointOuterAbscissaDerivative cStar certifiedEndpointPair.2, + endpointMixedAuxiliaryDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨1342822 / 1000000, 1342847 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointOuterRadius_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointOuterAbscissaDerivative_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMixedAuxiliaryDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointMixedDistanceDerivative, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, sub_eq_add_neg] using h + +private theorem endpointBaseAngularCoefficient_mem_interval : + (-270235 : ℝ) / 1000000 ≤ + endpointBaseAngularCoefficient cStar certifiedEndpointPair.2 ∧ + endpointBaseAngularCoefficient cStar certifiedEndpointPair.2 ≤ -270221 / 1000000 := by + let f : RadicalExpression 4 := + .add (.mul (.mul (.literal 2) (.var 0)) (.inv (.var 1))) + (.mul (.mul (.literal 2) (.var 2)) (.inv (.var 3))) + let X : Fin 4 → RationalInterval + | 0 => ⟨580020 / 1000000, 580023 / 1000000, by norm_num⟩ + | 1 => endpointInputBox 1 + | 2 => ⟨-688662 / 1000000, -688657 / 1000000, by norm_num⟩ + | 3 => ⟨2043810 / 1000000, 2043811 / 1000000, by norm_num⟩ + let value : Fin 4 → ℝ := + ![endpointUnitOrdinate certifiedEndpointPair.2, certifiedEndpointPair.2, + endpointOuterOrdinate cStar certifiedEndpointPair.2, + endpointSecondDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨-270235 / 1000000, -270221 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointUnitOrdinate_mem_interval + · exact endpointInput_mem_box 1 + · simpa [X, value, RationalInterval.Contains] using endpointOuterOrdinate_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointSecondDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointBaseAngularCoefficient, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv] using h + +private theorem endpointLambdaAngularCoefficient_mem_interval : + (403668 : ℝ) / 1000000 ≤ endpointLambdaAngularCoefficient certifiedEndpointPair.2 ∧ + endpointLambdaAngularCoefficient certifiedEndpointPair.2 ≤ 403672 / 1000000 := by + let f : RadicalExpression 2 := + .mul (.mul (.literal 2) (.var 0)) (.inv (.var 1)) + let X : Fin 2 → RationalInterval + | 0 => ⟨580020 / 1000000, 580023 / 1000000, by norm_num⟩ + | 1 => endpointInputBox 1 + let value : Fin 2 → ℝ := + ![endpointUnitOrdinate certifiedEndpointPair.2, certifiedEndpointPair.2] + let target : RationalInterval := ⟨403668 / 1000000, 403672 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointUnitOrdinate_mem_interval + · exact endpointInput_mem_box 1 + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.mul, + RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointLambdaAngularCoefficient, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv] using h + +private theorem endpointMuAngularCoefficient_mem_interval : + (252041 : ℝ) / 1000000 ≤ endpointMuAngularCoefficient cStar certifiedEndpointPair.2 ∧ + endpointMuAngularCoefficient cStar certifiedEndpointPair.2 ≤ 252051 / 1000000 := by + let f : RadicalExpression 4 := + .add (.mul (.var 0) (.inv (.var 1))) + (.mul (.add (.var 0) (.var 2)) (.inv (.var 3))) + let X : Fin 4 → RationalInterval + | 0 => ⟨580020 / 1000000, 580023 / 1000000, by norm_num⟩ + | 1 => ⟨1905046 / 1000000, 1905047 / 1000000, by norm_num⟩ + | 2 => ⟨-688662 / 1000000, -688657 / 1000000, by norm_num⟩ + | 3 => ⟨2072459 / 1000000, 2072460 / 1000000, by norm_num⟩ + let value : Fin 4 → ℝ := + ![endpointUnitOrdinate certifiedEndpointPair.2, + endpointFirstAuxiliaryDistance certifiedEndpointPair.2, + endpointOuterOrdinate cStar certifiedEndpointPair.2, + endpointMixedAuxiliaryDistance cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨252041 / 1000000, 252051 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using endpointUnitOrdinate_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointFirstAuxiliaryDistance_mem_interval + · simpa [X, value, RationalInterval.Contains] using endpointOuterOrdinate_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMixedAuxiliaryDistance_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.mul, + RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointMuAngularCoefficient, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv] using h + +private theorem endpointLambdaRadialCoefficient_mem_interval : + (-1193307 : ℝ) / 1000000 ≤ endpointLambdaRadialCoefficient cStar ∧ + endpointLambdaRadialCoefficient cStar ≤ -1193306 / 1000000 := by + rw [endpointLambdaRadialCoefficient] + constructor <;> linarith [cStar_mem_isolation_box.1, cStar_mem_isolation_box.2] + +private theorem endpointMuRadialCoefficient_mem_interval : + (-2817020 : ℝ) / 1000000 ≤ endpointMuRadialCoefficient cStar certifiedEndpointPair.2 ∧ + endpointMuRadialCoefficient cStar certifiedEndpointPair.2 ≤ -2816989 / 1000000 := by + let f : RadicalExpression 2 := + .add (.var 0) (.neg (.mul (.literal 3) (.var 1))) + let X : Fin 2 → RationalInterval + | 0 => ⟨1342822 / 1000000, 1342847 / 1000000, by norm_num⟩ + | 1 => endpointInputBox 0 + let value : Fin 2 → ℝ := + ![endpointMixedDistanceDerivative cStar certifiedEndpointPair.2, cStar] + let target : RationalInterval := ⟨-2817020 / 1000000, -2816989 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using + endpointMixedDistanceDerivative_mem_interval + · exact endpointInput_mem_box 0 + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, endpointInputBox, target, RadicalExpression.certifiesWithin, + RadicalExpression.enclosure, RationalInterval.singleton, RationalInterval.add, + RationalInterval.neg, RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointMuRadialCoefficient, RationalInterval.Contains, + RadicalExpression.eval, sub_eq_add_neg] using h + +private theorem endpointStationarityDeterminant_mem_interval : + (-836399 : ℝ) / 1000000 ≤ + endpointStationarityDeterminant cStar certifiedEndpointPair.2 ∧ + endpointStationarityDeterminant cStar certifiedEndpointPair.2 ≤ -836342 / 1000000 := by + let f : RadicalExpression 4 := + .add (.mul (.var 0) (.var 1)) (.neg (.mul (.var 2) (.var 3))) + let X : Fin 4 → RationalInterval + | 0 => ⟨403668 / 1000000, 403672 / 1000000, by norm_num⟩ + | 1 => ⟨-2817020 / 1000000, -2816989 / 1000000, by norm_num⟩ + | 2 => ⟨252041 / 1000000, 252051 / 1000000, by norm_num⟩ + | 3 => ⟨-1193307 / 1000000, -1193306 / 1000000, by norm_num⟩ + let value : Fin 4 → ℝ := + ![endpointLambdaAngularCoefficient certifiedEndpointPair.2, + endpointMuRadialCoefficient cStar certifiedEndpointPair.2, + endpointMuAngularCoefficient cStar certifiedEndpointPair.2, + endpointLambdaRadialCoefficient cStar] + let target : RationalInterval := ⟨-836399 / 1000000, -836342 / 1000000, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using + endpointLambdaAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMuRadialCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMuAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointLambdaRadialCoefficient_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointStationarityDeterminant, RationalInterval.Contains, + RadicalExpression.eval, sub_eq_add_neg] using h + +private theorem endpointLambda_mem_interval_aux : + (8 : ℝ) / 100 ≤ endpointLambda ∧ endpointLambda ≤ 10 / 100 := by + let f : RadicalExpression 5 := + .mul + (.add (.neg (.mul (.var 0) (.var 1))) (.mul (.var 2) (.var 3))) + (.inv (.var 4)) + let X : Fin 5 → RationalInterval + | 0 => ⟨-270235 / 1000000, -270221 / 1000000, by norm_num⟩ + | 1 => ⟨-2817020 / 1000000, -2816989 / 1000000, by norm_num⟩ + | 2 => ⟨252041 / 1000000, 252051 / 1000000, by norm_num⟩ + | 3 => ⟨2723294 / 1000000, 2723337 / 1000000, by norm_num⟩ + | 4 => ⟨-836399 / 1000000, -836342 / 1000000, by norm_num⟩ + let value : Fin 5 → ℝ := + ![endpointBaseAngularCoefficient cStar certifiedEndpointPair.2, + endpointMuRadialCoefficient cStar certifiedEndpointPair.2, + endpointMuAngularCoefficient cStar certifiedEndpointPair.2, + endpointSecondDistanceDerivative cStar certifiedEndpointPair.2, + endpointStationarityDeterminant cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨8 / 100, 10 / 100, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using + endpointBaseAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMuRadialCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointMuAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointSecondDistanceDerivative_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointStationarityDeterminant_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointLambda, endpointCramerLambda, + RationalInterval.Contains, RadicalExpression.eval, div_eq_mul_inv, sub_eq_add_neg] using h + +private theorem endpointMu_mem_interval_aux : + (92 : ℝ) / 100 ≤ endpointMu ∧ endpointMu ≤ 94 / 100 := by + let f : RadicalExpression 5 := + .mul + (.add (.neg (.mul (.var 0) (.var 1))) (.mul (.var 2) (.var 3))) + (.inv (.var 4)) + let X : Fin 5 → RationalInterval + | 0 => ⟨403668 / 1000000, 403672 / 1000000, by norm_num⟩ + | 1 => ⟨2723294 / 1000000, 2723337 / 1000000, by norm_num⟩ + | 2 => ⟨-270235 / 1000000, -270221 / 1000000, by norm_num⟩ + | 3 => ⟨-1193307 / 1000000, -1193306 / 1000000, by norm_num⟩ + | 4 => ⟨-836399 / 1000000, -836342 / 1000000, by norm_num⟩ + let value : Fin 5 → ℝ := + ![endpointLambdaAngularCoefficient certifiedEndpointPair.2, + endpointSecondDistanceDerivative cStar certifiedEndpointPair.2, + endpointBaseAngularCoefficient cStar certifiedEndpointPair.2, + endpointLambdaRadialCoefficient cStar, + endpointStationarityDeterminant cStar certifiedEndpointPair.2] + let target : RationalInterval := ⟨92 / 100, 94 / 100, by norm_num⟩ + have hX : ∀ i, (X i).Contains (value i) := by + intro i + fin_cases i + · simpa [X, value, RationalInterval.Contains] using + endpointLambdaAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointSecondDistanceDerivative_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointBaseAngularCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointLambdaRadialCoefficient_mem_interval + · simpa [X, value, RationalInterval.Contains] using + endpointStationarityDeterminant_mem_interval + have hf : f.certifiesWithin X target = true := by + norm_num [f, X, target, RadicalExpression.certifiesWithin, RadicalExpression.enclosure, + RationalInterval.singleton, RationalInterval.add, RationalInterval.neg, + RationalInterval.mul, RationalInterval.inv] + have h := RadicalExpression.certifiesWithin_sound hX hf + simpa [f, value, target, endpointMu, endpointCramerMu, RationalInterval.Contains, + RadicalExpression.eval, div_eq_mul_inv, sub_eq_add_neg] using h + +end + +/-- The first endpoint weight lies between `0.08` and `0.1`. -/ +theorem endpointLambda_mem_interval : + (2 : ℝ) / 25 ≤ endpointLambda ∧ endpointLambda ≤ 1 / 10 := by + convert endpointLambda_mem_interval_aux using 1 <;> norm_num + +/-- The second endpoint weight lies between `0.92` and `0.94`. -/ +theorem endpointMu_mem_interval : + (23 : ℝ) / 25 ≤ endpointMu ∧ endpointMu ≤ 47 / 50 := by + convert endpointMu_mem_interval_aux using 1 <;> norm_num + +/-- The first endpoint weight is positive. -/ +theorem endpointLambda_pos : 0 < endpointLambda := by + linarith [endpointLambda_mem_interval.1] + +/-- The second endpoint weight is positive. -/ +theorem endpointMu_pos : 0 < endpointMu := by + linarith [endpointMu_mem_interval.1] + +/-- The endpoint stationarity system has nonzero determinant. -/ +theorem endpointStationarityDeterminant_ne_zero : + endpointStationarityDeterminant cStar certifiedEndpointPair.2 ≠ 0 := by + linarith [endpointStationarityDeterminant_mem_interval.2] + +/-- Cramer's endpoint weights satisfy angular stationarity exactly. -/ +theorem endpoint_angular_stationarity : + endpointBaseAngularCoefficient cStar certifiedEndpointPair.2 + + endpointLambda * endpointLambdaAngularCoefficient certifiedEndpointPair.2 + + endpointMu * endpointMuAngularCoefficient cStar certifiedEndpointPair.2 = 0 := by + rw [endpointLambda, endpointMu, endpointCramerLambda, endpointCramerMu] + field_simp [endpointStationarityDeterminant_ne_zero] + rw [endpointStationarityDeterminant] + ring + +/-- Cramer's endpoint weights satisfy radial stationarity exactly. -/ +theorem endpoint_radial_stationarity : + endpointSecondDistanceDerivative cStar certifiedEndpointPair.2 + + endpointLambda * endpointLambdaRadialCoefficient cStar + + endpointMu * endpointMuRadialCoefficient cStar certifiedEndpointPair.2 = 0 := by + rw [endpointLambda, endpointMu, endpointCramerLambda, endpointCramerMu] + field_simp [endpointStationarityDeterminant_ne_zero] + rw [endpointStationarityDeterminant] + ring + +/-- Radial shrinkage gains more than one unit beyond both Lipschitz losses. -/ +theorem one_lt_endpoint_weight_penalty_margin : + 1 < weightedSecondPenalty cStar endpointLambda endpointMu - (2 + endpointMu) := by + have hc := cStar_mem_isolation_box.1 + have hlambda := endpointLambda_mem_interval.1 + have hmu := endpointMu_mem_interval.1 + rw [weightedSecondPenalty] + nlinarith + +/-- The endpoint weights meet the non-strict hypothesis of radial chord reduction. -/ +theorem endpoint_weight_reduction_margin : + 2 + endpointMu ≤ weightedSecondPenalty cStar endpointLambda endpointMu := by + linarith [one_lt_endpoint_weight_penalty_margin] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/FailureTree.lean b/LeanPool/Besicovitch/SixPoint/FailureTree.lean new file mode 100644 index 0000000000..dc10637c34 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/FailureTree.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.FourChildren +public import LeanPool.Besicovitch.SixPoint.RowColumnRescue + +/-! +# The first stage of the six-point failure tree + +For an admissible endpoint configuration, either a packing already has nonnegative score or one +of the two perfect matchings of the four children satisfies the exact matching obstruction. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +private theorem barC_four_children_gaps : + 0 < barC * (barC + 2) - 4 ∧ 1 < 2 * barC * (barC - 1) := by + have hc : (69 : ℝ) / 50 < barC := by + nlinarith [barC_mem_isolation_box.1] + constructor <;> nlinarith [sq_nonneg (barC - 69 / 50)] + +private theorem sibling_distance_mem_four_children_range + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (color : SixPointColor) : + barC ≤ dist (configuration color .left) (configuration color .right) ∧ + dist (configuration color .left) (configuration color .right) ≤ 2 := by + constructor + · have hsibling := h.sibling_distance color + rw [barS, show 2 * (barC / 2) = barC by ring] at hsibling + exact hsibling + · calc + dist (configuration color .left) (configuration color .right) ≤ + dist (configuration color .left) (configuration color .root) + + dist (configuration color .root) (configuration color .right) := dist_triangle _ _ _ + _ ≤ 1 + 1 := add_le_add + (by simpa [dist_comm] using h.child_distance color .left (by simp)) + (h.child_distance color .right (by simp)) + _ = 2 := by norm_num + +private theorem cross_child_distance_le_three {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (redLabel blueLabel : SixPointLabel) + (hred : redLabel ≠ .root) (hblue : blueLabel ≠ .root) : + dist (configuration .red redLabel) (configuration .blue blueLabel) ≤ 3 := by + calc + _ ≤ dist (configuration .red redLabel) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue blueLabel) := dist_triangle _ _ _ + _ ≤ dist (configuration .red redLabel) (configuration .red .root) + + (dist (configuration .red .root) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .blue blueLabel)) := + by + gcongr + exact dist_triangle _ _ _ + _ ≤ 1 + (1 + 1) := add_le_add + (by simpa [dist_comm] using h.child_distance .red redLabel hred) + (add_le_add h.root_distance.le (h.child_distance .blue blueLabel hblue)) + _ = 3 := by norm_num + +private theorem exists_nonnegative_score_or_matching_obstruction_of_no_split + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hno : ¬ ∃ x y : ℝ, + dist (configuration .red .left) (configuration .red .right) - 1 ≤ x ∧ x ≤ 1 ∧ + dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y ∧ y ≤ 1 ∧ + fourChildrenSplitDiameter + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) ≤ + barC * (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right))) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .left) + + dist (configuration .red .right) (configuration .blue .right) ∨ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .right) + + dist (configuration .red .right) (configuration .blue .left) := by + obtain ⟨hcL, hL⟩ := sibling_distance_mem_four_children_range h .red + obtain ⟨hcM, hM⟩ := sibling_distance_mem_four_children_range h .blue + have hfail : ∀ x y : ℝ, + dist (configuration .red .left) (configuration .red .right) - 1 ≤ x → x ≤ 1 → + dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y → y ≤ 1 → + barC * (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) < + fourChildrenSplitDiameter + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) := by + intro x y hx_lower hx_upper hy_lower hy_upper + exact lt_of_not_ge fun hdiameter ↦ + hno ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, hdiameter⟩ + rcases fourChildren_row_column_or_matching one_lt_barC_and_barC_lt_two.1 + one_lt_barC_and_barC_lt_two.2.le hcL hcM hL hM barC_four_children_gaps.1 + barC_four_children_gaps.2 (cross_child_distance_le_three h .left .left (by simp) + (by simp)) (cross_child_distance_le_three h .left .right (by simp) (by simp)) + (cross_child_distance_le_three h .right .left (by simp) (by simp)) + (cross_child_distance_le_three h .right .right (by simp) (by simp)) hfail with + hrowLeft | hrowRight | hcolumnLeft | hcolumnRight | hdiagonal | hantiDiagonal + · exact Or.inl ⟨redRootBlueTrianglePacking configuration + (h.child_distance .blue .left (by simp)) (h.child_distance .blue .right (by simp)), + red_root_blue_triangle_score_nonnegative_of_row_obstruction configuration h .left + (by simp) hrowLeft⟩ + · exact Or.inl ⟨redRootBlueTrianglePacking configuration + (h.child_distance .blue .left (by simp)) (h.child_distance .blue .right (by simp)), + red_root_blue_triangle_score_nonnegative_of_row_obstruction configuration h .right + (by simp) hrowRight⟩ + · exact Or.inl ⟨blueRootRedTrianglePacking configuration + (h.child_distance .red .left (by simp)) (h.child_distance .red .right (by simp)), + blue_root_red_triangle_score_nonnegative_of_column_obstruction configuration h .left + (by simp) (by nlinarith [hcolumnLeft])⟩ + · exact Or.inl ⟨blueRootRedTrianglePacking configuration + (h.child_distance .red .left (by simp)) (h.child_distance .red .right (by simp)), + blue_root_red_triangle_score_nonnegative_of_column_obstruction configuration h .right + (by simp) (by nlinarith [hcolumnRight])⟩ + · exact Or.inr (Or.inl hdiagonal) + · exact Or.inr (Or.inr hantiDiagonal) + +/-- Every admissible endpoint configuration has a nonnegative packing or an obstructing child +matching. -/ +theorem exists_nonnegative_score_or_matching_obstruction + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .left) + + dist (configuration .red .right) (configuration .blue .right) ∨ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .right) + + dist (configuration .red .right) (configuration .blue .left) := by + by_cases hsplit : ∃ x y : ℝ, + dist (configuration .red .left) (configuration .red .right) - 1 ≤ x ∧ x ≤ 1 ∧ + dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y ∧ y ≤ 1 ∧ + fourChildrenSplitDiameter + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) ≤ + barC * (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) + · rcases hsplit with ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, hdiameter⟩ + have hL := (one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_four_children_range h .red).1) + have hM := (one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_four_children_range h .blue).1) + refine Or.inl ⟨fourChildrenPacking configuration rfl rfl hL hx_lower hx_upper hM + hy_lower hy_upper, ?_⟩ + simpa only [barS] using fourChildrenPacking_score_nonnegative configuration rfl rfl hL + hx_lower hx_upper hM hy_lower hy_upper barC_pos hdiameter + · exact exists_nonnegative_score_or_matching_obstruction_of_no_split configuration h hsplit + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/FiniteProperty.lean b/LeanPool/Besicovitch/SixPoint/FiniteProperty.lean new file mode 100644 index 0000000000..5742459fe9 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/FiniteProperty.lean @@ -0,0 +1,521 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Score + +/-! +# The finite six-point property + +This file states the compactified finite property and removes zero-radius labels from strict +witnesses. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Every admissible configuration at `s` has a compactified packing of nonnegative score. -/ +def SixPointFiniteProperty (s : ℝ) : Prop := + ∀ configuration : SixPointConfiguration, configuration.IsAdmissibleAt s → + ∃ packing : SixPointPacking configuration, 0 ≤ packing.score s + +namespace SixPointPacking + +variable {configuration : SixPointConfiguration} (packing : SixPointPacking configuration) + +/-- A packing is genuine when every radius on its support is positive. -/ +def HasPositiveRadii : Prop := + ∀ i : packing.support, 0 < (packing.radius i : ℝ) + +/-- The labels carrying positive radius in a compactified packing. -/ +def positiveSupport : Finset SixPointIndex := + packing.support.filter fun index ↦ + ∃ hindex : index ∈ packing.support, 0 < (packing.radius ⟨index, hindex⟩ : ℝ) + +/-- Membership in the positive support is exactly positivity of the corresponding radius. -/ +theorem mem_positiveSupport_iff {index : SixPointIndex} : + index ∈ packing.positiveSupport ↔ + ∃ hindex : index ∈ packing.support, 0 < (packing.radius ⟨index, hindex⟩ : ℝ) := by + rw [positiveSupport, Finset.mem_filter] + constructor + · exact And.right + · rintro ⟨hindex, hpositive⟩ + exact ⟨hindex, hindex, hpositive⟩ + +/-- The positive support is contained in the compactified support. -/ +theorem positiveSupport_subset : packing.positiveSupport ⊆ packing.support := by + exact Finset.filter_subset _ _ + +private def positiveRestriction + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + SixPointPacking configuration where + support := packing.positiveSupport + meets_color := hmeets + radius i := packing.radius ⟨i, packing.positiveSupport_subset i.2⟩ + same_color_disjoint i j hij hcolor := by + apply packing.same_color_disjoint + · intro h + apply hij + apply Subtype.ext + exact congrArg (fun x : packing.support ↦ (x : SixPointIndex)) h + · exact hcolor + +private theorem positiveRestriction_hasPositiveRadii + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + (packing.positiveRestriction hmeets).HasPositiveRadii := by + intro i + exact (packing.mem_positiveSupport_iff.1 i.2).choose_spec + +private theorem positiveRestriction_radius_le {cap : ℝ} + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + ∀ i : (packing.positiveRestriction hmeets).support, + ((packing.positiveRestriction hmeets).radius i : ℝ) ≤ cap := by + intro i + exact hcap ⟨i, packing.positiveSupport_subset i.2⟩ + +private theorem positiveRestriction_totalRadius + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + (packing.positiveRestriction hmeets).totalRadius = packing.totalRadius := by + change (∑ i ∈ packing.positiveSupport.attach, + (packing.radius ⟨i, packing.positiveSupport_subset i.2⟩ : ℝ)) = + ∑ i ∈ packing.support.attach, (packing.radius i : ℝ) + calc + _ = ∑ i ∈ packing.support.attach.filter fun i ↦ 0 < (packing.radius i : ℝ), + (packing.radius i : ℝ) := by + refine Finset.sum_bij (fun i _ ↦ ⟨i, packing.positiveSupport_subset i.2⟩) ?_ ?_ ?_ ?_ + · intro i hi + exact Finset.mem_filter.2 + ⟨Finset.mem_attach _ _, (packing.mem_positiveSupport_iff.1 i.2).choose_spec⟩ + · intro i₁ hi₁ i₂ hi₂ heq + apply Subtype.ext + exact congrArg (fun x : packing.support ↦ (x : SixPointIndex)) heq + · intro j hj + refine ⟨⟨j, packing.mem_positiveSupport_iff.2 ⟨j.2, (Finset.mem_filter.1 hj).2⟩⟩, + Finset.mem_attach _ _, ?_⟩ + rfl + · intro i hi + rfl + _ = _ := by + apply Finset.sum_subset (Finset.filter_subset _ _) + intro i hi hnot + apply le_antisymm + · exact not_lt.mp fun hpositive ↦ hnot (Finset.mem_filter.2 ⟨hi, hpositive⟩) + · exact (packing.radius i).property.1 + +private theorem positiveRestriction_virtualDiameter_le + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + (packing.positiveRestriction hmeets).virtualDiameter ≤ packing.virtualDiameter := by + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact packing.pair_le_virtualDiameter + ⟨i, packing.positiveSupport_subset i.2⟩ ⟨j, packing.positiveSupport_subset j.2⟩ + +private theorem score_le_positiveRestriction {beta : ℝ} (hbeta : 0 < beta) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport) : + packing.score beta ≤ (packing.positiveRestriction hmeets).score beta := by + simp only [score] + rw [packing.positiveRestriction_totalRadius hmeets] + gcongr + exact packing.positiveRestriction_virtualDiameter_le hmeets + +private def radiusValue (index : SixPointIndex) : ℝ := + if hindex : index ∈ packing.support then packing.radius ⟨index, hindex⟩ else 0 + +private theorem radiusValue_nonneg (index : SixPointIndex) : 0 ≤ packing.radiusValue index := by + rw [radiusValue] + split_ifs with hindex + · exact (packing.radius ⟨index, hindex⟩).property.1 + · exact le_rfl + +private theorem totalRadius_eq_sum_radiusValue : + packing.totalRadius = ∑ index ∈ packing.support, packing.radiusValue index := by + rw [totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, packing.radiusValue i := by + apply Finset.sum_congr rfl + intro i hi + simp only [radiusValue, i.2, dite_true] + _ = _ := Finset.sum_attach _ _ + +private theorem totalRadius_eq_sum_positiveSupport : + packing.totalRadius = ∑ index ∈ packing.positiveSupport, packing.radiusValue index := by + rw [packing.totalRadius_eq_sum_radiusValue] + symm + apply Finset.sum_subset packing.positiveSupport_subset + intro index hindex hpositive + simp only [radiusValue, hindex, dite_true] + apply le_antisymm + · apply not_lt.mp + intro hradius + exact hpositive (packing.mem_positiveSupport_iff.2 ⟨hindex, hradius⟩) + · exact (packing.radius ⟨index, hindex⟩).property.1 + +private def addIsolated (index : SixPointIndex) + (habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index}) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + SixPointPacking configuration where + support := packing.positiveSupport ∪ {index} + meets_color := hmeets + radius i := if hpositive : (i : SixPointIndex) ∈ packing.positiveSupport then + packing.radius ⟨i, packing.positiveSupport_subset hpositive⟩ + else ⟨epsilon, hepsilon.le, hepsilon_one⟩ + same_color_disjoint i j hij hcolor := by + classical + by_cases hi : (i : SixPointIndex) ∈ packing.positiveSupport + · by_cases hj : (j : SixPointIndex) ∈ packing.positiveSupport + · simp only [hi, hj, dite_true] + apply packing.same_color_disjoint + · intro h + apply hij + apply Subtype.ext + exact congrArg (fun x : packing.support ↦ (x : SixPointIndex)) h + · exact hcolor + · have hjindex : (j : SixPointIndex) = index := + Finset.mem_singleton.1 ((Finset.mem_union.1 j.2).resolve_left hj) + exact (habsent i hi (hcolor.trans (congrArg Prod.fst hjindex))).elim + · by_cases hj : (j : SixPointIndex) ∈ packing.positiveSupport + · have hiindex : (i : SixPointIndex) = index := + Finset.mem_singleton.1 ((Finset.mem_union.1 i.2).resolve_left hi) + exact (habsent j hj (hcolor.symm.trans (congrArg Prod.fst hiindex))).elim + · have hiindex : (i : SixPointIndex) = index := + Finset.mem_singleton.1 ((Finset.mem_union.1 i.2).resolve_left hi) + have hjindex : (j : SixPointIndex) = index := + Finset.mem_singleton.1 ((Finset.mem_union.1 j.2).resolve_left hj) + exact (hij (Subtype.ext (hiindex.trans hjindex.symm))).elim + +private theorem addIsolated_hasPositiveRadii (index : SixPointIndex) + (habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index}) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).HasPositiveRadii := by + intro i + simp only [addIsolated] + split_ifs with hpositive + · exact (packing.mem_positiveSupport_iff.1 hpositive).choose_spec + · exact hepsilon + +private theorem addIsolated_radius_le (index : SixPointIndex) + (habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index}) + {epsilon cap : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) + (hepsilon_cap : epsilon ≤ cap) + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) : + ∀ i : (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).support, + ((packing.addIsolated index habsent hmeets hepsilon hepsilon_one).radius i : ℝ) ≤ + cap := by + intro i + simp only [addIsolated] + split_ifs with hpositive + · exact hcap ⟨i, packing.positiveSupport_subset hpositive⟩ + · exact hepsilon_cap + +private theorem totalRadius_le_addIsolated (index : SixPointIndex) + (habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index}) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + packing.totalRadius ≤ + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).totalRadius := by + rw [packing.totalRadius_eq_sum_positiveSupport, + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).totalRadius_eq_sum_radiusValue] + calc + ∑ i ∈ packing.positiveSupport, packing.radiusValue i = + ∑ i ∈ packing.positiveSupport, + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).radiusValue i := by + apply Finset.sum_congr rfl + intro i hi + simp only [radiusValue, packing.positiveSupport_subset hi, dite_true] + have hi' : i ∈ (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).support := + Finset.mem_union_left _ hi + rw [dite_eq_left hi'] + simp only [addIsolated, hi, dite_true] + _ ≤ ∑ i ∈ (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).support, + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).radiusValue i := by + apply Finset.sum_le_sum_of_subset_of_nonneg Finset.subset_union_left + intro i hi hpositive + exact (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).radiusValue_nonneg i + +private theorem addIsolated_virtualDiameter_le (index : SixPointIndex) + (hindex : index ∈ packing.support) + (habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1) + (hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index}) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + (packing.addIsolated index habsent hmeets hepsilon hepsilon_one).virtualDiameter ≤ + packing.virtualDiameter + 2 * epsilon := by + let completed := packing.addIsolated index habsent hmeets hepsilon hepsilon_one + have old_mem (i : completed.support) : (i : SixPointIndex) ∈ packing.support := by + rcases Finset.mem_union.1 i.2 with hpositive | hi + · exact packing.positiveSupport_subset hpositive + · have hi' : (i : SixPointIndex) = index := by + simpa only [Finset.mem_singleton] using hi + exact hi' ▸ hindex + have radius_le (i : completed.support) : + (completed.radius i : ℝ) ≤ packing.radius ⟨i, old_mem i⟩ + epsilon := by + dsimp only [completed, addIsolated] + split_ifs with hpositive + · exact le_add_of_nonneg_right hepsilon.le + · exact le_add_of_nonneg_left (packing.radius ⟨i, old_mem i⟩).property.1 + change completed.virtualDiameter ≤ packing.virtualDiameter + 2 * epsilon + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + calc + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + completed.radius i + completed.radius j ≤ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + (packing.radius ⟨i, old_mem i⟩ + epsilon) + + (packing.radius ⟨j, old_mem j⟩ + epsilon) := + add_le_add (add_le_add le_rfl (radius_le i)) (radius_le j) + _ = (dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius ⟨i, old_mem i⟩ + packing.radius ⟨j, old_mem j⟩) + + 2 * epsilon := by ring + _ ≤ packing.virtualDiameter + 2 * epsilon := + add_le_add_left + (packing.pair_le_virtualDiameter ⟨i, old_mem i⟩ ⟨j, old_mem j⟩) (2 * epsilon) + +private theorem score_sub_error_le (packing' : SixPointPacking configuration) {beta epsilon : ℝ} + (hbeta : 0 < beta) (htotal : packing.totalRadius ≤ packing'.totalRadius) + (hvirtual : packing'.virtualDiameter ≤ packing.virtualDiameter + 2 * epsilon) : + packing.score beta - epsilon / beta ≤ packing'.score beta := by + simp only [score] + calc + packing.totalRadius - packing.virtualDiameter / (2 * beta) - epsilon / beta = + packing.totalRadius - (packing.virtualDiameter + 2 * epsilon) / (2 * beta) := by + field_simp + ring + _ ≤ packing'.totalRadius - packing'.virtualDiameter / (2 * beta) := + sub_le_sub htotal ((div_le_div_iff_of_pos_right (by positivity : 0 < 2 * beta)).2 hvirtual) + +private def twoIsolated (_packing : SixPointPacking configuration) + (redLabel blueLabel : SixPointLabel) {epsilon : ℝ} + (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : SixPointPacking configuration where + support := {(.red, redLabel), (.blue, blueLabel)} + meets_color color := by + cases color + · exact ⟨redLabel, by simp⟩ + · exact ⟨blueLabel, by simp⟩ + radius _ := ⟨epsilon, hepsilon.le, hepsilon_one⟩ + same_color_disjoint i j hij hcolor := by + have hi := i.2 + have hj := j.2 + simp only [Finset.mem_insert, Finset.mem_singleton] at hi hj + rcases hi with hi | hi + · rcases hj with hj | hj + · exact (hij (Subtype.ext (hi.trans hj.symm))).elim + · simp [hi, hj] at hcolor + · rcases hj with hj | hj + · simp [hi, hj] at hcolor + · exact (hij (Subtype.ext (hi.trans hj.symm))).elim + +private theorem twoIsolated_hasPositiveRadii (redLabel blueLabel : SixPointLabel) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + (packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one).HasPositiveRadii := by + intro i + exact hepsilon + +private theorem twoIsolated_radius_le (redLabel blueLabel : SixPointLabel) + {epsilon cap : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) + (hepsilon_cap : epsilon ≤ cap) : + ∀ i : (packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one).support, + ((packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one).radius i : ℝ) ≤ cap := by + intro i + exact hepsilon_cap + +private theorem twoIsolated_virtualDiameter_le (redLabel blueLabel : SixPointLabel) + (hred : (.red, redLabel) ∈ packing.support) (hblue : (.blue, blueLabel) ∈ packing.support) + {epsilon : ℝ} (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) : + (packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one).virtualDiameter ≤ + packing.virtualDiameter + 2 * epsilon := by + let completed := packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one + have old_mem (i : completed.support) : (i : SixPointIndex) ∈ packing.support := by + have hi := i.2 + dsimp only [completed, twoIsolated] at hi + simp only [Finset.mem_insert, Finset.mem_singleton] at hi + rcases hi with hi | hi + · exact hi ▸ hred + · exact hi ▸ hblue + have radius_le (i : completed.support) : + (completed.radius i : ℝ) ≤ packing.radius ⟨i, old_mem i⟩ + epsilon := by + dsimp only [completed, twoIsolated] + exact le_add_of_nonneg_left (packing.radius ⟨i, old_mem i⟩).property.1 + change completed.virtualDiameter ≤ packing.virtualDiameter + 2 * epsilon + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + calc + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + completed.radius i + completed.radius j ≤ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + (packing.radius ⟨i, old_mem i⟩ + epsilon) + + (packing.radius ⟨j, old_mem j⟩ + epsilon) := + add_le_add (add_le_add le_rfl (radius_le i)) (radius_le j) + _ = (dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius ⟨i, old_mem i⟩ + packing.radius ⟨j, old_mem j⟩) + + 2 * epsilon := by ring + _ ≤ packing.virtualDiameter + 2 * epsilon := + add_le_add_left + (packing.pair_le_virtualDiameter ⟨i, old_mem i⟩ ⟨j, old_mem j⟩) (2 * epsilon) + +private theorem exists_cleanup_of_both_colors {beta cap a : ℝ} (hbeta : 0 < beta) + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) + (hscore : a < packing.score beta) + (hred : ∃ label, (.red, label) ∈ packing.positiveSupport) + (hblue : ∃ label, (.blue, label) ∈ packing.positiveSupport) : + ∃ packing' : SixPointPacking configuration, packing'.HasPositiveRadii ∧ + (∀ i : packing'.support, (packing'.radius i : ℝ) ≤ cap) ∧ + a < packing'.score beta := by + have hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport := by + intro color + cases color + · exact hred + · exact hblue + let packing' := packing.positiveRestriction hmeets + refine ⟨packing', packing.positiveRestriction_hasPositiveRadii hmeets, + packing.positiveRestriction_radius_le hcap hmeets, ?_⟩ + exact hscore.trans_le (packing.score_le_positiveRestriction hbeta hmeets) + +private theorem exists_cleanup_of_red_only {beta cap a epsilon : ℝ} (hbeta : 0 < beta) + (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) (hepsilon_cap : epsilon ≤ cap) + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) + (hstrict : a < packing.score beta - epsilon / beta) + (hred : ∃ label, (.red, label) ∈ packing.positiveSupport) + (hblue : ¬ ∃ label, (.blue, label) ∈ packing.positiveSupport) : + ∃ packing' : SixPointPacking configuration, packing'.HasPositiveRadii ∧ + (∀ i : packing'.support, (packing'.radius i : ℝ) ≤ cap) ∧ + a < packing'.score beta := by + obtain ⟨blueLabel, hblueLabel⟩ := packing.meets_color .blue + let index : SixPointIndex := (.blue, blueLabel) + have habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1 := by + rintro ⟨color, label⟩ hi hcolor + apply hblue + dsimp only [index] at hcolor + subst color + exact ⟨label, hi⟩ + have hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index} := by + intro color + cases color + · obtain ⟨label, hlabel⟩ := hred + exact ⟨label, Finset.mem_union_left _ hlabel⟩ + · exact ⟨blueLabel, Finset.mem_union_right _ (Finset.mem_singleton_self index)⟩ + let packing' := packing.addIsolated index habsent hmeets hepsilon hepsilon_one + refine ⟨packing', packing.addIsolated_hasPositiveRadii index habsent hmeets hepsilon + hepsilon_one, packing.addIsolated_radius_le index habsent hmeets hepsilon hepsilon_one + hepsilon_cap hcap, ?_⟩ + apply hstrict.trans_le + exact packing.score_sub_error_le packing' hbeta + (packing.totalRadius_le_addIsolated index habsent hmeets hepsilon hepsilon_one) + (packing.addIsolated_virtualDiameter_le index hblueLabel habsent hmeets hepsilon hepsilon_one) + +private theorem exists_cleanup_of_blue_only {beta cap a epsilon : ℝ} (hbeta : 0 < beta) + (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) (hepsilon_cap : epsilon ≤ cap) + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) + (hstrict : a < packing.score beta - epsilon / beta) + (hred : ¬ ∃ label, (.red, label) ∈ packing.positiveSupport) + (hblue : ∃ label, (.blue, label) ∈ packing.positiveSupport) : + ∃ packing' : SixPointPacking configuration, packing'.HasPositiveRadii ∧ + (∀ i : packing'.support, (packing'.radius i : ℝ) ≤ cap) ∧ + a < packing'.score beta := by + obtain ⟨redLabel, hredLabel⟩ := packing.meets_color .red + let index : SixPointIndex := (.red, redLabel) + have habsent : ∀ i ∈ packing.positiveSupport, i.1 ≠ index.1 := by + rintro ⟨color, label⟩ hi hcolor + apply hred + dsimp only [index] at hcolor + subst color + exact ⟨label, hi⟩ + have hmeets : ∀ color, ∃ label, (color, label) ∈ packing.positiveSupport ∪ {index} := by + intro color + cases color + · exact ⟨redLabel, Finset.mem_union_right _ (Finset.mem_singleton_self index)⟩ + · obtain ⟨label, hlabel⟩ := hblue + exact ⟨label, Finset.mem_union_left _ hlabel⟩ + let packing' := packing.addIsolated index habsent hmeets hepsilon hepsilon_one + refine ⟨packing', packing.addIsolated_hasPositiveRadii index habsent hmeets hepsilon + hepsilon_one, packing.addIsolated_radius_le index habsent hmeets hepsilon hepsilon_one + hepsilon_cap hcap, ?_⟩ + apply hstrict.trans_le + exact packing.score_sub_error_le packing' hbeta + (packing.totalRadius_le_addIsolated index habsent hmeets hepsilon hepsilon_one) + (packing.addIsolated_virtualDiameter_le index hredLabel habsent hmeets hepsilon hepsilon_one) + +private theorem exists_cleanup_of_no_positive_radii {beta cap a epsilon : ℝ} + (hbeta : 0 < beta) (hepsilon : 0 < epsilon) (hepsilon_one : epsilon ≤ 1) + (hepsilon_cap : epsilon ≤ cap) (hstrict : a < packing.score beta - epsilon / beta) + (hred : ¬ ∃ label, (.red, label) ∈ packing.positiveSupport) + (hblue : ¬ ∃ label, (.blue, label) ∈ packing.positiveSupport) : + ∃ packing' : SixPointPacking configuration, packing'.HasPositiveRadii ∧ + (∀ i : packing'.support, (packing'.radius i : ℝ) ≤ cap) ∧ + a < packing'.score beta := by + obtain ⟨redLabel, hredLabel⟩ := packing.meets_color .red + obtain ⟨blueLabel, hblueLabel⟩ := packing.meets_color .blue + have hpositive_empty : packing.positiveSupport = ∅ := by + apply Finset.not_nonempty_iff_eq_empty.1 + rintro ⟨⟨color, label⟩, hlabel⟩ + cases color + · exact hred ⟨label, hlabel⟩ + · exact hblue ⟨label, hlabel⟩ + have htotal_zero : packing.totalRadius = 0 := by + rw [packing.totalRadius_eq_sum_positiveSupport, hpositive_empty] + simp + let packing' := packing.twoIsolated redLabel blueLabel hepsilon hepsilon_one + refine ⟨packing', packing.twoIsolated_hasPositiveRadii redLabel blueLabel hepsilon + hepsilon_one, packing.twoIsolated_radius_le redLabel blueLabel hepsilon hepsilon_one + hepsilon_cap, ?_⟩ + apply hstrict.trans_le + apply packing.score_sub_error_le packing' hbeta + · rw [htotal_zero] + exact packing'.totalRadius_nonneg + · exact packing.twoIsolated_virtualDiameter_le redLabel blueLabel hredLabel hblueLabel + hepsilon hepsilon_one + +/-- A strict compactified score has a genuine witness below the same positive radius cap. -/ +theorem exists_positiveRadii_score_gt {beta cap a : ℝ} (hbeta : 0 < beta) + (hcap_pos : 0 < cap) (hcap_one : cap ≤ 1) + (hcap : ∀ i : packing.support, (packing.radius i : ℝ) ≤ cap) + (hscore : a < packing.score beta) : + ∃ packing' : SixPointPacking configuration, packing'.HasPositiveRadii ∧ + (∀ i : packing'.support, (packing'.radius i : ℝ) ≤ cap) ∧ + a < packing'.score beta := by + let epsilon := min cap (beta * (packing.score beta - a) / 2) + have hgap : 0 < packing.score beta - a := sub_pos.mpr hscore + have hepsilon : 0 < epsilon := by + dsimp only [epsilon] + rw [lt_min_iff] + exact ⟨hcap_pos, div_pos (mul_pos hbeta hgap) (by norm_num)⟩ + have hepsilon_cap : epsilon ≤ cap := by + dsimp only [epsilon] + exact min_le_left _ _ + have hepsilon_one : epsilon ≤ 1 := hepsilon_cap.trans hcap_one + have herror : epsilon / beta < packing.score beta - a := by + apply (div_lt_iff₀ hbeta).2 + have hepsilon_gain := min_le_right cap (beta * (packing.score beta - a) / 2) + nlinarith [mul_pos hbeta hgap] + have hstrict : a < packing.score beta - epsilon / beta := by linarith + by_cases hred : ∃ label, (.red, label) ∈ packing.positiveSupport + · by_cases hblue : ∃ label, (.blue, label) ∈ packing.positiveSupport + · exact packing.exists_cleanup_of_both_colors hbeta hcap hscore hred hblue + · exact packing.exists_cleanup_of_red_only hbeta hepsilon hepsilon_one hepsilon_cap + hcap hstrict hred hblue + · by_cases hblue : ∃ label, (.blue, label) ∈ packing.positiveSupport + · exact packing.exists_cleanup_of_blue_only hbeta hepsilon hepsilon_one hepsilon_cap + hcap hstrict hred hblue + · exact packing.exists_cleanup_of_no_positive_radii hbeta hepsilon hepsilon_one + hepsilon_cap hstrict hred hblue + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/FourChildren.lean b/LeanPool/Besicovitch/SixPoint/FourChildren.lean new file mode 100644 index 0000000000..3a2a5a59a6 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/FourChildren.lean @@ -0,0 +1,475 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Packing + +/-! +# The four-child packing + +This file constructs the split-radius packing on the four child labels and records its elementary +routing algebra. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The packing on all four children with prescribed tangent radius splits. -/ +def fourChildrenPacking (configuration : SixPointConfiguration) {L M x y : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) : + SixPointPacking configuration where + support := {(.red, .left), (.red, .right), (.blue, .left), (.blue, .right)} + meets_color color := by + cases color + · exact ⟨.left, by simp⟩ + · exact ⟨.left, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color <;> cases label + · simp at hlabel + · exact ⟨x, by nlinarith, hx_upper⟩ + · exact ⟨L - x, by nlinarith, by nlinarith⟩ + · simp at hlabel + · exact ⟨y, by nlinarith, hy_upper⟩ + · exact ⟨M - y, by nlinarith, by nlinarith⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li + · simp at hi + · cases lj + · simp at hj + · exact (hij (Subtype.ext rfl)).elim + · dsimp + nlinarith + · cases lj + · simp at hj + · dsimp + rw [dist_comm, hLdist] + nlinarith + · exact (hij (Subtype.ext rfl)).elim + · cases li + · simp at hi + · cases lj + · simp at hj + · exact (hij (Subtype.ext rfl)).elim + · dsimp + nlinarith + · cases lj + · simp at hj + · dsimp + rw [dist_comm, hMdist] + nlinarith + · exact (hij (Subtype.ext rfl)).elim + +/-- The largest cross-color diameter term for a four-child radius split. -/ +def fourChildrenCrossMaximum (L M x y B11 B12 B21 B22 : ℝ) : ℝ := + max (B11 + x + y) <| max (B12 + x + (M - y)) <| + max (B21 + (L - x) + y) (B22 + (L - x) + (M - y)) + +/-- The largest same-color or cross-color diameter term for a four-child split. -/ +def fourChildrenSplitDiameter (L M x y B11 B12 B21 B22 : ℝ) : ℝ := + max (2 * L) (max (2 * M) (fourChildrenCrossMaximum L M x y B11 B12 B21 B22)) + +/-- The total radius of the four-child packing is the sum of the two sibling lengths. -/ +theorem fourChildrenPacking_totalRadius + (configuration : SixPointConfiguration) {L M x y : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) : + (fourChildrenPacking configuration hLdist hMdist hL hx_lower hx_upper hM hy_lower + hy_upper).totalRadius = L + M := by + let packing := fourChildrenPacking configuration hLdist hMdist hL hx_lower hx_upper hM + hy_lower hy_upper + let value : SixPointIndex → ℝ + | (.red, .root) | (.blue, .root) => 0 + | (.red, .left) => x + | (.red, .right) => L - x + | (.blue, .left) => y + | (.blue, .right) => M - y + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [fourChildrenPacking, value] at hi ⊢ + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + simp [packing, fourChildrenPacking, value] + ring + +private theorem fourChildren_sameColorPair_le + {configuration : SixPointConfiguration} (packing : SixPointPacking configuration) + (i j : packing.support) (hcolor : i.1.1 = j.1.1) {bound : ℝ} + (hbound : 1 ≤ bound) + (hdist : dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ bound) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ 2 * bound := by + by_cases hij : i = j + · subst j + simp only [dist_self, zero_add] + nlinarith [(packing.radius i).property.2] + · nlinarith [packing.same_color_disjoint i j hij hcolor] + +/-- The virtual diameter of the four-child packing is its explicit split minimax. -/ +theorem fourChildrenPacking_virtualDiameter + (configuration : SixPointConfiguration) {L M x y : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) : + (fourChildrenPacking configuration hLdist hMdist hL hx_lower hx_upper hM hy_lower + hy_upper).virtualDiameter = + fourChildrenSplitDiameter L M x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) := by + let packing := fourChildrenPacking configuration hLdist hMdist hL hx_lower hx_upper hM + hy_lower hy_upper + let target := fourChildrenSplitDiameter L M x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) + have htwoL : 2 * L ≤ target := le_max_left _ _ + have htwoM : 2 * M ≤ target := le_max_of_le_right (le_max_left _ _) + have h11 : dist (configuration .red .left) (configuration .blue .left) + x + y ≤ + target := le_max_of_le_right <| le_max_of_le_right <| le_max_left _ _ + have h12 : + dist (configuration .red .left) (configuration .blue .right) + x + (M - y) ≤ + target := le_max_of_le_right <| le_max_of_le_right <| le_max_of_le_right <| + le_max_left _ _ + have h21 : + dist (configuration .red .right) (configuration .blue .left) + (L - x) + y ≤ + target := le_max_of_le_right <| le_max_of_le_right <| le_max_of_le_right <| + le_max_of_le_right <| le_max_left _ _ + have h22 : + dist (configuration .red .right) (configuration .blue .right) + + (L - x) + (M - y) ≤ target := + le_max_of_le_right <| le_max_of_le_right <| le_max_of_le_right <| + le_max_of_le_right <| le_max_right _ _ + have hredLeftRadius (hmem : (.red, .left) ∈ packing.support) : + (packing.radius ⟨(.red, .left), hmem⟩ : ℝ) = x := by + rfl + have hredRightRadius (hmem : (.red, .right) ∈ packing.support) : + (packing.radius ⟨(.red, .right), hmem⟩ : ℝ) = L - x := by + rfl + have hblueLeftRadius (hmem : (.blue, .left) ∈ packing.support) : + (packing.radius ⟨(.blue, .left), hmem⟩ : ℝ) = y := by + rfl + have hblueRightRadius (hmem : (.blue, .right) ∈ packing.support) : + (packing.radius ⟨(.blue, .right), hmem⟩ : ℝ) = M - y := by + rfl + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · have hleftMem := hleft + have hrightMem := hright + cases leftLabel <;> cases rightLabel + all_goals simp [packing, fourChildrenPacking] at hleft hright + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hL (by simp; linarith)).trans htwoL + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hL + (by rw [hLdist])).trans htwoL + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hL + (by rw [dist_comm, hLdist])).trans htwoL + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hL (by simp; linarith)).trans htwoL + · have hleftMem := hleft + have hrightMem := hright + cases leftLabel <;> cases rightLabel + all_goals simp [packing, fourChildrenPacking] at hleft hright + · simpa [hredLeftRadius hleftMem, hblueLeftRadius hrightMem] using h11 + · simpa [hredLeftRadius hleftMem, hblueRightRadius hrightMem] using h12 + · simpa [hredRightRadius hleftMem, hblueLeftRadius hrightMem] using h21 + · simpa [hredRightRadius hleftMem, hblueRightRadius hrightMem] using h22 + · have hleftMem := hleft + have hrightMem := hright + cases leftLabel <;> cases rightLabel + all_goals simp [packing, fourChildrenPacking] at hleft hright + · rw [hblueLeftRadius hleftMem, hredLeftRadius hrightMem, dist_comm] + linarith [h11] + · rw [hblueLeftRadius hleftMem, hredRightRadius hrightMem, dist_comm] + linarith [h21] + · rw [hblueRightRadius hleftMem, hredLeftRadius hrightMem, dist_comm] + linarith [h12] + · rw [hblueRightRadius hleftMem, hredRightRadius hrightMem, dist_comm] + linarith [h22] + · have hleftMem := hleft + have hrightMem := hright + cases leftLabel <;> cases rightLabel + all_goals simp [packing, fourChildrenPacking] at hleft hright + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hM (by simp; linarith)).trans htwoM + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hM + (by rw [hMdist])).trans htwoM + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hM + (by rw [dist_comm, hMdist])).trans htwoM + · exact (fourChildren_sameColorPair_le packing ⟨_, hleftMem⟩ ⟨_, hrightMem⟩ rfl + hM (by simp; linarith)).trans htwoM + apply le_antisymm + · unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + · let redLeft : packing.support := ⟨(.red, .left), by + simp [packing, fourChildrenPacking]⟩ + let redRight : packing.support := ⟨(.red, .right), by + simp [packing, fourChildrenPacking]⟩ + let blueLeft : packing.support := ⟨(.blue, .left), by + simp [packing, fourChildrenPacking]⟩ + let blueRight : packing.support := ⟨(.blue, .right), by + simp [packing, fourChildrenPacking]⟩ + have hdiameterL : 2 * L ≤ packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter redLeft redRight + rw [hredLeftRadius redLeft.property, hredRightRadius redRight.property, + hLdist] at hp + linarith + have hdiameterM : 2 * M ≤ packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter blueLeft blueRight + rw [hblueLeftRadius blueLeft.property, hblueRightRadius blueRight.property, + hMdist] at hp + linarith + have hdiameter11 : + dist (configuration .red .left) (configuration .blue .left) + x + y ≤ + packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter redLeft blueLeft + change dist (configuration .red .left) (configuration .blue .left) + + packing.radius redLeft + packing.radius blueLeft ≤ packing.virtualDiameter at hp + rw [hredLeftRadius redLeft.property, hblueLeftRadius blueLeft.property] at hp + exact hp + have hdiameter12 : + dist (configuration .red .left) (configuration .blue .right) + x + (M - y) ≤ + packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter redLeft blueRight + change dist (configuration .red .left) (configuration .blue .right) + + packing.radius redLeft + packing.radius blueRight ≤ packing.virtualDiameter at hp + rw [hredLeftRadius redLeft.property, hblueRightRadius blueRight.property] at hp + exact hp + have hdiameter21 : + dist (configuration .red .right) (configuration .blue .left) + (L - x) + y ≤ + packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter redRight blueLeft + change dist (configuration .red .right) (configuration .blue .left) + + packing.radius redRight + packing.radius blueLeft ≤ packing.virtualDiameter at hp + rw [hredRightRadius redRight.property, hblueLeftRadius blueLeft.property] at hp + exact hp + have hdiameter22 : + dist (configuration .red .right) (configuration .blue .right) + + (L - x) + (M - y) ≤ packing.virtualDiameter := by + have hp := packing.pair_le_virtualDiameter redRight blueRight + change dist (configuration .red .right) (configuration .blue .right) + + packing.radius redRight + packing.radius blueRight ≤ packing.virtualDiameter at hp + rw [hredRightRadius redRight.property, hblueRightRadius blueRight.property] at hp + exact hp + simp only [fourChildrenSplitDiameter, fourChildrenCrossMaximum, max_le_iff] + exact ⟨hdiameterL, hdiameterM, hdiameter11, hdiameter12, hdiameter21, hdiameter22⟩ + +/-- A split below `c(L+M)` gives the four-child packing nonnegative score at `c/2`. -/ +theorem fourChildrenPacking_score_nonnegative + (configuration : SixPointConfiguration) {c L M x y : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) + (hc : 0 < c) + (hdiameter : fourChildrenSplitDiameter L M x y + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .left) (configuration .blue .right)) + (dist (configuration .red .right) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) ≤ c * (L + M)) : + 0 ≤ (fourChildrenPacking configuration hLdist hMdist hL hx_lower hx_upper hM + hy_lower hy_upper).score (c / 2) := by + rw [SixPointPacking.score, + fourChildrenPacking_totalRadius configuration hLdist hMdist hL hx_lower hx_upper hM + hy_lower hy_upper, + fourChildrenPacking_virtualDiameter configuration hLdist hMdist hL hx_lower hx_upper hM + hy_lower hy_upper, + show 2 * (c / 2) = c by ring] + exact sub_nonneg.mpr ((div_le_iff₀ hc).2 (by simpa [mul_comm] using hdiameter)) + +/-- The routing bounds give a split whose four cross terms are all below the target. -/ +theorem exists_fourChildren_split_of_routing_bounds + {L M T B11 B12 B21 B22 : ℝ} (hL : L ≤ 2) (hM : M ≤ 2) + (h11 : L + M + B11 - 2 ≤ T) (h12 : L + M + B12 - 2 ≤ T) + (h21 : L + M + B21 - 2 ≤ T) (h22 : L + M + B22 - 2 ≤ T) + (hrow1 : L + M + L - 2 + B11 + B12 ≤ 2 * T) + (hrow2 : L + M + L - 2 + B21 + B22 ≤ 2 * T) + (hcolumn1 : L + M + M - 2 + B11 + B21 ≤ 2 * T) + (hcolumn2 : L + M + M - 2 + B12 + B22 ≤ 2 * T) + (hmatching1 : L + M + B11 + B22 ≤ 2 * T) + (hmatching2 : L + M + B12 + B21 ≤ 2 * T) : + ∃ x y : ℝ, L - 1 ≤ x ∧ x ≤ 1 ∧ M - 1 ≤ y ∧ y ≤ 1 ∧ + B11 + x + y ≤ T ∧ B12 + x + (M - y) ≤ T ∧ + B21 + (L - x) + y ≤ T ∧ B22 + (L - x) + (M - y) ≤ T := by + let lower1 := M - 1 - T + B21 + L + let lower2 := B22 + (L + M) - T - 1 + let lower3 := (B21 + B22 + (L + M) + L - 2 * T) / 2 + let x := max (L - 1) (max lower1 (max lower2 lower3)) + have hx_lower : L - 1 ≤ x := by + exact le_max_left _ _ + have hlower1 : lower1 ≤ x := by + exact le_max_of_le_right (le_max_left _ _) + have hlower2 : lower2 ≤ x := by + exact le_max_of_le_right (le_max_of_le_right (le_max_left _ _)) + have hlower3 : lower3 ≤ x := by + exact le_max_of_le_right (le_max_of_le_right (le_max_right _ _)) + dsimp only [lower1] at hlower1 + dsimp only [lower2] at hlower2 + dsimp only [lower3] at hlower3 + have hx_upper : x ≤ 1 := by + simp only [x, lower1, lower2, lower3, max_le_iff] + exact ⟨by linarith, by linarith, by linarith, by linarith⟩ + have hx_upper1 : x ≤ T - B11 - M + 1 := by + simp only [x, lower1, lower2, lower3, max_le_iff] + exact ⟨by linarith, by linarith, by linarith, by linarith⟩ + have hx_upper2 : x ≤ T - B12 - M + 1 := by + simp only [x, lower1, lower2, lower3, max_le_iff] + exact ⟨by linarith, by linarith, by linarith, by linarith⟩ + have hx_upper3' : x ≤ (2 * T - B11 - B12 - M) / 2 := by + simp only [x, lower1, lower2, lower3, max_le_iff] + exact ⟨by linarith, by linarith, by linarith, by linarith⟩ + have hx_upper3 : 2 * x ≤ 2 * T - B11 - B12 - M := by + linarith + let lowerY1 := B12 + x + M - T + let lowerY2 := B22 + (L + M) - x - T + let y := max (M - 1) (max lowerY1 lowerY2) + have hy_lower : M - 1 ≤ y := le_max_left _ _ + have hlowerY1 : lowerY1 ≤ y := le_max_of_le_right (le_max_left _ _) + have hlowerY2 : lowerY2 ≤ y := le_max_of_le_right (le_max_right _ _) + dsimp only [lowerY1] at hlowerY1 + dsimp only [lowerY2] at hlowerY2 + have hy_upper : y ≤ 1 := by + simp only [y, lowerY1, lowerY2, max_le_iff] + exact ⟨by linarith, by linarith, by linarith⟩ + have hy_upper1 : y ≤ T - B11 - x := by + simp only [y, lowerY1, lowerY2, max_le_iff] + exact ⟨by linarith, by linarith, by linarith⟩ + have hy_upper2 : y ≤ T - B21 - L + x := by + simp only [y, lowerY1, lowerY2, max_le_iff] + exact ⟨by linarith, by linarith, by linarith⟩ + exact ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, by linarith, by linarith, + by linarith, by linarith⟩ + +/-- Exact threshold form of the two-by-two split minimax formula. -/ +theorem exists_fourChildren_split_iff_routing_bounds + {L M T B11 B12 B21 B22 : ℝ} (hL : L ≤ 2) (hM : M ≤ 2) : + (∃ x y : ℝ, L - 1 ≤ x ∧ x ≤ 1 ∧ M - 1 ≤ y ∧ y ≤ 1 ∧ + fourChildrenSplitDiameter L M x y B11 B12 B21 B22 ≤ T) ↔ + 2 * L ≤ T ∧ 2 * M ≤ T ∧ + L + M + B11 - 2 ≤ T ∧ L + M + B12 - 2 ≤ T ∧ + L + M + B21 - 2 ≤ T ∧ L + M + B22 - 2 ≤ T ∧ + L + M + L - 2 + B11 + B12 ≤ 2 * T ∧ + L + M + L - 2 + B21 + B22 ≤ 2 * T ∧ + L + M + M - 2 + B11 + B21 ≤ 2 * T ∧ + L + M + M - 2 + B12 + B22 ≤ 2 * T ∧ + L + M + B11 + B22 ≤ 2 * T ∧ L + M + B12 + B21 ≤ 2 * T := by + constructor + · rintro ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, hdiameter⟩ + simp only [fourChildrenSplitDiameter, fourChildrenCrossMaximum, max_le_iff] + at hdiameter + rcases hdiameter with ⟨hsameL, hsameM, hd11, hd12, hd21, hd22⟩ + exact ⟨hsameL, hsameM, by linarith, by linarith, by linarith, by linarith, + by linarith, by linarith, by linarith, by linarith, by linarith, by linarith⟩ + · rintro ⟨hsameL, hsameM, h11, h12, h21, h22, hrow1, hrow2, hcolumn1, + hcolumn2, hmatching1, hmatching2⟩ + obtain ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, hd11, hd12, hd21, hd22⟩ := + exists_fourChildren_split_of_routing_bounds hL hM h11 h12 h21 h22 hrow1 hrow2 + hcolumn1 hcolumn2 hmatching1 hmatching2 + refine ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, ?_⟩ + simp only [fourChildrenSplitDiameter, fourChildrenCrossMaximum, max_le_iff] + exact ⟨hsameL, hsameM, hd11, hd12, hd21, hd22⟩ + +/-- Failure of every split forces a single, row, column, or matching routing term. -/ +theorem fourChildren_routing {L M T B11 B12 B21 B22 : ℝ} + (hL : L ≤ 2) (hM : M ≤ 2) (hsameL : 2 * L ≤ T) (hsameM : 2 * M ≤ T) + (hfail : ∀ x y : ℝ, L - 1 ≤ x → x ≤ 1 → M - 1 ≤ y → y ≤ 1 → + T < fourChildrenSplitDiameter L M x y B11 B12 B21 B22) : + T < L + M + B11 - 2 ∨ T < L + M + B12 - 2 ∨ + T < L + M + B21 - 2 ∨ T < L + M + B22 - 2 ∨ + 2 * T < L + M + L - 2 + B11 + B12 ∨ + 2 * T < L + M + L - 2 + B21 + B22 ∨ + 2 * T < L + M + M - 2 + B11 + B21 ∨ + 2 * T < L + M + M - 2 + B12 + B22 ∨ + 2 * T < L + M + B11 + B22 ∨ 2 * T < L + M + B12 + B21 := by + by_contra hroute + simp only [not_or, not_lt] at hroute + rcases hroute with ⟨h11, h12, h21, h22, hrow1, hrow2, hcolumn1, hcolumn2, + hmatching1, hmatching2⟩ + obtain ⟨x, y, hx_lower, hx_upper, hy_lower, hy_upper, hd11, hd12, hd21, hd22⟩ := + exists_fourChildren_split_of_routing_bounds hL hM h11 h12 h21 h22 hrow1 hrow2 + hcolumn1 hcolumn2 hmatching1 hmatching2 + have hdiameter : fourChildrenSplitDiameter L M x y B11 B12 B21 B22 ≤ T := by + simp only [fourChildrenSplitDiameter, fourChildrenCrossMaximum, max_le_iff] + exact ⟨hsameL, hsameM, hd11, hd12, hd21, hd22⟩ + exact (not_lt_of_ge hdiameter) (hfail x y hx_lower hx_upper hy_lower hy_upper) + +/-- In the endpoint range, four-child failure routes to a row, column, or matching. -/ +theorem fourChildren_row_column_or_matching + {c L M B11 B12 B21 B22 : ℝ} (hc_one : 1 < c) (hc_two : c ≤ 2) + (hcL : c ≤ L) (hcM : c ≤ M) (hL : L ≤ 2) (hM : M ≤ 2) + (hsame_gap : 0 < c * (c + 2) - 4) (hsingle_gap : 1 < 2 * c * (c - 1)) + (hB11 : B11 ≤ 3) (hB12 : B12 ≤ 3) (hB21 : B21 ≤ 3) (hB22 : B22 ≤ 3) + (hfail : ∀ x y : ℝ, L - 1 ≤ x → x ≤ 1 → M - 1 ≤ y → y ≤ 1 → + c * (L + M) < fourChildrenSplitDiameter L M x y B11 B12 B21 B22) : + 2 + 2 * (c - 1) * L + (2 * c - 1) * M ≤ B11 + B12 ∨ + 2 + 2 * (c - 1) * L + (2 * c - 1) * M ≤ B21 + B22 ∨ + 2 + (2 * c - 1) * L + 2 * (c - 1) * M ≤ B11 + B21 ∨ + 2 + (2 * c - 1) * L + 2 * (c - 1) * M ≤ B12 + B22 ∨ + (2 * c - 1) * (L + M) ≤ B11 + B22 ∨ + (2 * c - 1) * (L + M) ≤ B12 + B21 := by + have hc_nonneg : 0 ≤ c := by linarith + have hc_sub_two : c - 2 ≤ 0 := sub_nonpos.mpr hc_two + have hcM_mul : c * c ≤ c * M := mul_le_mul_of_nonneg_left hcM hc_nonneg + have hcL_mul : c * c ≤ c * L := mul_le_mul_of_nonneg_left hcL hc_nonneg + have hLpart : (c - 2) * 2 ≤ (c - 2) * L := mul_le_mul_of_nonpos_left hL hc_sub_two + have hMpart : (c - 2) * 2 ≤ (c - 2) * M := mul_le_mul_of_nonpos_left hM hc_sub_two + have hsameL : 2 * L < c * (L + M) := by nlinarith + have hsameM : 2 * M < c * (L + M) := by nlinarith + have hQ : 2 * c ≤ L + M := by linarith + have hc_sub_one : 0 ≤ c - 1 := sub_nonneg.mpr hc_one.le + have hQmul : (c - 1) * (2 * c) ≤ (c - 1) * (L + M) := + mul_le_mul_of_nonneg_left hQ hc_sub_one + have hsingle : 1 < (c - 1) * (L + M) := by nlinarith + have hs11 : L + M + B11 - 2 < c * (L + M) := by nlinarith + have hs12 : L + M + B12 - 2 < c * (L + M) := by nlinarith + have hs21 : L + M + B21 - 2 < c * (L + M) := by nlinarith + have hs22 : L + M + B22 - 2 < c * (L + M) := by nlinarith + rcases fourChildren_routing hL hM hsameL.le hsameM.le hfail with + h11 | h12 | h21 | h22 | hrow1 | hrow2 | hcolumn1 | hcolumn2 | hmatching1 | hmatching2 + · linarith + · linarith + · linarith + · linarith + · exact Or.inl (by nlinarith) + · exact Or.inr (Or.inl (by nlinarith)) + · exact Or.inr (Or.inr (Or.inl (by nlinarith))) + · exact Or.inr (Or.inr (Or.inr (Or.inl (by nlinarith)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl (by nlinarith))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (by nlinarith))))) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/GramCertificateCore.lean b/LeanPool/Besicovitch/SixPoint/GramCertificateCore.lean new file mode 100644 index 0000000000..318f33ae29 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/GramCertificateCore.lean @@ -0,0 +1,470 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.MatrixCorrections +public import LeanPool.Besicovitch.SixPoint.WeightedReduction +import Mathlib.Analysis.InnerProductSpace.GramMatrix +import Mathlib.Analysis.Matrix.Order + +/-! +# Local Gram certificates for the weighted six-point score + +The weighted pair score at the small rational weights `1/12` and `13/14` is a positive combination +of six norms minus two radial penalties. Replacing each norm by a quadratic tangent, each radial +penalty by a secant on a radius box, and adding two nonnegative separation multipliers turns the +score into a quadratic form in the five configuration vectors. A rank-three rational factor, +completed by elementary two-vector squares, dominates that form, so the score is bounded by an +explicit rational number depending only on the certificate. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- Indices of the five vectors in a six-point Gram certificate. -/ +abbrev Five := Fin 5 + +/-- Indices of the three rows in the rational Gram factor. -/ +abbrev Three := Fin 3 + +/-- The small rational weight on the coincident-endpoint slack. -/ +def gramLambda : ℝ := 1 / 12 + +/-- The small rational weight on the balanced root--edge slack. -/ +def gramMu : ℝ := 13 / 14 + +theorem gramLambda_pos : 0 < gramLambda := by norm_num [gramLambda] + +theorem gramMu_pos : 0 < gramMu := by norm_num [gramMu] + +/-- Half the first-child radial penalty at the small rational weights. -/ +def gramFirstPenalty : ℝ := weightedFirstPenalty barC gramLambda gramMu / 2 + +/-- Half the second-child radial penalty at the small rational weights. -/ +def gramSecondPenalty : ℝ := weightedSecondPenalty barC gramLambda gramMu / 2 + +theorem gramFirstPenalty_pos : 0 < gramFirstPenalty := by + norm_num [gramFirstPenalty, weightedFirstPenalty, gramLambda, gramMu, barC] + +theorem gramSecondPenalty_pos : 0 < gramSecondPenalty := by + norm_num [gramSecondPenalty, weightedSecondPenalty, gramLambda, gramMu, barC] + +/-- A local certificate on one rectangle of second-child radii. -/ +structure GramCertificate where + /-- Lower bound for the second red radius. -/ + pLower : ℚ + /-- Upper bound for the second red radius. -/ + pUpper : ℚ + /-- Lower bound for the second blue radius. -/ + wLower : ℚ + /-- Upper bound for the second blue radius. -/ + wUpper : ℚ + /-- Tangent parameter for `e - p₁ - w₁`. -/ + alpha₀ : ℚ + /-- Tangent parameter for `e - p₂ - w₂`. -/ + alpha₁ : ℚ + /-- Tangent parameter for `e - p₁`. -/ + alpha₂ : ℚ + /-- Tangent parameter for `e - w₁`. -/ + alpha₃ : ℚ + /-- Tangent parameter for `e - p₁ - w₂`. -/ + alpha₄ : ℚ + /-- Tangent parameter for `e - w₁ - p₂`. -/ + alpha₅ : ℚ + /-- Multiplier for the red separation constraint. -/ + etaP : ℚ + /-- Multiplier for the blue separation constraint. -/ + etaW : ℚ + /-- The rank-three rational Gram factor. -/ + factor : Fin 3 → Fin 5 → ℚ + +/-- Scale a table of integers by `10⁻⁴`. -/ +def tenThousandthFactor (entries : Fin 3 → Fin 5 → ℤ) : Fin 3 → Fin 5 → ℚ := + fun i j ↦ entries i j / 10000 + +/-- One rational Gram-factor row, cast to real coordinates. -/ +def factorRow (certificate : GramCertificate) (k : Three) : Five → ℝ := + fun i ↦ certificate.factor k i + +/-- The positive semidefinite Gram matrix represented by the three factor rows. -/ +def factorGram (certificate : GramCertificate) : Matrix Five Five ℝ := + ∑ k, Matrix.vecMulVec (factorRow certificate k) (factorRow certificate k) + +/-- The negated off-diagonal coefficients of the quadratic form. -/ +def targetOffDiagonal (certificate : GramCertificate) : Matrix Five Five ℝ := + !![0, certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄, + certificate.alpha₁ + certificate.alpha₅, + certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅, + certificate.alpha₁ + certificate.alpha₄; + certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄, 0, certificate.etaP, + -certificate.alpha₀, -certificate.alpha₄; + certificate.alpha₁ + certificate.alpha₅, certificate.etaP, 0, + -certificate.alpha₅, -certificate.alpha₁; + certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅, + -certificate.alpha₀, -certificate.alpha₅, 0, certificate.etaW; + certificate.alpha₁ + certificate.alpha₄, -certificate.alpha₄, -certificate.alpha₁, + certificate.etaW, 0] + +/-- The discrepancy between the target quadratic form and its rational Gram factor. -/ +def residual (certificate : GramCertificate) (i j : Five) : ℝ := + targetOffDiagonal certificate i j - factorGram certificate i j + +private def certificateMatrix (certificate : GramCertificate) : Matrix Five Five ℝ := + fivePairCompletion (factorGram certificate) (residual certificate) + +private theorem certificateMatrix_posSemidef (certificate : GramCertificate) : + (certificateMatrix certificate).PosSemidef := by + have hfactor : (factorGram certificate).PosSemidef := by + apply Matrix.posSemidef_sum + intro i _ + exact Matrix.posSemidef_vecMulVec_self_star (factorRow certificate i) + exact fivePairCompletion_posSemidef hfactor (residual certificate) + +private theorem factorGram_apply_comm (certificate : GramCertificate) (i j : Five) : + factorGram certificate i j = factorGram certificate j i := by + simp only [factorGram, Matrix.sum_apply, Matrix.vecMulVec_apply] + exact Finset.sum_congr rfl fun k _ ↦ mul_comm _ _ + +@[simp] private theorem factorGram_10 (certificate : GramCertificate) : + factorGram certificate 1 0 = factorGram certificate 0 1 := + factorGram_apply_comm certificate 1 0 + +@[simp] private theorem factorGram_20 (certificate : GramCertificate) : + factorGram certificate 2 0 = factorGram certificate 0 2 := + factorGram_apply_comm certificate 2 0 + +@[simp] private theorem factorGram_21 (certificate : GramCertificate) : + factorGram certificate 2 1 = factorGram certificate 1 2 := + factorGram_apply_comm certificate 2 1 + +@[simp] private theorem factorGram_30 (certificate : GramCertificate) : + factorGram certificate 3 0 = factorGram certificate 0 3 := + factorGram_apply_comm certificate 3 0 + +@[simp] private theorem factorGram_31 (certificate : GramCertificate) : + factorGram certificate 3 1 = factorGram certificate 1 3 := + factorGram_apply_comm certificate 3 1 + +@[simp] private theorem factorGram_32 (certificate : GramCertificate) : + factorGram certificate 3 2 = factorGram certificate 2 3 := + factorGram_apply_comm certificate 3 2 + +@[simp] private theorem factorGram_40 (certificate : GramCertificate) : + factorGram certificate 4 0 = factorGram certificate 0 4 := + factorGram_apply_comm certificate 4 0 + +@[simp] private theorem factorGram_41 (certificate : GramCertificate) : + factorGram certificate 4 1 = factorGram certificate 1 4 := + factorGram_apply_comm certificate 4 1 + +@[simp] private theorem factorGram_42 (certificate : GramCertificate) : + factorGram certificate 4 2 = factorGram certificate 2 4 := + factorGram_apply_comm certificate 4 2 + +@[simp] private theorem factorGram_43 (certificate : GramCertificate) : + factorGram certificate 4 3 = factorGram certificate 3 4 := + factorGram_apply_comm certificate 4 3 + +private theorem certificateMatrix_offDiagonal (certificate : GramCertificate) {i j : Five} + (hij : i ≠ j) : + certificateMatrix certificate i j = targetOffDiagonal certificate i j := by + fin_cases i <;> fin_cases j <;> + simp_all [certificateMatrix, fivePairCompletion, residual, targetOffDiagonal] + +/-- Diagonal entry 0 after adding the rank-one residual corrections. -/ +def diagonal₀ (certificate : GramCertificate) : ℝ := + factorGram certificate 0 0 + |residual certificate 0 1| + + |residual certificate 0 2| + |residual certificate 0 3| + |residual certificate 0 4| + +/-- Diagonal entry 1 after adding the rank-one residual corrections. -/ +def diagonal₁ (certificate : GramCertificate) : ℝ := + factorGram certificate 1 1 + |residual certificate 0 1| + + |residual certificate 1 2| + |residual certificate 1 3| + |residual certificate 1 4| + +/-- Diagonal entry 2 after adding the rank-one residual corrections. -/ +def diagonal₂ (certificate : GramCertificate) : ℝ := + factorGram certificate 2 2 + |residual certificate 0 2| + + |residual certificate 1 2| + |residual certificate 2 3| + |residual certificate 2 4| + +/-- Diagonal entry 3 after adding the rank-one residual corrections. -/ +def diagonal₃ (certificate : GramCertificate) : ℝ := + factorGram certificate 3 3 + |residual certificate 0 3| + + |residual certificate 1 3| + |residual certificate 2 3| + |residual certificate 3 4| + +/-- Diagonal entry 4 after adding the rank-one residual corrections. -/ +def diagonal₄ (certificate : GramCertificate) : ℝ := + factorGram certificate 4 4 + |residual certificate 0 4| + + |residual certificate 1 4| + |residual certificate 2 4| + |residual certificate 3 4| + +private theorem certificateMatrix_diagonal₀ (certificate : GramCertificate) : + certificateMatrix certificate 0 0 = diagonal₀ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₀] + +private theorem certificateMatrix_diagonal₁ (certificate : GramCertificate) : + certificateMatrix certificate 1 1 = diagonal₁ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₁] + +private theorem certificateMatrix_diagonal₂ (certificate : GramCertificate) : + certificateMatrix certificate 2 2 = diagonal₂ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₂] + +private theorem certificateMatrix_diagonal₃ (certificate : GramCertificate) : + certificateMatrix certificate 3 3 = diagonal₃ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₃] + +private theorem certificateMatrix_diagonal₄ (certificate : GramCertificate) : + certificateMatrix certificate 4 4 = diagonal₄ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₄] + +private theorem gram_sum_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : GramCertificate) (v : Five → E) : + 0 ≤ ∑ i, ∑ j, certificateMatrix certificate i j * ⟪v i, v j⟫_ℝ := by + exact matrix_inner_sum_nonneg (certificateMatrix_posSemidef certificate) v + +/-- The lower bound the separation forces on the first red radius. -/ +def redFirstLower (certificate : GramCertificate) : ℝ := barC - certificate.pUpper + +/-- The lower bound the separation forces on the first blue radius. -/ +def blueFirstLower (certificate : GramCertificate) : ℝ := barC - certificate.wUpper + +private theorem certificate_gram_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : GramCertificate) (e p₁ p₂ w₁ w₂ : E) : + 0 ≤ diagonal₀ certificate * ‖e‖ ^ 2 + + diagonal₁ certificate * ‖p₁‖ ^ 2 + + diagonal₂ certificate * ‖p₂‖ ^ 2 + + diagonal₃ certificate * ‖w₁‖ ^ 2 + + diagonal₄ certificate * ‖w₂‖ ^ 2 + + 2 * (certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄) * ⟪e, p₁⟫_ℝ + + 2 * (certificate.alpha₁ + certificate.alpha₅) * ⟪e, p₂⟫_ℝ + + 2 * (certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅) * ⟪e, w₁⟫_ℝ + + 2 * (certificate.alpha₁ + certificate.alpha₄) * ⟪e, w₂⟫_ℝ + + 2 * certificate.etaP * ⟪p₁, p₂⟫_ℝ - + 2 * certificate.alpha₀ * ⟪p₁, w₁⟫_ℝ - + 2 * certificate.alpha₄ * ⟪p₁, w₂⟫_ℝ - + 2 * certificate.alpha₅ * ⟪p₂, w₁⟫_ℝ - + 2 * certificate.alpha₁ * ⟪p₂, w₂⟫_ℝ + + 2 * certificate.etaW * ⟪w₁, w₂⟫_ℝ := by + let v : Five → E := ![e, p₁, p₂, w₁, w₂] + have h := gram_sum_nonneg certificate v + simp only [Fin.sum_univ_five, Fin.isValue, Matrix.cons_val_zero, Matrix.cons_val_one, + Matrix.cons_val, inner_self_eq_norm_sq_to_K, RCLike.ofReal_real_eq_id, id_eq, v] at h + rw [certificateMatrix_diagonal₀, certificateMatrix_diagonal₁, + certificateMatrix_diagonal₂, certificateMatrix_diagonal₃, + certificateMatrix_diagonal₄] at h + rw [certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 3)] at h + simp [targetOffDiagonal, real_inner_comm] at h + nlinarith + +/-- The balance of the root vector. -/ +def balance₀ (certificate : GramCertificate) : ℝ := + diagonal₀ certificate + certificate.alpha₀ + certificate.alpha₁ + certificate.alpha₂ + + certificate.alpha₃ + certificate.alpha₄ + certificate.alpha₅ + +/-- The balance of the first red vector. -/ +def balance₁ (certificate : GramCertificate) : ℝ := + diagonal₁ certificate + certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄ - + gramFirstPenalty / (redFirstLower certificate + 1) + certificate.etaP + +/-- The balance of the second red vector. -/ +def balance₂ (certificate : GramCertificate) : ℝ := + diagonal₂ certificate + certificate.alpha₁ + certificate.alpha₅ - + gramSecondPenalty / (certificate.pLower + certificate.pUpper) + certificate.etaP + +/-- The balance of the first blue vector. -/ +def balance₃ (certificate : GramCertificate) : ℝ := + diagonal₃ certificate + certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅ - + gramFirstPenalty / (blueFirstLower certificate + 1) + certificate.etaW + +/-- The balance of the second blue vector. -/ +def balance₄ (certificate : GramCertificate) : ℝ := + diagonal₄ certificate + certificate.alpha₁ + certificate.alpha₄ - + gramSecondPenalty / (certificate.wLower + certificate.wUpper) + certificate.etaW + +/-- The radius-box maximum of the diagonal form after the Gram corrections. -/ +def dualRadialBound (certificate : GramCertificate) : ℝ := + balance₀ certificate + + positivePart (balance₁ certificate) - + negativePart (balance₁ certificate) * redFirstLower certificate ^ 2 + + positivePart (balance₂ certificate) * certificate.pUpper ^ 2 - + negativePart (balance₂ certificate) * certificate.pLower ^ 2 + + positivePart (balance₃ certificate) - + negativePart (balance₃ certificate) * blueFirstLower certificate ^ 2 + + positivePart (balance₄ certificate) * certificate.wUpper ^ 2 - + negativePart (balance₄ certificate) * certificate.wLower ^ 2 - + (certificate.etaP + certificate.etaW) * barC ^ 2 + +/-- The exact rational upper bound the certificate proves for the weighted score. -/ +def GramCertificate.upperBound (certificate : GramCertificate) : ℝ := + -weightedConstantTerm barC gramLambda gramMu + + (1 + gramLambda) ^ 2 / (4 * certificate.alpha₀) + + 1 / (4 * certificate.alpha₁) + + (gramMu / 2) ^ 2 / (4 * certificate.alpha₂) + + (gramMu / 2) ^ 2 / (4 * certificate.alpha₃) + + (gramMu / 2) ^ 2 / (4 * certificate.alpha₄) + + (gramMu / 2) ^ 2 / (4 * certificate.alpha₅) - + gramFirstPenalty * redFirstLower certificate / (redFirstLower certificate + 1) - + gramSecondPenalty * certificate.pLower * certificate.pUpper / + (certificate.pLower + certificate.pUpper) - + gramFirstPenalty * blueFirstLower certificate / (blueFirstLower certificate + 1) - + gramSecondPenalty * certificate.wLower * certificate.wUpper / + (certificate.wLower + certificate.wUpper) + + dualRadialBound certificate + +/-- The arithmetic conditions making a certificate usable. -/ +def GramCertificate.Valid (certificate : GramCertificate) : Prop := + barC - 1 ≤ (certificate.pLower : ℝ) ∧ + (certificate.pLower : ℝ) ≤ certificate.pUpper ∧ (certificate.pUpper : ℝ) ≤ 1 ∧ + barC - 1 ≤ (certificate.wLower : ℝ) ∧ + (certificate.wLower : ℝ) ≤ certificate.wUpper ∧ (certificate.wUpper : ℝ) ≤ 1 ∧ + 0 < (certificate.alpha₀ : ℝ) ∧ 0 < (certificate.alpha₁ : ℝ) ∧ + 0 < (certificate.alpha₂ : ℝ) ∧ 0 < (certificate.alpha₃ : ℝ) ∧ + 0 < (certificate.alpha₄ : ℝ) ∧ 0 < (certificate.alpha₅ : ℝ) ∧ + 0 ≤ (certificate.etaP : ℝ) ∧ 0 ≤ (certificate.etaW : ℝ) ∧ + certificate.upperBound ≤ -(1 / 2000) + +private theorem certificate_dual_bound {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : GramCertificate) (hvalid : certificate.Valid) + (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hp₁Lower : redFirstLower certificate ≤ ‖p₁‖) + (hw₁Lower : blueFirstLower certificate ≤ ‖w₁‖) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) + (hpLower : (certificate.pLower : ℝ) ≤ ‖p₂‖) + (hpUpper : ‖p₂‖ ≤ certificate.pUpper) + (hwLower : (certificate.wLower : ℝ) ≤ ‖w₂‖) + (hwUpper : ‖w₂‖ ≤ certificate.wUpper) : + (certificate.alpha₀ + certificate.alpha₁ + certificate.alpha₂ + certificate.alpha₃ + + certificate.alpha₄ + certificate.alpha₅) * ‖e‖ ^ 2 + + (certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄ - + gramFirstPenalty / (redFirstLower certificate + 1)) * ‖p₁‖ ^ 2 + + (certificate.alpha₁ + certificate.alpha₅ - + gramSecondPenalty / (certificate.pLower + certificate.pUpper)) * ‖p₂‖ ^ 2 + + (certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅ - + gramFirstPenalty / (blueFirstLower certificate + 1)) * ‖w₁‖ ^ 2 + + (certificate.alpha₁ + certificate.alpha₄ - + gramSecondPenalty / (certificate.wLower + certificate.wUpper)) * ‖w₂‖ ^ 2 - + 2 * (certificate.alpha₀ + certificate.alpha₂ + certificate.alpha₄) * ⟪e, p₁⟫_ℝ - + 2 * (certificate.alpha₁ + certificate.alpha₅) * ⟪e, p₂⟫_ℝ - + 2 * (certificate.alpha₀ + certificate.alpha₃ + certificate.alpha₅) * ⟪e, w₁⟫_ℝ - + 2 * (certificate.alpha₁ + certificate.alpha₄) * ⟪e, w₂⟫_ℝ + + 2 * certificate.alpha₀ * ⟪p₁, w₁⟫_ℝ + + 2 * certificate.alpha₄ * ⟪p₁, w₂⟫_ℝ + + 2 * certificate.alpha₅ * ⟪p₂, w₁⟫_ℝ + + 2 * certificate.alpha₁ * ⟪p₂, w₂⟫_ℝ ≤ dualRadialBound certificate := by + obtain ⟨hpL1, hpLU, hpU1, hwL1, hwLU, hwU1, _, _, _, _, _, _, hetaP, hetaW, _⟩ := hvalid + have hbarC := one_lt_barC_and_barC_lt_two.1 + have hredLower : (0 : ℝ) ≤ redFirstLower certificate := by + simp only [redFirstLower]; linarith + have hblueLower : (0 : ℝ) ≤ blueFirstLower certificate := by + simp only [blueFirstLower]; linarith + have hpSum : (0 : ℝ) < certificate.pLower + certificate.pUpper := by linarith + have hwSum : (0 : ℝ) < certificate.wLower + certificate.wUpper := by linarith + have hpsepSq := (sq_le_sq₀ (by linarith) (norm_nonneg _)).2 hpsep + have hwsepSq := (sq_le_sq₀ (by linarith) (norm_nonneg _)).2 hwsep + rw [norm_sub_sq_real] at hpsepSq hwsepSq + have hb₀ := balance_mul_sq_le (a := balance₁ certificate) hredLower hp₁Lower hp₁ + have hb₁ := balance_mul_sq_le (a := balance₂ certificate) (by linarith) hpLower hpUpper + have hb₂ := balance_mul_sq_le (a := balance₃ certificate) hblueLower hw₁Lower hw₁ + have hb₃ := balance_mul_sq_le (a := balance₄ certificate) (by linarith) hwLower hwUpper + have hgram := certificate_gram_nonneg certificate e p₁ p₂ w₁ w₂ + simp only [dualRadialBound, balance₀, balance₁, balance₂, balance₃, + balance₄, he, one_pow] at hgram hb₀ hb₁ hb₂ hb₃ ⊢ + have hpsepWeighted := mul_le_mul_of_nonneg_left hpsepSq hetaP + have hwsepWeighted := mul_le_mul_of_nonneg_left hwsepSq hetaW + linarith only [hgram, hb₀, hb₁, hb₂, hb₃, hpsepWeighted, hwsepWeighted] + +/-- A valid certificate bounds the weighted pair score on its radius rectangle. -/ +theorem weightedPairScore_le_of_gramCertificate {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : GramCertificate) (hvalid : certificate.Valid) + (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) + (hpLower : (certificate.pLower : ℝ) ≤ ‖p₂‖) + (hpUpper : ‖p₂‖ ≤ certificate.pUpper) + (hwLower : (certificate.wLower : ℝ) ≤ ‖w₂‖) + (hwUpper : ‖w₂‖ ≤ certificate.wUpper) : + weightedPairScore e barC gramLambda gramMu p₁ p₂ w₁ w₂ ≤ -(1 / 2000) := by + obtain ⟨hpL1, hpLU, hpU1, hwL1, hwLU, hwU1, ha₀, ha₁, ha₂, ha₃, ha₄, ha₅, + hetaP, hetaW, hbound⟩ := hvalid + have hbarC := one_lt_barC_and_barC_lt_two.1 + have hpSum : (0 : ℝ) < certificate.pLower + certificate.pUpper := by linarith + have hwSum : (0 : ℝ) < certificate.wLower + certificate.wUpper := by linarith + -- the separation forces the first radii away from the origin + have hp₁Lower : redFirstLower certificate ≤ ‖p₁‖ := by + have := norm_sub_le p₁ p₂ + simp only [redFirstLower]; linarith + have hw₁Lower : blueFirstLower certificate ≤ ‖w₁‖ := by + have := norm_sub_le w₁ w₂ + simp only [blueFirstLower]; linarith + have hredLower : (0 : ℝ) ≤ redFirstLower certificate := by + simp only [redFirstLower]; linarith + have hblueLower : (0 : ℝ) ≤ blueFirstLower certificate := by + simp only [blueFirstLower]; linarith + have hdual := certificate_dual_bound certificate + ⟨hpL1, hpLU, hpU1, hwL1, hwLU, hwU1, ha₀, ha₁, ha₂, ha₃, ha₄, ha₅, hetaP, hetaW, + hbound⟩ e p₁ p₂ w₁ w₂ he hp₁ hw₁ hp₁Lower hw₁Lower hpsep hwsep hpLower + hpUpper hwLower hwUpper + -- six quadratic norm tangents + have ht₀ := weightedNorm_le_quadratic (e - p₁ - w₁) (1 + gramLambda) certificate.alpha₀ ha₀ + have ht₁ := weightedNorm_le_quadratic (e - p₂ - w₂) 1 certificate.alpha₁ ha₁ + have ht₂ := weightedNorm_le_quadratic (e - p₁) (gramMu / 2) certificate.alpha₂ ha₂ + have ht₃ := weightedNorm_le_quadratic (e - w₁) (gramMu / 2) certificate.alpha₃ ha₃ + have ht₄ := weightedNorm_le_quadratic (e - p₁ - w₂) (gramMu / 2) certificate.alpha₄ ha₄ + have ht₅ := weightedNorm_le_quadratic (e - w₁ - p₂) (gramMu / 2) certificate.alpha₅ ha₅ + rw [norm_sub_sub_sq e p₁ w₁] at ht₀ + rw [norm_sub_sub_sq e p₂ w₂] at ht₁ + rw [norm_sub_sq_real] at ht₂ ht₃ + rw [norm_sub_sub_sq e p₁ w₂] at ht₄ + rw [norm_sub_sub_sq e w₁ p₂] at ht₅ + have hcomm : ⟪w₁, p₂⟫_ℝ = ⟪p₂, w₁⟫_ℝ := real_inner_comm _ _ + -- four radial secants + have hr₀ := radial_secant (d := gramFirstPenalty) (l := redFirstLower certificate) (u := 1) + (r := ‖p₁‖) gramFirstPenalty_pos.le hp₁Lower hp₁ (by linarith) + have hr₁ := radial_secant (d := gramSecondPenalty) (l := certificate.pLower) + (u := certificate.pUpper) (r := ‖p₂‖) gramSecondPenalty_pos.le hpLower hpUpper hpSum + have hr₂ := radial_secant (d := gramFirstPenalty) (l := blueFirstLower certificate) (u := 1) + (r := ‖w₁‖) gramFirstPenalty_pos.le hw₁Lower hw₁ (by linarith) + have hr₃ := radial_secant (d := gramSecondPenalty) (l := certificate.wLower) + (u := certificate.wUpper) (r := ‖w₂‖) gramSecondPenalty_pos.le hwLower hwUpper hwSum + simp only [he, one_pow] at ht₀ ht₁ ht₂ ht₃ ht₄ ht₅ hdual + have hscore : weightedPairScore e barC gramLambda gramMu p₁ p₂ w₁ w₂ ≤ + certificate.upperBound := by + have htangent := add_le_add (add_le_add (add_le_add ht₀ ht₁) (add_le_add ht₂ ht₃)) + (add_le_add ht₄ ht₅) + have hradial := add_le_add (add_le_add hr₀ hr₁) (add_le_add hr₂ hr₃) + rw [hcomm] at htangent + simp only [weightedPairScore, GramCertificate.upperBound] at ⊢ + rw [show weightedFirstPenalty barC gramLambda gramMu / 2 = gramFirstPenalty from rfl, + show weightedSecondPenalty barC gramLambda gramMu / 2 = gramSecondPenalty from rfl] + ring_nf at htangent hradial hdual ⊢ + linarith only [htangent, hradial, hdual] + linarith [hscore, hbound] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/GramCertificateCover.lean b/LeanPool/Besicovitch/SixPoint/GramCertificateCover.lean new file mode 100644 index 0000000000..c1b8fd1784 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/GramCertificateCover.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.GramCertificateData + +/-! +# The finite cover of second-child radii + +Both second-child radii lie in `[barC - 1, 1]`. Eight bands cover that interval, and every +ordered pair of bands is contained in the radius rectangle of one stored certificate, after +swapping the two sibling pairs when the blue band precedes the red one. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Lower endpoints of the eight radius bands. -/ +def bandLower : Fin 8 → ℚ + | 0 => 967 / 2500 + | 1 => 1 / 2 + | 2 => 3 / 5 + | 3 => 13 / 20 + | 4 => 7 / 10 + | 5 => 3 / 4 + | 6 => 4 / 5 + | 7 => 9 / 10 + +/-- Upper endpoints of the eight radius bands. -/ +def bandUpper : Fin 8 → ℚ + | 0 => 1 / 2 + | 1 => 3 / 5 + | 2 => 13 / 20 + | 3 => 7 / 10 + | 4 => 3 / 4 + | 5 => 4 / 5 + | 6 => 9 / 10 + | 7 => 1 + +/-- The certificate covering a given ordered pair of bands. -/ +def bandCertificate : Fin 8 → Fin 8 → Fin 30 + | 0, 0 => 0 + | 0, 1 => 1 + | 0, 2 => 2 + | 0, 3 => 2 + | 0, 4 => 3 + | 0, 5 => 4 + | 0, 6 => 5 + | 0, 7 => 6 + | 1, 0 => 1 + | 1, 1 => 7 + | 1, 2 => 8 + | 1, 3 => 8 + | 1, 4 => 9 + | 1, 5 => 10 + | 1, 6 => 11 + | 1, 7 => 12 + | 2, 0 => 2 + | 2, 1 => 8 + | 2, 2 => 27 + | 2, 3 => 28 + | 2, 4 => 13 + | 2, 5 => 14 + | 2, 6 => 15 + | 2, 7 => 16 + | 3, 0 => 2 + | 3, 1 => 8 + | 3, 2 => 28 + | 3, 3 => 29 + | 3, 4 => 13 + | 3, 5 => 14 + | 3, 6 => 15 + | 3, 7 => 16 + | 4, 0 => 3 + | 4, 1 => 9 + | 4, 2 => 13 + | 4, 3 => 13 + | 4, 4 => 17 + | 4, 5 => 18 + | 4, 6 => 19 + | 4, 7 => 20 + | 5, 0 => 4 + | 5, 1 => 10 + | 5, 2 => 14 + | 5, 3 => 14 + | 5, 4 => 18 + | 5, 5 => 21 + | 5, 6 => 22 + | 5, 7 => 23 + | 6, 0 => 5 + | 6, 1 => 11 + | 6, 2 => 15 + | 6, 3 => 15 + | 6, 4 => 19 + | 6, 5 => 22 + | 6, 6 => 24 + | 6, 7 => 25 + | 7, 0 => 6 + | 7, 1 => 12 + | 7, 2 => 16 + | 7, 3 => 16 + | 7, 4 => 20 + | 7, 5 => 23 + | 7, 6 => 25 + | 7, 7 => 26 + +/-- Whether the covering certificate needs the two sibling pairs swapped. -/ +def bandSwapped : Fin 8 → Fin 8 → Bool + | 0, 0 => false + | 0, 1 => false + | 0, 2 => false + | 0, 3 => false + | 0, 4 => false + | 0, 5 => false + | 0, 6 => false + | 0, 7 => false + | 1, 0 => true + | 1, 1 => false + | 1, 2 => false + | 1, 3 => false + | 1, 4 => false + | 1, 5 => false + | 1, 6 => false + | 1, 7 => false + | 2, 0 => true + | 2, 1 => true + | 2, 2 => false + | 2, 3 => false + | 2, 4 => false + | 2, 5 => false + | 2, 6 => false + | 2, 7 => false + | 3, 0 => true + | 3, 1 => true + | 3, 2 => true + | 3, 3 => false + | 3, 4 => false + | 3, 5 => false + | 3, 6 => false + | 3, 7 => false + | 4, 0 => true + | 4, 1 => true + | 4, 2 => true + | 4, 3 => true + | 4, 4 => false + | 4, 5 => false + | 4, 6 => false + | 4, 7 => false + | 5, 0 => true + | 5, 1 => true + | 5, 2 => true + | 5, 3 => true + | 5, 4 => true + | 5, 5 => false + | 5, 6 => false + | 5, 7 => false + | 6, 0 => true + | 6, 1 => true + | 6, 2 => true + | 6, 3 => true + | 6, 4 => true + | 6, 5 => true + | 6, 6 => false + | 6, 7 => false + | 7, 0 => true + | 7, 1 => true + | 7, 2 => true + | 7, 3 => true + | 7, 4 => true + | 7, 5 => true + | 7, 6 => true + | 7, 7 => false + +/-- Every radius in range lies in one of the eight bands. -/ +theorem exists_band (x : ℝ) (h0 : barC - 1 ≤ x) (h1 : x ≤ 1) : + ∃ k : Fin 8, (bandLower k : ℝ) ≤ x ∧ x ≤ (bandUpper k : ℝ) := by + have hb : (barC : ℝ) - 1 = 967 / 2500 := by norm_num [barC] + rw [hb] at h0 + by_cases c0 : x ≤ 1 / 2 + · exact ⟨0, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c1 : x ≤ 3 / 5 + · exact ⟨1, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c2 : x ≤ 13 / 20 + · exact ⟨2, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c3 : x ≤ 7 / 10 + · exact ⟨3, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c4 : x ≤ 3 / 4 + · exact ⟨4, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c5 : x ≤ 4 / 5 + · exact ⟨5, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + by_cases c6 : x ≤ 9 / 10 + · exact ⟨6, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + · exact ⟨7, by norm_num [bandLower]; linarith, by norm_num [bandUpper]; linarith⟩ + +/-- The band pair is contained in the radius rectangle of its covering certificate. -/ +theorem bandCertificate_contains (k l : Fin 8) : + (if bandSwapped k l then + (gramCertificates (bandCertificate k l)).pLower ≤ bandLower l ∧ + bandUpper l ≤ (gramCertificates (bandCertificate k l)).pUpper ∧ + (gramCertificates (bandCertificate k l)).wLower ≤ bandLower k ∧ + bandUpper k ≤ (gramCertificates (bandCertificate k l)).wUpper + else + (gramCertificates (bandCertificate k l)).pLower ≤ bandLower k ∧ + bandUpper k ≤ (gramCertificates (bandCertificate k l)).pUpper ∧ + (gramCertificates (bandCertificate k l)).wLower ≤ bandLower l ∧ + bandUpper l ≤ (gramCertificates (bandCertificate k l)).wUpper) := by + fin_cases k <;> fin_cases l <;> + norm_num [bandCertificate, bandSwapped, bandLower, bandUpper] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/GramCertificateData.lean b/LeanPool/Besicovitch/SixPoint/GramCertificateData.lean new file mode 100644 index 0000000000..37c7b5953a --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/GramCertificateData.lean @@ -0,0 +1,829 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.GramCertificateCore + +/-! +# The thirty local Gram certificates + +The two second-child radii both lie in `[barC - 1, 1]`. Seven intervals cover that range, the +score is symmetric in the two sibling pairs, and the middle square is split once more, leaving +thirty ordered rectangles. This file records one certificate for each and checks its arithmetic. + +The tangent parameters, separation multipliers and factor entries were found numerically and are +stored as exact rationals with denominator `10000`; every inequality below is recomputed here. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- One local Gram certificate for each of the thirty radius rectangles. -/ +def gramCertificates : Fin 30 → GramCertificate := ![ + -- `I0xI0` + { pLower := 967/2500, pUpper := 1/2, wLower := 967/2500, wUpper := 1/2, + alpha₀ := 1880 / 10000, alpha₁ := 3752 / 10000, alpha₂ := 1215 / 10000, + alpha₃ := 1216 / 10000, alpha₄ := 1320 / 10000, alpha₅ := 1320 / 10000, + etaP := 8111 / 10000, etaW := 8110 / 10000, + factor := tenThousandthFactor ![ + ![-27, -6328, -8502, 6297, 8445], + ![-8122, -5410, -6221, -5463, -6269], + ![-15, -2916, 2178, 2918, -2168]] }, + -- `I0xI1` + { pLower := 967/2500, pUpper := 1/2, wLower := 1/2, wUpper := 3/5, + alpha₀ := 1883 / 10000, alpha₁ := 3370 / 10000, alpha₂ := 1216 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1219 / 10000, alpha₅ := 1323 / 10000, + etaP := 8277 / 10000, etaW := 5910 / 10000, + factor := tenThousandthFactor ![ + ![-4790, -8414, -10647, 1537, 2375], + ![-6984, -255, 450, -7546, -8088], + ![-390, -2835, 2364, 2762, -2019]] }, + -- `I0xI2` + { pLower := 967/2500, pUpper := 1/2, wLower := 3/5, wUpper := 7/10, + alpha₀ := 1884 / 10000, alpha₁ := 3152 / 10000, alpha₂ := 1217 / 10000, + alpha₃ := 1221 / 10000, alpha₄ := 1164 / 10000, alpha₅ := 1330 / 10000, + etaP := 8386 / 10000, etaW := 5005 / 10000, + factor := tenThousandthFactor ![ + ![-5134, -8463, -10670, 1032, 1692], + ![-6980, 352, 1216, -7344, -7267], + ![-595, -2790, 2462, 2697, -1878]] }, + -- `I0xI3` + { pLower := 967/2500, pUpper := 1/2, wLower := 7/10, wUpper := 3/4, + alpha₀ := 1882 / 10000, alpha₁ := 3007 / 10000, alpha₂ := 1214 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1121 / 10000, alpha₅ := 1328 / 10000, + etaP := 8437 / 10000, etaW := 4466 / 10000, + factor := tenThousandthFactor ![ + ![-5242, -8482, -10649, 851, 1437], + ![-7061, 592, 1522, -7166, -6736], + ![-688, -2747, 2498, 2680, -1807]] }, + -- `I0xI4` + { pLower := 967/2500, pUpper := 1/2, wLower := 3/4, wUpper := 4/5, + alpha₀ := 1881 / 10000, alpha₁ := 2919 / 10000, alpha₂ := 1215 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1096 / 10000, alpha₅ := 1327 / 10000, + etaP := 8482 / 10000, etaW := 4164 / 10000, + factor := tenThousandthFactor ![ + ![-5283, -8499, -10648, 772, 1319], + ![-7133, 704, 1670, -7056, -6421], + ![-746, -2721, 2519, 2676, -1754]] }, + -- `I0xI5` + { pLower := 967/2500, pUpper := 1/2, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1881 / 10000, alpha₁ := 2802 / 10000, alpha₂ := 1214 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1058 / 10000, alpha₅ := 1325 / 10000, + etaP := 8560 / 10000, etaW := 3771 / 10000, + factor := tenThousandthFactor ![ + ![-5319, -8527, -10663, 690, 1189], + ![-7259, 829, 1842, -6900, -6000], + ![-816, -2692, 2546, 2679, -1684]] }, + -- `I0xI6` + { pLower := 967/2500, pUpper := 1/2, wLower := 9/10, wUpper := 1, + alpha₀ := 1878 / 10000, alpha₁ := 2654 / 10000, alpha₂ := 1214 / 10000, + alpha₃ := 1215 / 10000, alpha₄ := 1010 / 10000, alpha₅ := 1323 / 10000, + etaP := 8668 / 10000, etaW := 3327 / 10000, + factor := tenThousandthFactor ![ + ![-5339, -8568, -10685, 617, 1062], + ![-7433, 950, 2017, -6708, -5503], + ![-889, -2647, 2563, 2691, -1597]] }, + -- `I1xI1` + { pLower := 1/2, pUpper := 3/5, wLower := 1/2, wUpper := 3/5, + alpha₀ := 1880 / 10000, alpha₁ := 3028 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1228 / 10000, alpha₅ := 1226 / 10000, + etaP := 6011 / 10000, etaW := 6021 / 10000, + factor := tenThousandthFactor ![ + ![-8767, -4877, -4791, -4989, -4916], + ![-80, -6070, -7028, 5985, 6939], + ![-9, -2613, 2262, 2606, -2242]] }, + -- `I1xI2` + { pLower := 1/2, pUpper := 3/5, wLower := 3/5, wUpper := 7/10, + alpha₀ := 1883 / 10000, alpha₁ := 2844 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1220 / 10000, alpha₄ := 1168 / 10000, alpha₅ := 1228 / 10000, + etaP := 6087 / 10000, etaW := 5081 / 10000, + factor := tenThousandthFactor ![ + ![-7475, -7386, -7796, -987, -379], + ![-4900, 2654, 3491, -7433, -7525], + ![-189, -2529, 2363, 2530, -2171]] }, + -- `I1xI3` + { pLower := 1/2, pUpper := 3/5, wLower := 7/10, wUpper := 3/4, + alpha₀ := 1888 / 10000, alpha₁ := 2726 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1126 / 10000, alpha₅ := 1225 / 10000, + etaP := 6131 / 10000, etaW := 4538 / 10000, + factor := tenThousandthFactor ![ + ![-7399, -7449, -7856, -822, -203], + ![-5234, 2589, 3414, -7263, -6948], + ![-310, -2482, 2438, 2498, -2105]] }, + -- `I1xI4` + { pLower := 1/2, pUpper := 3/5, wLower := 3/4, wUpper := 4/5, + alpha₀ := 1883 / 10000, alpha₁ := 2647 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1101 / 10000, alpha₅ := 1225 / 10000, + etaP := 6169 / 10000, etaW := 4234 / 10000, + factor := tenThousandthFactor ![ + ![-7348, -7483, -7886, -746, -127], + ![-5407, 2567, 3386, -7157, -6615], + ![-374, -2440, 2463, 2476, -2058]] }, + -- `I1xI5` + { pLower := 1/2, pUpper := 3/5, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1882 / 10000, alpha₁ := 2545 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1062 / 10000, alpha₅ := 1222 / 10000, + etaP := 6214 / 10000, etaW := 3841 / 10000, + factor := tenThousandthFactor ![ + ![-7332, -7503, -7905, -699, -80], + ![-5599, 2592, 3415, -7008, -6172], + ![-465, -2400, 2512, 2462, -1991]] }, + -- `I1xI6` + { pLower := 1/2, pUpper := 3/5, wLower := 9/10, wUpper := 1, + alpha₀ := 1880 / 10000, alpha₁ := 2426 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1216 / 10000, alpha₄ := 1015 / 10000, alpha₅ := 1219 / 10000, + etaP := 6292 / 10000, etaW := 3396 / 10000, + factor := tenThousandthFactor ![ + ![-7331, -7533, -7927, -658, -42], + ![-5824, 2639, 3474, -6817, -5673], + ![-556, -2341, 2544, 2465, -1922]] }, + -- `I2xI3` + { pLower := 3/5, pUpper := 7/10, wLower := 7/10, wUpper := 3/4, + alpha₀ := 1884 / 10000, alpha₁ := 2569 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1126 / 10000, alpha₅ := 1166 / 10000, + etaP := 5183 / 10000, etaW := 4591 / 10000, + factor := tenThousandthFactor ![ + ![-8941, -5867, -5484, -3194, -2519], + ![-2173, 4811, 5251, -6632, -6515], + ![-118, -2371, 2365, 2389, -2238]] }, + -- `I2xI4` + { pLower := 3/5, pUpper := 7/10, wLower := 3/4, wUpper := 4/5, + alpha₀ := 1884 / 10000, alpha₁ := 2500 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1100 / 10000, alpha₅ := 1165 / 10000, + etaP := 5209 / 10000, etaW := 4285 / 10000, + factor := tenThousandthFactor ![ + ![-8808, -6175, -5817, -2692, -1962], + ![-2882, 4447, 4902, -6734, -6349], + ![-189, -2333, 2410, 2364, -2195]] }, + -- `I2xI5` + { pLower := 3/5, pUpper := 7/10, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1883 / 10000, alpha₁ := 2407 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1062 / 10000, alpha₅ := 1162 / 10000, + etaP := 5254 / 10000, etaW := 3880 / 10000, + factor := tenThousandthFactor ![ + ![-8676, -6415, -6069, -2254, -1483], + ![-3526, 4155, 4618, -6727, -6021], + ![-279, -2274, 2454, 2349, -2148]] }, + -- `I2xI6` + { pLower := 3/5, pUpper := 7/10, wLower := 9/10, wUpper := 1, + alpha₀ := 1881 / 10000, alpha₁ := 2296 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1215 / 10000, alpha₄ := 1015 / 10000, alpha₅ := 1156 / 10000, + etaP := 5301 / 10000, etaW := 3441 / 10000, + factor := tenThousandthFactor ![ + ![-8592, -6558, -6218, -1951, -1149], + ![-4021, 3989, 4460, -6629, -5582], + ![-383, -2213, 2514, 2336, -2071]] }, + -- `I3xI3` + { pLower := 7/10, pUpper := 3/4, wLower := 7/10, wUpper := 3/4, + alpha₀ := 1884 / 10000, alpha₁ := 2465 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1125 / 10000, alpha₅ := 1124 / 10000, + etaP := 4632 / 10000, etaW := 4632 / 10000, + factor := tenThousandthFactor ![ + ![-9301, -4545, -3859, -4544, -3859], + ![0, -5841, -5846, 5841, 5846], + ![0, -2317, 2315, 2318, -2316]] }, + -- `I3xI4` + { pLower := 7/10, pUpper := 3/4, wLower := 3/4, wUpper := 4/5, + alpha₀ := 1883 / 10000, alpha₁ := 2402 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1098 / 10000, alpha₅ := 1123 / 10000, + etaP := 4657 / 10000, etaW := 4320 / 10000, + factor := tenThousandthFactor ![ + ![-9317, -5051, -4368, -3918, -3133], + ![-960, 5437, 5494, -6145, -5883], + ![-73, -2272, 2360, 2294, -2280]] }, + -- `I3xI5` + { pLower := 7/10, pUpper := 3/4, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1880 / 10000, alpha₁ := 2314 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1216 / 10000, alpha₄ := 1060 / 10000, alpha₅ := 1120 / 10000, + etaP := 4694 / 10000, etaW := 3916 / 10000, + factor := tenThousandthFactor ![ + ![-9262, -5488, -4808, -3293, -2427], + ![-1905, 5038, 5140, -6324, -5727], + ![-163, -2214, 2415, 2265, -2227]] }, + -- `I3xI6` + { pLower := 7/10, pUpper := 3/4, wLower := 9/10, wUpper := 1, + alpha₀ := 1880 / 10000, alpha₁ := 2211 / 10000, alpha₂ := 1217 / 10000, + alpha₃ := 1213 / 10000, alpha₄ := 1012 / 10000, alpha₅ := 1113 / 10000, + etaP := 4738 / 10000, etaW := 3471 / 10000, + factor := tenThousandthFactor ![ + ![-9193, -5776, -5097, -2813, -1888], + ![-2647, 4757, 4889, -6353, -5395], + ![-273, -2145, 2480, 2253, -2163]] }, + -- `I4xI4` + { pLower := 3/4, pUpper := 4/5, wLower := 3/4, wUpper := 4/5, + alpha₀ := 1885 / 10000, alpha₁ := 2344 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1095 / 10000, alpha₅ := 1096 / 10000, + etaP := 4341 / 10000, etaW := 4342 / 10000, + factor := tenThousandthFactor ![ + ![-9433, -4451, -3646, -4452, -3646], + ![1, 5797, 5595, -5797, -5594], + ![0, -2250, 2331, 2249, -2331]] }, + -- `I4xI5` + { pLower := 3/4, pUpper := 4/5, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1883 / 10000, alpha₁ := 2259 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1058 / 10000, alpha₅ := 1093 / 10000, + etaP := 4376 / 10000, etaW := 3939 / 10000, + factor := tenThousandthFactor ![ + ![-9464, -4949, -4127, -3808, -2895], + ![-1007, 5418, 5273, -6059, -5515], + ![-96, -2185, 2392, 2219, -2280]] }, + -- `I4xI6` + { pLower := 3/4, pUpper := 4/5, wLower := 9/10, wUpper := 1, + alpha₀ := 1880 / 10000, alpha₁ := 2159 / 10000, alpha₂ := 1218 / 10000, + alpha₃ := 1215 / 10000, alpha₄ := 1012 / 10000, alpha₅ := 1087 / 10000, + etaP := 4425 / 10000, etaW := 3487 / 10000, + factor := tenThousandthFactor ![ + ![-9449, -5313, -4474, -3261, -2274], + ![-1861, 5117, 5011, -6156, -5253], + ![-200, -2105, 2448, 2200, -2222]] }, + -- `I5xI5` + { pLower := 4/5, pUpper := 9/10, wLower := 4/5, wUpper := 9/10, + alpha₀ := 1882 / 10000, alpha₁ := 2180 / 10000, alpha₂ := 1217 / 10000, + alpha₃ := 1217 / 10000, alpha₄ := 1056 / 10000, alpha₅ := 1055 / 10000, + etaP := 3970 / 10000, etaW := 3969 / 10000, + factor := tenThousandthFactor ![ + ![-9605, -4327, -3370, -4324, -3368], + ![-2, 5736, 5258, -5737, -5259], + ![0, -2150, 2345, 2149, -2345]] }, + -- `I5xI6` + { pLower := 4/5, pUpper := 9/10, wLower := 9/10, wUpper := 1, + alpha₀ := 1881 / 10000, alpha₁ := 2086 / 10000, alpha₂ := 1217 / 10000, + alpha₃ := 1214 / 10000, alpha₄ := 1008 / 10000, alpha₅ := 1049 / 10000, + etaP := 4012 / 10000, etaW := 3517 / 10000, + factor := tenThousandthFactor ![ + ![-9667, -4734, -3741, -3758, -2701], + ![-905, 5453, 5025, -5906, -5061], + ![-108, -2067, 2414, 2126, -2292]] }, + -- `I6xI6` + { pLower := 9/10, pUpper := 1, wLower := 9/10, wUpper := 1, + alpha₀ := 1880 / 10000, alpha₁ := 1999 / 10000, alpha₂ := 1216 / 10000, + alpha₃ := 1216 / 10000, alpha₄ := 1003 / 10000, alpha₅ := 1003 / 10000, + etaP := 3557 / 10000, etaW := 3558 / 10000, + factor := tenThousandthFactor ![ + ![-9814, -4176, -3058, -4176, -3059], + ![0, 5666, 4873, -5666, -4873], + ![0, -2034, 2366, 2034, -2364]] }, + -- `I2aI2a` + { pLower := 3/5, pUpper := 13/20, wLower := 3/5, wUpper := 13/20, + alpha₀ := 1887 / 10000, alpha₁ := 2758 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1218 / 10000, alpha₄ := 1184 / 10000, alpha₅ := 1183 / 10000, + etaP := 5348 / 10000, etaW := 5350 / 10000, + factor := tenThousandthFactor ![ + ![-9010, -4741, -4351, -4780, -4399], + ![-32, -5966, -6453, 5933, 6430], + ![4, -2474, 2282, 2478, -2292]] }, + -- `I2aI2b` + { pLower := 3/5, pUpper := 13/20, wLower := 13/20, wUpper := 7/10, + alpha₀ := 1883 / 10000, alpha₁ := 2681 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1152 / 10000, alpha₅ := 1181 / 10000, + etaP := 5378 / 10000, etaW := 4933 / 10000, + factor := tenThousandthFactor ![ + ![-8827, -5954, -5696, -3245, -2657], + ![-2139, 4784, 5350, -6732, -6858], + ![-91, -2440, 2346, 2440, -2238]] }, + -- `I2bI2b` + { pLower := 13/20, pUpper := 7/10, wLower := 13/20, wUpper := 7/10, + alpha₀ := 1885 / 10000, alpha₁ := 2602 / 10000, alpha₂ := 1219 / 10000, + alpha₃ := 1219 / 10000, alpha₄ := 1153 / 10000, alpha₅ := 1154 / 10000, + etaP := 4960 / 10000, etaW := 4960 / 10000, + factor := tenThousandthFactor ![ + ![-9165, -4649, -4101, -4641, -4094], + ![-6, 5888, 6123, -5892, -6128], + ![2, -2395, 2302, 2391, -2301]] }] + +/-! ### Radius rectangles + +The four box endpoints of each stored certificate, for the cover argument. -/ + +@[simp] theorem gramCertificates_pLower_0 : + (gramCertificates 0).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_0 : + (gramCertificates 0).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_0 : + (gramCertificates 0).wLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_wUpper_0 : + (gramCertificates 0).wUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pLower_1 : + (gramCertificates 1).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_1 : + (gramCertificates 1).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_1 : + (gramCertificates 1).wLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wUpper_1 : + (gramCertificates 1).wUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_2 : + (gramCertificates 2).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_2 : + (gramCertificates 2).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_2 : + (gramCertificates 2).wLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_2 : + (gramCertificates 2).wUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_3 : + (gramCertificates 3).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_3 : + (gramCertificates 3).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_3 : + (gramCertificates 3).wLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_3 : + (gramCertificates 3).wUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pLower_4 : + (gramCertificates 4).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_4 : + (gramCertificates 4).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_4 : + (gramCertificates 4).wLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wUpper_4 : + (gramCertificates 4).wUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_5 : + (gramCertificates 5).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_5 : + (gramCertificates 5).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_5 : + (gramCertificates 5).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_5 : + (gramCertificates 5).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_6 : + (gramCertificates 6).pLower = 967 / 2500 := rfl + +@[simp] theorem gramCertificates_pUpper_6 : + (gramCertificates 6).pUpper = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wLower_6 : + (gramCertificates 6).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_6 : + (gramCertificates 6).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_7 : + (gramCertificates 7).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_7 : + (gramCertificates 7).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_7 : + (gramCertificates 7).wLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_wUpper_7 : + (gramCertificates 7).wUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_8 : + (gramCertificates 8).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_8 : + (gramCertificates 8).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_8 : + (gramCertificates 8).wLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_8 : + (gramCertificates 8).wUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_9 : + (gramCertificates 9).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_9 : + (gramCertificates 9).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_9 : + (gramCertificates 9).wLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_9 : + (gramCertificates 9).wUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pLower_10 : + (gramCertificates 10).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_10 : + (gramCertificates 10).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_10 : + (gramCertificates 10).wLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wUpper_10 : + (gramCertificates 10).wUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_11 : + (gramCertificates 11).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_11 : + (gramCertificates 11).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_11 : + (gramCertificates 11).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_11 : + (gramCertificates 11).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_12 : + (gramCertificates 12).pLower = 1 / 2 := rfl + +@[simp] theorem gramCertificates_pUpper_12 : + (gramCertificates 12).pUpper = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_12 : + (gramCertificates 12).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_12 : + (gramCertificates 12).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_13 : + (gramCertificates 13).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_13 : + (gramCertificates 13).pUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_13 : + (gramCertificates 13).wLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_13 : + (gramCertificates 13).wUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pLower_14 : + (gramCertificates 14).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_14 : + (gramCertificates 14).pUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_14 : + (gramCertificates 14).wLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wUpper_14 : + (gramCertificates 14).wUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_15 : + (gramCertificates 15).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_15 : + (gramCertificates 15).pUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_15 : + (gramCertificates 15).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_15 : + (gramCertificates 15).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_16 : + (gramCertificates 16).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_16 : + (gramCertificates 16).pUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_16 : + (gramCertificates 16).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_16 : + (gramCertificates 16).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_17 : + (gramCertificates 17).pLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pUpper_17 : + (gramCertificates 17).pUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wLower_17 : + (gramCertificates 17).wLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_17 : + (gramCertificates 17).wUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pLower_18 : + (gramCertificates 18).pLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pUpper_18 : + (gramCertificates 18).pUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wLower_18 : + (gramCertificates 18).wLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wUpper_18 : + (gramCertificates 18).wUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_19 : + (gramCertificates 19).pLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pUpper_19 : + (gramCertificates 19).pUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wLower_19 : + (gramCertificates 19).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_19 : + (gramCertificates 19).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_20 : + (gramCertificates 20).pLower = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pUpper_20 : + (gramCertificates 20).pUpper = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wLower_20 : + (gramCertificates 20).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_20 : + (gramCertificates 20).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_21 : + (gramCertificates 21).pLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pUpper_21 : + (gramCertificates 21).pUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_21 : + (gramCertificates 21).wLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_wUpper_21 : + (gramCertificates 21).wUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pLower_22 : + (gramCertificates 22).pLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pUpper_22 : + (gramCertificates 22).pUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_22 : + (gramCertificates 22).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_22 : + (gramCertificates 22).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_23 : + (gramCertificates 23).pLower = 3 / 4 := rfl + +@[simp] theorem gramCertificates_pUpper_23 : + (gramCertificates 23).pUpper = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wLower_23 : + (gramCertificates 23).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_23 : + (gramCertificates 23).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_24 : + (gramCertificates 24).pLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_24 : + (gramCertificates 24).pUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_24 : + (gramCertificates 24).wLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_24 : + (gramCertificates 24).wUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_25 : + (gramCertificates 25).pLower = 4 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_25 : + (gramCertificates 25).pUpper = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_25 : + (gramCertificates 25).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_25 : + (gramCertificates 25).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_26 : + (gramCertificates 26).pLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_pUpper_26 : + (gramCertificates 26).pUpper = 1 := rfl + +@[simp] theorem gramCertificates_wLower_26 : + (gramCertificates 26).wLower = 9 / 10 := rfl + +@[simp] theorem gramCertificates_wUpper_26 : + (gramCertificates 26).wUpper = 1 := rfl + +@[simp] theorem gramCertificates_pLower_27 : + (gramCertificates 27).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_27 : + (gramCertificates 27).pUpper = 13 / 20 := rfl + +@[simp] theorem gramCertificates_wLower_27 : + (gramCertificates 27).wLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_wUpper_27 : + (gramCertificates 27).wUpper = 13 / 20 := rfl + +@[simp] theorem gramCertificates_pLower_28 : + (gramCertificates 28).pLower = 3 / 5 := rfl + +@[simp] theorem gramCertificates_pUpper_28 : + (gramCertificates 28).pUpper = 13 / 20 := rfl + +@[simp] theorem gramCertificates_wLower_28 : + (gramCertificates 28).wLower = 13 / 20 := rfl + +@[simp] theorem gramCertificates_wUpper_28 : + (gramCertificates 28).wUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_pLower_29 : + (gramCertificates 29).pLower = 13 / 20 := rfl + +@[simp] theorem gramCertificates_pUpper_29 : + (gramCertificates 29).pUpper = 7 / 10 := rfl + +@[simp] theorem gramCertificates_wLower_29 : + (gramCertificates 29).wLower = 13 / 20 := rfl + +@[simp] theorem gramCertificates_wUpper_29 : + (gramCertificates 29).wUpper = 7 / 10 := rfl + + +local macro "verify_gram_certificate" : tactic => + `(tactic| norm_num [gramCertificates, GramCertificate.Valid, GramCertificate.upperBound, + dualRadialBound, balance₀, balance₁, balance₂, balance₃, balance₄, + diagonal₀, diagonal₁, diagonal₂, diagonal₃, diagonal₄, factorGram, factorRow, + Matrix.vecMulVec, residual, targetOffDiagonal, positivePart, negativePart, + redFirstLower, blueFirstLower, tenThousandthFactor, barC, gramLambda, gramMu, + gramFirstPenalty, gramSecondPenalty, weightedFirstPenalty, weightedSecondPenalty, + weightedConstantTerm, Fin.sum_univ_three, Matrix.cons_val_zero, Matrix.cons_val_one, + Matrix.cons_val_two, Matrix.cons_val_three, Matrix.cons_val_four, Matrix.head_cons]) + +/-- Arithmetic validation for certificate 0. -/ +theorem gramCertificates_valid_0 : (gramCertificates 0).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 1. -/ +theorem gramCertificates_valid_1 : (gramCertificates 1).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 2. -/ +theorem gramCertificates_valid_2 : (gramCertificates 2).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 3. -/ +theorem gramCertificates_valid_3 : (gramCertificates 3).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 4. -/ +theorem gramCertificates_valid_4 : (gramCertificates 4).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 5. -/ +theorem gramCertificates_valid_5 : (gramCertificates 5).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 6. -/ +theorem gramCertificates_valid_6 : (gramCertificates 6).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 7. -/ +theorem gramCertificates_valid_7 : (gramCertificates 7).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 8. -/ +theorem gramCertificates_valid_8 : (gramCertificates 8).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 9. -/ +theorem gramCertificates_valid_9 : (gramCertificates 9).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 10. -/ +theorem gramCertificates_valid_10 : (gramCertificates 10).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 11. -/ +theorem gramCertificates_valid_11 : (gramCertificates 11).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 12. -/ +theorem gramCertificates_valid_12 : (gramCertificates 12).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 13. -/ +theorem gramCertificates_valid_13 : (gramCertificates 13).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 14. -/ +theorem gramCertificates_valid_14 : (gramCertificates 14).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 15. -/ +theorem gramCertificates_valid_15 : (gramCertificates 15).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 16. -/ +theorem gramCertificates_valid_16 : (gramCertificates 16).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 17. -/ +theorem gramCertificates_valid_17 : (gramCertificates 17).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 18. -/ +theorem gramCertificates_valid_18 : (gramCertificates 18).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 19. -/ +theorem gramCertificates_valid_19 : (gramCertificates 19).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 20. -/ +theorem gramCertificates_valid_20 : (gramCertificates 20).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 21. -/ +theorem gramCertificates_valid_21 : (gramCertificates 21).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 22. -/ +theorem gramCertificates_valid_22 : (gramCertificates 22).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 23. -/ +theorem gramCertificates_valid_23 : (gramCertificates 23).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 24. -/ +theorem gramCertificates_valid_24 : (gramCertificates 24).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 25. -/ +theorem gramCertificates_valid_25 : (gramCertificates 25).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 26. -/ +theorem gramCertificates_valid_26 : (gramCertificates 26).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 27. -/ +theorem gramCertificates_valid_27 : (gramCertificates 27).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 28. -/ +theorem gramCertificates_valid_28 : (gramCertificates 28).Valid := by + verify_gram_certificate + +/-- Arithmetic validation for certificate 29. -/ +theorem gramCertificates_valid_29 : (gramCertificates 29).Valid := by + verify_gram_certificate + +/-- Every stored certificate satisfies its arithmetic side conditions. -/ +theorem gramCertificates_valid (i : Fin 30) : (gramCertificates i).Valid := by + fin_cases i + · exact gramCertificates_valid_0 + · exact gramCertificates_valid_1 + · exact gramCertificates_valid_2 + · exact gramCertificates_valid_3 + · exact gramCertificates_valid_4 + · exact gramCertificates_valid_5 + · exact gramCertificates_valid_6 + · exact gramCertificates_valid_7 + · exact gramCertificates_valid_8 + · exact gramCertificates_valid_9 + · exact gramCertificates_valid_10 + · exact gramCertificates_valid_11 + · exact gramCertificates_valid_12 + · exact gramCertificates_valid_13 + · exact gramCertificates_valid_14 + · exact gramCertificates_valid_15 + · exact gramCertificates_valid_16 + · exact gramCertificates_valid_17 + · exact gramCertificates_valid_18 + · exact gramCertificates_valid_19 + · exact gramCertificates_valid_20 + · exact gramCertificates_valid_21 + · exact gramCertificates_valid_22 + · exact gramCertificates_valid_23 + · exact gramCertificates_valid_24 + · exact gramCertificates_valid_25 + · exact gramCertificates_valid_26 + · exact gramCertificates_valid_27 + · exact gramCertificates_valid_28 + · exact gramCertificates_valid_29 + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/GramWeightedBound.lean b/LeanPool/Besicovitch/SixPoint/GramWeightedBound.lean new file mode 100644 index 0000000000..8e0fad7cae --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/GramWeightedBound.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.GramCertificateCover +public import LeanPool.Besicovitch.SixPoint.EndpointPacking + +/-! +# The coordinate-free weighted bound at the small rational weights + +Combining the local Gram certificates with the finite cover of second-child radii gives the +weighted geometric bound for every pair of separated sibling pairs in the unit ball. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- A separated sibling pair in the unit ball has its second radius in `[barC - 1, 1]`. -/ +private theorem second_radius_mem {E : Type*} [NormedAddCommGroup E] {p₁ p₂ : E} + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hsep : barC ≤ ‖p₁ - p₂‖) : + barC - 1 ≤ ‖p₂‖ ∧ ‖p₂‖ ≤ 1 := by + refine ⟨?_, hp₂⟩ + have := norm_sub_le p₁ p₂ + linarith + +/-- Every separated pair of sibling pairs in the unit ball has strictly negative weighted score. -/ +theorem weightedPairScore_le_of_separated {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + weightedPairScore e barC gramLambda gramMu p₁ p₂ w₁ w₂ ≤ -(1 / 2000) := by + obtain ⟨hpLow, hpHigh⟩ := second_radius_mem hp₁ hp₂ hpsep + obtain ⟨hwLow, hwHigh⟩ := second_radius_mem hw₁ hw₂ hwsep + obtain ⟨k, hk₀, hk₁⟩ := exists_band ‖p₂‖ hpLow hpHigh + obtain ⟨l, hl₀, hl₁⟩ := exists_band ‖w₂‖ hwLow hwHigh + have hcontains := bandCertificate_contains k l + set certificate := gramCertificates (bandCertificate k l) with hcert + have hvalid : certificate.Valid := gramCertificates_valid _ + by_cases hswap : bandSwapped k l = true + · rw [ite_eq_left hswap] at hcontains + obtain ⟨hpL, hpU, hwL, hwU⟩ := hcontains + rw [weightedPairScore_swap] + refine weightedPairScore_le_of_gramCertificate certificate hvalid e w₁ w₂ p₁ p₂ he + hw₁ hp₁ hwsep hpsep ?_ ?_ ?_ ?_ + · exact le_trans (by exact_mod_cast hpL) hl₀ + · exact le_trans hl₁ (by exact_mod_cast hpU) + · exact le_trans (by exact_mod_cast hwL) hk₀ + · exact le_trans hk₁ (by exact_mod_cast hwU) + · rw [ite_eq_right hswap] at hcontains + obtain ⟨hpL, hpU, hwL, hwU⟩ := hcontains + refine weightedPairScore_le_of_gramCertificate certificate hvalid e p₁ p₂ w₁ w₂ he + hp₁ hw₁ hpsep hwsep ?_ ?_ ?_ ?_ + · exact le_trans (by exact_mod_cast hpL) hk₀ + · exact le_trans hk₁ (by exact_mod_cast hpU) + · exact le_trans (by exact_mod_cast hwL) hl₀ + · exact le_trans hl₁ (by exact_mod_cast hwU) + +/-- The Gram certificates prove the weighted geometric bound at the small rational weights. -/ +theorem weightedGeometricBound_gram : WeightedGeometricBound gramLambda gramMu := by + intro e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ hpChord hwChord + have := weightedPairScore_le_of_separated e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ hpChord + hwChord + linarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/LensEndpointBalancedE0S0.lean b/LeanPool/Besicovitch/SixPoint/LensEndpointBalancedE0S0.lean new file mode 100644 index 0000000000..e4893f7d06 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/LensEndpointBalancedE0S0.lean @@ -0,0 +1,1020 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.MatrixCorrections +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger +import Mathlib.Analysis.InnerProductSpace.GramMatrix +import Mathlib.Analysis.Matrix.Order + +/-! +# The endpoint-balanced `E0/S0` lens inequality + +The positive distance terms are first replaced by quadratic norm tangents. The two second-child +radii are then divided into a small rational cover. On every rectangle, an explicit three-square +Gram majorant, corrected by elementary two-vector squares, proves the required strict bound. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +private abbrev Five := Fin 5 + +private abbrev Three := Fin 3 + +private def comparisonChord : ℝ := 6933 / 5000 + +private def redFirstPenalty : ℝ := 3 * (comparisonChord - 1) + +private def redSecondPenalty : ℝ := 3 * (comparisonChord + 1) + +private def blueFirstPenalty : ℝ := 9 / 2 * (comparisonChord - 1) + +private def blueSecondPenalty : ℝ := 9 / 2 * (comparisonChord + 1) + +private structure LensCertificate where + redLower : ℚ + redUpper : ℚ + blueLower : ℚ + blueUpper : ℚ + alpha₁₁ : ℚ + alpha₁₂ : ℚ + alpha₂₂ : ℚ + redSeparation : ℚ + blueSeparation : ℚ + factor : Three → Five → ℚ + +private def millionth (n : ℤ) : ℚ := n / 1000000 + +private def tenThousandthFactor (entries : Three → Five → ℤ) : Three → Five → ℚ := + fun i j ↦ entries i j / 10000 + +private def lensCertificates : Fin 28 → LensCertificate := ![ + { redLower := 3 / 8, redUpper := 17 / 32, blueLower := 17 / 32, + blueUpper := 11 / 16, alpha₁₁ := millionth 2890506, alpha₁₂ := millionth 741364, + alpha₂₂ := millionth 1740227, redSeparation := millionth 2610026, + blueSeparation := millionth 3088621, factor := tenThousandthFactor ![ + ![1819, 5355, -14521, -6987, 8937], + ![18915, -1699, 289, 22440, 15183], + ![-14886, -25903, -13097, 8243, 3714]] }, + { redLower := 3 / 8, redUpper := 17 / 32, blueLower := 11 / 16, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890526, alpha₁₂ := millionth 685572, + alpha₂₂ := millionth 1557844, redSeparation := millionth 2674058, + blueSeparation := millionth 2455362, factor := tenThousandthFactor ![ + ![2883, 4729, -14967, -6530, 8047], + ![16496, -7023, -2108, 22922, 12897], + ![-18229, -25224, -12820, 3853, 636]] }, + { redLower := 3 / 8, redUpper := 17 / 32, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888910, alpha₁₂ := millionth 636035, + alpha₂₂ := millionth 1415361, redSeparation := millionth 2739077, + blueSeparation := millionth 2019493, factor := tenThousandthFactor ![ + ![3562, 4247, -15198, -6410, 7294], + ![16378, -8330, -2662, 22473, 11054], + ![-18933, -25026, -12638, 2975, 100]] }, + { redLower := 3 / 8, redUpper := 11 / 16, blueLower := 3 / 8, + blueUpper := 17 / 32, alpha₁₁ := millionth 2888154, alpha₁₂ := millionth 802554, + alpha₂₂ := millionth 1845176, redSeparation := millionth 2096492, + blueSeparation := millionth 4126527, factor := tenThousandthFactor ![ + ![1216, -5449, 12634, 7692, -10525], + ![19867, 24129, 10515, -1989, 972], + ![-12893, 8041, 3083, -24739, -20031]] }, + { redLower := 17 / 32, redUpper := 39 / 64, blueLower := 11 / 16, + blueUpper := 49 / 64, alpha₁₁ := millionth 2890715, alpha₁₂ := millionth 699051, + alpha₂₂ := millionth 1478460, redSeparation := millionth 2076689, + blueSeparation := millionth 2589614, factor := tenThousandthFactor ![ + ![1098, 3719, -13437, -5799, 9155], + ![12308, -11547, -3390, 23612, 13196], + ![-21559, -23054, -9478, -224, -2100]] }, + { redLower := 17 / 32, redUpper := 39 / 64, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890329, alpha₁₂ := millionth 672867, + alpha₂₂ := millionth 1409783, redSeparation := millionth 2110108, + blueSeparation := millionth 2329345, factor := tenThousandthFactor ![ + ![1575, 3405, -13606, -5619, 8740], + ![13050, -11276, -3156, 23316, 12118], + ![-21385, -23293, -9520, 300, -1700]] }, + { redLower := 17 / 32, redUpper := 39 / 64, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888957, alpha₁₂ := millionth 636683, + alpha₂₂ := millionth 1320165, redSeparation := millionth 2160931, + blueSeparation := millionth 2014317, factor := tenThousandthFactor ![ + ![2143, 3005, -13776, -5489, 8179], + ![13591, -11381, -3093, 22909, 10785], + ![-21416, -23384, -9506, 500, -1475]] }, + { redLower := 17 / 32, redUpper := 11 / 16, blueLower := 17 / 32, + blueUpper := 39 / 64, alpha₁₁ := millionth 2890043, alpha₁₂ := millionth 757466, + alpha₂₂ := millionth 1599317, redSeparation := millionth 1851458, + blueSeparation := millionth 3329045, factor := tenThousandthFactor ![ + ![694, -4320, 12397, 6363, -10337], + ![17975, 24958, 9362, -5826, -1583], + ![-16468, 4911, 1029, -23640, -16474]] }, + { redLower := 17 / 32, redUpper := 11 / 16, blueLower := 39 / 64, + blueUpper := 11 / 16, alpha₁₁ := millionth 2890674, alpha₁₂ := millionth 726523, + alpha₂₂ := millionth 1510374, redSeparation := millionth 1880532, + blueSeparation := millionth 2908577, factor := tenThousandthFactor ![ + ![60, 3849, -12703, -5873, 9861], + ![426, 21194, 7118, -20718, -11445], + ![-24677, -14283, -6029, -12086, -9238]] }, + { redLower := 39 / 64, redUpper := 11 / 16, blueLower := 11 / 16, + blueUpper := 49 / 64, alpha₁₁ := millionth 2890627, alpha₁₂ := millionth 698596, + alpha₂₂ := millionth 1404137, redSeparation := millionth 1790421, + blueSeparation := millionth 2594204, factor := tenThousandthFactor ![ + ![314, 3316, -12524, -5394, 9616], + ![7405, -15990, -4516, 23177, 12391], + ![-23890, -19937, -7442, -4986, -4834]] }, + { redLower := 39 / 64, redUpper := 11 / 16, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890214, alpha₁₂ := millionth 672530, + alpha₂₂ := millionth 1341186, redSeparation := millionth 1820424, + blueSeparation := millionth 2332636, factor := tenThousandthFactor ![ + ![804, 2976, -12686, -5183, 9205], + ![10103, -14061, -3669, 23282, 11717], + ![-23126, -21445, -7843, -2507, -3269]] }, + { redLower := 39 / 64, redUpper := 11 / 16, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888950, alpha₁₂ := millionth 636503, + alpha₂₂ := millionth 1258997, redSeparation := millionth 1867383, + blueSeparation := millionth 2015753, factor := tenThousandthFactor ![ + ![1399, 2541, -12852, -5017, 8646], + ![11507, -13342, -3285, 22979, 10511], + ![-22803, -22037, -7967, -1381, -2478]] }, + { redLower := 11 / 16, redUpper := 93 / 128, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890244, alpha₁₂ := millionth 672089, + alpha₂₂ := millionth 1298911, redSeparation := millionth 1662157, + blueSeparation := millionth 2336817, factor := tenThousandthFactor ![ + ![380, 2799, -12132, -4941, 9461], + ![8100, -15708, -3899, 23062, 11366], + ![-24015, -20087, -6916, -4334, -4224]] }, + { redLower := 11 / 16, redUpper := 49 / 64, blueLower := 39 / 64, + blueUpper := 11 / 16, alpha₁₁ := millionth 2890577, alpha₁₂ := millionth 725524, + alpha₂₂ := millionth 1409255, redSeparation := millionth 1559772, + blueSeparation := millionth 2920064, factor := tenThousandthFactor ![ + ![844, -3525, 11590, 5444, -10380], + ![9191, 24556, 7344, -15494, -7519], + ![-23152, -5999, -2749, -18438, -12584]] }, + { redLower := 11 / 16, redUpper := 49 / 64, blueLower := 11 / 16, + blueUpper := 93 / 128, alpha₁₁ := millionth 2890648, alpha₁₂ := millionth 704649, + alpha₂₂ := millionth 1359487, redSeparation := millionth 1579603, + blueSeparation := millionth 2675037, factor := tenThousandthFactor ![ + ![387, -3211, 11753, 5173, -10054], + ![830, -20393, -5591, 21290, 10961], + ![-25084, -15057, -5424, -10740, -8021]] }, + { redLower := 11 / 16, redUpper := 49 / 64, blueLower := 93 / 128, + blueUpper := 49 / 64, alpha₁₁ := millionth 2890553, alpha₁₂ := millionth 691258, + alpha₂₂ := millionth 1328595, redSeparation := millionth 1593341, + blueSeparation := millionth 2531027, factor := tenThousandthFactor ![ + ![114, -3019, 11844, 5031, -9843], + ![4630, -18070, -4692, 22498, 11449], + ![-24785, -17841, -6182, -7437, -6056]] }, + { redLower := 11 / 16, redUpper := 49 / 64, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888899, alpha₁₂ := millionth 635992, + alpha₂₂ := millionth 1208968, redSeparation := millionth 1658631, + blueSeparation := millionth 2020063, factor := tenThousandthFactor ![ + ![864, 2297, -12122, -4676, 8981], + ![9735, -14826, -3364, 22900, 10238], + ![-23761, -20825, -6907, -2946, -3244]] }, + { redLower := 11 / 16, redUpper := 27 / 32, blueLower := 17 / 32, + blueUpper := 39 / 64, alpha₁₁ := millionth 2889781, alpha₁₂ := millionth 756524, + alpha₂₂ := millionth 1455451, redSeparation := millionth 1447399, + blueSeparation := millionth 3357122, factor := tenThousandthFactor ![ + ![1869, -4000, 10966, 5885, -10988], + ![17273, 24865, 7546, -7627, -2669], + ![-17617, 3258, 300, -23258, -16339]] }, + { redLower := 11 / 16, redUpper := 1, blueLower := 3 / 8, + blueUpper := 17 / 32, alpha₁₁ := millionth 2887389, alpha₁₂ := millionth 800698, + alpha₂₂ := millionth 1505942, redSeparation := millionth 1270742, + blueSeparation := millionth 4192122, factor := tenThousandthFactor ![ + ![3645, -4876, 9822, 6921, -11762], + ![19553, 24033, 6933, -4683, -868], + ![-14413, 5782, 1441, -24635, -20156]] }, + { redLower := 93 / 128, redUpper := 49 / 64, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890160, alpha₁₂ := millionth 671737, + alpha₂₂ := millionth 1272329, redSeparation := millionth 1569159, + blueSeparation := millionth 2340282, factor := tenThousandthFactor ![ + ![131, 2717, -11791, -4797, 9612], + ![6838, -16654, -3996, 22852, 11117], + ![-24475, -19192, -6378, -5450, -4786]] }, + { redLower := 49 / 64, redUpper := 27 / 32, blueLower := 39 / 64, + blueUpper := 11 / 16, alpha₁₁ := millionth 2890443, alpha₁₂ := millionth 724599, + alpha₂₂ := millionth 1349809, redSeparation := millionth 1393656, + blueSeparation := millionth 2930837, factor := tenThousandthFactor ![ + ![1311, -3436, 10958, 5212, -10647], + ![10634, 24698, 6771, -14535, -6807], + ![-22672, -4560, -2144, -19265, -12958]] }, + { redLower := 49 / 64, redUpper := 27 / 32, blueLower := 11 / 16, + blueUpper := 49 / 64, alpha₁₁ := millionth 2890494, alpha₁₂ := millionth 697000, + alpha₂₂ := millionth 1289028, redSeparation := millionth 1418570, + blueSeparation := millionth 2610671, factor := tenThousandthFactor ![ + ![710, -3007, 11164, 4847, -10219], + ![-263, -20923, -5207, 20851, 10341], + ![-25285, -14055, -4730, -11513, -8249]] }, + { redLower := 49 / 64, redUpper := 27 / 32, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2890126, alpha₁₂ := millionth 671071, + alpha₂₂ := millionth 1234650, redSeparation := millionth 1444940, + blueSeparation := millionth 2346630, factor := tenThousandthFactor ![ + ![204, -2634, 11319, 4600, -9812], + ![5122, -17829, -4063, 22488, 10748], + ![-24987, -17928, -5682, -6920, -5504]] }, + { redLower := 49 / 64, redUpper := 27 / 32, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888793, alpha₁₂ := millionth 635251, + alpha₂₂ := millionth 1163098, redSeparation := millionth 1486455, + blueSeparation := millionth 2026651, factor := tenThousandthFactor ![ + ![419, 2157, -11480, -4387, 9256], + ![8138, -16031, -3368, 22732, 9966], + ![-24483, -19686, -6066, -4318, -3874]] }, + { redLower := 27 / 32, redUpper := 1, blueLower := 17 / 32, + blueUpper := 11 / 16, alpha₁₁ := millionth 2889918, alpha₁₂ := millionth 737429, + alpha₂₂ := millionth 1300581, redSeparation := millionth 1182097, + blueSeparation := millionth 3138952, factor := tenThousandthFactor ![ + ![2217, -3663, 10032, 5168, -11170], + ![14771, 24847, 6230, -11034, -4727], + ![-20284, -189, -778, -21717, -14710]] }, + { redLower := 27 / 32, redUpper := 1, blueLower := 11 / 16, + blueUpper := 49 / 64, alpha₁₁ := millionth 2890275, alpha₁₂ := millionth 695389, + alpha₂₂ := millionth 1215912, redSeparation := millionth 1215199, + blueSeparation := millionth 2628085, factor := tenThousandthFactor ![ + ![1271, -2964, 10353, 4526, -10537], + ![3252, 22189, 4968, -19530, -9358], + ![-25257, -11489, -3654, -13730, -9303]] }, + { redLower := 27 / 32, redUpper := 1, blueLower := 49 / 64, + blueUpper := 27 / 32, alpha₁₁ := millionth 2889921, alpha₁₂ := millionth 669445, + alpha₂₂ := millionth 1166568, redSeparation := millionth 1239233, + blueSeparation := millionth 2362262, factor := tenThousandthFactor ![ + ![760, -2574, 10504, 4258, -10134], + ![2413, -19429, -3999, 21746, 10108], + ![-25567, -15832, -4628, -9124, -6529]] }, + { redLower := 27 / 32, redUpper := 1, blueLower := 27 / 32, + blueUpper := 1, alpha₁₁ := millionth 2888619, alpha₁₂ := millionth 633708, + alpha₂₂ := millionth 1101333, redSeparation := millionth 1277300, + blueSeparation := millionth 2039948, factor := tenThousandthFactor ![ + ![128, -2073, 10661, 4020, -9581], + ![6137, -17374, -3275, 22407, 9598], + ![-25233, -18195, -5107, -5978, -4590]] } +] + +private structure LensBox where + redLower : ℚ + redUpper : ℚ + blueLower : ℚ + blueUpper : ℚ + +private def lensBox (i : Fin 28) : LensBox := + match i.val with + | 0 => ⟨3 / 8, 17 / 32, 17 / 32, 11 / 16⟩ + | 1 => ⟨3 / 8, 17 / 32, 11 / 16, 27 / 32⟩ + | 2 => ⟨3 / 8, 17 / 32, 27 / 32, 1⟩ + | 3 => ⟨3 / 8, 11 / 16, 3 / 8, 17 / 32⟩ + | 4 => ⟨17 / 32, 39 / 64, 11 / 16, 49 / 64⟩ + | 5 => ⟨17 / 32, 39 / 64, 49 / 64, 27 / 32⟩ + | 6 => ⟨17 / 32, 39 / 64, 27 / 32, 1⟩ + | 7 => ⟨17 / 32, 11 / 16, 17 / 32, 39 / 64⟩ + | 8 => ⟨17 / 32, 11 / 16, 39 / 64, 11 / 16⟩ + | 9 => ⟨39 / 64, 11 / 16, 11 / 16, 49 / 64⟩ + | 10 => ⟨39 / 64, 11 / 16, 49 / 64, 27 / 32⟩ + | 11 => ⟨39 / 64, 11 / 16, 27 / 32, 1⟩ + | 12 => ⟨11 / 16, 93 / 128, 49 / 64, 27 / 32⟩ + | 13 => ⟨11 / 16, 49 / 64, 39 / 64, 11 / 16⟩ + | 14 => ⟨11 / 16, 49 / 64, 11 / 16, 93 / 128⟩ + | 15 => ⟨11 / 16, 49 / 64, 93 / 128, 49 / 64⟩ + | 16 => ⟨11 / 16, 49 / 64, 27 / 32, 1⟩ + | 17 => ⟨11 / 16, 27 / 32, 17 / 32, 39 / 64⟩ + | 18 => ⟨11 / 16, 1, 3 / 8, 17 / 32⟩ + | 19 => ⟨93 / 128, 49 / 64, 49 / 64, 27 / 32⟩ + | 20 => ⟨49 / 64, 27 / 32, 39 / 64, 11 / 16⟩ + | 21 => ⟨49 / 64, 27 / 32, 11 / 16, 49 / 64⟩ + | 22 => ⟨49 / 64, 27 / 32, 49 / 64, 27 / 32⟩ + | 23 => ⟨49 / 64, 27 / 32, 27 / 32, 1⟩ + | 24 => ⟨27 / 32, 1, 17 / 32, 11 / 16⟩ + | 25 => ⟨27 / 32, 1, 11 / 16, 49 / 64⟩ + | 26 => ⟨27 / 32, 1, 49 / 64, 27 / 32⟩ + | 27 => ⟨27 / 32, 1, 27 / 32, 1⟩ + | _ => ⟨27 / 32, 1, 27 / 32, 1⟩ + + +private def factorRow (certificate : LensCertificate) (k : Three) : Five → ℝ := + fun i ↦ certificate.factor k i + +private def factorGram (certificate : LensCertificate) : Matrix Five Five ℝ := + ∑ k, Matrix.vecMulVec (factorRow certificate k) (factorRow certificate k) + +private def targetOffDiagonal (certificate : LensCertificate) : Matrix Five Five ℝ := + !![0, certificate.alpha₁₁ + certificate.alpha₁₂, certificate.alpha₂₂, + certificate.alpha₁₁, certificate.alpha₁₂ + certificate.alpha₂₂; + certificate.alpha₁₁ + certificate.alpha₁₂, 0, certificate.redSeparation, + -certificate.alpha₁₁, -certificate.alpha₁₂; + certificate.alpha₂₂, certificate.redSeparation, 0, 0, + -certificate.alpha₂₂; + certificate.alpha₁₁, -certificate.alpha₁₁, 0, 0, + certificate.blueSeparation; + certificate.alpha₁₂ + certificate.alpha₂₂, + -certificate.alpha₁₂, -certificate.alpha₂₂, + certificate.blueSeparation, 0] + +private def residual (certificate : LensCertificate) (i j : Five) : ℝ := + targetOffDiagonal certificate i j - factorGram certificate i j + +private def certificateMatrix (certificate : LensCertificate) : Matrix Five Five ℝ := + fivePairCompletion (factorGram certificate + (1 / 1000000 : ℝ) • 1) (residual certificate) + +private theorem certificateMatrix_posSemidef (certificate : LensCertificate) : + (certificateMatrix certificate).PosSemidef := by + have hfactor : (factorGram certificate).PosSemidef := by + apply Matrix.posSemidef_sum + intro i _ + exact Matrix.posSemidef_vecMulVec_self_star (factorRow certificate i) + have hepsilon : ((1 / 1000000 : ℝ) • (1 : Matrix Five Five ℝ)).PosSemidef := + Matrix.PosSemidef.one.smul (by norm_num) + exact fivePairCompletion_posSemidef (hfactor.add hepsilon) (residual certificate) + +private theorem factorGram_apply_comm (certificate : LensCertificate) (i j : Five) : + factorGram certificate i j = factorGram certificate j i := by + simp only [factorGram, Matrix.sum_apply, Matrix.vecMulVec_apply] + congr 1 + funext k + ring + +@[simp] private theorem factorGram_10 (certificate : LensCertificate) : + factorGram certificate 1 0 = factorGram certificate 0 1 := + factorGram_apply_comm certificate 1 0 + +@[simp] private theorem factorGram_20 (certificate : LensCertificate) : + factorGram certificate 2 0 = factorGram certificate 0 2 := + factorGram_apply_comm certificate 2 0 + +@[simp] private theorem factorGram_21 (certificate : LensCertificate) : + factorGram certificate 2 1 = factorGram certificate 1 2 := + factorGram_apply_comm certificate 2 1 + +@[simp] private theorem factorGram_30 (certificate : LensCertificate) : + factorGram certificate 3 0 = factorGram certificate 0 3 := + factorGram_apply_comm certificate 3 0 + +@[simp] private theorem factorGram_31 (certificate : LensCertificate) : + factorGram certificate 3 1 = factorGram certificate 1 3 := + factorGram_apply_comm certificate 3 1 + +@[simp] private theorem factorGram_32 (certificate : LensCertificate) : + factorGram certificate 3 2 = factorGram certificate 2 3 := + factorGram_apply_comm certificate 3 2 + +@[simp] private theorem factorGram_40 (certificate : LensCertificate) : + factorGram certificate 4 0 = factorGram certificate 0 4 := + factorGram_apply_comm certificate 4 0 + +@[simp] private theorem factorGram_41 (certificate : LensCertificate) : + factorGram certificate 4 1 = factorGram certificate 1 4 := + factorGram_apply_comm certificate 4 1 + +@[simp] private theorem factorGram_42 (certificate : LensCertificate) : + factorGram certificate 4 2 = factorGram certificate 2 4 := + factorGram_apply_comm certificate 4 2 + +@[simp] private theorem factorGram_43 (certificate : LensCertificate) : + factorGram certificate 4 3 = factorGram certificate 3 4 := + factorGram_apply_comm certificate 4 3 + +private theorem certificateMatrix_offDiagonal (certificate : LensCertificate) {i j : Five} + (hij : i ≠ j) : + certificateMatrix certificate i j = targetOffDiagonal certificate i j := by + fin_cases i <;> fin_cases j <;> + simp_all [certificateMatrix, fivePairCompletion, residual, targetOffDiagonal] + +private def diagonal₀ (certificate : LensCertificate) : ℝ := + factorGram certificate 0 0 + 1 / 1000000 + |residual certificate 0 1| + + |residual certificate 0 2| + |residual certificate 0 3| + |residual certificate 0 4| + +private def diagonal₁ (certificate : LensCertificate) : ℝ := + factorGram certificate 1 1 + 1 / 1000000 + |residual certificate 0 1| + + |residual certificate 1 2| + |residual certificate 1 3| + |residual certificate 1 4| + +private def diagonal₂ (certificate : LensCertificate) : ℝ := + factorGram certificate 2 2 + 1 / 1000000 + |residual certificate 0 2| + + |residual certificate 1 2| + |residual certificate 2 3| + |residual certificate 2 4| + +private def diagonal₃ (certificate : LensCertificate) : ℝ := + factorGram certificate 3 3 + 1 / 1000000 + |residual certificate 0 3| + + |residual certificate 1 3| + |residual certificate 2 3| + |residual certificate 3 4| + +private def diagonal₄ (certificate : LensCertificate) : ℝ := + factorGram certificate 4 4 + 1 / 1000000 + |residual certificate 0 4| + + |residual certificate 1 4| + |residual certificate 2 4| + |residual certificate 3 4| + +private theorem certificateMatrix_diagonal₀ (certificate : LensCertificate) : + certificateMatrix certificate 0 0 = diagonal₀ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₀] + +private theorem certificateMatrix_diagonal₁ (certificate : LensCertificate) : + certificateMatrix certificate 1 1 = diagonal₁ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₁] + +private theorem certificateMatrix_diagonal₂ (certificate : LensCertificate) : + certificateMatrix certificate 2 2 = diagonal₂ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₂] + +private theorem certificateMatrix_diagonal₃ (certificate : LensCertificate) : + certificateMatrix certificate 3 3 = diagonal₃ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₃] + +private theorem certificateMatrix_diagonal₄ (certificate : LensCertificate) : + certificateMatrix certificate 4 4 = diagonal₄ certificate := by + simp [certificateMatrix, fivePairCompletion, diagonal₄] + +private theorem gram_sum_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : LensCertificate) (v : Five → E) : + 0 ≤ ∑ i, ∑ j, certificateMatrix certificate i j * ⟪v i, v j⟫_ℝ := by + exact matrix_inner_sum_nonneg (certificateMatrix_posSemidef certificate) v + +private def dualY (certificate : LensCertificate) : ℝ := + diagonal₀ certificate + certificate.alpha₁₁ + certificate.alpha₁₂ + + certificate.alpha₂₂ + +private def redFirstBalance (certificate : LensCertificate) : ℝ := + diagonal₁ certificate + certificate.alpha₁₁ + certificate.alpha₁₂ - + redFirstPenalty + certificate.redSeparation + +private def redSecondBalance (certificate : LensCertificate) : ℝ := + diagonal₂ certificate + certificate.alpha₂₂ - + redSecondPenalty / (certificate.redLower + certificate.redUpper) + + certificate.redSeparation + +private def blueFirstBalance (certificate : LensCertificate) : ℝ := + diagonal₃ certificate + certificate.alpha₁₁ - blueFirstPenalty + + certificate.blueSeparation + +private def blueSecondBalance (certificate : LensCertificate) : ℝ := + diagonal₄ certificate + certificate.alpha₁₂ + certificate.alpha₂₂ - + blueSecondPenalty / (certificate.blueLower + certificate.blueUpper) + + certificate.blueSeparation + +private def dualRadialBound (certificate : LensCertificate) : ℝ := + dualY certificate + positivePart (redFirstBalance certificate) + + positivePart (redSecondBalance certificate) * certificate.redUpper ^ 2 - + negativePart (redSecondBalance certificate) * certificate.redLower ^ 2 + + positivePart (blueFirstBalance certificate) + + positivePart (blueSecondBalance certificate) * certificate.blueUpper ^ 2 - + negativePart (blueSecondBalance certificate) * certificate.blueLower ^ 2 - + (certificate.redSeparation + certificate.blueSeparation) * comparisonChord ^ 2 + +private def certificateUpperBound (certificate : LensCertificate) : ℝ := + -9 + 59 / 2 * comparisonChord - 85 / 2 * comparisonChord ^ 2 + + 17 ^ 2 / (4 * certificate.alpha₁₁) + + 3 ^ 2 / (4 * certificate.alpha₁₂) + + 5 ^ 2 / (4 * certificate.alpha₂₂) - + redSecondPenalty * certificate.redLower * certificate.redUpper / + (certificate.redLower + certificate.redUpper) - + blueSecondPenalty * certificate.blueLower * certificate.blueUpper / + (certificate.blueLower + certificate.blueUpper) + dualRadialBound certificate + +private def LensCertificate.Valid (certificate : LensCertificate) : Prop := + 0 < certificate.redLower ∧ certificate.redLower ≤ certificate.redUpper ∧ + certificate.redUpper ≤ 1 ∧ 0 < certificate.blueLower ∧ + certificate.blueLower ≤ certificate.blueUpper ∧ certificate.blueUpper ≤ 1 ∧ + 0 < certificate.alpha₁₁ ∧ 0 < certificate.alpha₁₂ ∧ + 0 < certificate.alpha₂₂ ∧ 0 ≤ certificate.redSeparation ∧ + 0 ≤ certificate.blueSeparation ∧ certificateUpperBound certificate < 0 + +private theorem certificate_gram_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : LensCertificate) (e p₁ p₂ w₁ w₂ : E) : + 0 ≤ diagonal₀ certificate * ‖e‖ ^ 2 + + diagonal₁ certificate * ‖p₁‖ ^ 2 + + diagonal₂ certificate * ‖p₂‖ ^ 2 + + diagonal₃ certificate * ‖w₁‖ ^ 2 + + diagonal₄ certificate * ‖w₂‖ ^ 2 + + 2 * (certificate.alpha₁₁ + certificate.alpha₁₂) * ⟪e, p₁⟫_ℝ + + 2 * certificate.alpha₂₂ * ⟪e, p₂⟫_ℝ + + 2 * certificate.alpha₁₁ * ⟪e, w₁⟫_ℝ + + 2 * (certificate.alpha₁₂ + certificate.alpha₂₂) * ⟪e, w₂⟫_ℝ + + 2 * certificate.redSeparation * ⟪p₁, p₂⟫_ℝ - + 2 * certificate.alpha₁₁ * ⟪p₁, w₁⟫_ℝ - + 2 * certificate.alpha₁₂ * ⟪p₁, w₂⟫_ℝ - + 2 * certificate.alpha₂₂ * ⟪p₂, w₂⟫_ℝ + + 2 * certificate.blueSeparation * ⟪w₁, w₂⟫_ℝ := by + let v : Five → E := ![e, p₁, p₂, w₁, w₂] + have h := gram_sum_nonneg certificate v + simp only [Fin.sum_univ_five, Fin.isValue, Matrix.cons_val_zero, Matrix.cons_val_one, + Matrix.cons_val, inner_self_eq_norm_sq_to_K, RCLike.ofReal_real_eq_id, id_eq, v] at h + rw [certificateMatrix_diagonal₀, certificateMatrix_diagonal₁, + certificateMatrix_diagonal₂, certificateMatrix_diagonal₃, + certificateMatrix_diagonal₄] at h + rw [certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (0 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (1 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 3), + certificateMatrix_offDiagonal certificate (by decide : (2 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (3 : Five) ≠ 4), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 0), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 1), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 2), + certificateMatrix_offDiagonal certificate (by decide : (4 : Five) ≠ 3)] at h + simp [targetOffDiagonal, real_inner_comm] at h + nlinarith + +private theorem balance_mul_sq_le_one {a r : ℝ} (hr : 0 ≤ r) (hru : r ≤ 1) : + a * r ^ 2 ≤ positivePart a := by + simpa using balance_mul_sq_le (a := a) (l := 0) (u := 1) (by norm_num) hr hru + +private theorem certificate_dual_bound {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : LensCertificate) (hvalid : certificate.Valid) + (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) + (hpsep : comparisonChord ≤ ‖p₁ - p₂‖) (hwsep : comparisonChord ≤ ‖w₁ - w₂‖) + (hp₂Lower : certificate.redLower ≤ ‖p₂‖) + (hp₂Upper : ‖p₂‖ ≤ certificate.redUpper) + (hw₂Lower : certificate.blueLower ≤ ‖w₂‖) + (hw₂Upper : ‖w₂‖ ≤ certificate.blueUpper) : + (certificate.alpha₁₁ + certificate.alpha₁₂ + certificate.alpha₂₂) * ‖e‖ ^ 2 + + (certificate.alpha₁₁ + certificate.alpha₁₂ - redFirstPenalty) * ‖p₁‖ ^ 2 + + (certificate.alpha₂₂ - redSecondPenalty / + (certificate.redLower + certificate.redUpper)) * ‖p₂‖ ^ 2 + + (certificate.alpha₁₁ - blueFirstPenalty) * ‖w₁‖ ^ 2 + + (certificate.alpha₁₂ + certificate.alpha₂₂ - blueSecondPenalty / + (certificate.blueLower + certificate.blueUpper)) * ‖w₂‖ ^ 2 - + 2 * (certificate.alpha₁₁ + certificate.alpha₁₂) * ⟪e, p₁⟫_ℝ - + 2 * certificate.alpha₂₂ * ⟪e, p₂⟫_ℝ - + 2 * certificate.alpha₁₁ * ⟪e, w₁⟫_ℝ - + 2 * (certificate.alpha₁₂ + certificate.alpha₂₂) * ⟪e, w₂⟫_ℝ + + 2 * certificate.alpha₁₁ * ⟪p₁, w₁⟫_ℝ + + 2 * certificate.alpha₁₂ * ⟪p₁, w₂⟫_ℝ + + 2 * certificate.alpha₂₂ * ⟪p₂, w₂⟫_ℝ ≤ dualRadialBound certificate := by + rcases hvalid with + ⟨hredLower, _, _, hblueLower, _, _, _, _, _, hredSeparation, hblueSeparation, _⟩ + have hredLowerR : (0 : ℝ) < certificate.redLower := by exact_mod_cast hredLower + have hblueLowerR : (0 : ℝ) < certificate.blueLower := by exact_mod_cast hblueLower + have hredSeparationR : (0 : ℝ) ≤ certificate.redSeparation := by + exact_mod_cast hredSeparation + have hblueSeparationR : (0 : ℝ) ≤ certificate.blueSeparation := by + exact_mod_cast hblueSeparation + have hpsepSq := (sq_le_sq₀ (by norm_num [comparisonChord]) (norm_nonneg _)).2 hpsep + have hwsepSq := (sq_le_sq₀ (by norm_num [comparisonChord]) (norm_nonneg _)).2 hwsep + rw [norm_sub_sq_real] at hpsepSq hwsepSq + have hredFirst := balance_mul_sq_le_one (a := redFirstBalance certificate) + (norm_nonneg p₁) hp₁ + have hredSecond := balance_mul_sq_le (a := redSecondBalance certificate) + hredLowerR.le hp₂Lower hp₂Upper + have hblueFirst := balance_mul_sq_le_one (a := blueFirstBalance certificate) + (norm_nonneg w₁) hw₁ + have hblueSecond := balance_mul_sq_le (a := blueSecondBalance certificate) + hblueLowerR.le hw₂Lower hw₂Upper + have hgram := certificate_gram_nonneg certificate e p₁ p₂ w₁ w₂ + simp only [he, one_pow, dualRadialBound, dualY, redFirstBalance, redSecondBalance, + blueFirstBalance, blueSecondBalance] at hgram hredFirst hredSecond hblueFirst hblueSecond ⊢ + have hpsepWeighted := mul_le_mul_of_nonneg_left hpsepSq hredSeparationR + have hwsepWeighted := mul_le_mul_of_nonneg_left hwsepSq hblueSeparationR + linarith only [hgram, hredFirst, hredSecond, hblueFirst, hblueSecond, hpsepWeighted, + hwsepWeighted] + +private theorem certificate_analytic_bound {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : LensCertificate) (hvalid : certificate.Valid) + (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) + (hpsep : comparisonChord ≤ ‖p₁ - p₂‖) (hwsep : comparisonChord ≤ ‖w₁ - w₂‖) + (hp₂Lower : certificate.redLower ≤ ‖p₂‖) + (hp₂Upper : ‖p₂‖ ≤ certificate.redUpper) + (hw₂Lower : certificate.blueLower ≤ ‖w₂‖) + (hw₂Upper : ‖w₂‖ ≤ certificate.blueUpper) : + 17 * ‖e - p₁ - w₁‖ + 3 * ‖e - p₁ - w₂‖ + 5 * ‖e - p₂ - w₂‖ - + redFirstPenalty * ‖p₁‖ - redSecondPenalty * ‖p₂‖ - + blueFirstPenalty * ‖w₁‖ - + blueSecondPenalty * ‖w₂‖ ≤ dualRadialBound certificate + + 17 ^ 2 / (4 * certificate.alpha₁₁) + 3 ^ 2 / (4 * certificate.alpha₁₂) + + 5 ^ 2 / (4 * certificate.alpha₂₂) - + redSecondPenalty * certificate.redLower * certificate.redUpper / + (certificate.redLower + certificate.redUpper) - + blueSecondPenalty * certificate.blueLower * certificate.blueUpper / + (certificate.blueLower + certificate.blueUpper) := by + have hdual := certificate_dual_bound certificate hvalid e p₁ p₂ w₁ w₂ he hp₁ hw₁ hpsep + hwsep hp₂Lower hp₂Upper hw₂Lower hw₂Upper + rcases hvalid with + ⟨hredLower, hredBounds, _, hblueLower, hblueBounds, _, halpha₁₁, halpha₁₂, + halpha₂₂, _, _, _⟩ + have hredLowerR : (0 : ℝ) < certificate.redLower := by exact_mod_cast hredLower + have hredBoundsR : (certificate.redLower : ℝ) ≤ certificate.redUpper := by + exact_mod_cast hredBounds + have hblueLowerR : (0 : ℝ) < certificate.blueLower := by exact_mod_cast hblueLower + have hblueBoundsR : (certificate.blueLower : ℝ) ≤ certificate.blueUpper := by + exact_mod_cast hblueBounds + have halpha₁₁R : (0 : ℝ) < certificate.alpha₁₁ := by exact_mod_cast halpha₁₁ + have halpha₁₂R : (0 : ℝ) < certificate.alpha₁₂ := by exact_mod_cast halpha₁₂ + have halpha₂₂R : (0 : ℝ) < certificate.alpha₂₂ := by exact_mod_cast halpha₂₂ + have htangent₁₁ := + weightedNorm_le_quadratic (e - p₁ - w₁) 17 certificate.alpha₁₁ halpha₁₁R + have htangent₁₂ := + weightedNorm_le_quadratic (e - p₁ - w₂) 3 certificate.alpha₁₂ halpha₁₂R + have htangent₂₂ := + weightedNorm_le_quadratic (e - p₂ - w₂) 5 certificate.alpha₂₂ halpha₂₂R + rw [norm_sub_sub_sq e p₁ w₁] at htangent₁₁ + rw [norm_sub_sub_sq e p₁ w₂] at htangent₁₂ + rw [norm_sub_sub_sq e p₂ w₂] at htangent₂₂ + have hredFirst := radial_secant (d := redFirstPenalty) (l := 0) (u := 1) (r := ‖p₁‖) + (by norm_num [redFirstPenalty, comparisonChord]) (norm_nonneg p₁) hp₁ (by norm_num) + have hredSecond := radial_secant (d := redSecondPenalty) (l := certificate.redLower) + (u := certificate.redUpper) (r := ‖p₂‖) (by norm_num [redSecondPenalty, comparisonChord]) + hp₂Lower hp₂Upper (by linarith) + have hblueFirst := radial_secant (d := blueFirstPenalty) (l := 0) (u := 1) (r := ‖w₁‖) + (by norm_num [blueFirstPenalty, comparisonChord]) (norm_nonneg w₁) hw₁ (by norm_num) + have hblueSecond := radial_secant (d := blueSecondPenalty) (l := certificate.blueLower) + (u := certificate.blueUpper) (r := ‖w₂‖) + (by norm_num [blueSecondPenalty, comparisonChord]) hw₂Lower hw₂Upper (by linarith) + simp only [he, one_pow] at htangent₁₁ htangent₁₂ htangent₂₂ hdual + norm_num at hredFirst hblueFirst + have htangent := add_le_add (add_le_add htangent₁₁ htangent₁₂) htangent₂₂ + have hradial := add_le_add (add_le_add hredFirst hredSecond) + (add_le_add hblueFirst hblueSecond) + ring_nf at htangent hradial hdual ⊢ + linarith only [htangent, hradial, hdual] + +private theorem lens_bound_of_certificate {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (certificate : LensCertificate) (hvalid : certificate.Valid) + (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) + (hpsep : comparisonChord ≤ ‖p₁ - p₂‖) (hwsep : comparisonChord ≤ ‖w₁ - w₂‖) + (hp₂Lower : certificate.redLower ≤ ‖p₂‖) + (hp₂Upper : ‖p₂‖ ≤ certificate.redUpper) + (hw₂Lower : certificate.blueLower ≤ ‖w₂‖) + (hw₂Upper : ‖w₂‖ ≤ certificate.blueUpper) : + 17 * ‖e - p₁ - w₁‖ + 3 * ‖e - p₁ - w₂‖ + 5 * ‖e - p₂ - w₂‖ - + redFirstPenalty * ‖p₁‖ - redSecondPenalty * ‖p₂‖ - + blueFirstPenalty * ‖w₁‖ - blueSecondPenalty * ‖w₂‖ - 9 + + 59 / 2 * comparisonChord - 85 / 2 * comparisonChord ^ 2 < 0 := by + have hanalytic := + certificate_analytic_bound certificate hvalid e p₁ p₂ w₁ w₂ he hp₁ hw₁ hpsep hwsep + hp₂Lower hp₂Upper hw₂Lower hw₂Upper + have hbound := hvalid.2.2.2.2.2.2.2.2.2.2.2 + unfold certificateUpperBound at hbound + nlinarith + +private theorem lensCertificate_box (i : Fin 28) : + (lensCertificates i).redLower = (lensBox i).redLower ∧ + (lensCertificates i).redUpper = (lensBox i).redUpper ∧ + (lensCertificates i).blueLower = (lensBox i).blueLower ∧ + (lensCertificates i).blueUpper = (lensBox i).blueUpper := by + fin_cases i <;> + norm_num [lensCertificates, lensBox, Matrix.cons_val_zero, Matrix.cons_val_one, + Matrix.cons_val_two, Matrix.cons_val_three, Matrix.cons_val_four] + +@[simp] private theorem lensCertificate_redLower (i : Fin 28) : + (lensCertificates i).redLower = (lensBox i).redLower := (lensCertificate_box i).1 + +@[simp] private theorem lensCertificate_redUpper (i : Fin 28) : + (lensCertificates i).redUpper = (lensBox i).redUpper := (lensCertificate_box i).2.1 + +@[simp] private theorem lensCertificate_blueLower (i : Fin 28) : + (lensCertificates i).blueLower = (lensBox i).blueLower := (lensCertificate_box i).2.2.1 + +@[simp] private theorem lensCertificate_blueUpper (i : Fin 28) : + (lensCertificates i).blueUpper = (lensBox i).blueUpper := (lensCertificate_box i).2.2.2 + +-- Separate certificates keep each kernel proof within the normal heartbeat budget. +local macro "verify_lens_certificate" : tactic => `(tactic| + norm_num [lensCertificates, LensCertificate.Valid, certificateUpperBound, dualRadialBound, + dualY, redFirstBalance, redSecondBalance, blueFirstBalance, blueSecondBalance, diagonal₀, + diagonal₁, diagonal₂, diagonal₃, diagonal₄, factorGram, factorRow, Matrix.vecMulVec, + residual, targetOffDiagonal, positivePart, negativePart, millionth, tenThousandthFactor, + comparisonChord, redFirstPenalty, redSecondPenalty, blueFirstPenalty, blueSecondPenalty, + Fin.sum_univ_three, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_two, + Matrix.cons_val_three, Matrix.cons_val_four]) + +private theorem lensCertificates_valid_0 : (lensCertificates 0).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_1 : (lensCertificates 1).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_2 : (lensCertificates 2).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_3 : (lensCertificates 3).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_4 : (lensCertificates 4).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_5 : (lensCertificates 5).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_6 : (lensCertificates 6).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_7 : (lensCertificates 7).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_8 : (lensCertificates 8).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_9 : (lensCertificates 9).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_10 : (lensCertificates 10).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_11 : (lensCertificates 11).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_12 : (lensCertificates 12).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_13 : (lensCertificates 13).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_14 : (lensCertificates 14).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_15 : (lensCertificates 15).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_16 : (lensCertificates 16).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_17 : (lensCertificates 17).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_18 : (lensCertificates 18).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_19 : (lensCertificates 19).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_20 : (lensCertificates 20).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_21 : (lensCertificates 21).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_22 : (lensCertificates 22).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_23 : (lensCertificates 23).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_24 : (lensCertificates 24).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_25 : (lensCertificates 25).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_26 : (lensCertificates 26).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid_27 : (lensCertificates 27).Valid := by + verify_lens_certificate + +private theorem lensCertificates_valid (i : Fin 28) : (lensCertificates i).Valid := by + fin_cases i + · exact lensCertificates_valid_0 + · exact lensCertificates_valid_1 + · exact lensCertificates_valid_2 + · exact lensCertificates_valid_3 + · exact lensCertificates_valid_4 + · exact lensCertificates_valid_5 + · exact lensCertificates_valid_6 + · exact lensCertificates_valid_7 + · exact lensCertificates_valid_8 + · exact lensCertificates_valid_9 + · exact lensCertificates_valid_10 + · exact lensCertificates_valid_11 + · exact lensCertificates_valid_12 + · exact lensCertificates_valid_13 + · exact lensCertificates_valid_14 + · exact lensCertificates_valid_15 + · exact lensCertificates_valid_16 + · exact lensCertificates_valid_17 + · exact lensCertificates_valid_18 + · exact lensCertificates_valid_19 + · exact lensCertificates_valid_20 + · exact lensCertificates_valid_21 + · exact lensCertificates_valid_22 + · exact lensCertificates_valid_23 + · exact lensCertificates_valid_24 + · exact lensCertificates_valid_25 + · exact lensCertificates_valid_26 + · exact lensCertificates_valid_27 + +private theorem exists_certificate_first_red_band (r b : ℝ) + (hrl : 3 / 8 ≤ r) (hru : r ≤ 17 / 32) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨3, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 11 / 16 + · refine ⟨0, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 27 / 32 + · refine ⟨1, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨2, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_second_red_band (r b : ℝ) + (hrl : 17 / 32 ≤ r) (hru : r ≤ 39 / 64) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨3, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 39 / 64 + · refine ⟨7, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 11 / 16 + · refine ⟨8, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 49 / 64 + · refine ⟨4, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₄ : b ≤ 27 / 32 + · refine ⟨5, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨6, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_third_red_band (r b : ℝ) + (hrl : 39 / 64 ≤ r) (hru : r ≤ 11 / 16) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨3, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 39 / 64 + · refine ⟨7, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 11 / 16 + · refine ⟨8, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 49 / 64 + · refine ⟨9, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₄ : b ≤ 27 / 32 + · refine ⟨10, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨11, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_fourth_red_band (r b : ℝ) + (hrl : 11 / 16 ≤ r) (hru : r ≤ 93 / 128) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨18, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 39 / 64 + · refine ⟨17, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 11 / 16 + · refine ⟨13, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 93 / 128 + · refine ⟨14, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₄ : b ≤ 49 / 64 + · refine ⟨15, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₅ : b ≤ 27 / 32 + · refine ⟨12, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨16, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_fifth_red_band (r b : ℝ) + (hrl : 93 / 128 ≤ r) (hru : r ≤ 49 / 64) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨18, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 39 / 64 + · refine ⟨17, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 11 / 16 + · refine ⟨13, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 93 / 128 + · refine ⟨14, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₄ : b ≤ 49 / 64 + · refine ⟨15, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₅ : b ≤ 27 / 32 + · refine ⟨19, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨16, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_sixth_red_band (r b : ℝ) + (hrl : 49 / 64 ≤ r) (hru : r ≤ 27 / 32) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨18, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 39 / 64 + · refine ⟨17, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 11 / 16 + · refine ⟨20, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 49 / 64 + · refine ⟨21, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₄ : b ≤ 27 / 32 + · refine ⟨22, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨23, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_certificate_seventh_red_band (r b : ℝ) + (hrl : 27 / 32 ≤ r) (hru : r ≤ 1) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hb₀ : b ≤ 17 / 32 + · refine ⟨18, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₁ : b ≤ 11 / 16 + · refine ⟨24, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₂ : b ≤ 49 / 64 + · refine ⟨25, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + by_cases hb₃ : b ≤ 27 / 32 + · refine ⟨26, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + · refine ⟨27, ?_, ?_, ?_, ?_⟩ <;> norm_num [lensBox, Fin.coe_ofNat_eq_mod] <;> linarith + +private theorem exists_lens_certificate (r b : ℝ) + (hrl : 3 / 8 ≤ r) (hru : r ≤ 1) (hbl : 3 / 8 ≤ b) (hbu : b ≤ 1) : + ∃ i, (lensCertificates i).redLower ≤ r ∧ r ≤ (lensCertificates i).redUpper ∧ + (lensCertificates i).blueLower ≤ b ∧ b ≤ (lensCertificates i).blueUpper := by + by_cases hr₀ : r ≤ 17 / 32 + · exact exists_certificate_first_red_band r b hrl hr₀ hbl hbu + by_cases hr₁ : r ≤ 39 / 64 + · exact exists_certificate_second_red_band r b (by linarith) hr₁ hbl hbu + by_cases hr₂ : r ≤ 11 / 16 + · exact exists_certificate_third_red_band r b (by linarith) hr₂ hbl hbu + by_cases hr₃ : r ≤ 93 / 128 + · exact exists_certificate_fourth_red_band r b (by linarith) hr₃ hbl hbu + by_cases hr₄ : r ≤ 49 / 64 + · exact exists_certificate_fifth_red_band r b (by linarith) hr₄ hbl hbu + by_cases hr₅ : r ≤ 27 / 32 + · exact exists_certificate_sixth_red_band r b (by linarith) hr₅ hbl hbu + · exact exists_certificate_seventh_red_band r b (by linarith) hru hbl hbu + +private theorem comparisonChord_lt_barC : comparisonChord < barC := by + have hc := barC_mem_isolation_box.1 + norm_num [comparisonChord] at hc ⊢ + linarith + +private theorem second_norm_lower {E : Type*} [SeminormedAddCommGroup E] (p₁ p₂ : E) + (hp₁ : ‖p₁‖ ≤ 1) (hsep : comparisonChord ≤ ‖p₁ - p₂‖) : + 3 / 8 ≤ ‖p₂‖ := by + have htriangle := norm_sub_le p₁ p₂ + norm_num [comparisonChord] at hsep ⊢ + linarith + +private theorem rational_chord_bound_implies_endpoint {E : Type*} + [SeminormedAddCommGroup E] (e p₁ p₂ w₁ w₂ : E) + (hbound : + 17 * ‖e - p₁ - w₁‖ + 3 * ‖e - p₁ - w₂‖ + 5 * ‖e - p₂ - w₂‖ - + redFirstPenalty * ‖p₁‖ - redSecondPenalty * ‖p₂‖ - + blueFirstPenalty * ‖w₁‖ - blueSecondPenalty * ‖w₂‖ - 9 + + 59 / 2 * comparisonChord - 85 / 2 * comparisonChord ^ 2 < 0) : + 17 * ‖e - p₁ - w₁‖ + 3 * ‖e - p₁ - w₂‖ + 5 * ‖e - p₂ - w₂‖ - + 3 * (barC - 1) * ‖p₁‖ - 3 * (barC + 1) * ‖p₂‖ - + 9 / 2 * (barC - 1) * ‖w₁‖ - 9 / 2 * (barC + 1) * ‖w₂‖ - 9 + + 59 / 2 * barC - 85 / 2 * barC ^ 2 < 0 := by + have hc := comparisonChord_lt_barC + have hslope : 0 ≤ + 3 * ‖p₁‖ + 3 * ‖p₂‖ + 9 / 2 * ‖w₁‖ + 9 / 2 * ‖w₂‖ := by positivity + have hpenalty := mul_nonneg (sub_nonneg.mpr hc.le) hslope + have hfactor : 0 < 85 / 2 * (barC + comparisonChord) - 59 / 2 := by + norm_num [comparisonChord] at hc ⊢ + linarith + have hconstant := mul_pos (sub_pos.mpr hc) hfactor + unfold redFirstPenalty redSecondPenalty blueFirstPenalty blueSecondPenalty at hbound + nlinarith + +private theorem endpoint_balanced_lens_vector_bound {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 17 * ‖e - p₁ - w₁‖ + 3 * ‖e - p₁ - w₂‖ + 5 * ‖e - p₂ - w₂‖ - + 3 * (barC - 1) * ‖p₁‖ - 3 * (barC + 1) * ‖p₂‖ - + 9 / 2 * (barC - 1) * ‖w₁‖ - 9 / 2 * (barC + 1) * ‖w₂‖ - 9 + + 59 / 2 * barC - 85 / 2 * barC ^ 2 < 0 := by + have hpsep' := comparisonChord_lt_barC.le.trans hpsep + have hwsep' := comparisonChord_lt_barC.le.trans hwsep + have hp₂Lower := second_norm_lower p₁ p₂ hp₁ hpsep' + have hw₂Lower := second_norm_lower w₁ w₂ hw₁ hwsep' + rcases exists_lens_certificate ‖p₂‖ ‖w₂‖ hp₂Lower hp₂ hw₂Lower hw₂ with + ⟨i, hpLower, hpUpper, hwLower, hwUpper⟩ + apply rational_chord_bound_implies_endpoint e p₁ p₂ w₁ w₂ + exact lens_bound_of_certificate (lensCertificates i) (lensCertificates_valid i) + e p₁ p₂ w₁ w₂ he hp₁ hw₁ hpsep' hwsep' hpLower hpUpper hwLower hwUpper + +/-- The endpoint-balanced `E0/S0` lens separator is negative for every admissible +six-point configuration. -/ +theorem endpointBalancedE0S0LensBound_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + EndpointBalancedE0S0LensBound configuration := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hpsep : barC ≤ ‖p₁ - p₂‖ := by + have hred := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hred + exact hred + have hwsep : barC ≤ ‖w₁ - w₂‖ := by + have hblue := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hblue + exact hblue + have hcertificate := endpoint_balanced_lens_vector_bound e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hpsep hwsep + simp only [EndpointBalancedE0S0LensBound, diagonalMatchingReducedSlack, + redEndpointReducedSlack, blueBalancedReducedSlack, balancedIncidencePenalty, + incidenceCrossDistance_eq_norm, incidenceChildRadius_red_eq_norm, + incidenceChildRadius_blue_eq_norm] + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] + dsimp only [e, p₁, p₂, w₁, w₂] at hcertificate + nlinarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/MatrixCorrections.lean b/LeanPool/Besicovitch/SixPoint/MatrixCorrections.lean new file mode 100644 index 0000000000..e35e6ba5ff --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/MatrixCorrections.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.InnerProductSpace.GramMatrix +public import Mathlib.Analysis.Matrix.Order +public import LeanPool.Besicovitch.SixPoint.NormEstimates + +/-! +# Shared rank-one matrix corrections + +Certificate families use these signed corrections to dominate their off-diagonal residuals. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +variable {ι : Type*} [DecidableEq ι] + +/-- Sign used for the off-diagonal entry of a rank-one correction. -/ +def pairSign (r : ℝ) : ℝ := if 0 ≤ r then 1 else -1 + +/-- The two-coordinate vector for a signed matrix correction. -/ +def pairVector (r : ℝ) (i j : ι) : ι → ℝ := + fun k ↦ if k = i then 1 else if k = j then pairSign r else 0 + +/-- A positive semidefinite rank-one correction. -/ +def pairCorrection (r : ℝ) (i j : ι) : Matrix ι ι ℝ := + |r| • Matrix.vecMulVec (pairVector r i j) (pairVector r i j) + +/-- The correction matrix is positive semidefinite. -/ +theorem pairCorrection_posSemidef [Finite ι] (r : ℝ) (i j : ι) : + (pairCorrection r i j).PosSemidef := + (Matrix.posSemidef_vecMulVec_self_star (pairVector r i j)).smul (abs_nonneg r) + +/-- Complete a five-vector certificate with positive two-coordinate corrections. -/ +def fivePairCompletion (base : Matrix (Fin 5) (Fin 5) ℝ) + (residual : Fin 5 → Fin 5 → ℝ) : Matrix (Fin 5) (Fin 5) ℝ := + base + + pairCorrection (residual 0 1) 0 1 + + pairCorrection (residual 0 2) 0 2 + + pairCorrection (residual 0 3) 0 3 + + pairCorrection (residual 0 4) 0 4 + + pairCorrection (residual 1 2) 1 2 + + pairCorrection (residual 1 3) 1 3 + + pairCorrection (residual 1 4) 1 4 + + pairCorrection (residual 2 3) 2 3 + + pairCorrection (residual 2 4) 2 4 + + pairCorrection (residual 3 4) 3 4 + +/-- Pairwise completion preserves positive semidefiniteness. -/ +theorem fivePairCompletion_posSemidef {base : Matrix (Fin 5) (Fin 5) ℝ} + (hbase : base.PosSemidef) (residual : Fin 5 → Fin 5 → ℝ) : + (fivePairCompletion base residual).PosSemidef := by + have h := hbase.add (pairCorrection_posSemidef (residual 0 1) 0 1) + have h := h.add (pairCorrection_posSemidef (residual 0 2) 0 2) + have h := h.add (pairCorrection_posSemidef (residual 0 3) 0 3) + have h := h.add (pairCorrection_posSemidef (residual 0 4) 0 4) + have h := h.add (pairCorrection_posSemidef (residual 1 2) 1 2) + have h := h.add (pairCorrection_posSemidef (residual 1 3) 1 3) + have h := h.add (pairCorrection_posSemidef (residual 1 4) 1 4) + have h := h.add (pairCorrection_posSemidef (residual 2 3) 2 3) + have h := h.add (pairCorrection_posSemidef (residual 2 4) 2 4) + exact h.add (pairCorrection_posSemidef (residual 3 4) 3 4) + +omit [DecidableEq ι] in +/-- The signed absolute value recovers the original residual. -/ +theorem abs_mul_pairSign (r : ℝ) : |r| * pairSign r = r := by + by_cases hr : 0 ≤ r + · simp [pairSign, hr, abs_of_nonneg hr] + · simp [pairSign, hr, abs_of_neg (lt_of_not_ge hr)] + +/-- The corrected off-diagonal entry. -/ +@[simp] +theorem pairCorrection_apply_pair (r : ℝ) {i j : ι} (hij : i ≠ j) : + pairCorrection r i j i j = r := by + simp [pairCorrection, Matrix.vecMulVec, pairVector, hij.symm, abs_mul_pairSign] + +/-- The transposed corrected off-diagonal entry. -/ +@[simp] +theorem pairCorrection_apply_pair_rev (r : ℝ) {i j : ι} (hij : i ≠ j) : + pairCorrection r i j j i = r := by + simp [pairCorrection, Matrix.vecMulVec, pairVector, hij.symm, abs_mul_pairSign, mul_comm] + +/-- The first diagonal entry is the residual magnitude. -/ +@[simp] +theorem pairCorrection_apply_left_left (r : ℝ) {i j : ι} : + pairCorrection r i j i i = |r| := by + simp [pairCorrection, Matrix.vecMulVec, pairVector] + +/-- The second diagonal entry is the residual magnitude. -/ +@[simp] +theorem pairCorrection_apply_right_right (r : ℝ) {i j : ι} (hij : i ≠ j) : + pairCorrection r i j j j = |r| := by + by_cases hr : 0 ≤ r <;> + simp [pairCorrection, Matrix.vecMulVec, pairVector, pairSign, hij.symm, hr] + +/-- Other rows of the correction vanish. -/ +@[simp] +theorem pairCorrection_apply_zero_left (r : ℝ) {i j k l : ι} + (hki : k ≠ i) (hkj : k ≠ j) : pairCorrection r i j k l = 0 := by + simp [pairCorrection, Matrix.vecMulVec, pairVector, hki, hkj] + +/-- Other columns of the correction vanish. -/ +@[simp] +theorem pairCorrection_apply_zero_right (r : ℝ) {i j k l : ι} + (hli : l ≠ i) (hlj : l ≠ j) : pairCorrection r i j k l = 0 := by + simp [pairCorrection, Matrix.vecMulVec, pairVector, hli, hlj] + +omit [DecidableEq ι] in +/-- A positive semidefinite matrix has a nonnegative sum against vector inner products. -/ +theorem matrix_inner_sum_nonneg [Fintype ι] {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] {matrix : Matrix ι ι ℝ} (hmatrix : matrix.PosSemidef) + (v : ι → E) : 0 ≤ ∑ i, ∑ j, matrix i j * ⟪v i, v j⟫_ℝ := by + classical + have h := (hmatrix.hadamard (Matrix.posSemidef_gram ℝ v)).dotProduct_mulVec_nonneg + (fun _ ↦ (1 : ℝ)) + simpa [dotProduct, Matrix.mulVec, Finset.mul_sum] using h + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/NormEstimates.lean b/LeanPool/Besicovitch/SixPoint/NormEstimates.lean new file mode 100644 index 0000000000..10f7dda814 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/NormEstimates.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.InnerProductSpace.Basic +public import Mathlib.Tactic.FieldSimp +public import Mathlib.Tactic.Linarith +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.Ring + +/-! +# Shared norm and quadratic estimates + +The sibling and row-column certificates use the same norm expansions and tangent bounds. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- A norm is bounded by its quadratic tangent at a positive radius. -/ +theorem norm_tangent {E : Type*} [SeminormedAddCommGroup E] (x : E) {r : ℝ} + (hr : 0 < r) : ‖x‖ ≤ (‖x‖ ^ 2 + r ^ 2) / (2 * r) := by + rw [le_div_iff₀ (by positivity : 0 < 2 * r)] + nlinarith [sq_nonneg (‖x‖ - r)] + +/-- A nonnegative weighted norm is bounded by its quadratic tangent. -/ +theorem weighted_norm_tangent {E : Type*} [SeminormedAddCommGroup E] + (x : E) (weight r : ℝ) (hr : 0 < r) (hweight : 0 ≤ weight) : + weight * ‖x‖ ≤ weight / (2 * r) * (‖x‖ ^ 2 + r ^ 2) := by + calc + weight * ‖x‖ ≤ weight * ((‖x‖ ^ 2 + r ^ 2) / (2 * r)) := + mul_le_mul_of_nonneg_left (norm_tangent x hr) hweight + _ = _ := by ring + +/-- The squared norm of a nonnegative weighted pair in terms of its separation. -/ +theorem weighted_norm_sq {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (x y : E) {a b : ℝ} (ha : 0 ≤ a) (hb : 0 ≤ b) : + ‖a • x + b • y‖ ^ 2 = + (a + b) * (a * ‖x‖ ^ 2 + b * ‖y‖ ^ 2) - a * b * ‖x - y‖ ^ 2 := by + rw [norm_add_sq_real, norm_sub_sq_real] + simp only [norm_smul, Real.norm_eq_abs, abs_of_nonneg ha, abs_of_nonneg hb, + real_inner_smul_left, real_inner_smul_right] + ring + +/-- Twice a norm is bounded by a positive radius and its squared-norm quotient. -/ +theorem two_mul_norm_tangent {E : Type*} [SeminormedAddCommGroup E] (x : E) + {r : ℝ} (hr : 0 < r) : 2 * ‖x‖ ≤ r + ‖x‖ ^ 2 / r := by + have h := norm_tangent x hr + calc + 2 * ‖x‖ ≤ 2 * ((‖x‖ ^ 2 + r ^ 2) / (2 * r)) := + mul_le_mul_of_nonneg_left h (by norm_num) + _ = r + ‖x‖ ^ 2 / r := by field_simp; ring + +/-- A convex quadratic on an interval is bounded by its endpoint values. -/ +theorem quadratic_le_max_endpoints {a b d l x u : ℝ} (ha : 0 ≤ a) + (hlx : l ≤ x) (hxu : x ≤ u) : + a * x ^ 2 + b * x + d ≤ max (a * l ^ 2 + b * l + d) (a * u ^ 2 + b * u + d) := by + by_cases hlu : l = u + · subst u + have hx : x = l := le_antisymm hxu hlx + subst x + exact le_max_left _ _ + have hwidth : 0 < u - l := sub_pos.mpr (lt_of_le_of_ne (hlx.trans hxu) hlu) + have hcurve : a * (x - l) * (x - u) ≤ 0 := + mul_nonpos_of_nonneg_of_nonpos (mul_nonneg ha (sub_nonneg.mpr hlx)) + (sub_nonpos.mpr hxu) + have hleft := le_max_left (a * l ^ 2 + b * l + d) (a * u ^ 2 + b * u + d) + have hright := le_max_right (a * l ^ 2 + b * l + d) (a * u ^ 2 + b * u + d) + have hweighted := add_le_add + (mul_le_mul_of_nonneg_left hleft (sub_nonneg.mpr hxu)) + (mul_le_mul_of_nonneg_left hright (sub_nonneg.mpr hlx)) + apply (mul_le_mul_iff_of_pos_left hwidth).mp + nlinarith + +/-- Expand the squared norm of a difference of three vectors. -/ +theorem norm_sub_sub_sq {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x y : E) : + ‖e - x - y‖ ^ 2 = ‖e‖ ^ 2 + ‖x‖ ^ 2 + ‖y‖ ^ 2 - + 2 * ⟪e, x⟫_ℝ - 2 * ⟪e, y⟫_ℝ + 2 * ⟪x, y⟫_ℝ := by + rw [norm_sub_sq_real, norm_sub_sq_real] + simp only [inner_sub_left] + ring + +/-- The nonnegative part of a real coefficient. -/ +def positivePart (x : ℝ) : ℝ := max x 0 + +/-- The magnitude of the negative part of a real coefficient. -/ +def negativePart (x : ℝ) : ℝ := max (-x) 0 + +/-- Positive and negative parts recover the coefficient. -/ +theorem positivePart_sub_negativePart (x : ℝ) : + positivePart x - negativePart x = x := by + by_cases hx : 0 ≤ x + · simp [positivePart, negativePart, hx] + · have hx' : x ≤ 0 := le_of_not_ge hx + simp [positivePart, negativePart, hx', neg_nonneg.mpr hx'] + +/-- The positive part is nonnegative. -/ +theorem positivePart_nonneg (x : ℝ) : 0 ≤ positivePart x := le_max_right _ _ + +/-- The negative part is nonnegative. -/ +theorem negativePart_nonneg (x : ℝ) : 0 ≤ negativePart x := le_max_right _ _ + +/-- A negative linear radial term is bounded by its quadratic secant. -/ +theorem radial_secant {r d l u : ℝ} (hd : 0 ≤ d) (hl : l ≤ r) (hu : r ≤ u) + (hsum : 0 < l + u) : + -d * r ≤ -d / (l + u) * r ^ 2 - d * l * u / (l + u) := by + have hproduct : 0 ≤ (r - l) * (u - r) := + mul_nonneg (sub_nonneg.mpr hl) (sub_nonneg.mpr hu) + have hbase : r ^ 2 + l * u ≤ (l + u) * r := by nlinarith + have hscaled := mul_le_mul_of_nonneg_left hbase (div_nonneg hd hsum.le) + field_simp [hsum.ne'] at hscaled ⊢ + nlinarith + +/-- Split a signed quadratic coefficient to bound it at the interval endpoints. -/ +theorem balance_mul_sq_le {a r l u : ℝ} (hl : 0 ≤ l) (hlr : l ≤ r) (hru : r ≤ u) : + a * r ^ 2 ≤ positivePart a * u ^ 2 - negativePart a * l ^ 2 := by + have hr := hl.trans hlr + have hu := hr.trans hru + have hupperSq := (sq_le_sq₀ hr hu).2 hru + have hlowerSq := (sq_le_sq₀ hl hr).2 hlr + have hupper := mul_le_mul_of_nonneg_left hupperSq (positivePart_nonneg a) + have hlower := mul_le_mul_of_nonneg_left hlowerSq (negativePart_nonneg a) + have hparts := congrArg (fun x : ℝ ↦ x * r ^ 2) (positivePart_sub_negativePart a) + linarith only [hparts, hupper, hlower] + +/-- A positive quadratic coefficient gives a global tangent bound for a weighted norm. -/ +theorem weightedNorm_le_quadratic {E : Type*} [SeminormedAddCommGroup E] + (x : E) (weight coefficient : ℝ) (hcoefficient : 0 < coefficient) : + weight * ‖x‖ ≤ coefficient * ‖x‖ ^ 2 + weight ^ 2 / (4 * coefficient) := by + have hsquare := sq_nonneg (2 * coefficient * ‖x‖ - weight) + field_simp [hcoefficient.ne'] + nlinarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Normalization.lean b/LeanPool/Besicovitch/SixPoint/Normalization.lean new file mode 100644 index 0000000000..b1f650c776 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Normalization.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Configuration + +/-! +# Normalization of six-point configurations + +This file translates and rescales a configuration for the finite six-point problem. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +namespace SixPointConfiguration + +/-- Translate a configuration by `origin` and divide all coordinates by `scale`. -/ +def normalize (configuration : SixPointConfiguration) + (origin : (EuclideanSpace ℝ (Fin 2))) (scale : ℝ) : + SixPointConfiguration := + fun color label ↦ scale⁻¹ • (configuration color label - origin) + +/-- Normalization by a positive scale divides every pairwise distance by that scale. -/ +theorem dist_normalize (configuration : SixPointConfiguration) + (origin : (EuclideanSpace ℝ (Fin 2))) {scale : ℝ} + (hscale : 0 < scale) (color₁ color₂ : SixPointColor) (label₁ label₂ : SixPointLabel) : + dist (configuration.normalize origin scale color₁ label₁) + (configuration.normalize origin scale color₂ label₂) = + dist (configuration color₁ label₁) (configuration color₂ label₂) / scale := by + simp [normalize, dist_smul₀, Real.norm_eq_abs, abs_of_pos hscale, div_eq_inv_mul] + +/-- Multiplying normalized distances by the positive scale recovers physical distances. -/ +theorem dist_eq_scale_mul_dist_normalize (configuration : SixPointConfiguration) + (origin : (EuclideanSpace ℝ (Fin 2))) {scale : ℝ} (hscale : 0 < scale) + (color₁ color₂ : SixPointColor) (label₁ label₂ : SixPointLabel) : + dist (configuration color₁ label₁) (configuration color₂ label₂) = + scale * dist (configuration.normalize origin scale color₁ label₁) + (configuration.normalize origin scale color₂ label₂) := by + rw [configuration.dist_normalize origin hscale] + field_simp + +/-- Distance bounds at scale `scale` give an admissible normalized configuration. -/ +theorem isAdmissibleAt_normalize_of_distances (configuration : SixPointConfiguration) + (origin : (EuclideanSpace ℝ (Fin 2))) {scale d γ q s : ℝ} (hscale : 0 < scale) + (hroot : dist (configuration .red .root) (configuration .blue .root) = scale) + (hchild : ∀ color label, label ≠ .root → + dist (configuration color .root) (configuration color label) ≤ d) + (hsibling : ∀ color, + 2 * γ * d < dist (configuration color .left) (configuration color .right)) + (hq : q = d / scale) (hq_le_one : q ≤ 1) (hs_le : s ≤ γ * q) : + (configuration.normalize origin scale).IsAdmissibleAt s := by + constructor + · rw [configuration.dist_normalize origin hscale, hroot] + exact div_self hscale.ne' + · intro color label hlabel + rw [configuration.dist_normalize origin hscale] + calc + _ ≤ d / scale := div_le_div_of_nonneg_right (hchild color label hlabel) hscale.le + _ = q := hq.symm + _ ≤ 1 := hq_le_one + · intro color + rw [configuration.dist_normalize origin hscale] + have hscaled : 2 * γ * (d / scale) < + dist (configuration color .left) (configuration color .right) / scale := by + calc + _ = (2 * γ * d) / scale := by ring + _ < _ := (div_lt_div_iff_of_pos_right hscale).2 (hsibling color) + rw [← hq] at hscaled + nlinarith + +end SixPointConfiguration + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Packing.lean b/LeanPool/Besicovitch/SixPoint/Packing.lean new file mode 100644 index 0000000000..d7b2c7c3c2 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Packing.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Configuration +public import Mathlib.Data.Finset.Lattice.Fold + +/-! +# Packings on six-point configurations + +A support remembers selected zero-radius labels, so its virtual diameter has no degenerate cases. +-/ + +@[expose] public section + +noncomputable section + +open scoped BigOperators + +namespace LeanPool.Besicovitch + +/-- A supported radius assignment with disjoint same-color balls. -/ +structure SixPointPacking (configuration : SixPointConfiguration) where + /-- The centers retained by the packing. -/ + support : Finset SixPointIndex + meets_color : ∀ color, ∃ label, (color, label) ∈ support + /-- The radius at each retained center. -/ + radius : support → Set.Icc (0 : ℝ) 1 + same_color_disjoint : ∀ i j : support, i ≠ j → i.1.1 = j.1.1 → + (radius i : ℝ) + radius j ≤ dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + +namespace SixPointPacking + +variable {configuration : SixPointConfiguration} (packing : SixPointPacking configuration) + +/-- The support of a six-point packing is nonempty. -/ +theorem support_nonempty : packing.support.Nonempty := by + obtain ⟨label, hlabel⟩ := packing.meets_color .red + exact ⟨(.red, label), hlabel⟩ + +/-- The sum of all supported radii. -/ +def totalRadius : ℝ := + packing.support.attach.sum fun i ↦ (packing.radius i : ℝ) + +/-- The maximum pairwise center distance plus the two radii on the explicit support. -/ +def virtualDiameter : ℝ := + packing.support.attach.sup' packing.support_nonempty.attach fun i ↦ + packing.support.attach.sup' packing.support_nonempty.attach fun j ↦ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j + +/-- The packing score at parameter `s`. -/ +def score (s : ℝ) : ℝ := + packing.totalRadius - packing.virtualDiameter / (2 * s) + +/-- Every supported pair contributes at most the virtual diameter. -/ +theorem pair_le_virtualDiameter (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ packing.virtualDiameter := by + unfold virtualDiameter + calc + _ ≤ packing.support.attach.sup' packing.support_nonempty.attach (fun j ↦ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j) := Finset.le_sup' _ (Finset.mem_attach _ j) + _ ≤ _ := Finset.le_sup' + (fun i ↦ packing.support.attach.sup' packing.support_nonempty.attach fun j ↦ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j) (Finset.mem_attach _ i) + +/-- The virtual diameter is nonnegative. -/ +theorem virtualDiameter_nonneg : 0 ≤ packing.virtualDiameter := by + obtain ⟨index, hindex⟩ := packing.support_nonempty + let i : packing.support := ⟨index, hindex⟩ + exact (add_nonneg (add_nonneg dist_nonneg (packing.radius i).property.1) + (packing.radius i).property.1).trans (packing.pair_le_virtualDiameter i i) + +/-- Every supported center distance is at most the virtual diameter. -/ +theorem dist_le_virtualDiameter (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + packing.virtualDiameter := by + calc + _ ≤ _ + (packing.radius i : ℝ) := le_add_of_nonneg_right (packing.radius i).property.1 + _ ≤ _ + (packing.radius j : ℝ) := le_add_of_nonneg_right (packing.radius j).property.1 + _ ≤ _ := packing.pair_le_virtualDiameter i j + +/-- A lower bound between the two colors is inherited by the virtual diameter. -/ +theorem crossColor_le_virtualDiameter {lower : ℝ} + (hcross : ∀ redLabel blueLabel, + (.red, redLabel) ∈ packing.support → (.blue, blueLabel) ∈ packing.support → + lower ≤ dist (configuration .red redLabel) (configuration .blue blueLabel)) : + lower ≤ packing.virtualDiameter := by + obtain ⟨redLabel, hred⟩ := packing.meets_color .red + obtain ⟨blueLabel, hblue⟩ := packing.meets_color .blue + let red : packing.support := ⟨(.red, redLabel), hred⟩ + let blue : packing.support := ⟨(.blue, blueLabel), hblue⟩ + exact (hcross redLabel blueLabel hred hblue).trans (packing.dist_le_virtualDiameter red blue) + +/-- Twice any supported radius is at most the virtual diameter. -/ +theorem two_mul_radius_le_virtualDiameter (i : packing.support) : + 2 * (packing.radius i : ℝ) ≤ packing.virtualDiameter := by + simpa [two_mul] using packing.pair_le_virtualDiameter i i + +/-- The total radius is nonnegative. -/ +theorem totalRadius_nonneg : 0 ≤ packing.totalRadius := by + exact Finset.sum_nonneg fun i _ ↦ (packing.radius i).property.1 + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/PackingRelabel.lean b/LeanPool/Besicovitch/SixPoint/PackingRelabel.lean new file mode 100644 index 0000000000..037619809d --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/PackingRelabel.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Packing + +/-! +# Relabelling supported packings + +A color-preserving permutation transports a packing and preserves its radius sum and score. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch.SixPointPacking + +/-- Pull the support back along the relabelling permutation. -/ +def relabelSupportEquiv (support : Finset SixPointIndex) + (permutation : SixPointIndex ≃ SixPointIndex) : + (support.map permutation.toEmbedding : Finset SixPointIndex) ≃ support where + toFun index := ⟨permutation.symm index, by + obtain ⟨source, hsource, heq⟩ := Finset.mem_map.1 index.2 + simpa only [← heq, Equiv.toEmbedding_apply, Equiv.symm_apply_apply] using hsource⟩ + invFun index := ⟨permutation index, Finset.mem_map.2 ⟨index, index.2, rfl⟩⟩ + left_inv index := Subtype.ext (permutation.apply_symm_apply index) + right_inv index := Subtype.ext (permutation.symm_apply_apply index) + +/-- Transport a packing along a color-preserving permutation of its centers. -/ +def relabel {source target : SixPointConfiguration} (packing : SixPointPacking source) + (permutation : SixPointIndex ≃ SixPointIndex) + (hcolor : ∀ index, (permutation index).1 = index.1) + (hconfiguration : ∀ index, source index.1 index.2 = + target (permutation index).1 (permutation index).2) : SixPointPacking target where + support := packing.support.map permutation.toEmbedding + meets_color color := by + obtain ⟨label, hlabel⟩ := packing.meets_color color + refine ⟨(permutation (color, label)).2, Finset.mem_map.2 ⟨(color, label), hlabel, ?_⟩⟩ + exact Prod.ext (hcolor _) rfl + radius index := packing.radius (relabelSupportEquiv packing.support permutation index) + same_color_disjoint i j hij hsame := by + let equivalence := relabelSupportEquiv packing.support permutation + have hsame' : (equivalence i).1.1 = (equivalence j).1.1 := by + have hi : i.1.1 = (permutation.symm i).1 := by + simpa only [Equiv.apply_symm_apply] using hcolor (permutation.symm i) + have hj : j.1.1 = (permutation.symm j).1 := by + simpa only [Equiv.apply_symm_apply] using hcolor (permutation.symm j) + exact hi.symm.trans (hsame.trans hj) + have hp := packing.same_color_disjoint (equivalence i) (equivalence j) + (fun heq ↦ hij (equivalence.injective heq)) hsame' + simpa only [hconfiguration, equivalence, relabelSupportEquiv, Equiv.coe_fn_mk, + Equiv.apply_symm_apply] using hp + +variable {source target : SixPointConfiguration} (packing : SixPointPacking source) + (permutation : SixPointIndex ≃ SixPointIndex) + (hcolor : ∀ index, (permutation index).1 = index.1) + (hconfiguration : ∀ index, source index.1 index.2 = + target (permutation index).1 (permutation index).2) + +/-- Relabelling preserves the sum of the supported radii. -/ +theorem relabel_totalRadius : + (packing.relabel permutation hcolor hconfiguration).totalRadius = packing.totalRadius := by + unfold totalRadius + rw [← Finset.univ_eq_attach, ← Finset.univ_eq_attach] + exact Fintype.sum_equiv (relabelSupportEquiv packing.support permutation) _ _ (fun _ ↦ rfl) + +/-- Relabelling preserves every contribution to the virtual diameter. -/ +theorem relabel_virtualDiameter : + (packing.relabel permutation hcolor hconfiguration).virtualDiameter = + packing.virtualDiameter := by + let equivalence := relabelSupportEquiv packing.support permutation + have hpair (i j : (packing.relabel permutation hcolor hconfiguration).support) : + dist (target i.1.1 i.1.2) (target j.1.1 j.1.2) + + (packing.relabel permutation hcolor hconfiguration).radius i + + (packing.relabel permutation hcolor hconfiguration).radius j = + dist (source (equivalence i).1.1 (equivalence i).1.2) + (source (equivalence j).1.1 (equivalence j).1.2) + + packing.radius (equivalence i) + packing.radius (equivalence j) := by + simp only [hconfiguration, equivalence, relabelSupportEquiv, Equiv.coe_fn_mk, + Equiv.apply_symm_apply, relabel] + apply le_antisymm + · unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + rw [hpair] + exact packing.pair_le_virtualDiameter (equivalence i) (equivalence j) + · unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + have hp := (packing.relabel permutation hcolor hconfiguration).pair_le_virtualDiameter + (equivalence.symm i) (equivalence.symm j) + have hbound := (hpair (equivalence.symm i) (equivalence.symm j)).symm.trans_le hp + simpa only [Equiv.apply_symm_apply, virtualDiameter] using hbound + +/-- Relabelling preserves the score at every threshold. -/ +theorem relabel_score (s : ℝ) : + (packing.relabel permutation hcolor hconfiguration).score s = packing.score s := by + simp only [score, relabel_totalRadius, relabel_virtualDiameter] + +end LeanPool.Besicovitch.SixPointPacking diff --git a/LeanPool/Besicovitch/SixPoint/RationalChord.lean b/LeanPool/Besicovitch/SixPoint/RationalChord.lean new file mode 100644 index 0000000000..c628cced79 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RationalChord.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Basic.Real.Basic +public import Mathlib.Tactic.NormNum + +/-! +# The rational chord of the retargeted six-point argument + +The six-point analysis computes the sharp constant `sStar`, but a Lean proof of +`sigmaOne ≤ sStar` needs that endpoint to be attained exactly, and the resulting tightness is what +makes the finite certificates expensive. The argument is carried out instead at the rational +threshold `barS = 6934 / 10000`, which still improves on the published `0.7` and leaves the weighted +score a margin of about `3 * 10 ^ -3` rather than `10 ^ -8`. + +The routing and exclusion modules use a chord only through the two facts below: that it lies +between one and two, and that it lies in an explicit rational box. Both are immediate here. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Twice the rational threshold: the chord length of the retargeted argument. -/ +def barC : ℝ := 3467 / 2500 + +/-- The rational density threshold certified by the retargeted argument. -/ +def barS : ℝ := barC / 2 + +/-- The rational threshold is `0.6934`. -/ +theorem barS_eq : barS = 6934 / 10000 := by + norm_num [barS, barC] + +/-- The rational chord lies in an explicit isolation box. -/ +theorem barC_mem_isolation_box : + 13867999999999999 / 10 ^ 16 < barC ∧ barC < 13868000000000001 / 10 ^ 16 := by + constructor <;> norm_num [barC] + +/-- The rational chord is a genuine chord of the unit disk. -/ +theorem one_lt_barC_and_barC_lt_two : 1 < barC ∧ barC < 2 := by + constructor <;> norm_num [barC] + +/-- The rational chord is positive. -/ +theorem barC_pos : 0 < barC := by + norm_num [barC] + +/-- The rational threshold lies in an explicit isolation box. -/ +theorem barS_mem_isolation_box : + 6933999999999999 / 10 ^ 16 ≤ barS ∧ barS < 6934000000000001 / 10 ^ 16 := by + constructor <;> norm_num [barS, barC] + +/-- The rational threshold lies strictly between one half and one. -/ +theorem half_lt_barS_and_barS_lt_one : 1 / 2 < barS ∧ barS < 1 := by + constructor <;> norm_num [barS, barC] + +/-- The rational threshold exceeds one half. -/ +theorem half_lt_barS : 1 / 2 < barS := half_lt_barS_and_barS_lt_one.1 + +/-- The rational threshold is below one. -/ +theorem barS_lt_one : barS < 1 := half_lt_barS_and_barS_lt_one.2 + +/-- The rational threshold is positive. -/ +theorem barS_pos : 0 < barS := by + norm_num [barS, barC] + +/-- The rational threshold is below the previous record. -/ +theorem barS_lt_seven_tenths : barS < 7 / 10 := by + norm_num [barS, barC] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Realization.lean b/LeanPool/Besicovitch/SixPoint/Realization.lean new file mode 100644 index 0000000000..67d5c10490 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Realization.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.Geometry.BallUnion +public import LeanPool.Besicovitch.SixPoint.Packing + +/-! +# Physical realization of a six-point packing + +A normalized packing is realized by multiplying its radii by the physical length scale. This file +relates its virtual diameter and disjointness constraints to the resulting union of open balls. +-/ + +@[expose] public section + +noncomputable section + +open scoped BigOperators + +namespace LeanPool.Besicovitch + +namespace SixPointPacking + +variable {normalized physical : SixPointConfiguration} + +/-- The physical union of balls obtained from a normalized packing at a given scale. -/ +def ballUnionAt (packing : SixPointPacking normalized) (physical : SixPointConfiguration) + (scale : ℝ) : Set (EuclideanSpace ℝ (Fin 2)) := + finiteBallUnion packing.support + (fun i ↦ physical i.1.1 i.1.2) (fun i ↦ scale * packing.radius i) + +/-- The physical radii sum is the scale times the normalized radii sum. -/ +theorem sum_radiusAt (packing : SixPointPacking normalized) (scale : ℝ) : + (∑ i ∈ packing.support.attach, scale * (packing.radius i : ℝ)) = + scale * packing.totalRadius := by + simp [totalRadius, Finset.mul_sum] + +/-- The physical ball union is open. -/ +theorem isOpen_ballUnionAt (packing : SixPointPacking normalized) + (physical : SixPointConfiguration) (scale : ℝ) : + IsOpen (packing.ballUnionAt physical scale) := + isOpen_finiteBallUnion _ _ + +/-- Exact scaling of center distances bounds the diameter of the physical ball union. -/ +theorem ediam_ballUnionAt_le (packing : SixPointPacking normalized) + (physical : SixPointConfiguration) {scale : ℝ} (hscale : 0 ≤ scale) + (hdistance : ∀ i j : packing.support, + dist (physical i.1.1 i.1.2) (physical j.1.1 j.1.2) = + scale * dist (normalized i.1.1 i.1.2) (normalized j.1.1 j.1.2)) : + Metric.ediam (packing.ballUnionAt physical scale) ≤ + ENNReal.ofReal (scale * packing.virtualDiameter) := by + let maximum := packing.support.attach.sup' packing.support_nonempty.attach fun i ↦ + packing.support.attach.sup' packing.support_nonempty.attach fun j ↦ + dist (physical i.1.1 i.1.2) (physical j.1.1 j.1.2) + + scale * packing.radius i + scale * packing.radius j + have hmaximum : maximum ≤ scale * packing.virtualDiameter := by + dsimp only [maximum] + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + rw [hdistance i j] + calc + scale * dist (normalized i.1.1 i.1.2) (normalized j.1.1 j.1.2) + + scale * packing.radius i + scale * packing.radius j = + scale * (dist (normalized i.1.1 i.1.2) (normalized j.1.1 j.1.2) + + packing.radius i + packing.radius j) := by ring + _ ≤ scale * packing.virtualDiameter := + mul_le_mul_of_nonneg_left (packing.pair_le_virtualDiameter i j) hscale + exact (ediam_finiteBallUnion_le packing.support_nonempty _ _).trans + (ENNReal.ofReal_le_ofReal hmaximum) + +/-- Same-color physical balls remain disjoint under exact distance scaling. -/ +theorem disjoint_ballAt (packing : SixPointPacking normalized) + (physical : SixPointConfiguration) {scale : ℝ} (hscale : 0 ≤ scale) + (hdistance : ∀ i j : packing.support, + dist (physical i.1.1 i.1.2) (physical j.1.1 j.1.2) = + scale * dist (normalized i.1.1 i.1.2) (normalized j.1.1 j.1.2)) + (i j : packing.support) (hij : i ≠ j) (hcolor : i.1.1 = j.1.1) : + Disjoint (Metric.ball (physical i.1.1 i.1.2) (scale * packing.radius i)) + (Metric.ball (physical j.1.1 j.1.2) (scale * packing.radius j)) := by + apply Metric.ball_disjoint_ball + rw [hdistance i j] + calc + scale * (packing.radius i : ℝ) + scale * packing.radius j = + scale * ((packing.radius i : ℝ) + packing.radius j) := by ring + _ ≤ scale * dist (normalized i.1.1 i.1.2) (normalized j.1.1 j.1.2) := + mul_le_mul_of_nonneg_left (packing.same_color_disjoint i j hij hcolor) hscale + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/RootEdge.lean b/LeanPool/Besicovitch/SixPoint/RootEdge.lean new file mode 100644 index 0000000000..438f66adcc --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RootEdge.lean @@ -0,0 +1,1224 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +import LeanPool.Besicovitch.SixPoint.NormEstimates + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry +public import LeanPool.Besicovitch.SixPoint.SiblingTriangle + +/-! +# Root--edge packings + +This file develops the one-dimensional minimax for a root--child edge against the full opposite +triangle. It also proves the exact rational separator that excludes an internal triangle +primitive on the matching branch of the endpoint failure tree. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- The cross-color part of a root-edge split with edge length `R`. -/ +def rootEdgeCrossMaximum (R x : ℝ) (rootReach childReach : SixPointLabel → ℝ) : ℝ := + max (x + triangleMaximum rootReach) (R - x + triangleMaximum childReach) + +/-- The diameter of a root-edge split after its same-color terms are reduced to `2M`. -/ +def rootEdgeSplitDiameter (R M x : ℝ) + (rootReach childReach : SixPointLabel → ℝ) : ℝ := + max (2 * M) (rootEdgeCrossMaximum R x rootReach childReach) + +/-- Exact threshold form of the sixteen-term root-edge minimax. -/ +theorem exists_rootEdge_split_iff {R M T : ℝ} + {rootReach childReach : SixPointLabel → ℝ} (hR : 0 ≤ R) : + (∃ x : ℝ, 0 ≤ x ∧ x ≤ R ∧ + rootEdgeSplitDiameter R M x rootReach childReach ≤ T) ↔ + 2 * M ≤ T ∧ ( ∀ label, rootReach label ≤ T) ∧ + (∀ label, childReach label ≤ T) ∧ + ∀ rootLabel childLabel, + R + rootReach rootLabel + childReach childLabel ≤ 2 * T := by + constructor + · rintro ⟨x, hx_zero, hx_R, hdiameter⟩ + simp only [rootEdgeSplitDiameter, rootEdgeCrossMaximum, max_le_iff] at hdiameter + rcases hdiameter with ⟨hsame, hroot, hchild⟩ + refine ⟨hsame, ?_, ?_, ?_⟩ + · intro label + nlinarith [le_triangleMaximum rootReach label] + · intro label + nlinarith [le_triangleMaximum childReach label] + · intro rootLabel childLabel + nlinarith [le_triangleMaximum rootReach rootLabel, + le_triangleMaximum childReach childLabel] + · rintro ⟨hsame, hroot, hchild, hbalanced⟩ + obtain ⟨rootLabel, hrootLabel⟩ := exists_triangleMaximum_eq rootReach + obtain ⟨childLabel, hchildLabel⟩ := exists_triangleMaximum_eq childReach + have hrootMax : triangleMaximum rootReach ≤ T := by + rw [hrootLabel] + exact hroot rootLabel + have hchildMax : triangleMaximum childReach ≤ T := by + rw [hchildLabel] + exact hchild childLabel + have hbalancedMax : + R + triangleMaximum rootReach + triangleMaximum childReach ≤ 2 * T := by + rw [hrootLabel, hchildLabel] + exact hbalanced rootLabel childLabel + let x := max 0 (R + triangleMaximum childReach - T) + have hx_zero : 0 ≤ x := le_max_left _ _ + have hx_R : x ≤ R := by + simp only [x, max_le_iff] + constructor <;> linarith + have hrootCross : x + triangleMaximum rootReach ≤ T := by + simp only [x, max_add, max_le_iff] + constructor <;> linarith + have hchildCross : R - x + triangleMaximum childReach ≤ T := by + nlinarith [le_max_right 0 (R + triangleMaximum childReach - T)] + refine ⟨x, hx_zero, hx_R, ?_⟩ + simp only [rootEdgeSplitDiameter, rootEdgeCrossMaximum, max_le_iff] + exact ⟨hsame, hrootCross, hchildCross⟩ + +/-- Failure of every root-edge split selects one of its sixteen routing terms. -/ +theorem rootEdge_failure_routing {R M T : ℝ} + {rootReach childReach : SixPointLabel → ℝ} (hR : 0 ≤ R) + (hfail : ∀ x : ℝ, 0 ≤ x → x ≤ R → + T < rootEdgeSplitDiameter R M x rootReach childReach) : + T < 2 * M ∨ (∃ label, T < rootReach label) ∨ + (∃ label, T < childReach label) ∨ + ∃ rootLabel childLabel, + 2 * T < R + rootReach rootLabel + childReach childLabel := by + by_contra hrouting + simp only [not_or, not_exists, not_lt] at hrouting + rcases hrouting with ⟨hsame, hroot, hchild, hbalanced⟩ + obtain ⟨x, hx_zero, hx_R, hdiameter⟩ := + (exists_rootEdge_split_iff hR).2 ⟨hsame, hroot, hchild, hbalanced⟩ + exact (not_lt_of_ge hdiameter) (hfail x hx_zero hx_R) + +/-- The sixteen root-edge terms reduce pointwise to internal, `(1,1)`, or `(1,2)`. -/ +theorem rootEdge_failure_reduces_to_three_types {R M T : ℝ} + {rootReach childReach : SixPointLabel → ℝ} (hR : 0 < R) + (hrootRoot : rootReach .root ≤ T - R) (hchildRoot : childReach .root ≤ T - R) + (hleftLower : T - R ≤ rootReach .left) + (hleftLargest : rootReach .right < rootReach .left) + (hclose : ∀ label, label ≠ .root → rootReach label - R ≤ childReach label) + (hroute : T < 2 * M ∨ (∃ label, T < rootReach label) ∨ + (∃ label, T < childReach label) ∨ + ∃ rootLabel childLabel, + 2 * T < R + rootReach rootLabel + childReach childLabel) : + T < 2 * M ∨ 2 * T < R + rootReach .left + childReach .left ∨ + 2 * T < R + rootReach .left + childReach .right := by + rcases hroute with hinternal | hroot | hchild | hbalanced + · exact Or.inl hinternal + · rcases hroot with ⟨label, hlabel⟩ + cases label + · exfalso + linarith + · exact Or.inr <| Or.inl <| by nlinarith [hclose .left (by simp)] + · exact Or.inr <| Or.inr <| by + nlinarith [hclose .right (by simp)] + · rcases hchild with ⟨label, hlabel⟩ + cases label + · exfalso + linarith + · exact Or.inr <| Or.inl <| by nlinarith + · exact Or.inr <| Or.inr <| by nlinarith + · rcases hbalanced with ⟨rootLabel, childLabel, hlabels⟩ + cases rootLabel <;> cases childLabel + · exfalso + linarith + · exact Or.inr <| Or.inl <| by nlinarith + · exact Or.inr <| Or.inr <| by nlinarith + · exact Or.inr <| Or.inl <| by nlinarith [hclose .left (by simp)] + · exact Or.inr <| Or.inl hlabels + · exact Or.inr <| Or.inr hlabels + · exact Or.inr <| Or.inr <| by nlinarith [hclose .right (by simp)] + · exact Or.inr <| Or.inl <| by nlinarith + · exact Or.inr <| Or.inr <| by nlinarith + +/-- Supports `37` and `57`: a red root--child edge against the full blue triangle. -/ +def redRootEdgeBlueTrianglePacking (configuration : SixPointConfiguration) + (redLabel : SixPointLabel) (hredLabel : redLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + SixPointPacking configuration where + support := {(.red, .root), (.red, redLabel), (.blue, .root), (.blue, .left), + (.blue, .right)} + meets_color color := by + cases color + · exact ⟨.root, by simp⟩ + · exact ⟨.root, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color + · by_cases hroot : label = .root + · exact ⟨x, hx_zero, hx_R.trans hR_one⟩ + · exact ⟨R - x, sub_nonneg.mpr hx_R, by linarith⟩ + · cases label + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .right⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · have hi' : li = .root ∨ li = redLabel := by simpa using hi + have hj' : lj = .root ∨ lj = redLabel := by simpa using hj + rcases hi' with rfl | rfl <;> rcases hj' with rfl | rfl + · exact (hij (Subtype.ext rfl)).elim + · dsimp + rw [hRdist] + simp [hredLabel] + · dsimp + rw [dist_comm, hRdist] + simp [hredLabel] + · exact (hij (Subtype.ext rfl)).elim + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + +/-- The radius at the red root is the split variable. -/ +@[simp] theorem redRootEdgeBlueTrianglePacking_radius_root + (configuration : SixPointConfiguration) (redLabel : SixPointLabel) + (hredLabel : redLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (hmem : (.red, .root) ∈ (redRootEdgeBlueTrianglePacking configuration redLabel + hredLabel hRdist hR_one hx_zero hx_R hblueLeft hblueRight).support) : + ((redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist hR_one hx_zero hx_R + hblueLeft hblueRight).radius ⟨(.red, .root), hmem⟩ : ℝ) = x := by + rfl + +/-- The radius at the selected red child is the complementary split. -/ +@[simp] theorem redRootEdgeBlueTrianglePacking_radius_child + (configuration : SixPointConfiguration) (redLabel : SixPointLabel) + (hredLabel : redLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (hmem : (.red, redLabel) ∈ (redRootEdgeBlueTrianglePacking configuration redLabel + hredLabel hRdist hR_one hx_zero hx_R hblueLeft hblueRight).support) : + ((redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist hR_one hx_zero hx_R + hblueLeft hblueRight).radius ⟨(.red, redLabel), hmem⟩ : ℝ) = R - x := by + simp [redRootEdgeBlueTrianglePacking, hredLabel] + +/-- Blue radii in a red root-edge packing are the canonical triangle radii. -/ +@[simp] theorem redRootEdgeBlueTrianglePacking_radius_blue + (configuration : SixPointConfiguration) (redLabel : SixPointLabel) + (hredLabel : redLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (label : SixPointLabel) + (hmem : (.blue, label) ∈ (redRootEdgeBlueTrianglePacking configuration redLabel + hredLabel hRdist hR_one hx_zero hx_R hblueLeft hblueRight).support) : + ((redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist hR_one hx_zero hx_R + hblueLeft hblueRight).radius ⟨(.blue, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label := by + cases label <;> rfl + +/-- The total radius of a red root-edge packing is its edge length plus a semiperimeter. -/ +theorem redRootEdgeBlueTrianglePacking_totalRadius + (configuration : SixPointConfiguration) (redLabel : SixPointLabel) + (hredLabel : redLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + (redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist hR_one hx_zero hx_R + hblueLeft hblueRight).totalRadius = R + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2 := by + let packing := redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist + hR_one hx_zero hx_R hblueLeft hblueRight + let value : SixPointIndex → ℝ + | (.red, .root) => x + | (.red, label) => if label = redLabel then R - x else 0 + | (.blue, label) => canonicalTriangleRadius (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) label + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [redRootEdgeBlueTrianglePacking, value] at hi ⊢ <;> simp_all + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + cases redLabel + · exact (hredLabel rfl).elim + · simp [packing, redRootEdgeBlueTrianglePacking, value, canonicalTriangleRadius] + ring + · simp [packing, redRootEdgeBlueTrianglePacking, value, canonicalTriangleRadius] + ring + +/-- Cross reach from the red root to a labelled blue triangle ball. -/ +def redRootBlueTriangleReach (configuration : SixPointConfiguration) + (label : SixPointLabel) : ℝ := + dist (configuration .red .root) (configuration .blue label) + + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label + +/-- Cross reach from a red child to a labelled blue triangle ball. -/ +def redChildBlueTriangleReach (configuration : SixPointConfiguration) + (redLabel blueLabel : SixPointLabel) : ℝ := + dist (configuration .red redLabel) (configuration .blue blueLabel) + + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) blueLabel + +private theorem same_color_pair_le_twice_bound {configuration : SixPointConfiguration} + (packing : SixPointPacking configuration) (i j : packing.support) + (hcolor : i.1.1 = j.1.1) {bound : ℝ} (hbound : 1 ≤ bound) + (hdist : dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ bound) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ 2 * bound := by + by_cases hij : i = j + · subst j + simp only [dist_self, zero_add] + nlinarith [(packing.radius i).property.2] + · nlinarith [packing.same_color_disjoint i j hij hcolor] + +/-- Supports `73` and `75`: a blue root--child edge against the full red triangle. -/ +def blueRootEdgeRedTrianglePacking (configuration : SixPointConfiguration) + (blueLabel : SixPointLabel) (hblueLabel : blueLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .blue .root) (configuration .blue blueLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + SixPointPacking configuration where + support := {(.blue, .root), (.blue, blueLabel), (.red, .root), (.red, .left), + (.red, .right)} + meets_color color := by + cases color + · exact ⟨.root, by simp⟩ + · exact ⟨.root, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color + · cases label + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .right⟩ + · by_cases hroot : label = .root + · exact ⟨x, hx_zero, hx_R.trans hR_one⟩ + · exact ⟨R - x, sub_nonneg.mpr hx_R, by linarith⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · have hi' : li = .root ∨ li = blueLabel := by simpa using hi + have hj' : lj = .root ∨ lj = blueLabel := by simpa using hj + rcases hi' with rfl | rfl <;> rcases hj' with rfl | rfl + · exact (hij (Subtype.ext rfl)).elim + · dsimp + rw [hRdist] + simp [hblueLabel] + · dsimp + rw [dist_comm, hRdist] + simp [hblueLabel] + · exact (hij (Subtype.ext rfl)).elim + +/-- The virtual diameter of supports `37` and `57` is the root-edge split diameter. -/ +theorem redRootEdgeBlueTrianglePacking_virtualDiameter + (configuration : SixPointConfiguration) (redLabel : SixPointLabel) + (hredLabel : redLabel ≠ .root) {R M x : ℝ} + (hRdist : dist (configuration .red .root) (configuration .red redLabel) = R) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hR_one : R ≤ 1) (hM : 1 ≤ M) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + (redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist hR_one hx_zero hx_R + hblueLeft hblueRight).virtualDiameter = + rootEdgeSplitDiameter R M x (redRootBlueTriangleReach configuration) + (redChildBlueTriangleReach configuration redLabel) := by + let packing := redRootEdgeBlueTrianglePacking configuration redLabel hredLabel hRdist + hR_one hx_zero hx_R hblueLeft hblueRight + let target := rootEdgeSplitDiameter R M x (redRootBlueTriangleReach configuration) + (redChildBlueTriangleReach configuration redLabel) + have hredDist (leftLabel rightLabel : SixPointLabel) + (hleft : (.red, leftLabel) ∈ packing.support) + (hright : (.red, rightLabel) ∈ packing.support) : + dist (configuration .red leftLabel) (configuration .red rightLabel) ≤ M := by + have hleft' : leftLabel = .root ∨ leftLabel = redLabel := by + simpa [packing, redRootEdgeBlueTrianglePacking] using hleft + have hright' : rightLabel = .root ∨ rightLabel = redLabel := by + simpa [packing, redRootEdgeBlueTrianglePacking] using hright + rcases hleft' with hleft' | hleft' <;> rcases hright' with hright' | hright' + · subst leftLabel + subst rightLabel + simpa using (show (0 : ℝ) ≤ M by linarith) + · subst leftLabel + subst rightLabel + linarith + · subst leftLabel + subst rightLabel + rw [dist_comm] + linarith + · subst leftLabel + subst rightLabel + simpa using (show (0 : ℝ) ≤ M by linarith) + have hblueDist (leftLabel rightLabel : SixPointLabel) : + dist (configuration .blue leftLabel) (configuration .blue rightLabel) ≤ M := by + cases leftLabel <;> cases rightLabel + · simpa using (show (0 : ℝ) ≤ M by linarith) + · exact hblueLeft.trans hM + · exact hblueRight.trans hM + · simpa [dist_comm] using hblueLeft.trans hM + · simpa using (show (0 : ℝ) ≤ M by linarith) + · rw [hMdist] + · simpa [dist_comm] using hblueRight.trans hM + · rw [dist_comm, hMdist] + · simpa using (show (0 : ℝ) ≤ M by linarith) + have htwoM : 2 * M ≤ target := le_max_left _ _ + have hcrossRoot : + x + triangleMaximum (redRootBlueTriangleReach configuration) ≤ target := + le_max_of_le_right (le_max_left _ _) + have hcrossChild : + R - x + triangleMaximum (redChildBlueTriangleReach configuration redLabel) ≤ target := + le_max_of_le_right (le_max_right _ _) + have hrootRadius (hmem : (.red, .root) ∈ packing.support) : + (packing.radius ⟨(.red, .root), hmem⟩ : ℝ) = x := by rfl + have hchildRadius (hmem : (.red, redLabel) ∈ packing.support) : + (packing.radius ⟨(.red, redLabel), hmem⟩ : ℝ) = R - x := by + simp [packing, redRootEdgeBlueTrianglePacking, hredLabel] + have hblueRadius (label : SixPointLabel) (hmem : (.blue, label) ∈ packing.support) : + (packing.radius ⟨(.blue, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label := by + cases label <;> rfl + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · exact (same_color_pair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hM + (hredDist leftLabel rightLabel hleft hright)).trans htwoM + · have hlabel : leftLabel = .root ∨ leftLabel = redLabel := by + simpa [packing, redRootEdgeBlueTrianglePacking] using hleft + rcases hlabel with hlabel | hlabel + · subst leftLabel + rw [hrootRadius hleft, hblueRadius rightLabel hright] + have hreach := le_triangleMaximum (redRootBlueTriangleReach configuration) rightLabel + simp only [redRootBlueTriangleReach] at hreach + nlinarith + · subst leftLabel + rw [hchildRadius hleft, hblueRadius rightLabel hright] + have hreach := + le_triangleMaximum (redChildBlueTriangleReach configuration redLabel) rightLabel + simp only [redChildBlueTriangleReach] at hreach + nlinarith + · have hlabel : rightLabel = .root ∨ rightLabel = redLabel := by + simpa [packing, redRootEdgeBlueTrianglePacking] using hright + rcases hlabel with hlabel | hlabel + · subst rightLabel + rw [hblueRadius leftLabel hleft, hrootRadius hright, dist_comm] + have hreach := le_triangleMaximum (redRootBlueTriangleReach configuration) leftLabel + simp only [redRootBlueTriangleReach] at hreach + nlinarith + · subst rightLabel + rw [hblueRadius leftLabel hleft, hchildRadius hright, dist_comm] + have hreach := + le_triangleMaximum (redChildBlueTriangleReach configuration redLabel) leftLabel + simp only [redChildBlueTriangleReach] at hreach + nlinarith + · exact (same_color_pair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hM + (hblueDist leftLabel rightLabel)).trans htwoM + apply le_antisymm + · unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + · let redRoot : packing.support := ⟨(.red, .root), by + simp [packing, redRootEdgeBlueTrianglePacking]⟩ + let redChild : packing.support := ⟨(.red, redLabel), by + simp [packing, redRootEdgeBlueTrianglePacking]⟩ + let blueLeft : packing.support := ⟨(.blue, .left), by + simp [packing, redRootEdgeBlueTrianglePacking]⟩ + let blueRight : packing.support := ⟨(.blue, .right), by + simp [packing, redRootEdgeBlueTrianglePacking]⟩ + have hdiameterM : 2 * M ≤ packing.virtualDiameter := by + have hpairM := packing.pair_le_virtualDiameter blueLeft blueRight + rw [hblueRadius .left blueLeft.property, hblueRadius .right blueRight.property, + hMdist] at hpairM + nlinarith [canonicalTriangleRadius_left_add_right (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right)] + have hrootPoint (label : SixPointLabel) : + redRootBlueTriangleReach configuration label + x ≤ packing.virtualDiameter := by + let blue : packing.support := ⟨(.blue, label), by + cases label <;> simp [packing, redRootEdgeBlueTrianglePacking]⟩ + have hpairRoot := packing.pair_le_virtualDiameter redRoot blue + rw [hrootRadius redRoot.property, hblueRadius label blue.property] at hpairRoot + simp only [redRootBlueTriangleReach] + linarith + have hchildPoint (label : SixPointLabel) : + redChildBlueTriangleReach configuration redLabel label + (R - x) ≤ + packing.virtualDiameter := by + let blue : packing.support := ⟨(.blue, label), by + cases label <;> simp [packing, redRootEdgeBlueTrianglePacking]⟩ + have hpairChild := packing.pair_le_virtualDiameter redChild blue + rw [hchildRadius redChild.property, hblueRadius label blue.property] at hpairChild + simp only [redChildBlueTriangleReach] + linarith + have hdiameterRoot : + x + triangleMaximum (redRootBlueTriangleReach configuration) ≤ + packing.virtualDiameter := by + simp only [triangleMaximum, add_max, max_le_iff] + exact ⟨by nlinarith [hrootPoint .root], by nlinarith [hrootPoint .left], + by nlinarith [hrootPoint .right]⟩ + have hdiameterChild : + R - x + triangleMaximum (redChildBlueTriangleReach configuration redLabel) ≤ + packing.virtualDiameter := by + rw [show R - x + triangleMaximum (redChildBlueTriangleReach configuration redLabel) = + triangleMaximum (redChildBlueTriangleReach configuration redLabel) + (R - x) by ring] + simp only [triangleMaximum, max_add, max_le_iff] + exact ⟨hchildPoint .root, hchildPoint .left, hchildPoint .right⟩ + simp only [rootEdgeSplitDiameter, rootEdgeCrossMaximum, max_le_iff] + exact ⟨hdiameterM, hdiameterRoot, hdiameterChild⟩ + +/-- The total radius of a blue root-edge packing is its edge length plus a semiperimeter. -/ +theorem blueRootEdgeRedTrianglePacking_totalRadius + (configuration : SixPointConfiguration) (blueLabel : SixPointLabel) + (hblueLabel : blueLabel ≠ .root) {R x : ℝ} + (hRdist : dist (configuration .blue .root) (configuration .blue blueLabel) = R) + (hR_one : R ≤ 1) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + (blueRootEdgeRedTrianglePacking configuration blueLabel hblueLabel hRdist hR_one hx_zero hx_R + hredLeft hredRight).totalRadius = R + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2 := by + let packing := blueRootEdgeRedTrianglePacking configuration blueLabel hblueLabel hRdist + hR_one hx_zero hx_R hredLeft hredRight + let value : SixPointIndex → ℝ + | (.red, label) => canonicalTriangleRadius (configuration .red .root) + (configuration .red .left) (configuration .red .right) label + | (.blue, .root) => x + | (.blue, label) => if label = blueLabel then R - x else 0 + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [blueRootEdgeRedTrianglePacking, value] at hi ⊢ <;> simp_all + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + cases blueLabel + · exact (hblueLabel rfl).elim + · simp [packing, blueRootEdgeRedTrianglePacking, value, canonicalTriangleRadius] + ring + · simp [packing, blueRootEdgeRedTrianglePacking, value, canonicalTriangleRadius] + ring + +/-- Cross reach from the blue root to a labelled red triangle ball. -/ +def blueRootRedTriangleReach (configuration : SixPointConfiguration) + (label : SixPointLabel) : ℝ := + dist (configuration .blue .root) (configuration .red label) + + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label + +/-- Cross reach from a blue child to a labelled red triangle ball. -/ +def blueChildRedTriangleReach (configuration : SixPointConfiguration) + (blueLabel redLabel : SixPointLabel) : ℝ := + dist (configuration .blue blueLabel) (configuration .red redLabel) + + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) redLabel + +/-- The virtual diameter of supports `73` and `75` is the root-edge split diameter. -/ +theorem blueRootEdgeRedTrianglePacking_virtualDiameter + (configuration : SixPointConfiguration) (blueLabel : SixPointLabel) + (hblueLabel : blueLabel ≠ .root) {R L x : ℝ} + (hRdist : dist (configuration .blue .root) (configuration .blue blueLabel) = R) + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hR_one : R ≤ 1) (hL : 1 ≤ L) (hx_zero : 0 ≤ x) (hx_R : x ≤ R) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + (blueRootEdgeRedTrianglePacking configuration blueLabel hblueLabel hRdist hR_one hx_zero hx_R + hredLeft hredRight).virtualDiameter = + rootEdgeSplitDiameter R L x (blueRootRedTriangleReach configuration) + (blueChildRedTriangleReach configuration blueLabel) := by + let packing := blueRootEdgeRedTrianglePacking configuration blueLabel hblueLabel hRdist + hR_one hx_zero hx_R hredLeft hredRight + let target := rootEdgeSplitDiameter R L x (blueRootRedTriangleReach configuration) + (blueChildRedTriangleReach configuration blueLabel) + have hblueDist (leftLabel rightLabel : SixPointLabel) + (hleft : (.blue, leftLabel) ∈ packing.support) + (hright : (.blue, rightLabel) ∈ packing.support) : + dist (configuration .blue leftLabel) (configuration .blue rightLabel) ≤ L := by + have hleft' : leftLabel = .root ∨ leftLabel = blueLabel := by + simpa [packing, blueRootEdgeRedTrianglePacking] using hleft + have hright' : rightLabel = .root ∨ rightLabel = blueLabel := by + simpa [packing, blueRootEdgeRedTrianglePacking] using hright + rcases hleft' with hleft' | hleft' <;> rcases hright' with hright' | hright' + · subst leftLabel + subst rightLabel + simpa using (show (0 : ℝ) ≤ L by linarith) + · subst leftLabel + subst rightLabel + linarith + · subst leftLabel + subst rightLabel + rw [dist_comm] + linarith + · subst leftLabel + subst rightLabel + simpa using (show (0 : ℝ) ≤ L by linarith) + have hredDist (leftLabel rightLabel : SixPointLabel) : + dist (configuration .red leftLabel) (configuration .red rightLabel) ≤ L := by + cases leftLabel <;> cases rightLabel + · simpa using (show (0 : ℝ) ≤ L by linarith) + · exact hredLeft.trans hL + · exact hredRight.trans hL + · simpa [dist_comm] using hredLeft.trans hL + · simpa using (show (0 : ℝ) ≤ L by linarith) + · rw [hLdist] + · simpa [dist_comm] using hredRight.trans hL + · rw [dist_comm, hLdist] + · simpa using (show (0 : ℝ) ≤ L by linarith) + have htwoL : 2 * L ≤ target := le_max_left _ _ + have hcrossRoot : + x + triangleMaximum (blueRootRedTriangleReach configuration) ≤ target := + le_max_of_le_right (le_max_left _ _) + have hcrossChild : + R - x + triangleMaximum (blueChildRedTriangleReach configuration blueLabel) ≤ target := + le_max_of_le_right (le_max_right _ _) + have hrootRadius (hmem : (.blue, .root) ∈ packing.support) : + (packing.radius ⟨(.blue, .root), hmem⟩ : ℝ) = x := by rfl + have hchildRadius (hmem : (.blue, blueLabel) ∈ packing.support) : + (packing.radius ⟨(.blue, blueLabel), hmem⟩ : ℝ) = R - x := by + simp [packing, blueRootEdgeRedTrianglePacking, hblueLabel] + have hredRadius (label : SixPointLabel) (hmem : (.red, label) ∈ packing.support) : + (packing.radius ⟨(.red, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label := by + cases label <;> rfl + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · exact (same_color_pair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hL + (hredDist leftLabel rightLabel)).trans htwoL + · have hlabel : rightLabel = .root ∨ rightLabel = blueLabel := by + simpa [packing, blueRootEdgeRedTrianglePacking] using hright + rcases hlabel with hlabel | hlabel + · subst rightLabel + rw [hredRadius leftLabel hleft, hrootRadius hright, dist_comm] + have hreach := le_triangleMaximum (blueRootRedTriangleReach configuration) leftLabel + simp only [blueRootRedTriangleReach] at hreach + nlinarith + · subst rightLabel + rw [hredRadius leftLabel hleft, hchildRadius hright, dist_comm] + have hreach := + le_triangleMaximum (blueChildRedTriangleReach configuration blueLabel) leftLabel + simp only [blueChildRedTriangleReach] at hreach + nlinarith + · have hlabel : leftLabel = .root ∨ leftLabel = blueLabel := by + simpa [packing, blueRootEdgeRedTrianglePacking] using hleft + rcases hlabel with hlabel | hlabel + · subst leftLabel + rw [hrootRadius hleft, hredRadius rightLabel hright] + have hreach := le_triangleMaximum (blueRootRedTriangleReach configuration) rightLabel + simp only [blueRootRedTriangleReach] at hreach + nlinarith + · subst leftLabel + rw [hchildRadius hleft, hredRadius rightLabel hright] + have hreach := + le_triangleMaximum (blueChildRedTriangleReach configuration blueLabel) rightLabel + simp only [blueChildRedTriangleReach] at hreach + nlinarith + · exact (same_color_pair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hL + (hblueDist leftLabel rightLabel hleft hright)).trans htwoL + apply le_antisymm + · unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + · let blueRoot : packing.support := ⟨(.blue, .root), by + simp [packing, blueRootEdgeRedTrianglePacking]⟩ + let blueChild : packing.support := ⟨(.blue, blueLabel), by + simp [packing, blueRootEdgeRedTrianglePacking]⟩ + let redLeft : packing.support := ⟨(.red, .left), by + simp [packing, blueRootEdgeRedTrianglePacking]⟩ + let redRight : packing.support := ⟨(.red, .right), by + simp [packing, blueRootEdgeRedTrianglePacking]⟩ + have hdiameterL : 2 * L ≤ packing.virtualDiameter := by + have hpairL := packing.pair_le_virtualDiameter redLeft redRight + rw [hredRadius .left redLeft.property, hredRadius .right redRight.property, + hLdist] at hpairL + nlinarith [canonicalTriangleRadius_left_add_right (configuration .red .root) + (configuration .red .left) (configuration .red .right)] + have hrootPoint (label : SixPointLabel) : + blueRootRedTriangleReach configuration label + x ≤ packing.virtualDiameter := by + let red : packing.support := ⟨(.red, label), by + cases label <;> simp [packing, blueRootEdgeRedTrianglePacking]⟩ + have hpairRoot := packing.pair_le_virtualDiameter blueRoot red + rw [hrootRadius blueRoot.property, hredRadius label red.property] at hpairRoot + simp only [blueRootRedTriangleReach] + linarith + have hchildPoint (label : SixPointLabel) : + blueChildRedTriangleReach configuration blueLabel label + (R - x) ≤ + packing.virtualDiameter := by + let red : packing.support := ⟨(.red, label), by + cases label <;> simp [packing, blueRootEdgeRedTrianglePacking]⟩ + have hpairChild := packing.pair_le_virtualDiameter blueChild red + rw [hchildRadius blueChild.property, hredRadius label red.property] at hpairChild + simp only [blueChildRedTriangleReach] + linarith + have hdiameterRoot : + x + triangleMaximum (blueRootRedTriangleReach configuration) ≤ + packing.virtualDiameter := by + simp only [triangleMaximum, add_max, max_le_iff] + exact ⟨by nlinarith [hrootPoint .root], by nlinarith [hrootPoint .left], + by nlinarith [hrootPoint .right]⟩ + have hdiameterChild : + R - x + triangleMaximum (blueChildRedTriangleReach configuration blueLabel) ≤ + packing.virtualDiameter := by + rw [show R - x + triangleMaximum (blueChildRedTriangleReach configuration blueLabel) = + triangleMaximum (blueChildRedTriangleReach configuration blueLabel) + (R - x) by ring] + simp only [triangleMaximum, max_add, max_le_iff] + exact ⟨hchildPoint .root, hchildPoint .left, hchildPoint .right⟩ + simp only [rootEdgeSplitDiameter, rootEdgeCrossMaximum, max_le_iff] + exact ⟨hdiameterL, hdiameterRoot, hdiameterChild⟩ + +private def twoPointGain (A rho : ℝ) : ℝ := A / rho + +private def twoPointUpper (c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ : ℝ) : ℝ := + A₁ / (2 * rho₁) * (1 + rho₁ ^ 2 + 4 * t₁ ^ 2) + + A₂ / (2 * rho₂) * (1 + rho₂ ^ 2 + 4 * t₂ ^ 2) + sigma + + (((twoPointGain A₁ rho₁ + twoPointGain A₂ rho₂) * + (twoPointGain A₁ rho₁ * t₁ ^ 2 + twoPointGain A₂ rho₂ * t₂ ^ 2) - + twoPointGain A₁ rho₁ * twoPointGain A₂ rho₂ * c ^ 2) / sigma) - + d₁ * t₁ - d₂ * t₂ + +private theorem twoPointTangent_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x₁ x₂ : E) {c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ : ℝ} + (he : ‖e‖ = 1) (hseparation : c ≤ ‖x₁ - x₂‖) (hc : 0 ≤ c) + (hA₁ : 0 ≤ A₁) (hA₂ : 0 ≤ A₂) (hrho₁ : 0 < rho₁) (hrho₂ : 0 < rho₂) + (hsigma : 0 < sigma) : + A₁ * ‖e - (2 : ℝ) • x₁‖ + A₂ * ‖e - (2 : ℝ) • x₂‖ - + d₁ * ‖x₁‖ - d₂ * ‖x₂‖ ≤ + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ ‖x₁‖ ‖x₂‖ := by + let g₁ := twoPointGain A₁ rho₁ + let g₂ := twoPointGain A₂ rho₂ + have hg₁ : 0 ≤ g₁ := div_nonneg hA₁ hrho₁.le + have hg₂ : 0 ≤ g₂ := div_nonneg hA₂ hrho₂.le + have htangent₁ : A₁ * ‖e - (2 : ℝ) • x₁‖ ≤ + A₁ / (2 * rho₁) * (‖e - (2 : ℝ) • x₁‖ ^ 2 + rho₁ ^ 2) := by + have h := mul_le_mul_of_nonneg_left (norm_tangent (e - (2 : ℝ) • x₁) hrho₁) hA₁ + calc + _ ≤ _ := h + _ = _ := by ring + have htangent₂ : A₂ * ‖e - (2 : ℝ) • x₂‖ ≤ + A₂ / (2 * rho₂) * (‖e - (2 : ℝ) • x₂‖ ^ 2 + rho₂ ^ 2) := by + have h := mul_le_mul_of_nonneg_left (norm_tangent (e - (2 : ℝ) • x₂) hrho₂) hA₂ + calc + _ ≤ _ := h + _ = _ := by ring + have hsquare (x : E) : ‖e - (2 : ℝ) • x‖ ^ 2 = + 1 + 4 * ‖x‖ ^ 2 - 4 * ⟪e, x⟫_ℝ := by + rw [norm_sub_sq_real] + simp only [he, one_pow, norm_smul, Real.norm_eq_abs, abs_of_nonneg (by norm_num : + (0 : ℝ) ≤ 2), real_inner_smul_right] + ring + let u := g₁ • x₁ + g₂ • x₂ + have hsep_sq : c ^ 2 ≤ ‖x₁ - x₂‖ ^ 2 := by + nlinarith [norm_nonneg (x₁ - x₂)] + have hu_sq : ‖u‖ ^ 2 ≤ + (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - g₁ * g₂ * c ^ 2 := by + rw [show ‖u‖ ^ 2 = + (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - + g₁ * g₂ * ‖x₁ - x₂‖ ^ 2 by + exact weighted_norm_sq x₁ x₂ hg₁ hg₂] + exact sub_le_sub_left (mul_le_mul_of_nonneg_left hsep_sq (mul_nonneg hg₁ hg₂)) _ + have horientation : -2 * ⟪e, u⟫_ℝ ≤ sigma + ‖u‖ ^ 2 / sigma := by + have hinner := real_inner_le_norm (-e) u + simp only [inner_neg_left, norm_neg, he, one_mul] at hinner + have hnorm : 2 * ‖u‖ ≤ sigma + ‖u‖ ^ 2 / sigma := by + have h := norm_tangent u hsigma + rw [show (‖u‖ ^ 2 + sigma ^ 2) / (2 * sigma) = + (sigma + ‖u‖ ^ 2 / sigma) / 2 by field_simp; ring] at h + linarith + nlinarith + have hu_scaled := (div_le_div_iff_of_pos_right hsigma).2 hu_sq + have htangentSum := add_le_add htangent₁ htangent₂ + rw [hsquare x₁, hsquare x₂] at htangentSum + have htangentSum' : + A₁ * ‖e - (2 : ℝ) • x₁‖ + A₂ * ‖e - (2 : ℝ) • x₂‖ ≤ + A₁ / (2 * rho₁) * (1 + rho₁ ^ 2 + 4 * ‖x₁‖ ^ 2) + + A₂ / (2 * rho₂) * (1 + rho₂ ^ 2 + 4 * ‖x₂‖ ^ 2) - + 2 * (twoPointGain A₁ rho₁ * ⟪e, x₁⟫_ℝ + + twoPointGain A₂ rho₂ * ⟪e, x₂⟫_ℝ) := by + calc + _ ≤ _ := htangentSum + _ = _ := by + simp only [twoPointGain] + field_simp [ne_of_gt hrho₁, ne_of_gt hrho₂] + ring + dsimp only [u, g₁, g₂] at horientation hu_scaled ⊢ + simp only [inner_add_right, real_inner_smul_right] at horientation + have horientationBound : + -2 * (twoPointGain A₁ rho₁ * ⟪e, x₁⟫_ℝ + + twoPointGain A₂ rho₂ * ⟪e, x₂⟫_ℝ) ≤ + sigma + + ((twoPointGain A₁ rho₁ + twoPointGain A₂ rho₂) * + (twoPointGain A₁ rho₁ * ‖x₁‖ ^ 2 + + twoPointGain A₂ rho₂ * ‖x₂‖ ^ 2) - + twoPointGain A₁ rho₁ * twoPointGain A₂ rho₂ * c ^ 2) / sigma := by + exact horientation.trans (add_le_add_right hu_scaled sigma) + simp only [twoPointGain] at htangentSum' horientationBound + simp only [twoPointUpper, twoPointGain] at ⊢ + linarith + +private def twoPointQuadratic1 (A₁ A₂ rho₁ rho₂ sigma : ℝ) : ℝ := + 2 * A₁ / rho₁ + + (twoPointGain A₁ rho₁ + twoPointGain A₂ rho₂) * twoPointGain A₁ rho₁ / sigma + +private def twoPointQuadratic2 (A₁ A₂ rho₁ rho₂ sigma : ℝ) : ℝ := + 2 * A₂ / rho₂ + + (twoPointGain A₁ rho₁ + twoPointGain A₂ rho₂) * twoPointGain A₂ rho₂ / sigma + +private def twoPointBase (c A₁ A₂ rho₁ rho₂ sigma : ℝ) : ℝ := + A₁ / (2 * rho₁) * (1 + rho₁ ^ 2) + A₂ / (2 * rho₂) * (1 + rho₂ ^ 2) + + sigma - twoPointGain A₁ rho₁ * twoPointGain A₂ rho₂ * c ^ 2 / sigma + +private theorem twoPointUpper_eq_quadratic + (c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ : ℝ) : + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ = + twoPointBase c A₁ A₂ rho₁ rho₂ sigma + + twoPointQuadratic1 A₁ A₂ rho₁ rho₂ sigma * t₁ ^ 2 + + twoPointQuadratic2 A₁ A₂ rho₁ rho₂ sigma * t₂ ^ 2 - + d₁ * t₁ - d₂ * t₂ := by + simp only [twoPointUpper, twoPointBase, twoPointQuadratic1, twoPointQuadratic2, + twoPointGain] + ring + +private theorem twoPointUpper_le_vertices + {c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ : ℝ} + (hquadratic1 : 0 ≤ twoPointQuadratic1 A₁ A₂ rho₁ rho₂ sigma) + (hquadratic2 : 0 ≤ twoPointQuadratic2 A₁ A₂ rho₁ rho₂ sigma) + (ht₁_one : t₁ ≤ 1) (ht₂_one : t₂ ≤ 1) (hsum : c ≤ t₁ + t₂) : + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ ≤ + max (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ 1 1) + (max (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ 1 (c - 1)) + (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ (c - 1) 1)) := by + have ht₁_lower : c - 1 ≤ t₁ := by linarith + have ht₂_lower : c - 1 ≤ t₂ := by linarith + have hsecond : + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ t₂ ≤ + max (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ (c - t₁)) + (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ 1) := by + have h := quadratic_le_max_endpoints hquadratic2 + (show c - t₁ ≤ t₂ by linarith) ht₂_one (b := -d₂) + (d := twoPointBase c A₁ A₂ rho₁ rho₂ sigma + + twoPointQuadratic1 A₁ A₂ rho₁ rho₂ sigma * t₁ ^ 2 - d₁ * t₁) + rw [twoPointUpper_eq_quadratic, twoPointUpper_eq_quadratic, + twoPointUpper_eq_quadratic] + convert h using 1 <;> ring_nf + have hdiagonal : + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ (c - t₁) ≤ + max (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ (c - 1) 1) + (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ 1 (c - 1)) := by + have h := quadratic_le_max_endpoints (add_nonneg hquadratic1 hquadratic2) + ht₁_lower ht₁_one + (b := -2 * twoPointQuadratic2 A₁ A₂ rho₁ rho₂ sigma * c - d₁ + d₂) + (d := twoPointBase c A₁ A₂ rho₁ rho₂ sigma + + twoPointQuadratic2 A₁ A₂ rho₁ rho₂ sigma * c ^ 2 - d₂ * c) + rw [twoPointUpper_eq_quadratic, twoPointUpper_eq_quadratic, + twoPointUpper_eq_quadratic] + convert h using 1 <;> ring_nf + have htop : + twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ t₁ 1 ≤ + max (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ (c - 1) 1) + (twoPointUpper c A₁ A₂ rho₁ rho₂ sigma d₁ d₂ 1 1) := by + have h := quadratic_le_max_endpoints hquadratic1 ht₁_lower ht₁_one (b := -d₁) + (d := twoPointBase c A₁ A₂ rho₁ rho₂ sigma + + twoPointQuadratic2 A₁ A₂ rho₁ rho₂ sigma - d₂) + rw [twoPointUpper_eq_quadratic, twoPointUpper_eq_quadratic, + twoPointUpper_eq_quadratic] + convert h using 1 <;> ring_nf + refine hsecond.trans (max_le ?_ ?_) + · exact hdiagonal.trans <| max_le + (le_max_right _ _ |>.trans <| le_max_right _ _) + (le_max_left _ _ |>.trans <| le_max_right _ _) + · exact htop.trans <| max_le + (le_max_right _ _ |>.trans <| le_max_right _ _) + (le_max_left _ _) + +private def redPointUpper (c t₁ t₂ : ℝ) : ℝ := + twoPointUpper c (25 / 2) (19 / 2) (14 / 5) (7 / 4) (407 / 100) 0 (24 * c) t₁ t₂ + +private def bluePointUpper (c t₁ t₂ : ℝ) : ℝ := + twoPointUpper c (25 / 2) (19 / 2) (113 / 40) (213 / 100) (24 / 5) + (15 * c - 3) (15 * c + 3) t₁ t₂ + +private def redPointVertex0 (c : ℝ) : ℝ := + 627494429 / 7977200 - 24 * c - 118750 / 19943 * c ^ 2 + +private def redPointVertex1 (c : ℝ) : ℝ := + 627494429 / 7977200 - 480716 / 19943 * c - 117708 / 19943 * c ^ 2 + +private def redPointVertex2 (c : ℝ) : ℝ := + 627494429 / 7977200 - 2535139 / 39886 * c + 1102875 / 79772 * c ^ 2 + +private def bluePointVertex0 (c : ℝ) : ℝ := + 99038091574697 / 1390360226400 - 30 * c - 296875 / 72207 * c ^ 2 + +private def bluePointVertex1 (c : ℝ) : ℝ := + 107380252933097 / 1390360226400 - 574473748 / 15380091 * c - + 526885 / 272214 * c ^ 2 + +private def bluePointVertex2 (c : ℝ) : ℝ := + 90695930216297 / 1390360226400 - 253592077 / 8159391 * c - + 79355 / 38307 * c ^ 2 + +private theorem redPointUpper_vertices (c : ℝ) : + redPointUpper c 1 1 = redPointVertex0 c ∧ + redPointUpper c 1 (c - 1) = redPointVertex1 c ∧ + redPointUpper c (c - 1) 1 = redPointVertex2 c := by + norm_num [redPointUpper, redPointVertex0, redPointVertex1, redPointVertex2, + twoPointUpper, twoPointGain] + constructor + · ring + constructor <;> ring + +private theorem bluePointUpper_vertices (c : ℝ) : + bluePointUpper c 1 1 = bluePointVertex0 c ∧ + bluePointUpper c 1 (c - 1) = bluePointVertex1 c ∧ + bluePointUpper c (c - 1) 1 = bluePointVertex2 c := by + norm_num [bluePointUpper, bluePointVertex0, bluePointVertex1, bluePointVertex2, + twoPointUpper, twoPointGain] + constructor + · ring + constructor <;> ring + +private theorem redPointVertex_dominates : + redPointVertex1 barC < redPointVertex0 barC ∧ + redPointVertex2 barC < redPointVertex0 barC := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [redPointVertex0, redPointVertex1, redPointVertex2] at hlower hupper ⊢ + constructor <;> nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + +private theorem bluePointVertex_dominates : + bluePointVertex1 barC < bluePointVertex0 barC ∧ + bluePointVertex2 barC < bluePointVertex0 barC := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [bluePointVertex0, bluePointVertex1, bluePointVertex2] at hlower hupper ⊢ + constructor <;> nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + +private theorem redPointUpper_le_vertex0 {t₁ t₂ : ℝ} (ht₁ : t₁ ≤ 1) (ht₂ : t₂ ≤ 1) + (hsum : barC ≤ t₁ + t₂) : redPointUpper barC t₁ t₂ ≤ redPointVertex0 barC := by + have hvertices := twoPointUpper_le_vertices + (c := barC) (A₁ := 25 / 2) (A₂ := 19 / 2) (rho₁ := 14 / 5) (rho₂ := 7 / 4) + (sigma := 407 / 100) (d₁ := 0) (d₂ := 24 * barC) (t₁ := t₁) (t₂ := t₂) + (by norm_num [twoPointQuadratic1, twoPointGain]) + (by norm_num [twoPointQuadratic2, twoPointGain]) ht₁ ht₂ hsum + rw [← redPointUpper, ← redPointUpper, ← redPointUpper, ← redPointUpper] at hvertices + rw [redPointUpper_vertices barC |>.1, redPointUpper_vertices barC |>.2.1, + redPointUpper_vertices barC |>.2.2] at hvertices + exact hvertices.trans <| max_le (le_rfl) <| max_le + redPointVertex_dominates.1.le redPointVertex_dominates.2.le + +private theorem bluePointUpper_le_vertex0 {t₁ t₂ : ℝ} (ht₁ : t₁ ≤ 1) + (ht₂ : t₂ ≤ 1) (hsum : barC ≤ t₁ + t₂) : + bluePointUpper barC t₁ t₂ ≤ bluePointVertex0 barC := by + have hvertices := twoPointUpper_le_vertices + (c := barC) (A₁ := 25 / 2) (A₂ := 19 / 2) (rho₁ := 113 / 40) + (rho₂ := 213 / 100) (sigma := 24 / 5) (d₁ := 15 * barC - 3) + (d₂ := 15 * barC + 3) (t₁ := t₁) (t₂ := t₂) + (by norm_num [twoPointQuadratic1, twoPointGain]) + (by norm_num [twoPointQuadratic2, twoPointGain]) ht₁ ht₂ hsum + rw [← bluePointUpper, ← bluePointUpper, ← bluePointUpper, ← bluePointUpper] at hvertices + rw [bluePointUpper_vertices barC |>.1, bluePointUpper_vertices barC |>.2.1, + bluePointUpper_vertices barC |>.2.2] at hvertices + exact hvertices.trans <| max_le (le_rfl) <| max_le + bluePointVertex_dominates.1.le bluePointVertex_dominates.2.le + +private theorem redPointTangent_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ : E) (he : ‖e‖ = 1) (hp₁ : ‖p₁‖ ≤ 1) + (hp₂ : ‖p₂‖ ≤ 1) (hseparation : barC ≤ ‖p₁ - p₂‖) : + (25 / 2) * ‖e - (2 : ℝ) • p₁‖ + (19 / 2) * ‖e - (2 : ℝ) • p₂‖ - + 24 * barC * ‖p₂‖ ≤ redPointVertex0 barC := by + have htangent := twoPointTangent_le e p₁ p₂ (c := barC) (A₁ := 25 / 2) + (A₂ := 19 / 2) (rho₁ := 14 / 5) (rho₂ := 7 / 4) (sigma := 407 / 100) + (d₁ := 0) (d₂ := 24 * barC) he hseparation barC_pos.le + (by norm_num) (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hsum : barC ≤ ‖p₁‖ + ‖p₂‖ := + hseparation.trans (norm_sub_le p₁ p₂) + have hupper : redPointUpper barC ‖p₁‖ ‖p₂‖ ≤ redPointVertex0 barC := + redPointUpper_le_vertex0 hp₁ hp₂ hsum + simpa only [redPointUpper, zero_mul, sub_zero] using htangent.trans hupper + +private theorem bluePointTangent_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e w₁ w₂ : E) (he : ‖e‖ = 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hseparation : barC ≤ ‖w₁ - w₂‖) : + (25 / 2) * ‖e - (2 : ℝ) • w₁‖ + (19 / 2) * ‖e - (2 : ℝ) • w₂‖ - + (15 * barC - 3) * ‖w₁‖ - (15 * barC + 3) * ‖w₂‖ ≤ + bluePointVertex0 barC := by + have htangent := twoPointTangent_le e w₁ w₂ (c := barC) (A₁ := 25 / 2) + (A₂ := 19 / 2) (rho₁ := 113 / 40) (rho₂ := 213 / 100) (sigma := 24 / 5) + (d₁ := 15 * barC - 3) (d₂ := 15 * barC + 3) he hseparation barC_pos.le + (by norm_num) (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hsum : barC ≤ ‖w₁‖ + ‖w₂‖ := + hseparation.trans (norm_sub_le w₁ w₂) + refine htangent.trans ?_ + change bluePointUpper barC ‖w₁‖ ‖w₂‖ ≤ bluePointVertex0 barC + exact bluePointUpper_le_vertex0 hw₁ hw₂ hsum + +private theorem rootEdge_internal_polynomial_lt : + redPointVertex0 barC + bluePointVertex0 barC + + 95 * barC - 97 * barC ^ 2 - 6 < -5 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [redPointVertex0, bluePointVertex0] at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + +/-- Midpoint convexity splits a cross distance into one term for each color. -/ +theorem midpoint_crossDistance_le {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] + (e p w : E) : + ‖e - p - w‖ ≤ (‖e - (2 : ℝ) • p‖ + ‖e - (2 : ℝ) • w‖) / 2 := by + have heq : e - p - w = + (1 / 2 : ℝ) • ((e - (2 : ℝ) • p) + (e - (2 : ℝ) • w)) := by + module + calc + ‖e - p - w‖ = (1 / 2 : ℝ) * + ‖(e - (2 : ℝ) • p) + (e - (2 : ℝ) • w)‖ := by + rw [heq, norm_smul] + norm_num [Real.norm_eq_abs] + _ ≤ (1 / 2 : ℝ) * + (‖e - (2 : ℝ) • p‖ + ‖e - (2 : ℝ) • w‖) := + mul_le_mul_of_nonneg_left (norm_add_le _ _) (by norm_num) + _ = _ := by ring + +/-- The exact two-point tangent certificate for the root-edge internal separator. -/ +theorem rootEdge_internal_expanded_lt {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) + (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + 25 * ‖e - p₁ - w₁‖ + 19 * ‖e - p₂ - w₂‖ + + (3 - 15 * barC) * ‖w₁‖ - (15 * barC + 3) * ‖w₂‖ - + 24 * barC * ‖p₂‖ + 95 * barC - 97 * barC ^ 2 - 6 < 0 := by + have hmid₁ := midpoint_crossDistance_le e p₁ w₁ + have hmid₂ := midpoint_crossDistance_le e p₂ w₂ + have hred := redPointTangent_le e p₁ p₂ he hp₁ hp₂ hredSeparation + have hblue := bluePointTangent_le e w₁ w₂ he hw₁ hw₂ hblueSeparation + nlinarith [rootEdge_internal_polynomial_lt] + +/-- Failure slack for the diagonal four-child matching. -/ +def matchingFailureSlack (c L M B₁₁ B₂₂ : ℝ) : ℝ := + B₁₁ + B₂₂ - (2 * c - 1) * (L + M) + +/-- Failure slack for the red coincident endpoint on the first matching edge. -/ +def redEndpointFailureSlack (c L M b₁ b₂ B₁₁ : ℝ) : ℝ := + L - 1 + B₁₁ + (b₁ + M - b₂) / 2 - c * (L + (b₁ + b₂ + M) / 2) + +/-- Internal failure slack for the red root--second-child edge. -/ +def redRootEdgeInternalSlack (c M r₂ b₁ b₂ : ℝ) : ℝ := + 2 * M - c * (r₂ + (b₁ + b₂ + M) / 2) + +/-- Failure slack for the blue coincident endpoint on the first matching edge. -/ +def blueEndpointFailureSlack (c L M r₁ r₂ B₁₁ : ℝ) : ℝ := + M - 1 + B₁₁ + (r₁ + L - r₂) / 2 - c * (M + (r₁ + r₂ + L) / 2) + +/-- Internal failure slack for the blue root--second-child edge. -/ +def blueRootEdgeInternalSlack (c L b₂ r₁ r₂ : ℝ) : ℝ := + 2 * L - c * (b₂ + (r₁ + r₂ + L) / 2) + +/-- The internal root-edge slack has a strictly negative positive separator. -/ +theorem rootEdge_internal_separator_lt {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) + (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + 19 * matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖ + + 6 * redEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖w₁‖ ‖w₂‖ ‖e - p₁ - w₁‖ + + 24 * redRootEdgeInternalSlack barC ‖w₁ - w₂‖ ‖p₂‖ ‖w₁‖ ‖w₂‖ < + 0 := by + have hexpanded := rootEdge_internal_expanded_lt e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + have hcoefRed : 25 - 44 * barC ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hcoefBlue : 70 - 53 * barC ≤ 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + linarith + have hredTerm := mul_le_mul_of_nonpos_left hredSeparation hcoefRed + have hblueTerm := mul_le_mul_of_nonpos_left hblueSeparation hcoefBlue + simp only [matchingFailureSlack, redEndpointFailureSlack, redRootEdgeInternalSlack] + nlinarith + +/-- A matching and its coincident endpoint exclude the red internal root-edge failure. -/ +theorem redRootEdgeInternalSlack_neg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) + (hblueSeparation : barC ≤ ‖w₁ - w₂‖) + (hmatching : 0 ≤ matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖) + (hendpoint : 0 ≤ redEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖w₁‖ ‖w₂‖ ‖e - p₁ - w₁‖) : + redRootEdgeInternalSlack barC ‖w₁ - w₂‖ ‖p₂‖ ‖w₁‖ ‖w₂‖ < 0 := by + have hseparator := rootEdge_internal_separator_lt e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + nlinarith + +/-- The color-transposed internal root-edge slack has the same strict separator. -/ +theorem blueRootEdge_internal_separator_lt {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) + (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + 19 * matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖ + + 6 * blueEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖p₁‖ ‖p₂‖ ‖e - p₁ - w₁‖ + + 24 * blueRootEdgeInternalSlack barC ‖p₁ - p₂‖ ‖w₂‖ ‖p₁‖ ‖p₂‖ < + 0 := by + have hseparator := rootEdge_internal_separator_lt e w₁ w₂ p₁ p₂ he hw₁ hw₂ hp₁ hp₂ + hblueSeparation hredSeparation + have hcross₁ : e - w₁ - p₁ = e - p₁ - w₁ := by abel + have hcross₂ : e - w₂ - p₂ = e - p₂ - w₂ := by abel + rw [hcross₁, hcross₂] at hseparator + simp only [matchingFailureSlack, redEndpointFailureSlack, redRootEdgeInternalSlack, + blueEndpointFailureSlack, blueRootEdgeInternalSlack] at hseparator ⊢ + nlinarith + +/-- A matching and its coincident endpoint exclude the blue internal root-edge failure. -/ +theorem blueRootEdgeInternalSlack_neg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) + (hblueSeparation : barC ≤ ‖w₁ - w₂‖) + (hmatching : 0 ≤ matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖) + (hendpoint : 0 ≤ blueEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖p₁‖ ‖p₂‖ ‖e - p₁ - w₁‖) : + blueRootEdgeInternalSlack barC ‖p₁ - p₂‖ ‖w₂‖ ‖p₁‖ ‖p₂‖ < 0 := by + have hseparator := + blueRootEdge_internal_separator_lt e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + nlinarith + +/-- In an admissible configuration, a diagonal matching and its red coincident endpoint rule out +the red root-edge internal primitive. -/ +theorem SixPointConfiguration.redRootEdgeInternalSlack_neg_of_matching_endpoint + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : 0 ≤ matchingFailureSlack barC + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right))) + (hendpoint : 0 ≤ redEndpointFailureSlack barC + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .blue .root) (configuration .blue .left)) + (dist (configuration .blue .root) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .blue .left))) : + redRootEdgeInternalSlack barC + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .root) (configuration .red .right)) + (dist (configuration .blue .root) (configuration .blue .left)) + (dist (configuration .blue .root) (configuration .blue .right)) < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hL : ‖p₁ - p₂‖ = + dist (configuration .red .left) (configuration .red .right) := by + rw [← dist_eq_norm, configuration.dist_redDisplacement] + have hM : ‖w₁ - w₂‖ = + dist (configuration .blue .left) (configuration .blue .right) := by + rw [← dist_eq_norm, configuration.dist_bluePullback] + have hr₂ : ‖p₂‖ = dist (configuration .red .root) (configuration .red .right) := by + simp [p₂, SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hb₁ : ‖w₁‖ = dist (configuration .blue .root) (configuration .blue .left) := by + simp [w₁, SixPointConfiguration.bluePullback, dist_eq_norm] + have hb₂ : ‖w₂‖ = dist (configuration .blue .root) (configuration .blue .right) := by + simp [w₂, SixPointConfiguration.bluePullback, dist_eq_norm] + have hB₁₁ : ‖e - p₁ - w₁‖ = + dist (configuration .red .left) (configuration .blue .left) := by + exact (configuration.dist_red_blue_eq_norm .left .left).symm + have hB₂₂ : ‖e - p₂ - w₂‖ = + dist (configuration .red .right) (configuration .blue .right) := by + exact (configuration.dist_red_blue_eq_norm .right .right).symm + have hredSeparation : barC ≤ ‖p₁ - p₂‖ := by + have hsibling := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hblueSeparation : barC ≤ ‖w₁ - w₂‖ := by + have hsibling := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hnegative := redRootEdgeInternalSlack_neg e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hredSeparation hblueSeparation + (by simpa only [hL, hM, hB₁₁, hB₂₂] using hmatching) + (by simpa only [hL, hM, hb₁, hb₂, hB₁₁] using hendpoint) + simpa only [hM, hr₂, hb₁, hb₂] using hnegative + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/RootEdgeClosed.lean b/LeanPool/Besicovitch/SixPoint/RootEdgeClosed.lean new file mode 100644 index 0000000000..af6d4c9a72 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RootEdgeClosed.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.RootEdgeFailureTree +public import LeanPool.Besicovitch.SixPoint.RootEdgeType12 + +/-! +# Closing the root--edge failure stage + +The crossed `(1,2)` separator removes the second branch of each root--edge minimax. Thus the two +root--edge supports either provide a nonnegative packing or both select their `(1,1)` terms. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The selected matching and endpoint force a failed red root--edge support onto `(1,1)`. -/ +theorem redRootEdge_failure_forces_type11 + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hendpoint : redSiblingTriangleFailure configuration (.endpoint 0)) + (hfailure : RedRootEdgeFails configuration h) : + 2 * redRootEdgeTarget configuration < + dist (configuration .red .root) (configuration .red .right) + + redRootBlueTriangleReach configuration .left + + redChildBlueTriangleReach configuration .right .left := by + rcases redRootEdge_failure_routes_to_child_balanced h hmatching hendpoint hfailure with + htype11 | htype12 + · exact htype11 + · have hnegative := + configuration.redRootEdgeType12Slack_neg_of_matching_endpoint h hmatching hendpoint + simp only [redRootEdgeType12Slack] at hnegative + simp only [redRootEdgeTarget, rootedTriangleTotalRadius, redRootBlueTriangleReach, + redChildBlueTriangleReach, canonicalTriangleRadius] at htype12 + linarith + +/-- The selected matching and endpoint force a failed blue root--edge support onto `(1,1)`. -/ +theorem blueRootEdge_failure_forces_type11 + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hendpoint : blueSiblingTriangleFailure configuration (.endpoint 0)) + (hfailure : BlueRootEdgeFails configuration h) : + 2 * blueRootEdgeTarget configuration < + dist (configuration .blue .root) (configuration .blue .right) + + blueRootRedTriangleReach configuration .left + + blueChildRedTriangleReach configuration .right .left := by + rcases blueRootEdge_failure_routes_to_child_balanced h hmatching hendpoint hfailure with + htype11 | htype12 + · exact htype11 + · let transposed := transposeConfigurationColors configuration + have hnegative := + SixPointConfiguration.redRootEdgeType12Slack_neg_of_matching_endpoint transposed + (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) + ((redEndpointFailure_transposeColors configuration 0).2 hendpoint) + simp only [redRootEdgeType12Slack, transposed, transposeConfigurationColors] at hnegative + simp only [blueRootEdgeTarget, rootedTriangleTotalRadius, blueRootRedTriangleReach, + blueChildRedTriangleReach, canonicalTriangleRadius] at htype12 + rw [dist_comm (configuration .blue .right) (configuration .red .right)] at hnegative + rw [dist_comm (configuration .blue .right) (configuration .red .right)] at htype12 + linarith + +/-- The two root--edge supports either win or both leave the active `(1,1)` inequalities. -/ +theorem exists_nonnegative_score_or_rootEdge_type11_pair + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hredEndpoint : redSiblingTriangleFailure configuration (.endpoint 0)) + (hblueEndpoint : blueSiblingTriangleFailure configuration (.endpoint 0)) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + (2 * redRootEdgeTarget configuration < + dist (configuration .red .root) (configuration .red .right) + + redRootBlueTriangleReach configuration .left + + redChildBlueTriangleReach configuration .right .left ∧ + 2 * blueRootEdgeTarget configuration < + dist (configuration .blue .root) (configuration .blue .right) + + blueRootRedTriangleReach configuration .left + + blueChildRedTriangleReach configuration .right .left) := by + by_cases hred : RedRootEdgeFails configuration h + · by_cases hblue : BlueRootEdgeFails configuration h + · exact Or.inr ⟨redRootEdge_failure_forces_type11 h hmatching hredEndpoint hred, + blueRootEdge_failure_forces_type11 h hmatching hblueEndpoint hblue⟩ + · simp only [BlueRootEdgeFails, not_forall, not_lt] at hblue + obtain ⟨x, hxZero, hxEdge, hscore⟩ := hblue + exact Or.inl ⟨blueRootEdgePackingAtEndpoint configuration h x hxZero hxEdge, hscore⟩ + · simp only [RedRootEdgeFails, not_forall, not_lt] at hred + obtain ⟨x, hxZero, hxEdge, hscore⟩ := hred + exact Or.inl ⟨redRootEdgePackingAtEndpoint configuration h x hxZero hxEdge, hscore⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/RootEdgeFailureTree.lean b/LeanPool/Besicovitch/SixPoint/RootEdgeFailureTree.lean new file mode 100644 index 0000000000..e12245973a --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RootEdgeFailureTree.lean @@ -0,0 +1,557 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.RootEdge +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# The root--edge stage of the six-point failure tree + +After the sibling supports choose the coincident endpoint `B11`, the two root--edge supports use +the opposite children. This file connects their geometric packings to the root--edge minimax and +records the elementary reductions shared by the two color directions. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The endpoint diameter target for the red root--second-child support. -/ +def redRootEdgeTarget (configuration : SixPointConfiguration) : ℝ := + barC * (dist (configuration .red .root) (configuration .red .right) + + rootedTriangleTotalRadius configuration .blue) + +/-- The endpoint diameter target for the blue root--second-child support. -/ +def blueRootEdgeTarget (configuration : SixPointConfiguration) : ℝ := + barC * (dist (configuration .blue .root) (configuration .blue .right) + + rootedTriangleTotalRadius configuration .red) + +/-- Support `57`, with the red root--second-child radius split at `x`. -/ +def redRootEdgePackingAtEndpoint (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) (x : ℝ) + (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .red .root) (configuration .red .right)) : + SixPointPacking configuration := + redRootEdgeBlueTrianglePacking configuration .right (by simp) rfl + (h.child_distance .red .right (by simp)) hxZero hxEdge + (h.child_distance .blue .left (by simp)) (h.child_distance .blue .right (by simp)) + +/-- Support `75`, with the blue root--second-child radius split at `x`. -/ +def blueRootEdgePackingAtEndpoint (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) (x : ℝ) + (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .blue .root) (configuration .blue .right)) : + SixPointPacking configuration := + blueRootEdgeRedTrianglePacking configuration .right (by simp) rfl + (h.child_distance .blue .right (by simp)) hxZero hxEdge + (h.child_distance .red .left (by simp)) (h.child_distance .red .right (by simp)) + +/-- A feasible red root--edge split below its target gives nonnegative score. -/ +theorem redRootEdgePackingAtEndpoint_score_nonnegative + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) (x : ℝ) + (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .red .root) (configuration .red .right)) + (hdiameter : rootEdgeSplitDiameter + (dist (configuration .red .root) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x + (redRootBlueTriangleReach configuration) + (redChildBlueTriangleReach configuration .right) ≤ redRootEdgeTarget configuration) : + 0 ≤ (redRootEdgePackingAtEndpoint configuration h x hxZero hxEdge).score barS := by + have hblueOne : 1 ≤ dist (configuration .blue .left) (configuration .blue .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .blue).1 + simp only [redRootEdgePackingAtEndpoint, SixPointPacking.score] + rw [redRootEdgeBlueTrianglePacking_totalRadius, + redRootEdgeBlueTrianglePacking_virtualDiameter (hMdist := rfl) (hM := hblueOne)] + simp only [barS] + rw [show 2 * (barC / 2) = barC by ring] + rw [sub_nonneg, div_le_iff₀ barC_pos] + simpa [redRootEdgeTarget, rootedTriangleTotalRadius, mul_comm] using hdiameter + +/-- A feasible blue root--edge split below its target gives nonnegative score. -/ +theorem blueRootEdgePackingAtEndpoint_score_nonnegative + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) (x : ℝ) + (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .blue .root) (configuration .blue .right)) + (hdiameter : rootEdgeSplitDiameter + (dist (configuration .blue .root) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .red .right)) x + (blueRootRedTriangleReach configuration) + (blueChildRedTriangleReach configuration .right) ≤ blueRootEdgeTarget configuration) : + 0 ≤ (blueRootEdgePackingAtEndpoint configuration h x hxZero hxEdge).score barS := by + have hredOne : 1 ≤ dist (configuration .red .left) (configuration .red .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .red).1 + simp only [blueRootEdgePackingAtEndpoint, SixPointPacking.score] + rw [blueRootEdgeRedTrianglePacking_totalRadius, + blueRootEdgeRedTrianglePacking_virtualDiameter (hLdist := rfl) (hL := hredOne)] + simp only [barS] + rw [show 2 * (barC / 2) = barC by ring] + rw [sub_nonneg, div_le_iff₀ barC_pos] + simpa [blueRootEdgeTarget, rootedTriangleTotalRadius, mul_comm] using hdiameter + +/-- Every feasible split of support `57` has negative score. -/ +def RedRootEdgeFails (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) : Prop := + ∀ (x : ℝ) (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .red .root) (configuration .red .right)), + (redRootEdgePackingAtEndpoint configuration h x hxZero hxEdge).score barS < 0 + +/-- Every feasible split of support `75` has negative score. -/ +def BlueRootEdgeFails (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) : Prop := + ∀ (x : ℝ) (hxZero : 0 ≤ x) + (hxEdge : x ≤ dist (configuration .blue .root) (configuration .blue .right)), + (blueRootEdgePackingAtEndpoint configuration h x hxZero hxEdge).score barS < 0 + +/-- Failure of support `57` makes every feasible root--edge split exceed its target. -/ +theorem redRootEdge_split_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfailure : RedRootEdgeFails configuration h) : + ∀ (x : ℝ) (_hxZero : 0 ≤ x) + (_hxEdge : x ≤ dist (configuration .red .root) (configuration .red .right)), + redRootEdgeTarget configuration < rootEdgeSplitDiameter + (dist (configuration .red .root) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x + (redRootBlueTriangleReach configuration) + (redChildBlueTriangleReach configuration .right) := by + intro x hxZero hxEdge + exact lt_of_not_ge fun hdiameter ↦ + (not_lt_of_ge (redRootEdgePackingAtEndpoint_score_nonnegative configuration h x hxZero hxEdge + hdiameter)) (hfailure x hxZero hxEdge) + +/-- Failure of support `75` makes every feasible root--edge split exceed its target. -/ +theorem blueRootEdge_split_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfailure : BlueRootEdgeFails configuration h) : + ∀ (x : ℝ) (_hxZero : 0 ≤ x) + (_hxEdge : x ≤ dist (configuration .blue .root) (configuration .blue .right)), + blueRootEdgeTarget configuration < rootEdgeSplitDiameter + (dist (configuration .blue .root) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .red .right)) x + (blueRootRedTriangleReach configuration) + (blueChildRedTriangleReach configuration .right) := by + intro x hxZero hxEdge + exact lt_of_not_ge fun hdiameter ↦ + (not_lt_of_ge (blueRootEdgePackingAtEndpoint_score_nonnegative configuration h x hxZero hxEdge + hdiameter)) (hfailure x hxZero hxEdge) + +private theorem barC_rootEdge_child_gap_pos : 0 < barC ^ 2 + barC - 3 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem barC_rootEdge_order_gap_pos : 2 < 4 * barC * (barC - 1) := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +/-- The selected matching and blue coincident endpoint exclude the blue internal primitive. -/ +theorem SixPointConfiguration.blueRootEdgeInternalSlack_neg_of_matching_endpoint + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : 0 ≤ matchingFailureSlack barC + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right))) + (hendpoint : 0 ≤ blueEndpointFailureSlack barC + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .root) (configuration .red .left)) + (dist (configuration .red .root) (configuration .red .right)) + (dist (configuration .red .left) (configuration .blue .left))) : + blueRootEdgeInternalSlack barC + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .root) (configuration .blue .right)) + (dist (configuration .red .root) (configuration .red .left)) + (dist (configuration .red .root) (configuration .red .right)) < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hL : ‖p₁ - p₂‖ = + dist (configuration .red .left) (configuration .red .right) := by + rw [← dist_eq_norm, configuration.dist_redDisplacement] + have hM : ‖w₁ - w₂‖ = + dist (configuration .blue .left) (configuration .blue .right) := by + rw [← dist_eq_norm, configuration.dist_bluePullback] + have hb₂ : ‖w₂‖ = dist (configuration .blue .root) (configuration .blue .right) := by + simp [w₂, SixPointConfiguration.bluePullback, dist_eq_norm] + have hr₁ : ‖p₁‖ = dist (configuration .red .root) (configuration .red .left) := by + simp [p₁, SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hr₂ : ‖p₂‖ = dist (configuration .red .root) (configuration .red .right) := by + simp [p₂, SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hB₁₁ : ‖e - p₁ - w₁‖ = + dist (configuration .red .left) (configuration .blue .left) := by + exact (configuration.dist_red_blue_eq_norm .left .left).symm + have hB₂₂ : ‖e - p₂ - w₂‖ = + dist (configuration .red .right) (configuration .blue .right) := by + exact (configuration.dist_red_blue_eq_norm .right .right).symm + have hredSeparation : barC ≤ ‖p₁ - p₂‖ := by + have hsibling := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hblueSeparation : barC ≤ ‖w₁ - w₂‖ := by + have hsibling := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hnegative := blueRootEdgeInternalSlack_neg e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hredSeparation hblueSeparation + (by simpa only [hL, hM, hB₁₁, hB₂₂] using hmatching) + (by simpa only [hL, hM, hr₁, hr₂, hB₁₁] using hendpoint) + simpa only [hL, hb₂, hr₁, hr₂] using hnegative + +/-- On the selected endpoint branch, failure of the red root--edge support can only use one of +the two child-labelled balanced terms. -/ +theorem redRootEdge_failure_routes_to_child_balanced + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hendpoint : redSiblingTriangleFailure configuration (.endpoint 0)) + (hfailure : RedRootEdgeFails configuration h) : + 2 * redRootEdgeTarget configuration < + dist (configuration .red .root) (configuration .red .right) + + redRootBlueTriangleReach configuration .left + + redChildBlueTriangleReach configuration .right .left ∨ + 2 * redRootEdgeTarget configuration < + dist (configuration .red .root) (configuration .red .right) + + redRootBlueTriangleReach configuration .left + + redChildBlueTriangleReach configuration .right .right := by + let R := dist (configuration .red .root) (configuration .red .right) + let L := dist (configuration .red .left) (configuration .red .right) + let M := dist (configuration .blue .left) (configuration .blue .right) + let r₁ := dist (configuration .red .root) (configuration .red .left) + let b₁ := dist (configuration .blue .root) (configuration .blue .left) + let b₂ := dist (configuration .blue .root) (configuration .blue .right) + have hcOne : 1 < barC := one_lt_barC_and_barC_lt_two.1 + have hcTwo : barC < 2 := one_lt_barC_and_barC_lt_two.2 + have hLLower : barC ≤ L := by + simpa [L] using (sibling_distance_mem_endpoint_interval h .red).1 + have hMLower : barC ≤ M := by + simpa [M] using (sibling_distance_mem_endpoint_interval h .blue).1 + have hROne : R ≤ 1 := by + simpa [R] using h.child_distance .red .right (by simp) + have hr₁One : r₁ ≤ 1 := by + simpa [r₁] using h.child_distance .red .left (by simp) + have hb₁One : b₁ ≤ 1 := by + simpa [b₁] using h.child_distance .blue .left (by simp) + have hb₂One : b₂ ≤ 1 := by + simpa [b₂] using h.child_distance .blue .right (by simp) + have hRTriangle : L ≤ r₁ + R := by + calc + L ≤ dist (configuration .red .left) (configuration .red .root) + R := by + simpa [L, R] using dist_triangle (configuration .red .left) + (configuration .red .root) (configuration .red .right) + _ = r₁ + R := by rw [dist_comm] + have hRLower : barC - 1 ≤ R := by linarith + have hRPos : 0 < R := by linarith + have hBlueTriangle : M ≤ b₁ + b₂ := by + calc + M ≤ dist (configuration .blue .left) (configuration .blue .root) + b₂ := by + simpa [M, b₂] using dist_triangle (configuration .blue .left) + (configuration .blue .root) (configuration .blue .right) + _ = b₁ + b₂ := by rw [dist_comm] + have hRootRoot : + redRootBlueTriangleReach configuration .root ≤ redRootEdgeTarget configuration - R := by + have hRScaled := mul_le_mul_of_nonneg_left hRLower (by linarith : 0 ≤ barC - 1) + have hBlueScaled := mul_le_mul_of_nonneg_left hBlueTriangle + (by linarith : 0 ≤ (barC - 1) / 2) + have hMScaled := mul_le_mul_of_nonneg_left hMLower barC_pos.le + simp [redRootBlueTriangleReach, redRootEdgeTarget, rootedTriangleTotalRadius, + canonicalTriangleRadius, R, h.root_distance] + nlinarith + have hChildRoot : + redChildBlueTriangleReach configuration .right .root ≤ + redRootEdgeTarget configuration - R := by + have hcross : dist (configuration .red .right) (configuration .blue .root) ≤ R + 1 := by + calc + _ ≤ dist (configuration .red .right) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue .root) := + dist_triangle _ _ _ + _ = R + 1 := by rw [dist_comm, h.root_distance] + have hRScaled := mul_le_mul_of_nonpos_left hROne (by linarith : barC - 2 ≤ 0) + have hBlueScaled := mul_le_mul_of_nonneg_left hBlueTriangle + (by linarith : 0 ≤ (barC - 1) / 2) + have hMScaled := mul_le_mul_of_nonneg_left hMLower barC_pos.le + simp [redChildBlueTriangleReach, redRootEdgeTarget, rootedTriangleTotalRadius, + canonicalTriangleRadius, R] + nlinarith [barC_rootEdge_child_gap_pos] + have hLeftLower : redRootEdgeTarget configuration - R ≤ + redRootBlueTriangleReach configuration .left := by + have hB₁₁Triangle : + dist (configuration .red .left) (configuration .blue .left) ≤ r₁ + + dist (configuration .red .root) (configuration .blue .left) := by + calc + _ ≤ dist (configuration .red .left) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue .left) := + dist_triangle _ _ _ + _ = _ := by rw [dist_comm] + have hLRLower : barC - 1 ≤ L - R := by linarith + have hLRScaled := mul_le_mul_of_nonneg_left hLRLower + (by linarith : 0 ≤ barC - 1) + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, incidenceFirst, + incidenceSecond, incidenceChild, redSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, canonicalTriangleRadius, redRootEdgeTarget, + redRootBlueTriangleReach, R] at hendpoint ⊢ + nlinarith + have hLeftLargest : redRootBlueTriangleReach configuration .right < + redRootBlueTriangleReach configuration .left := by + by_contra hnot + have hreachOrder : redRootBlueTriangleReach configuration .left ≤ + redRootBlueTriangleReach configuration .right := not_lt.mp hnot + have hRootLeft : + dist (configuration .red .root) (configuration .blue .left) ≤ 1 + b₁ := by + calc + _ ≤ dist (configuration .red .root) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .blue .left) := + dist_triangle _ _ _ + _ = _ := by rw [h.root_distance] + have hRootRight : + dist (configuration .red .root) (configuration .blue .right) ≤ 1 + b₂ := by + calc + _ ≤ dist (configuration .red .root) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .blue .right) := + dist_triangle _ _ _ + _ = _ := by rw [h.root_distance] + have hB₁₁Triangle : + dist (configuration .red .left) (configuration .blue .left) ≤ r₁ + + dist (configuration .red .root) (configuration .blue .left) := by + calc + _ ≤ dist (configuration .red .left) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue .left) := + dist_triangle _ _ _ + _ = _ := by rw [dist_comm] + have hLScaled := mul_le_mul_of_nonneg_left hLLower + (by linarith : 0 ≤ barC - 1) + have hSumLower : 2 * barC ≤ b₁ + b₂ + M := by linarith + have hSumScaled := mul_le_mul_of_nonneg_left hSumLower + (by linarith : 0 ≤ barC - 1) + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, incidenceFirst, + incidenceSecond, incidenceChild, redSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, canonicalTriangleRadius, + redRootBlueTriangleReach] at hendpoint hreachOrder ⊢ + nlinarith [barC_rootEdge_order_gap_pos] + have hClose : ∀ label, label ≠ .root → + redRootBlueTriangleReach configuration label - R ≤ + redChildBlueTriangleReach configuration .right label := by + intro label hlabel + have htriangle := dist_triangle (configuration .red .root) + (configuration .red .right) (configuration .blue label) + simp only [redRootBlueTriangleReach, redChildBlueTriangleReach] + dsimp only [R] at htriangle ⊢ + linarith + have hroute := rootEdge_failure_routing hRPos.le (redRootEdge_split_failure h hfailure) + rcases rootEdge_failure_reduces_to_three_types hRPos hRootRoot hChildRoot hLeftLower + hLeftLargest hClose hroute with hinternal | hleft | hright + · have hmatchingSlack : 0 ≤ matchingFailureSlack barC L M + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) := by + simpa [SelectedDiagonalMatchingFails, matchingFailureSlack, incidenceCrossDistance, + incidenceChild, L, M] using hmatching + have hendpointSlack : 0 ≤ redEndpointFailureSlack barC L M b₁ b₂ + (dist (configuration .red .left) (configuration .blue .left)) := by + simp [redSiblingTriangleFailure, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius] at hendpoint + simp only [redEndpointFailureSlack] + dsimp only [L, M, b₁, b₂] + linarith + have hnegative := configuration.redRootEdgeInternalSlack_neg_of_matching_endpoint h + hmatchingSlack hendpointSlack + have hnegative' : 2 * M - barC * + (R + (b₁ + b₂ + M) / 2) < 0 := by + simpa [redRootEdgeInternalSlack, R, M, b₁, b₂] using hnegative + have hinternal' : barC * (R + (b₁ + b₂ + M) / 2) < 2 * M := by + simpa [redRootEdgeTarget, rootedTriangleTotalRadius, R, M, b₁, b₂] using hinternal + exfalso + linarith + · dsimp only [R] at hleft + exact Or.inl hleft + · dsimp only [R] at hright + exact Or.inr hright + +/-- The color-reversed root--edge failure has the same two surviving balanced terms. -/ +theorem blueRootEdge_failure_routes_to_child_balanced + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hendpoint : blueSiblingTriangleFailure configuration (.endpoint 0)) + (hfailure : BlueRootEdgeFails configuration h) : + 2 * blueRootEdgeTarget configuration < + dist (configuration .blue .root) (configuration .blue .right) + + blueRootRedTriangleReach configuration .left + + blueChildRedTriangleReach configuration .right .left ∨ + 2 * blueRootEdgeTarget configuration < + dist (configuration .blue .root) (configuration .blue .right) + + blueRootRedTriangleReach configuration .left + + blueChildRedTriangleReach configuration .right .right := by + let R := dist (configuration .blue .root) (configuration .blue .right) + let L := dist (configuration .red .left) (configuration .red .right) + let M := dist (configuration .blue .left) (configuration .blue .right) + let b₁ := dist (configuration .blue .root) (configuration .blue .left) + let r₁ := dist (configuration .red .root) (configuration .red .left) + let r₂ := dist (configuration .red .root) (configuration .red .right) + have hcOne : 1 < barC := one_lt_barC_and_barC_lt_two.1 + have hcTwo : barC < 2 := one_lt_barC_and_barC_lt_two.2 + have hrootReverse : + dist (configuration .blue .root) (configuration .red .root) = 1 := by + simpa [dist_comm] using h.root_distance + have hLLower : barC ≤ L := by + simpa [L] using (sibling_distance_mem_endpoint_interval h .red).1 + have hMLower : barC ≤ M := by + simpa [M] using (sibling_distance_mem_endpoint_interval h .blue).1 + have hROne : R ≤ 1 := by + simpa [R] using h.child_distance .blue .right (by simp) + have hb₁One : b₁ ≤ 1 := by + simpa [b₁] using h.child_distance .blue .left (by simp) + have hr₁One : r₁ ≤ 1 := by + simpa [r₁] using h.child_distance .red .left (by simp) + have hr₂One : r₂ ≤ 1 := by + simpa [r₂] using h.child_distance .red .right (by simp) + have hBlueTriangle : M ≤ b₁ + R := by + calc + M ≤ dist (configuration .blue .left) (configuration .blue .root) + R := by + simpa [M, R] using dist_triangle (configuration .blue .left) + (configuration .blue .root) (configuration .blue .right) + _ = b₁ + R := by rw [dist_comm] + have hRLower : barC - 1 ≤ R := by linarith + have hRPos : 0 < R := by linarith + have hRedTriangle : L ≤ r₁ + r₂ := by + calc + L ≤ dist (configuration .red .left) (configuration .red .root) + r₂ := by + simpa [L, r₂] using dist_triangle (configuration .red .left) + (configuration .red .root) (configuration .red .right) + _ = r₁ + r₂ := by rw [dist_comm] + have hRootRoot : + blueRootRedTriangleReach configuration .root ≤ blueRootEdgeTarget configuration - R := by + have hRScaled := mul_le_mul_of_nonneg_left hRLower (by linarith : 0 ≤ barC - 1) + have hRedScaled := mul_le_mul_of_nonneg_left hRedTriangle + (by linarith : 0 ≤ (barC - 1) / 2) + have hLScaled := mul_le_mul_of_nonneg_left hLLower barC_pos.le + simp [blueRootRedTriangleReach, blueRootEdgeTarget, rootedTriangleTotalRadius, + canonicalTriangleRadius, R, hrootReverse] + nlinarith + have hChildRoot : + blueChildRedTriangleReach configuration .right .root ≤ + blueRootEdgeTarget configuration - R := by + have hcross : dist (configuration .blue .right) (configuration .red .root) ≤ R + 1 := by + calc + _ ≤ dist (configuration .blue .right) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .red .root) := + dist_triangle _ _ _ + _ = R + 1 := by rw [dist_comm (configuration .blue .right), hrootReverse] + have hRScaled := mul_le_mul_of_nonpos_left hROne (by linarith : barC - 2 ≤ 0) + have hRedScaled := mul_le_mul_of_nonneg_left hRedTriangle + (by linarith : 0 ≤ (barC - 1) / 2) + have hLScaled := mul_le_mul_of_nonneg_left hLLower barC_pos.le + simp [blueChildRedTriangleReach, blueRootEdgeTarget, rootedTriangleTotalRadius, + canonicalTriangleRadius, R] + nlinarith [barC_rootEdge_child_gap_pos] + have hLeftLower : blueRootEdgeTarget configuration - R ≤ + blueRootRedTriangleReach configuration .left := by + have hB₁₁Triangle : + dist (configuration .blue .left) (configuration .red .left) ≤ b₁ + + dist (configuration .blue .root) (configuration .red .left) := by + calc + _ ≤ dist (configuration .blue .left) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .red .left) := + dist_triangle _ _ _ + _ = _ := by rw [dist_comm (configuration .blue .left)] + have hMRLower : barC - 1 ≤ M - R := by linarith + have hMRScaled := mul_le_mul_of_nonneg_left hMRLower + (by linarith : 0 ≤ barC - 1) + simp [blueSiblingTriangleFailure, transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + blueSiblingTriangleTarget, rootedTriangleTotalRadius, blueSiblingRedTriangleReach, + canonicalTriangleRadius, blueRootEdgeTarget, blueRootRedTriangleReach, R] at hendpoint ⊢ + nlinarith + have hLeftLargest : blueRootRedTriangleReach configuration .right < + blueRootRedTriangleReach configuration .left := by + by_contra hnot + have hreachOrder : blueRootRedTriangleReach configuration .left ≤ + blueRootRedTriangleReach configuration .right := not_lt.mp hnot + have hRootLeft : + dist (configuration .blue .root) (configuration .red .left) ≤ 1 + r₁ := by + calc + _ ≤ dist (configuration .blue .root) (configuration .red .root) + + dist (configuration .red .root) (configuration .red .left) := + dist_triangle _ _ _ + _ = _ := by rw [hrootReverse] + have hRootRight : + dist (configuration .blue .root) (configuration .red .right) ≤ 1 + r₂ := by + calc + _ ≤ dist (configuration .blue .root) (configuration .red .root) + + dist (configuration .red .root) (configuration .red .right) := + dist_triangle _ _ _ + _ = _ := by rw [hrootReverse] + have hB₁₁Triangle : + dist (configuration .blue .left) (configuration .red .left) ≤ b₁ + + dist (configuration .blue .root) (configuration .red .left) := by + calc + _ ≤ dist (configuration .blue .left) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .red .left) := + dist_triangle _ _ _ + _ = _ := by rw [dist_comm (configuration .blue .left)] + have hMScaled := mul_le_mul_of_nonneg_left hMLower + (by linarith : 0 ≤ barC - 1) + have hSumLower : 2 * barC ≤ r₁ + r₂ + L := by linarith + have hSumScaled := mul_le_mul_of_nonneg_left hSumLower + (by linarith : 0 ≤ barC - 1) + simp [blueSiblingTriangleFailure, transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + blueSiblingTriangleTarget, rootedTriangleTotalRadius, blueSiblingRedTriangleReach, + canonicalTriangleRadius, blueRootRedTriangleReach] at hendpoint hreachOrder ⊢ + nlinarith [barC_rootEdge_order_gap_pos] + have hClose : ∀ label, label ≠ .root → + blueRootRedTriangleReach configuration label - R ≤ + blueChildRedTriangleReach configuration .right label := by + intro label hlabel + have htriangle := dist_triangle (configuration .blue .root) + (configuration .blue .right) (configuration .red label) + simp only [blueRootRedTriangleReach, blueChildRedTriangleReach] + dsimp only [R] at htriangle ⊢ + linarith + have hroute := rootEdge_failure_routing hRPos.le (blueRootEdge_split_failure h hfailure) + rcases rootEdge_failure_reduces_to_three_types hRPos hRootRoot hChildRoot hLeftLower + hLeftLargest hClose hroute with hinternal | hleft | hright + · have hmatchingSlack : 0 ≤ matchingFailureSlack barC L M + (dist (configuration .red .left) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) := by + simpa [SelectedDiagonalMatchingFails, matchingFailureSlack, incidenceCrossDistance, + incidenceChild, L, M] using hmatching + have hendpointSlack : 0 ≤ blueEndpointFailureSlack barC L M r₁ r₂ + (dist (configuration .red .left) (configuration .blue .left)) := by + norm_num [blueSiblingTriangleFailure, transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + blueSiblingTriangleTarget, rootedTriangleTotalRadius, blueSiblingRedTriangleReach, + canonicalTriangleRadius] at hendpoint + rw [dist_comm (configuration .blue .left) (configuration .red .left)] at hendpoint + simp only [blueEndpointFailureSlack] + dsimp only [L, M, r₁, r₂] + linarith + have hnegative := configuration.blueRootEdgeInternalSlack_neg_of_matching_endpoint h + hmatchingSlack hendpointSlack + have hnegative' : 2 * L - barC * + (R + (r₁ + r₂ + L) / 2) < 0 := by + simpa [blueRootEdgeInternalSlack, R, L, r₁, r₂] using hnegative + have hinternal' : barC * (R + (r₁ + r₂ + L) / 2) < 2 * L := by + simpa [blueRootEdgeTarget, rootedTriangleTotalRadius, R, L, r₁, r₂] using hinternal + exfalso + linarith + · dsimp only [R] at hleft + exact Or.inl hleft + · dsimp only [R] at hright + exact Or.inr hright + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/RootEdgeType12.lean b/LeanPool/Besicovitch/SixPoint/RootEdgeType12.lean new file mode 100644 index 0000000000..cca8ba05b4 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RootEdgeType12.lean @@ -0,0 +1,592 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.MatrixCorrections +public import LeanPool.Besicovitch.SixPoint.RootEdge +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger +import Mathlib.Analysis.InnerProductSpace.GramMatrix +import Mathlib.Analysis.Matrix.Order + +/-! +# The crossed root--edge `(1,2)` obstruction + +This file excludes the crossed term in the root--edge minimax. The proof uses the positive +separator with weights `1, 1, 2`. Three scalar norm tangents reduce it to one fixed rational +Gram certificate; radial secants use only the sibling separation and the unit-ball bounds. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- Failure slack of the crossed `(1,2)` term for a red root--second-child edge. -/ +def redRootEdgeType12Slack + (c M r₂ b₁ b₂ rootToBlueFirst secondCross : ℝ) : ℝ := + r₂ + rootToBlueFirst + secondCross + M - + 2 * c * (r₂ + (b₁ + b₂ + M) / 2) + +private abbrev Five := Fin 5 + +private abbrev Three := Fin 3 + +private def redSeparationMultiplier : ℝ := 4713 / 20000 + +private def blueSeparationMultiplier : ℝ := 7587 / 20000 + +private def factorRow : Three → Five → ℝ + | 0 => ![590 / 10000, 4584 / 10000, -1112 / 10000, -3575 / 10000, 2862 / 10000] + | 1 => ![3933 / 10000, 3465 / 10000, 8248 / 10000, -821 / 10000, -4181 / 10000] + | 2 => ![7438 / 10000, 205 / 10000, 417 / 10000, 6703 / 10000, 6674 / 10000] + +private def factorGram : Matrix Five Five ℝ := + ∑ k, Matrix.vecMulVec (factorRow k) (factorRow k) + +private def factorGramValues : Matrix Five Five ℝ := + !![71140433 / 100000000, 3571439 / 20000000, 697699 / 2000000, + 44518671 / 100000000, 34885919 / 100000000; + 3571439 / 20000000, 16530653 / 50000000, 23567397 / 100000000, + -357169 / 2000000, 413 / 100000000; + 697699 / 2000000, 23567397 / 100000000, 69439937 / 100000000, + -1057 / 100000000, -17442187 / 50000000; + 44518671 / 100000000, -357169 / 2000000, -1057 / 100000000, + 467079 / 800000, 37936773 / 100000000; + 34885919 / 100000000, 413 / 100000000, -17442187 / 50000000, + 37936773 / 100000000, 70214081 / 100000000] + +private theorem factorGram_eq_values : factorGram = factorGramValues := by + ext i j + fin_cases i <;> fin_cases j <;> + norm_num [factorGram, factorGramValues, factorRow, Matrix.vecMulVec, + Fin.sum_univ_three] + +private def targetOffDiagonal : Matrix Five Five ℝ := + !![0, 5 / 28, 15 / 43, 5 / 28 + 4 / 15, 15 / 43; + 5 / 28, 0, redSeparationMultiplier, -5 / 28, 0; + 15 / 43, redSeparationMultiplier, 0, 0, -15 / 43; + 5 / 28 + 4 / 15, -5 / 28, 0, 0, blueSeparationMultiplier; + 15 / 43, 0, -15 / 43, blueSeparationMultiplier, 0] + +private def residual (i j : Five) : ℝ := + targetOffDiagonal i j - factorGram i j + +private def certificateMatrix : Matrix Five Five ℝ := + fivePairCompletion (factorGram + (1 / 10000000 : ℝ) • 1) (residual) + +private theorem certificateMatrix_posSemidef : certificateMatrix.PosSemidef := by + have hfactor : factorGram.PosSemidef := by + apply Matrix.posSemidef_sum + intro i _ + exact Matrix.posSemidef_vecMulVec_self_star (factorRow i) + have hepsilon : ((1 / 10000000 : ℝ) • (1 : Matrix Five Five ℝ)).PosSemidef := + Matrix.PosSemidef.one.smul (by norm_num) + exact fivePairCompletion_posSemidef (hfactor.add hepsilon) (residual) + +private theorem factorGram_apply_comm (i j : Five) : factorGram i j = factorGram j i := by + simp only [factorGram, Matrix.sum_apply, Matrix.vecMulVec_apply] + congr 1 + funext k + ring + +@[simp] private theorem factorGram_10 : factorGram 1 0 = factorGram 0 1 := + factorGram_apply_comm 1 0 + +@[simp] private theorem factorGram_20 : factorGram 2 0 = factorGram 0 2 := + factorGram_apply_comm 2 0 + +@[simp] private theorem factorGram_21 : factorGram 2 1 = factorGram 1 2 := + factorGram_apply_comm 2 1 + +@[simp] private theorem factorGram_30 : factorGram 3 0 = factorGram 0 3 := + factorGram_apply_comm 3 0 + +@[simp] private theorem factorGram_31 : factorGram 3 1 = factorGram 1 3 := + factorGram_apply_comm 3 1 + +@[simp] private theorem factorGram_32 : factorGram 3 2 = factorGram 2 3 := + factorGram_apply_comm 3 2 + +@[simp] private theorem factorGram_40 : factorGram 4 0 = factorGram 0 4 := + factorGram_apply_comm 4 0 + +@[simp] private theorem factorGram_41 : factorGram 4 1 = factorGram 1 4 := + factorGram_apply_comm 4 1 + +@[simp] private theorem factorGram_42 : factorGram 4 2 = factorGram 2 4 := + factorGram_apply_comm 4 2 + +@[simp] private theorem factorGram_43 : factorGram 4 3 = factorGram 3 4 := + factorGram_apply_comm 4 3 + +private theorem certificateMatrix_offDiagonal {i j : Five} (hij : i ≠ j) : + certificateMatrix i j = targetOffDiagonal i j := by + fin_cases i <;> fin_cases j <;> + simp_all [certificateMatrix, fivePairCompletion, residual, targetOffDiagonal] + +private def diagonal₀ : ℝ := + factorGram 0 0 + 1 / 10000000 + |residual 0 1| + |residual 0 2| + + |residual 0 3| + |residual 0 4| + +private def diagonal₁ : ℝ := + factorGram 1 1 + 1 / 10000000 + |residual 0 1| + |residual 1 2| + + |residual 1 3| + |residual 1 4| + +private def diagonal₂ : ℝ := + factorGram 2 2 + 1 / 10000000 + |residual 0 2| + |residual 1 2| + + |residual 2 3| + |residual 2 4| + +private def diagonal₃ : ℝ := + factorGram 3 3 + 1 / 10000000 + |residual 0 3| + |residual 1 3| + + |residual 2 3| + |residual 3 4| + +private def diagonal₄ : ℝ := + factorGram 4 4 + 1 / 10000000 + |residual 0 4| + |residual 1 4| + + |residual 2 4| + |residual 3 4| + +private theorem certificateMatrix_diagonal₀_eq : certificateMatrix 0 0 = diagonal₀ := by + simp [certificateMatrix, fivePairCompletion, diagonal₀] + +private theorem certificateMatrix_diagonal₁_eq : certificateMatrix 1 1 = diagonal₁ := by + simp [certificateMatrix, fivePairCompletion, diagonal₁] + +private theorem certificateMatrix_diagonal₂_eq : certificateMatrix 2 2 = diagonal₂ := by + simp [certificateMatrix, fivePairCompletion, diagonal₂] + +private theorem certificateMatrix_diagonal₃_eq : certificateMatrix 3 3 = diagonal₃ := by + simp [certificateMatrix, fivePairCompletion, diagonal₃] + +private theorem certificateMatrix_diagonal₄_eq : certificateMatrix 4 4 = diagonal₄ := by + simp [certificateMatrix, fivePairCompletion, diagonal₄] + +private theorem certificateMatrix_diagonal₀ : + certificateMatrix 0 0 = 2294557211 / 3225000000 := by + rw [certificateMatrix_diagonal₀_eq] + simp only [diagonal₀, residual] + rw [factorGram_eq_values] + simp [factorGramValues, targetOffDiagonal] + norm_num [redSeparationMultiplier, blueSeparationMultiplier] + +private theorem certificateMatrix_diagonal₁ : + certificateMatrix 1 1 = 231458397 / 700000000 := by + rw [certificateMatrix_diagonal₁_eq] + simp only [diagonal₁, residual] + rw [factorGram_eq_values] + simp [factorGramValues, targetOffDiagonal] + norm_num [redSeparationMultiplier, blueSeparationMultiplier] + +private theorem certificateMatrix_diagonal₂ : + certificateMatrix 2 2 = 119445887 / 172000000 := by + rw [certificateMatrix_diagonal₂_eq] + simp only [diagonal₂, residual] + rw [factorGram_eq_values] + simp [factorGramValues, targetOffDiagonal] + norm_num [redSeparationMultiplier, blueSeparationMultiplier] + +private theorem certificateMatrix_diagonal₃ : + certificateMatrix 3 3 = 87591241 / 150000000 := by + rw [certificateMatrix_diagonal₃_eq] + simp only [diagonal₃, residual] + rw [factorGram_eq_values] + simp [factorGramValues, targetOffDiagonal] + norm_num [redSeparationMultiplier, blueSeparationMultiplier] + +private theorem certificateMatrix_diagonal₄ : + certificateMatrix 4 4 = 301942251 / 430000000 := by + rw [certificateMatrix_diagonal₄_eq] + simp only [diagonal₄, residual] + rw [factorGram_eq_values] + simp [factorGramValues, targetOffDiagonal] + norm_num [redSeparationMultiplier, blueSeparationMultiplier] + +private theorem gram_sum_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (v : Five → E) : + 0 ≤ ∑ i, ∑ j, certificateMatrix i j * ⟪v i, v j⟫_ℝ := by + exact matrix_inner_sum_nonneg certificateMatrix_posSemidef v + +private theorem certificate_gram_nonneg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) : + 0 ≤ certificateMatrix 0 0 * ‖e‖ ^ 2 + certificateMatrix 1 1 * ‖p₁‖ ^ 2 + + certificateMatrix 2 2 * ‖p₂‖ ^ 2 + certificateMatrix 3 3 * ‖w₁‖ ^ 2 + + certificateMatrix 4 4 * ‖w₂‖ ^ 2 + + 2 * (5 / 28) * ⟪e, p₁⟫_ℝ + 2 * (15 / 43) * ⟪e, p₂⟫_ℝ + + 2 * (5 / 28 + 4 / 15) * ⟪e, w₁⟫_ℝ + 2 * (15 / 43) * ⟪e, w₂⟫_ℝ + + 2 * redSeparationMultiplier * ⟪p₁, p₂⟫_ℝ - 2 * (5 / 28) * ⟪p₁, w₁⟫_ℝ - + 2 * (15 / 43) * ⟪p₂, w₂⟫_ℝ + + 2 * blueSeparationMultiplier * ⟪w₁, w₂⟫_ℝ := by + let v : Five → E := ![e, p₁, p₂, w₁, w₂] + have h := gram_sum_nonneg v + simp only [Fin.sum_univ_five, Fin.isValue, Matrix.cons_val_zero, Matrix.cons_val_one, + Matrix.cons_val, inner_self_eq_norm_sq_to_K, RCLike.ofReal_real_eq_id, id_eq, v] at h + rw [certificateMatrix_offDiagonal (by decide : (0 : Five) ≠ 1), + certificateMatrix_offDiagonal (by decide : (0 : Five) ≠ 2), + certificateMatrix_offDiagonal (by decide : (0 : Five) ≠ 3), + certificateMatrix_offDiagonal (by decide : (0 : Five) ≠ 4), + certificateMatrix_offDiagonal (by decide : (1 : Five) ≠ 0), + certificateMatrix_offDiagonal (by decide : (1 : Five) ≠ 2), + certificateMatrix_offDiagonal (by decide : (1 : Five) ≠ 3), + certificateMatrix_offDiagonal (by decide : (1 : Five) ≠ 4), + certificateMatrix_offDiagonal (by decide : (2 : Five) ≠ 0), + certificateMatrix_offDiagonal (by decide : (2 : Five) ≠ 1), + certificateMatrix_offDiagonal (by decide : (2 : Five) ≠ 3), + certificateMatrix_offDiagonal (by decide : (2 : Five) ≠ 4), + certificateMatrix_offDiagonal (by decide : (3 : Five) ≠ 0), + certificateMatrix_offDiagonal (by decide : (3 : Five) ≠ 1), + certificateMatrix_offDiagonal (by decide : (3 : Five) ≠ 2), + certificateMatrix_offDiagonal (by decide : (3 : Five) ≠ 4), + certificateMatrix_offDiagonal (by decide : (4 : Five) ≠ 0), + certificateMatrix_offDiagonal (by decide : (4 : Five) ≠ 1), + certificateMatrix_offDiagonal (by decide : (4 : Five) ≠ 2), + certificateMatrix_offDiagonal (by decide : (4 : Five) ≠ 3)] at h + simp [targetOffDiagonal, real_inner_comm] at h + nlinarith + +private theorem norm_sub_sq {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x : E) : + ‖e - x‖ ^ 2 = ‖e‖ ^ 2 + ‖x‖ ^ 2 - 2 * ⟪e, x⟫_ℝ := by + rw [norm_sub_sq_real] + ring + +private def firstBlueRadialPenalty (c : ℝ) : ℝ := (5 * c - 1) / 4 + +private def secondBlueRadialPenalty (c : ℝ) : ℝ := (5 * c + 1) / 4 + +private def secondRedRadialPenalty (c : ℝ) : ℝ := 2 * c - 1 + +private def balance₀ : ℝ := + certificateMatrix 0 0 + 5 / 28 + 15 / 43 + 4 / 15 + +private def balance₁ : ℝ := + certificateMatrix 1 1 + 5 / 28 + redSeparationMultiplier + +private def balance₂ (c : ℝ) : ℝ := + certificateMatrix 2 2 + 15 / 43 + redSeparationMultiplier - + secondRedRadialPenalty c / c + +private def balance₃ (c : ℝ) : ℝ := + certificateMatrix 3 3 + 5 / 28 + 4 / 15 + blueSeparationMultiplier - + firstBlueRadialPenalty c / c + +private def balance₄ (c : ℝ) : ℝ := + certificateMatrix 4 4 + 15 / 43 + blueSeparationMultiplier - + secondBlueRadialPenalty c / c + +private theorem balance₀_nonneg : 0 ≤ balance₀ := by + rw [balance₀, certificateMatrix_diagonal₀] + norm_num + +private theorem balance₁_nonneg : 0 ≤ balance₁ := by + rw [balance₁, certificateMatrix_diagonal₁] + norm_num [redSeparationMultiplier] + +private theorem balance₂_nonneg : 0 ≤ balance₂ barC := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + have hc := barC_pos + rw [balance₂, certificateMatrix_diagonal₂] + norm_num [redSeparationMultiplier, secondRedRadialPenalty] at hlower hupper ⊢ + field_simp [hc.ne'] at ⊢ + nlinarith + +private theorem balance₃_nonneg : 0 ≤ balance₃ barC := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + have hc := barC_pos + rw [balance₃, certificateMatrix_diagonal₃] + norm_num [blueSeparationMultiplier, firstBlueRadialPenalty] at hlower hupper ⊢ + field_simp [hc.ne'] at ⊢ + nlinarith + +private theorem balance₄_nonneg : 0 ≤ balance₄ barC := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + have hc := barC_pos + rw [balance₄, certificateMatrix_diagonal₄] + norm_num [blueSeparationMultiplier, secondBlueRadialPenalty] at hlower hupper ⊢ + field_simp [hc.ne'] at ⊢ + nlinarith + +private def certificateUpper (c : ℝ) : ℝ := + 7 / 5 + 129 / 80 + 15 / 16 - + (3 * c - 2) / 2 * c - (9 * c - 7) / 4 * c - + firstBlueRadialPenalty c * (c - 1) / c - + secondBlueRadialPenalty c * (c - 1) / c - + secondRedRadialPenalty c * (c - 1) / c - 1 / 2 + + balance₀ + balance₁ + balance₂ c + balance₃ c + balance₄ c - + (redSeparationMultiplier + blueSeparationMultiplier) * c ^ 2 + +private theorem certificateUpper_neg : certificateUpper barC < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + have hc := barC_pos + rw [certificateUpper, balance₀, balance₁, balance₂, balance₃, balance₄, + certificateMatrix_diagonal₀, certificateMatrix_diagonal₁, + certificateMatrix_diagonal₂, certificateMatrix_diagonal₃, + certificateMatrix_diagonal₄] + norm_num [redSeparationMultiplier, blueSeparationMultiplier, firstBlueRadialPenalty, + secondBlueRadialPenalty, secondRedRadialPenalty] at hlower hupper ⊢ + field_simp [hc.ne'] at ⊢ + nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + +private theorem tangentQuadratic_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + 5 / 28 * ‖e - p₁ - w₁‖ ^ 2 + 15 / 43 * ‖e - p₂ - w₂‖ ^ 2 + + 4 / 15 * ‖e - w₁‖ ^ 2 - + firstBlueRadialPenalty barC / barC * ‖w₁‖ ^ 2 - + secondBlueRadialPenalty barC / barC * ‖w₂‖ ^ 2 - + secondRedRadialPenalty barC / barC * ‖p₂‖ ^ 2 ≤ + balance₀ + balance₁ + balance₂ barC + balance₃ barC + balance₄ barC - + (redSeparationMultiplier + blueSeparationMultiplier) * barC ^ 2 := by + have hredSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + exact (sq_le_sq₀ barC_pos.le (norm_nonneg _)).2 hredSeparation + have hblueSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + exact (sq_le_sq₀ barC_pos.le (norm_nonneg _)).2 hblueSeparation + rw [norm_sub_sq_real] at hredSq hblueSq + have hredScaled := mul_le_mul_of_nonneg_left hredSq + (show 0 ≤ redSeparationMultiplier by norm_num [redSeparationMultiplier]) + have hblueScaled := mul_le_mul_of_nonneg_left hblueSq + (show 0 ≤ blueSeparationMultiplier by norm_num [blueSeparationMultiplier]) + have hp₁Sq : ‖p₁‖ ^ 2 ≤ 1 := by + nlinarith [norm_nonneg p₁] + have hp₂Sq : ‖p₂‖ ^ 2 ≤ 1 := by + nlinarith [norm_nonneg p₂] + have hw₁Sq : ‖w₁‖ ^ 2 ≤ 1 := by + nlinarith [norm_nonneg w₁] + have hw₂Sq : ‖w₂‖ ^ 2 ≤ 1 := by + nlinarith [norm_nonneg w₂] + have hbalance₁ := mul_le_mul_of_nonneg_left hp₁Sq balance₁_nonneg + have hbalance₂ := mul_le_mul_of_nonneg_left hp₂Sq balance₂_nonneg + have hbalance₃ := mul_le_mul_of_nonneg_left hw₁Sq balance₃_nonneg + have hbalance₄ := mul_le_mul_of_nonneg_left hw₂Sq balance₄_nonneg + have hgram := certificate_gram_nonneg e p₁ p₂ w₁ w₂ + simp only [he, one_pow] at hgram + rw [norm_sub_sub_sq e p₁ w₁, norm_sub_sub_sq e p₂ w₂, + norm_sub_sq e w₁] + simp only [he, one_pow] + simp only [balance₁] at hbalance₁ + simp only [balance₂] at hbalance₂ + simp only [balance₃] at hbalance₃ + simp only [balance₄] at hbalance₄ + simp only [balance₀, balance₁, balance₂, balance₃, balance₄] + nlinarith + +/-- The exact Gram separator for the crossed root--edge term. -/ +theorem rootEdge_type12_expanded_lt {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + ‖e - p₁ - w₁‖ + 3 / 2 * ‖e - p₂ - w₂‖ + ‖e - w₁‖ + + (2 - 3 * barC) / 2 * ‖p₁ - p₂‖ + + (7 - 9 * barC) / 4 * ‖w₁ - w₂‖ + + (1 - 5 * barC) / 4 * ‖w₁‖ - + (1 + 5 * barC) / 4 * ‖w₂‖ + + (1 - 2 * barC) * ‖p₂‖ - 1 / 2 < 0 := by + have hredSum : barC ≤ ‖p₁‖ + ‖p₂‖ := + hredSeparation.trans (norm_sub_le p₁ p₂) + have hblueSum : barC ≤ ‖w₁‖ + ‖w₂‖ := + hblueSeparation.trans (norm_sub_le w₁ w₂) + have hp₁Lower : barC - 1 ≤ ‖p₁‖ := by linarith + have hp₂Lower : barC - 1 ≤ ‖p₂‖ := by linarith + have hw₁Lower : barC - 1 ≤ ‖w₁‖ := by linarith + have hw₂Lower : barC - 1 ≤ ‖w₂‖ := by linarith + have hfirstPenalty : 0 ≤ firstBlueRadialPenalty barC := by + simp only [firstBlueRadialPenalty] + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hsecondPenalty : 0 ≤ secondBlueRadialPenalty barC := by + simp only [secondBlueRadialPenalty] + nlinarith [barC_pos] + have hredPenalty : 0 ≤ secondRedRadialPenalty barC := by + simp only [secondRedRadialPenalty] + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hfirstRadial := radial_secant hfirstPenalty hw₁Lower hw₁ (by linarith [barC_pos]) + have hsecondRadial := radial_secant hsecondPenalty hw₂Lower hw₂ + (by linarith [barC_pos]) + have hredRadial := radial_secant hredPenalty hp₂Lower hp₂ (by linarith [barC_pos]) + simp only [sub_add_cancel, mul_one] at hfirstRadial hsecondRadial hredRadial + have hredDistance : + (2 - 3 * barC) / 2 * ‖p₁ - p₂‖ ≤ (2 - 3 * barC) / 2 * barC := by + have hcoefficient : 0 ≤ (3 * barC - 2) / 2 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hscaled := mul_le_mul_of_nonneg_left hredSeparation hcoefficient + nlinarith + have hblueDistance : + (7 - 9 * barC) / 4 * ‖w₁ - w₂‖ ≤ (7 - 9 * barC) / 4 * barC := by + have hcoefficient : 0 ≤ (9 * barC - 7) / 4 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hscaled := mul_le_mul_of_nonneg_left hblueSeparation hcoefficient + nlinarith + have htangent₁ := weightedNorm_le_quadratic (e - p₁ - w₁) 1 (5 / 28) (by norm_num) + have htangent₂ := weightedNorm_le_quadratic (e - p₂ - w₂) (3 / 2) (15 / 43) + (by norm_num) + have htangent₃ := weightedNorm_le_quadratic (e - w₁) 1 (4 / 15) (by norm_num) + norm_num at htangent₁ htangent₂ htangent₃ + have hquadratic := tangentQuadratic_le e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + have hupper := certificateUpper_neg + simp only [certificateUpper] at hupper + simp only [firstBlueRadialPenalty] at hfirstRadial + simp only [secondBlueRadialPenalty] at hsecondRadial + simp only [secondRedRadialPenalty] at hredRadial + simp only [firstBlueRadialPenalty, secondBlueRadialPenalty, + secondRedRadialPenalty] at hquadratic hupper + have hfirstRadial' : + (1 - 5 * barC) / 4 * ‖w₁‖ ≤ + -((5 * barC - 1) / 4) / barC * ‖w₁‖ ^ 2 - + (5 * barC - 1) / 4 * (barC - 1) / barC := by + convert hfirstRadial using 1 + all_goals ring + have hsecondRadial' : + -(1 + 5 * barC) / 4 * ‖w₂‖ ≤ + -((5 * barC + 1) / 4) / barC * ‖w₂‖ ^ 2 - + (5 * barC + 1) / 4 * (barC - 1) / barC := by + convert hsecondRadial using 1 + all_goals ring + have hredRadial' : + (1 - 2 * barC) * ‖p₂‖ ≤ + -(2 * barC - 1) / barC * ‖p₂‖ ^ 2 - + (2 * barC - 1) * (barC - 1) / barC := by + convert hredRadial using 1 + all_goals ring + have hpreUpper : + ‖e - p₁ - w₁‖ + 3 / 2 * ‖e - p₂ - w₂‖ + ‖e - w₁‖ + + (2 - 3 * barC) / 2 * ‖p₁ - p₂‖ + + (7 - 9 * barC) / 4 * ‖w₁ - w₂‖ + + (1 - 5 * barC) / 4 * ‖w₁‖ - + (1 + 5 * barC) / 4 * ‖w₂‖ + + (1 - 2 * barC) * ‖p₂‖ - 1 / 2 ≤ + 5 / 28 * ‖e - p₁ - w₁‖ ^ 2 + 15 / 43 * ‖e - p₂ - w₂‖ ^ 2 + + 4 / 15 * ‖e - w₁‖ ^ 2 - + (5 * barC - 1) / 4 / barC * ‖w₁‖ ^ 2 - + (5 * barC + 1) / 4 / barC * ‖w₂‖ ^ 2 - + (2 * barC - 1) / barC * ‖p₂‖ ^ 2 + + 7 / 5 + 129 / 80 + 15 / 16 + + (2 - 3 * barC) / 2 * barC + (7 - 9 * barC) / 4 * barC - + (5 * barC - 1) / 4 * (barC - 1) / barC - + (5 * barC + 1) / 4 * (barC - 1) / barC - + (2 * barC - 1) * (barC - 1) / barC - 1 / 2 := by + ring_nf at htangent₁ + ring_nf at htangent₂ + ring_nf at htangent₃ + ring_nf at hredDistance + ring_nf at hblueDistance + ring_nf at hfirstRadial' + ring_nf at hsecondRadial' + ring_nf at hredRadial' + ring_nf + linarith only [htangent₁, htangent₂, htangent₃, hredDistance, hblueDistance, + hfirstRadial', hsecondRadial', hredRadial'] + linarith only [hpreUpper, hquadratic, hupper] + +/-- Matching, endpoint, and crossed root--edge slacks have a strictly negative separator. -/ +theorem rootEdge_type12_separator_lt {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) (hblueSeparation : barC ≤ ‖w₁ - w₂‖) : + matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖ + + redEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖w₁‖ ‖w₂‖ ‖e - p₁ - w₁‖ + + 2 * redRootEdgeType12Slack barC ‖w₁ - w₂‖ ‖p₂‖ ‖w₁‖ ‖w₂‖ + ‖e - w₁‖ ‖e - p₂ - w₂‖ < 0 := by + have h := rootEdge_type12_expanded_lt e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + simp only [matchingFailureSlack, redEndpointFailureSlack, + redRootEdgeType12Slack] + ring_nf at h ⊢ + nlinarith + +/-- A matching and its first coincident endpoint exclude the crossed red root--edge term. -/ +theorem redRootEdgeType12Slack_neg {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hredSeparation : barC ≤ ‖p₁ - p₂‖) (hblueSeparation : barC ≤ ‖w₁ - w₂‖) + (hmatching : 0 ≤ matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖) + (hendpoint : 0 ≤ redEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖w₁‖ ‖w₂‖ ‖e - p₁ - w₁‖) : + redRootEdgeType12Slack barC ‖w₁ - w₂‖ ‖p₂‖ ‖w₁‖ ‖w₂‖ + ‖e - w₁‖ ‖e - p₂ - w₂‖ < 0 := by + have hseparator := rootEdge_type12_separator_lt e p₁ p₂ w₁ w₂ he hp₁ hp₂ hw₁ hw₂ + hredSeparation hblueSeparation + nlinarith + +/-- In an admissible configuration, the selected matching and endpoint code `0` exclude the +red crossed `(left,right)` root--edge term. -/ +theorem SixPointConfiguration.redRootEdgeType12Slack_neg_of_matching_endpoint + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hendpoint : redSiblingTriangleFailure configuration (.endpoint 0)) : + redRootEdgeType12Slack barC + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .root) (configuration .red .right)) + (dist (configuration .blue .root) (configuration .blue .left)) + (dist (configuration .blue .root) (configuration .blue .right)) + (dist (configuration .red .root) (configuration .blue .left)) + (dist (configuration .red .right) (configuration .blue .right)) < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hL : ‖p₁ - p₂‖ = + dist (configuration .red .left) (configuration .red .right) := by + rw [← dist_eq_norm, configuration.dist_redDisplacement] + have hM : ‖w₁ - w₂‖ = + dist (configuration .blue .left) (configuration .blue .right) := by + rw [← dist_eq_norm, configuration.dist_bluePullback] + have hr₂ : ‖p₂‖ = dist (configuration .red .root) (configuration .red .right) := by + simp [p₂, SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hb₁ : ‖w₁‖ = dist (configuration .blue .root) (configuration .blue .left) := by + simp [w₁, SixPointConfiguration.bluePullback, dist_eq_norm] + have hb₂ : ‖w₂‖ = dist (configuration .blue .root) (configuration .blue .right) := by + simp [w₂, SixPointConfiguration.bluePullback, dist_eq_norm] + have hB₁₁ : ‖e - p₁ - w₁‖ = + dist (configuration .red .left) (configuration .blue .left) := by + exact (configuration.dist_red_blue_eq_norm .left .left).symm + have hB₂₂ : ‖e - p₂ - w₂‖ = + dist (configuration .red .right) (configuration .blue .right) := by + exact (configuration.dist_red_blue_eq_norm .right .right).symm + have hA₁ : ‖e - w₁‖ = + dist (configuration .red .root) (configuration .blue .left) := by + simpa [e, p₁, w₁, SixPointConfiguration.redDisplacement] using + (configuration.dist_red_blue_eq_norm .root .left).symm + have hredSeparation : barC ≤ ‖p₁ - p₂‖ := by + have hsibling := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hblueSeparation : barC ≤ ‖w₁ - w₂‖ := by + have hsibling := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hsibling + exact hsibling + have hmatching' : 0 ≤ matchingFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖e - p₁ - w₁‖ ‖e - p₂ - w₂‖ := by + simp only [hL, hM, hB₁₁, hB₂₂, matchingFailureSlack] + apply sub_nonneg.mpr + simpa [SelectedDiagonalMatchingFails, incidenceCrossDistance, incidenceChild] using + hmatching + have hendpoint' : 0 ≤ redEndpointFailureSlack barC ‖p₁ - p₂‖ ‖w₁ - w₂‖ + ‖w₁‖ ‖w₂‖ ‖e - p₁ - w₁‖ := by + simp only [hL, hM, hb₁, hb₂, hB₁₁, redEndpointFailureSlack] + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius, incidenceFirst, incidenceSecond, incidenceChild] at hendpoint + linarith + have hnegative := redRootEdgeType12Slack_neg e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hredSeparation hblueSeparation + hmatching' hendpoint' + simpa only [hM, hr₂, hb₁, hb₂, hA₁, hB₂₂] using hnegative + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/RowColumnRescue.lean b/LeanPool/Besicovitch/SixPoint/RowColumnRescue.lean new file mode 100644 index 0000000000..a4f56ff3a3 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/RowColumnRescue.lean @@ -0,0 +1,1169 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry +public import LeanPool.Besicovitch.SixPoint.SiblingTriangle + +/-! +# The row and column rescue + +This file proves the first strict exit in the endpoint failure tree. A row or column obstruction +for the four-child packing forces the corresponding root against the full opposite triangle to +have nonnegative score. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +private def rowRho1 : ℝ := 361 / 125 + +private def rowRho2 : ℝ := 64 / 25 + +private def rowRho3 : ℝ := 1937 / 1000 + +private def rowSigma : ℝ := 601 / 100 + +private def rowEta : ℝ := 567 / 100 + +private def rowK1 : ℝ := 5 / rowRho1 + +private def rowK2 : ℝ := 5 / rowRho2 + +private def rowK3 : ℝ := (9 / 2) / rowRho3 + +private def rowK : ℝ := rowK1 + rowK2 + +private def rowA1 : ℝ := rowK1 + rowK3 + rowK * rowK1 / rowSigma + +private def rowA2 : ℝ := rowK2 + rowK * rowK2 / rowSigma + +private def rowPositiveConstant (c : ℝ) : ℝ := + rowK1 * (2 + rowRho1 ^ 2) + rowK2 * (2 + rowRho2 ^ 2) + + rowK3 * (1 + rowRho3 ^ 2) + rowSigma + + (rowK ^ 2 - rowK1 * rowK2 * c ^ 2) / rowSigma + +private def rowConstant (c : ℝ) : ℝ := + -10 * (4 * c ^ 2 - 3 * c + 2) - 9 * (c - 1) - (9 / 2) * c * (c - 1) + + rowPositiveConstant c + +private def rowQuadratic1 : ℝ := + rowA1 + (rowA1 + rowA2) * rowA1 / rowEta + +private def rowQuadratic2 : ℝ := + rowA2 + (rowA1 + rowA2) * rowA2 / rowEta + +private def rowBase (c : ℝ) : ℝ := + rowConstant c + rowEta - rowA1 * rowA2 * c ^ 2 / rowEta + +private def rowUpper (c t₁ t₂ : ℝ) : ℝ := + rowConstant c + rowA1 * t₁ ^ 2 + rowA2 * t₂ ^ 2 + rowEta + + ((rowA1 + rowA2) * (rowA1 * t₁ ^ 2 + rowA2 * t₂ ^ 2) - + rowA1 * rowA2 * c ^ 2) / rowEta - + (9 / 2) * (c - 1) * t₁ - (9 / 2) * (c + 1) * t₂ + +private theorem rowUpper_eq_quadratic (c t₁ t₂ : ℝ) : + rowUpper c t₁ t₂ = + rowBase c + rowQuadratic1 * t₁ ^ 2 + rowQuadratic2 * t₂ ^ 2 - + (9 / 2) * (c - 1) * t₁ - (9 / 2) * (c + 1) * t₂ := by + simp only [rowUpper, rowBase, rowQuadratic1, rowQuadratic2] + ring + +private theorem weighted_norm_tangent_of_eq {E : Type*} [SeminormedAddCommGroup E] + (x : E) (weight r k : ℝ) (hr : 0 < r) (hrelation : k = weight / (2 * r)) + (hweight : 0 ≤ weight) : weight * ‖x‖ ≤ k * (‖x‖ ^ 2 + r ^ 2) := by + rw [hrelation] + exact LeanPool.Besicovitch.weighted_norm_tangent x weight r hr hweight + +private theorem rowUpper_le_vertices {c t₁ t₂ : ℝ} (ht₁_one : t₁ ≤ 1) + (ht₂_one : t₂ ≤ 1) (hsum : c ≤ t₁ + t₂) : + rowUpper c t₁ t₂ ≤ + max (rowUpper c 1 1) (max (rowUpper c 1 (c - 1)) (rowUpper c (c - 1) 1)) := by + have hquadratic1 : 0 ≤ rowQuadratic1 := by + norm_num [rowQuadratic1, rowA1, rowA2, rowK, rowK1, rowK2, rowK3, rowRho1, + rowRho2, rowRho3, rowSigma, rowEta] + have hquadratic2 : 0 ≤ rowQuadratic2 := by + norm_num [rowQuadratic2, rowA1, rowA2, rowK, rowK1, rowK2, rowK3, rowRho1, + rowRho2, rowRho3, rowSigma, rowEta] + have ht₁_lower : c - 1 ≤ t₁ := by linarith + have ht₂_lower : c - 1 ≤ t₂ := by linarith + have hsecond : + rowUpper c t₁ t₂ ≤ max (rowUpper c t₁ (c - t₁)) (rowUpper c t₁ 1) := by + have h := quadratic_le_max_endpoints hquadratic2 + (show c - t₁ ≤ t₂ by linarith) ht₂_one + (b := -(9 / 2) * (c + 1)) + (d := rowBase c + rowQuadratic1 * t₁ ^ 2 - (9 / 2) * (c - 1) * t₁) + rw [rowUpper_eq_quadratic, rowUpper_eq_quadratic, rowUpper_eq_quadratic] + convert h using 1 <;> ring_nf + have hdiagonal : + rowUpper c t₁ (c - t₁) ≤ + max (rowUpper c (c - 1) 1) (rowUpper c 1 (c - 1)) := by + have h := quadratic_le_max_endpoints (add_nonneg hquadratic1 hquadratic2) + ht₁_lower ht₁_one + (b := -2 * rowQuadratic2 * c - (9 / 2) * (c - 1) + (9 / 2) * (c + 1)) + (d := rowBase c + rowQuadratic2 * c ^ 2 - (9 / 2) * (c + 1) * c) + rw [rowUpper_eq_quadratic, rowUpper_eq_quadratic, rowUpper_eq_quadratic] + convert h using 1 <;> ring_nf + have htop : + rowUpper c t₁ 1 ≤ max (rowUpper c (c - 1) 1) (rowUpper c 1 1) := by + have h := quadratic_le_max_endpoints hquadratic1 ht₁_lower ht₁_one + (b := -(9 / 2) * (c - 1)) + (d := rowBase c + rowQuadratic2 - (9 / 2) * (c + 1)) + rw [rowUpper_eq_quadratic, rowUpper_eq_quadratic, rowUpper_eq_quadratic] + convert h using 1 <;> ring_nf + refine hsecond.trans (max_le ?_ ?_) + · exact hdiagonal.trans <| max_le + (le_max_right _ _ |>.trans <| le_max_right _ _) + (le_max_left _ _ |>.trans <| le_max_right _ _) + · exact htop.trans <| max_le + (le_max_right _ _ |>.trans <| le_max_right _ _) + (le_max_left _ _) + +private theorem rowUpper_vertices_lt : + max (rowUpper barC 1 1) + (max (rowUpper barC 1 (barC - 1)) (rowUpper barC (barC - 1) 1)) < + -8 / 25 := by + rw [max_lt_iff, max_lt_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + constructor + · norm_num [rowUpper, rowConstant, rowPositiveConstant, rowA1, rowA2, rowK, + rowK1, rowK2, rowK3, + rowRho1, rowRho2, rowRho3, rowSigma, rowEta] at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + · constructor + · norm_num [rowUpper, rowConstant, rowPositiveConstant, rowA1, rowA2, rowK, + rowK1, rowK2, rowK3, + rowRho1, rowRho2, rowRho3, rowSigma, rowEta] at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 13866128436518096 / 10 ^ 16)] + · norm_num [rowUpper, rowConstant, rowPositiveConstant, rowA1, rowA2, rowK, + rowK1, rowK2, rowK3, + rowRho1, rowRho2, rowRho3, rowSigma, rowEta] at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 13866128436518100 / 10 ^ 16)] + +private theorem row_preconditioner_inner_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p w₁ w₂ : E) (hp : ‖p‖ ≤ 1) + (he : ‖e‖ = 1) (hseparation : barC ≤ ‖w₁ - w₂‖) : + 2 * ⟪p, rowK1 • w₁ + rowK2 • w₂ - rowK • e⟫_ℝ ≤ rowSigma + + (rowK * (rowK1 * ‖w₁‖ ^ 2 + rowK2 * ‖w₂‖ ^ 2) - + rowK1 * rowK2 * barC ^ 2 + rowK ^ 2 - + 2 * rowK * ⟪e, rowK1 • w₁ + rowK2 • w₂⟫_ℝ) / rowSigma := by + let z := rowK1 • w₁ + rowK2 • w₂ - rowK • e + have hk1 : 0 ≤ rowK1 := by norm_num [rowK1, rowRho1] + have hk2 : 0 ≤ rowK2 := by norm_num [rowK2, rowRho2] + have hK : 0 ≤ rowK := add_nonneg hk1 hk2 + have hseparation_sq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hpz : 2 * ⟪p, z⟫_ℝ ≤ 2 * ‖z‖ := by + have hinner := real_inner_le_norm p z + nlinarith [norm_nonneg z, mul_le_mul_of_nonneg_right hp (norm_nonneg z)] + have hz_eq : + ‖z‖ ^ 2 = rowK * (rowK1 * ‖w₁‖ ^ 2 + rowK2 * ‖w₂‖ ^ 2) - + rowK1 * rowK2 * ‖w₁ - w₂‖ ^ 2 + rowK ^ 2 - + 2 * rowK * ⟪e, rowK1 • w₁ + rowK2 • w₂⟫_ℝ := by + dsimp only [z] + rw [norm_sub_sq_real, weighted_norm_sq w₁ w₂ hk1 hk2] + simp only [norm_smul, Real.norm_eq_abs, abs_of_nonneg hK, he, + real_inner_smul_right] + rw [real_inner_comm (rowK1 • w₁ + rowK2 • w₂) e] + simp only [rowK] + ring + have hz_upper : + ‖z‖ ^ 2 ≤ rowK * (rowK1 * ‖w₁‖ ^ 2 + rowK2 * ‖w₂‖ ^ 2) - + rowK1 * rowK2 * barC ^ 2 + rowK ^ 2 - + 2 * rowK * ⟪e, rowK1 • w₁ + rowK2 • w₂⟫_ℝ := by + have hproduct := mul_le_mul_of_nonneg_left hseparation_sq (mul_nonneg hk1 hk2) + nlinarith + have hsigma : 0 < rowSigma := by norm_num [rowSigma] + have hpz_upper : 2 * ⟪p, z⟫_ℝ ≤ rowSigma + ‖z‖ ^ 2 / rowSigma := + hpz.trans (two_mul_norm_tangent z hsigma) + have hz_scaled := (div_le_div_iff_of_pos_right hsigma).2 hz_upper + dsimp only [z] at hpz_upper ⊢ + nlinarith + +private theorem row_tangent_sq_expansion {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p w₁ w₂ : E) (he : ‖e‖ = 1) : + rowK1 * (‖e - p - w₁‖ ^ 2 + rowRho1 ^ 2) + + rowK2 * (‖e - p - w₂‖ ^ 2 + rowRho2 ^ 2) + + rowK3 * (‖e - w₁‖ ^ 2 + rowRho3 ^ 2) = + rowK1 * (1 + rowRho1 ^ 2) + rowK2 * (1 + rowRho2 ^ 2) + + rowK3 * (1 + rowRho3 ^ 2) + (rowK1 + rowK3) * ‖w₁‖ ^ 2 + + rowK2 * ‖w₂‖ ^ 2 - 2 * ⟪e, (rowK1 + rowK3) • w₁ + rowK2 • w₂⟫_ℝ + + rowK * ‖p‖ ^ 2 + + 2 * ⟪p, rowK1 • w₁ + rowK2 • w₂ - rowK • e⟫_ℝ := by + rw [norm_sub_sub_sq e p w₁, norm_sub_sub_sq e p w₂, norm_sub_sq_real e w₁] + simp only [he, one_pow, inner_sub_right, inner_add_right, real_inner_smul_right] + rw [real_inner_comm p e] + simp only [rowK] + ring + +private theorem row_tangent_sum_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p w₁ w₂ : E) (he : ‖e‖ = 1) (hp : ‖p‖ ≤ 1) + (hseparation : barC ≤ ‖w₁ - w₂‖) : + 10 * ‖e - p - w₁‖ + 10 * ‖e - p - w₂‖ + 9 * ‖e - w₁‖ ≤ + rowPositiveConstant barC + rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2 - + 2 * ⟪e, rowA1 • w₁ + rowA2 • w₂⟫_ℝ := by + have htangent1 := weighted_norm_tangent_of_eq (e - p - w₁) 10 rowRho1 rowK1 + (by norm_num [rowRho1]) + (by norm_num [rowK1, rowRho1]) (by norm_num) + have htangent2 := weighted_norm_tangent_of_eq (e - p - w₂) 10 rowRho2 rowK2 + (by norm_num [rowRho2]) + (by norm_num [rowK2, rowRho2]) (by norm_num) + have htangent3 := weighted_norm_tangent_of_eq (e - w₁) 9 rowRho3 rowK3 + (by norm_num [rowRho3]) + (by norm_num [rowK3, rowRho3]) (by norm_num) + have htangentSum : + 10 * ‖e - p - w₁‖ + 10 * ‖e - p - w₂‖ + 9 * ‖e - w₁‖ ≤ + rowK1 * (‖e - p - w₁‖ ^ 2 + rowRho1 ^ 2) + + rowK2 * (‖e - p - w₂‖ ^ 2 + rowRho2 ^ 2) + + rowK3 * (‖e - w₁‖ ^ 2 + rowRho3 ^ 2) := by linarith + have hpz := row_preconditioner_inner_le e p w₁ w₂ hp he hseparation + have hp_sq : ‖p‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg p] + have hK : 0 ≤ rowK := by norm_num [rowK, rowK1, rowK2, rowRho1, rowRho2] + have hkp : rowK * ‖p‖ ^ 2 ≤ rowK := by + simpa only [mul_one] using mul_le_mul_of_nonneg_left hp_sq hK + calc + _ ≤ _ := htangentSum + _ = _ := row_tangent_sq_expansion e p w₁ w₂ he + _ ≤ rowK1 * (1 + rowRho1 ^ 2) + rowK2 * (1 + rowRho2 ^ 2) + + rowK3 * (1 + rowRho3 ^ 2) + (rowK1 + rowK3) * ‖w₁‖ ^ 2 + + rowK2 * ‖w₂‖ ^ 2 - 2 * ⟪e, (rowK1 + rowK3) • w₁ + rowK2 • w₂⟫_ℝ + + rowK + (rowSigma + + (rowK * (rowK1 * ‖w₁‖ ^ 2 + rowK2 * ‖w₂‖ ^ 2) - + rowK1 * rowK2 * barC ^ 2 + rowK ^ 2 - + 2 * rowK * ⟪e, rowK1 • w₁ + rowK2 • w₂⟫_ℝ) / rowSigma) := by linarith + _ = _ := by + simp only [rowPositiveConstant, rowA1, rowA2, rowK, inner_add_right, + real_inner_smul_right] + ring + +private theorem row_orientation_le_upper {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e w₁ w₂ : E) (he : ‖e‖ = 1) + (hseparation : barC ≤ ‖w₁ - w₂‖) : + rowPositiveConstant barC + rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2 - + 2 * ⟪e, rowA1 • w₁ + rowA2 • w₂⟫_ℝ ≤ + rowPositiveConstant barC + rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2 + + rowEta + ((rowA1 + rowA2) * (rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2) - + rowA1 * rowA2 * barC ^ 2) / rowEta := by + have hk1 : 0 ≤ rowK1 := by norm_num [rowK1, rowRho1] + have hk2 : 0 ≤ rowK2 := by norm_num [rowK2, rowRho2] + have hk3 : 0 ≤ rowK3 := by norm_num [rowK3, rowRho3] + have hK : 0 ≤ rowK := add_nonneg hk1 hk2 + have ha1 : 0 ≤ rowA1 := add_nonneg (add_nonneg hk1 hk3) <| + div_nonneg (mul_nonneg hK hk1) (by norm_num [rowSigma]) + have ha2 : 0 ≤ rowA2 := add_nonneg hk2 <| + div_nonneg (mul_nonneg hK hk2) (by norm_num [rowSigma]) + let u := rowA1 • w₁ + rowA2 • w₂ + have hseparation_sq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hu_sq : ‖u‖ ^ 2 ≤ + (rowA1 + rowA2) * (rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2) - + rowA1 * rowA2 * barC ^ 2 := by + rw [show ‖u‖ ^ 2 = + (rowA1 + rowA2) * (rowA1 * ‖w₁‖ ^ 2 + rowA2 * ‖w₂‖ ^ 2) - + rowA1 * rowA2 * ‖w₁ - w₂‖ ^ 2 by + exact weighted_norm_sq w₁ w₂ ha1 ha2] + exact sub_le_sub_left + (mul_le_mul_of_nonneg_left hseparation_sq (mul_nonneg ha1 ha2)) _ + have horientation : -2 * ⟪e, u⟫_ℝ ≤ rowEta + ‖u‖ ^ 2 / rowEta := by + have hinner := real_inner_le_norm (-e) u + simp only [inner_neg_left, norm_neg, he, one_mul] at hinner + calc + -2 * ⟪e, u⟫_ℝ = 2 * (-⟪e, u⟫_ℝ) := by ring + _ ≤ 2 * ‖u‖ := mul_le_mul_of_nonneg_left hinner (by norm_num) + _ ≤ rowEta + ‖u‖ ^ 2 / rowEta := two_mul_norm_tangent u (by norm_num [rowEta]) + have heta : 0 < rowEta := by norm_num [rowEta] + have hu_scaled := (div_le_div_iff_of_pos_right heta).2 hu_sq + dsimp only [u] at horientation hu_scaled + nlinarith + +private theorem rowWeighted_le_upper {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p w₁ w₂ : E) (he : ‖e‖ = 1) (hp : ‖p‖ ≤ 1) + (hseparation : barC ≤ ‖w₁ - w₂‖) : + 10 * (‖e - p - w₁‖ + ‖e - p - w₂‖ - (4 * barC ^ 2 - 3 * barC + 2)) + + 9 * (‖e - w₁‖ - (barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2)) ≤ + rowUpper barC ‖w₁‖ ‖w₂‖ := by + have htangent := row_tangent_sum_le e p w₁ w₂ he hp hseparation + have horientation := row_orientation_le_upper e w₁ w₂ he hseparation + simp only [rowUpper, rowConstant] at ⊢ + linarith + +private theorem rowWeighted_lt {E : Type*} [NormedAddCommGroup E] [InnerProductSpace ℝ E] + (e p w₁ w₂ : E) (he : ‖e‖ = 1) (hp : ‖p‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hseparation : barC ≤ ‖w₁ - w₂‖) : + 10 * (‖e - p - w₁‖ + ‖e - p - w₂‖ - (4 * barC ^ 2 - 3 * barC + 2)) + + 9 * (‖e - w₁‖ - (barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2)) < 0 := by + have hsum : barC ≤ ‖w₁‖ + ‖w₂‖ := + hseparation.trans (norm_sub_le w₁ w₂) + have hupper := rowWeighted_le_upper e p w₁ w₂ he hp hseparation + have hvertices := rowUpper_le_vertices hw₁ hw₂ hsum + exact (hupper.trans hvertices).trans_lt (rowUpper_vertices_lt.trans (by norm_num)) + +/-- A four-child row obstruction is incompatible with the corresponding root-triangle endpoint. -/ +theorem row_obstruction_excludes_root_triangle_endpoint {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p w₁ w₂ : E) (he : ‖e‖ = 1) (hp : ‖p‖ ≤ 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hseparation : barC ≤ ‖w₁ - w₂‖) + (hrow : 4 * barC ^ 2 - 3 * barC + 2 ≤ + ‖e - p - w₁‖ + ‖e - p - w₂‖) : + ‖e - w₁‖ < barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2 := by + have hweighted := rowWeighted_lt e p w₁ w₂ he hp hw₁ hw₂ hseparation + by_contra hendpoint + rw [not_lt] at hendpoint + nlinarith + +/-- Support `17`: the red root of radius one against the canonical blue triangle. -/ +def redRootBlueTrianglePacking (configuration : SixPointConfiguration) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + SixPointPacking configuration where + support := {(.red, .root), (.blue, .root), (.blue, .left), (.blue, .right)} + meets_color color := by + cases color + · exact ⟨.root, by simp⟩ + · exact ⟨.root, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color <;> cases label + · exact ⟨1, by norm_num, by norm_num⟩ + · simp at hlabel + · simp at hlabel + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .right⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li + · cases lj + · exact (hij (Subtype.ext rfl)).elim + · simp at hj + · simp at hj + · simp at hi + · simp at hi + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + +/-- Support `71`: the blue root of radius one against the canonical red triangle. -/ +def blueRootRedTrianglePacking (configuration : SixPointConfiguration) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + SixPointPacking configuration where + support := {(.blue, .root), (.red, .root), (.red, .left), (.red, .right)} + meets_color color := by + cases color + · exact ⟨.root, by simp⟩ + · exact ⟨.root, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color <;> cases label + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .right⟩ + · exact ⟨1, by norm_num, by norm_num⟩ + · simp at hlabel + · simp at hlabel + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · cases li + · cases lj + · exact (hij (Subtype.ext rfl)).elim + · simp at hj + · simp at hj + · simp at hi + · simp at hi + +/-- The total radius of support `17` is one plus the blue semiperimeter. -/ +theorem redRootBlueTrianglePacking_totalRadius (configuration : SixPointConfiguration) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + (redRootBlueTrianglePacking configuration hblueLeft hblueRight).totalRadius = + 1 + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2 := by + let packing := redRootBlueTrianglePacking configuration hblueLeft hblueRight + let value : SixPointIndex → ℝ + | (.red, .root) => 1 + | (.red, .left) => 0 + | (.red, .right) => 0 + | (.blue, label) => canonicalTriangleRadius (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) label + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [redRootBlueTrianglePacking, value] at hi ⊢ + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + simp [packing, redRootBlueTrianglePacking, value, canonicalTriangleRadius] + ring + +/-- The total radius of support `71` is one plus the red semiperimeter. -/ +theorem blueRootRedTrianglePacking_totalRadius (configuration : SixPointConfiguration) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + (blueRootRedTrianglePacking configuration hredLeft hredRight).totalRadius = + 1 + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2 := by + let packing := blueRootRedTrianglePacking configuration hredLeft hredRight + let value : SixPointIndex → ℝ + | (.red, label) => canonicalTriangleRadius (configuration .red .root) + (configuration .red .left) (configuration .red .right) label + | (.blue, .root) => 1 + | (.blue, .left) => 0 + | (.blue, .right) => 0 + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [blueRootRedTrianglePacking, value] at hi ⊢ + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + simp [packing, blueRootRedTrianglePacking, value, canonicalTriangleRadius] + ring + +private def trianglePoint {X : Type*} (root left right : X) : SixPointLabel → X + | .root => root + | .left => left + | .right => right + +@[simp] private theorem trianglePoint_configuration (configuration : SixPointConfiguration) + (color : SixPointColor) (label : SixPointLabel) : + trianglePoint (configuration color .root) (configuration color .left) + (configuration color .right) label = configuration color label := by + cases label <;> rfl + +private theorem redRootBlueTrianglePacking_radius_blue + (configuration : SixPointConfiguration) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (label : SixPointLabel) + (hlabel : (.blue, label) ∈ + (redRootBlueTrianglePacking configuration hblueLeft hblueRight).support) : + (redRootBlueTrianglePacking configuration hblueLeft hblueRight).radius + ⟨(.blue, label), hlabel⟩ = + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label := by + cases label <;> rfl + +private theorem blueRootRedTrianglePacking_radius_red + (configuration : SixPointConfiguration) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) + (label : SixPointLabel) + (hlabel : (.red, label) ∈ + (blueRootRedTrianglePacking configuration hredLeft hredRight).support) : + (blueRootRedTrianglePacking configuration hredLeft hredRight).radius + ⟨(.red, label), hlabel⟩ = + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label := by + cases label <;> rfl + +private theorem canonicalTriangle_pair_le {X : Type*} [PseudoMetricSpace X] + (root left right : X) (hleft : dist root left ≤ 1) (hright : dist root right ≤ 1) + {target : ℝ} (htarget : 2 ≤ target) + (hdist : ∀ leftLabel rightLabel, + 2 * dist (trianglePoint root left right leftLabel) + (trianglePoint root left right rightLabel) ≤ target) + (leftLabel rightLabel : SixPointLabel) : + dist (trianglePoint root left right leftLabel) (trianglePoint root left right rightLabel) + + canonicalTriangleRadius root left right leftLabel + + canonicalTriangleRadius root left right rightLabel ≤ target := by + cases leftLabel <;> cases rightLabel + · simp only [trianglePoint, dist_self, zero_add] + nlinarith [canonicalTriangleRadius_le_one root left right hleft hright .root] + · simp only [trianglePoint] + nlinarith [canonicalTriangleRadius_root_add_left root left right, hdist .root .left] + · simp only [trianglePoint] + nlinarith [canonicalTriangleRadius_root_add_right root left right, hdist .root .right] + · simp only [trianglePoint] + nlinarith [canonicalTriangleRadius_root_add_left root left right, hdist .left .root, + dist_comm left root] + · simp only [trianglePoint, dist_self, zero_add] + nlinarith [canonicalTriangleRadius_le_one root left right hleft hright .left] + · simp only [trianglePoint] + have h := hdist .left .right + simp only [trianglePoint] at h + nlinarith [canonicalTriangleRadius_left_add_right root left right] + · simp only [trianglePoint] + nlinarith [canonicalTriangleRadius_root_add_right root left right, hdist .right .root, + dist_comm right root] + · simp only [trianglePoint] + have h := hdist .right .left + simp only [trianglePoint] at h + nlinarith [canonicalTriangleRadius_left_add_right root left right, dist_comm right left] + · simp only [trianglePoint, dist_self, zero_add] + nlinarith [canonicalTriangleRadius_le_one root left right hleft hright .right] + +private theorem triangle_pair_dist_le (configuration : SixPointConfiguration) + (color : SixPointColor) + (hleft : dist (configuration color .root) (configuration color .left) ≤ 1) + (hright : dist (configuration color .root) (configuration color .right) ≤ 1) + {target : ℝ} (htargetTwo : 2 ≤ target) + (htargetSibling : + 2 * dist (configuration color .left) (configuration color .right) ≤ target) : + ∀ leftLabel rightLabel, + 2 * dist (configuration color leftLabel) (configuration color rightLabel) ≤ target := by + intro leftLabel rightLabel + cases leftLabel <;> cases rightLabel + · simpa using le_trans (by norm_num : (0 : ℝ) ≤ 2) htargetTwo + · nlinarith [hleft] + · nlinarith [hright] + · rw [dist_comm] + nlinarith [hleft] + · simpa using le_trans (by norm_num : (0 : ℝ) ≤ 2) htargetTwo + · exact htargetSibling + · rw [dist_comm] + nlinarith [hright] + · simpa only [dist_comm] using htargetSibling + · simpa using le_trans (by norm_num : (0 : ℝ) ≤ 2) htargetTwo + +private theorem red_root_blue_triangle_cross_le (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) {target : ℝ} + (hroot : 2 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) - + dist (configuration .blue .left) (configuration .blue .right)) / 2 ≤ target) + (hleft : + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ + 1 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .left) (configuration .blue .right) - + dist (configuration .blue .root) (configuration .blue .right)) / 2 ≤ target) + (hright : + ‖configuration.rootDisplacement - configuration.bluePullback .right‖ + 1 + + (dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right) - + dist (configuration .blue .root) (configuration .blue .left)) / 2 ≤ target) : + ∀ label, + dist (configuration .red .root) (configuration .blue label) + 1 + + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label ≤ target := by + intro label + cases label + · simp only [canonicalTriangleRadius] + rw [h.root_distance] + simpa only [one_add_one_eq_two] using hroot + · simp only [canonicalTriangleRadius, configuration.dist_red_blue_eq_norm] + simpa only [SixPointConfiguration.redDisplacement, sub_self, sub_zero] using hleft + · simp only [canonicalTriangleRadius, configuration.dist_red_blue_eq_norm] + simpa only [SixPointConfiguration.redDisplacement, sub_self, sub_zero] using hright + +private theorem blue_root_red_triangle_cross_le (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) {target : ℝ} + (hroot : 2 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) - + dist (configuration .red .left) (configuration .red .right)) / 2 ≤ target) + (hleft : ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ + 1 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .left) (configuration .red .right) - + dist (configuration .red .root) (configuration .red .right)) / 2 ≤ target) + (hright : ‖configuration.rootDisplacement - configuration.redDisplacement .right‖ + 1 + + (dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right) - + dist (configuration .red .root) (configuration .red .left)) / 2 ≤ target) : + ∀ label, + dist (configuration .blue .root) (configuration .red label) + 1 + + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label ≤ target := by + intro label + cases label + · simp only [canonicalTriangleRadius, dist_comm (configuration .blue .root)] + rw [h.root_distance] + simpa only [one_add_one_eq_two] using hroot + · simp only [canonicalTriangleRadius, dist_comm (configuration .blue .root), + configuration.dist_red_blue_eq_norm] + simpa only [SixPointConfiguration.bluePullback, sub_self, sub_zero] using hleft + · simp only [canonicalTriangleRadius, dist_comm (configuration .blue .root), + configuration.dist_red_blue_eq_norm] + simpa only [SixPointConfiguration.bluePullback, sub_self, sub_zero] using hright + +private theorem redRootBlueTrianglePacking_virtualDiameter_le + (configuration : SixPointConfiguration) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + {target : ℝ} (hroot : 2 ≤ target) + (hblue : ∀ leftLabel rightLabel, + 2 * dist (configuration .blue leftLabel) (configuration .blue rightLabel) ≤ target) + (hcross : ∀ label, + dist (configuration .red .root) (configuration .blue label) + 1 + + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label ≤ target) : + (redRootBlueTrianglePacking configuration hblueLeft hblueRight).virtualDiameter ≤ + target := by + let packing := redRootBlueTrianglePacking configuration hblueLeft hblueRight + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · cases leftLabel <;> cases rightLabel + · dsimp [packing, redRootBlueTrianglePacking] + simpa only [dist_self, zero_add, one_add_one_eq_two] using hroot + all_goals simp [packing, redRootBlueTrianglePacking] at hleft hright + · cases leftLabel + · cases rightLabel + · simpa [packing, redRootBlueTrianglePacking] using hcross .root + · simpa [packing, redRootBlueTrianglePacking] using hcross .left + · simpa [packing, redRootBlueTrianglePacking] using hcross .right + · simp [packing, redRootBlueTrianglePacking] at hleft + · simp [packing, redRootBlueTrianglePacking] at hleft + · cases rightLabel + · cases leftLabel + · simpa [packing, redRootBlueTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .root + · simpa [packing, redRootBlueTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .left + · simpa [packing, redRootBlueTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .right + · simp [packing, redRootBlueTrianglePacking] at hright + · simp [packing, redRootBlueTrianglePacking] at hright + · let hdist : ∀ leftLabel rightLabel, + 2 * dist (trianglePoint (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) leftLabel) + (trianglePoint (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) rightLabel) ≤ target := by + intro leftLabel rightLabel + simpa only [trianglePoint_configuration] using hblue leftLabel rightLabel + dsimp only [packing] + rw [redRootBlueTrianglePacking_radius_blue configuration hblueLeft hblueRight + leftLabel hleft, + redRootBlueTrianglePacking_radius_blue configuration hblueLeft hblueRight + rightLabel hright] + simpa only [trianglePoint_configuration] using + canonicalTriangle_pair_le (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) hblueLeft hblueRight hroot hdist leftLabel rightLabel + unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + +private theorem blueRootRedTrianglePacking_virtualDiameter_le + (configuration : SixPointConfiguration) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) + {target : ℝ} (hroot : 2 ≤ target) + (hred : ∀ leftLabel rightLabel, + 2 * dist (configuration .red leftLabel) (configuration .red rightLabel) ≤ target) + (hcross : ∀ label, + dist (configuration .blue .root) (configuration .red label) + 1 + + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label ≤ target) : + (blueRootRedTrianglePacking configuration hredLeft hredRight).virtualDiameter ≤ + target := by + let packing := blueRootRedTrianglePacking configuration hredLeft hredRight + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · let hdist : ∀ leftLabel rightLabel, + 2 * dist (trianglePoint (configuration .red .root) (configuration .red .left) + (configuration .red .right) leftLabel) + (trianglePoint (configuration .red .root) (configuration .red .left) + (configuration .red .right) rightLabel) ≤ target := by + intro leftLabel rightLabel + simpa only [trianglePoint_configuration] using hred leftLabel rightLabel + dsimp only [packing] + rw [blueRootRedTrianglePacking_radius_red configuration hredLeft hredRight + leftLabel hleft, + blueRootRedTrianglePacking_radius_red configuration hredLeft hredRight + rightLabel hright] + simpa only [trianglePoint_configuration] using + canonicalTriangle_pair_le (configuration .red .root) (configuration .red .left) + (configuration .red .right) hredLeft hredRight hroot hdist leftLabel rightLabel + · cases rightLabel + · cases leftLabel + · simpa [packing, blueRootRedTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .root + · simpa [packing, blueRootRedTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .left + · simpa [packing, blueRootRedTrianglePacking, dist_comm, add_comm, add_left_comm, add_assoc] + using hcross .right + · simp [packing, blueRootRedTrianglePacking] at hright + · simp [packing, blueRootRedTrianglePacking] at hright + · cases leftLabel + · cases rightLabel + · simpa [packing, blueRootRedTrianglePacking, add_assoc] using hcross .root + · simpa [packing, blueRootRedTrianglePacking, add_assoc] using hcross .left + · simpa [packing, blueRootRedTrianglePacking, add_assoc] using hcross .right + · simp [packing, blueRootRedTrianglePacking] at hleft + · simp [packing, blueRootRedTrianglePacking] at hleft + · cases leftLabel <;> cases rightLabel + · dsimp [packing, blueRootRedTrianglePacking] + simpa only [dist_self, zero_add, one_add_one_eq_two] using hroot + all_goals simp [packing, blueRootRedTrianglePacking] at hleft hright + unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + +private theorem barC_row_rescue_gaps : + 0 < 3 * barC - 4 ∧ 0 < barC ^ 2 + (3 / 2) * barC - 3 ∧ + 2 < barC * (1 + barC) := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + constructor + · linarith + · constructor <;> nlinarith [sq_nonneg (barC - 1)] + +private theorem root_triangle_target_bounds {E : Type*} [NormedAddCommGroup E] + (e w₁ w₂ : E) (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) + (hM : barC ≤ ‖w₁ - w₂‖) + (hleft : ‖e - w₁‖ < barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2) + (hright : ‖e - w₂‖ < barC - 1 + + ((barC - 1) * (‖w₂‖ + barC) + (barC + 1) * ‖w₁‖) / 2) : + let M := ‖w₁ - w₂‖ + let target := barC * (1 + (‖w₁‖ + ‖w₂‖ + M) / 2) + 2 ≤ target ∧ 2 * M ≤ target ∧ + 2 + (‖w₁‖ + ‖w₂‖ - M) / 2 ≤ target ∧ + ‖e - w₁‖ + 1 + (‖w₁‖ + M - ‖w₂‖) / 2 ≤ target ∧ + ‖e - w₂‖ + 1 + (‖w₂‖ + M - ‖w₁‖) / 2 ≤ target := by + dsimp only + have hsum : ‖w₁ - w₂‖ ≤ ‖w₁‖ + ‖w₂‖ := norm_sub_le w₁ w₂ + have hsumTwo : ‖w₁‖ + ‖w₂‖ ≤ 2 := by linarith + have hMtwo : ‖w₁ - w₂‖ ≤ 2 := hsum.trans hsumTwo + have htargetLower : + barC * (1 + ‖w₁ - w₂‖) ≤ + barC * (1 + (‖w₁‖ + ‖w₂‖ + ‖w₁ - w₂‖) / 2) := by + apply mul_le_mul_of_nonneg_left _ barC_pos.le + linarith + have hcc := mul_le_mul_of_nonneg_left hM barC_pos.le + have htargetTwo : 2 ≤ + barC * (1 + (‖w₁‖ + ‖w₂‖ + ‖w₁ - w₂‖) / 2) := + (barC_row_rescue_gaps.2.2.le.trans (by nlinarith)).trans htargetLower + have hnegative : barC - 2 ≤ 0 := by linarith [one_lt_barC_and_barC_lt_two.2] + have hMpart := mul_le_mul_of_nonpos_left hMtwo hnegative + have htargetM : 2 * ‖w₁ - w₂‖ ≤ + barC * (1 + (‖w₁‖ + ‖w₂‖ + ‖w₁ - w₂‖) / 2) := + (show 2 * ‖w₁ - w₂‖ ≤ barC * (1 + ‖w₁ - w₂‖) by + nlinarith [barC_row_rescue_gaps.1]).trans htargetLower + have hMmul : barC * (barC + 1) ≤ barC * (‖w₁ - w₂‖ + 1) := + mul_le_mul_of_nonneg_left (by linarith) barC_pos.le + have hMcoef := mul_le_mul_of_nonneg_left hM + (sub_nonneg.mpr one_lt_barC_and_barC_lt_two.1.le) + exact ⟨htargetTwo, htargetM, by nlinarith [barC_row_rescue_gaps.2.1], + by nlinarith, by nlinarith⟩ + +private theorem row_obstruction_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (redLabel : SixPointLabel) (hredLabel : redLabel ≠ .root) + (hrow : + 2 + 2 * (barC - 1) * + dist (configuration .red .left) (configuration .red .right) + + (2 * barC - 1) * + dist (configuration .blue .left) (configuration .blue .right) ≤ + dist (configuration .red redLabel) (configuration .blue .left) + + dist (configuration .red redLabel) (configuration .blue .right)) : + let e := configuration.rootDisplacement + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + ‖e - w₁‖ < barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2 ∧ + ‖e - w₂‖ < barC - 1 + + ((barC - 1) * (‖w₂‖ + barC) + (barC + 1) * ‖w₁‖) / 2 := by + dsimp only + let p := configuration.redDisplacement redLabel + have he := configuration.norm_rootDisplacement h + have hp := configuration.norm_redDisplacement_le_one h hredLabel + have hw₁ := configuration.norm_bluePullback_le_one h (by simp : SixPointLabel.left ≠ .root) + have hw₂ := configuration.norm_bluePullback_le_one h (by simp : SixPointLabel.right ≠ .root) + have hM : barC ≤ + ‖configuration.bluePullback .left - configuration.bluePullback .right‖ := by + have hM' := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hM' + exact hM' + have hL := h.sibling_distance .red + rw [barS, show 2 * (barC / 2) = barC by ring] at hL + have hMdist : dist (configuration .blue .left) (configuration .blue .right) = + ‖configuration.bluePullback .left - configuration.bluePullback .right‖ := by + rw [← configuration.dist_bluePullback .left .right, dist_eq_norm] + have hfactor1 : 0 ≤ 2 * (barC - 1) := by nlinarith [one_lt_barC_and_barC_lt_two.1] + have hfactor2 : 0 ≤ 2 * barC - 1 := by nlinarith [one_lt_barC_and_barC_lt_two.1] + have hredPart := mul_le_mul_of_nonneg_left hL hfactor1 + have hbluePart := mul_le_mul_of_nonneg_left hM hfactor2 + rw [hMdist, configuration.dist_red_blue_eq_norm redLabel .left, + configuration.dist_red_blue_eq_norm redLabel .right] at hrow + have hrowVector : 4 * barC ^ 2 - 3 * barC + 2 ≤ + ‖configuration.rootDisplacement - p - configuration.bluePullback .left‖ + + ‖configuration.rootDisplacement - p - configuration.bluePullback .right‖ := by nlinarith + exact ⟨row_obstruction_excludes_root_triangle_endpoint _ p _ _ he hp hw₁ hw₂ hM hrowVector, + row_obstruction_excludes_root_triangle_endpoint _ p _ _ he hp hw₂ hw₁ + (by simpa [norm_sub_rev] using hM) (by simpa [add_comm] using hrowVector)⟩ + +private theorem column_obstruction_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (blueLabel : SixPointLabel) (hblueLabel : blueLabel ≠ .root) + (hcolumn : + 2 + 2 * (barC - 1) * + dist (configuration .blue .left) (configuration .blue .right) + + (2 * barC - 1) * + dist (configuration .red .left) (configuration .red .right) ≤ + dist (configuration .red .left) (configuration .blue blueLabel) + + dist (configuration .red .right) (configuration .blue blueLabel)) : + let e := configuration.rootDisplacement + let w₁ := configuration.redDisplacement .left + let w₂ := configuration.redDisplacement .right + ‖e - w₁‖ < barC - 1 + + ((barC - 1) * (‖w₁‖ + barC) + (barC + 1) * ‖w₂‖) / 2 ∧ + ‖e - w₂‖ < barC - 1 + + ((barC - 1) * (‖w₂‖ + barC) + (barC + 1) * ‖w₁‖) / 2 := by + dsimp only + let p := configuration.bluePullback blueLabel + have he := configuration.norm_rootDisplacement h + have hp := configuration.norm_bluePullback_le_one h hblueLabel + have hw₁ := configuration.norm_redDisplacement_le_one h + (by simp : SixPointLabel.left ≠ .root) + have hw₂ := configuration.norm_redDisplacement_le_one h + (by simp : SixPointLabel.right ≠ .root) + have hM : barC ≤ + ‖configuration.redDisplacement .left - configuration.redDisplacement .right‖ := by + have hM' := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hM' + exact hM' + have hblueSibling := h.sibling_distance .blue + rw [barS, show 2 * (barC / 2) = barC by ring] at hblueSibling + have hMdist : dist (configuration .red .left) (configuration .red .right) = + ‖configuration.redDisplacement .left - configuration.redDisplacement .right‖ := by + rw [← configuration.dist_redDisplacement .left .right, dist_eq_norm] + have hfactor1 : 0 ≤ 2 * (barC - 1) := by nlinarith [one_lt_barC_and_barC_lt_two.1] + have hfactor2 : 0 ≤ 2 * barC - 1 := by nlinarith [one_lt_barC_and_barC_lt_two.1] + have hbluePart := mul_le_mul_of_nonneg_left hblueSibling hfactor1 + have hredPart := mul_le_mul_of_nonneg_left hM hfactor2 + rw [hMdist, configuration.dist_red_blue_eq_norm .left blueLabel, + configuration.dist_red_blue_eq_norm .right blueLabel] at hcolumn + have hcolumnVector : 4 * barC ^ 2 - 3 * barC + 2 ≤ + ‖configuration.rootDisplacement - p - configuration.redDisplacement .left‖ + + ‖configuration.rootDisplacement - p - configuration.redDisplacement .right‖ := by + dsimp only [p] + rw [show configuration.rootDisplacement - configuration.bluePullback blueLabel - + configuration.redDisplacement .left = + configuration.rootDisplacement - configuration.redDisplacement .left - + configuration.bluePullback blueLabel by abel] + rw [show configuration.rootDisplacement - configuration.bluePullback blueLabel - + configuration.redDisplacement .right = + configuration.rootDisplacement - configuration.redDisplacement .right - + configuration.bluePullback blueLabel by abel] + nlinarith + exact ⟨row_obstruction_excludes_root_triangle_endpoint _ p _ _ he hp hw₁ hw₂ hM + hcolumnVector, + row_obstruction_excludes_root_triangle_endpoint _ p _ _ he hp hw₂ hw₁ + (by simpa [norm_sub_rev] using hM) (by simpa [add_comm] using hcolumnVector)⟩ + +private theorem red_root_blue_triangle_target_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .left‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.bluePullback .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .right‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .left‖) / 2) : + let target := barC * (1 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2) + 2 ≤ target ∧ + 2 * dist (configuration .blue .left) (configuration .blue .right) ≤ target ∧ + 2 + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) - + dist (configuration .blue .left) (configuration .blue .right)) / 2 ≤ target ∧ + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ + 1 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .left) (configuration .blue .right) - + dist (configuration .blue .root) (configuration .blue .right)) / 2 ≤ target ∧ + ‖configuration.rootDisplacement - configuration.bluePullback .right‖ + 1 + + (dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right) - + dist (configuration .blue .root) (configuration .blue .left)) / 2 ≤ target := by + dsimp only + have hw₁ := configuration.norm_bluePullback_le_one h + (by simp : SixPointLabel.left ≠ .root) + have hw₂ := configuration.norm_bluePullback_le_one h + (by simp : SixPointLabel.right ≠ .root) + have hMdist : dist (configuration .blue .left) (configuration .blue .right) = + ‖configuration.bluePullback .left - configuration.bluePullback .right‖ := by + rw [← configuration.dist_bluePullback .left .right, dist_eq_norm] + have hb₁dist : dist (configuration .blue .root) (configuration .blue .left) = + ‖configuration.bluePullback .left‖ := by + simp [SixPointConfiguration.bluePullback, dist_eq_norm] + have hb₂dist : dist (configuration .blue .root) (configuration .blue .right) = + ‖configuration.bluePullback .right‖ := by + simp [SixPointConfiguration.bluePullback, dist_eq_norm] + have hM : barC ≤ + ‖configuration.bluePullback .left - configuration.bluePullback .right‖ := by + have hM' := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hM' + exact hM' + rw [hb₁dist, hb₂dist, hMdist] + exact root_triangle_target_bounds configuration.rootDisplacement + (configuration.bluePullback .left) (configuration.bluePullback .right) + hw₁ hw₂ hM hleft hright + +private theorem redRootBlueTrianglePacking_virtualDiameter_le_of_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .left‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.bluePullback .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .right‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .left‖) / 2) : + (redRootBlueTrianglePacking configuration + (h.child_distance .blue .left (by simp)) + (h.child_distance .blue .right (by simp))).virtualDiameter ≤ + barC * (1 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2) := by + let target := barC * (1 + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2) + obtain ⟨htargetTwo, htargetSibling, hrootTarget, hleftTarget, hrightTarget⟩ := + red_root_blue_triangle_target_bounds configuration h hleft hright + change 2 ≤ target at htargetTwo + change + 2 * dist (configuration .blue .left) (configuration .blue .right) ≤ target at htargetSibling + change _ ≤ target at hrootTarget hleftTarget hrightTarget + have hblueLeft := h.child_distance .blue .left (by simp) + have hblueRight := h.child_distance .blue .right (by simp) + have hblue := triangle_pair_dist_le configuration .blue hblueLeft hblueRight + htargetTwo htargetSibling + have hcross := red_root_blue_triangle_cross_le configuration h hrootTarget + hleftTarget hrightTarget + exact redRootBlueTrianglePacking_virtualDiameter_le configuration hblueLeft hblueRight + htargetTwo hblue hcross + +private theorem redRootBlueTriangle_score_nonnegative_of_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .left‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.bluePullback .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.bluePullback .right‖ + barC) + + (barC + 1) * ‖configuration.bluePullback .left‖) / 2) : + 0 ≤ (redRootBlueTrianglePacking configuration + (h.child_distance .blue .left (by simp)) + (h.child_distance .blue .right (by simp))).score barS := by + have hvirtual := redRootBlueTrianglePacking_virtualDiameter_le_of_endpoint_bounds + configuration h hleft hright + rw [SixPointPacking.score, redRootBlueTrianglePacking_totalRadius] + simp only [barS] + rw [show 2 * (barC / 2) = barC by ring] + apply sub_nonneg.mpr + apply (div_le_iff₀ barC_pos).2 + simpa only [mul_comm] using hvirtual + +private theorem blue_root_red_triangle_target_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .left‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.redDisplacement .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .right‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .left‖) / 2) : + let target := barC * (1 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2) + 2 ≤ target ∧ + 2 * dist (configuration .red .left) (configuration .red .right) ≤ target ∧ + 2 + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) - + dist (configuration .red .left) (configuration .red .right)) / 2 ≤ target ∧ + ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ + 1 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .left) (configuration .red .right) - + dist (configuration .red .root) (configuration .red .right)) / 2 ≤ target ∧ + ‖configuration.rootDisplacement - configuration.redDisplacement .right‖ + 1 + + (dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right) - + dist (configuration .red .root) (configuration .red .left)) / 2 ≤ target := by + dsimp only + have hw₁ := configuration.norm_redDisplacement_le_one h + (by simp : SixPointLabel.left ≠ .root) + have hw₂ := configuration.norm_redDisplacement_le_one h + (by simp : SixPointLabel.right ≠ .root) + have hMdist : dist (configuration .red .left) (configuration .red .right) = + ‖configuration.redDisplacement .left - configuration.redDisplacement .right‖ := by + rw [← configuration.dist_redDisplacement .left .right, dist_eq_norm] + have hr₁dist : dist (configuration .red .root) (configuration .red .left) = + ‖configuration.redDisplacement .left‖ := by + rw [SixPointConfiguration.redDisplacement, norm_sub_rev, dist_eq_norm] + have hr₂dist : dist (configuration .red .root) (configuration .red .right) = + ‖configuration.redDisplacement .right‖ := by + rw [SixPointConfiguration.redDisplacement, norm_sub_rev, dist_eq_norm] + have hM : barC ≤ + ‖configuration.redDisplacement .left - configuration.redDisplacement .right‖ := by + have hM' := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hM' + exact hM' + rw [hr₁dist, hr₂dist, hMdist] + exact root_triangle_target_bounds configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + hw₁ hw₂ hM hleft hright + +private theorem blueRootRedTrianglePacking_virtualDiameter_le_of_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .left‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.redDisplacement .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .right‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .left‖) / 2) : + (blueRootRedTrianglePacking configuration + (h.child_distance .red .left (by simp)) + (h.child_distance .red .right (by simp))).virtualDiameter ≤ + barC * (1 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2) := by + let target := barC * (1 + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2) + obtain ⟨htargetTwo, htargetSibling, hrootTarget, hleftTarget, hrightTarget⟩ := + blue_root_red_triangle_target_bounds configuration h hleft hright + change 2 ≤ target at htargetTwo + change + 2 * dist (configuration .red .left) (configuration .red .right) ≤ target at htargetSibling + change _ ≤ target at hrootTarget hleftTarget hrightTarget + have hredLeft := h.child_distance .red .left (by simp) + have hredRight := h.child_distance .red .right (by simp) + have hred := triangle_pair_dist_le configuration .red hredLeft hredRight + htargetTwo htargetSibling + have hcross := blue_root_red_triangle_cross_le configuration h hrootTarget + hleftTarget hrightTarget + exact blueRootRedTrianglePacking_virtualDiameter_le configuration hredLeft hredRight + htargetTwo hred hcross + +private theorem blueRootRedTriangle_score_nonnegative_of_endpoint_bounds + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hleft : + ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .left‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .right‖) / 2) + (hright : + ‖configuration.rootDisplacement - configuration.redDisplacement .right‖ < barC - 1 + + ((barC - 1) * (‖configuration.redDisplacement .right‖ + barC) + + (barC + 1) * ‖configuration.redDisplacement .left‖) / 2) : + 0 ≤ (blueRootRedTrianglePacking configuration + (h.child_distance .red .left (by simp)) + (h.child_distance .red .right (by simp))).score barS := by + have hvirtual := blueRootRedTrianglePacking_virtualDiameter_le_of_endpoint_bounds + configuration h hleft hright + rw [SixPointPacking.score, blueRootRedTrianglePacking_totalRadius] + simp only [barS] + rw [show 2 * (barC / 2) = barC by ring] + apply sub_nonneg.mpr + apply (div_le_iff₀ barC_pos).2 + simpa only [mul_comm] using hvirtual + +/-- A row obstruction makes support `17` a nonnegative-score endpoint packing. -/ +theorem red_root_blue_triangle_score_nonnegative_of_row_obstruction + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (redLabel : SixPointLabel) (hredLabel : redLabel ≠ .root) + (hrow : + 2 + 2 * (barC - 1) * + dist (configuration .red .left) (configuration .red .right) + + (2 * barC - 1) * + dist (configuration .blue .left) (configuration .blue .right) ≤ + dist (configuration .red redLabel) (configuration .blue .left) + + dist (configuration .red redLabel) (configuration .blue .right)) : + 0 ≤ (redRootBlueTrianglePacking configuration + (h.child_distance .blue .left (by simp)) + (h.child_distance .blue .right (by simp))).score barS := by + obtain ⟨hleft, hright⟩ := + row_obstruction_endpoint_bounds configuration h redLabel hredLabel hrow + exact redRootBlueTriangle_score_nonnegative_of_endpoint_bounds configuration h hleft hright + +/-- A column obstruction makes support `71` a nonnegative-score endpoint packing. -/ +theorem blue_root_red_triangle_score_nonnegative_of_column_obstruction + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (blueLabel : SixPointLabel) (hblueLabel : blueLabel ≠ .root) + (hcolumn : + 2 + 2 * (barC - 1) * + dist (configuration .blue .left) (configuration .blue .right) + + (2 * barC - 1) * + dist (configuration .red .left) (configuration .red .right) ≤ + dist (configuration .red .left) (configuration .blue blueLabel) + + dist (configuration .red .right) (configuration .blue blueLabel)) : + 0 ≤ (blueRootRedTrianglePacking configuration + (h.child_distance .red .left (by simp)) + (h.child_distance .red .right (by simp))).score barS := by + obtain ⟨hleft, hright⟩ := + column_obstruction_endpoint_bounds configuration h blueLabel hblueLabel hcolumn + exact blueRootRedTriangle_score_nonnegative_of_endpoint_bounds configuration h hleft hright + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Scaling.lean b/LeanPool/Besicovitch/SixPoint/Scaling.lean new file mode 100644 index 0000000000..2765624e6e --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Scaling.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Score + +/-! +# Scaling six-point packing radii + +This file shrinks every radius while retaining the same centers and support. Shrinking creates the +strict score gain used when the density parameter is larger than the finite endpoint. +-/ + +@[expose] public section + +noncomputable section + +open scoped BigOperators + +namespace LeanPool.Besicovitch + +namespace SixPointPacking + +variable {configuration : SixPointConfiguration} + +/-- Shrink every packing radius by a factor in `[0, 1]`. -/ +def scaleRadii (packing : SixPointPacking configuration) (q : ℝ) (hq0 : 0 ≤ q) + (hq1 : q ≤ 1) : SixPointPacking configuration where + support := packing.support + meets_color := packing.meets_color + radius i := ⟨q * packing.radius i, + mul_nonneg hq0 (packing.radius i).property.1, + calc + q * (packing.radius i : ℝ) ≤ q * 1 := + mul_le_mul_of_nonneg_left (packing.radius i).property.2 hq0 + _ ≤ 1 := by simpa using hq1⟩ + same_color_disjoint i j hij hcolor := by + have hsum := packing.same_color_disjoint i j hij hcolor + have hsum_nonneg : 0 ≤ (packing.radius i : ℝ) + packing.radius j := + add_nonneg (packing.radius i).property.1 (packing.radius j).property.1 + have hshrink : q * ((packing.radius i : ℝ) + packing.radius j) ≤ + (packing.radius i : ℝ) + packing.radius j := by + nlinarith + calc + q * (packing.radius i : ℝ) + q * packing.radius j = + q * ((packing.radius i : ℝ) + packing.radius j) := by ring + _ ≤ (packing.radius i : ℝ) + packing.radius j := hshrink + _ ≤ _ := hsum + +@[simp] +theorem scaleRadii_totalRadius (packing : SixPointPacking configuration) (q : ℝ) + (hq0 : 0 ≤ q) (hq1 : q ≤ 1) : + (packing.scaleRadii q hq0 hq1).totalRadius = q * packing.totalRadius := by + simp [totalRadius, scaleRadii, Finset.mul_sum] + +/-- Shrinking radii cannot increase the virtual diameter. -/ +theorem scaleRadii_virtualDiameter_le (packing : SixPointPacking configuration) (q : ℝ) + (hq0 : 0 ≤ q) (hq1 : q ≤ 1) : + (packing.scaleRadii q hq0 hq1).virtualDiameter ≤ packing.virtualDiameter := by + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + have hri : q * (packing.radius i : ℝ) ≤ packing.radius i := by + nlinarith [(packing.radius i).property.1] + have hrj : q * (packing.radius j : ℝ) ≤ packing.radius j := by + nlinarith [(packing.radius j).property.1] + calc + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + q * packing.radius i + q * packing.radius j ≤ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j := by gcongr + _ ≤ packing.virtualDiameter := packing.pair_le_virtualDiameter i j + +/-- The score after shrinking has an explicit lower bound from the original diameter. -/ +theorem scaleRadii_score_ge (packing : SixPointPacking configuration) + {s β q lower : ℝ} (hs : 0 < s) (hβ : 0 < β) (hq : 0 ≤ q) (hq1 : q ≤ 1) + (hgain : s ≤ β * q) (hscore : 0 ≤ packing.score s) + (hlower : lower ≤ packing.virtualDiameter) : + lower * (β * q - s) / (2 * s * β) ≤ + (packing.scaleRadii q hq hq1).score β := by + have hcoefficient : 0 ≤ (β * q - s) / (2 * s * β) := by positivity + have hbase : packing.virtualDiameter / (2 * s) ≤ packing.totalRadius := by + simpa only [score, sub_nonneg] using hscore + have htotal : q * (packing.virtualDiameter / (2 * s)) ≤ + q * packing.totalRadius := mul_le_mul_of_nonneg_left hbase hq + have hdiameter : + (packing.scaleRadii q hq hq1).virtualDiameter / (2 * β) ≤ + packing.virtualDiameter / (2 * β) := by + exact div_le_div_of_nonneg_right + (packing.scaleRadii_virtualDiameter_le q hq hq1) (by positivity) + calc + lower * (β * q - s) / (2 * s * β) = + lower * ((β * q - s) / (2 * s * β)) := by ring + _ ≤ packing.virtualDiameter * ((β * q - s) / (2 * s * β)) := + mul_le_mul_of_nonneg_right hlower hcoefficient + _ = q * (packing.virtualDiameter / (2 * s)) - + packing.virtualDiameter / (2 * β) := by field_simp + _ ≤ q * packing.totalRadius - + (packing.scaleRadii q hq hq1).virtualDiameter / (2 * β) := + sub_le_sub htotal hdiameter + _ = (packing.scaleRadii q hq hq1).score β := by + rw [score, scaleRadii_totalRadius] + +/-- Shrinking by `q` gives positive score at `β` when `s < βq`. -/ +theorem scaleRadii_score_pos (packing : SixPointPacking configuration) + {s β q lower : ℝ} (hs : 0 < s) (hβ : 0 < β) (hq : 0 < q) (hq1 : q ≤ 1) + (hgain : s < β * q) (hscore : 0 ≤ packing.score s) + (hlower : lower ≤ packing.virtualDiameter) (hlower_pos : 0 < lower) : + 0 < (packing.scaleRadii q hq.le hq1).score β := by + have hdiameter_pos : 0 < packing.virtualDiameter := hlower_pos.trans_le hlower + have hbase : packing.virtualDiameter ≤ packing.totalRadius * (2 * s) := by + rw [score, sub_nonneg] at hscore + exact (div_le_iff₀ (by positivity : 0 < 2 * s)).1 hscore + have htotal_pos : 0 < packing.totalRadius := by + nlinarith + have hstrict : packing.virtualDiameter < q * packing.totalRadius * (2 * β) := by + calc + packing.virtualDiameter ≤ packing.totalRadius * (2 * s) := hbase + _ < q * packing.totalRadius * (2 * β) := by nlinarith + rw [score, scaleRadii_totalRadius, sub_pos] + apply (div_lt_iff₀ (by positivity : 0 < 2 * β)).2 + exact (packing.scaleRadii_virtualDiameter_le q hq.le hq1).trans_lt hstrict + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/Score.lean b/LeanPool/Besicovitch/SixPoint/Score.lean new file mode 100644 index 0000000000..be9607c2ed --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/Score.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.Packing + +/-! +# Stability of the six-point packing score + +This file controls the score when its parameter or the underlying center distances change. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +namespace SixPointPacking + +variable {configuration configuration' : SixPointConfiguration} + +/-- Increasing the score parameter adds an explicit virtual-diameter gain. -/ +theorem score_eq_add_gain (packing : SixPointPacking configuration) {s β : ℝ} (hs : 0 < s) + (hsβ : s < β) : + packing.score β = packing.score s + packing.virtualDiameter * (β - s) / (2 * s * β) := by + have hs0 : s ≠ 0 := ne_of_gt hs + have hβ0 : β ≠ 0 := ne_of_gt (hs.trans hsβ) + simp only [score] + field_simp + ring + +/-- The packing score is nondecreasing in its positive parameter. -/ +theorem score_mono (packing : SixPointPacking configuration) {s β : ℝ} (hs : 0 < s) + (hsβ : s < β) : packing.score s ≤ packing.score β := by + rw [packing.score_eq_add_gain hs hsβ] + exact le_add_of_nonneg_right <| div_nonneg + (mul_nonneg packing.virtualDiameter_nonneg (sub_nonneg.mpr hsβ.le)) + (mul_nonneg (mul_nonneg (by norm_num) hs.le) (hs.trans hsβ).le) + +/-- Transport a packing when every relevant same-color distance can only increase. -/ +def transport (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) : + SixPointPacking configuration' where + support := packing.support + meets_color := packing.meets_color + radius := packing.radius + same_color_disjoint i j hij hcolor := + (packing.same_color_disjoint i j hij hcolor).trans (hdistance i j hij hcolor) + +@[simp] +theorem transport_totalRadius (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) : + (packing.transport hdistance).totalRadius = packing.totalRadius := rfl + +/-- An upper perturbation of all supported distances bounds the transported virtual diameter. -/ +theorem transport_virtualDiameter_le_add (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) + {eta : ℝ} (hperturb : ∀ i j : packing.support, + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) ≤ + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + eta) : + (packing.transport hdistance).virtualDiameter ≤ packing.virtualDiameter + eta := by + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + calc + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ + (dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + eta) + + packing.radius i + packing.radius j := by + simpa only [transport] using + add_le_add_left (add_le_add_left (hperturb i j) (packing.radius i)) (packing.radius j) + _ = (dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j) + eta := by ring + _ ≤ packing.virtualDiameter + eta := + add_le_add_left (packing.pair_le_virtualDiameter i j) eta + +/-- A lower perturbation of all supported distances bounds the original virtual diameter. -/ +theorem virtualDiameter_le_transport_add (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) + {eta : ℝ} (hperturb : ∀ i j : packing.support, + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) + eta) : + packing.virtualDiameter ≤ (packing.transport hdistance).virtualDiameter + eta := by + unfold virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + calc + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ + (dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) + eta) + + packing.radius i + packing.radius j := by + exact add_le_add_left (add_le_add_left (hperturb i j) (packing.radius i)) + (packing.radius j) + _ = (dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) + + packing.radius i + packing.radius j) + eta := by ring + _ ≤ (packing.transport hdistance).virtualDiameter + eta := by + simpa only [transport] using + add_le_add_left ((packing.transport hdistance).pair_le_virtualDiameter i j) eta + +/-- Pairwise center errors bound the change in virtual diameter by the same error. -/ +theorem abs_transport_virtualDiameter_sub_le (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) + {eta : ℝ} (hperturb : ∀ i j : packing.support, + |dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) - + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2)| ≤ eta) : + |(packing.transport hdistance).virtualDiameter - packing.virtualDiameter| ≤ eta := by + rw [abs_sub_le_iff] + constructor + · exact sub_le_iff_le_add'.2 <| packing.transport_virtualDiameter_le_add hdistance fun i j ↦ + sub_le_iff_le_add'.1 (abs_sub_le_iff.1 (hperturb i j)).1 + · exact sub_le_iff_le_add'.2 <| packing.virtualDiameter_le_transport_add hdistance fun i j ↦ + sub_le_iff_le_add'.1 (abs_sub_le_iff.1 (hperturb i j)).2 + +/-- A controlled diameter error preserves strict positivity after increasing the parameter. -/ +theorem score_pos_of_virtualDiameter_error (packing : SixPointPacking configuration) + (packing' : SixPointPacking configuration') {s β lower eta : ℝ} (hs : 0 < s) (hsβ : s < β) + (hscore : 0 ≤ packing.score s) (hlower_pos : 0 < lower) + (hlower : lower ≤ packing.virtualDiameter) + (htotal : packing'.totalRadius = packing.totalRadius) + (hvirtual : packing'.virtualDiameter ≤ packing.virtualDiameter + eta) + (herror : s * eta < lower * (β - s)) : 0 < packing'.score β := by + have hβ : 0 < β := hs.trans hsβ + have hvisual : 0 < packing.virtualDiameter := hlower_pos.trans_le hlower + have hbase : packing.virtualDiameter ≤ packing.totalRadius * (2 * s) := by + rw [score, sub_nonneg] at hscore + exact (div_le_iff₀ (by positivity : 0 < 2 * s)).1 hscore + have hgain : lower * (β - s) ≤ packing.virtualDiameter * (β - s) := + mul_le_mul_of_nonneg_right hlower (sub_nonneg.mpr hsβ.le) + have hscaledVirtual := mul_le_mul_of_nonneg_left hvirtual hs.le + have hscaledBase := mul_le_mul_of_nonneg_left hbase hβ.le + have hdiameter : packing'.virtualDiameter < packing.totalRadius * (2 * β) := by + rw [← mul_lt_mul_iff_of_pos_left hs] + calc + s * packing'.virtualDiameter ≤ s * (packing.virtualDiameter + eta) := hscaledVirtual + _ < β * packing.virtualDiameter := by nlinarith + _ ≤ β * (packing.totalRadius * (2 * s)) := hscaledBase + _ = s * (packing.totalRadius * (2 * β)) := by ring + rw [score, htotal, sub_pos] + exact (div_lt_iff₀ (by positivity : 0 < 2 * β)).2 hdiameter + +/-- A transported packing has positive score when its center error is below the score gain. -/ +theorem transport_score_pos (packing : SixPointPacking configuration) + (hdistance : ∀ i j : packing.support, i ≠ j → i.1.1 = j.1.1 → + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ + dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2)) + {s β lower eta : ℝ} (hs : 0 < s) (hsβ : s < β) (hscore : 0 ≤ packing.score s) + (hlower_pos : 0 < lower) (hlower : lower ≤ packing.virtualDiameter) + (herror : s * eta < lower * (β - s)) + (hperturb : ∀ i j : packing.support, + |dist (configuration' i.1.1 i.1.2) (configuration' j.1.1 j.1.2) - + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2)| ≤ eta) : + 0 < (packing.transport hdistance).score β := by + refine packing.score_pos_of_virtualDiameter_error (packing.transport hdistance) hs hsβ hscore + hlower_pos hlower (packing.transport_totalRadius hdistance) ?_ herror + exact sub_le_iff_le_add'.1 + (abs_sub_le_iff.1 (packing.abs_transport_virtualDiameter_sub_le hdistance hperturb)).1 + +end SixPointPacking + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingFailureTree.lean b/LeanPool/Besicovitch/SixPoint/SiblingFailureTree.lean new file mode 100644 index 0000000000..955251e737 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingFailureTree.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.FailureTree +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# The sibling-triangle stage of the six-point failure tree + +Once the diagonal matching obstruction is selected, supports `67` and `76` either provide a +nonnegative-score packing or route their simultaneous failures into the finite incidence ledger. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Under the diagonal matching obstruction, the two sibling-triangle supports either win or +produce one of the residual incidence outcomes. -/ +theorem exists_nonnegative_score_or_siblingIncidenceOutcome + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + SiblingIncidenceOutcome configuration := by + by_cases hred : RedSiblingTriangleFails configuration h + · by_cases hblue : BlueSiblingTriangleFails configuration h + · exact Or.inr (siblingTriangle_score_failure_route h hmatching hred hblue) + · simp only [BlueSiblingTriangleFails, not_forall, not_lt] at hblue + obtain ⟨y, hyLower, hyUpper, hscore⟩ := hblue + exact Or.inl ⟨blueSiblingTrianglePackingAtEndpoint configuration h y hyLower hyUpper, + hscore⟩ + · simp only [RedSiblingTriangleFails, not_forall, not_lt] at hred + obtain ⟨x, hxLower, hxUpper, hscore⟩ := hred + exact Or.inl ⟨redSiblingTrianglePackingAtEndpoint configuration h x hxLower hxUpper, + hscore⟩ + +/-- The first two packing stages leave only a sibling incidence or the anti-diagonal matching. -/ +theorem exists_nonnegative_score_or_siblingIncidence_or_antiDiagonal + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + SiblingIncidenceOutcome configuration ∨ + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + dist (configuration .red .left) (configuration .blue .right) + + dist (configuration .red .right) (configuration .blue .left) := by + rcases exists_nonnegative_score_or_matching_obstruction configuration h with + hpacking | hdiagonal | hantiDiagonal + · exact Or.inl hpacking + · rcases exists_nonnegative_score_or_siblingIncidenceOutcome configuration h hdiagonal with + hpacking | houtcome + · exact Or.inl hpacking + · exact Or.inr (Or.inl houtcome) + · exact Or.inr (Or.inr hantiDiagonal) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingIncidence.lean b/LeanPool/Besicovitch/SixPoint/SiblingIncidence.lean new file mode 100644 index 0000000000..ea761df8d4 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingIncidence.lean @@ -0,0 +1,941 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.SiblingTriangle +public import LeanPool.Besicovitch.SixPoint.SiblingTangent + +/-! +# Incidences in the sibling--triangle branch + +This file encodes the finite incidence ledger for simultaneous failures of supports `67` and +`76`. Endpoint and balanced witnesses use the four codes from the paper, and the orbit types +are exactly the six, eight, and seven cases left by the fixed diagonal matching. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The child at one coordinate of an incidence code. -/ +def incidenceChild : Fin 2 → SixPointLabel + | 0 => .left + | 1 => .right + +/-- The other child index. -/ +def otherChild : Fin 2 → Fin 2 + | 0 => 1 + | 1 => 0 + +/-- The first child coordinate in the code `2 i + j`. -/ +def incidenceFirst : Fin 4 → Fin 2 + | 0 => 0 + | 1 => 0 + | 2 => 1 + | 3 => 1 + +/-- The second child coordinate in the code `2 i + j`. -/ +def incidenceSecond : Fin 4 → Fin 2 + | 0 => 0 + | 1 => 1 + | 2 => 0 + | 3 => 1 + +/-- A sibling--triangle failure is witnessed by an endpoint or a balanced pair of terms. -/ +inductive SiblingTriangleWitness + | endpoint (code : Fin 4) + | balanced (code : Fin 4) + deriving DecidableEq + +/-- Simultaneously swapping the two children sends an endpoint code `a` to `3 - a`. -/ +def swapEndpointCode : Fin 4 → Fin 4 + | 0 => 3 + | 1 => 2 + | 2 => 1 + | 3 => 0 + +/-- Transposing the two colors transposes an endpoint's two coordinates. -/ +def transposeEndpointCode : Fin 4 → Fin 4 + | 0 => 0 + | 1 => 2 + | 2 => 1 + | 3 => 3 + +/-- Put a blue endpoint witness into the common `(red child, blue child)` code convention. -/ +def transposeBlueEndpointWitness : SiblingTriangleWitness → SiblingTriangleWitness + | .endpoint code => .endpoint (transposeEndpointCode code) + | .balanced code => .balanced code + +/-- Simultaneously swapping the children exchanges balanced codes `0` and `3`. -/ +def swapBalancedCode : Fin 4 → Fin 4 + | 0 => 3 + | 1 => 1 + | 2 => 2 + | 3 => 0 + +/-- The six endpoint--endpoint orbits relative to the diagonal matching. -/ +inductive EndpointEndpointOrbit + | matchedCoincident + | offMatchingCoincident + | adjacentFirst + | adjacentSecond + | matchingDisjoint + | offMatchingDisjoint + deriving DecidableEq + +/-- The eight endpoint--balanced orbits after orienting the endpoint from red to blue. -/ +inductive EndpointBalancedOrbit + | e0s0 + | e0s1 + | e0s2 + | e0s3 + | e1s0 + | e1s1 + | e1s2 + | e1s3 + deriving DecidableEq + +/-- The seven balanced--balanced orbits relative to the diagonal matching. -/ +inductive BalancedBalancedOrbit + | s0s0 + | s0s3 + | s0s1 + | s0s2 + | s1s1 + | s1s2 + | s2s2 + deriving DecidableEq + +/-- Classify an ordered pair of endpoint codes under child swap and color transposition. -/ +def endpointEndpointOrbit : Fin 4 → Fin 4 → EndpointEndpointOrbit + | 0, 0 | 3, 3 => .matchedCoincident + | 1, 1 | 2, 2 => .offMatchingCoincident + | 0, 1 | 3, 2 | 2, 0 | 1, 3 => .adjacentFirst + | 0, 2 | 3, 1 | 1, 0 | 2, 3 => .adjacentSecond + | 0, 3 | 3, 0 => .matchingDisjoint + | 1, 2 | 2, 1 => .offMatchingDisjoint + +/-- Classify an endpoint code and a balanced code under simultaneous child swap. -/ +def endpointBalancedOrbit : Fin 4 → Fin 4 → EndpointBalancedOrbit + | 0, 0 | 3, 3 => .e0s0 + | 0, 1 | 3, 1 => .e0s1 + | 0, 2 | 3, 2 => .e0s2 + | 0, 3 | 3, 0 => .e0s3 + | 1, 0 | 2, 3 => .e1s0 + | 1, 1 | 2, 1 => .e1s1 + | 1, 2 | 2, 2 => .e1s2 + | 1, 3 | 2, 0 => .e1s3 + +/-- Classify an ordered pair of balanced codes under child swap and color transposition. -/ +def balancedBalancedOrbit : Fin 4 → Fin 4 → BalancedBalancedOrbit + | 0, 0 | 3, 3 => .s0s0 + | 0, 3 | 3, 0 => .s0s3 + | 0, 1 | 3, 1 | 1, 0 | 1, 3 => .s0s1 + | 0, 2 | 3, 2 | 2, 0 | 2, 3 => .s0s2 + | 1, 1 => .s1s1 + | 1, 2 | 2, 1 => .s1s2 + | 2, 2 => .s2s2 + +/-- The matched coincident orbit consists exactly of the two diagonal coincidences. -/ +theorem endpointEndpointOrbit_eq_matchedCoincident_iff (redCode blueCode : Fin 4) : + endpointEndpointOrbit redCode blueCode = .matchedCoincident ↔ + (redCode = 0 ∧ blueCode = 0) ∨ (redCode = 3 ∧ blueCode = 3) := by + fin_cases redCode <;> fin_cases blueCode <;> simp [endpointEndpointOrbit] + +/-- The endpoint--endpoint classifier is unchanged by simultaneous child swap. -/ +@[simp] theorem endpointEndpointOrbit_swap (redCode blueCode : Fin 4) : + endpointEndpointOrbit (swapEndpointCode redCode) (swapEndpointCode blueCode) = + endpointEndpointOrbit redCode blueCode := by + fin_cases redCode <;> fin_cases blueCode <;> + rfl + +/-- The endpoint--endpoint classifier is unchanged by color transposition. -/ +@[simp] theorem endpointEndpointOrbit_transpose (redCode blueCode : Fin 4) : + endpointEndpointOrbit (transposeEndpointCode blueCode) + (transposeEndpointCode redCode) = endpointEndpointOrbit redCode blueCode := by + fin_cases redCode <;> fin_cases blueCode <;> + rfl + +/-- The endpoint--balanced classifier is unchanged by simultaneous child swap. -/ +@[simp] theorem endpointBalancedOrbit_swap (endpointCode balancedCode : Fin 4) : + endpointBalancedOrbit (swapEndpointCode endpointCode) (swapBalancedCode balancedCode) = + endpointBalancedOrbit endpointCode balancedCode := by + fin_cases endpointCode <;> fin_cases balancedCode <;> + rfl + +/-- The balanced--balanced classifier is unchanged by simultaneous child swap. -/ +@[simp] theorem balancedBalancedOrbit_swap (redCode blueCode : Fin 4) : + balancedBalancedOrbit (swapBalancedCode redCode) (swapBalancedCode blueCode) = + balancedBalancedOrbit redCode blueCode := by + fin_cases redCode <;> fin_cases blueCode <;> + rfl + +/-- The balanced--balanced classifier is unchanged by color transposition. -/ +theorem balancedBalancedOrbit_transpose (redCode blueCode : Fin 4) : + balancedBalancedOrbit blueCode redCode = balancedBalancedOrbit redCode blueCode := by + fin_cases redCode <;> fin_cases blueCode <;> + rfl + +/-- The threshold inequality selected by an endpoint or balanced sibling witness. -/ +def siblingTriangleWitnessExceeds (L T : ℝ) (leftReach rightReach : SixPointLabel → ℝ) : + SiblingTriangleWitness → Prop + | .endpoint code => + let reach := if incidenceFirst code = 0 then leftReach else rightReach + T < L - 1 + reach (incidenceChild (incidenceSecond code)) + | .balanced code => + 2 * T < L + leftReach (incidenceChild (incidenceFirst code)) + + rightReach (incidenceChild (incidenceSecond code)) + +/-- Removing root-labelled primitives turns the minimax route into one of the eight incidences. -/ +theorem exists_siblingTriangleWitnessExceeds_of_failure + {L M T : ℝ} {leftReach rightReach : SixPointLabel → ℝ} + (hL : L ≤ 2) (hsameL : 2 * L ≤ T) (hsameM : 2 * M ≤ T) + (hleftRoot : L - 1 + leftReach .root ≤ T) + (hrightRoot : L - 1 + rightReach .root ≤ T) + (hbalancedRoot : ∀ leftLabel rightLabel, + leftLabel = .root ∨ rightLabel = .root → + L + leftReach leftLabel + rightReach rightLabel ≤ 2 * T) + (hfail : ∀ x : ℝ, L - 1 ≤ x → x ≤ 1 → + T < siblingTriangleSplitDiameter L M x leftReach rightReach) : + ∃ witness, siblingTriangleWitnessExceeds L T leftReach rightReach witness := by + rcases siblingTriangle_failure_routing hL hsameL hsameM hfail with + ⟨label, hlabel⟩ | ⟨label, hlabel⟩ | ⟨leftLabel, rightLabel, hlabels⟩ + · cases label with + | root => exact (not_lt_of_ge hleftRoot hlabel).elim + | left => exact ⟨.endpoint 0, hlabel⟩ + | right => exact ⟨.endpoint 1, hlabel⟩ + · cases label with + | root => exact (not_lt_of_ge hrightRoot hlabel).elim + | left => exact ⟨.endpoint 2, hlabel⟩ + | right => exact ⟨.endpoint 3, hlabel⟩ + · cases leftLabel <;> cases rightLabel + · exact (not_lt_of_ge (hbalancedRoot .root .root (Or.inl rfl)) hlabels).elim + · exact (not_lt_of_ge (hbalancedRoot .root .left (Or.inl rfl)) hlabels).elim + · exact (not_lt_of_ge (hbalancedRoot .root .right (Or.inl rfl)) hlabels).elim + · exact (not_lt_of_ge (hbalancedRoot .left .root (Or.inr rfl)) hlabels).elim + · exact ⟨.balanced 0, hlabels⟩ + · exact ⟨.balanced 1, hlabels⟩ + · exact (not_lt_of_ge (hbalancedRoot .right .root (Or.inr rfl)) hlabels).elim + · exact ⟨.balanced 2, hlabels⟩ + · exact ⟨.balanced 3, hlabels⟩ + +/-- The total canonical radius of one color's rooted triangle. -/ +def rootedTriangleTotalRadius (configuration : SixPointConfiguration) + (color : SixPointColor) : ℝ := + (dist (configuration color .root) (configuration color .left) + + dist (configuration color .root) (configuration color .right) + + dist (configuration color .left) (configuration color .right)) / 2 + +/-- The diameter threshold for support `67` at the exact endpoint. -/ +def redSiblingTriangleTarget (configuration : SixPointConfiguration) : ℝ := + barC * (dist (configuration .red .left) (configuration .red .right) + + rootedTriangleTotalRadius configuration .blue) + +/-- The diameter threshold for support `76` at the exact endpoint. -/ +def blueSiblingTriangleTarget (configuration : SixPointConfiguration) : ℝ := + barC * (dist (configuration .blue .left) (configuration .blue .right) + + rootedTriangleTotalRadius configuration .red) + +/-- The exact endpoint or balanced failure inequality for support `67`. -/ +def redSiblingTriangleFailure (configuration : SixPointConfiguration) : + SiblingTriangleWitness → Prop := + siblingTriangleWitnessExceeds + (dist (configuration .red .left) (configuration .red .right)) + (redSiblingTriangleTarget configuration) + (redSiblingBlueTriangleReach configuration .left) + (redSiblingBlueTriangleReach configuration .right) + +/-- The exact endpoint or balanced failure inequality for support `76`. -/ +def blueSiblingTriangleFailure (configuration : SixPointConfiguration) : + SiblingTriangleWitness → Prop := + fun witness ↦ siblingTriangleWitnessExceeds + (dist (configuration .blue .left) (configuration .blue .right)) + (blueSiblingTriangleTarget configuration) + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right) + (transposeBlueEndpointWitness witness) + +/-- The average of the two root-to-child distances at a matched child index. -/ +def matchedChildAverage (configuration : SixPointConfiguration) (child : Fin 2) : ℝ := + (dist (configuration .red .root) (configuration .red (incidenceChild child)) + + dist (configuration .blue .root) (configuration .blue (incidenceChild child))) / 2 + +private theorem barC_internal_gap_pos : 0 < barC ^ 2 + 2 * barC - 4 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem barC_root_endpoint_gap_pos : 0 < 2 * barC ^ 2 - barC / 2 - 2 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem barC_balanced_root_gap_pos : 6 < 4 * barC ^ 2 - barC := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem barC_disjoint_gap_neg : 2 + 4 * barC - 4 * barC ^ 2 < 0 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem sibling_internal_terms_le_target {L M U : ℝ} + (hL : barC ≤ L ∧ L ≤ 2) (hM : barC ≤ M ∧ M ≤ 2) (hMU : M ≤ U) : + 2 * L ≤ barC * (L + U) ∧ 2 * M ≤ barC * (L + U) := by + have hc_two : barC - 2 ≤ 0 := by linarith [one_lt_barC_and_barC_lt_two.2] + have hc_nonneg : 0 ≤ barC := barC_pos.le + have htarget : barC * (L + M) ≤ barC * (L + U) := by + apply mul_le_mul_of_nonneg_left _ hc_nonneg + linarith + have hLM := mul_le_mul_of_nonneg_left hM.1 hc_nonneg + have hML := mul_le_mul_of_nonneg_left hL.1 hc_nonneg + have hLnegative := mul_le_mul_of_nonpos_left hL.2 hc_two + have hMnegative := mul_le_mul_of_nonpos_left hM.2 hc_two + constructor + · apply le_trans (le_of_lt ?_) htarget + nlinarith [barC_internal_gap_pos] + · apply le_trans (le_of_lt ?_) htarget + nlinarith [barC_internal_gap_pos] + +private theorem root_endpoint_le_target {L M U reach : ℝ} + (hL : barC ≤ L) (hM : barC ≤ M) (hMU : M ≤ U) + (hreach : reach ≤ 3 - M / 2) : L - 1 + reach ≤ barC * (L + U) := by + have hc_nonneg : 0 ≤ barC := barC_pos.le + have hc_sub_one : 0 ≤ barC - 1 := by linarith [one_lt_barC_and_barC_lt_two.1] + have hc_add_half : 0 ≤ barC + 1 / 2 := by positivity + have hLscaled := mul_le_mul_of_nonneg_left hL hc_sub_one + have hMscaled := mul_le_mul_of_nonneg_left hM hc_add_half + have htarget : barC * (L + M) ≤ barC * (L + U) := by + apply mul_le_mul_of_nonneg_left _ hc_nonneg + linarith + nlinarith [barC_root_endpoint_gap_pos] + +private theorem balanced_root_le_target {L M U reachSum : ℝ} + (hL : barC ≤ L) (hM : barC ≤ M) (hMU : M ≤ U) + (hreach : reachSum ≤ 6) : L + reachSum ≤ 2 * (barC * (L + U)) := by + have hc_nonneg : 0 ≤ barC := barC_pos.le + have htwoCSubOne : 0 ≤ 2 * barC - 1 := by nlinarith [one_lt_barC_and_barC_lt_two.1] + have htwoC : 0 ≤ 2 * barC := by positivity + have hLscaled := mul_le_mul_of_nonneg_left hL htwoCSubOne + have hMscaled := mul_le_mul_of_nonneg_left hM htwoC + have htarget : barC * (L + M) ≤ barC * (L + U) := by + apply mul_le_mul_of_nonneg_left _ hc_nonneg + linarith + nlinarith [barC_balanced_root_gap_pos] + +/-- Each sibling length in an endpoint-admissible configuration lies between `barC` and two. -/ +theorem sibling_distance_mem_endpoint_interval {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (color : SixPointColor) : + barC ≤ dist (configuration color .left) (configuration color .right) ∧ + dist (configuration color .left) (configuration color .right) ≤ 2 := by + constructor + · have hsibling := h.sibling_distance color + rw [barS] at hsibling + linarith + · calc + dist (configuration color .left) (configuration color .right) ≤ + dist (configuration color .left) (configuration color .root) + + dist (configuration color .root) (configuration color .right) := + dist_triangle _ _ _ + _ ≤ 1 + 1 := add_le_add (by simpa [dist_comm] using h.child_distance color .left (by simp)) + (h.child_distance color .right (by simp)) + _ = 2 := by norm_num + +/-- The canonical triangle total lies between its sibling side and two. -/ +theorem rootedTriangleTotalRadius_mem_endpoint_interval + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (color : SixPointColor) : + dist (configuration color .left) (configuration color .right) ≤ + rootedTriangleTotalRadius configuration color ∧ + rootedTriangleTotalRadius configuration color ≤ 2 := by + have hleft := h.child_distance color .left (by simp) + have hright := h.child_distance color .right (by simp) + have hsibling := (sibling_distance_mem_endpoint_interval h color).2 + have htriangle := dist_triangle (configuration color .left) (configuration color .root) + (configuration color .right) + rw [dist_comm (configuration color .left) (configuration color .root)] at htriangle + simp only [rootedTriangleTotalRadius] + constructor <;> nlinarith + +private theorem red_child_blue_root_distance_le_two {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (redLabel : SixPointLabel) + (hred : redLabel ≠ .root) : + dist (configuration .red redLabel) (configuration .blue .root) ≤ 2 := by + calc + _ ≤ dist (configuration .red redLabel) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue .root) := dist_triangle _ _ _ + _ ≤ 1 + 1 := add_le_add (by simpa [dist_comm] using h.child_distance .red redLabel hred) + h.root_distance.le + _ = 2 := by norm_num + +private theorem blue_child_red_root_distance_le_two {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (blueLabel : SixPointLabel) + (hblue : blueLabel ≠ .root) : + dist (configuration .blue blueLabel) (configuration .red .root) ≤ 2 := by + calc + _ ≤ dist (configuration .blue blueLabel) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .red .root) := dist_triangle _ _ _ + _ ≤ 1 + 1 := add_le_add (by simpa [dist_comm] using h.child_distance .blue blueLabel hblue) + (by simpa [dist_comm] using h.root_distance.le) + _ = 2 := by norm_num + +private theorem cross_child_distance_le_three {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (redLabel blueLabel : SixPointLabel) + (hred : redLabel ≠ .root) (hblue : blueLabel ≠ .root) : + dist (configuration .red redLabel) (configuration .blue blueLabel) ≤ 3 := by + calc + _ ≤ dist (configuration .red redLabel) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .blue blueLabel) := dist_triangle _ _ _ + _ ≤ 2 + 1 := add_le_add (red_child_blue_root_distance_le_two h redLabel hred) + (h.child_distance .blue blueLabel hblue) + _ = 3 := by norm_num + +private theorem cross_child_distance_le_one_add_root_distances + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (redLabel blueLabel : SixPointLabel) : + dist (configuration .red redLabel) (configuration .blue blueLabel) ≤ + 1 + dist (configuration .red .root) (configuration .red redLabel) + + dist (configuration .blue .root) (configuration .blue blueLabel) := by + calc + _ ≤ dist (configuration .red redLabel) (configuration .red .root) + + dist (configuration .red .root) (configuration .blue blueLabel) := dist_triangle _ _ _ + _ ≤ dist (configuration .red redLabel) (configuration .red .root) + + (dist (configuration .red .root) (configuration .blue .root) + + dist (configuration .blue .root) (configuration .blue blueLabel)) := by + have htriangle := dist_triangle (configuration .red .root) + (configuration .blue .root) (configuration .blue blueLabel) + linarith + _ = _ := by rw [h.root_distance, dist_comm (configuration .red redLabel)]; ring + +private theorem red_reach_root_le {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (redLabel : SixPointLabel) + (hred : redLabel ≠ .root) : + redSiblingBlueTriangleReach configuration redLabel .root ≤ + 3 - dist (configuration .blue .left) (configuration .blue .right) / 2 := by + have hleft := h.child_distance .blue .left (by simp) + have hright := h.child_distance .blue .right (by simp) + have hdist := red_child_blue_root_distance_le_two h redLabel hred + simp only [redSiblingBlueTriangleReach, canonicalTriangleRadius] + nlinarith + +private theorem blue_reach_root_le {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (blueLabel : SixPointLabel) + (hblue : blueLabel ≠ .root) : + blueSiblingRedTriangleReach configuration blueLabel .root ≤ + 3 - dist (configuration .red .left) (configuration .red .right) / 2 := by + have hleft := h.child_distance .red .left (by simp) + have hright := h.child_distance .red .right (by simp) + have hdist := blue_child_red_root_distance_le_two h blueLabel hblue + simp only [blueSiblingRedTriangleReach, canonicalTriangleRadius] + nlinarith + +private theorem red_balanced_root_reaches_le_six {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (leftTarget rightTarget : SixPointLabel) + (hroot : leftTarget = .root ∨ rightTarget = .root) : + redSiblingBlueTriangleReach configuration .left leftTarget + + redSiblingBlueTriangleReach configuration .right rightTarget ≤ 6 := by + cases leftTarget <;> cases rightTarget + · have hleft := red_child_blue_root_distance_le_two h .left (by simp) + have hright := red_child_blue_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_le_average (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) + have hblueLeft := h.child_distance .blue .left (by simp) + have hblueRight := h.child_distance .blue .right (by simp) + simp only [redSiblingBlueTriangleReach] + nlinarith + · have hleft := red_child_blue_root_distance_le_two h .left (by simp) + have hright := cross_child_distance_le_three h .right .left (by simp) (by simp) + have hradius := canonicalTriangleRadius_root_add_left (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) + have hblue := h.child_distance .blue .left (by simp) + simp only [redSiblingBlueTriangleReach] + nlinarith + · have hleft := red_child_blue_root_distance_le_two h .left (by simp) + have hright := cross_child_distance_le_three h .right .right (by simp) (by simp) + have hradius := canonicalTriangleRadius_root_add_right (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) + have hblue := h.child_distance .blue .right (by simp) + simp only [redSiblingBlueTriangleReach] + nlinarith + · have hleft := cross_child_distance_le_three h .left .left (by simp) (by simp) + have hright := red_child_blue_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_add_left (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) + have hblue := h.child_distance .blue .left (by simp) + simp only [redSiblingBlueTriangleReach] + nlinarith + · simp at hroot + · simp at hroot + · have hleft := cross_child_distance_le_three h .left .right (by simp) (by simp) + have hright := red_child_blue_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_add_right (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) + have hblue := h.child_distance .blue .right (by simp) + simp only [redSiblingBlueTriangleReach] + nlinarith + · simp at hroot + · simp at hroot + +private theorem blue_balanced_root_reaches_le_six {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (leftTarget rightTarget : SixPointLabel) + (hroot : leftTarget = .root ∨ rightTarget = .root) : + blueSiblingRedTriangleReach configuration .left leftTarget + + blueSiblingRedTriangleReach configuration .right rightTarget ≤ 6 := by + cases leftTarget <;> cases rightTarget + · have hleft := blue_child_red_root_distance_le_two h .left (by simp) + have hright := blue_child_red_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_le_average (configuration .red .root) + (configuration .red .left) (configuration .red .right) + have hredLeft := h.child_distance .red .left (by simp) + have hredRight := h.child_distance .red .right (by simp) + simp only [blueSiblingRedTriangleReach] + nlinarith + · have hleft := blue_child_red_root_distance_le_two h .left (by simp) + have hright : dist (configuration .blue .right) (configuration .red .left) ≤ 3 := by + simpa [dist_comm] using cross_child_distance_le_three h .left .right (by simp) (by simp) + have hradius := canonicalTriangleRadius_root_add_left (configuration .red .root) + (configuration .red .left) (configuration .red .right) + have hred := h.child_distance .red .left (by simp) + simp only [blueSiblingRedTriangleReach] + nlinarith + · have hleft := blue_child_red_root_distance_le_two h .left (by simp) + have hright : dist (configuration .blue .right) (configuration .red .right) ≤ 3 := by + simpa [dist_comm] using cross_child_distance_le_three h .right .right (by simp) (by simp) + have hradius := canonicalTriangleRadius_root_add_right (configuration .red .root) + (configuration .red .left) (configuration .red .right) + have hred := h.child_distance .red .right (by simp) + simp only [blueSiblingRedTriangleReach] + nlinarith + · have hleft : dist (configuration .blue .left) (configuration .red .left) ≤ 3 := by + simpa [dist_comm] using cross_child_distance_le_three h .left .left (by simp) (by simp) + have hright := blue_child_red_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_add_left (configuration .red .root) + (configuration .red .left) (configuration .red .right) + have hred := h.child_distance .red .left (by simp) + simp only [blueSiblingRedTriangleReach] + nlinarith + · simp at hroot + · simp at hroot + · have hleft : dist (configuration .blue .left) (configuration .red .right) ≤ 3 := by + simpa [dist_comm] using cross_child_distance_le_three h .right .left (by simp) (by simp) + have hright := blue_child_red_root_distance_le_two h .right (by simp) + have hradius := canonicalTriangleRadius_root_add_right (configuration .red .root) + (configuration .red .left) (configuration .red .right) + have hred := h.child_distance .red .right (by simp) + simp only [blueSiblingRedTriangleReach] + nlinarith + · simp at hroot + · simp at hroot + +/-- Failure of every radius split in support `67` has a child-labelled incidence witness. -/ +theorem exists_redSiblingTriangleFailure_of_split_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfail : ∀ x : ℝ, + dist (configuration .red .left) (configuration .red .right) - 1 ≤ x → x ≤ 1 → + redSiblingTriangleTarget configuration < + siblingTriangleSplitDiameter + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x + (redSiblingBlueTriangleReach configuration .left) + (redSiblingBlueTriangleReach configuration .right)) : + ∃ witness, redSiblingTriangleFailure configuration witness := by + have hred := sibling_distance_mem_endpoint_interval h .red + have hblue := sibling_distance_mem_endpoint_interval h .blue + have hblueTotal := rootedTriangleTotalRadius_mem_endpoint_interval h .blue + have hinternal := sibling_internal_terms_le_target hred hblue hblueTotal.1 + have hleftRoot := root_endpoint_le_target hred.1 hblue.1 hblueTotal.1 + (red_reach_root_le h .left (by simp)) + have hrightRoot := root_endpoint_le_target hred.1 hblue.1 hblueTotal.1 + (red_reach_root_le h .right (by simp)) + have hbalancedRoot (leftTarget rightTarget : SixPointLabel) + (hroot : leftTarget = .root ∨ rightTarget = .root) := + balanced_root_le_target hred.1 hblue.1 hblueTotal.1 + (red_balanced_root_reaches_le_six h leftTarget rightTarget hroot) + apply exists_siblingTriangleWitnessExceeds_of_failure hred.2 + (T := redSiblingTriangleTarget configuration) + (leftReach := redSiblingBlueTriangleReach configuration .left) + (rightReach := redSiblingBlueTriangleReach configuration .right) + · simpa [redSiblingTriangleTarget] using hinternal.1 + · simpa [redSiblingTriangleTarget] using hinternal.2 + · simpa [redSiblingTriangleTarget] using hleftRoot + · simpa [redSiblingTriangleTarget] using hrightRoot + · intro leftTarget rightTarget hroot + simpa [redSiblingTriangleTarget, add_assoc] using + hbalancedRoot leftTarget rightTarget hroot + · exact hfail + +/-- Failure of every radius split in support `76` has a child-labelled incidence witness. -/ +theorem exists_blueSiblingTriangleFailure_of_split_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfail : ∀ y : ℝ, + dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y → y ≤ 1 → + blueSiblingTriangleTarget configuration < + siblingTriangleSplitDiameter + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .red .right)) y + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right)) : + ∃ witness, blueSiblingTriangleFailure configuration witness := by + have hblue := sibling_distance_mem_endpoint_interval h .blue + have hred := sibling_distance_mem_endpoint_interval h .red + have hredTotal := rootedTriangleTotalRadius_mem_endpoint_interval h .red + have hinternal := sibling_internal_terms_le_target hblue hred hredTotal.1 + have hleftRoot := root_endpoint_le_target hblue.1 hred.1 hredTotal.1 + (blue_reach_root_le h .left (by simp)) + have hrightRoot := root_endpoint_le_target hblue.1 hred.1 hredTotal.1 + (blue_reach_root_le h .right (by simp)) + have hbalancedRoot (leftTarget rightTarget : SixPointLabel) + (hroot : leftTarget = .root ∨ rightTarget = .root) := + balanced_root_le_target hblue.1 hred.1 hredTotal.1 + (blue_balanced_root_reaches_le_six h leftTarget rightTarget hroot) + have hexists : ∃ witness, siblingTriangleWitnessExceeds + (dist (configuration .blue .left) (configuration .blue .right)) + (blueSiblingTriangleTarget configuration) + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right) witness := by + apply exists_siblingTriangleWitnessExceeds_of_failure hblue.2 + (M := dist (configuration .red .left) (configuration .red .right)) + · simpa [blueSiblingTriangleTarget] using hinternal.1 + · simpa [blueSiblingTriangleTarget] using hinternal.2 + · simpa [blueSiblingTriangleTarget] using hleftRoot + · simpa [blueSiblingTriangleTarget] using hrightRoot + · intro leftTarget rightTarget hroot + simpa [blueSiblingTriangleTarget, add_assoc] using + hbalancedRoot leftTarget rightTarget hroot + · exact hfail + obtain ⟨witness, hwitness⟩ := hexists + cases witness with + | endpoint code => + refine ⟨.endpoint (transposeEndpointCode code), ?_⟩ + fin_cases code <;> exact hwitness + | balanced code => exact ⟨.balanced code, hwitness⟩ + +/-- The support `67` packing with its actual sibling length at the exact endpoint. -/ +def redSiblingTrianglePackingAtEndpoint (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) (x : ℝ) + (hxLower : dist (configuration .red .left) (configuration .red .right) - 1 ≤ x) + (hxUpper : x ≤ 1) : SixPointPacking configuration := + redSiblingBlueTrianglePacking configuration rfl + (one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .red).1) + hxLower hxUpper (h.child_distance .blue .left (by simp)) + (h.child_distance .blue .right (by simp)) + +/-- The support `76` packing with its actual sibling length at the exact endpoint. -/ +def blueSiblingTrianglePackingAtEndpoint (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) (y : ℝ) + (hyLower : dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y) + (hyUpper : y ≤ 1) : SixPointPacking configuration := + blueSiblingRedTrianglePacking configuration rfl + (one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .blue).1) + hyLower hyUpper (h.child_distance .red .left (by simp)) + (h.child_distance .red .right (by simp)) + +/-- Every feasible support `67` radius split has negative endpoint score. -/ +def RedSiblingTriangleFails (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) : Prop := + ∀ (x : ℝ) + (hxLower : dist (configuration .red .left) (configuration .red .right) - 1 ≤ x) + (hxUpper : x ≤ 1), + (redSiblingTrianglePackingAtEndpoint configuration h x hxLower hxUpper).score barS < 0 + +/-- Every feasible support `76` radius split has negative endpoint score. -/ +def BlueSiblingTriangleFails (configuration : SixPointConfiguration) + (h : configuration.IsAdmissibleAt barS) : Prop := + ∀ (y : ℝ) + (hyLower : dist (configuration .blue .left) (configuration .blue .right) - 1 ≤ y) + (hyUpper : y ≤ 1), + (blueSiblingTrianglePackingAtEndpoint configuration h y hyLower hyUpper).score barS < 0 + +/-- Negative score for every support `67` split yields a child-labelled failure witness. -/ +theorem exists_redSiblingTriangleFailure_of_score_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfailure : RedSiblingTriangleFails configuration h) : + ∃ witness, redSiblingTriangleFailure configuration witness := by + apply exists_redSiblingTriangleFailure_of_split_failure h + intro x hxLower hxUpper + have hscore := hfailure x hxLower hxUpper + have hredOne : 1 ≤ dist (configuration .red .left) (configuration .red .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .red).1 + have hblueOne : 1 ≤ dist (configuration .blue .left) (configuration .blue .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .blue).1 + simp only [redSiblingTrianglePackingAtEndpoint, SixPointPacking.score] at hscore + rw [redSiblingBlueTrianglePacking_totalRadius, + redSiblingBlueTrianglePacking_virtualDiameter (hM := hblueOne) (hMdist := rfl)] at hscore + rw [barS] at hscore + rw [show 2 * (barC / 2) = barC by ring] at hscore + have hquotient : + dist (configuration .red .left) (configuration .red .right) + + rootedTriangleTotalRadius configuration .blue < + siblingTriangleSplitDiameter + (dist (configuration .red .left) (configuration .red .right)) + (dist (configuration .blue .left) (configuration .blue .right)) x + (redSiblingBlueTriangleReach configuration .left) + (redSiblingBlueTriangleReach configuration .right) / barC := by + simp only [rootedTriangleTotalRadius] + linarith + rw [redSiblingTriangleTarget] + nlinarith [(lt_div_iff₀ barC_pos).1 hquotient] + +/-- Negative score for every support `76` split yields a child-labelled failure witness. -/ +theorem exists_blueSiblingTriangleFailure_of_score_failure + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hfailure : BlueSiblingTriangleFails configuration h) : + ∃ witness, blueSiblingTriangleFailure configuration witness := by + apply exists_blueSiblingTriangleFailure_of_split_failure h + intro y hyLower hyUpper + have hscore := hfailure y hyLower hyUpper + have hblueOne : 1 ≤ dist (configuration .blue .left) (configuration .blue .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .blue).1 + have hredOne : 1 ≤ dist (configuration .red .left) (configuration .red .right) := + one_lt_barC_and_barC_lt_two.1.le.trans + (sibling_distance_mem_endpoint_interval h .red).1 + simp only [blueSiblingTrianglePackingAtEndpoint, SixPointPacking.score] at hscore + rw [blueSiblingRedTrianglePacking_totalRadius, + blueSiblingRedTrianglePacking_virtualDiameter (hL := hredOne) (hLdist := rfl)] at hscore + rw [barS] at hscore + rw [show 2 * (barC / 2) = barC by ring] at hscore + have hquotient : + dist (configuration .blue .left) (configuration .blue .right) + + rootedTriangleTotalRadius configuration .red < + siblingTriangleSplitDiameter + (dist (configuration .blue .left) (configuration .blue .right)) + (dist (configuration .red .left) (configuration .red .right)) y + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right) / barC := by + simp only [rootedTriangleTotalRadius] + linarith + rw [blueSiblingTriangleTarget] + nlinarith [(lt_div_iff₀ barC_pos).1 hquotient] + +/-- Coincident endpoint failures at `B11` imply the first exact `q2` inequality. -/ +theorem q2_strict_of_matched_endpoint_zero {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) + (hred : redSiblingTriangleFailure configuration (.endpoint 0)) + (hblue : blueSiblingTriangleFailure configuration (.endpoint 0)) : + ((barC - 1) * matchedChildAverage configuration 0 + + (barC + 1) * matchedChildAverage configuration 1 + + 3 * barC ^ 2 - 3 * barC + 2) / 2 < + dist (configuration .red .left) (configuration .blue .left) := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 0 ≤ 3 * (barC - 1) / 2 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hsiblingSum := mul_le_mul_of_nonneg_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + hcoefficient + norm_num [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + matchedChildAverage] at hred hblue ⊢ + rw [dist_comm (configuration .blue .left) (configuration .red .left)] at hblue + nlinarith + +/-- Coincident endpoint failures at `B22` imply the child-swapped exact `q2` inequality. -/ +theorem q2_strict_of_matched_endpoint_three {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) + (hred : redSiblingTriangleFailure configuration (.endpoint 3)) + (hblue : blueSiblingTriangleFailure configuration (.endpoint 3)) : + ((barC - 1) * matchedChildAverage configuration 1 + + (barC + 1) * matchedChildAverage configuration 0 + + 3 * barC ^ 2 - 3 * barC + 2) / 2 < + dist (configuration .red .right) (configuration .blue .right) := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 0 ≤ 3 * (barC - 1) / 2 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hsiblingSum := mul_le_mul_of_nonneg_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + hcoefficient + norm_num [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + matchedChildAverage] at hred hblue ⊢ + rw [dist_comm (configuration .blue .right) (configuration .red .right)] at hblue + nlinarith + +/-- The selected-matching disjoint endpoint incidence is impossible. -/ +theorem not_redEndpoint_zero_and_blueEndpoint_three + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.endpoint 3)) := by + rintro ⟨hred, hblue⟩ + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hredTriangle := dist_triangle (configuration .red .left) (configuration .red .root) + (configuration .red .right) + have hblueTriangle := dist_triangle (configuration .blue .left) + (configuration .blue .root) (configuration .blue .right) + rw [dist_comm (configuration .red .left) (configuration .red .root)] at hredTriangle + rw [dist_comm (configuration .blue .left) (configuration .blue .root)] at hblueTriangle + have hselected : + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .blue .root) (configuration .blue .left) ≤ 2 := by + have hredRight := h.child_distance .red .right (by simp) + have hblueLeft := h.child_distance .blue .left (by simp) + linarith + have hB11 := cross_child_distance_le_one_add_root_distances h .left .left + have hB22 := cross_child_distance_le_one_add_root_distances h .right .right + have hsum : + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) ≤ + (dist (configuration .red .root) (configuration .red .right) + + dist (configuration .blue .root) (configuration .blue .left)) + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .blue .root) (configuration .blue .right)) := by + linarith + have hsumScaled := mul_le_mul_of_nonpos_left hsum + (show (1 - barC) / 2 ≤ 0 by nlinarith [one_lt_barC_and_barC_lt_two.1]) + have hPscaled := mul_le_mul_of_nonpos_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + (show 2 * (1 - barC) ≤ 0 by nlinarith [one_lt_barC_and_barC_lt_two.1]) + norm_num [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius] + at hred hblue + rw [dist_comm (configuration .blue .right) (configuration .red .right)] at hblue + nlinarith [barC_disjoint_gap_neg] + +/-- The off-matching disjoint endpoint incidence is impossible. -/ +theorem not_redEndpoint_one_and_blueEndpoint_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.endpoint 2)) := by + rintro ⟨hred, hblue⟩ + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hredTriangle := dist_triangle (configuration .red .left) (configuration .red .root) + (configuration .red .right) + have hblueTriangle := dist_triangle (configuration .blue .left) + (configuration .blue .root) (configuration .blue .right) + rw [dist_comm (configuration .red .left) (configuration .red .root)] at hredTriangle + rw [dist_comm (configuration .blue .left) (configuration .blue .root)] at hblueTriangle + have hselected : + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .blue .root) (configuration .blue .right) ≤ 2 := by + have hredRight := h.child_distance .red .right (by simp) + have hblueRight := h.child_distance .blue .right (by simp) + linarith + have hB12 := cross_child_distance_le_one_add_root_distances h .left .right + have hB21 := cross_child_distance_le_one_add_root_distances h .right .left + have hsum : + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) ≤ + (dist (configuration .red .root) (configuration .red .right) + + dist (configuration .blue .root) (configuration .blue .right)) + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .blue .root) (configuration .blue .left)) := by + linarith + have hsumScaled := mul_le_mul_of_nonpos_left hsum + (show (1 - barC) / 2 ≤ 0 by nlinarith [one_lt_barC_and_barC_lt_two.1]) + have hPscaled := mul_le_mul_of_nonpos_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + (show 2 * (1 - barC) ≤ 0 by nlinarith [one_lt_barC_and_barC_lt_two.1]) + norm_num [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, incidenceFirst, incidenceSecond, incidenceChild, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius] + at hred hblue + rw [dist_comm (configuration .blue .left) (configuration .red .right)] at hblue + nlinarith [barC_disjoint_gap_neg] + +/-- The analytic exclusions required by the complete sibling-incidence ledger. -/ +structure SiblingIncidenceExclusions + (redFailure blueFailure : SiblingTriangleWitness → Prop) : Prop where + endpointEndpoint : ∀ redCode blueCode, + endpointEndpointOrbit redCode blueCode ≠ .matchedCoincident → + ¬ (redFailure (.endpoint redCode) ∧ blueFailure (.endpoint blueCode)) + endpointBalanced : ∀ endpointCode balancedCode, + ¬ (redFailure (.endpoint endpointCode) ∧ blueFailure (.balanced balancedCode)) + balancedEndpoint : ∀ balancedCode endpointCode, + ¬ (redFailure (.balanced balancedCode) ∧ blueFailure (.endpoint endpointCode)) + balancedBalanced : ∀ redCode blueCode, + ¬ (redFailure (.balanced redCode) ∧ blueFailure (.balanced blueCode)) + +/-- Complete incidence routing: the only simultaneous failures select one diagonal endpoint. -/ +theorem exists_matched_endpoint_of_siblingIncidenceExclusions + {redFailure blueFailure : SiblingTriangleWitness → Prop} + (hexclusions : SiblingIncidenceExclusions redFailure blueFailure) + (hred : ∃ witness, redFailure witness) (hblue : ∃ witness, blueFailure witness) : + ∃ code : Fin 4, (code = 0 ∨ code = 3) ∧ + redFailure (.endpoint code) ∧ blueFailure (.endpoint code) := by + obtain ⟨redWitness, hred⟩ := hred + obtain ⟨blueWitness, hblue⟩ := hblue + cases redWitness with + | endpoint redCode => + cases blueWitness with + | endpoint blueCode => + have horbit : endpointEndpointOrbit redCode blueCode = .matchedCoincident := by + by_contra hne + exact hexclusions.endpointEndpoint redCode blueCode hne ⟨hred, hblue⟩ + rcases (endpointEndpointOrbit_eq_matchedCoincident_iff redCode blueCode).1 horbit with + hzero | hthree + · exact ⟨0, Or.inl rfl, hzero.1 ▸ hred, hzero.2 ▸ hblue⟩ + · exact ⟨3, Or.inr rfl, hthree.1 ▸ hred, hthree.2 ▸ hblue⟩ + | balanced blueCode => + exact (hexclusions.endpointBalanced redCode blueCode ⟨hred, hblue⟩).elim + | balanced redCode => + cases blueWitness with + | endpoint blueCode => + exact (hexclusions.balancedEndpoint redCode blueCode ⟨hred, hblue⟩).elim + | balanced blueCode => + exact (hexclusions.balancedBalanced redCode blueCode ⟨hred, hblue⟩).elim + +/-- If supports `67` and `76` both fail, the incidence ledger selects one diagonal endpoint. -/ +theorem exists_matched_endpoint_of_siblingTriangle_score_failures + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hred : RedSiblingTriangleFails configuration h) + (hblue : BlueSiblingTriangleFails configuration h) + (hexclusions : SiblingIncidenceExclusions (redSiblingTriangleFailure configuration) + (blueSiblingTriangleFailure configuration)) : + ∃ code : Fin 4, (code = 0 ∨ code = 3) ∧ + redSiblingTriangleFailure configuration (.endpoint code) ∧ + blueSiblingTriangleFailure configuration (.endpoint code) := + exists_matched_endpoint_of_siblingIncidenceExclusions hexclusions + (exists_redSiblingTriangleFailure_of_score_failure h hred) + (exists_blueSiblingTriangleFailure_of_score_failure h hblue) + +/-- Simultaneous `67` and `76` failures force the exact `q2` inequality at one matched child. -/ +theorem q2_strict_of_siblingTriangle_score_failures + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hred : RedSiblingTriangleFails configuration h) + (hblue : BlueSiblingTriangleFails configuration h) + (hexclusions : SiblingIncidenceExclusions (redSiblingTriangleFailure configuration) + (blueSiblingTriangleFailure configuration)) : + ((barC - 1) * matchedChildAverage configuration 0 + + (barC + 1) * matchedChildAverage configuration 1 + + 3 * barC ^ 2 - 3 * barC + 2) / 2 < + dist (configuration .red .left) (configuration .blue .left) ∨ + ((barC - 1) * matchedChildAverage configuration 1 + + (barC + 1) * matchedChildAverage configuration 0 + + 3 * barC ^ 2 - 3 * barC + 2) / 2 < + dist (configuration .red .right) (configuration .blue .right) := by + obtain ⟨code, hcode, hredCode, hblueCode⟩ := + exists_matched_endpoint_of_siblingTriangle_score_failures h hred hblue hexclusions + rcases hcode with rfl | rfl + · exact Or.inl (q2_strict_of_matched_endpoint_zero h hredCode hblueCode) + · exact Or.inr (q2_strict_of_matched_endpoint_three h hredCode hblueCode) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingIncidenceClosed.lean b/LeanPool/Besicovitch/SixPoint/SiblingIncidenceClosed.lean new file mode 100644 index 0000000000..99c55dc9dd --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingIncidenceClosed.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.LensEndpointBalancedE0S0 +public import LeanPool.Besicovitch.SixPoint.SiblingFailureTree +public import LeanPool.Besicovitch.SixPoint.SiblingLensE1S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S0 +public import LeanPool.Besicovitch.SixPoint.SiblingLensS0S3 + +/-! +# The closed sibling-incidence ledger + +The five lens separators, together with the direct outside-orbit exclusions, rule out every +simultaneous sibling failure except the two matched endpoint coincidences. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +private theorem endpointEndpoint_offMatching_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {redCode blueCode : Fin 4} + (horbit : endpointEndpointOrbit redCode blueCode = .offMatchingCoincident) : + ¬ (redSiblingTriangleFailure configuration (.endpoint redCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint blueCode)) := by + fin_cases redCode <;> fin_cases blueCode <;> simp [endpointEndpointOrbit] at horbit + · exact not_redEndpoint_one_and_blueEndpoint_one h hmatching + · intro failures + apply not_redEndpoint_one_and_blueEndpoint_one (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueEndpointFailure_swapChildren configuration 2).2 failures.2⟩ + +private theorem endpointBalanced_e0s0_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {endpointCode balancedCode : Fin 4} + (horbit : endpointBalancedOrbit endpointCode balancedCode = .e0s0) : + ¬ (redSiblingTriangleFailure configuration (.endpoint endpointCode) ∧ + blueSiblingTriangleFailure configuration (.balanced balancedCode)) := by + fin_cases endpointCode <;> fin_cases balancedCode <;> simp [endpointBalancedOrbit] at horbit + · exact endpointBalancedE0S0_excluded_of_lensBound h hmatching + (endpointBalancedE0S0LensBound_of_admissible h) + · intro failures + apply endpointBalancedE0S0_excluded_of_lensBound (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + (endpointBalancedE0S0LensBound_of_admissible (IsAdmissibleAt.swapChildren h)) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 3).2 failures.2⟩ + +private theorem endpointBalanced_e1s0_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {endpointCode balancedCode : Fin 4} + (horbit : endpointBalancedOrbit endpointCode balancedCode = .e1s0) : + ¬ (redSiblingTriangleFailure configuration (.endpoint endpointCode) ∧ + blueSiblingTriangleFailure configuration (.balanced balancedCode)) := by + fin_cases endpointCode <;> fin_cases balancedCode <;> simp [endpointBalancedOrbit] at horbit + · exact not_redEndpoint_one_and_blueBalanced_zero h hmatching + · intro failures + apply not_redEndpoint_one_and_blueBalanced_zero (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueBalancedFailure_swapChildren configuration 3).2 failures.2⟩ + +private theorem balancedEndpoint_e0s0_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {balancedCode endpointCode : Fin 4} + (horbit : endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e0s0) : + ¬ (redSiblingTriangleFailure configuration (.balanced balancedCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint endpointCode)) := by + intro failures + apply endpointBalanced_e0s0_excluded_aux + (configuration := transposeConfigurationColors configuration) + (endpointCode := transposeEndpointCode endpointCode) (balancedCode := balancedCode) + (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) horbit + exact ⟨(redEndpointFailure_transposeColors configuration endpointCode).2 failures.2, + (blueBalancedFailure_transposeColors configuration balancedCode).2 failures.1⟩ + +private theorem balancedEndpoint_e1s0_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {balancedCode endpointCode : Fin 4} + (horbit : endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e1s0) : + ¬ (redSiblingTriangleFailure configuration (.balanced balancedCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint endpointCode)) := by + intro failures + apply endpointBalanced_e1s0_excluded_aux + (configuration := transposeConfigurationColors configuration) + (endpointCode := transposeEndpointCode endpointCode) (balancedCode := balancedCode) + (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) horbit + exact ⟨(redEndpointFailure_transposeColors configuration endpointCode).2 failures.2, + (blueBalancedFailure_transposeColors configuration balancedCode).2 failures.1⟩ + +private theorem balancedBalanced_s0s0_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {redCode blueCode : Fin 4} + (horbit : balancedBalancedOrbit redCode blueCode = .s0s0) : + ¬ (redSiblingTriangleFailure configuration (.balanced redCode) ∧ + blueSiblingTriangleFailure configuration (.balanced blueCode)) := by + fin_cases redCode <;> fin_cases blueCode <;> simp [balancedBalancedOrbit] at horbit + · exact not_redBalanced_zero_and_blueBalanced_zero h hmatching + · intro failures + apply not_redBalanced_zero_and_blueBalanced_zero (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redBalancedFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 3).2 failures.2⟩ + +private theorem balancedBalanced_s0s3_excluded_aux + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) {redCode blueCode : Fin 4} + (horbit : balancedBalancedOrbit redCode blueCode = .s0s3) : + ¬ (redSiblingTriangleFailure configuration (.balanced redCode) ∧ + blueSiblingTriangleFailure configuration (.balanced blueCode)) := by + fin_cases redCode <;> fin_cases blueCode <;> simp [balancedBalancedOrbit] at horbit + · exact not_redBalanced_zero_and_blueBalanced_three h hmatching + · intro failures + apply not_redBalanced_zero_and_blueBalanced_three (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redBalancedFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 0).2 failures.2⟩ + +/-- Every non-matched sibling-incidence cell is excluded at the exact endpoint. -/ +theorem siblingIncidenceExclusions_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + SiblingIncidenceExclusions (redSiblingTriangleFailure configuration) + (blueSiblingTriangleFailure configuration) where + endpointEndpoint redCode blueCode hnotMatched := by + by_cases horbit : endpointEndpointOrbit redCode blueCode = .offMatchingCoincident + · exact endpointEndpoint_offMatching_excluded_aux h hmatching horbit + · exact endpointEndpoint_excluded_outside_lens h hmatching redCode blueCode + hnotMatched horbit + endpointBalanced endpointCode balancedCode := by + by_cases hzero : endpointBalancedOrbit endpointCode balancedCode = .e0s0 + · exact endpointBalanced_e0s0_excluded_aux h hmatching hzero + · by_cases hone : endpointBalancedOrbit endpointCode balancedCode = .e1s0 + · exact endpointBalanced_e1s0_excluded_aux h hmatching hone + · exact endpointBalanced_excluded_outside_lenses h hmatching endpointCode balancedCode + hzero hone + balancedEndpoint balancedCode endpointCode := by + by_cases hzero : + endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e0s0 + · exact balancedEndpoint_e0s0_excluded_aux h hmatching hzero + · by_cases hone : + endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e1s0 + · exact balancedEndpoint_e1s0_excluded_aux h hmatching hone + · exact balancedEndpoint_excluded_outside_lenses h hmatching balancedCode endpointCode + hzero hone + balancedBalanced redCode blueCode := by + by_cases hzero : balancedBalancedOrbit redCode blueCode = .s0s0 + · exact balancedBalanced_s0s0_excluded_aux h hmatching hzero + · by_cases hthree : balancedBalancedOrbit redCode blueCode = .s0s3 + · exact balancedBalanced_s0s3_excluded_aux h hmatching hthree + · exact balancedBalanced_excluded_outside_lenses h hmatching redCode blueCode + hzero hthree + +private theorem siblingIncidenceOutcome_failures_aux {configuration : SixPointConfiguration} + (houtcome : SiblingIncidenceOutcome configuration) : + (∃ witness, redSiblingTriangleFailure configuration witness) ∧ + ∃ witness, blueSiblingTriangleFailure configuration witness := by + rcases houtcome with hmatched | hoffMatching | hendpointBalanced | hbalancedEndpoint | + hbalancedBalanced + · rcases hmatched with ⟨code, _, hred, hblue⟩ + exact ⟨⟨.endpoint code, hred⟩, ⟨.endpoint code, hblue⟩⟩ + · rcases hoffMatching with ⟨redCode, blueCode, _, hred, hblue⟩ + exact ⟨⟨.endpoint redCode, hred⟩, ⟨.endpoint blueCode, hblue⟩⟩ + · rcases hendpointBalanced with ⟨endpointCode, balancedCode, _, hred, hblue⟩ + exact ⟨⟨.endpoint endpointCode, hred⟩, ⟨.balanced balancedCode, hblue⟩⟩ + · rcases hbalancedEndpoint with ⟨balancedCode, endpointCode, _, hred, hblue⟩ + exact ⟨⟨.balanced balancedCode, hred⟩, ⟨.endpoint endpointCode, hblue⟩⟩ + · rcases hbalancedBalanced with ⟨redCode, blueCode, _, hred, hblue⟩ + exact ⟨⟨.balanced redCode, hred⟩, ⟨.balanced blueCode, hblue⟩⟩ + +/-- The sibling supports either give a nonnegative packing or fail at one matched endpoint. -/ +theorem exists_nonnegative_score_or_matched_sibling_endpoint + (configuration : SixPointConfiguration) (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + (∃ packing : SixPointPacking configuration, 0 ≤ packing.score barS) ∨ + ∃ code : Fin 4, (code = 0 ∨ code = 3) ∧ + redSiblingTriangleFailure configuration (.endpoint code) ∧ + blueSiblingTriangleFailure configuration (.endpoint code) := by + rcases exists_nonnegative_score_or_siblingIncidenceOutcome configuration h hmatching with + hpacking | houtcome + · exact Or.inl hpacking + · rcases siblingIncidenceOutcome_failures_aux houtcome with ⟨hred, hblue⟩ + exact Or.inr <| exists_matched_endpoint_of_siblingIncidenceExclusions + (siblingIncidenceExclusions_of_admissible h hmatching) hred hblue + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingIncidenceLedger.lean b/LeanPool/Besicovitch/SixPoint/SiblingIncidenceLedger.lean new file mode 100644 index 0000000000..fdbd625bef --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingIncidenceLedger.lean @@ -0,0 +1,1139 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.SiblingIncidence + +/-! +# Geometric sibling-incidence exclusions + +This file connects the exact rational tangent certificates to the endpoint and balanced +failure witnesses. The only remaining analytic inputs are the five named lens inequalities. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- Swap the two child labels while fixing the root. -/ +def swapChildLabel : SixPointLabel → SixPointLabel + | .root => .root + | .left => .right + | .right => .left + +/-- Simultaneously swap the two children of both colors. -/ +def swapConfigurationChildren (configuration : SixPointConfiguration) : SixPointConfiguration := + fun color label ↦ configuration color (swapChildLabel label) + +/-- Interchange the red and blue colors. -/ +def transposeConfigurationColors (configuration : SixPointConfiguration) : SixPointConfiguration + | .red => configuration .blue + | .blue => configuration .red + +/-- Simultaneous child swap preserves endpoint admissibility. -/ +theorem IsAdmissibleAt.swapChildren {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : + (swapConfigurationChildren configuration).IsAdmissibleAt s where + root_distance := h.root_distance + child_distance color label hlabel := by + cases label with + | root => simp at hlabel + | left => exact h.child_distance color .right (by simp) + | right => exact h.child_distance color .left (by simp) + sibling_distance color := by + simpa [swapConfigurationChildren, swapChildLabel, dist_comm] using h.sibling_distance color + +/-- Color transposition preserves endpoint admissibility. -/ +theorem IsAdmissibleAt.transposeColors {configuration : SixPointConfiguration} {s : ℝ} + (h : configuration.IsAdmissibleAt s) : + (transposeConfigurationColors configuration).IsAdmissibleAt s where + root_distance := by + simpa [transposeConfigurationColors, dist_comm] using h.root_distance + child_distance color label hlabel := by + cases color <;> + simpa [transposeConfigurationColors] using h.child_distance _ label hlabel + sibling_distance color := by + cases color <;> + simpa [transposeConfigurationColors] using h.sibling_distance _ + +/-- The distance between a chosen red child and a chosen blue child. -/ +def incidenceCrossDistance (configuration : SixPointConfiguration) (redChild blueChild : Fin 2) : + ℝ := + dist (configuration .red (incidenceChild redChild)) + (configuration .blue (incidenceChild blueChild)) + +/-- The root-to-child radius at a chosen color and child. -/ +def incidenceChildRadius (configuration : SixPointConfiguration) (color : SixPointColor) + (child : Fin 2) : ℝ := + dist (configuration color .root) (configuration color (incidenceChild child)) + +/-- A child radius is the norm of its red displacement vector. -/ +theorem incidenceChildRadius_red_eq_norm (configuration : SixPointConfiguration) (child : Fin 2) : + incidenceChildRadius configuration .red child = + ‖configuration.redDisplacement (incidenceChild child)‖ := by + simp [incidenceChildRadius, SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + +/-- A child radius is the norm of its pulled-back blue displacement vector. -/ +theorem incidenceChildRadius_blue_eq_norm (configuration : SixPointConfiguration) (child : Fin 2) : + incidenceChildRadius configuration .blue child = + ‖configuration.bluePullback (incidenceChild child)‖ := by + simp [incidenceChildRadius, SixPointConfiguration.bluePullback, dist_eq_norm] + +/-- A cross distance is the norm of its endpoint-geometry displacement. -/ +theorem incidenceCrossDistance_eq_norm (configuration : SixPointConfiguration) + (redChild blueChild : Fin 2) : + incidenceCrossDistance configuration redChild blueChild = + ‖configuration.rootDisplacement - + configuration.redDisplacement (incidenceChild redChild) - + configuration.bluePullback (incidenceChild blueChild)‖ := by + exact configuration.dist_red_blue_eq_norm _ _ + +/-- The radial penalty in a reduced balanced incidence slack. -/ +def balancedIncidencePenalty (code : Fin 4) (firstRadius secondRadius : ℝ) : ℝ := + match code with + | 0 => ((barC - 1) * firstRadius + (barC + 1) * secondRadius) / 2 + | 1 | 2 => barC * (firstRadius + secondRadius) / 2 + | 3 => ((barC + 1) * firstRadius + (barC - 1) * secondRadius) / 2 + +/-- The reduced matching slack retained from the four-child branch. -/ +def diagonalMatchingReducedSlack (configuration : SixPointConfiguration) : ℝ := + incidenceCrossDistance configuration 0 0 + incidenceCrossDistance configuration 1 1 - + 2 * barC * (2 * barC - 1) + +/-- The selected diagonal matching alternative from the four-child minimax. -/ +def SelectedDiagonalMatchingFails (configuration : SixPointConfiguration) : Prop := + (2 * barC - 1) * + (dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right)) ≤ + incidenceCrossDistance configuration 0 0 + incidenceCrossDistance configuration 1 1 + +/-- The selected diagonal matching is unchanged by simultaneous child swap. -/ +theorem selectedDiagonalMatchingFails_swapChildren (configuration : SixPointConfiguration) : + SelectedDiagonalMatchingFails (swapConfigurationChildren configuration) ↔ + SelectedDiagonalMatchingFails configuration := by + simp only [SelectedDiagonalMatchingFails, incidenceCrossDistance, incidenceChild, + swapConfigurationChildren, swapChildLabel] + constructor <;> intro h <;> + simpa [add_comm, dist_comm] using h + +/-- The selected diagonal matching is unchanged by color transposition. -/ +theorem selectedDiagonalMatchingFails_transposeColors (configuration : SixPointConfiguration) : + SelectedDiagonalMatchingFails (transposeConfigurationColors configuration) ↔ + SelectedDiagonalMatchingFails configuration := by + simp only [SelectedDiagonalMatchingFails, incidenceCrossDistance, incidenceChild, + transposeConfigurationColors] + constructor <;> intro h <;> + simpa [add_comm, dist_comm] using h + +/-- Red endpoint failures respect simultaneous child swap. -/ +theorem redEndpointFailure_swapChildren (configuration : SixPointConfiguration) (code : Fin 4) : + redSiblingTriangleFailure (swapConfigurationChildren configuration) + (.endpoint (swapEndpointCode code)) ↔ + redSiblingTriangleFailure configuration (.endpoint code) := by + fin_cases code <;> + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius, swapEndpointCode, swapConfigurationChildren, swapChildLabel, + incidenceFirst, incidenceSecond, incidenceChild, dist_comm, add_comm] + +/-- Blue endpoint failures respect simultaneous child swap. -/ +theorem blueEndpointFailure_swapChildren (configuration : SixPointConfiguration) (code : Fin 4) : + blueSiblingTriangleFailure (swapConfigurationChildren configuration) + (.endpoint (swapEndpointCode code)) ↔ + blueSiblingTriangleFailure configuration (.endpoint code) := by + fin_cases code <;> + simp [blueSiblingTriangleFailure, transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + blueSiblingRedTriangleReach, canonicalTriangleRadius, swapEndpointCode, + swapConfigurationChildren, swapChildLabel, incidenceFirst, incidenceSecond, + incidenceChild, dist_comm, add_comm] + +/-- Red balanced failures respect simultaneous child swap. -/ +theorem redBalancedFailure_swapChildren (configuration : SixPointConfiguration) (code : Fin 4) : + redSiblingTriangleFailure (swapConfigurationChildren configuration) + (.balanced (swapBalancedCode code)) ↔ + redSiblingTriangleFailure configuration (.balanced code) := by + fin_cases code <;> + norm_num [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius, swapBalancedCode, swapConfigurationChildren, swapChildLabel, + incidenceFirst, incidenceSecond, incidenceChild, dist_comm, add_comm] <;> + constructor <;> intro h <;> nlinarith + +/-- Blue balanced failures respect simultaneous child swap. -/ +theorem blueBalancedFailure_swapChildren (configuration : SixPointConfiguration) (code : Fin 4) : + blueSiblingTriangleFailure (swapConfigurationChildren configuration) + (.balanced (swapBalancedCode code)) ↔ + blueSiblingTriangleFailure configuration (.balanced code) := by + fin_cases code <;> + norm_num [blueSiblingTriangleFailure, transposeBlueEndpointWitness, + siblingTriangleWitnessExceeds, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + blueSiblingRedTriangleReach, canonicalTriangleRadius, swapBalancedCode, + swapConfigurationChildren, swapChildLabel, incidenceFirst, incidenceSecond, + incidenceChild, dist_comm, add_comm] <;> + constructor <;> intro h <;> nlinarith + +/-- Red endpoint failures become blue endpoint failures under color transposition. -/ +theorem redEndpointFailure_transposeColors (configuration : SixPointConfiguration) (code : Fin 4) : + redSiblingTriangleFailure (transposeConfigurationColors configuration) + (.endpoint (transposeEndpointCode code)) ↔ + blueSiblingTriangleFailure configuration (.endpoint code) := by + fin_cases code <;> + simp [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + transposeConfigurationColors, incidenceFirst, incidenceSecond, incidenceChild, + dist_comm, add_comm] + +/-- Blue endpoint failures become red endpoint failures under color transposition. -/ +theorem blueEndpointFailure_transposeColors (configuration : SixPointConfiguration) (code : Fin 4) : + blueSiblingTriangleFailure (transposeConfigurationColors configuration) + (.endpoint (transposeEndpointCode code)) ↔ + redSiblingTriangleFailure configuration (.endpoint code) := by + fin_cases code <;> + simp [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, transposeEndpointCode, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + transposeConfigurationColors, incidenceFirst, incidenceSecond, incidenceChild, + dist_comm, add_comm] + +/-- Red balanced failures become blue balanced failures under color transposition. -/ +theorem redBalancedFailure_transposeColors (configuration : SixPointConfiguration) (code : Fin 4) : + redSiblingTriangleFailure (transposeConfigurationColors configuration) (.balanced code) ↔ + blueSiblingTriangleFailure configuration (.balanced code) := by + fin_cases code <;> + simp [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + transposeConfigurationColors, incidenceFirst, incidenceSecond, incidenceChild, + dist_comm, add_comm] + +/-- Blue balanced failures become red balanced failures under color transposition. -/ +theorem blueBalancedFailure_transposeColors (configuration : SixPointConfiguration) (code : Fin 4) : + blueSiblingTriangleFailure (transposeConfigurationColors configuration) (.balanced code) ↔ + redSiblingTriangleFailure configuration (.balanced code) := by + fin_cases code <;> + simp [redSiblingTriangleFailure, blueSiblingTriangleFailure, + transposeBlueEndpointWitness, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + redSiblingBlueTriangleReach, blueSiblingRedTriangleReach, canonicalTriangleRadius, + transposeConfigurationColors, incidenceFirst, incidenceSecond, incidenceChild, + dist_comm, add_comm] + +/-- The reduced upper slack for a red endpoint incidence. -/ +def redEndpointReducedSlack (configuration : SixPointConfiguration) (code : Fin 4) : ℝ := + let blueChild := incidenceSecond code + incidenceCrossDistance configuration (incidenceFirst code) blueChild - + (1 + 3 * barC * (barC - 1) / 2) - + ((barC - 1) * incidenceChildRadius configuration .blue blueChild + + (barC + 1) * incidenceChildRadius configuration .blue (otherChild blueChild)) / 2 + +/-- The reduced upper slack for a blue endpoint incidence. -/ +def blueEndpointReducedSlack (configuration : SixPointConfiguration) (code : Fin 4) : ℝ := + let redChild := incidenceFirst code + incidenceCrossDistance configuration redChild (incidenceSecond code) - + (1 + 3 * barC * (barC - 1) / 2) - + ((barC - 1) * incidenceChildRadius configuration .red redChild + + (barC + 1) * incidenceChildRadius configuration .red (otherChild redChild)) / 2 + +/-- The reduced upper slack for a red balanced incidence. -/ +def redBalancedReducedSlack (configuration : SixPointConfiguration) (code : Fin 4) : ℝ := + (incidenceCrossDistance configuration 0 (incidenceFirst code) + + incidenceCrossDistance configuration 1 (incidenceSecond code)) / 2 + + barC - 3 * barC ^ 2 / 2 - + balancedIncidencePenalty code (incidenceChildRadius configuration .blue 0) + (incidenceChildRadius configuration .blue 1) + +/-- The reduced upper slack for a blue balanced incidence. -/ +def blueBalancedReducedSlack (configuration : SixPointConfiguration) (code : Fin 4) : ℝ := + (incidenceCrossDistance configuration (incidenceFirst code) 0 + + incidenceCrossDistance configuration (incidenceSecond code) 1) / 2 + + barC - 3 * barC ^ 2 / 2 - + balancedIncidencePenalty code (incidenceChildRadius configuration .red 0) + (incidenceChildRadius configuration .red 1) + +/-- The selected matching alternative makes its reduced slack nonnegative. -/ +theorem diagonalMatchingReducedSlack_nonneg {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + 0 ≤ diagonalMatchingReducedSlack configuration := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 0 ≤ 2 * barC - 1 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hscaled := mul_le_mul_of_nonneg_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + hcoefficient + apply sub_nonneg.mpr + simpa [mul_comm] using hscaled.trans hmatching + +/-- A red endpoint failure makes the corresponding reduced endpoint slack positive. -/ +theorem redEndpointReducedSlack_pos {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (code : Fin 4) + (hfailure : redSiblingTriangleFailure configuration (.endpoint code)) : + 0 < redEndpointReducedSlack configuration code := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 1 - barC ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hLscaled := mul_le_mul_of_nonpos_left hL hcoefficient + have hMscaled := mul_le_mul_of_nonpos_left hM hcoefficient + fin_cases code <;> + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius, redEndpointReducedSlack, incidenceFirst, incidenceSecond, + incidenceChild, incidenceCrossDistance, incidenceChildRadius, otherChild] at hfailure ⊢ <;> + nlinarith + +/-- A blue endpoint failure makes the corresponding reduced endpoint slack positive. -/ +theorem blueEndpointReducedSlack_pos {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (code : Fin 4) + (hfailure : blueSiblingTriangleFailure configuration (.endpoint code)) : + 0 < blueEndpointReducedSlack configuration code := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 1 - barC ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hLscaled := mul_le_mul_of_nonpos_left hL hcoefficient + have hMscaled := mul_le_mul_of_nonpos_left hM hcoefficient + fin_cases code <;> + norm_num [blueSiblingTriangleFailure, transposeBlueEndpointWitness, transposeEndpointCode, + siblingTriangleWitnessExceeds, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + blueSiblingRedTriangleReach, canonicalTriangleRadius, blueEndpointReducedSlack, + incidenceFirst, incidenceSecond, incidenceChild, incidenceCrossDistance, + incidenceChildRadius, otherChild] at hfailure ⊢ <;> + rw [dist_comm (configuration .blue _) (configuration .red _)] at hfailure <;> + nlinarith + +/-- A red balanced failure makes the corresponding reduced balanced slack positive. -/ +theorem redBalancedReducedSlack_pos {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (code : Fin 4) + (hfailure : redSiblingTriangleFailure configuration (.balanced code)) : + 0 < redBalancedReducedSlack configuration code := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficientL : 1 / 2 - barC ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hcoefficientM : (1 - barC) / 2 ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hLscaled := mul_le_mul_of_nonpos_left hL hcoefficientL + have hMscaled := mul_le_mul_of_nonpos_left hM hcoefficientM + fin_cases code <;> + simp [redSiblingTriangleFailure, siblingTriangleWitnessExceeds, + redSiblingTriangleTarget, rootedTriangleTotalRadius, redSiblingBlueTriangleReach, + canonicalTriangleRadius, redBalancedReducedSlack, balancedIncidencePenalty, + incidenceFirst, incidenceSecond, incidenceChild, incidenceCrossDistance, + incidenceChildRadius] at hfailure ⊢ <;> + nlinarith + +/-- A blue balanced failure makes the corresponding reduced balanced slack positive. -/ +theorem blueBalancedReducedSlack_pos {configuration : SixPointConfiguration} + (h : configuration.IsAdmissibleAt barS) (code : Fin 4) + (hfailure : blueSiblingTriangleFailure configuration (.balanced code)) : + 0 < blueBalancedReducedSlack configuration code := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficientL : 1 / 2 - barC ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hcoefficientM : (1 - barC) / 2 ≤ 0 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hLscaled := mul_le_mul_of_nonpos_left hL hcoefficientM + have hMscaled := mul_le_mul_of_nonpos_left hM hcoefficientL + fin_cases code <;> + simp [blueSiblingTriangleFailure, transposeBlueEndpointWitness, + siblingTriangleWitnessExceeds, blueSiblingTriangleTarget, rootedTriangleTotalRadius, + blueSiblingRedTriangleReach, canonicalTriangleRadius, blueBalancedReducedSlack, + balancedIncidencePenalty, incidenceFirst, incidenceSecond, incidenceChild, + incidenceCrossDistance, incidenceChildRadius] at hfailure ⊢ <;> + simp only [dist_comm (configuration .blue .left) (configuration .red .left), + dist_comm (configuration .blue .left) (configuration .red .right), + dist_comm (configuration .blue .right) (configuration .red .left), + dist_comm (configuration .blue .right) (configuration .red .right)] at hfailure <;> + nlinarith + +/-- The `E0/S1` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_zero_and_blueBalanced_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 1)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e0s1 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 1 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 7 * redEndpointReducedSlack configuration 0 + + 13 * blueBalancedReducedSlack configuration 1 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `E0/S2` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_zero_and_blueBalanced_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e0s2 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 2 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 2 * redEndpointReducedSlack configuration 0 + + 3 * blueBalancedReducedSlack configuration 2 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `E0/S3` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_zero_and_blueBalanced_three + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 3)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e0s3 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 3 hblue + have hpositive : 0 < 5 * diagonalMatchingReducedSlack configuration + + 41 * redEndpointReducedSlack configuration 0 + + 54 * blueBalancedReducedSlack configuration 3 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `E1/S1` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_one_and_blueBalanced_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 1)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e1s1 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 1 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 7 * redEndpointReducedSlack configuration 1 + + 12 * blueBalancedReducedSlack configuration 1 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `E1/S2` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_one_and_blueBalanced_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e1s2 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 2 hblue + have hpositive : 0 < 3 * redEndpointReducedSlack configuration 1 + + 7 * blueBalancedReducedSlack configuration 2 := by + nlinarith + simp only [redEndpointReducedSlack, blueBalancedReducedSlack, + balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `E1/S3` red-endpoint/blue-balanced representative is impossible. -/ +theorem not_redEndpoint_one_and_blueBalanced_three + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 3)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_e1s3 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 3 hblue + have hpositive : 0 < 3 * diagonalMatchingReducedSlack configuration + + 11 * redEndpointReducedSlack configuration 1 + + 16 * blueBalancedReducedSlack configuration 3 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The `S0/S1` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_zero_and_blueBalanced_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 1)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_s0s1 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 1 hblue + have hpositive : 0 < 2 * redBalancedReducedSlack configuration 0 + + 5 * blueBalancedReducedSlack configuration 1 := by + nlinarith + simp only [redBalancedReducedSlack, blueBalancedReducedSlack, + balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild] at hpositive + nlinarith + +/-- The `S0/S2` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_zero_and_blueBalanced_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_s0s2 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 2 hblue + have hpositive : 0 < 2 * redBalancedReducedSlack configuration 0 + + 5 * blueBalancedReducedSlack configuration 2 := by + nlinarith + simp only [redBalancedReducedSlack, blueBalancedReducedSlack, + balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild] at hpositive + nlinarith + +/-- The `S1/S1` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_one_and_blueBalanced_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 1)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_s1s1 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 1 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 12 * redBalancedReducedSlack configuration 1 + + 12 * blueBalancedReducedSlack configuration 1 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redBalancedReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild] at hpositive + nlinarith + +/-- The `S1/S2` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_one_and_blueBalanced_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + ¬ (redSiblingTriangleFailure configuration (.balanced 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_s1s2 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hredSlack := redBalancedReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 2 hblue + have hpositive : 0 < 2 * redBalancedReducedSlack configuration 1 + + 5 * blueBalancedReducedSlack configuration 2 := by + nlinarith + simp only [redBalancedReducedSlack, blueBalancedReducedSlack, + balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild] at hpositive + nlinarith + +/-- The `S2/S2` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_two_and_blueBalanced_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 2) ∧ + blueSiblingTriangleFailure configuration (.balanced 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_s2s2 configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 2 hred + have hblueSlack := blueBalancedReducedSlack_pos h 2 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 8 * redBalancedReducedSlack configuration 2 + + 8 * blueBalancedReducedSlack configuration 2 := by + nlinarith + simp only [diagonalMatchingReducedSlack, redBalancedReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild] at hpositive + nlinarith + +/-- The first adjacent endpoint representative is impossible. -/ +theorem not_redEndpoint_zero_and_blueEndpoint_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.endpoint 1)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_adjacentFirst configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueEndpointReducedSlack_pos h 1 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 7 / 4 * (redEndpointReducedSlack configuration 0 + + blueEndpointReducedSlack configuration 1) := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueEndpointReducedSlack, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The second adjacent endpoint representative is impossible. -/ +theorem not_redEndpoint_zero_and_blueEndpoint_two + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.endpoint 2)) := by + rintro ⟨hred, hblue⟩ + have hpsep := SixPointConfiguration.two_mul_le_dist_redDisplacement h + have hwsep := SixPointConfiguration.two_mul_le_dist_bluePullback h + rw [barS, dist_eq_norm] at hpsep hwsep + have hcertificate := tangentCertificate_adjacentSecond configuration.rootDisplacement + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) + (SixPointConfiguration.norm_rootDisplacement h) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_redDisplacement_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) + (SixPointConfiguration.norm_bluePullback_le_one h (by simp)) (by linarith) (by linarith) + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueEndpointReducedSlack_pos h 2 hblue + have hpositive : 0 < diagonalMatchingReducedSlack configuration + + 7 / 4 * (redEndpointReducedSlack configuration 0 + + blueEndpointReducedSlack configuration 2) := by + nlinarith + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueEndpointReducedSlack, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] at hpositive + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] at hpositive + nlinarith + +/-- The exact scalar lens bound for the off-matching coincident endpoint cell. -/ +def OffMatchingCoincidentLensBound (configuration : SixPointConfiguration) : Prop := + 6 * diagonalMatchingReducedSlack configuration + + 7 * redEndpointReducedSlack configuration 1 + + 7 * blueEndpointReducedSlack configuration 1 < 0 + +/-- The exact scalar lens bound for the `E0/S0` endpoint/balanced cell. -/ +def EndpointBalancedE0S0LensBound (configuration : SixPointConfiguration) : Prop := + 5 * diagonalMatchingReducedSlack configuration + + 9 * redEndpointReducedSlack configuration 0 + + 6 * blueBalancedReducedSlack configuration 0 < 0 + +/-- The exact scalar lens bound for the `E1/S0` endpoint/balanced cell. -/ +def EndpointBalancedE1S0LensBound (configuration : SixPointConfiguration) : Prop := + 13 * diagonalMatchingReducedSlack configuration + + 24 * redEndpointReducedSlack configuration 1 + + 15 * blueBalancedReducedSlack configuration 0 < 0 + +/-- The exact scalar lens bound for the `S0/S0` balanced/balanced cell. -/ +def BalancedBalancedS0S0LensBound (configuration : SixPointConfiguration) : Prop := + 2 * diagonalMatchingReducedSlack configuration + + 5 * redBalancedReducedSlack configuration 0 + + 5 * blueBalancedReducedSlack configuration 0 < 0 + +/-- The exact scalar lens bound for the `S0/S3` balanced/balanced cell. -/ +def BalancedBalancedS0S3LensBound (configuration : SixPointConfiguration) : Prop := + 7 * diagonalMatchingReducedSlack configuration + + 20 * redBalancedReducedSlack configuration 0 + + 20 * blueBalancedReducedSlack configuration 3 < 0 + +/-- The off-matching scalar lens bound excludes its endpoint representative. -/ +theorem offMatchingCoincident_excluded_of_lensBound + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hlens : OffMatchingCoincidentLensBound configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.endpoint 1)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueEndpointReducedSlack_pos h 1 hblue + exact (not_lt_of_ge (by positivity : 0 ≤ + 6 * diagonalMatchingReducedSlack configuration + + 7 * redEndpointReducedSlack configuration 1 + + 7 * blueEndpointReducedSlack configuration 1)) hlens + +/-- The `E0/S0` scalar lens bound excludes its endpoint/balanced representative. -/ +theorem endpointBalancedE0S0_excluded_of_lensBound + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hlens : EndpointBalancedE0S0LensBound configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 0)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 0 hblue + exact (not_lt_of_ge (by positivity : 0 ≤ + 5 * diagonalMatchingReducedSlack configuration + + 9 * redEndpointReducedSlack configuration 0 + + 6 * blueBalancedReducedSlack configuration 0)) hlens + +/-- The `E1/S0` scalar lens bound excludes its endpoint/balanced representative. -/ +theorem endpointBalancedE1S0_excluded_of_lensBound + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hlens : EndpointBalancedE1S0LensBound configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 0)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 0 hblue + exact (not_lt_of_ge (by positivity : 0 ≤ + 13 * diagonalMatchingReducedSlack configuration + + 24 * redEndpointReducedSlack configuration 1 + + 15 * blueBalancedReducedSlack configuration 0)) hlens + +/-- The `S0/S0` scalar lens bound excludes its balanced representative. -/ +theorem balancedBalancedS0S0_excluded_of_lensBound + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hlens : BalancedBalancedS0S0LensBound configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 0)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 0 hblue + exact (not_lt_of_ge (by positivity : 0 ≤ + 2 * diagonalMatchingReducedSlack configuration + + 5 * redBalancedReducedSlack configuration 0 + + 5 * blueBalancedReducedSlack configuration 0)) hlens + +/-- The `S0/S3` scalar lens bound excludes its balanced representative. -/ +theorem balancedBalancedS0S3_excluded_of_lensBound + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hlens : BalancedBalancedS0S3LensBound configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 3)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 3 hblue + exact (not_lt_of_ge (by positivity : 0 ≤ + 7 * diagonalMatchingReducedSlack configuration + + 20 * redBalancedReducedSlack configuration 0 + + 20 * blueBalancedReducedSlack configuration 3)) hlens + +/-- Every endpoint/endpoint cell outside the matched and off-matching lens orbits is excluded. -/ +theorem endpointEndpoint_excluded_outside_lens + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) (redCode blueCode : Fin 4) + (hnotMatched : endpointEndpointOrbit redCode blueCode ≠ .matchedCoincident) + (hnotLens : endpointEndpointOrbit redCode blueCode ≠ .offMatchingCoincident) : + ¬ (redSiblingTriangleFailure configuration (.endpoint redCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint blueCode)) := by + fin_cases redCode <;> fin_cases blueCode + · exact (hnotMatched rfl).elim + · exact not_redEndpoint_zero_and_blueEndpoint_one h hmatching + · exact not_redEndpoint_zero_and_blueEndpoint_two h hmatching + · exact not_redEndpoint_zero_and_blueEndpoint_three h + · intro failures + apply not_redEndpoint_zero_and_blueEndpoint_two (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) + exact ⟨(redEndpointFailure_transposeColors configuration 0).2 failures.2, + (blueEndpointFailure_transposeColors configuration 1).2 failures.1⟩ + · exact (hnotLens rfl).elim + · exact not_redEndpoint_one_and_blueEndpoint_two h + · intro failures + let transposed := transposeConfigurationColors configuration + apply not_redEndpoint_zero_and_blueEndpoint_one + (IsAdmissibleAt.swapChildren (IsAdmissibleAt.transposeColors h)) + ((selectedDiagonalMatchingFails_swapChildren transposed).2 + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching)) + exact ⟨(redEndpointFailure_swapChildren transposed 3).2 + ((redEndpointFailure_transposeColors configuration 3).2 failures.2), + (blueEndpointFailure_swapChildren transposed 2).2 + ((blueEndpointFailure_transposeColors configuration 1).2 failures.1)⟩ + · intro failures + apply not_redEndpoint_zero_and_blueEndpoint_one (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) + exact ⟨(redEndpointFailure_transposeColors configuration 0).2 failures.2, + (blueEndpointFailure_transposeColors configuration 2).2 failures.1⟩ + · intro failures + apply not_redEndpoint_one_and_blueEndpoint_two (IsAdmissibleAt.swapChildren h) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueEndpointFailure_swapChildren configuration 1).2 failures.2⟩ + · exact (hnotLens rfl).elim + · intro failures + let transposed := transposeConfigurationColors configuration + apply not_redEndpoint_zero_and_blueEndpoint_two + (IsAdmissibleAt.swapChildren (IsAdmissibleAt.transposeColors h)) + ((selectedDiagonalMatchingFails_swapChildren transposed).2 + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching)) + exact ⟨(redEndpointFailure_swapChildren transposed 3).2 + ((redEndpointFailure_transposeColors configuration 3).2 failures.2), + (blueEndpointFailure_swapChildren transposed 1).2 + ((blueEndpointFailure_transposeColors configuration 2).2 failures.1)⟩ + · intro failures + apply not_redEndpoint_zero_and_blueEndpoint_three (IsAdmissibleAt.swapChildren h) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueEndpointFailure_swapChildren configuration 0).2 failures.2⟩ + · intro failures + apply not_redEndpoint_zero_and_blueEndpoint_two (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueEndpointFailure_swapChildren configuration 1).2 failures.2⟩ + · intro failures + apply not_redEndpoint_zero_and_blueEndpoint_one (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueEndpointFailure_swapChildren configuration 2).2 failures.2⟩ + · exact (hnotMatched rfl).elim + +/-- Every endpoint/balanced cell outside the two lens orbits is excluded. -/ +theorem endpointBalanced_excluded_outside_lenses + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) (endpointCode balancedCode : Fin 4) + (hnotE0S0 : endpointBalancedOrbit endpointCode balancedCode ≠ .e0s0) + (hnotE1S0 : endpointBalancedOrbit endpointCode balancedCode ≠ .e1s0) : + ¬ (redSiblingTriangleFailure configuration (.endpoint endpointCode) ∧ + blueSiblingTriangleFailure configuration (.balanced balancedCode)) := by + fin_cases endpointCode <;> fin_cases balancedCode + · exact (hnotE0S0 rfl).elim + · exact not_redEndpoint_zero_and_blueBalanced_one h hmatching + · exact not_redEndpoint_zero_and_blueBalanced_two h hmatching + · exact not_redEndpoint_zero_and_blueBalanced_three h hmatching + · exact (hnotE1S0 rfl).elim + · exact not_redEndpoint_one_and_blueBalanced_one h hmatching + · exact not_redEndpoint_one_and_blueBalanced_two h + · exact not_redEndpoint_one_and_blueBalanced_three h hmatching + · intro failures + apply not_redEndpoint_one_and_blueBalanced_three (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueBalancedFailure_swapChildren configuration 0).2 failures.2⟩ + · intro failures + apply not_redEndpoint_one_and_blueBalanced_one (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueBalancedFailure_swapChildren configuration 1).2 failures.2⟩ + · intro failures + apply not_redEndpoint_one_and_blueBalanced_two (IsAdmissibleAt.swapChildren h) + exact ⟨(redEndpointFailure_swapChildren configuration 2).2 failures.1, + (blueBalancedFailure_swapChildren configuration 2).2 failures.2⟩ + · exact (hnotE1S0 rfl).elim + · intro failures + apply not_redEndpoint_zero_and_blueBalanced_three (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 0).2 failures.2⟩ + · intro failures + apply not_redEndpoint_zero_and_blueBalanced_one (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 1).2 failures.2⟩ + · intro failures + apply not_redEndpoint_zero_and_blueBalanced_two (IsAdmissibleAt.swapChildren h) + ((selectedDiagonalMatchingFails_swapChildren configuration).2 hmatching) + exact ⟨(redEndpointFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 2).2 failures.2⟩ + · exact (hnotE0S0 rfl).elim + +/-- The color-reversed endpoint/balanced cells outside the two lens orbits are excluded. -/ +theorem balancedEndpoint_excluded_outside_lenses + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) (balancedCode endpointCode : Fin 4) + (hnotE0S0 : endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode ≠ .e0s0) + (hnotE1S0 : endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode ≠ .e1s0) : + ¬ (redSiblingTriangleFailure configuration (.balanced balancedCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint endpointCode)) := by + intro failures + apply endpointBalanced_excluded_outside_lenses (IsAdmissibleAt.transposeColors h) + ((selectedDiagonalMatchingFails_transposeColors configuration).2 hmatching) + (transposeEndpointCode endpointCode) balancedCode hnotE0S0 hnotE1S0 + exact ⟨(redEndpointFailure_transposeColors configuration endpointCode).2 failures.2, + (blueBalancedFailure_transposeColors configuration balancedCode).2 failures.1⟩ + +/-- Every balanced/balanced cell outside the two lens orbits is excluded. -/ +theorem balancedBalanced_excluded_outside_lenses + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) (redCode blueCode : Fin 4) + (hnotS0S0 : balancedBalancedOrbit redCode blueCode ≠ .s0s0) + (hnotS0S3 : balancedBalancedOrbit redCode blueCode ≠ .s0s3) : + ¬ (redSiblingTriangleFailure configuration (.balanced redCode) ∧ + blueSiblingTriangleFailure configuration (.balanced blueCode)) := by + fin_cases redCode <;> fin_cases blueCode + · exact (hnotS0S0 rfl).elim + · exact not_redBalanced_zero_and_blueBalanced_one h + · exact not_redBalanced_zero_and_blueBalanced_two h + · exact (hnotS0S3 rfl).elim + · intro failures + apply not_redBalanced_zero_and_blueBalanced_one (IsAdmissibleAt.transposeColors h) + exact ⟨(redBalancedFailure_transposeColors configuration 0).2 failures.2, + (blueBalancedFailure_transposeColors configuration 1).2 failures.1⟩ + · exact not_redBalanced_one_and_blueBalanced_one h hmatching + · exact not_redBalanced_one_and_blueBalanced_two h + · intro failures + let transposed := transposeConfigurationColors configuration + apply not_redBalanced_zero_and_blueBalanced_one + (IsAdmissibleAt.swapChildren (IsAdmissibleAt.transposeColors h)) + exact ⟨(redBalancedFailure_swapChildren transposed 3).2 + ((redBalancedFailure_transposeColors configuration 3).2 failures.2), + (blueBalancedFailure_swapChildren transposed 1).2 + ((blueBalancedFailure_transposeColors configuration 1).2 failures.1)⟩ + · intro failures + apply not_redBalanced_zero_and_blueBalanced_two (IsAdmissibleAt.transposeColors h) + exact ⟨(redBalancedFailure_transposeColors configuration 0).2 failures.2, + (blueBalancedFailure_transposeColors configuration 2).2 failures.1⟩ + · intro failures + apply not_redBalanced_one_and_blueBalanced_two (IsAdmissibleAt.transposeColors h) + exact ⟨(redBalancedFailure_transposeColors configuration 1).2 failures.2, + (blueBalancedFailure_transposeColors configuration 2).2 failures.1⟩ + · exact not_redBalanced_two_and_blueBalanced_two h hmatching + · intro failures + let transposed := transposeConfigurationColors configuration + apply not_redBalanced_zero_and_blueBalanced_two + (IsAdmissibleAt.swapChildren (IsAdmissibleAt.transposeColors h)) + exact ⟨(redBalancedFailure_swapChildren transposed 3).2 + ((redBalancedFailure_transposeColors configuration 3).2 failures.2), + (blueBalancedFailure_swapChildren transposed 2).2 + ((blueBalancedFailure_transposeColors configuration 2).2 failures.1)⟩ + · exact (hnotS0S3 rfl).elim + · intro failures + apply not_redBalanced_zero_and_blueBalanced_one (IsAdmissibleAt.swapChildren h) + exact ⟨(redBalancedFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 1).2 failures.2⟩ + · intro failures + apply not_redBalanced_zero_and_blueBalanced_two (IsAdmissibleAt.swapChildren h) + exact ⟨(redBalancedFailure_swapChildren configuration 3).2 failures.1, + (blueBalancedFailure_swapChildren configuration 2).2 failures.2⟩ + · exact (hnotS0S0 rfl).elim + +/-- The five possible outcomes after all tangent and direct incidence exclusions. -/ +def SiblingIncidenceOutcome (configuration : SixPointConfiguration) : Prop := + (∃ code : Fin 4, (code = 0 ∨ code = 3) ∧ + redSiblingTriangleFailure configuration (.endpoint code) ∧ + blueSiblingTriangleFailure configuration (.endpoint code)) ∨ + (∃ redCode blueCode, endpointEndpointOrbit redCode blueCode = .offMatchingCoincident ∧ + redSiblingTriangleFailure configuration (.endpoint redCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint blueCode)) ∨ + (∃ endpointCode balancedCode, + (endpointBalancedOrbit endpointCode balancedCode = .e0s0 ∨ + endpointBalancedOrbit endpointCode balancedCode = .e1s0) ∧ + redSiblingTriangleFailure configuration (.endpoint endpointCode) ∧ + blueSiblingTriangleFailure configuration (.balanced balancedCode)) ∨ + (∃ balancedCode endpointCode, + (endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e0s0 ∨ + endpointBalancedOrbit (transposeEndpointCode endpointCode) balancedCode = .e1s0) ∧ + redSiblingTriangleFailure configuration (.balanced balancedCode) ∧ + blueSiblingTriangleFailure configuration (.endpoint endpointCode)) ∨ + (∃ redCode blueCode, + (balancedBalancedOrbit redCode blueCode = .s0s0 ∨ + balancedBalancedOrbit redCode blueCode = .s0s3) ∧ + redSiblingTriangleFailure configuration (.balanced redCode) ∧ + blueSiblingTriangleFailure configuration (.balanced blueCode)) + +/-- Simultaneous sibling-triangle witnesses route to a matched endpoint or one lens orbit. -/ +theorem siblingIncidence_route + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hred : ∃ witness, redSiblingTriangleFailure configuration witness) + (hblue : ∃ witness, blueSiblingTriangleFailure configuration witness) : + SiblingIncidenceOutcome configuration := by + obtain ⟨redWitness, hred⟩ := hred + obtain ⟨blueWitness, hblue⟩ := hblue + unfold SiblingIncidenceOutcome + cases redWitness with + | endpoint redCode => + cases blueWitness with + | endpoint blueCode => + by_cases hmatched : endpointEndpointOrbit redCode blueCode = .matchedCoincident + · rcases (endpointEndpointOrbit_eq_matchedCoincident_iff redCode blueCode).1 + hmatched with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact Or.inl ⟨0, Or.inl rfl, hred, hblue⟩ + · exact Or.inl ⟨3, Or.inr rfl, hred, hblue⟩ + · by_cases hlens : endpointEndpointOrbit redCode blueCode = .offMatchingCoincident + · exact Or.inr (Or.inl ⟨redCode, blueCode, hlens, hred, hblue⟩) + · exact (endpointEndpoint_excluded_outside_lens h hmatching redCode blueCode + hmatched hlens ⟨hred, hblue⟩).elim + | balanced blueCode => + by_cases hzero : endpointBalancedOrbit redCode blueCode = .e0s0 + · exact Or.inr (Or.inr (Or.inl ⟨redCode, blueCode, Or.inl hzero, hred, hblue⟩)) + · by_cases hone : endpointBalancedOrbit redCode blueCode = .e1s0 + · exact Or.inr (Or.inr (Or.inl ⟨redCode, blueCode, Or.inr hone, hred, hblue⟩)) + · exact (endpointBalanced_excluded_outside_lenses h hmatching redCode blueCode + hzero hone ⟨hred, hblue⟩).elim + | balanced redCode => + cases blueWitness with + | endpoint blueCode => + by_cases hzero : + endpointBalancedOrbit (transposeEndpointCode blueCode) redCode = .e0s0 + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨redCode, blueCode, Or.inl hzero, hred, hblue⟩))) + · by_cases hone : + endpointBalancedOrbit (transposeEndpointCode blueCode) redCode = .e1s0 + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨redCode, blueCode, Or.inr hone, hred, hblue⟩))) + · exact (balancedEndpoint_excluded_outside_lenses h hmatching redCode blueCode + hzero hone ⟨hred, hblue⟩).elim + | balanced blueCode => + by_cases hzero : balancedBalancedOrbit redCode blueCode = .s0s0 + · exact Or.inr (Or.inr (Or.inr (Or.inr + ⟨redCode, blueCode, Or.inl hzero, hred, hblue⟩))) + · by_cases hthree : balancedBalancedOrbit redCode blueCode = .s0s3 + · exact Or.inr (Or.inr (Or.inr (Or.inr + ⟨redCode, blueCode, Or.inr hthree, hred, hblue⟩))) + · exact (balancedBalanced_excluded_outside_lenses h hmatching redCode blueCode + hzero hthree ⟨hred, hblue⟩).elim + +/-- If supports `67` and `76` both fail, their witnesses route to the five residual outcomes. -/ +theorem siblingTriangle_score_failure_route + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) + (hred : RedSiblingTriangleFails configuration h) + (hblue : BlueSiblingTriangleFails configuration h) : + SiblingIncidenceOutcome configuration := + siblingIncidence_route h hmatching + (exists_redSiblingTriangleFailure_of_score_failure h hred) + (exists_blueSiblingTriangleFailure_of_score_failure h hblue) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingLens.lean b/LeanPool/Besicovitch/SixPoint/SiblingLens.lean new file mode 100644 index 0000000000..fa04ba0911 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingLens.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# Analytic separators for sibling lens cells + +The off-matching coincident endpoint cell has a short global proof. Three norm tangents +preserve the correlation between its cross distances. A rational two-by-two Gram majorant then +separates the two colors, leaving a convex quadratic on the three radial vertices. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- The rational Gram majorant that retains the three-distance incidence pattern. -/ +private theorem offMatching_cross_inner_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (p₁ p₂ w₁ w₂ : E) : + 2 * (12 / 5 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (3 / 2 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (3 / 2 : ℝ) * ⟪p₂, w₁⟫_ℝ ≤ + 267 / 100 * (‖p₁‖ ^ 2 + ‖w₁‖ ^ 2) + + 75 / 64 * (‖p₂‖ ^ 2 + ‖w₂‖ ^ 2) + + 2 * (15 / 16) * (⟪p₁, p₂⟫_ℝ + ⟪w₁, w₂⟫_ℝ) := by + have hplus : 0 ≤ + 507 / 200 * ‖(p₁ - w₁) + (25 / 52 : ℝ) • (p₂ - w₂)‖ ^ 2 := by + positivity + have hminus : 0 ≤ + 27 / 200 * ‖(p₁ + w₁) - (25 / 12 : ℝ) • (p₂ + w₂)‖ ^ 2 := by + positivity + rw [norm_add_sq_real] at hplus + rw [norm_sub_sq_real] at hminus + simp only [norm_smul, Real.norm_eq_abs, abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 25 / 52), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 25 / 12), inner_sub_left, + inner_sub_right, inner_add_left, inner_add_right, real_inner_smul_right, + real_inner_comm] at hplus hminus + ring_nf at hplus hminus + rw [norm_sub_sq_real p₁ w₁, norm_sub_sq_real p₂ w₂] at hplus + rw [norm_add_sq_real p₁ w₁, norm_add_sq_real p₂ w₂] at hminus + ring_nf at hplus hminus ⊢ + nlinarith + +private theorem offMatching_pair_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x₁ x₂ : E) (he : ‖e‖ = 1) + (hx₁ : ‖x₁‖ ≤ 1) (hx₂ : ‖x₂‖ ≤ 1) + (hseparation : barC ≤ ‖x₁ - x₂‖) : + 3003 / 400 * ‖x₁‖ ^ 2 + 231 / 64 * ‖x₂‖ ^ 2 - + 2 * ⟪e, (39 / 10 : ℝ) • x₁ + (3 / 2 : ℝ) • x₂⟫_ℝ - + 7 / 2 * (barC - 1) * ‖x₁‖ - 7 / 2 * (barC + 1) * ‖x₂‖ - + 15 / 16 * barC ^ 2 ≤ 831 / 100 := by + let z := (39 / 10 : ℝ) • x₁ + (3 / 2 : ℝ) • x₂ + let Q := 1053 / 50 * ‖x₁‖ ^ 2 + 81 / 10 * ‖x₂‖ ^ 2 - + 117 / 20 * barC ^ 2 + have hseparationSq : barC ^ 2 ≤ ‖x₁ - x₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (x₁ - x₂)] + have hzUpper : ‖z‖ ^ 2 ≤ Q := by + rw [show ‖z‖ ^ 2 = + ((39 / 10 : ℝ) + 3 / 2) * + ((39 / 10 : ℝ) * ‖x₁‖ ^ 2 + 3 / 2 * ‖x₂‖ ^ 2) - + (39 / 10 : ℝ) * (3 / 2) * ‖x₁ - x₂‖ ^ 2 by + exact weighted_norm_sq x₁ x₂ (by norm_num) (by norm_num)] + dsimp only [Q] + nlinarith + have hinner := real_inner_le_norm (-e) z + simp only [inner_neg_left, norm_neg, he, one_mul] at hinner + have hnorm : 2 * ‖z‖ ≤ 84 / 25 + ‖z‖ ^ 2 / (84 / 25) := + two_mul_norm_tangent z (by norm_num) + have hscaled : ‖z‖ ^ 2 / (84 / 25) ≤ Q / (84 / 25) := by + exact div_le_div_of_nonneg_right hzUpper (by norm_num) + have horientation : + -2 * ⟪e, z⟫_ℝ ≤ 84 / 25 + 351 / 56 * ‖x₁‖ ^ 2 + + 135 / 56 * ‖x₂‖ ^ 2 - 195 / 112 * barC ^ 2 := by + dsimp only [Q] at hscaled + nlinarith + have hsum : barC ≤ ‖x₁‖ + ‖x₂‖ := + hseparation.trans (norm_sub_le x₁ x₂) + have hvertices := separableQuadratic_le_radial_vertices + (a₁ := 38571 / 2800) (a₂ := 2697 / 448) + (b₁ := -7 / 2 * (barC - 1)) (b₂ := -7 / 2 * (barC + 1)) + (d := 84 / 25 - 75 / 28 * barC ^ 2) (c := barC) + (t₁ := ‖x₁‖) (t₂ := ‖x₂‖) (by norm_num) (by norm_num) hx₁ hx₂ hsum + have hvertexBound : + max (38571 / 2800 + (-7 / 2 * (barC - 1)) + 2697 / 448 + + (-7 / 2 * (barC + 1)) + (84 / 25 - 75 / 28 * barC ^ 2)) + (max (38571 / 2800 + (-7 / 2 * (barC - 1)) + + 2697 / 448 * (barC - 1) ^ 2 + + (-7 / 2 * (barC + 1)) * (barC - 1) + + (84 / 25 - 75 / 28 * barC ^ 2)) + (38571 / 2800 * (barC - 1) ^ 2 + + (-7 / 2 * (barC - 1)) * (barC - 1) + 2697 / 448 + + (-7 / 2 * (barC + 1)) + + (84 / 25 - 75 / 28 * barC ^ 2))) ≤ 831 / 100 := by + simp only [max_le_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + constructor + · nlinarith [sq_nonneg (barC - 1)] + constructor <;> nlinarith [sq_nonneg (barC - 1)] + dsimp only [z] at horientation + nlinarith [hvertices.trans hvertexBound] + +/-- A global rational tangent separator for the off-matching coincident endpoint cell. -/ +theorem offMatchingCoincidentTangentCertificate {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 14 * ‖e - p₁ - w₁‖ + 6 * ‖e - p₁ - w₂‖ + 6 * ‖e - p₂ - w₁‖ - + 7 / 2 * ((barC - 1) * (‖p₁‖ + ‖w₁‖) + + (barC + 1) * (‖p₂‖ + ‖w₂‖)) - + 14 + 33 * barC - 45 * barC ^ 2 < 0 := by + have h₁₁ := weighted_norm_tangent (e - p₁ - w₁) 14 (35 / 12) (by norm_num) (by norm_num) + have h₁₂ := weighted_norm_tangent (e - p₁ - w₂) 6 2 (by norm_num) (by norm_num) + have h₂₁ := weighted_norm_tangent (e - p₂ - w₁) 6 2 (by norm_num) (by norm_num) + rw [norm_sub_sub_sq e p₁ w₁] at h₁₁ + rw [norm_sub_sub_sq e p₁ w₂] at h₁₂ + rw [norm_sub_sub_sq e p₂ w₁] at h₂₁ + simp only [he, one_pow] at h₁₁ h₁₂ h₂₁ + have hcross := offMatching_cross_inner_le p₁ p₂ w₁ w₂ + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hpinner : + 2 * ⟪p₁, p₂⟫_ℝ ≤ ‖p₁‖ ^ 2 + ‖p₂‖ ^ 2 - barC ^ 2 := by + rw [norm_sub_sq_real] at hpsepSq + nlinarith + have hwinner : + 2 * ⟪w₁, w₂⟫_ℝ ≤ ‖w₁‖ ^ 2 + ‖w₂‖ ^ 2 - barC ^ 2 := by + rw [norm_sub_sq_real] at hwsepSq + nlinarith + have hp := offMatching_pair_le e p₁ p₂ he hp₁ hp₂ hpsep + have hw := offMatching_pair_le e w₁ w₂ he hw₁ hw₂ hwsep + have hconstant : + 27 / 5 + 7 * (35 / 12) + 12 - 14 + 33 * barC - 45 * barC ^ 2 + + 2 * (831 / 100) < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + simp only [inner_add_right, real_inner_smul_right] at hp hw + ring_nf at h₁₁ h₁₂ h₂₁ hcross hpinner hwinner hp hw ⊢ + nlinarith + +/-- The off-matching coincident lens bound holds for every admissible configuration. -/ +theorem offMatchingCoincidentLensBound_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + OffMatchingCoincidentLensBound configuration := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .right + let w₂ := configuration.bluePullback .left + have hpsep : barC ≤ ‖p₁ - p₂‖ := by + have hred := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hred + exact hred + have hwsep : barC ≤ ‖w₁ - w₂‖ := by + have hblue := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hblue + exact hblue.trans_eq (norm_sub_rev _ _) + have hcertificate := offMatchingCoincidentTangentCertificate e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + hpsep hwsep + simp only [OffMatchingCoincidentLensBound, diagonalMatchingReducedSlack, + redEndpointReducedSlack, blueEndpointReducedSlack, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] + dsimp only [e, p₁, p₂, w₁, w₂] at hcertificate + nlinarith + +/-- The off-matching coincident endpoint representative is impossible. -/ +theorem not_redEndpoint_one_and_blueEndpoint_one + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.endpoint 1)) := + offMatchingCoincident_excluded_of_lensBound h hmatching + (offMatchingCoincidentLensBound_of_admissible h) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingLensE1S0.lean b/LeanPool/Besicovitch/SixPoint/SiblingLensE1S0.lean new file mode 100644 index 0000000000..acf9b18a86 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingLensE1S0.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.SixPoint.SiblingLens + +/-! +# The `E1/S0` sibling incidence + +This file closes the endpoint/balanced orbit `E1/S0`. A rational factorization of its cross-term +matrix preserves the correlation between the three positive distances. The resulting two +colorwise quadratics are bounded on the three radial vertices. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- A rational sum-of-squares factorization of the `E1/S0` cross matrix. -/ +private theorem e1s0_cross_inner_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (p₁ p₂ w₁ w₂ : E) : + 2 * (31 / 80 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (7 / 15 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (4 / 15 : ℝ) * ⟪p₂, w₂⟫_ℝ ≤ + 256 / 625 * ‖p₁‖ ^ 2 + 757 / 5000 * ‖p₂‖ ^ 2 + + 2 * (68 / 625) * ⟪p₁, p₂⟫_ℝ + + 727477 / 1605632 * ‖w₁‖ ^ 2 + 39397 / 56448 * ‖w₂‖ ^ 2 + + 2 * (32271 / 100352) * ⟪w₁, w₂⟫_ℝ := by + have hfirst : 0 ≤ + ‖(16 / 25 : ℝ) • p₁ + (17 / 100 : ℝ) • p₂ - + ((155 / 256 : ℝ) • w₁ + (35 / 48 : ℝ) • w₂)‖ ^ 2 := + sq_nonneg _ + have hsecond : 0 ≤ + ‖(7 / 20 : ℝ) • p₂ - + ((137 / 336 : ℝ) • w₂ - (527 / 1792 : ℝ) • w₁)‖ ^ 2 := + sq_nonneg _ + rw [norm_sub_sq_real] at hfirst hsecond + rw [norm_add_sq_real] at hfirst + rw [norm_add_sq_real] at hfirst + rw [norm_sub_sq_real] at hsecond + simp only [norm_smul, Real.norm_eq_abs, abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 16 / 25), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 17 / 100), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 155 / 256), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 35 / 48), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 7 / 20), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 137 / 336), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 527 / 1792), inner_add_left, + inner_add_right, inner_sub_right, real_inner_smul_right, real_inner_comm] at hfirst hsecond + ring_nf at hfirst hsecond ⊢ + nlinarith + +private theorem e1s0_red_pair_maximum : + gramPairMaximum barC (41177 / 30000) (7903 / 15000) (41 / 48) (4 / 15) + ((barC - 1) / 2) ((barC + 1) / 2) (68 / 625) (9 / 10) ≤ 53 / 25 := by + simp only [gramPairMaximum, max_le_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [gramPairValue] at hlower hupper ⊢ + constructor + · nlinarith [sq_nonneg (barC - 1)] + constructor <;> nlinarith [sq_nonneg (barC - 1)] + +private theorem e1s0_blue_pair_maximum : + gramPairMaximum barC (9329977 / 8028160) (7915571 / 4515840) (31 / 80) (11 / 15) + (17 / 16 * (barC + 1)) (17 / 16 * (barC - 1)) (32271 / 100352) + (13 / 20) ≤ 11 / 10 := by + simp only [gramPairMaximum, max_le_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [gramPairValue] at hlower hupper ⊢ + constructor + · nlinarith [sq_nonneg (barC - 1)] + constructor <;> nlinarith [sq_nonneg (barC - 1)] + +private theorem e1s0_positive_distances_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) : + 37 / 20 * ‖e - p₁ - w₁‖ + 21 / 8 * ‖e - p₁ - w₂‖ + + 27 / 20 * ‖e - p₂ - w₂‖ ≤ + 269 / 240 + 4717 / 620 + + 41 / 48 * ‖p₁‖ ^ 2 + 4 / 15 * ‖p₂‖ ^ 2 + + 31 / 80 * ‖w₁‖ ^ 2 + 11 / 15 * ‖w₂‖ ^ 2 - + 41 / 24 * ⟪e, p₁⟫_ℝ - 8 / 15 * ⟪e, p₂⟫_ℝ - + 31 / 40 * ⟪e, w₁⟫_ℝ - 22 / 15 * ⟪e, w₂⟫_ℝ + + 2 * (31 / 80 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (7 / 15 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (4 / 15 : ℝ) * ⟪p₂, w₂⟫_ℝ := by + have h₁₁ := weightedNorm_le_quadratic (e - p₁ - w₁) (37 / 20) (31 / 80) + (by norm_num) + have h₁₂ := weightedNorm_le_quadratic (e - p₁ - w₂) (21 / 8) (7 / 15) + (by norm_num) + have h₂₂ := weightedNorm_le_quadratic (e - p₂ - w₂) (27 / 20) (4 / 15) + (by norm_num) + rw [norm_sub_sub_sq e p₁ w₁] at h₁₁ + rw [norm_sub_sub_sq e p₁ w₂] at h₁₂ + rw [norm_sub_sub_sq e p₂ w₂] at h₂₂ + simp only [he, one_pow] at h₁₁ h₁₂ h₂₂ + ring_nf at h₁₁ h₁₂ h₂₂ ⊢ + nlinarith + +private theorem e1s0_cross_le_reduced {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (p₁ p₂ w₁ w₂ : E) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 2 * (31 / 80 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (7 / 15 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (4 / 15 : ℝ) * ⟪p₂, w₂⟫_ℝ ≤ + 256 / 625 * ‖p₁‖ ^ 2 + 757 / 5000 * ‖p₂‖ ^ 2 + + 68 / 625 * (‖p₁‖ ^ 2 + ‖p₂‖ ^ 2 - barC ^ 2) + + 727477 / 1605632 * ‖w₁‖ ^ 2 + 39397 / 56448 * ‖w₂‖ ^ 2 + + 32271 / 100352 * (‖w₁‖ ^ 2 + ‖w₂‖ ^ 2 - barC ^ 2) := by + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + rw [norm_sub_sq_real] at hpsepSq hwsepSq + have hpinnerScaled := mul_le_mul_of_nonneg_left hpsepSq + (by norm_num : (0 : ℝ) ≤ 68 / 625) + have hwinnerScaled := mul_le_mul_of_nonneg_left hwsepSq + (by norm_num : (0 : ℝ) ≤ 32271 / 100352) + have hcross := e1s0_cross_inner_le p₁ p₂ w₁ w₂ + nlinarith + +private theorem e1s0_constant_neg : + 269 / 240 + 4717 / 620 - 17 / 8 + 551 / 80 * barC - + 807 / 80 * barC ^ 2 + 53 / 25 + 11 / 10 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem e1s0_decomposition {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 37 / 20 * ‖e - p₁ - w₁‖ + 21 / 8 * ‖e - p₁ - w₂‖ + + 27 / 20 * ‖e - p₂ - w₂‖ - + ((barC - 1) * ‖p₁‖ + (barC + 1) * ‖p₂‖) / 2 - + 17 / 16 * ((barC + 1) * ‖w₁‖ + (barC - 1) * ‖w₂‖) ≤ + 269 / 240 + 4717 / 620 + + (41177 / 30000 * ‖p₁‖ ^ 2 + 7903 / 15000 * ‖p₂‖ ^ 2 - + 41 / 24 * ⟪e, p₁⟫_ℝ - 8 / 15 * ⟪e, p₂⟫_ℝ - + (barC - 1) / 2 * ‖p₁‖ - (barC + 1) / 2 * ‖p₂‖ - + 68 / 625 * barC ^ 2) + + (9329977 / 8028160 * ‖w₁‖ ^ 2 + 7915571 / 4515840 * ‖w₂‖ ^ 2 - + 31 / 40 * ⟪e, w₁⟫_ℝ - 22 / 15 * ⟪e, w₂⟫_ℝ - + 17 / 16 * (barC + 1) * ‖w₁‖ - + 17 / 16 * (barC - 1) * ‖w₂‖ - 32271 / 100352 * barC ^ 2) := by + have htangent := e1s0_positive_distances_le e p₁ p₂ w₁ w₂ he + have hcross := e1s0_cross_le_reduced p₁ p₂ w₁ w₂ hpsep hwsep + nlinarith + +private theorem e1s0_red_pair_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) : + 41177 / 30000 * ‖p₁‖ ^ 2 + 7903 / 15000 * ‖p₂‖ ^ 2 - + 41 / 24 * ⟪e, p₁⟫_ℝ - 8 / 15 * ⟪e, p₂⟫_ℝ - + (barC - 1) / 2 * ‖p₁‖ - (barC + 1) / 2 * ‖p₂‖ - + 68 / 625 * barC ^ 2 ≤ 53 / 25 := by + have hp := gramPairCore_le_vertices e p₁ p₂ barC (41177 / 30000) (7903 / 15000) + (41 / 48) (4 / 15) ((barC - 1) / 2) ((barC + 1) / 2) (68 / 625) (9 / 10) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hpBound := hp.trans e1s0_red_pair_maximum + simp only [inner_add_right, real_inner_smul_right] at hpBound + nlinarith + +private theorem e1s0_blue_pair_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e w₁ w₂ : E) (he : ‖e‖ = 1) + (hw₁ : ‖w₁‖ ≤ 1) (hw₂ : ‖w₂‖ ≤ 1) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 9329977 / 8028160 * ‖w₁‖ ^ 2 + 7915571 / 4515840 * ‖w₂‖ ^ 2 - + 31 / 40 * ⟪e, w₁⟫_ℝ - 22 / 15 * ⟪e, w₂⟫_ℝ - + 17 / 16 * (barC + 1) * ‖w₁‖ - + 17 / 16 * (barC - 1) * ‖w₂‖ - 32271 / 100352 * barC ^ 2 ≤ 11 / 10 := by + have hw := gramPairCore_le_vertices e w₁ w₂ barC + (9329977 / 8028160) (7915571 / 4515840) (31 / 80) (11 / 15) + (17 / 16 * (barC + 1)) (17 / 16 * (barC - 1)) (32271 / 100352) (13 / 20) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hwBound := hw.trans e1s0_blue_pair_maximum + simp only [inner_add_right, real_inner_smul_right] at hwBound + nlinarith + +/-- A rational Gram separator for the `E1/S0` incidence representative. -/ +theorem gramCertificate_e1s0 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 37 / 20 * ‖e - p₁ - w₁‖ + 21 / 8 * ‖e - p₁ - w₂‖ + + 27 / 20 * ‖e - p₂ - w₂‖ - + ((barC - 1) * ‖p₁‖ + (barC + 1) * ‖p₂‖) / 2 - + 17 / 16 * ((barC + 1) * ‖w₁‖ + (barC - 1) * ‖w₂‖) - + 17 / 8 + 551 / 80 * barC - 807 / 80 * barC ^ 2 < 0 := by + have hdecompose := e1s0_decomposition e p₁ p₂ w₁ w₂ he hpsep hwsep + have hpBound := e1s0_red_pair_le e p₁ p₂ he hp₁ hp₂ hpsep + have hwBound := e1s0_blue_pair_le e w₁ w₂ he hw₁ hw₂ hwsep + nlinarith [e1s0_constant_neg] + +/-- The alternative positive separator is strictly negative for every admissible configuration. -/ +theorem endpointBalancedE1S0GramBound_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + 27 / 20 * diagonalMatchingReducedSlack configuration + + 17 / 8 * redEndpointReducedSlack configuration 1 + + blueBalancedReducedSlack configuration 0 < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hpsep : barC ≤ ‖p₁ - p₂‖ := by + have hred := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hred + exact hred + have hwsep : barC ≤ ‖w₁ - w₂‖ := by + have hblue := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hblue + exact hblue + have hcertificate := gramCertificate_e1s0 e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hpsep hwsep + simp only [diagonalMatchingReducedSlack, redEndpointReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] + dsimp only [e, p₁, p₂, w₁, w₂] at hcertificate + nlinarith + +/-- The `E1/S0` endpoint/balanced representative is impossible. -/ +theorem not_redEndpoint_one_and_blueBalanced_zero + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.endpoint 1) ∧ + blueSiblingTriangleFailure configuration (.balanced 0)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redEndpointReducedSlack_pos h 1 hred + have hblueSlack := blueBalancedReducedSlack_pos h 0 hblue + have hbound := endpointBalancedE1S0GramBound_of_admissible h + nlinarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingLensS0S0.lean b/LeanPool/Besicovitch/SixPoint/SiblingLensS0S0.lean new file mode 100644 index 0000000000..974af921f5 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingLensS0S0.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# The `S0/S0` sibling incidence + +This file closes the balanced/balanced orbit `S0/S0`. Four norm tangents retain their full +two-by-two incidence matrix. A rational positive-semidefinite factorization then separates the +two colors, leaving two copies of the three-vertex radial estimate. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- The rational positive-semidefinite factorization for the `S0/S0` cross matrix. -/ +private theorem s0s0_cross_inner_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (p₁ p₂ w₁ w₂ : E) : + 2 * (1 / 4 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₂, w₁⟫_ℝ + + 2 * (7 / 60 : ℝ) * ⟪p₂, w₂⟫_ℝ ≤ + 1 / 4 * ‖p₁‖ ^ 2 + 7 / 60 * ‖p₂‖ ^ 2 + + 2 * (3 / 25) * ⟪p₁, p₂⟫_ℝ + + 1 / 4 * ‖w₁‖ ^ 2 + 7 / 60 * ‖w₂‖ ^ 2 + + 2 * (3 / 25) * ⟪w₁, w₂⟫_ℝ := by + have hfirst : 0 ≤ + ‖(1 / 2 : ℝ) • (p₁ - w₁) + (6 / 25 : ℝ) • (p₂ - w₂)‖ ^ 2 := + sq_nonneg _ + have hsecond : 0 ≤ (443 / 7500 : ℝ) * ‖p₂ - w₂‖ ^ 2 := + mul_nonneg (by norm_num) (sq_nonneg _) + rw [norm_add_sq_real] at hfirst + simp only [norm_smul, Real.norm_eq_abs, + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 1 / 2), + abs_of_nonneg (by norm_num : (0 : ℝ) ≤ 6 / 25), + real_inner_smul_left, real_inner_smul_right] at hfirst + ring_nf at hfirst + rw [norm_sub_sq_real, norm_sub_sq_real] at hfirst + rw [norm_sub_sq_real] at hsecond + simp only [inner_sub_left, inner_sub_right, real_inner_comm] at hfirst hsecond + ring_nf at hfirst hsecond ⊢ + nlinarith + +private theorem s0s0_positive_distances_le {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) : + 22 / 15 * ‖e - p₁ - w₁‖ + 1 / 2 * ‖e - p₁ - w₂‖ + + 1 / 2 * ‖e - p₂ - w₁‖ + 7 / 15 * ‖e - p₂ - w₂‖ ≤ + 7679 / 1800 + + 37 / 100 * ‖p₁‖ ^ 2 + 71 / 300 * ‖p₂‖ ^ 2 + + 37 / 100 * ‖w₁‖ ^ 2 + 71 / 300 * ‖w₂‖ ^ 2 - + 37 / 50 * ⟪e, p₁⟫_ℝ - 71 / 150 * ⟪e, p₂⟫_ℝ - + 37 / 50 * ⟪e, w₁⟫_ℝ - 71 / 150 * ⟪e, w₂⟫_ℝ + + 2 * (1 / 4 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₂, w₁⟫_ℝ + + 2 * (7 / 60 : ℝ) * ⟪p₂, w₂⟫_ℝ := by + have h₁₁ := weightedNorm_le_quadratic (e - p₁ - w₁) (22 / 15) (1 / 4) + (by norm_num) + have h₁₂ := weightedNorm_le_quadratic (e - p₁ - w₂) (1 / 2) (3 / 25) + (by norm_num) + have h₂₁ := weightedNorm_le_quadratic (e - p₂ - w₁) (1 / 2) (3 / 25) + (by norm_num) + have h₂₂ := weightedNorm_le_quadratic (e - p₂ - w₂) (7 / 15) (7 / 60) + (by norm_num) + rw [norm_sub_sub_sq e p₁ w₁] at h₁₁ + rw [norm_sub_sub_sq e p₁ w₂] at h₁₂ + rw [norm_sub_sub_sq e p₂ w₁] at h₂₁ + rw [norm_sub_sub_sq e p₂ w₂] at h₂₂ + simp only [he, one_pow] at h₁₁ h₁₂ h₂₁ h₂₂ + ring_nf at h₁₁ h₁₂ h₂₁ h₂₂ ⊢ + nlinarith + +private theorem s0s0_cross_le_reduced {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (p₁ p₂ w₁ w₂ : E) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 2 * (1 / 4 : ℝ) * ⟪p₁, w₁⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₁, w₂⟫_ℝ + + 2 * (3 / 25 : ℝ) * ⟪p₂, w₁⟫_ℝ + + 2 * (7 / 60 : ℝ) * ⟪p₂, w₂⟫_ℝ ≤ + 1 / 4 * ‖p₁‖ ^ 2 + 7 / 60 * ‖p₂‖ ^ 2 + + 3 / 25 * (‖p₁‖ ^ 2 + ‖p₂‖ ^ 2 - barC ^ 2) + + 1 / 4 * ‖w₁‖ ^ 2 + 7 / 60 * ‖w₂‖ ^ 2 + + 3 / 25 * (‖w₁‖ ^ 2 + ‖w₂‖ ^ 2 - barC ^ 2) := by + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + rw [norm_sub_sq_real] at hpsepSq hwsepSq + have hpinnerScaled := mul_le_mul_of_nonneg_left hpsepSq + (by norm_num : (0 : ℝ) ≤ 3 / 25) + have hwinnerScaled := mul_le_mul_of_nonneg_left hwsepSq + (by norm_num : (0 : ℝ) ≤ 3 / 25) + have hcross := s0s0_cross_inner_le p₁ p₂ w₁ w₂ + nlinarith + +private theorem s0s0_pair_maximum : + gramPairMaximum barC (37 / 50) (71 / 150) (37 / 100) (71 / 300) + ((barC - 1) / 2) ((barC + 1) / 2) (3 / 25) (10 / 27) ≤ 51 / 100 := by + simp only [gramPairMaximum, max_le_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num [gramPairValue] at hlower hupper ⊢ + constructor + · nlinarith [sq_nonneg (barC - 1)] + constructor <;> nlinarith [sq_nonneg (barC - 1)] + +private theorem s0s0_constant_neg : + 7679 / 1800 + 2 * (51 / 100) - + 14 / 15 * barC * (2 * barC - 1) + 2 * barC - 3 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + +/-- A rational Gram separator for the `S0/S0` incidence representative. -/ +theorem gramCertificate_s0s0 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 22 / 15 * ‖e - p₁ - w₁‖ + 1 / 2 * ‖e - p₁ - w₂‖ + + 1 / 2 * ‖e - p₂ - w₁‖ + 7 / 15 * ‖e - p₂ - w₂‖ - + ((barC - 1) * (‖p₁‖ + ‖w₁‖) + + (barC + 1) * (‖p₂‖ + ‖w₂‖)) / 2 - + 14 / 15 * barC * (2 * barC - 1) + 2 * barC - 3 * barC ^ 2 < 0 := by + have htangent := s0s0_positive_distances_le e p₁ p₂ w₁ w₂ he + have hcross := s0s0_cross_le_reduced p₁ p₂ w₁ w₂ hpsep hwsep + have hp := gramPairCore_le_vertices e p₁ p₂ barC + (37 / 50) (71 / 150) (37 / 100) (71 / 300) + ((barC - 1) / 2) ((barC + 1) / 2) (3 / 25) (10 / 27) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) + (by norm_num) (by norm_num) + have hw := gramPairCore_le_vertices e w₁ w₂ barC + (37 / 50) (71 / 150) (37 / 100) (71 / 300) + ((barC - 1) / 2) ((barC + 1) / 2) (3 / 25) (10 / 27) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) + (by norm_num) (by norm_num) + have hpBound := hp.trans s0s0_pair_maximum + have hwBound := hw.trans s0s0_pair_maximum + simp only [inner_add_right, real_inner_smul_right] at hpBound hwBound + nlinarith [s0s0_constant_neg] + +/-- The alternative positive separator is strictly negative for every admissible configuration. -/ +theorem balancedBalancedS0S0GramBound_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + 7 / 15 * diagonalMatchingReducedSlack configuration + + redBalancedReducedSlack configuration 0 + + blueBalancedReducedSlack configuration 0 < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hpsep : barC ≤ ‖p₁ - p₂‖ := by + have hred := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hred + exact hred + have hwsep : barC ≤ ‖w₁ - w₂‖ := by + have hblue := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hblue + exact hblue + have hcertificate := gramCertificate_s0s0 e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hpsep hwsep + simp only [diagonalMatchingReducedSlack, redBalancedReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] + dsimp only [e, p₁, p₂, w₁, w₂] at hcertificate + nlinarith + +/-- The `S0/S0` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_zero_and_blueBalanced_zero + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 0)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 0 hblue + have hbound := balancedBalancedS0S0GramBound_of_admissible h + nlinarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingLensS0S3.lean b/LeanPool/Besicovitch/SixPoint/SiblingLensS0S3.lean new file mode 100644 index 0000000000..6a6bdc0ea4 --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingLensS0S3.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.SiblingIncidenceLedger + +/-! +# The `S0/S3` sibling incidence + +This file closes the balanced/balanced orbit `S0/S3`. A common quadratic tangent controls the +three positive cross distances. Two secants of the square root retain enough of the two larger +radial penalties, and three exact rational Gram factorizations cover the resulting radial ranges. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +private theorem s0s3_scalarGram_low_low (e p₁ p₂ w₁ w₂ : ℝ) : + 18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 11930 / 543 * (p₁ ^ 2 + w₂ ^ 2) - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2) ≤ + 1157 / 50 * e ^ 2 + 1263 / 50 * (p₂ ^ 2 + w₁ ^ 2) - + 871 / 100 * ((p₁ - p₂) ^ 2 + (w₁ - w₂) ^ 2) := by + apply sub_nonneg.mp + rw [show + 1157 / 50 * e ^ 2 + 1263 / 50 * (p₂ ^ 2 + w₁ ^ 2) - + 871 / 100 * ((p₁ - p₂) ^ 2 + (w₁ - w₂) ^ 2) - + (18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 11930 / 543 * (p₁ ^ 2 + w₂ ^ 2) - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2)) = + (3511 / 1000 * e + 41 / 40 * p₁ + 41 / 20 * p₂ + 41 / 20 * w₁ + + 41 / 40 * w₂) ^ 2 + + (733 / 250 * p₁ + 2253 / 1000 * p₂ - 243 / 125 * w₁ - + 179 / 500 * w₂) ^ 2 + + (843 / 500 * p₂ - 203 / 100 * w₁ - 2903 / 1000 * w₂) ^ 2 + + (69 / 500 * w₁ + 67 / 500 * w₂) ^ 2 + (41 / 250 * w₂) ^ 2 + + 49 / 40000 * (e + p₁) ^ 2 + 49 / 20000 * (e + p₂) ^ 2 + + 49 / 20000 * (e + w₁) ^ 2 + 49 / 40000 * (e + w₂) ^ 2 + + 1477 / 500000 * (p₁ + p₂) ^ 2 + 721 / 500000 * (p₁ - w₁) ^ 2 + + 969 / 1000000 * (p₁ - w₂) ^ 2 + 11 / 125000 * (p₂ - w₁) ^ 2 + + 109 / 500000 * (p₂ - w₂) ^ 2 + 19 / 15625 * (w₁ + w₂) ^ 2 + + 5529 / 1000000 * e ^ 2 + 3635423 / 543000000 * p₁ ^ 2 + + 1133441 / 138600000 * p₂ ^ 2 + 711779 / 86625000 * w₁ ^ 2 + + 1589923 / 271500000 * w₂ ^ 2 by ring] + positivity + +private theorem s0s3_scalarGram_low_high (e p₁ p₂ w₁ w₂ : ℝ) : + 18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 11930 / 543 * p₁ ^ 2 - 1193 / 85 * w₂ ^ 2 - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2) ≤ + 621 / 25 * e ^ 2 + 2701 / 100 * p₂ ^ 2 + 1863 / 100 * w₁ ^ 2 - + 849 / 100 * (p₁ - p₂) ^ 2 - 131 / 25 * (w₁ - w₂) ^ 2 := by + apply sub_nonneg.mp + rw [show + 621 / 25 * e ^ 2 + 2701 / 100 * p₂ ^ 2 + 1863 / 100 * w₁ ^ 2 - + 849 / 100 * (p₁ - p₂) ^ 2 - 131 / 25 * (w₁ - w₂) ^ 2 - + (18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 11930 / 543 * p₁ ^ 2 - + 1193 / 85 * w₂ ^ 2 - 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2)) = + (1873 / 500 * e + 961 / 1000 * p₁ + 961 / 500 * p₂ + 961 / 500 * w₁ + + 961 / 1000 * w₂) ^ 2 + + (2991 / 1000 * p₁ + 2221 / 1000 * p₂ - 1821 / 1000 * w₁ - + 309 / 1000 * w₂) ^ 2 + + (1169 / 500 * p₂ - 139 / 100 * w₁ - 509 / 250 * w₂) ^ 2 + + (29 / 200 * w₁ - 1 / 500 * w₂) ^ 2 + (141 / 1000 * w₂) ^ 2 + + 47 / 500000 * (e + p₁) ^ 2 + 47 / 250000 * (e + p₂) ^ 2 + + 47 / 250000 * (e + w₁) ^ 2 + 47 / 500000 * (e + w₂) ^ 2 + + 53 / 1000000 * (p₁ - p₂) ^ 2 + 431 / 1000000 * (p₁ - w₁) ^ 2 + + 349 / 500000 * (p₁ + w₂) ^ 2 + 177 / 1000000 * (p₂ + w₁) ^ 2 + + 117 / 200000 * (p₂ - w₂) ^ 2 + 519 / 1000000 * (w₁ + w₂) ^ 2 + + 173 / 25000 * e ^ 2 + 2621623 / 271500000 * p₁ ^ 2 + + 1874701 / 173250000 * p₂ ^ 2 + 1445291 / 138600000 * w₁ ^ 2 + + 156657 / 17000000 * w₂ ^ 2 by ring] + positivity + +private theorem s0s3_scalarGram_high_high (e p₁ p₂ w₁ w₂ : ℝ) : + 18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 1193 / 85 * (p₁ ^ 2 + w₂ ^ 2) - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2) ≤ + 2641 / 100 * e ^ 2 + 2071 / 100 * (p₂ ^ 2 + w₁ ^ 2) - + 517 / 100 * ((p₁ - p₂) ^ 2 + (w₁ - w₂) ^ 2) := by + apply sub_nonneg.mp + rw [show + 2641 / 100 * e ^ 2 + 2071 / 100 * (p₂ ^ 2 + w₁ ^ 2) - + 517 / 100 * ((p₁ - p₂) ^ 2 + (w₁ - w₂) ^ 2) - + (18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 1193 / 85 * (p₁ ^ 2 + w₂ ^ 2) - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2)) = + (79 / 20 * e + 911 / 1000 * p₁ + 1823 / 1000 * p₂ + 1823 / 1000 * w₁ + + 911 / 1000 * w₂) ^ 2 + + (2103 / 1000 * p₁ + 417 / 250 * p₂ - 2501 / 1000 * w₁ - + 79 / 200 * w₂) ^ 2 + + (1119 / 500 * p₂ - 1229 / 1000 * w₁ - 257 / 125 * w₂) ^ 2 + + (157 / 1000 * w₁ - 11 / 250 * w₂) ^ 2 + (39 / 200 * w₂) ^ 2 + + 31 / 20000 * (e + p₁) ^ 2 + 17 / 20000 * (e - p₂) ^ 2 + + 17 / 20000 * (e - w₁) ^ 2 + 31 / 20000 * (e + w₂) ^ 2 + + 1443 / 1000000 * (p₁ + p₂) ^ 2 + 23 / 20000 * (p₁ - w₁) ^ 2 + + 191 / 250000 * (p₁ + w₂) ^ 2 + 1159 / 1000000 * (p₂ - w₁) ^ 2 + + 113 / 200000 * (p₂ - w₂) ^ 2 + 359 / 250000 * (w₁ + w₂) ^ 2 + + 27 / 10000 * e ^ 2 + 133571 / 17000000 * p₁ ^ 2 + + 2348849 / 346500000 * p₂ ^ 2 + 967121 / 138600000 * w₁ ^ 2 + + 67457 / 8500000 * w₂ ^ 2 by ring] + positivity + +private theorem s0s3_gram_low_low (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 11930 / 543 * (‖p₁‖ ^ 2 + ‖w₂‖ ^ 2) - + 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 1157 / 50 * ‖e‖ ^ 2 + 1263 / 50 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) - + 871 / 100 * (‖p₁ - p₂‖ ^ 2 + ‖w₁ - w₂‖ ^ 2) := by + have h₀ := s0s3_scalarGram_low_low (e 0) (p₁ 0) (p₂ 0) (w₁ 0) (w₂ 0) + have h₁ := s0s3_scalarGram_low_low (e 1) (p₁ 1) (p₂ 1) (w₁ 1) (w₂ 1) + have h := add_le_add h₀ h₁ + simp only [PiLp.norm_sq_eq_of_L2, Fin.sum_univ_two, PiLp.sub_apply, Real.norm_eq_abs, + sq_abs] at ⊢ + ring_nf at h ⊢ + exact h + +private theorem s0s3_gram_low_high (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 11930 / 543 * ‖p₁‖ ^ 2 - + 1193 / 85 * ‖w₂‖ ^ 2 - 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 621 / 25 * ‖e‖ ^ 2 + 2701 / 100 * ‖p₂‖ ^ 2 + 1863 / 100 * ‖w₁‖ ^ 2 - + 849 / 100 * ‖p₁ - p₂‖ ^ 2 - 131 / 25 * ‖w₁ - w₂‖ ^ 2 := by + have h₀ := s0s3_scalarGram_low_high (e 0) (p₁ 0) (p₂ 0) (w₁ 0) (w₂ 0) + have h₁ := s0s3_scalarGram_low_high (e 1) (p₁ 1) (p₂ 1) (w₁ 1) (w₂ 1) + have h := add_le_add h₀ h₁ + simp only [PiLp.norm_sq_eq_of_L2, Fin.sum_univ_two, PiLp.sub_apply, Real.norm_eq_abs, + sq_abs] at ⊢ + ring_nf at h ⊢ + exact h + +private theorem s0s3_gram_high_high (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 1193 / 85 * (‖p₁‖ ^ 2 + ‖w₂‖ ^ 2) - + 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 2641 / 100 * ‖e‖ ^ 2 + 2071 / 100 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) - + 517 / 100 * (‖p₁ - p₂‖ ^ 2 + ‖w₁ - w₂‖ ^ 2) := by + have h₀ := s0s3_scalarGram_high_high (e 0) (p₁ 0) (p₂ 0) (w₁ 0) (w₂ 0) + have h₁ := s0s3_scalarGram_high_high (e 1) (p₁ 1) (p₂ 1) (w₁ 1) (w₂ 1) + have h := add_le_add h₀ h₁ + simp only [PiLp.norm_sq_eq_of_L2, Fin.sum_univ_two, PiLp.sub_apply, Real.norm_eq_abs, + sq_abs] at ⊢ + ring_nf at h ⊢ + exact h + +private theorem s0s3_scalarGram_high_low (e p₁ p₂ w₁ w₂ : ℝ) : + 18 / 5 * ((e - p₁ - w₁) ^ 2 + (e - p₂ - w₁) ^ 2 + + (e - p₂ - w₂) ^ 2) - 1193 / 85 * p₁ ^ 2 - 11930 / 543 * w₂ ^ 2 - + 1930 / 693 * (p₂ ^ 2 + w₁ ^ 2) ≤ + 621 / 25 * e ^ 2 + 1863 / 100 * p₂ ^ 2 + 2701 / 100 * w₁ ^ 2 - + 131 / 25 * (p₁ - p₂) ^ 2 - 849 / 100 * (w₁ - w₂) ^ 2 := by + have h := s0s3_scalarGram_low_high e w₂ w₁ p₂ p₁ + ring_nf at h ⊢ + exact h + +private theorem s0s3_gram_high_low (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 1193 / 85 * ‖p₁‖ ^ 2 - + 11930 / 543 * ‖w₂‖ ^ 2 - 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 621 / 25 * ‖e‖ ^ 2 + 1863 / 100 * ‖p₂‖ ^ 2 + 2701 / 100 * ‖w₁‖ ^ 2 - + 131 / 25 * ‖p₁ - p₂‖ ^ 2 - 849 / 100 * ‖w₁ - w₂‖ ^ 2 := by + have h₀ := s0s3_scalarGram_high_low (e 0) (p₁ 0) (p₂ 0) (w₁ 0) (w₂ 0) + have h₁ := s0s3_scalarGram_high_low (e 1) (p₁ 1) (p₂ 1) (w₁ 1) (w₂ 1) + have h := add_le_add h₀ h₁ + simp only [PiLp.norm_sq_eq_of_L2, Fin.sum_univ_two, PiLp.sub_apply, Real.norm_eq_abs, + sq_abs] at ⊢ + ring_nf at h ⊢ + exact h + +private theorem s0s3_positive_distances_le (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) : + 17 * ‖e - p₁ - w₁‖ + 20 * ‖e - p₂ - w₁‖ + + 17 * ‖e - p₂ - w₂‖ ≤ + 815 / 12 + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + + ‖e - p₂ - w₁‖ ^ 2 + ‖e - p₂ - w₂‖ ^ 2) := by + have h₁₁ := weightedNorm_le_quadratic (e - p₁ - w₁) 17 (18 / 5) (by norm_num) + have h₂₁ := weightedNorm_le_quadratic (e - p₂ - w₁) 20 (18 / 5) (by norm_num) + have h₂₂ := weightedNorm_le_quadratic (e - p₂ - w₂) 17 (18 / 5) (by norm_num) + norm_num at h₁₁ h₂₁ h₂₂ ⊢ + linarith + +private theorem secant_le (x lower upper : ℝ) (hlower : lower ≤ x) (hupper : x ≤ upper) + (hsum : 0 < lower + upper) : + (x ^ 2 + lower * upper) / (lower + upper) ≤ x := by + rw [div_le_iff₀ hsum] + nlinarith [mul_nonpos_of_nonneg_of_nonpos (sub_nonneg.mpr hlower) + (sub_nonpos.mpr hupper)] + +private theorem s0s3_radius_floor {E : Type*} [NormedAddCommGroup E] (x y : E) + (hy : ‖y‖ ≤ 1) (hseparation : barC ≤ ‖x - y‖) : + 193 / 500 ≤ ‖x‖ := by + have htriangle := norm_sub_le x y + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + linarith + +private theorem s0s3_low_radial_secant (x : ℝ) (hlower : 193 / 500 ≤ x) + (hupper : x ≤ 1) : + 1930 / 693 * x ^ 2 + 37249 / 34650 ≤ 193 / 50 * x := by + have h := secant_le x (193 / 500) 1 hlower hupper (by norm_num) + norm_num at h ⊢ + linarith + +private theorem s0s3_high_radial_low_secant (x : ℝ) (hlower : 193 / 500 ≤ x) + (hupper : x ≤ 7 / 10) : + 11930 / 543 * x ^ 2 + 1611743 / 271500 ≤ 1193 / 50 * x := by + have h := secant_le x (193 / 500) (7 / 10) hlower hupper (by norm_num) + norm_num at h ⊢ + linarith + +private theorem s0s3_high_radial_high_secant (x : ℝ) (hlower : 7 / 10 ≤ x) + (hupper : x ≤ 1) : + 1193 / 85 * x ^ 2 + 8351 / 850 ≤ 1193 / 50 * x := by + have h := secant_le x (7 / 10) 1 hlower hupper (by norm_num) + norm_num at h ⊢ + linarith + +private theorem s0s3_high_coefficient_le : 1193 / 50 ≤ 10 * (barC + 1) := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + linarith + +private theorem s0s3_low_coefficient_le : 193 / 50 ≤ 10 * (barC - 1) := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + linarith + +private theorem s0s3_low_low_constant_neg : + 815 / 12 + 1157 / 50 + 2 * (1263 / 50) - 2 * (871 / 100) * barC ^ 2 - + 2 * (37249 / 34650) - 2 * (1611743 / 271500) + + 54 * barC - 88 * barC ^ 2 < 0 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem s0s3_low_high_constant_neg : + 815 / 12 + 621 / 25 + 2701 / 100 + 1863 / 100 - + (849 / 100 + 131 / 25) * barC ^ 2 - 2 * (37249 / 34650) - + 1611743 / 271500 - 8351 / 850 + 54 * barC - 88 * barC ^ 2 < 0 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem s0s3_high_high_constant_neg : + 815 / 12 + 2641 / 100 + 2 * (2071 / 100) - 2 * (517 / 100) * barC ^ 2 - + 2 * (37249 / 34650) - 2 * (8351 / 850) + + 54 * barC - 88 * barC ^ 2 < 0 := by + have hc := barC_mem_isolation_box.1 + norm_num at hc ⊢ + nlinarith [sq_nonneg (barC - 1)] + +private theorem s0s3_gramBound_low_low + (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) (he : ‖e‖ = 1) + (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 11930 / 543 * (‖p₁‖ ^ 2 + ‖w₂‖ ^ 2) - + 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 1157 / 50 + 2 * (1263 / 50) - 2 * (871 / 100) * barC ^ 2 := by + have hp₂Sq : ‖p₂‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg p₂] + have hw₁Sq : ‖w₁‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg w₁] + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hgram := s0s3_gram_low_low e p₁ p₂ w₁ w₂ + rw [he, one_pow] at hgram + nlinarith only [hgram, hp₂Sq, hw₁Sq, hpsepSq, hwsepSq] + +private theorem s0s3_gramBound_low_high + (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) (he : ‖e‖ = 1) + (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 11930 / 543 * ‖p₁‖ ^ 2 - + 1193 / 85 * ‖w₂‖ ^ 2 - 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 621 / 25 + 2701 / 100 + 1863 / 100 - + (849 / 100 + 131 / 25) * barC ^ 2 := by + have hp₂Sq : ‖p₂‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg p₂] + have hw₁Sq : ‖w₁‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg w₁] + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hgram := s0s3_gram_low_high e p₁ p₂ w₁ w₂ + rw [he, one_pow] at hgram + nlinarith only [hgram, hp₂Sq, hw₁Sq, hpsepSq, hwsepSq] + +private theorem s0s3_gramBound_high_low + (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) (he : ‖e‖ = 1) + (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 1193 / 85 * ‖p₁‖ ^ 2 - + 11930 / 543 * ‖w₂‖ ^ 2 - 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 621 / 25 + 2701 / 100 + 1863 / 100 - + (849 / 100 + 131 / 25) * barC ^ 2 := by + have hp₂Sq : ‖p₂‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg p₂] + have hw₁Sq : ‖w₁‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg w₁] + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hgram := s0s3_gram_high_low e p₁ p₂ w₁ w₂ + rw [he, one_pow] at hgram + nlinarith only [hgram, hp₂Sq, hw₁Sq, hpsepSq, hwsepSq] + +private theorem s0s3_gramBound_high_high + (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) (he : ‖e‖ = 1) + (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 18 / 5 * (‖e - p₁ - w₁‖ ^ 2 + ‖e - p₂ - w₁‖ ^ 2 + + ‖e - p₂ - w₂‖ ^ 2) - 1193 / 85 * (‖p₁‖ ^ 2 + ‖w₂‖ ^ 2) - + 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) ≤ + 2641 / 100 + 2 * (2071 / 100) - 2 * (517 / 100) * barC ^ 2 := by + have hp₂Sq : ‖p₂‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg p₂] + have hw₁Sq : ‖w₁‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg w₁] + have hpsepSq : barC ^ 2 ≤ ‖p₁ - p₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (p₁ - p₂)] + have hwsepSq : barC ^ 2 ≤ ‖w₁ - w₂‖ ^ 2 := by + nlinarith [barC_pos, norm_nonneg (w₁ - w₂)] + have hgram := s0s3_gram_high_high e p₁ p₂ w₁ w₂ + rw [he, one_pow] at hgram + nlinarith only [hgram, hp₂Sq, hw₁Sq, hpsepSq, hwsepSq] + +private theorem s0s3_radialBound_of_secants (p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) + (pSlope pConstant wSlope wConstant : ℝ) + (hp₁ : pSlope * ‖p₁‖ ^ 2 + pConstant ≤ 1193 / 50 * ‖p₁‖) + (hp₂ : 1930 / 693 * ‖p₂‖ ^ 2 + 37249 / 34650 ≤ 193 / 50 * ‖p₂‖) + (hw₁ : 1930 / 693 * ‖w₁‖ ^ 2 + 37249 / 34650 ≤ 193 / 50 * ‖w₁‖) + (hw₂ : wSlope * ‖w₂‖ ^ 2 + wConstant ≤ 1193 / 50 * ‖w₂‖) : + pSlope * ‖p₁‖ ^ 2 + wSlope * ‖w₂‖ ^ 2 + + 1930 / 693 * (‖p₂‖ ^ 2 + ‖w₁‖ ^ 2) + + pConstant + wConstant + 2 * (37249 / 34650) ≤ + 10 * (barC + 1) * (‖p₁‖ + ‖w₂‖) + + 10 * (barC - 1) * (‖p₂‖ + ‖w₁‖) := by + have hhigh := mul_le_mul_of_nonneg_right s0s3_high_coefficient_le + (add_nonneg (norm_nonneg p₁) (norm_nonneg w₂)) + have hlow := mul_le_mul_of_nonneg_right s0s3_low_coefficient_le + (add_nonneg (norm_nonneg p₂) (norm_nonneg w₁)) + calc + _ ≤ 1193 / 50 * (‖p₁‖ + ‖w₂‖) + + 193 / 50 * (‖p₂‖ + ‖w₁‖) := by linarith + _ ≤ _ := add_le_add hhigh hlow + +/-- A two-secant rational Gram separator for the `S0/S3` incidence representative. -/ +theorem gramCertificate_s0s3 (e p₁ p₂ w₁ w₂ : (EuclideanSpace ℝ (Fin 2))) + (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) (hpsep : barC ≤ ‖p₁ - p₂‖) + (hwsep : barC ≤ ‖w₁ - w₂‖) : + 17 * ‖e - p₁ - w₁‖ + 20 * ‖e - p₂ - w₁‖ + + 17 * ‖e - p₂ - w₂‖ - + 10 * (barC + 1) * (‖p₁‖ + ‖w₂‖) - + 10 * (barC - 1) * (‖p₂‖ + ‖w₁‖) + + 54 * barC - 88 * barC ^ 2 < 0 := by + have hp₁Lower := s0s3_radius_floor p₁ p₂ hp₂ hpsep + have hp₂Lower := s0s3_radius_floor p₂ p₁ hp₁ (by simpa [norm_sub_rev] using hpsep) + have hw₁Lower := s0s3_radius_floor w₁ w₂ hw₂ hwsep + have hw₂Lower := s0s3_radius_floor w₂ w₁ hw₁ (by simpa [norm_sub_rev] using hwsep) + have htangent := s0s3_positive_distances_le e p₁ p₂ w₁ w₂ + have hp₂Radial := s0s3_low_radial_secant ‖p₂‖ hp₂Lower hp₂ + have hw₁Radial := s0s3_low_radial_secant ‖w₁‖ hw₁Lower hw₁ + by_cases hp₁Low : ‖p₁‖ ≤ 7 / 10 + · have hp₁Radial := s0s3_high_radial_low_secant ‖p₁‖ hp₁Lower hp₁Low + by_cases hw₂Low : ‖w₂‖ ≤ 7 / 10 + · have hw₂Radial := s0s3_high_radial_low_secant ‖w₂‖ hw₂Lower hw₂Low + have hgram := + s0s3_gramBound_low_low e p₁ p₂ w₁ w₂ he hp₂ hw₁ hpsep hwsep + have hradial := s0s3_radialBound_of_secants p₁ p₂ w₁ w₂ + (11930 / 543) (1611743 / 271500) (11930 / 543) (1611743 / 271500) + hp₁Radial hp₂Radial hw₁Radial hw₂Radial + nlinarith only [htangent, hgram, hradial, s0s3_low_low_constant_neg] + · have hw₂Radial := s0s3_high_radial_high_secant ‖w₂‖ + (le_of_not_ge hw₂Low) hw₂ + have hgram := + s0s3_gramBound_low_high e p₁ p₂ w₁ w₂ he hp₂ hw₁ hpsep hwsep + have hradial := s0s3_radialBound_of_secants p₁ p₂ w₁ w₂ + (11930 / 543) (1611743 / 271500) (1193 / 85) (8351 / 850) + hp₁Radial hp₂Radial hw₁Radial hw₂Radial + nlinarith only [htangent, hgram, hradial, s0s3_low_high_constant_neg] + · have hp₁Radial := s0s3_high_radial_high_secant ‖p₁‖ + (le_of_not_ge hp₁Low) hp₁ + by_cases hw₂Low : ‖w₂‖ ≤ 7 / 10 + · have hw₂Radial := s0s3_high_radial_low_secant ‖w₂‖ hw₂Lower hw₂Low + have hgram := + s0s3_gramBound_high_low e p₁ p₂ w₁ w₂ he hp₂ hw₁ hpsep hwsep + have hradial := s0s3_radialBound_of_secants p₁ p₂ w₁ w₂ + (1193 / 85) (8351 / 850) (11930 / 543) (1611743 / 271500) + hp₁Radial hp₂Radial hw₁Radial hw₂Radial + nlinarith only [htangent, hgram, hradial, s0s3_low_high_constant_neg] + · have hw₂Radial := s0s3_high_radial_high_secant ‖w₂‖ + (le_of_not_ge hw₂Low) hw₂ + have hgram := + s0s3_gramBound_high_high e p₁ p₂ w₁ w₂ he hp₂ hw₁ hpsep hwsep + have hradial := s0s3_radialBound_of_secants p₁ p₂ w₁ w₂ + (1193 / 85) (8351 / 850) (1193 / 85) (8351 / 850) + hp₁Radial hp₂Radial hw₁Radial hw₂Radial + nlinarith only [htangent, hgram, hradial, s0s3_high_high_constant_neg] + +/-- The `S0/S3` separator is strictly negative for every admissible configuration. -/ +theorem balancedBalancedS0S3GramBound_of_admissible + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) : + 7 * diagonalMatchingReducedSlack configuration + + 20 * redBalancedReducedSlack configuration 0 + + 20 * blueBalancedReducedSlack configuration 3 < 0 := by + let e := configuration.rootDisplacement + let p₁ := configuration.redDisplacement .left + let p₂ := configuration.redDisplacement .right + let w₁ := configuration.bluePullback .left + let w₂ := configuration.bluePullback .right + have hpsep : barC ≤ ‖p₁ - p₂‖ := by + have hred := configuration.two_mul_le_dist_redDisplacement h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hred + exact hred + have hwsep : barC ≤ ‖w₁ - w₂‖ := by + have hblue := configuration.two_mul_le_dist_bluePullback h + rw [barS, show 2 * (barC / 2) = barC by ring, dist_eq_norm] at hblue + exact hblue + have hcertificate := gramCertificate_s0s3 e p₁ p₂ w₁ w₂ + (configuration.norm_rootDisplacement h) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_redDisplacement_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) + (configuration.norm_bluePullback_le_one h (by simp)) hpsep hwsep + simp only [diagonalMatchingReducedSlack, redBalancedReducedSlack, + blueBalancedReducedSlack, balancedIncidencePenalty, incidenceCrossDistance_eq_norm, + incidenceChildRadius_red_eq_norm, incidenceChildRadius_blue_eq_norm] + norm_num [incidenceFirst, incidenceSecond, incidenceChild, otherChild] + dsimp only [e, p₁, p₂, w₁, w₂] at hcertificate + nlinarith + +/-- The `S0/S3` balanced/balanced representative is impossible. -/ +theorem not_redBalanced_zero_and_blueBalanced_three + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + ¬ (redSiblingTriangleFailure configuration (.balanced 0) ∧ + blueSiblingTriangleFailure configuration (.balanced 3)) := by + rintro ⟨hred, hblue⟩ + have hmatchingSlack := diagonalMatchingReducedSlack_nonneg h hmatching + have hredSlack := redBalancedReducedSlack_pos h 0 hred + have hblueSlack := blueBalancedReducedSlack_pos h 3 hblue + have hbound := balancedBalancedS0S3GramBound_of_admissible h + nlinarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingTangent.lean b/LeanPool/Besicovitch/SixPoint/SiblingTangent.lean new file mode 100644 index 0000000000..54fb10f3fd --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingTangent.lean @@ -0,0 +1,745 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.NormEstimates +public import LeanPool.Besicovitch.Certificates.EndpointBridge +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry + +/-! +# Rational tangent bounds for sibling incidences + +This file proves the two-point tangent inequality used by the rational cells in the complete +sibling-incidence ledger. Its endpoint checks use only rational arithmetic and the certified +isolation interval for `barC`. +-/ + +@[expose] public section + +noncomputable section + +open scoped InnerProductSpace + +namespace LeanPool.Besicovitch + +/-- A separable convex quadratic on the radial triangle is bounded at its three vertices. -/ +theorem separableQuadratic_le_radial_vertices {a₁ a₂ b₁ b₂ d c t₁ t₂ : ℝ} + (ha₁ : 0 ≤ a₁) (ha₂ : 0 ≤ a₂) (ht₁ : t₁ ≤ 1) (ht₂ : t₂ ≤ 1) + (hsum : c ≤ t₁ + t₂) : + a₁ * t₁ ^ 2 + b₁ * t₁ + a₂ * t₂ ^ 2 + b₂ * t₂ + d ≤ + max (a₁ + b₁ + a₂ + b₂ + d) + (max (a₁ + b₁ + a₂ * (c - 1) ^ 2 + b₂ * (c - 1) + d) + (a₁ * (c - 1) ^ 2 + b₁ * (c - 1) + a₂ + b₂ + d)) := by + let value := fun x y ↦ a₁ * x ^ 2 + b₁ * x + a₂ * y ^ 2 + b₂ * y + d + let v11 := value 1 1 + let v1c := value 1 (c - 1) + let vc1 := value (c - 1) 1 + have ht₁Lower : c - 1 ≤ t₁ := by linarith + have hsecond := quadratic_le_max_endpoints ha₂ (show c - t₁ ≤ t₂ by linarith) ht₂ + (b := b₂) (d := a₁ * t₁ ^ 2 + b₁ * t₁ + d) + have hdiagonal := quadratic_le_max_endpoints (add_nonneg ha₁ ha₂) ht₁Lower ht₁ + (b := b₁ - 2 * a₂ * c - b₂) + (d := a₂ * c ^ 2 + b₂ * c + d) + have htop := quadratic_le_max_endpoints ha₁ ht₁Lower ht₁ + (b := b₁) (d := a₂ + b₂ + d) + have hsecond' : value t₁ t₂ ≤ max (value t₁ (c - t₁)) (value t₁ 1) := by + dsimp only [value] + convert hsecond using 1 <;> ring_nf + have hdiagonal' : value t₁ (c - t₁) ≤ max vc1 v1c := by + dsimp only [value, vc1, v1c] + convert hdiagonal using 1 <;> ring_nf + have htop' : value t₁ 1 ≤ max vc1 v11 := by + dsimp only [value, vc1, v11] + convert htop using 1 <;> ring_nf + have hfinal : value t₁ t₂ ≤ max v11 (max v1c vc1) := hsecond'.trans <| max_le + (hdiagonal'.trans <| max_le + (le_max_of_le_right (le_max_right _ _)) (le_max_of_le_right (le_max_left _ _))) + (htop'.trans <| max_le + (le_max_of_le_right (le_max_right _ _)) (le_max_left _ _)) + simpa [value, v11, v1c, vc1] using hfinal + +/-- The scalar upper function for a two-point Gram estimate. -/ +def gramPairValue (c u₁ u₂ g₁ g₂ d₁ d₂ off sigma t₁ t₂ : ℝ) : ℝ := + (u₁ + (g₁ + g₂) * g₁ / sigma) * t₁ ^ 2 - d₁ * t₁ + + (u₂ + (g₁ + g₂) * g₂ / sigma) * t₂ ^ 2 - d₂ * t₂ + + sigma - (off + g₁ * g₂ / sigma) * c ^ 2 + +/-- The largest radial-vertex value in a two-point Gram estimate. -/ +def gramPairMaximum (c u₁ u₂ g₁ g₂ d₁ d₂ off sigma : ℝ) : ℝ := + max (gramPairValue c u₁ u₂ g₁ g₂ d₁ d₂ off sigma 1 1) + (max (gramPairValue c u₁ u₂ g₁ g₂ d₁ d₂ off sigma 1 (c - 1)) + (gramPairValue c u₁ u₂ g₁ g₂ d₁ d₂ off sigma (c - 1) 1)) + +/-- A separated pair in the unit ball is controlled by the three radial vertices. -/ +theorem gramPairCore_le_vertices {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x₁ x₂ : E) (c u₁ u₂ g₁ g₂ d₁ d₂ off sigma : ℝ) + (he : ‖e‖ = 1) (hx₁ : ‖x₁‖ ≤ 1) (hx₂ : ‖x₂‖ ≤ 1) + (hseparation : c ≤ ‖x₁ - x₂‖) (hc : 0 ≤ c) (hu₁ : 0 ≤ u₁) (hu₂ : 0 ≤ u₂) + (hg₁ : 0 ≤ g₁) (hg₂ : 0 ≤ g₂) (hsigma : 0 < sigma) : + u₁ * ‖x₁‖ ^ 2 + u₂ * ‖x₂‖ ^ 2 - + 2 * ⟪e, g₁ • x₁ + g₂ • x₂⟫_ℝ - d₁ * ‖x₁‖ - d₂ * ‖x₂‖ - + off * c ^ 2 ≤ gramPairMaximum c u₁ u₂ g₁ g₂ d₁ d₂ off sigma := by + let z := g₁ • x₁ + g₂ • x₂ + let Q := (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - + g₁ * g₂ * c ^ 2 + have hseparationSq : c ^ 2 ≤ ‖x₁ - x₂‖ ^ 2 := by + nlinarith [norm_nonneg (x₁ - x₂)] + have hzUpper : ‖z‖ ^ 2 ≤ Q := by + rw [show ‖z‖ ^ 2 = + (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - + g₁ * g₂ * ‖x₁ - x₂‖ ^ 2 by exact weighted_norm_sq x₁ x₂ hg₁ hg₂] + dsimp only [Q] + exact sub_le_sub_left + (mul_le_mul_of_nonneg_left hseparationSq (mul_nonneg hg₁ hg₂)) _ + have hinner := real_inner_le_norm (-e) z + simp only [inner_neg_left, norm_neg, he, one_mul] at hinner + have hnorm := two_mul_norm_tangent z hsigma + have hscaled := (div_le_div_iff_of_pos_right hsigma).2 hzUpper + have horientation : -2 * ⟪e, z⟫_ℝ ≤ sigma + Q / sigma := by + nlinarith + have hsum : c ≤ ‖x₁‖ + ‖x₂‖ := + hseparation.trans (norm_sub_le x₁ x₂) + have hvertices := separableQuadratic_le_radial_vertices + (a₁ := u₁ + (g₁ + g₂) * g₁ / sigma) + (a₂ := u₂ + (g₁ + g₂) * g₂ / sigma) (b₁ := -d₁) (b₂ := -d₂) + (d := sigma - (off + g₁ * g₂ / sigma) * c ^ 2) (c := c) + (t₁ := ‖x₁‖) (t₂ := ‖x₂‖) (by positivity) (by positivity) hx₁ hx₂ hsum + have hpointwise : + u₁ * ‖x₁‖ ^ 2 + u₂ * ‖x₂‖ ^ 2 - 2 * ⟪e, z⟫_ℝ - + d₁ * ‖x₁‖ - d₂ * ‖x₂‖ - off * c ^ 2 ≤ + gramPairValue c u₁ u₂ g₁ g₂ d₁ d₂ off sigma ‖x₁‖ ‖x₂‖ := by + dsimp only [gramPairValue, Q] at horientation ⊢ + ring_nf at horientation ⊢ + nlinarith + dsimp only [z] at hpointwise + apply hpointwise.trans + unfold gramPairMaximum + dsimp only [gramPairValue] + ring_nf at hvertices ⊢ + exact hvertices + +/-- The quadratic upper function in the two-point tangent estimate. -/ +def pairTangentValue (c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma t₁ t₂ : ℝ) : ℝ := + let g₁ := A₁ / rho₁ + let g₂ := A₂ / rho₂ + A₁ / (2 * rho₁) * (1 + rho₁ ^ 2 + 4 * t₁ ^ 2) + + A₂ / (2 * rho₂) * (1 + rho₂ ^ 2 + 4 * t₂ ^ 2) + sigma + + ((g₁ + g₂) * (g₁ * t₁ ^ 2 + g₂ * t₂ ^ 2) - g₁ * g₂ * c ^ 2) / + sigma - d₁ * t₁ - d₂ * t₂ + +/-- The largest of the three radial vertex values in the two-point tangent estimate. -/ +def pairTangentMaximum (c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma : ℝ) : ℝ := + max (pairTangentValue c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma 1 1) + (max (pairTangentValue c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma 1 (c - 1)) + (pairTangentValue c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma (c - 1) 1)) + +/-- Midpoint convexity bounds one cross distance by its two doubled-point distances. -/ +theorem two_mul_crossDistance_le {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] + (e p w : E) : + 2 * ‖e - p - w‖ ≤ ‖e - (2 : ℝ) • p‖ + ‖e - (2 : ℝ) • w‖ := by + calc + 2 * ‖e - p - w‖ = ‖(2 : ℝ) • (e - p - w)‖ := by + rw [norm_smul, Real.norm_ofNat] + _ = ‖(e - (2 : ℝ) • p) + (e - (2 : ℝ) • w)‖ := by + congr 1 + module + _ ≤ _ := norm_add_le _ _ + +/-- A nonnegative four-entry cross-distance sum splits into two colorwise sums. -/ +theorem weightedCrossDistances_le {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] + (e p₁ p₂ w₁ w₂ : E) (a₁₁ a₁₂ a₂₁ a₂₂ : ℝ) + (ha₁₁ : 0 ≤ a₁₁) (ha₁₂ : 0 ≤ a₁₂) (ha₂₁ : 0 ≤ a₂₁) + (ha₂₂ : 0 ≤ a₂₂) : + a₁₁ * ‖e - p₁ - w₁‖ + a₁₂ * ‖e - p₁ - w₂‖ + + a₂₁ * ‖e - p₂ - w₁‖ + a₂₂ * ‖e - p₂ - w₂‖ ≤ + (a₁₁ + a₁₂) / 2 * ‖e - (2 : ℝ) • p₁‖ + + (a₂₁ + a₂₂) / 2 * ‖e - (2 : ℝ) • p₂‖ + + (a₁₁ + a₂₁) / 2 * ‖e - (2 : ℝ) • w₁‖ + + (a₁₂ + a₂₂) / 2 * ‖e - (2 : ℝ) • w₂‖ := by + have h₁₁ := mul_le_mul_of_nonneg_left (two_mul_crossDistance_le e p₁ w₁) ha₁₁ + have h₁₂ := mul_le_mul_of_nonneg_left (two_mul_crossDistance_le e p₁ w₂) ha₁₂ + have h₂₁ := mul_le_mul_of_nonneg_left (two_mul_crossDistance_le e p₂ w₁) ha₂₁ + have h₂₂ := mul_le_mul_of_nonneg_left (two_mul_crossDistance_le e p₂ w₂) ha₂₂ + nlinarith + +private theorem norm_sub_two_smul_sq {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x : E) : + ‖e - (2 : ℝ) • x‖ ^ 2 = ‖e‖ ^ 2 + 4 * ‖x‖ ^ 2 - 4 * ⟪e, x⟫_ℝ := by + rw [norm_sub_sq_real] + simp only [norm_smul, Real.norm_ofNat, real_inner_smul_right] + ring + +/-- Rational two-point tangent estimate on two separated points of the unit ball. -/ +theorem twoPointTangent_le_vertices {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e x₁ x₂ : E) (c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma : ℝ) + (he : ‖e‖ = 1) (hx₁ : ‖x₁‖ ≤ 1) (hx₂ : ‖x₂‖ ≤ 1) + (hseparation : c ≤ ‖x₁ - x₂‖) (hc : 0 ≤ c) (hA₁ : 0 ≤ A₁) (hA₂ : 0 ≤ A₂) + (hrho₁ : 0 < rho₁) (hrho₂ : 0 < rho₂) (hsigma : 0 < sigma) : + A₁ * ‖e - (2 : ℝ) • x₁‖ + A₂ * ‖e - (2 : ℝ) • x₂‖ - + d₁ * ‖x₁‖ - d₂ * ‖x₂‖ ≤ + pairTangentMaximum c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma := by + let g₁ := A₁ / rho₁ + let g₂ := A₂ / rho₂ + let z := g₁ • x₁ + g₂ • x₂ + let Q := (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - + g₁ * g₂ * c ^ 2 + have hg₁ : 0 ≤ g₁ := div_nonneg hA₁ hrho₁.le + have hg₂ : 0 ≤ g₂ := div_nonneg hA₂ hrho₂.le + have hseparationSq : c ^ 2 ≤ ‖x₁ - x₂‖ ^ 2 := by + nlinarith [norm_nonneg (x₁ - x₂)] + have hzUpper : ‖z‖ ^ 2 ≤ Q := by + rw [show ‖z‖ ^ 2 = (g₁ + g₂) * (g₁ * ‖x₁‖ ^ 2 + g₂ * ‖x₂‖ ^ 2) - + g₁ * g₂ * ‖x₁ - x₂‖ ^ 2 by exact weighted_norm_sq x₁ x₂ hg₁ hg₂] + exact sub_le_sub_left + (mul_le_mul_of_nonneg_left hseparationSq (mul_nonneg hg₁ hg₂)) _ + have horientation : -2 * ⟪e, z⟫_ℝ ≤ sigma + Q / sigma := by + have hinner := real_inner_le_norm (-e) z + simp only [inner_neg_left, norm_neg, he, one_mul] at hinner + have hnorm : 2 * ‖z‖ ≤ sigma + ‖z‖ ^ 2 / sigma := + two_mul_norm_tangent z hsigma + have hscaled := (div_le_div_iff_of_pos_right hsigma).2 hzUpper + nlinarith + have htangent₁ := weighted_norm_tangent (e - (2 : ℝ) • x₁) A₁ rho₁ hrho₁ hA₁ + have htangent₂ := weighted_norm_tangent (e - (2 : ℝ) • x₂) A₂ rho₂ hrho₂ hA₂ + have hpointwise : + A₁ * ‖e - (2 : ℝ) • x₁‖ + A₂ * ‖e - (2 : ℝ) • x₂‖ - + d₁ * ‖x₁‖ - d₂ * ‖x₂‖ ≤ + pairTangentValue c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma ‖x₁‖ ‖x₂‖ := by + rw [norm_sub_two_smul_sq e x₁] at htangent₁ + rw [norm_sub_two_smul_sq e x₂] at htangent₂ + simp only [he, one_pow] at htangent₁ htangent₂ + dsimp only [z, Q, g₁, g₂] at horientation + simp only [inner_add_right, real_inner_smul_right] at horientation + dsimp only [pairTangentValue, g₁, g₂] + ring_nf at htangent₁ htangent₂ horientation ⊢ + nlinarith + have hsum : c ≤ ‖x₁‖ + ‖x₂‖ := + hseparation.trans (norm_sub_le x₁ x₂) + let a₁ := 2 * A₁ / rho₁ + (g₁ + g₂) * g₁ / sigma + let a₂ := 2 * A₂ / rho₂ + (g₁ + g₂) * g₂ / sigma + let b₁ := -d₁ + let b₂ := -d₂ + let literal := A₁ / (2 * rho₁) * (1 + rho₁ ^ 2) + + A₂ / (2 * rho₂) * (1 + rho₂ ^ 2) + sigma - g₁ * g₂ * c ^ 2 / sigma + have ha₁ : 0 ≤ a₁ := by positivity + have ha₂ : 0 ≤ a₂ := by positivity + have hvertices := separableQuadratic_le_radial_vertices ha₁ ha₂ hx₁ hx₂ hsum + (b₁ := b₁) (b₂ := b₂) (d := literal) + apply hpointwise.trans + unfold pairTangentMaximum + let value := fun t₁ t₂ ↦ + a₁ * t₁ ^ 2 + b₁ * t₁ + a₂ * t₂ ^ 2 + b₂ * t₂ + literal + have hvalue (t₁ t₂ : ℝ) : + pairTangentValue c A₁ A₂ d₁ d₂ rho₁ rho₂ sigma t₁ t₂ = value t₁ t₂ := by + dsimp only [pairTangentValue, value, a₁, a₂, b₁, b₂, literal, g₁, g₂] + field_simp [hrho₁.ne', hrho₂.ne', hsigma.ne'] + ring + rw [hvalue ‖x₁‖ ‖x₂‖, hvalue 1 1, hvalue 1 (c - 1), hvalue (c - 1) 1] + simpa only [value, one_pow, mul_one] using hvertices + +local macro "verify_pair_tangent_maximum" : tactic => `(tactic| + (simp only [pairTangentMaximum, max_le_iff] + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + constructor + · norm_num [pairTangentValue] + nlinarith [sq_nonneg (barC - 1)] + constructor + · norm_num [pairTangentValue] + nlinarith [sq_nonneg (barC - 1)] + · norm_num [pairTangentValue] + nlinarith [sq_nonneg (barC - 1)])) + +private theorem tangentMaximum_e0s1_red : + pairTangentMaximum barC (29 / 4) (15 / 4) (13 * barC / 2) (13 * barC / 2) + (2903 / 1000) (2104 / 1000) (2599 / 1000) ≤ 1687 / 125 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e0s1_blue : + pairTangentMaximum barC (29 / 4) (15 / 4) (7 * (barC - 1) / 2) + (7 * (barC + 1) / 2) (2910 / 1000) (2220 / 1000) (2669 / 1000) ≤ + 21643 / 1000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e0s2_red : + pairTangentMaximum barC (9 / 4) (5 / 4) (3 * barC / 2) (3 * barC / 2) + (2904 / 1000) (2675 / 1000) (920 / 1000) ≤ 229 / 40 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e0s2_blue : + pairTangentMaximum barC (9 / 4) (5 / 4) (barC - 1) (barC + 1) + (2901 / 1000) (2495 / 1000) (890 / 1000) ≤ 1781 / 250 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e0s3_red : + pairTangentMaximum barC 23 (59 / 2) (27 * (barC + 1)) (27 * (barC - 1)) + (1999 / 1000) (2813 / 1000) (10791 / 1000) ≤ 7871 / 100 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e0s3_blue : + pairTangentMaximum barC (73 / 2) 16 (41 * (barC - 1) / 2) + (41 * (barC + 1) / 2) (2908 / 1000) (1739 / 1000) (11850 / 1000) ≤ + 19511 / 200 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s1_red : + pairTangentMaximum barC 7 (7 / 2) (6 * barC) (6 * barC) + (2903 / 1000) (2116 / 1000) (2499 / 1000) ≤ 13433 / 1000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s1_blue : + pairTangentMaximum barC (7 / 2) 7 (7 * (barC + 1) / 2) + (7 * (barC - 1) / 2) (2102 / 1000) (2896 / 1000) (2524 / 1000) ≤ + 2547 / 125 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s3_red : + pairTangentMaximum barC 7 (19 / 2) (8 * (barC + 1)) (8 * (barC - 1)) + (2024 / 1000) (2832 / 1000) (3439 / 1000) ≤ 12917 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s3_blue : + pairTangentMaximum barC (11 / 2) 11 (11 * (barC + 1) / 2) + (11 * (barC - 1) / 2) (2113 / 1000) (2915 / 1000) (3895 / 1000) ≤ + 16009 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s1s1_red : + pairTangentMaximum barC (13 / 2) (13 / 2) (6 * barC) (6 * barC) + (2807 / 1000) (2808 / 1000) (3337 / 1000) ≤ 993 / 50 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s1s1_blue : + pairTangentMaximum barC (13 / 2) (13 / 2) (6 * barC) (6 * barC) + (2808 / 1000) (2806 / 1000) (3338 / 1000) ≤ 993 / 50 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s2s2_red : + pairTangentMaximum barC (9 / 2) (9 / 2) (4 * barC) (4 * barC) + (2807 / 1000) (2808 / 1000) (2310 / 1000) ≤ 1772 / 125 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s2s2_blue : + pairTangentMaximum barC (9 / 2) (9 / 2) (4 * barC) (4 * barC) + (2808 / 1000) (2808 / 1000) (2310 / 1000) ≤ 1772 / 125 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s2_red : + pairTangentMaximum barC (13 / 4) (7 / 4) (7 * barC / 2) (7 * barC / 2) + (2889 / 1000) (1919 / 1000) (1109 / 1000) ≤ 4833 / 1000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_e1s2_blue : + pairTangentMaximum barC (7 / 4) (13 / 4) (3 * (barC + 1) / 2) + (3 * (barC - 1) / 2) (2373 / 1000) (2901 / 1000) (1238 / 1000) ≤ + 5009 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s0s1_red : + pairTangentMaximum barC (7 / 4) (7 / 4) (5 * barC / 2) (5 * barC / 2) + (2580 / 1000) (2580 / 1000) (804 / 1000) ≤ 2967 / 1000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s0s1_blue : + pairTangentMaximum barC (9 / 4) (5 / 4) (barC - 1) (barC + 1) + (2902 / 1000) (2491 / 1000) (893 / 1000) ≤ 1781 / 250 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s0s2_red : + pairTangentMaximum barC (7 / 4) (7 / 4) (5 * barC / 2) (5 * barC / 2) + (2584 / 1000) (2584 / 1000) (801 / 1000) ≤ 1483 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s0s2_blue : + pairTangentMaximum barC (9 / 4) (5 / 4) (barC - 1) (barC + 1) + (2897 / 1000) (2493 / 1000) (892 / 1000) ≤ 1781 / 250 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s1s2_red : + pairTangentMaximum barC (7 / 4) (7 / 4) (5 * barC / 2) (5 * barC / 2) + (2583 / 1000) (2583 / 1000) (802 / 1000) ≤ 1483 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_s1s2_blue : + pairTangentMaximum barC (7 / 4) (7 / 4) barC barC + (2804 / 1000) (2808 / 1000) (897 / 1000) ≤ 3527 / 500 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_adjacentFirst_red : + pairTangentMaximum barC (9 / 4) (1 / 2) (7 * (barC - 1) / 8) + (7 * (barC + 1) / 8) (49 / 16) (5 / 4) (13 / 20) ≤ 742013 / 125000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_adjacentFirst_blue : + pairTangentMaximum barC (11 / 8) (11 / 8) (7 * (barC - 1) / 8) + (7 * (barC + 1) / 8) (351 / 125) (351 / 125) (353 / 500) ≤ + 2647153 / 500000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_adjacentSecond_red : + pairTangentMaximum barC (11 / 8) (11 / 8) (7 * (barC + 1) / 8) + (7 * (barC - 1) / 8) (2808 / 1000) (2808 / 1000) (706 / 1000) ≤ + 2647153 / 500000 := by + verify_pair_tangent_maximum + +private theorem tangentMaximum_adjacentSecond_blue : + pairTangentMaximum barC (9 / 4) (1 / 2) (7 * (barC - 1) / 8) + (7 * (barC + 1) / 8) (2973 / 1000) (1247 / 1000) (660 / 1000) ≤ + 237273 / 40000 := by + verify_pair_tangent_maximum + +/-- The rational tangent separator for the `E0/S1` incidence representative. -/ +theorem tangentCertificate_e0s1 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 29 / 2 * ‖e - p₁ - w₁‖ + 15 / 2 * ‖e - p₂ - w₂‖ - + 13 * barC / 2 * ‖p₁‖ - 13 * barC / 2 * ‖p₂‖ - + 7 * (barC - 1) / 2 * ‖w₁‖ - 7 * (barC + 1) / 2 * ‖w₂‖ - 7 + + 51 / 2 * barC - 34 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ (29 / 2) 0 0 (15 / 2) + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (29 / 4) (15 / 4) + (13 * barC / 2) (13 * barC / 2) (2903 / 1000) (2104 / 1000) (2599 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (29 / 4) (15 / 4) + (7 * (barC - 1) / 2) (7 * (barC + 1) / 2) (2910 / 1000) (2220 / 1000) + (2669 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) + (by norm_num) (by norm_num) + have hconstant : 1687 / 125 + 21643 / 1000 - 7 + 51 / 2 * barC - + 34 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e0s1_red, tangentMaximum_e0s1_blue] + +/-- The rational tangent separator for the `E0/S2` incidence representative. -/ +theorem tangentCertificate_e0s2 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 3 * ‖e - p₁ - w₁‖ + 3 / 2 * ‖e - p₁ - w₂‖ + + 3 / 2 * ‖e - p₂ - w₁‖ + ‖e - p₂ - w₂‖ - + 3 * barC / 2 * ‖p₁‖ - 3 * barC / 2 * ‖p₂‖ - + (barC - 1) * ‖w₁‖ - (barC + 1) * ‖w₂‖ - 2 + 8 * barC - + 23 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 3 (3 / 2) (3 / 2) 1 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (9 / 4) (5 / 4) + (3 * barC / 2) (3 * barC / 2) (2904 / 1000) (2675 / 1000) (920 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (9 / 4) (5 / 4) + (barC - 1) (barC + 1) (2901 / 1000) (2495 / 1000) (890 / 1000) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hconstant : 229 / 40 + 1781 / 250 - 2 + 8 * barC - + 23 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e0s2_red, tangentMaximum_e0s2_blue] + +/-- The rational tangent separator for the `E0/S3` incidence representative. -/ +theorem tangentCertificate_e0s3 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 46 * ‖e - p₁ - w₁‖ + 27 * ‖e - p₂ - w₁‖ + 32 * ‖e - p₂ - w₂‖ - + 27 * (barC + 1) * ‖p₁‖ - 27 * (barC - 1) * ‖p₂‖ - + 41 * (barC - 1) / 2 * ‖w₁‖ - 41 * (barC + 1) / 2 * ‖w₂‖ - 41 + + 251 / 2 * barC - 325 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 46 0 27 32 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC 23 (59 / 2) + (27 * (barC + 1)) (27 * (barC - 1)) (1999 / 1000) (2813 / 1000) + (10791 / 1000) he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (73 / 2) 16 + (41 * (barC - 1) / 2) (41 * (barC + 1) / 2) (2908 / 1000) (1739 / 1000) + (11850 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 7871 / 100 + 19511 / 200 - 41 + 251 / 2 * barC - + 325 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e0s3_red, tangentMaximum_e0s3_blue] + +/-- The rational tangent separator for the `E1/S1` incidence representative. -/ +theorem tangentCertificate_e1s1 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 7 * ‖e - p₁ - w₁‖ + 7 * ‖e - p₁ - w₂‖ + 7 * ‖e - p₂ - w₂‖ - + 6 * barC * ‖p₁‖ - 6 * barC * ‖p₂‖ - + 7 * (barC + 1) / 2 * ‖w₁‖ - 7 * (barC - 1) / 2 * ‖w₂‖ - 7 + + 49 / 2 * barC - 65 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 7 7 0 7 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC 7 (7 / 2) (6 * barC) + (6 * barC) (2903 / 1000) (2116 / 1000) (2499 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (7 / 2) 7 + (7 * (barC + 1) / 2) (7 * (barC - 1) / 2) (2102 / 1000) (2896 / 1000) + (2524 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 13433 / 1000 + 2547 / 125 - 7 + 49 / 2 * barC - + 65 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e1s1_red, tangentMaximum_e1s1_blue] + +/-- The rational tangent separator for the `E1/S3` incidence representative. -/ +theorem tangentCertificate_e1s3 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 3 * ‖e - p₁ - w₁‖ + 11 * ‖e - p₁ - w₂‖ + + 8 * ‖e - p₂ - w₁‖ + 11 * ‖e - p₂ - w₂‖ - + 8 * (barC + 1) * ‖p₁‖ - 8 * (barC - 1) * ‖p₂‖ - + 11 * (barC + 1) / 2 * ‖w₁‖ - 11 * (barC - 1) / 2 * ‖w₂‖ - 11 + + 77 / 2 * barC - 105 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 3 11 8 11 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC 7 (19 / 2) + (8 * (barC + 1)) (8 * (barC - 1)) (2024 / 1000) (2832 / 1000) + (3439 / 1000) he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (11 / 2) 11 + (11 * (barC + 1) / 2) (11 * (barC - 1) / 2) (2113 / 1000) (2915 / 1000) + (3895 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 12917 / 500 + 16009 / 500 - 11 + 77 / 2 * barC - + 105 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e1s3_red, tangentMaximum_e1s3_blue] + +/-- The rational tangent separator for the `S1/S1` incidence representative. -/ +theorem tangentCertificate_s1s1 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 13 * ‖e - p₁ - w₁‖ + 13 * ‖e - p₂ - w₂‖ - + 6 * barC * ‖p₁‖ - 6 * barC * ‖p₂‖ - + 6 * barC * ‖w₁‖ - 6 * barC * ‖w₂‖ + 26 * barC - 40 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 13 0 0 13 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (13 / 2) (13 / 2) + (6 * barC) (6 * barC) (2807 / 1000) (2808 / 1000) (3337 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (13 / 2) (13 / 2) + (6 * barC) (6 * barC) (2808 / 1000) (2806 / 1000) (3338 / 1000) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hconstant : 993 / 50 + 993 / 50 + 26 * barC - 40 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_s1s1_red, tangentMaximum_s1s1_blue] + +/-- The rational tangent separator for the `S2/S2` incidence representative. -/ +theorem tangentCertificate_s2s2 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + ‖e - p₁ - w₁‖ + 8 * ‖e - p₁ - w₂‖ + + 8 * ‖e - p₂ - w₁‖ + ‖e - p₂ - w₂‖ - + 4 * barC * ‖p₁‖ - 4 * barC * ‖p₂‖ - + 4 * barC * ‖w₁‖ - 4 * barC * ‖w₂‖ + 18 * barC - 28 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 1 8 8 1 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (9 / 2) (9 / 2) + (4 * barC) (4 * barC) (2807 / 1000) (2808 / 1000) (2310 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (9 / 2) (9 / 2) + (4 * barC) (4 * barC) (2808 / 1000) (2808 / 1000) (2310 / 1000) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hconstant : 1772 / 125 + 1772 / 125 + 18 * barC - 28 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_s2s2_red, tangentMaximum_s2s2_blue] + +/-- The rational tangent separator for the `E1/S2` incidence representative. -/ +theorem tangentCertificate_e1s2 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 13 / 2 * ‖e - p₁ - w₂‖ + 7 / 2 * ‖e - p₂ - w₁‖ - + 7 * barC / 2 * ‖p₁‖ - 7 * barC / 2 * ‖p₂‖ - + 3 * (barC + 1) / 2 * ‖w₁‖ - 3 * (barC - 1) / 2 * ‖w₂‖ - 3 + + 23 / 2 * barC - 15 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 0 (13 / 2) (7 / 2) 0 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (13 / 4) (7 / 4) + (7 * barC / 2) (7 * barC / 2) (2889 / 1000) (1919 / 1000) (1109 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (7 / 4) (13 / 4) + (3 * (barC + 1) / 2) (3 * (barC - 1) / 2) (2373 / 1000) (2901 / 1000) + (1238 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 4833 / 1000 + 5009 / 500 - 3 + 23 / 2 * barC - + 15 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_e1s2_red, tangentMaximum_e1s2_blue] + +/-- The rational tangent separator for the `S0/S1` incidence representative. -/ +theorem tangentCertificate_s0s1 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 7 / 2 * ‖e - p₁ - w₁‖ + ‖e - p₂ - w₁‖ + + 5 / 2 * ‖e - p₂ - w₂‖ - 5 * barC / 2 * ‖p₁‖ - + 5 * barC / 2 * ‖p₂‖ - (barC - 1) * ‖w₁‖ - + (barC + 1) * ‖w₂‖ + 7 * barC - 21 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ (7 / 2) 0 1 (5 / 2) + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (7 / 4) (7 / 4) + (5 * barC / 2) (5 * barC / 2) (2580 / 1000) (2580 / 1000) (804 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (9 / 4) (5 / 4) + (barC - 1) (barC + 1) (2902 / 1000) (2491 / 1000) (893 / 1000) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hconstant : 2967 / 1000 + 1781 / 250 + 7 * barC - + 21 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_s0s1_red, tangentMaximum_s0s1_blue] + +/-- The rational tangent separator for the `S0/S2` incidence representative. -/ +theorem tangentCertificate_s0s2 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + ‖e - p₁ - w₁‖ + 5 / 2 * ‖e - p₁ - w₂‖ + + 7 / 2 * ‖e - p₂ - w₁‖ - 5 * barC / 2 * ‖p₁‖ - + 5 * barC / 2 * ‖p₂‖ - (barC - 1) * ‖w₁‖ - + (barC + 1) * ‖w₂‖ + 7 * barC - 21 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 1 (5 / 2) (7 / 2) 0 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (7 / 4) (7 / 4) + (5 * barC / 2) (5 * barC / 2) (2584 / 1000) (2584 / 1000) (801 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (9 / 4) (5 / 4) + (barC - 1) (barC + 1) (2897 / 1000) (2493 / 1000) (892 / 1000) + he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hconstant : 1483 / 500 + 1781 / 250 + 7 * barC - + 21 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_s0s2_red, tangentMaximum_s0s2_blue] + +/-- The rational tangent separator for the `S1/S2` incidence representative. -/ +theorem tangentCertificate_s1s2 {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + ‖e - p₁ - w₁‖ + 5 / 2 * ‖e - p₁ - w₂‖ + + 5 / 2 * ‖e - p₂ - w₁‖ + ‖e - p₂ - w₂‖ - + 5 * barC / 2 * ‖p₁‖ - 5 * barC / 2 * ‖p₂‖ - + barC * ‖w₁‖ - barC * ‖w₂‖ + 7 * barC - 21 / 2 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ 1 (5 / 2) (5 / 2) 1 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (7 / 4) (7 / 4) + (5 * barC / 2) (5 * barC / 2) (2583 / 1000) (2583 / 1000) (802 / 1000) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (7 / 4) (7 / 4) barC barC + (2804 / 1000) (2808 / 1000) (897 / 1000) he hw₁ hw₂ hwsep barC_pos.le + (by norm_num) (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hconstant : 1483 / 500 + 3527 / 500 + 7 * barC - + 21 / 2 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_s1s2_red, tangentMaximum_s1s2_blue] + +/-- The rational tangent separator for the first adjacent endpoint orbit. -/ +theorem tangentCertificate_adjacentFirst {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 11 / 4 * ‖e - p₁ - w₁‖ + 7 / 4 * ‖e - p₁ - w₂‖ + + ‖e - p₂ - w₂‖ - 7 * (barC - 1) / 8 * ‖p₁‖ - + 7 * (barC + 1) / 8 * ‖p₂‖ - 7 * (barC - 1) / 8 * ‖w₁‖ - + 7 * (barC + 1) / 8 * ‖w₂‖ - 7 / 2 + 29 / 4 * barC - + 37 / 4 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ (11 / 4) (7 / 4) 0 1 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (9 / 4) (1 / 2) + (7 * (barC - 1) / 8) (7 * (barC + 1) / 8) (49 / 16) (5 / 4) (13 / 20) + he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) (by norm_num) (by norm_num) + (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (11 / 8) (11 / 8) + (7 * (barC - 1) / 8) (7 * (barC + 1) / 8) (351 / 125) (351 / 125) + (353 / 500) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 742013 / 125000 + 2647153 / 500000 - 7 / 2 + + 29 / 4 * barC - 37 / 4 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_adjacentFirst_red, tangentMaximum_adjacentFirst_blue] + +/-- The rational tangent separator for the second adjacent endpoint orbit. -/ +theorem tangentCertificate_adjacentSecond {E : Type*} [NormedAddCommGroup E] + [InnerProductSpace ℝ E] (e p₁ p₂ w₁ w₂ : E) (he : ‖e‖ = 1) + (hp₁ : ‖p₁‖ ≤ 1) (hp₂ : ‖p₂‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hw₂ : ‖w₂‖ ≤ 1) + (hpsep : barC ≤ ‖p₁ - p₂‖) (hwsep : barC ≤ ‖w₁ - w₂‖) : + 11 / 4 * ‖e - p₁ - w₁‖ + 7 / 4 * ‖e - p₂ - w₁‖ + + ‖e - p₂ - w₂‖ - 7 * (barC + 1) / 8 * ‖p₁‖ - + 7 * (barC - 1) / 8 * ‖p₂‖ - 7 * (barC - 1) / 8 * ‖w₁‖ - + 7 * (barC + 1) / 8 * ‖w₂‖ - 7 / 2 + 29 / 4 * barC - + 37 / 4 * barC ^ 2 < 0 := by + have hmid := weightedCrossDistances_le e p₁ p₂ w₁ w₂ (11 / 4) 0 (7 / 4) 1 + (by norm_num) (by norm_num) (by norm_num) (by norm_num) + have hp := twoPointTangent_le_vertices e p₁ p₂ barC (11 / 8) (11 / 8) + (7 * (barC + 1) / 8) (7 * (barC - 1) / 8) (2808 / 1000) (2808 / 1000) + (706 / 1000) he hp₁ hp₂ hpsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hw := twoPointTangent_le_vertices e w₁ w₂ barC (9 / 4) (1 / 2) + (7 * (barC - 1) / 8) (7 * (barC + 1) / 8) (2973 / 1000) (1247 / 1000) + (660 / 1000) he hw₁ hw₂ hwsep barC_pos.le (by norm_num) (by norm_num) + (by norm_num) (by norm_num) (by norm_num) + have hconstant : 2647153 / 500000 + 237273 / 40000 - 7 / 2 + + 29 / 4 * barC - 37 / 4 * barC ^ 2 < 0 := by + rcases barC_mem_isolation_box with ⟨hlower, hupper⟩ + norm_num at hlower hupper ⊢ + nlinarith [sq_nonneg (barC - 1)] + nlinarith [tangentMaximum_adjacentSecond_red, tangentMaximum_adjacentSecond_blue] + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/SiblingTriangle.lean b/LeanPool/Besicovitch/SixPoint/SiblingTriangle.lean new file mode 100644 index 0000000000..71b63b863f --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/SiblingTriangle.lean @@ -0,0 +1,690 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.CanonicalTriangle +public import LeanPool.Besicovitch.SixPoint.Packing + +/-! +# Sibling-pair versus rooted-triangle packings + +This file constructs supports `67` and `76` and proves their one-dimensional routing algebra. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The canonical triangle's total radius is its semiperimeter. -/ +theorem canonicalTriangleRadius_sum {X : Type*} [PseudoMetricSpace X] + (root left right : X) : + canonicalTriangleRadius root left right .root + + canonicalTriangleRadius root left right .left + + canonicalTriangleRadius root left right .right = + (dist root left + dist root right + dist left right) / 2 := by + simp only [canonicalTriangleRadius] + ring + +/-- Support `67`: the red sibling pair against the canonical blue triangle. -/ +def redSiblingBlueTrianglePacking (configuration : SixPointConfiguration) {L x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + SixPointPacking configuration where + support := {(.red, .left), (.red, .right), (.blue, .root), (.blue, .left), + (.blue, .right)} + meets_color color := by + cases color + · exact ⟨.left, by simp⟩ + · exact ⟨.root, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color <;> cases label + · simp at hlabel + · exact ⟨x, by nlinarith, hx_upper⟩ + · exact ⟨L - x, by nlinarith, by nlinarith⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hblueLeft hblueRight .right⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li + · simp at hi + · cases lj + · simp at hj + · exact (hij (Subtype.ext rfl)).elim + · dsimp + nlinarith + · cases lj + · simp at hj + · dsimp + rw [dist_comm, hLdist] + nlinarith + · exact (hij (Subtype.ext rfl)).elim + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + +/-- The left red radius in support `67` is the split variable. -/ +@[simp] theorem redSiblingBlueTrianglePacking_radius_left + (configuration : SixPointConfiguration) {L x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (hmem : (.red, .left) ∈ (redSiblingBlueTrianglePacking configuration hLdist hL + hx_lower hx_upper hblueLeft hblueRight).support) : + ((redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper hblueLeft + hblueRight).radius ⟨(.red, .left), hmem⟩ : ℝ) = x := by + rfl + +/-- The right red radius in support `67` is the complementary split. -/ +@[simp] theorem redSiblingBlueTrianglePacking_radius_right + (configuration : SixPointConfiguration) {L x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (hmem : (.red, .right) ∈ (redSiblingBlueTrianglePacking configuration hLdist hL + hx_lower hx_upper hblueLeft hblueRight).support) : + ((redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper hblueLeft + hblueRight).radius ⟨(.red, .right), hmem⟩ : ℝ) = L - x := by + rfl + +/-- Blue radii in support `67` are the canonical triangle radii. -/ +@[simp] theorem redSiblingBlueTrianglePacking_radius_blue + (configuration : SixPointConfiguration) {L x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) + (label : SixPointLabel) + (hmem : (.blue, label) ∈ (redSiblingBlueTrianglePacking configuration hLdist hL + hx_lower hx_upper hblueLeft hblueRight).support) : + ((redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper hblueLeft + hblueRight).radius ⟨(.blue, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label := by + cases label <;> rfl + +/-- The total radius of support `67` is the sibling length plus blue semiperimeter. -/ +theorem redSiblingBlueTrianglePacking_totalRadius + (configuration : SixPointConfiguration) {L x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hL : 1 ≤ L) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + (redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper hblueLeft + hblueRight).totalRadius = L + + (dist (configuration .blue .root) (configuration .blue .left) + + dist (configuration .blue .root) (configuration .blue .right) + + dist (configuration .blue .left) (configuration .blue .right)) / 2 := by + let packing := redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper + hblueLeft hblueRight + let value : SixPointIndex → ℝ + | (.red, .root) => 0 + | (.red, .left) => x + | (.red, .right) => L - x + | (.blue, label) => canonicalTriangleRadius (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right) label + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [redSiblingBlueTrianglePacking, value] at hi ⊢ + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + simp [packing, redSiblingBlueTrianglePacking, value, canonicalTriangleRadius] + ring + +/-- Support `76`: the blue sibling pair against the canonical red triangle. -/ +def blueSiblingRedTrianglePacking (configuration : SixPointConfiguration) {M y : ℝ} + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + SixPointPacking configuration where + support := {(.red, .root), (.red, .left), (.red, .right), (.blue, .left), + (.blue, .right)} + meets_color color := by + cases color + · exact ⟨.root, by simp⟩ + · exact ⟨.left, by simp⟩ + radius i := by + rcases i with ⟨⟨color, label⟩, hlabel⟩ + cases color <;> cases label + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .root, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .root⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .left, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .left⟩ + · exact ⟨_, canonicalTriangleRadius_nonneg _ _ _ .right, + canonicalTriangleRadius_le_one _ _ _ hredLeft hredRight .right⟩ + · simp at hlabel + · exact ⟨y, by nlinarith, hy_upper⟩ + · exact ⟨M - y, by nlinarith, by nlinarith⟩ + same_color_disjoint i j hij hcolor := by + rcases i with ⟨⟨ci, li⟩, hi⟩ + rcases j with ⟨⟨cj, lj⟩, hj⟩ + simp only at hcolor + subst cj + cases ci + · cases li <;> cases lj + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_left _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · exact (canonicalTriangleRadius_left_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_root_add_right _ _ _).le + · rw [add_comm, dist_comm] + exact (canonicalTriangleRadius_left_add_right _ _ _).le + · exact (hij (Subtype.ext rfl)).elim + · cases li + · simp at hi + · cases lj + · simp at hj + · exact (hij (Subtype.ext rfl)).elim + · dsimp + nlinarith + · cases lj + · simp at hj + · dsimp + rw [dist_comm, hMdist] + nlinarith + · exact (hij (Subtype.ext rfl)).elim + +/-- The total radius of support `76` is the sibling length plus red semiperimeter. -/ +theorem blueSiblingRedTrianglePacking_totalRadius + (configuration : SixPointConfiguration) {M y : ℝ} + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + (blueSiblingRedTrianglePacking configuration hMdist hM hy_lower hy_upper hredLeft + hredRight).totalRadius = M + + (dist (configuration .red .root) (configuration .red .left) + + dist (configuration .red .root) (configuration .red .right) + + dist (configuration .red .left) (configuration .red .right)) / 2 := by + let packing := blueSiblingRedTrianglePacking configuration hMdist hM hy_lower hy_upper + hredLeft hredRight + let value : SixPointIndex → ℝ + | (.red, label) => canonicalTriangleRadius (configuration .red .root) + (configuration .red .left) (configuration .red .right) label + | (.blue, .root) => 0 + | (.blue, .left) => y + | (.blue, .right) => M - y + rw [SixPointPacking.totalRadius] + calc + _ = ∑ i ∈ packing.support.attach, value i := by + apply Finset.sum_congr rfl + rintro ⟨⟨color, label⟩, hi⟩ - + cases color <;> cases label <;> + simp [blueSiblingRedTrianglePacking, value] at hi ⊢ + _ = ∑ i ∈ packing.support, value i := Finset.sum_attach _ _ + _ = _ := by + simp [packing, blueSiblingRedTrianglePacking, value, canonicalTriangleRadius] + ring + +/-- Cross reach from a red point to a blue point carrying its canonical radius. -/ +def redSiblingBlueTriangleReach (configuration : SixPointConfiguration) + (redLabel blueLabel : SixPointLabel) : ℝ := + dist (configuration .red redLabel) (configuration .blue blueLabel) + + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) blueLabel + +/-- Cross reach from a blue point to a red point carrying its canonical radius. -/ +def blueSiblingRedTriangleReach (configuration : SixPointConfiguration) + (blueLabel redLabel : SixPointLabel) : ℝ := + dist (configuration .blue blueLabel) (configuration .red redLabel) + + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) redLabel + +/-- The largest of three labelled real values. -/ +def triangleMaximum (value : SixPointLabel → ℝ) : ℝ := + max (value .root) (max (value .left) (value .right)) + +/-- Every labelled value is bounded by its triangle maximum. -/ +theorem le_triangleMaximum (value : SixPointLabel → ℝ) (label : SixPointLabel) : + value label ≤ triangleMaximum value := by + cases label <;> simp [triangleMaximum] + +/-- A triangle maximum is attained at one of its three labels. -/ +theorem exists_triangleMaximum_eq (value : SixPointLabel → ℝ) : + ∃ label, triangleMaximum value = value label := by + rcases max_choice (value .root) (max (value .left) (value .right)) with h | h + · exact ⟨.root, h⟩ + · rcases max_choice (value .left) (value .right) with h' | h' + · exact ⟨.left, h.trans h'⟩ + · exact ⟨.right, h.trans h'⟩ + +/-- Diameter of a sibling split against a tangent triangle with fixed cross reaches. -/ +def siblingTriangleSplitDiameter (L M x : ℝ) + (leftReach rightReach : SixPointLabel → ℝ) : ℝ := + max (2 * L) <| max (2 * M) <| + max (x + triangleMaximum leftReach) (L - x + triangleMaximum rightReach) + +private theorem sameColorPair_le_twice_bound {configuration : SixPointConfiguration} + (packing : SixPointPacking configuration) (i j : packing.support) (hcolor : i.1.1 = j.1.1) + {bound : ℝ} (hbound : 1 ≤ bound) + (hdist : dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) ≤ bound) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ 2 * bound := by + by_cases hij : i = j + · subst j + simp only [dist_self, zero_add] + nlinarith [(packing.radius i).property.2] + · nlinarith [packing.same_color_disjoint i j hij hcolor] + +/-- The virtual diameter of support `67` is its explicit one-dimensional diameter. -/ +theorem redSiblingBlueTrianglePacking_virtualDiameter + (configuration : SixPointConfiguration) {L M x : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hM : 1 ≤ M) (hx_lower : L - 1 ≤ x) (hx_upper : x ≤ 1) + (hblueLeft : dist (configuration .blue .root) (configuration .blue .left) ≤ 1) + (hblueRight : dist (configuration .blue .root) (configuration .blue .right) ≤ 1) : + (redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper hblueLeft + hblueRight).virtualDiameter = + siblingTriangleSplitDiameter L M x + (redSiblingBlueTriangleReach configuration .left) + (redSiblingBlueTriangleReach configuration .right) := by + let packing := redSiblingBlueTrianglePacking configuration hLdist hL hx_lower hx_upper + hblueLeft hblueRight + let target := siblingTriangleSplitDiameter L M x + (redSiblingBlueTriangleReach configuration .left) + (redSiblingBlueTriangleReach configuration .right) + have hredDist (leftLabel rightLabel : SixPointLabel) + (hleft : (.red, leftLabel) ∈ packing.support) + (hright : (.red, rightLabel) ∈ packing.support) : + dist (configuration .red leftLabel) (configuration .red rightLabel) ≤ L := by + cases leftLabel <;> cases rightLabel + all_goals simp [packing, redSiblingBlueTrianglePacking] at hleft hright + · simp + linarith + · rw [hLdist] + · rw [dist_comm, hLdist] + · simp + linarith + have hblueDist (leftLabel rightLabel : SixPointLabel) : + dist (configuration .blue leftLabel) (configuration .blue rightLabel) ≤ M := by + cases leftLabel <;> cases rightLabel + · simp + linarith + · exact hblueLeft.trans hM + · exact hblueRight.trans hM + · simpa [dist_comm] using hblueLeft.trans hM + · simp + linarith + · rw [hMdist] + · simpa [dist_comm] using hblueRight.trans hM + · rw [dist_comm, hMdist] + · simp + linarith + have htwoL : 2 * L ≤ target := by + exact le_max_left _ _ + have htwoM : 2 * M ≤ target := by + exact le_max_of_le_right (le_max_left _ _) + have hcrossLeft : + x + triangleMaximum (redSiblingBlueTriangleReach configuration .left) ≤ target := by + exact le_max_of_le_right (le_max_of_le_right (le_max_left _ _)) + have hcrossRight : + L - x + triangleMaximum (redSiblingBlueTriangleReach configuration .right) ≤ target := by + exact le_max_of_le_right (le_max_of_le_right (le_max_right _ _)) + have hredLeftRadius (hmem : (.red, .left) ∈ packing.support) : + (packing.radius ⟨(.red, .left), hmem⟩ : ℝ) = x := by + rfl + have hredRightRadius (hmem : (.red, .right) ∈ packing.support) : + (packing.radius ⟨(.red, .right), hmem⟩ : ℝ) = L - x := by + rfl + have hblueRadius (label : SixPointLabel) (hmem : (.blue, label) ∈ packing.support) : + (packing.radius ⟨(.blue, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .blue .root) (configuration .blue .left) + (configuration .blue .right) label := by + cases label <;> rfl + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · exact (sameColorPair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hL + (hredDist leftLabel rightLabel hleft hright)).trans htwoL + · cases leftLabel + · simp [packing, redSiblingBlueTrianglePacking] at hleft + · rw [hredLeftRadius hleft, hblueRadius rightLabel hright] + have hreach := le_triangleMaximum + (redSiblingBlueTriangleReach configuration .left) rightLabel + simp only [redSiblingBlueTriangleReach] at hreach + nlinarith + · rw [hredRightRadius hleft, hblueRadius rightLabel hright] + have hreach := le_triangleMaximum + (redSiblingBlueTriangleReach configuration .right) rightLabel + simp only [redSiblingBlueTriangleReach] at hreach + nlinarith + · cases rightLabel + · simp [packing, redSiblingBlueTrianglePacking] at hright + · rw [hblueRadius leftLabel hleft, hredLeftRadius hright, dist_comm] + have hreach := le_triangleMaximum + (redSiblingBlueTriangleReach configuration .left) leftLabel + simp only [redSiblingBlueTriangleReach] at hreach + nlinarith + · rw [hblueRadius leftLabel hleft, hredRightRadius hright, dist_comm] + have hreach := le_triangleMaximum + (redSiblingBlueTriangleReach configuration .right) leftLabel + simp only [redSiblingBlueTriangleReach] at hreach + nlinarith + · exact (sameColorPair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hM + (hblueDist leftLabel rightLabel)).trans htwoM + apply le_antisymm + · unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + · let redLeft : packing.support := ⟨(.red, .left), by + simp [packing, redSiblingBlueTrianglePacking]⟩ + let redRight : packing.support := ⟨(.red, .right), by + simp [packing, redSiblingBlueTrianglePacking]⟩ + let blueLeft : packing.support := ⟨(.blue, .left), by + simp [packing, redSiblingBlueTrianglePacking]⟩ + let blueRight : packing.support := ⟨(.blue, .right), by + simp [packing, redSiblingBlueTrianglePacking]⟩ + have hdiameterL : 2 * L ≤ packing.virtualDiameter := by + have hpairL := packing.pair_le_virtualDiameter redLeft redRight + rw [hredLeftRadius redLeft.property, hredRightRadius redRight.property, + hLdist] at hpairL + linarith + have hdiameterM : 2 * M ≤ packing.virtualDiameter := by + have hpairM := packing.pair_le_virtualDiameter blueLeft blueRight + rw [hblueRadius .left blueLeft.property, hblueRadius .right blueRight.property, + hMdist] at hpairM + nlinarith [canonicalTriangleRadius_left_add_right (configuration .blue .root) + (configuration .blue .left) (configuration .blue .right)] + have hleftPoint (label : SixPointLabel) : + redSiblingBlueTriangleReach configuration .left label + x ≤ + packing.virtualDiameter := by + let blue : packing.support := ⟨(.blue, label), by + cases label <;> simp [packing, redSiblingBlueTrianglePacking]⟩ + have hpairLeft := packing.pair_le_virtualDiameter redLeft blue + rw [hredLeftRadius redLeft.property, hblueRadius label blue.property] at hpairLeft + simp only [redSiblingBlueTriangleReach] + linarith + have hrightPoint (label : SixPointLabel) : + redSiblingBlueTriangleReach configuration .right label + (L - x) ≤ + packing.virtualDiameter := by + let blue : packing.support := ⟨(.blue, label), by + cases label <;> simp [packing, redSiblingBlueTrianglePacking]⟩ + have hpairRight := packing.pair_le_virtualDiameter redRight blue + rw [hredRightRadius redRight.property, hblueRadius label blue.property] at hpairRight + simp only [redSiblingBlueTriangleReach] + linarith + have hdiameterLeft : + x + triangleMaximum (redSiblingBlueTriangleReach configuration .left) ≤ + packing.virtualDiameter := by + simp only [triangleMaximum, add_max, max_le_iff] + exact ⟨by nlinarith [hleftPoint .root], by nlinarith [hleftPoint .left], + by nlinarith [hleftPoint .right]⟩ + have hdiameterRight : + L - x + triangleMaximum (redSiblingBlueTriangleReach configuration .right) ≤ + packing.virtualDiameter := by + rw [show L - x + triangleMaximum (redSiblingBlueTriangleReach configuration .right) = + triangleMaximum (redSiblingBlueTriangleReach configuration .right) + (L - x) by ring] + simp only [triangleMaximum, max_add, max_le_iff] + exact ⟨hrightPoint .root, hrightPoint .left, hrightPoint .right⟩ + simp only [siblingTriangleSplitDiameter, max_le_iff] + exact ⟨hdiameterL, hdiameterM, hdiameterLeft, hdiameterRight⟩ + +/-- The virtual diameter of support `76` is its explicit one-dimensional diameter. -/ +theorem blueSiblingRedTrianglePacking_virtualDiameter + (configuration : SixPointConfiguration) {L M y : ℝ} + (hLdist : dist (configuration .red .left) (configuration .red .right) = L) + (hMdist : dist (configuration .blue .left) (configuration .blue .right) = M) + (hL : 1 ≤ L) (hM : 1 ≤ M) (hy_lower : M - 1 ≤ y) (hy_upper : y ≤ 1) + (hredLeft : dist (configuration .red .root) (configuration .red .left) ≤ 1) + (hredRight : dist (configuration .red .root) (configuration .red .right) ≤ 1) : + (blueSiblingRedTrianglePacking configuration hMdist hM hy_lower hy_upper hredLeft + hredRight).virtualDiameter = + siblingTriangleSplitDiameter M L y + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right) := by + let packing := blueSiblingRedTrianglePacking configuration hMdist hM hy_lower hy_upper + hredLeft hredRight + let target := siblingTriangleSplitDiameter M L y + (blueSiblingRedTriangleReach configuration .left) + (blueSiblingRedTriangleReach configuration .right) + have hblueDist (leftLabel rightLabel : SixPointLabel) + (hleft : (.blue, leftLabel) ∈ packing.support) + (hright : (.blue, rightLabel) ∈ packing.support) : + dist (configuration .blue leftLabel) (configuration .blue rightLabel) ≤ M := by + cases leftLabel <;> cases rightLabel + all_goals simp [packing, blueSiblingRedTrianglePacking] at hleft hright + · simp + linarith + · rw [hMdist] + · rw [dist_comm, hMdist] + · simp + linarith + have hredDist (leftLabel rightLabel : SixPointLabel) : + dist (configuration .red leftLabel) (configuration .red rightLabel) ≤ L := by + cases leftLabel <;> cases rightLabel + · simp + linarith + · exact hredLeft.trans hL + · exact hredRight.trans hL + · simpa [dist_comm] using hredLeft.trans hL + · simp + linarith + · rw [hLdist] + · simpa [dist_comm] using hredRight.trans hL + · rw [dist_comm, hLdist] + · simp + linarith + have htwoM : 2 * M ≤ target := le_max_left _ _ + have htwoL : 2 * L ≤ target := le_max_of_le_right (le_max_left _ _) + have hcrossLeft : + y + triangleMaximum (blueSiblingRedTriangleReach configuration .left) ≤ target := by + exact le_max_of_le_right (le_max_of_le_right (le_max_left _ _)) + have hcrossRight : + M - y + triangleMaximum (blueSiblingRedTriangleReach configuration .right) ≤ target := by + exact le_max_of_le_right (le_max_of_le_right (le_max_right _ _)) + have hblueLeftRadius (hmem : (.blue, .left) ∈ packing.support) : + (packing.radius ⟨(.blue, .left), hmem⟩ : ℝ) = y := by + rfl + have hblueRightRadius (hmem : (.blue, .right) ∈ packing.support) : + (packing.radius ⟨(.blue, .right), hmem⟩ : ℝ) = M - y := by + rfl + have hredRadius (label : SixPointLabel) (hmem : (.red, label) ∈ packing.support) : + (packing.radius ⟨(.red, label), hmem⟩ : ℝ) = + canonicalTriangleRadius (configuration .red .root) (configuration .red .left) + (configuration .red .right) label := by + cases label <;> rfl + have hpair (i j : packing.support) : + dist (configuration i.1.1 i.1.2) (configuration j.1.1 j.1.2) + + packing.radius i + packing.radius j ≤ target := by + rcases i with ⟨⟨leftColor, leftLabel⟩, hleft⟩ + rcases j with ⟨⟨rightColor, rightLabel⟩, hright⟩ + cases leftColor <;> cases rightColor + · exact (sameColorPair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hL + (hredDist leftLabel rightLabel)).trans htwoL + · cases rightLabel + · simp [packing, blueSiblingRedTrianglePacking] at hright + · rw [hredRadius leftLabel hleft, hblueLeftRadius hright, dist_comm] + have hreach := le_triangleMaximum + (blueSiblingRedTriangleReach configuration .left) leftLabel + simp only [blueSiblingRedTriangleReach] at hreach + nlinarith + · rw [hredRadius leftLabel hleft, hblueRightRadius hright, dist_comm] + have hreach := le_triangleMaximum + (blueSiblingRedTriangleReach configuration .right) leftLabel + simp only [blueSiblingRedTriangleReach] at hreach + nlinarith + · cases leftLabel + · simp [packing, blueSiblingRedTrianglePacking] at hleft + · rw [hblueLeftRadius hleft, hredRadius rightLabel hright] + have hreach := le_triangleMaximum + (blueSiblingRedTriangleReach configuration .left) rightLabel + simp only [blueSiblingRedTriangleReach] at hreach + nlinarith + · rw [hblueRightRadius hleft, hredRadius rightLabel hright] + have hreach := le_triangleMaximum + (blueSiblingRedTriangleReach configuration .right) rightLabel + simp only [blueSiblingRedTriangleReach] at hreach + nlinarith + · exact (sameColorPair_le_twice_bound packing ⟨_, hleft⟩ ⟨_, hright⟩ rfl hM + (hblueDist leftLabel rightLabel hleft hright)).trans htwoM + apply le_antisymm + · unfold SixPointPacking.virtualDiameter + apply Finset.sup'_le + intro i hi + apply Finset.sup'_le + intro j hj + exact hpair i j + · let redLeft : packing.support := ⟨(.red, .left), by + simp [packing, blueSiblingRedTrianglePacking]⟩ + let redRight : packing.support := ⟨(.red, .right), by + simp [packing, blueSiblingRedTrianglePacking]⟩ + let blueLeft : packing.support := ⟨(.blue, .left), by + simp [packing, blueSiblingRedTrianglePacking]⟩ + let blueRight : packing.support := ⟨(.blue, .right), by + simp [packing, blueSiblingRedTrianglePacking]⟩ + have hdiameterL : 2 * L ≤ packing.virtualDiameter := by + have hpairL := packing.pair_le_virtualDiameter redLeft redRight + rw [hredRadius .left redLeft.property, hredRadius .right redRight.property, + hLdist] at hpairL + nlinarith [canonicalTriangleRadius_left_add_right (configuration .red .root) + (configuration .red .left) (configuration .red .right)] + have hdiameterM : 2 * M ≤ packing.virtualDiameter := by + have hpairM := packing.pair_le_virtualDiameter blueLeft blueRight + rw [hblueLeftRadius blueLeft.property, hblueRightRadius blueRight.property, + hMdist] at hpairM + linarith + have hleftPoint (label : SixPointLabel) : + blueSiblingRedTriangleReach configuration .left label + y ≤ + packing.virtualDiameter := by + let red : packing.support := ⟨(.red, label), by + cases label <;> simp [packing, blueSiblingRedTrianglePacking]⟩ + have hpairLeft := packing.pair_le_virtualDiameter blueLeft red + rw [hblueLeftRadius blueLeft.property, hredRadius label red.property] at hpairLeft + simp only [blueSiblingRedTriangleReach] + linarith + have hrightPoint (label : SixPointLabel) : + blueSiblingRedTriangleReach configuration .right label + (M - y) ≤ + packing.virtualDiameter := by + let red : packing.support := ⟨(.red, label), by + cases label <;> simp [packing, blueSiblingRedTrianglePacking]⟩ + have hpairRight := packing.pair_le_virtualDiameter blueRight red + rw [hblueRightRadius blueRight.property, hredRadius label red.property] at hpairRight + simp only [blueSiblingRedTriangleReach] + linarith + have hdiameterLeft : + y + triangleMaximum (blueSiblingRedTriangleReach configuration .left) ≤ + packing.virtualDiameter := by + simp only [triangleMaximum, add_max, max_le_iff] + exact ⟨by nlinarith [hleftPoint .root], by nlinarith [hleftPoint .left], + by nlinarith [hleftPoint .right]⟩ + have hdiameterRight : + M - y + triangleMaximum (blueSiblingRedTriangleReach configuration .right) ≤ + packing.virtualDiameter := by + rw [show M - y + triangleMaximum (blueSiblingRedTriangleReach configuration .right) = + triangleMaximum (blueSiblingRedTriangleReach configuration .right) + (M - y) by ring] + simp only [triangleMaximum, max_add, max_le_iff] + exact ⟨hrightPoint .root, hrightPoint .left, hrightPoint .right⟩ + simp only [siblingTriangleSplitDiameter, max_le_iff] + exact ⟨hdiameterM, hdiameterL, hdiameterLeft, hdiameterRight⟩ + +/-- Exact threshold form of the one-dimensional sibling-triangle minimax. -/ +theorem exists_siblingTriangle_split_iff + {L M T : ℝ} {leftReach rightReach : SixPointLabel → ℝ} (hL : L ≤ 2) : + (∃ x : ℝ, L - 1 ≤ x ∧ x ≤ 1 ∧ + siblingTriangleSplitDiameter L M x leftReach rightReach ≤ T) ↔ + 2 * L ≤ T ∧ 2 * M ≤ T ∧ + (∀ label, L - 1 + leftReach label ≤ T) ∧ + (∀ label, L - 1 + rightReach label ≤ T) ∧ + (∀ leftLabel rightLabel, + L + leftReach leftLabel + rightReach rightLabel ≤ 2 * T) := by + constructor + · rintro ⟨x, hx_lower, hx_upper, hdiameter⟩ + simp only [siblingTriangleSplitDiameter, max_le_iff] at hdiameter + rcases hdiameter with ⟨hsameL, hsameM, hleft, hright⟩ + refine ⟨hsameL, hsameM, ?_, ?_, ?_⟩ + · intro label + nlinarith [le_triangleMaximum leftReach label] + · intro label + nlinarith [le_triangleMaximum rightReach label] + · intro leftLabel rightLabel + nlinarith [le_triangleMaximum leftReach leftLabel, + le_triangleMaximum rightReach rightLabel] + · rintro ⟨hsameL, hsameM, hleft, hright, hbalanced⟩ + obtain ⟨leftLabel, hleftLabel⟩ := exists_triangleMaximum_eq leftReach + obtain ⟨rightLabel, hrightLabel⟩ := exists_triangleMaximum_eq rightReach + have hleftMax : L - 1 + triangleMaximum leftReach ≤ T := by + rw [hleftLabel] + exact hleft leftLabel + have hrightMax : L - 1 + triangleMaximum rightReach ≤ T := by + rw [hrightLabel] + exact hright rightLabel + have hbalancedMax : + L + triangleMaximum leftReach + triangleMaximum rightReach ≤ 2 * T := by + rw [hleftLabel, hrightLabel] + exact hbalanced leftLabel rightLabel + let x := max (L - 1) (L + triangleMaximum rightReach - T) + have hx_lower : L - 1 ≤ x := le_max_left _ _ + have hx_upper : x ≤ 1 := by + simp only [x, max_le_iff] + exact ⟨by linarith, by linarith⟩ + have hcrossLeft : x + triangleMaximum leftReach ≤ T := by + simp only [x, max_add, max_le_iff] + exact ⟨by linarith, by linarith⟩ + have hcrossRight : L - x + triangleMaximum rightReach ≤ T := by + nlinarith [le_max_right (L - 1) (L + triangleMaximum rightReach - T)] + refine ⟨x, hx_lower, hx_upper, ?_⟩ + simp only [siblingTriangleSplitDiameter, max_le_iff] + exact ⟨hsameL, hsameM, hcrossLeft, hcrossRight⟩ + +/-- If every feasible split fails, an endpoint or balanced cross term exceeds the target. -/ +theorem siblingTriangle_failure_routing + {L M T : ℝ} {leftReach rightReach : SixPointLabel → ℝ} + (hL : L ≤ 2) (hsameL : 2 * L ≤ T) (hsameM : 2 * M ≤ T) + (hfail : ∀ x : ℝ, L - 1 ≤ x → x ≤ 1 → + T < siblingTriangleSplitDiameter L M x leftReach rightReach) : + (∃ label, T < L - 1 + leftReach label) ∨ + (∃ label, T < L - 1 + rightReach label) ∨ + ∃ leftLabel rightLabel, + 2 * T < L + leftReach leftLabel + rightReach rightLabel := by + by_contra hrouting + simp only [not_or, not_exists, not_lt] at hrouting + rcases hrouting with ⟨hleft, hright, hbalanced⟩ + obtain ⟨x, hx_lower, hx_upper, hdiameter⟩ := + (exists_siblingTriangle_split_iff hL).2 + ⟨hsameL, hsameM, hleft, hright, hbalanced⟩ + exact (not_lt_of_ge hdiameter) (hfail x hx_lower hx_upper) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/WeightedFailure.lean b/LeanPool/Besicovitch/SixPoint/WeightedFailure.lean new file mode 100644 index 0000000000..a591d57e1d --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/WeightedFailure.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.RationalChord +public import LeanPool.Besicovitch.SixPoint.EndpointWeights +public import LeanPool.Besicovitch.SixPoint.RootEdgeFailureTree + +/-! +# The three active six-point failure slacks + +The surviving path through the packing failure tree produces three scalar inequalities. This file +names those natural slacks and identifies their positive weighted sum with the coordinate-free +weighted pair score. +-/ + +@[expose] public section + +noncomputable section + +namespace LeanPool.Besicovitch + +/-- The weakened diagonal-matching slack `q1`. -/ +def firstActiveFailureSlack (configuration : SixPointConfiguration) : ℝ := + diagonalMatchingReducedSlack configuration + +/-- The coincident sibling-endpoint slack `q2`. -/ +def secondActiveFailureSlack (configuration : SixPointConfiguration) : ℝ := + dist (configuration .red .left) (configuration .blue .left) - + ((barC - 1) * matchedChildAverage configuration 0 + + (barC + 1) * matchedChildAverage configuration 1 + + 3 * barC ^ 2 - 3 * barC + 2) / 2 + +/-- The balanced root--edge slack `q3`. -/ +def thirdActiveFailureSlack (configuration : SixPointConfiguration) : ℝ := + (dist (configuration .red .left) (configuration .blue .root) + + dist (configuration .red .root) (configuration .blue .left) + + dist (configuration .red .left) (configuration .blue .right) + + dist (configuration .red .right) (configuration .blue .left)) / 2 - + ((barC - 1) * matchedChildAverage configuration 0 + + 3 * barC * matchedChildAverage configuration 1 + barC ^ 2 - barC) + +/-- The selected diagonal matching makes `q1` nonnegative. -/ +theorem firstActiveFailureSlack_nonneg + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hmatching : SelectedDiagonalMatchingFails configuration) : + 0 ≤ firstActiveFailureSlack configuration := by + exact diagonalMatchingReducedSlack_nonneg h hmatching + +/-- Coincident endpoint failures at `B11` make `q2` strictly positive. -/ +theorem secondActiveFailureSlack_pos + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hred : redSiblingTriangleFailure configuration (.endpoint 0)) + (hblue : blueSiblingTriangleFailure configuration (.endpoint 0)) : + 0 < secondActiveFailureSlack configuration := by + exact sub_pos.mpr (q2_strict_of_matched_endpoint_zero h hred hblue) + +/-- The two surviving `(1,1)` root--edge terms make `q3` strictly positive. -/ +theorem thirdActiveFailureSlack_pos + {configuration : SixPointConfiguration} (h : configuration.IsAdmissibleAt barS) + (hred : 2 * redRootEdgeTarget configuration < + dist (configuration .red .root) (configuration .red .right) + + redRootBlueTriangleReach configuration .left + + redChildBlueTriangleReach configuration .right .left) + (hblue : 2 * blueRootEdgeTarget configuration < + dist (configuration .blue .root) (configuration .blue .right) + + blueRootRedTriangleReach configuration .left + + blueChildRedTriangleReach configuration .right .left) : + 0 < thirdActiveFailureSlack configuration := by + have hL := (sibling_distance_mem_endpoint_interval h .red).1 + have hM := (sibling_distance_mem_endpoint_interval h .blue).1 + have hcoefficient : 0 ≤ barC - 1 := by + nlinarith [one_lt_barC_and_barC_lt_two.1] + have hsiblingScaled := mul_le_mul_of_nonneg_left (show 2 * barC ≤ + dist (configuration .red .left) (configuration .red .right) + + dist (configuration .blue .left) (configuration .blue .right) by linarith) + hcoefficient + norm_num [redRootEdgeTarget, blueRootEdgeTarget, rootedTriangleTotalRadius, + redRootBlueTriangleReach, redChildBlueTriangleReach, blueRootRedTriangleReach, + blueChildRedTriangleReach, canonicalTriangleRadius] at hred hblue + simp only [thirdActiveFailureSlack, matchedChildAverage, incidenceChild] + rw [dist_comm (configuration .blue .root) (configuration .red .left), + dist_comm (configuration .blue .right) (configuration .red .left)] at hblue + nlinarith + +/-- The weighted score of the displacement pairs is exactly `q1 + lambda*q2 + mu*q3`. -/ +theorem weightedPairScore_configuration_eq_activeFailureCombination + (configuration : SixPointConfiguration) (lambda mu : ℝ) : + weightedPairScore configuration.rootDisplacement barC lambda mu + (configuration.redDisplacement .left) (configuration.redDisplacement .right) + (configuration.bluePullback .left) (configuration.bluePullback .right) = + firstActiveFailureSlack configuration + + lambda * secondActiveFailureSlack configuration + + mu * thirdActiveFailureSlack configuration := by + have hB₁₁ := configuration.dist_red_blue_eq_norm .left .left + have hB₂₂ := configuration.dist_red_blue_eq_norm .right .right + have hB₁₂ := configuration.dist_red_blue_eq_norm .left .right + have hB₂₁ := configuration.dist_red_blue_eq_norm .right .left + have hAred : + dist (configuration .red .left) (configuration .blue .root) = + ‖configuration.rootDisplacement - configuration.redDisplacement .left‖ := by + simpa [SixPointConfiguration.bluePullback] using + configuration.dist_red_blue_eq_norm .left .root + have hAblue : + dist (configuration .red .root) (configuration .blue .left) = + ‖configuration.rootDisplacement - configuration.bluePullback .left‖ := by + simpa [SixPointConfiguration.redDisplacement] using + configuration.dist_red_blue_eq_norm .root .left + have hB₂₁' : + ‖configuration.rootDisplacement - configuration.bluePullback .left - + configuration.redDisplacement .right‖ = + dist (configuration .red .right) (configuration .blue .left) := by + rw [show configuration.rootDisplacement - configuration.bluePullback .left - + configuration.redDisplacement .right = + configuration.rootDisplacement - configuration.redDisplacement .right - + configuration.bluePullback .left by abel] + exact hB₂₁.symm + have hr₁ : ‖configuration.redDisplacement .left‖ = + dist (configuration .red .root) (configuration .red .left) := by + simp [SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hr₂ : ‖configuration.redDisplacement .right‖ = + dist (configuration .red .root) (configuration .red .right) := by + simp [SixPointConfiguration.redDisplacement, dist_eq_norm, norm_sub_rev] + have hb₁ : ‖configuration.bluePullback .left‖ = + dist (configuration .blue .root) (configuration .blue .left) := by + simp [SixPointConfiguration.bluePullback, dist_eq_norm] + have hb₂ : ‖configuration.bluePullback .right‖ = + dist (configuration .blue .root) (configuration .blue .right) := by + simp [SixPointConfiguration.bluePullback, dist_eq_norm] + simp only [weightedPairScore, firstActiveFailureSlack, diagonalMatchingReducedSlack, + incidenceCrossDistance, secondActiveFailureSlack, + thirdActiveFailureSlack, matchedChildAverage, incidenceChild, weightedFirstPenalty, + weightedSecondPenalty, weightedConstantTerm] + rw [← hB₁₁, ← hB₂₂, ← hB₁₂, hB₂₁', ← hAred, ← hAblue, + ← hr₁, ← hr₂, ← hb₁, ← hb₂] + ring + +/-- Nonnegative active slacks make their exact weighted combination nonnegative. -/ +theorem activeFailureCombination_nonneg {configuration : SixPointConfiguration} + {lambda mu : ℝ} (hlambda : 0 ≤ lambda) (hmu : 0 ≤ mu) + (hq₁ : 0 ≤ firstActiveFailureSlack configuration) + (hq₂ : 0 ≤ secondActiveFailureSlack configuration) + (hq₃ : 0 ≤ thirdActiveFailureSlack configuration) : + 0 ≤ firstActiveFailureSlack configuration + + lambda * secondActiveFailureSlack configuration + + mu * thirdActiveFailureSlack configuration := by + have hsecond := mul_nonneg hlambda hq₂ + have hthird := mul_nonneg hmu hq₃ + linarith + +/-- Strict second and third failure slacks make their weighted combination positive. -/ +theorem activeFailureCombination_pos {configuration : SixPointConfiguration} + {lambda mu : ℝ} (hlambda : 0 < lambda) (hmu : 0 < mu) + (hq₁ : 0 ≤ firstActiveFailureSlack configuration) + (hq₂ : 0 < secondActiveFailureSlack configuration) + (hq₃ : 0 < thirdActiveFailureSlack configuration) : + 0 < firstActiveFailureSlack configuration + + lambda * secondActiveFailureSlack configuration + + mu * thirdActiveFailureSlack configuration := by + have hsecond := mul_pos hlambda hq₂ + have hthird := mul_pos hmu hq₃ + linarith + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/SixPoint/WeightedReduction.lean b/LeanPool/Besicovitch/SixPoint/WeightedReduction.lean new file mode 100644 index 0000000000..4e40100f7f --- /dev/null +++ b/LeanPool/Besicovitch/SixPoint/WeightedReduction.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import LeanPool.Besicovitch.SixPoint.EndpointGeometry +import Mathlib.Topology.Order.IntermediateValue + +/-! +# Radial reduction for the weighted six-point inequality + +This file records the exact weighted score and proves that its two second children may be +moved inward until both sibling distances equal the endpoint chord length. +-/ + +@[expose] public section + +noncomputable section + +open Set + +namespace LeanPool.Besicovitch + +/-- The coefficient penalizing the first child radii in the weighted score. -/ +def weightedFirstPenalty (c lambda mu : ℝ) : ℝ := + (c - 1) * (lambda / 2 + mu) + +/-- The coefficient penalizing the second child radii in the weighted score. -/ +def weightedSecondPenalty (c lambda mu : ℝ) : ℝ := + (c + 1) * lambda / 2 + 3 * c * mu + +/-- The constant term in the weighted combination of the three failure slacks. -/ +def weightedConstantTerm (c lambda mu : ℝ) : ℝ := + 2 * c * (2 * c - 1) + lambda * (3 * c ^ 2 - 3 * c + 2) / 2 + + mu * (c ^ 2 - c) + +/-- The weighted failure score for two ordered sibling pairs relative to a unit root vector. -/ +def weightedPairScore {E : Type*} [NormedAddCommGroup E] + (e : E) (c lambda mu : ℝ) (p₁ p₂ w₁ w₂ : E) : ℝ := + (1 + lambda) * ‖e - p₁ - w₁‖ + ‖e - p₂ - w₂‖ + + mu / 2 * (‖e - p₁‖ + ‖e - w₁‖ + ‖e - p₁ - w₂‖ + ‖e - w₁ - p₂‖) - + weightedFirstPenalty c lambda mu / 2 * (‖p₁‖ + ‖w₁‖) - + weightedSecondPenalty c lambda mu / 2 * (‖p₂‖ + ‖w₂‖) - + weightedConstantTerm c lambda mu + +variable {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] + +/-- Scaling a point inward reaches every intermediate distance from another point. -/ +theorem exists_norm_sub_smul_eq {p q : E} {c : ℝ} (hp : ‖p‖ < c) + (hpq : c ≤ ‖p - q‖) : + ∃ a ∈ Icc (0 : ℝ) 1, ‖p - a • q‖ = c := by + let f : ℝ → ℝ := fun a ↦ ‖p - a • q‖ + have hf : Continuous f := continuous_norm.comp + (continuous_const.sub (continuous_id.smul continuous_const)) + have hc_mem : c ∈ Icc (f 0) (f 1) := by + simpa [f] using ⟨hp.le, hpq⟩ + obtain ⟨a, ha, hfa⟩ := + intermediate_value_Icc (show (0 : ℝ) ≤ 1 by norm_num) hf.continuousOn hc_mem + exact ⟨a, ha, hfa⟩ + +private theorem norm_eq_norm_smul_add_norm_sub_smul {q : E} {a : ℝ} + (ha_zero : 0 ≤ a) (ha_one : a ≤ 1) : + ‖q‖ = ‖a • q‖ + ‖q - a • q‖ := by + have h_one_sub : 0 ≤ 1 - a := sub_nonneg.mpr ha_one + have hq : q - a • q = (1 - a) • q := by module + rw [hq, norm_smul, norm_smul, Real.norm_eq_abs, Real.norm_eq_abs, + abs_of_nonneg ha_zero, abs_of_nonneg h_one_sub] + ring + +private theorem norm_replace_by_smul_le (x q : E) {a : ℝ} + (ha_zero : 0 ≤ a) (ha_one : a ≤ 1) : + ‖x - q‖ ≤ ‖x - a • q‖ + (‖q‖ - ‖a • q‖) := by + have h := norm_le_norm_add_norm_sub' (x - q) (x - a • q) + have hdiff : (x - q) - (x - a • q) = -(q - a • q) := by abel + rw [hdiff, norm_neg] at h + have hnorm := norm_eq_norm_smul_add_norm_sub_smul (q := q) ha_zero ha_one + linarith + +/-- Moving the second child of the first pair inward cannot decrease the weighted score. -/ +theorem weightedPairScore_le_smul_second_left (e : E) (c lambda mu : ℝ) + (p₁ p₂ w₁ w₂ : E) {a : ℝ} (ha_zero : 0 ≤ a) (ha_one : a ≤ 1) + (hmu : 0 ≤ mu) (hpenalty : 2 + mu ≤ weightedSecondPenalty c lambda mu) : + weightedPairScore e c lambda mu p₁ p₂ w₁ w₂ ≤ + weightedPairScore e c lambda mu p₁ (a • p₂) w₁ w₂ := by + have hnorm := norm_eq_norm_smul_add_norm_sub_smul (q := p₂) ha_zero ha_one + have hdifference : 0 ≤ ‖p₂‖ - ‖a • p₂‖ := by + rw [hnorm] + simp + have hfirst := norm_replace_by_smul_le (e - w₂) p₂ ha_zero ha_one + have hsecond := norm_replace_by_smul_le (e - w₁) p₂ ha_zero ha_one + have hsecond' : + mu / 2 * ‖e - w₁ - p₂‖ ≤ + mu / 2 * ‖e - w₁ - a • p₂‖ + mu / 2 * (‖p₂‖ - ‖a • p₂‖) := by + calc + _ ≤ mu / 2 * (‖e - w₁ - a • p₂‖ + + (‖p₂‖ - ‖a • p₂‖)) := + mul_le_mul_of_nonneg_left hsecond (div_nonneg hmu (by norm_num)) + _ = _ := by ring + have hmargin := mul_nonneg (sub_nonneg.mpr hpenalty) hdifference + simp only [weightedPairScore, weightedFirstPenalty, weightedSecondPenalty, + weightedConstantTerm] + dsimp only [weightedSecondPenalty] at hmargin + rw [show e - p₂ - w₂ = (e - w₂) - p₂ by abel, + show e - a • p₂ - w₂ = (e - w₂) - a • p₂ by abel, + show e - w₁ - p₂ = (e - w₁) - p₂ by abel, + show e - w₁ - a • p₂ = (e - w₁) - a • p₂ by abel] + nlinarith + +omit [NormedSpace ℝ E] in +/-- The weighted score is symmetric in its two sibling pairs. -/ +theorem weightedPairScore_swap (e : E) (c lambda mu : ℝ) (p₁ p₂ w₁ w₂ : E) : + weightedPairScore e c lambda mu p₁ p₂ w₁ w₂ = + weightedPairScore e c lambda mu w₁ w₂ p₁ p₂ := by + simp only [weightedPairScore] + rw [show ‖e - p₁ - w₁‖ = ‖e - w₁ - p₁‖ by + congr 1 + abel, + show ‖e - p₂ - w₂‖ = ‖e - w₂ - p₂‖ by + congr 1 + abel] + ring + +/-- Moving the second child of the second pair inward cannot decrease the weighted score. -/ +theorem weightedPairScore_le_smul_second_right (e : E) (c lambda mu : ℝ) + (p₁ p₂ w₁ w₂ : E) {a : ℝ} (ha_zero : 0 ≤ a) (ha_one : a ≤ 1) + (hmu : 0 ≤ mu) (hpenalty : 2 + mu ≤ weightedSecondPenalty c lambda mu) : + weightedPairScore e c lambda mu p₁ p₂ w₁ w₂ ≤ + weightedPairScore e c lambda mu p₁ p₂ w₁ (a • w₂) := by + rw [weightedPairScore_swap e c lambda mu p₁ p₂ w₁ w₂, + weightedPairScore_swap e c lambda mu p₁ p₂ w₁ (a • w₂)] + exact weightedPairScore_le_smul_second_left e c lambda mu w₁ w₂ p₁ p₂ + ha_zero ha_one hmu hpenalty + +/-- Both sibling pairs reduce to endpoint-length chords without lowering the weighted score. -/ +theorem exists_weightedPairScore_chord_reduction (e : E) {c lambda mu : ℝ} + {p₁ p₂ w₁ w₂ : E} (hc : 1 < c) + (hp₁ : ‖p₁‖ ≤ 1) (hw₁ : ‖w₁‖ ≤ 1) + (hp : c ≤ ‖p₁ - p₂‖) (hw : c ≤ ‖w₁ - w₂‖) + (hmu : 0 ≤ mu) (hpenalty : 2 + mu ≤ weightedSecondPenalty c lambda mu) : + ∃ p₂' w₂' : E, + ‖p₁ - p₂'‖ = c ∧ ‖w₁ - w₂'‖ = c ∧ + ‖p₂'‖ ≤ ‖p₂‖ ∧ ‖w₂'‖ ≤ ‖w₂‖ ∧ + weightedPairScore e c lambda mu p₁ p₂ w₁ w₂ ≤ + weightedPairScore e c lambda mu p₁ p₂' w₁ w₂' := by + obtain ⟨a, ⟨ha_zero, ha_one⟩, ha⟩ := + exists_norm_sub_smul_eq (p := p₁) (q := p₂) (c := c) (hp₁.trans_lt hc) hp + obtain ⟨b, ⟨hb_zero, hb_one⟩, hb⟩ := + exists_norm_sub_smul_eq (p := w₁) (q := w₂) (c := c) (hw₁.trans_lt hc) hw + refine ⟨a • p₂, b • w₂, ha, hb, ?_, ?_, ?_⟩ + · rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg ha_zero] + exact mul_le_of_le_one_left (norm_nonneg _) ha_one + · rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg hb_zero] + exact mul_le_of_le_one_left (norm_nonneg _) hb_one + · exact (weightedPairScore_le_smul_second_left e c lambda mu p₁ p₂ w₁ w₂ + ha_zero ha_one hmu hpenalty).trans + (weightedPairScore_le_smul_second_right e c lambda mu p₁ (a • p₂) w₁ w₂ + hb_zero hb_one hmu hpenalty) + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Statement.lean b/LeanPool/Besicovitch/Statement.lean new file mode 100644 index 0000000000..64a2d630f1 --- /dev/null +++ b/LeanPool/Besicovitch/Statement.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Analysis.InnerProductSpace.PiL2 +public import Mathlib.Analysis.Normed.Lp.MeasurableSpace +public import Mathlib.Analysis.Real.Sqrt +public import Mathlib.MeasureTheory.Measure.Hausdorff +public import Mathlib.Order.ConditionallyCompleteLattice.Indexed + +/-! +# Definitions in the public statement + +This module contains the transparent definitions used by the solution. They are repeated in +`Challenge.lean`, whose statement is checked independently by the comparator. +-/ + +@[expose] public section + +noncomputable section + +open Filter MeasureTheory Set +open scoped ENNReal MeasureTheory NNReal Topology + +namespace LeanPool.Besicovitch + +variable {X : Type*} [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + +/-- The lower one-density of `s` at `x`, normalized by the diameter `2 * r` of a ball. -/ +def lowerOneDensity (s : Set X) (x : X) : ℝ≥0∞ := + liminf (fun r : ℝ ↦ μH[1] (s ∩ Metric.ball x r) / ENNReal.ofReal (2 * r)) + (nhdsWithin 0 (Ioi 0)) + +/-- A set is countably one-rectifiable if Lipschitz curves cover it up to Hausdorff null measure. -/ +def IsCountablyOneRectifiable (s : Set X) : Prop := + ∃ f : ℕ → ℝ → X, + (∀ i, ∃ K : ℝ≥0, LipschitzWith K (f i)) ∧ μH[1] (s \ ⋃ i, range (f i)) = 0 + +/-- Every finite-measure set with lower density at least `β` is one-rectifiable. -/ +def ForcesOneRectifiability (X : Type*) [MetricSpace X] [MeasurableSpace X] [BorelSpace X] + (β : ℝ≥0∞) : Prop := + ∀ s : Set X, MeasurableSet s → μH[1] s < ∞ → + (∀ᵐ x ∂μH[1].restrict s, β ≤ lowerOneDensity s x) → + IsCountablyOneRectifiable s + +/-- The infimum of the nonnegative thresholds forcing one-rectifiability in `X`. -/ +def sigmaOne (X : Type*) [MetricSpace X] [MeasurableSpace X] [BorelSpace X] : ℝ := + sInf {β : ℝ | 0 ≤ β ∧ ForcesOneRectifiability X (ENNReal.ofReal β)} + +/-- The isolated radical system whose first coordinate is twice the six-point endpoint. -/ +def IsEndpointPair (c B : ℝ) : Prop := + let D := 4 * c ^ 2 - 2 * c - B + let b := (2 * B - 3 * c ^ 2 + 2 * c - 1) / (c + 1) + let A := Real.sqrt ((B ^ 2 - 1) / 2) + let C := Real.sqrt ((B ^ 2 + D ^ 2) / 2 - c ^ 2) + let x := (5 - B ^ 2) / 4 + let z := (1 + 4 * b ^ 2 - D ^ 2) / 4 + let k := (1 + b ^ 2 - c ^ 2) / 2 + 13866128436518096 / 10 ^ 16 < c ∧ c < 13866128436518100 / 10 ^ 16 ∧ + 2873744161801659 / 10 ^ 15 < B ∧ B < 2873744161801662 / 10 ^ 15 ∧ + A + C = 3 * c * b + c ^ 2 - 1 ∧ + (k - x * z) ^ 2 = (1 - x ^ 2) * (b ^ 2 - z ^ 2) ∧ + x < 0 ∧ z < 0 ∧ k - x * z < 0 + +/-- Twice the optimal six-point constant, defined by its isolated exact system. -/ +def cStar : ℝ := + sInf {c : ℝ | ∃ B : ℝ, IsEndpointPair c B} + +/-- The optimal two-colour six-point constant. -/ +def sStar : ℝ := + cStar / 2 + +end LeanPool.Besicovitch diff --git a/LeanPool/Besicovitch/Topology/ConnectedComponent.lean b/LeanPool/Besicovitch/Topology/ConnectedComponent.lean new file mode 100644 index 0000000000..626cac7110 --- /dev/null +++ b/LeanPool/Besicovitch/Topology/ConnectedComponent.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yongxi Lin. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yongxi Lin +-/ +module + +public import Mathlib.Topology.Separation.Regular +public import Mathlib.Topology.MetricSpace.Pseudo.Lemmas + +/-! +# Connected components in compact spaces + +A connected component in a compact Hausdorff space has arbitrarily small clopen +neighborhoods. This is the compact-space separation fact used in the BPC argument. +-/ + +@[expose] public section + +open Set + +namespace LeanPool.Besicovitch + +/-- A preconnected subset remains preconnected when viewed inside a larger subtype. -/ +theorem IsPreconnected.preimage_subtype_of_subset {X : Type*} [TopologicalSpace X] + {A Q : Set X} (hA : IsPreconnected A) (hAQ : A ⊆ Q) : + IsPreconnected ((↑) ⁻¹' A : Set Q) := by + let inclusion : A → Q := fun x ↦ ⟨x, hAQ x.2⟩ + have hinclusion : Topology.IsInducing inclusion := + Topology.IsInducing.subtypeVal.codRestrict fun x : A ↦ hAQ x.2 + have himage : inclusion '' (univ : Set A) = (↑) ⁻¹' A := by + ext x + constructor + · rintro ⟨y, -, rfl⟩ + exact y.2 + · intro hx + exact ⟨⟨x, hx⟩, mem_univ _, rfl⟩ + rw [← himage, hinclusion.isPreconnected_image] + let : PreconnectedSpace A := Subtype.preconnectedSpace hA + exact isPreconnected_univ + +/-- A connected component cut out inside a compact set is compact. -/ +theorem isCompact_connectedComponentIn {X : Type*} [TopologicalSpace X] + {K : Set X} (hK : IsCompact K) (x : X) : IsCompact (connectedComponentIn K x) := by + by_cases hx : x ∈ K + · rw [connectedComponentIn_eq_image hx] + let : CompactSpace K := isCompact_iff_compactSpace.mp hK + exact isClosed_connectedComponent.isCompact.image continuous_subtype_val + · rw [connectedComponentIn_eq_empty hx] + exact isCompact_empty + +/-- In a compact Hausdorff space, a connected component contained in an open set has a clopen +neighborhood contained in that open set. -/ +theorem exists_isClopen_between_connectedComponent {X : Type*} [TopologicalSpace X] + [T2Space X] [CompactSpace X] {x : X} {U : Set X} (hU : IsOpen U) + (hcomponent : connectedComponent x ⊆ U) : + ∃ H : Set X, IsClopen H ∧ connectedComponent x ⊆ H ∧ H ⊆ U := by + rw [connectedComponent_eq_iInter_isClopen] at hcomponent + have hfinite := hU.isClosed_compl.isCompact.inter_iInter_nonempty + (fun s : {s : Set X // IsClopen s ∧ x ∈ s} ↦ s) fun s ↦ s.2.1.1 + rw [← not_disjoint_iff_nonempty_inter, imp_not_comm, not_forall] at hfinite + obtain ⟨sets, hsets⟩ := + hfinite (disjoint_compl_left_iff_subset.2 hcomponent) + refine ⟨⋂ s ∈ sets, Subtype.val s, ?_, ?_, ?_⟩ + · exact isClopen_biInter_finset fun s _ ↦ s.2.1 + · rw [connectedComponent_eq_iInter_isClopen] + intro y hy + exact mem_iInter₂.2 fun s _ ↦ mem_iInter.1 hy s + · rwa [← disjoint_compl_left_iff_subset, disjoint_iff_inter_eq_empty, + ← not_nonempty_iff_eq_empty] + +/-- A clopen neighborhood of a component in a closed ball remains clopen in the ambient compact +set when it lies in a strictly smaller ball. -/ +theorem exists_isClopenWithin_between_connectedComponentIn_closedBall + {X : Type*} [PseudoMetricSpace X] [T2Space X] + {Q : Set X} (hQ : IsCompact Q) + {z : X} (hzQ : z ∈ Q) {R rho : ℝ} (hR : 0 ≤ R) (hRrho : R < rho) + (hcomponent : connectedComponentIn (Q ∩ Metric.closedBall z rho) z ⊆ Metric.ball z R) : + ∃ H : Set X, + connectedComponentIn (Q ∩ Metric.closedBall z rho) z ⊆ H ∧ + H ⊆ Q ∩ Metric.ball z R ∧ IsClopen ((↑) ⁻¹' H : Set Q) ∧ IsCompact H := by + let K := Q ∩ Metric.closedBall z rho + have hK : IsCompact K := hQ.inter_right Metric.isClosed_closedBall + have hzK : z ∈ K := + ⟨hzQ, Metric.mem_closedBall_self (le_of_lt (hR.trans_lt hRrho))⟩ + let zK : K := ⟨z, hzK⟩ + let U : Set K := (↑) ⁻¹' Metric.ball z R + have hU : IsOpen U := Metric.isOpen_ball.preimage continuous_subtype_val + have : CompactSpace K := isCompact_iff_compactSpace.mp hK + have hcomponent_subtype : connectedComponent zK ⊆ U := by + intro x hx + apply hcomponent + rw [connectedComponentIn_eq_image hzK] + exact ⟨x, hx, rfl⟩ + obtain ⟨H, hH_clopen, hcomponent_H, hH_U⟩ := + exists_isClopen_between_connectedComponent hU hcomponent_subtype + let Hplane : Set X := Subtype.val '' H + have hHplane_component : connectedComponentIn K z ⊆ Hplane := by + rw [connectedComponentIn_eq_image hzK] + exact image_mono hcomponent_H + have hHplane_subset : Hplane ⊆ Q ∩ Metric.ball z R := by + rintro x ⟨y, hyH, rfl⟩ + exact ⟨y.2.1, hH_U hyH⟩ + have hHplane_compact : IsCompact Hplane := + hH_clopen.isClosed.isCompact.image continuous_subtype_val + refine ⟨Hplane, hHplane_component, hHplane_subset, ?_, hHplane_compact⟩ + constructor + · exact hHplane_compact.isClosed.preimage continuous_subtype_val + · rcases isOpen_induced_iff.mp hH_clopen.isOpen with ⟨O, hO, hpreimage⟩ + apply isOpen_induced_iff.mpr + refine ⟨O ∩ Metric.ball z rho, hO.inter Metric.isOpen_ball, ?_⟩ + ext x + constructor + · rintro ⟨hxO, hxrho⟩ + let y : K := ⟨x, x.2, Metric.ball_subset_closedBall hxrho⟩ + have hyH : y ∈ H := by + rw [← hpreimage] + exact hxO + exact ⟨y, hyH, rfl⟩ + · intro hx + obtain ⟨y, hyH, hyx⟩ := hx + have hyO : (y : X) ∈ O := by + have : y ∈ Subtype.val ⁻¹' O := hpreimage.symm ▸ hyH + exact this + have hyR : (y : X) ∈ Metric.ball z R := hH_U hyH + exact ⟨hyx ▸ hyO, Metric.ball_subset_ball hRrho.le (hyx ▸ hyR)⟩ + +end LeanPool.Besicovitch diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index 553c55db1b..cc0ab77cf8 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -10440,3 +10440,54 @@ projects: - 47H30 - 46E30 - 47J05 + + - slug: besicovitchs-1-2 + title: A machine-checked bound of 0.6934 for Besicovitch's 1/2-problem + summary: >- + Proves the planar Besicovitch threshold is at most 6934/10000, improving the published + 7/10 record. The development formalizes the finite six-point reduction, thirty rational Gram + certificates, the endpoint isolation argument, and Besicovitch's classical lower-bound example. + branch: geometric measure theory + entry_module: LeanPool.Besicovitch + authors: + - Yongxi Lin + source: + title: The bound sigma_1(R^2) <= 6934/10000 for Besicovitch's 1/2-problem + authors: + - Yongxi Lin + url: https://github.com/CoolRmal/Besicovitchs-1-2 + github_repo: CoolRmal/Besicovitchs-1-2 + commit: 17c9597b2a901bf386d5bb8382d0a74d2069f25b + license: Apache-2.0 + status: verified + provenance: AI + main_declarations: + - LeanPool.Besicovitch.sigmaOne_plane_le_barS + main_results: + - declaration: LeanPool.Besicovitch.sigmaOne_plane_le_barS + informal: >- + The planar one-dimensional rectifiability threshold is at most 6934/10000, improving the + published upper bound 7/10. + - declaration: LeanPool.Besicovitch.forcesOneRectifiability_plane_of_barS_lt + informal: >- + Every threshold strictly above 6934/10000 forces countable one-rectifiability in the plane. + - declaration: LeanPool.Besicovitch.Example.one_half_le_sigmaOne_plane + informal: >- + The planar threshold is at least one half, witnessed by Besicovitch's purely unrectifiable + example. + - declaration: LeanPool.Besicovitch.weightedPairScore_le_of_separated + informal: >- + Thirty exact rational Gram certificates prove the weighted six-point score is at most + -1/2000 for every separated admissible pair in the unit ball. + tags: + - besicovitch-problem + - measure-theory + - rectifiability + - finite-certificates + - gram-matrices + msc: + - "28A75" + - "28A78" + - "49Q15" + - "68V20" + - "90C05"