Use a direct N-way unzip instead of induction over product size
This makes a finite-height proof for any `Fin n -> a` lattice immediate, and precludes the need for IterProd and Prod altogether. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -1,44 +0,0 @@
|
||||
import Spa.Lattice.Prod
|
||||
import Spa.Lattice.Unit
|
||||
|
||||
/-!
|
||||
|
||||
# Iterated Products
|
||||
|
||||
Given two types $\alpha$ and $\beta$ and a number $n$, produces
|
||||
an iterated product:
|
||||
|
||||
$$
|
||||
\overbrace{\alpha \times \ldots \times \alpha}^{n\ \text{times}} × \beta
|
||||
$$
|
||||
|
||||
This is mostly a stepping stone for isomorphisms. In
|
||||
`Spa/Lattice/Prod.lean`, By decomposing types such as `Fin n → α` into
|
||||
`IterProd α PUnit n`, we can automatically get a proof of their finite
|
||||
height via `Spa.FiniteHeightLattice.transport`.
|
||||
|
||||
-/
|
||||
|
||||
namespace Spa
|
||||
|
||||
universe u
|
||||
|
||||
def IterProd (A B : Type u) : ℕ → Type u
|
||||
| 0 => B
|
||||
| k + 1 => A × IterProd A B k
|
||||
|
||||
namespace IterProd
|
||||
|
||||
variable {A B : Type u}
|
||||
|
||||
def fixedHeight [FiniteHeightLattice A] [FiniteHeightLattice B] :
|
||||
∀ k, FiniteHeightLattice (IterProd A B k)
|
||||
| 0 => inferInstanceAs (FiniteHeightLattice B)
|
||||
| k + 1 => @Spa.prod A (IterProd A B k) _ (fixedHeight k)
|
||||
|
||||
instance finiteHeight [FiniteHeightLattice A] [FiniteHeightLattice B] (k : ℕ) :
|
||||
FiniteHeightLattice (IterProd A B k) := fixedHeight k
|
||||
|
||||
end IterProd
|
||||
|
||||
end Spa
|
||||
@@ -1,120 +0,0 @@
|
||||
import Spa.Lattice
|
||||
|
||||
/-!
|
||||
|
||||
# Product Lattice
|
||||
|
||||
This file provides a proof that, in addition to being a lattice,
|
||||
the product of two types $\alpha \times \beta$ forms a `Spa.FiniteHeightLattice`
|
||||
if both $\alpha$ and $\beta$ have a finite height.
|
||||
|
||||
The proof proceeds by "unzipping" a chain:
|
||||
|
||||
$$
|
||||
(a_1, b_1) < (a_1, b_2) < \ldots < (a_n, b_m)
|
||||
$$
|
||||
|
||||
In which, at each step, either an $\alpha$ or $\beta$ element
|
||||
might ratchet up, into two chains:
|
||||
|
||||
$$
|
||||
\begin{aligned}
|
||||
a_1 < \ldots < a_n \\
|
||||
b_1 < \ldots < b_m
|
||||
\end{aligned}
|
||||
$$
|
||||
|
||||
Because at least one of the two "unzipped" chains grows with
|
||||
each element of the product chain, the full chain length
|
||||
can't exceed the sum of the two components. By the definition
|
||||
of finite height, these two chains are bounded, and therefore,
|
||||
the product chain is bounded too.
|
||||
|
||||
-/
|
||||
|
||||
namespace Spa
|
||||
|
||||
section Unzip
|
||||
|
||||
variable {α β : Type*} [PartialOrder α] [PartialOrder β]
|
||||
|
||||
/-- The unzipping lemma: any chain (`LTSeries`) of product
|
||||
elements can be decomposed into chains of components,
|
||||
whose lengths bound the chain. -/
|
||||
lemma LTSeries.exists_unzip (c : LTSeries (α × β)) :
|
||||
∃ (c₁ : LTSeries α) (c₂ : LTSeries β),
|
||||
c₁.head = c.head.1 ∧ c₁.last = c.last.1 ∧
|
||||
c₂.head = c.head.2 ∧ c₂.last = c.last.2 ∧
|
||||
c.length ≤ c₁.length + c₂.length := by
|
||||
suffices H : ∀ (n : ℕ) (c : LTSeries (α × β)), c.length = n →
|
||||
∃ (c₁ : LTSeries α) (c₂ : LTSeries β),
|
||||
c₁.head = c.head.1 ∧ c₁.last = c.last.1 ∧
|
||||
c₂.head = c.head.2 ∧ c₂.last = c.last.2 ∧
|
||||
c.length ≤ c₁.length + c₂.length from H c.length c rfl
|
||||
intro n
|
||||
induction n with
|
||||
| zero =>
|
||||
intro c hn
|
||||
refine ⟨RelSeries.singleton _ c.head.1, RelSeries.singleton _ c.head.2,
|
||||
rfl, ?_, rfl, ?_, by simp [hn]⟩ <;>
|
||||
· have hlast : Fin.last c.length = 0 := by ext; simp [hn]
|
||||
simp [RelSeries.last, RelSeries.head, hlast]
|
||||
| succ n ih =>
|
||||
intro c hn
|
||||
have h0 : c.length ≠ 0 := by omega
|
||||
haveI : NeZero c.length := ⟨h0⟩
|
||||
obtain ⟨c₁, c₂, hh₁, hl₁, hh₂, hl₂, hlen⟩ :=
|
||||
ih (c.tail h0) (by simp [RelSeries.tail_length, hn])
|
||||
rw [RelSeries.last_tail] at hl₁ hl₂
|
||||
rw [RelSeries.head_tail] at hh₁ hh₂
|
||||
rw [RelSeries.tail_length] at hlen
|
||||
have hstep : c.head < c 1 := c.strictMono Fin.one_pos'
|
||||
obtain ⟨hle1, hle2⟩ := Prod.le_def.mp hstep.le
|
||||
rcases eq_or_lt_of_le hle1 with heq1 | hlt1 <;>
|
||||
rcases eq_or_lt_of_le hle2 with heq2 | hlt2
|
||||
· exact absurd (Prod.ext heq1 heq2) hstep.ne
|
||||
· refine ⟨c₁, c₂.cons c.head.2 (hh₂ ▸ hlt2),
|
||||
hh₁.trans heq1.symm, hl₁, RelSeries.head_cons .., by
|
||||
rw [RelSeries.last_cons]; exact hl₂, by
|
||||
simp only [RelSeries.cons_length]; omega⟩
|
||||
· refine ⟨c₁.cons c.head.1 (hh₁ ▸ hlt1), c₂,
|
||||
RelSeries.head_cons .., by
|
||||
rw [RelSeries.last_cons]; exact hl₁,
|
||||
hh₂.trans heq2.symm, hl₂, by
|
||||
simp only [RelSeries.cons_length]; omega⟩
|
||||
· refine ⟨c₁.cons c.head.1 (hh₁ ▸ hlt1), c₂.cons c.head.2 (hh₂ ▸ hlt2),
|
||||
RelSeries.head_cons .., by
|
||||
rw [RelSeries.last_cons]; exact hl₁,
|
||||
RelSeries.head_cons .., by
|
||||
rw [RelSeries.last_cons]; exact hl₂, by
|
||||
simp only [RelSeries.cons_length]; omega⟩
|
||||
|
||||
end Unzip
|
||||
|
||||
section FixedHeight
|
||||
|
||||
variable {α β : Type*}
|
||||
|
||||
/-- The longest possible chain is one in which only one of the components grows
|
||||
at a time, making the maximum height of $\alpha \times \beta$ be
|
||||
$\text{height}_\alpha + \text{height}_\beta$. -/
|
||||
instance prod [A : FiniteHeightLattice α] [B : FiniteHeightLattice β] :
|
||||
FiniteHeightLattice (α × β) where
|
||||
toLattice := inferInstance
|
||||
longestChain :=
|
||||
RelSeries.smash
|
||||
(A.longestChain.map (fun a => (a, (⊥ : β)))
|
||||
(fun _ _ h => Prod.mk_lt_mk_iff_left.mpr h))
|
||||
(B.longestChain.map (fun b => ((⊤ : α), b))
|
||||
(fun _ _ h => Prod.mk_lt_mk_iff_right.mpr h))
|
||||
rfl
|
||||
chains_bounded := fun c => by
|
||||
obtain ⟨c₁, c₂, -, -, -, -, hlen⟩ := LTSeries.exists_unzip c
|
||||
have h₁ := A.chains_bounded c₁
|
||||
have h₂ := B.chains_bounded c₂
|
||||
show c.length ≤ A.longestChain.length + B.longestChain.length
|
||||
omega
|
||||
|
||||
end FixedHeight
|
||||
|
||||
end Spa
|
||||
@@ -1,63 +1,171 @@
|
||||
import Spa.Lattice.IterProd
|
||||
import Spa.Lattice
|
||||
import Mathlib.Data.Fin.Tuple.Basic
|
||||
import Mathlib.Algebra.Order.BigOperators.Group.Finset
|
||||
|
||||
/-!
|
||||
|
||||
# Finite Tuple Lattices
|
||||
|
||||
This file provides a proof that, in addition to being a lattice, the function
|
||||
space `Fin n → β` is itself a `Spa.FiniteHeightLattice` if the element type
|
||||
`β` is a lattice.
|
||||
|
||||
Finite tuple lattices are the workhorse behind `FiniteMap`, whose carrier is
|
||||
`Fin ks.length → β`.
|
||||
|
||||
The proof proceeds by "unzipping" a chain (`LTSeries`):
|
||||
|
||||
$$
|
||||
(a_1, b_1, c_1) < \ldots < (a_1, b_1, c_o) < \ldots < (a_1, b_m, c_o) <
|
||||
\ldots < (a_n, b_m, c_o)
|
||||
$$
|
||||
|
||||
In which, at each step, at least one of the components must have increased
|
||||
(otherwise, the chain is not striclty increasing), into `n` chains
|
||||
(`LTSeries`).
|
||||
|
||||
$$
|
||||
\begin{aligned}
|
||||
a_1 < \ldots < a_n \\
|
||||
b_1 < \ldots < b_m \
|
||||
c_1 < \ldots < c_o \
|
||||
\end{aligned}
|
||||
$$
|
||||
|
||||
Because at least one of the two "unzipped" chains grows with each element of
|
||||
the product chain, the full chain length can't exceed the sum of the
|
||||
components. By the definition of finite height, these two chains are bounded,
|
||||
and therefore, the product chain is bounded too. -/
|
||||
|
||||
namespace Spa
|
||||
|
||||
namespace Tuple
|
||||
|
||||
universe u
|
||||
variable {β : Type*}
|
||||
|
||||
variable {B : Type u}
|
||||
section Unzip
|
||||
|
||||
private def iterOfFun : {n : ℕ} → (Fin n → B) → IterProd B PUnit n
|
||||
| 0, _ => PUnit.unit
|
||||
| _ + 1, f => (f 0, iterOfFun (Fin.tail f))
|
||||
variable [PartialOrder β]
|
||||
|
||||
private def funOfIter : {n : ℕ} → IterProd B PUnit n → (Fin n → B)
|
||||
| 0, _ => Fin.elim0
|
||||
| _ + 1, ip => Fin.cons ip.1 (funOfIter ip.2)
|
||||
open Classical in -- chain bounds are in Prop, so classical helps here.
|
||||
/-- The generalized unzip: any chain in `Fin n → β` decomposes into a family of
|
||||
per-tuple-coordinate chains in `β`, agreeing with the original at each end, whose
|
||||
lengths sum to an upper bound on the original chain's length. -/
|
||||
lemma exists_unzip {n : ℕ} (c : LTSeries (Fin n → β)) :
|
||||
∃ cs : Fin n → LTSeries β,
|
||||
(∀ i, (cs i).head = c.head i) ∧ (∀ i, (cs i).last = c.last i) ∧
|
||||
c.length ≤ ∑ i, (cs i).length := by
|
||||
suffices H : ∀ (m : ℕ) (c : LTSeries (Fin n → β)), c.length = m →
|
||||
∃ cs : Fin n → LTSeries β,
|
||||
(∀ i, (cs i).head = c.head i) ∧ (∀ i, (cs i).last = c.last i) ∧
|
||||
c.length ≤ ∑ i, (cs i).length from H c.length c rfl
|
||||
intro m
|
||||
induction m with
|
||||
| zero =>
|
||||
intro c hn
|
||||
have hlast : (Fin.last c.length) = 0 := by ext; simp [hn]
|
||||
have hhl : c.last = c.head := by rw [RelSeries.last, RelSeries.head, hlast]
|
||||
refine ⟨fun i => RelSeries.singleton _ (c.head i), fun i => ?_, fun i => ?_, ?_⟩
|
||||
· exact RelSeries.head_singleton _
|
||||
· rw [RelSeries.last_singleton, hhl]
|
||||
· simp [hn, RelSeries.singleton]
|
||||
| succ m ih =>
|
||||
intro c hn
|
||||
have h0 : c.length ≠ 0 := by omega
|
||||
haveI : NeZero c.length := ⟨h0⟩
|
||||
obtain ⟨cs', hh', hl', hlen'⟩ := ih (c.tail h0) (by rw [RelSeries.tail_length]; omega)
|
||||
have hstep : c.head < c 1 := c.strictMono Fin.one_pos'
|
||||
obtain ⟨hle, j, hjlt⟩ := Pi.lt_def.mp hstep
|
||||
have hh'1 : ∀ i, (cs' i).head = c 1 i := fun i => by rw [hh' i, RelSeries.head_tail]
|
||||
refine ⟨fun i =>
|
||||
if hlt : c.head i < c 1 i then
|
||||
(cs' i).cons (c.head i) (by rw [hh'1 i]; exact hlt)
|
||||
else cs' i,
|
||||
fun i => ?_, fun i => ?_, ?_⟩
|
||||
· by_cases hlt : c.head i < c 1 i
|
||||
· simp only [dif_pos hlt, RelSeries.head_cons]
|
||||
· simp only [dif_neg hlt]
|
||||
rw [hh'1 i]
|
||||
exact ((lt_or_eq_of_le (hle i)).resolve_left hlt).symm
|
||||
· by_cases hlt : c.head i < c 1 i
|
||||
· simp only [dif_pos hlt, RelSeries.last_cons, hl' i, RelSeries.last_tail]
|
||||
· simp only [dif_neg hlt, hl' i, RelSeries.last_tail]
|
||||
· calc c.length
|
||||
= (c.tail h0).length + 1 := by rw [RelSeries.tail_length]; omega
|
||||
_ ≤ (∑ i, (cs' i).length) + 1 := Nat.add_le_add_right hlen' 1
|
||||
_ ≤ ∑ i, (if hlt : c.head i < c 1 i then
|
||||
(cs' i).cons (c.head i) (by rw [hh'1 i]; exact hlt) else cs' i).length :=
|
||||
Nat.succ_le_of_lt (Finset.sum_lt_sum (fun i _ => by
|
||||
split
|
||||
· rw [RelSeries.cons_length]; omega
|
||||
· exact le_rfl)
|
||||
⟨j, Finset.mem_univ j, by rw [dif_pos hjlt, RelSeries.cons_length]; omega⟩)
|
||||
|
||||
private lemma funOfIter_iterOfFun : ∀ {n : ℕ} (f : Fin n → B),
|
||||
funOfIter (iterOfFun f) = f
|
||||
| 0, _ => funext fun i => i.elim0
|
||||
| _ + 1, f => by
|
||||
show Fin.cons (f 0) (funOfIter (iterOfFun (Fin.tail f))) = f
|
||||
rw [funOfIter_iterOfFun (Fin.tail f), Fin.cons_self_tail]
|
||||
end Unzip
|
||||
|
||||
private lemma iterOfFun_funOfIter : ∀ {n : ℕ} (ip : IterProd B PUnit n),
|
||||
iterOfFun (funOfIter ip) = ip
|
||||
| 0, PUnit.unit => rfl
|
||||
| _ + 1, ip => by
|
||||
show (funOfIter ip 0, iterOfFun (Fin.tail (funOfIter ip))) = ip
|
||||
rw [show funOfIter ip = Fin.cons ip.1 (funOfIter ip.2) from rfl]
|
||||
simp [Fin.cons_zero, Fin.tail_cons, iterOfFun_funOfIter ip.2]
|
||||
section FiniteHeight
|
||||
|
||||
variable [FiniteHeightLattice B]
|
||||
variable [FiniteHeightLattice β]
|
||||
|
||||
private lemma funOfIter_mono {n : ℕ} :
|
||||
Monotone (funOfIter : IterProd B PUnit n → (Fin n → B)) := by
|
||||
induction n with
|
||||
| zero => intro _ _ _ i; exact i.elim0
|
||||
| succ n ih =>
|
||||
intro ip₁ ip₂ h i
|
||||
obtain ⟨h1, h2⟩ := Prod.le_def.mp h
|
||||
rw [show funOfIter ip₁ = Fin.cons ip₁.1 (funOfIter ip₁.2) from rfl,
|
||||
show funOfIter ip₂ = Fin.cons ip₂.1 (funOfIter ip₂.2) from rfl]
|
||||
induction i using Fin.cases with
|
||||
| zero => rw [Fin.cons_zero, Fin.cons_zero]; exact h1
|
||||
| succ j => rw [Fin.cons_succ, Fin.cons_succ]; exact ih h2 j
|
||||
private lemma consBot_strictMono {n : ℕ} :
|
||||
StrictMono (fun b : β => (Fin.cons b (⊥ : Fin n → β) : Fin (n + 1) → β)) := by
|
||||
intro a b hab
|
||||
refine lt_iff_le_and_ne.mpr ⟨?_, ?_⟩
|
||||
· refine Pi.le_def.mpr (fun i => Fin.cases ?_ (fun j => ?_) i)
|
||||
· simpa using hab.le
|
||||
· simp
|
||||
· exact fun h => hab.ne (by simpa using congrFun h 0)
|
||||
|
||||
private lemma iterOfFun_mono {n : ℕ} :
|
||||
Monotone (iterOfFun : (Fin n → B) → IterProd B PUnit n) := by
|
||||
induction n with
|
||||
| zero => intro f g _; exact le_of_eq rfl
|
||||
| succ n ih =>
|
||||
intro f g h
|
||||
exact Prod.le_def.mpr ⟨h 0, ih fun i => h i.succ⟩
|
||||
private lemma consTop_strictMono {n : ℕ} :
|
||||
StrictMono (fun f : Fin n → β => (Fin.cons (⊤ : β) f : Fin (n + 1) → β)) := by
|
||||
intro f g hfg
|
||||
refine lt_iff_le_and_ne.mpr ⟨?_, ?_⟩
|
||||
· refine Pi.le_def.mpr (fun i => Fin.cases ?_ (fun j => ?_) i)
|
||||
· simp
|
||||
· simpa using Pi.le_def.mp hfg.le j
|
||||
· intro h
|
||||
apply hfg.ne
|
||||
funext j
|
||||
simpa using congrFun h j.succ
|
||||
|
||||
instance instFiniteHeight {n : ℕ} :
|
||||
FiniteHeightLattice (Fin n → B) :=
|
||||
FiniteHeightLattice.transport funOfIter iterOfFun
|
||||
funOfIter_mono iterOfFun_mono iterOfFun_funOfIter funOfIter_iterOfFun
|
||||
/-- The maximal chain in `Fin n → β`: walk the first tuple element from `⊥` to `⊤`
|
||||
through `β`'s longest chain, then do that with the second element, and so on. -/
|
||||
private def stdChain : (n : ℕ) →
|
||||
{ s : LTSeries (Fin n → β) //
|
||||
s.head = (⊥ : Fin n → β) ∧
|
||||
s.length = n * (FiniteHeightLattice.longestChain (α := β)).length }
|
||||
| 0 => ⟨RelSeries.singleton _ ⊥, by rw [RelSeries.head_singleton], by simp⟩
|
||||
| n + 1 =>
|
||||
let prev := stdChain n
|
||||
⟨RelSeries.smash
|
||||
((FiniteHeightLattice.longestChain (α := β)).map
|
||||
(fun b => (Fin.cons b (⊥ : Fin n → β) : Fin (n + 1) → β)) consBot_strictMono)
|
||||
(prev.1.map (fun f => (Fin.cons (⊤ : β) f : Fin (n + 1) → β)) consTop_strictMono)
|
||||
(by rw [LTSeries.last_map, LTSeries.head_map, prev.2.1]; rfl),
|
||||
by
|
||||
simp only [RelSeries.head_smash, LTSeries.head_map]
|
||||
rw [show (FiniteHeightLattice.longestChain (α := β)).head = (⊥ : β) from rfl]
|
||||
funext i
|
||||
refine Fin.cases ?_ (fun j => ?_) i <;> simp [Pi.bot_apply],
|
||||
by
|
||||
show (FiniteHeightLattice.longestChain (α := β)).length + prev.1.length
|
||||
= (n + 1) * (FiniteHeightLattice.longestChain (α := β)).length
|
||||
rw [prev.2.2, Nat.succ_mul]; exact Nat.add_comm _ _⟩
|
||||
|
||||
instance instFiniteHeight {n : ℕ} : FiniteHeightLattice (Fin n → β) where
|
||||
toLattice := inferInstance
|
||||
longestChain := (stdChain n).1
|
||||
chains_bounded := fun c => by
|
||||
obtain ⟨cs, _, _, hbound⟩ := exists_unzip c
|
||||
refine hbound.trans ?_
|
||||
rw [(stdChain n).2.2]
|
||||
calc ∑ i, (cs i).length
|
||||
≤ ∑ _i : Fin n, (FiniteHeightLattice.longestChain (α := β)).length :=
|
||||
Finset.sum_le_sum (fun i _ => FiniteHeightLattice.chains_bounded (cs i))
|
||||
_ = n * (FiniteHeightLattice.longestChain (α := β)).length := by
|
||||
simp [Finset.sum_const, Finset.card_univ, Fintype.card_fin]
|
||||
|
||||
end FiniteHeight
|
||||
|
||||
end Tuple
|
||||
|
||||
|
||||
@@ -5,9 +5,7 @@ import Spa.Lattice
|
||||
# Unit Lattice
|
||||
|
||||
This file provides a proof that in addition to being a lattice,
|
||||
`PUnit` is a `Spa.FiniteHeightLattice`. This is fairly trivial result,
|
||||
but the unit is used as a placeholder in various contexts (e.g.,
|
||||
as a base case for the iterated product `Spa/Lattice/IterProd.lean`). -/
|
||||
`PUnit` is a `Spa.FiniteHeightLattice`. This is a fairly trivial result. -/
|
||||
|
||||
namespace Spa
|
||||
|
||||
|
||||
Reference in New Issue
Block a user