1-- A continuous retraction of the cube onto a product of simplices: each2-- coordinate is shifted toward an anchor point by the shortfall of its block3-- sum and then divided by the scale, so that every block sums to one4-- Part of Cumulus, the Grace17 mathematics library.5-- Copyright (c) 2026 Grant Passmore.6-- Released under the Apache License 2.0. See LICENSE in the repository root.7-- Authors: Grant Passmore89module Grace.Cumulus.FixedPoint.SimplexRetraction10import BlockSimplex1112-- Coordinate j of the retraction toward the anchor a.13def retractCoordinate (n blk a j : Set) : Set:=14 mulCube(n, addCube(n, coordinateCube(n, j), mulCube(n, excessCube(n, blk, blk(j)), constantFunction(unitCube(n), ℝ, a(j)))), invCube(n, scaleCube(n, blk, blk(j))))1516theorem retractCoordinate.definition (n blk a j : Set)17shows retractCoordinate(n, blk, a, j) = mulCube(n, addCube(n, coordinateCube(n, j), mulCube(n, excessCube(n, blk, blk(j)), constantFunction(unitCube(n), ℝ, a(j)))), invCube(n, scaleCube(n, blk, blk(j))))18proof19unfold retractCoordinate20rfl2122theorem retractCoordinate.continuous (n : Nat) (blk a j : Set)23requires ha : a ∈ unitCube(n)24requires hj : j ∈ n25shows CubeFunctionContinuous(retractCoordinate(n, blk, a, j), n)26proof27have aj := unitCube.coordinate_real with ha, hj28have coordinate := coordinateCube.continuous with hj29have excess := excessCube.continuous at n, blk, blk(j)30have anchor := constantCube.continuous with aj31have shift := mulCube.continuous with excess, anchor32have numerator := addCube.continuous with coordinate, shift33have scale := scaleCube.continuous at n, blk, blk(j)34have atLeastOne : ∀ x ∈ unitCube(n), (1:R) ≤ (scaleCube(n, blk, blk(j))(x):R)35intros x hx36exact scaleCube.at_least_one with hx37have inverse := invCube.continuous with scale, atLeastOne38have same := retractCoordinate.definition at n, blk, a, j39rw same40exact mulCube.continuous with numerator, inverse4142theorem retractCoordinate.value (n : Nat) (blk a j x : Set)43requires ha : a ∈ unitCube(n)44requires hj : j ∈ n45requires hx : x ∈ unitCube(n)46shows retractCoordinate(n, blk, a, j)(x) = ((x(j):R) + (excessCube(n, blk, blk(j))(x):R) * (a(j):R)) * realInvValue((scaleCube(n, blk, blk(j))(x):R))47proof48have aj := unitCube.coordinate_real with ha, hj49have coordinate := coordinateCube.continuous with hj50have excess := excessCube.continuous at n, blk, blk(j)51have anchor := constantCube.continuous with aj52have shift := mulCube.continuous with excess, anchor53have numerator := addCube.continuous with coordinate, shift54have scale := scaleCube.continuous at n, blk, blk(j)55have atLeastOne : ∀ y ∈ unitCube(n), (1:R) ≤ (scaleCube(n, blk, blk(j))(y):R)56intros y hy57exact scaleCube.at_least_one with hy58have inverse := invCube.continuous with scale, atLeastOne59have coordinateFunction := CubeFunctionContinuous.function with coordinate60have excessFunction := CubeFunctionContinuous.function with excess61have anchorFunction := CubeFunctionContinuous.function with anchor62have shiftFunction := CubeFunctionContinuous.function with shift63have numeratorFunction := CubeFunctionContinuous.function with numerator64have scaleFunction := CubeFunctionContinuous.function with scale65have inverseFunction := CubeFunctionContinuous.function with inverse66have same := retractCoordinate.definition at n, blk, a, j67have product := mulCube.value with numeratorFunction, inverseFunction, hx68have sum := addCube.value with coordinateFunction, shiftFunction, hx69have shiftValue := mulCube.value with excessFunction, anchorFunction, hx70have coordinateValue := coordinateCube.value with hj, hx71have anchorValue := constantFunction.apply with hx, aj72have inverseValue := invCube.value with scaleFunction, hx73rw [same, product, sum, shiftValue, coordinateValue, anchorValue, inverseValue]74rfl7576-- Every retracted coordinate lies in [0, 1].77theorem retractCoordinate.bounds (n : Nat) (blk a j x : Set)78requires ha : a ∈ unitCube(n)79requires hj : j ∈ n80requires hx : x ∈ unitCube(n)81shows (0:R) ≤ (retractCoordinate(n, blk, a, j)(x):R) ∧ (retractCoordinate(n, blk, a, j)(x):R) ≤ (1:R)82proof83have value := retractCoordinate.value at n, blk, a, j, x with ha, hj, hx84have xInterval := unitCube.coordinate with hx, hj85obtain⟨xReal, xLower, xUpper⟩:= closedInterval.membership.forward with xInterval86have aInterval := unitCube.coordinate with ha, hj87obtain⟨aReal, aLower, aUpper⟩:= closedInterval.membership.forward with aInterval88have sumReal := blockSum.real at n, blk, blk(j), x with hx89have excessReal := excessCube.real at n, blk, blk(j), x with hx90have scaleReal := scaleCube.real at n, blk, blk(j), x with hx91have excessNonneg := excessCube.nonnegative at n, blk, blk(j), x with hx92have scaleAtLeastOne := scaleCube.at_least_one at n, blk, blk(j), x with hx93have sumExcess := scaleCube.sum_excess at n, blk, blk(j), x with hx94have termBound := blockSum.ge_coordinate at n, blk, x, j with hx, hj95obtain⟨inversePositive, inverseLe⟩:= realInvValue.le_one with scaleAtLeastOne96have inverseNonneg := realLess.implies_le with inversePositive97have shiftNonneg := realMulValue.nonnegative with excessNonneg, aLower98have numeratorNonneg : (0:R) ≤ (x(j):R) + (excessCube(n, blk, blk(j))(x):R) * (a(j):R) bylinarith99have scaleNonzero : (scaleCube(n, blk, blk(j))(x):R) ≠ (0:R)100intro zero101rw zero at scaleAtLeastOne102linarith103have cancel := realInvValue.mul_right with scaleNonzero104have shiftLe : (excessCube(n, blk, blk(j))(x):R) * (a(j):R) ≤ (excessCube(n, blk, blk(j))(x):R)105have step := realLe.mul_left_of_nonnegative with aUpper, excessNonneg106have one := realMulValue.one_right at excessCube(n, blk, blk(j))(x)107 rwa one at step108have numeratorLe : (x(j):R) + (excessCube(n, blk, blk(j))(x):R) * (a(j):R) ≤ (scaleCube(n, blk, blk(j))(x):R) bylinarith109have scaled := realLe.mul_right_of_nonnegative with numeratorLe, inverseNonneg110rw cancel at scaled111rw value112constructor113 . exact realMulValue.nonnegative with numeratorNonneg, inverseNonneg114 . exact scaled115116-- The family of retracted coordinates and the assembled retraction.117defgraph retractFamily (n blk a : Set) (j ∈ n) : functionSpace(unitCube(n), ℝ) := retractCoordinate(n, blk, a, j)118requires nNat : Nat(n)119requires ha : a ∈ unitCube(n)120proof121have continuous := retractCoordinate.continuous at n, blk, a, j with ha, member122have function := CubeFunctionContinuous.function with continuous123have between : retractCoordinate(n, blk, a, j) : unitCube(n) → ℝ124exact CubeFunction.function with function125exact functionSpace.mem_iff.backward with between126127theorem retractFamily.coordinate (n : Nat) (blk a j : Set)128requires ha : a ∈ unitCube(n)129requires hj : j ∈ n130shows retractFamily(n, blk, a)(j) = retractCoordinate(n, blk, a, j)131proof132exact retractFamily.value at n, blk, a, j with*133134theorem retractFamily.continuous (n : Nat) (blk a : Set)135requires ha : a ∈ unitCube(n)136shows∀ j ∈ n, CubeFunctionContinuous(retractFamily(n, blk, a)(j), n)137proof138intros j hj139have same := retractFamily.coordinate at n, blk, a, j with ha, hj140rw same141exact retractCoordinate.continuous with ha, hj142143theorem retractFamily.functions (n : Nat) (blk a : Set)144requires ha : a ∈ unitCube(n)145shows∀ j ∈ n, CubeFunction(retractFamily(n, blk, a)(j), n)146proof147intros j hj148have continuous := retractFamily.continuous at n, blk, a with ha149exact CubeFunctionContinuous.function with (continuous with hj)150151theorem retractFamily.bounds (n : Nat) (blk a : Set)152requires ha : a ∈ unitCube(n)153shows∀ j ∈ n, ∀ x ∈ unitCube(n), (0:R) ≤ (retractFamily(n, blk, a)(j)(x):R) ∧ (retractFamily(n, blk, a)(j)(x):R) ≤ (1:R)154proof155intros j hj x hx156have same := retractFamily.coordinate at n, blk, a, j with ha, hj157rw same158exact retractCoordinate.bounds with ha, hj, hx159160def retraction (n blk a : Set) : Set:= assembledMap(n, retractFamily(n, blk, a))161162theorem retraction.definition (n blk a : Set)163shows retraction(n, blk, a) = assembledMap(n, retractFamily(n, blk, a))164proof165unfold retraction166rfl167168theorem retraction.continuous (n : Nat) (blk a : Set)169requires ha : a ∈ unitCube(n)170shows CubeContinuous(retraction(n, blk, a), n)171proof172have family := retractFamily.continuous at n, blk, a with ha173have bounds := retractFamily.bounds at n, blk, a with ha174have same := retraction.definition at n, blk, a175rw same176exact assembledMap.continuous with family, bounds177178theorem retraction.map (n : Nat) (blk a : Set)179requires ha : a ∈ unitCube(n)180shows CubeMap(retraction(n, blk, a), n)181proof182have continuous := retraction.continuous at n, blk, a with ha183exact continuous.left184185theorem retraction.in_cube (n : Nat) (blk a x : Set)186requires ha : a ∈ unitCube(n)187requires hx : x ∈ unitCube(n)188shows retraction(n, blk, a)(x) ∈ unitCube(n)189proof190have map := retraction.map at n, blk, a with ha191have function := CubeMap.function with map192exact FunctionBetween.apply_closed with function, hx193194theorem retraction.coordinate (n : Nat) (blk a x j : Set)195requires ha : a ∈ unitCube(n)196requires hx : x ∈ unitCube(n)197requires hj : j ∈ n198shows retraction(n, blk, a)(x)(j) = ((x(j):R) + (excessCube(n, blk, blk(j))(x):R) * (a(j):R)) * realInvValue((scaleCube(n, blk, blk(j))(x):R))199proof200have functions := retractFamily.functions at n, blk, a with ha201have bounds := retractFamily.bounds at n, blk, a with ha202have same := retraction.definition at n, blk, a203have assembled := assembledMap.coordinate with functions, bounds, hx, hj204have family := retractFamily.coordinate at n, blk, a, j with ha, hj205rw [same, assembled, family]206exact retractCoordinate.value with ha, hj, hx207208-- Every block of the retracted point sums to one, so the retraction lands in209-- the product of simplices, and it fixes every point of the product.210theorem retraction.block_sum (n : Nat) (m blk a x p : Set)211requires blkFunction : blk : n → m212requires ha : a ∈ simplexProduct(n, m, blk)213requires hx : x ∈ unitCube(n)214requires hp : p ∈ m215shows blockSum(n, blk, p)(retraction(n, blk, a)(x)) = (1:R)216proof217have aCube := simplexProduct.cube with ha218have anchor := simplexProduct.block_sum with ha, hp219have image := retraction.in_cube at n, blk, a, x with aCube, hx220have shifted : ∀ j ∈ n, j ∈ blockSet(n, blk, p) → retraction(n, blk, a)(x)(j) = ((x(j):R) + (excessCube(n, blk, p)(x):R) * (a(j):R)) * realInvValue((scaleCube(n, blk, p)(x):R))221intros j hj inBlock222have parts := blockSet.membership.forward with inBlock223have block := parts.right224have value := retraction.coordinate at n, blk, a, x, j with aCube, hx, hj225 rwa block at value226have sumSame := blockSum.definition at n, blk, p227have affine := sumCube.affine with hx, aCube, image, shifted228rw sumSame at affine229have sumExcess := scaleCube.sum_excess at n, blk, p, x with hx230have scaleAtLeastOne := scaleCube.at_least_one at n, blk, p, x with hx231have scaleNonzero : (scaleCube(n, blk, p)(x):R) ≠ (0:R)232intro zero233rw zero at scaleAtLeastOne234linarith235have cancel := realInvValue.mul_right with scaleNonzero236have one := realMulValue.one_right at excessCube(n, blk, p)(x)237 rwa [affine, anchor, one, sumExcess]238239theorem retraction.in_product (n : Nat) (m blk a x : Set)240requires blkFunction : blk : n → m241requires ha : a ∈ simplexProduct(n, m, blk)242requires hx : x ∈ unitCube(n)243shows retraction(n, blk, a)(x) ∈ simplexProduct(n, m, blk)244proof245have aCube := simplexProduct.cube with ha246apply simplexProduct.membership.backward247constructor248 . exact retraction.in_cube with aCube, hx249 . intros p hp250exact retraction.block_sum with blkFunction, ha, hx, hp251252theorem retraction.fixed (n : Nat) (m blk a x : Set)253requires blkFunction : blk : n → m254requires ha : a ∈ simplexProduct(n, m, blk)255requires hx : x ∈ simplexProduct(n, m, blk)256shows retraction(n, blk, a)(x) = x257proof258have aCube := simplexProduct.cube with ha259have xCube := simplexProduct.cube with hx260have image := retraction.in_cube at n, blk, a, x with aCube, xCube261have imageFunction := unitCube.point with image262have xFunction := unitCube.point with xCube263apply FunctionBetween.ext with imageFunction, xFunction264intros j hj265have value := retraction.coordinate at n, blk, a, x, j with aCube, xCube, hj266have block := FunctionBetween.apply_closed with blkFunction, hj267have sumOne := simplexProduct.block_sum with hx, block268have excessValue := excessCube.value at n, blk, blk(j), x with xCube269have scaleValue := scaleCube.value at n, blk, blk(j), x with xCube270rw sumOne at excessValue271rw sumOne at scaleValue272have shift : (1:R) + -(1:R) = (0:R) bylinarith273rw shift at excessValue274have excessZero := realMax.of_le with (realLe.reflexive at (0:R))275have scaleOne := realMax.of_le with (realLe.reflexive at (1:R))276rw excessZero at excessValue277rw scaleOne at scaleValue278have oneNonzero : (1:R) ≠ (0:R)279intro equal280linarith281have inverseOne : realInvValue((1:R)) = (1:R)282have cancel := realInvValue.mul_right with oneNonzero283have one := realMulValue.one_left at realInvValue((1:R))284 rwa one at cancel285have xj := unitCube.coordinate_real with xCube, hj286have aj := unitCube.coordinate_real with aCube, hj287rw [value, excessValue, scaleValue, inverseOne]288ring289