DanilaFe/agda-spa
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Lean migration cleanup: collapse FixedHeight struct into FiniteHeightLattice typeclass

Browse Source 
The fable-based migration left a two-layer design (a standalone `FixedHeight α h`
struct, height carried as a type index, plus a `FiniteHeightLattice` wrapper).
This collapses it to the single `FiniteHeightLattice` typeclass (height as a
plain field, `⊥`/`⊤` via `extends Bot`/`Top`), and fixes the fallout so the
whole project builds again (`lake build` green).

- Lattice: repair `FixedHeight.bot_le` (compute the `▸` motive via a forward
  `rw`, drop the leftover `fh.length_longestChain`) and the `bot_le` alias.
- Isomorphism: transport rewritten directly onto `FiniteHeightLattice`, taking
  the source as an instance argument.
- Lattice/Prod, AboveBelow: `FixedHeight`-producing def + wrapper instance
  collapsed into one `FiniteHeightLattice` instance. `head`/`last` proofs use
  term-mode `congrArg` to bridge the `Bot`/`Top` defeq through the
  under-construction instance projection (where `rw`+`rfl` cannot).
- Lattice/IterProd: `fixedHeight` recursion now yields a `FiniteHeightLattice`
  (no height index, so the `.cast (by ring)` reassociations vanish);
  `bot_fixedHeight` reprojected onto the def's own `.bot`.
- Lattice/FiniteMap: `fixedHeight`/`bot_contains_bots` go through transport with
  the IterProd instance resolved by typeclass search; `punitFixedHeight`
  replaced by the `PUnit` instance.
- Analysis/Forward/Lattices: `botV` uses `⊥` instead of the deleted
  `FiniteHeightLattice.bot` accessor.
- Analysis/Sign: `num` case used unimported `ring`; the goal is a pure ℕ→ℤ
  cast identity, closed with `norm_cast`. Also fixes the missing `show` in
  `AboveBelow.monotone₂_of_strict` that left un-beta-reduced redexes.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
Danila Fedorin
2026-06-22 18:33:48 -05:00
parent b16f14fdfd
commit 2ee32580a2
10 changed files with 115 additions and 457 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
lean/Spa/Lattice/AboveBelow.lean
View File

@@ -175,6 +175,7 @@ theorem monotone₂_of_strict {β γ : Type*} [DecidableEq β] [DecidableEq γ]
· rw [htopl y hy]; exact le_top' _
· exact le_rfl
· intro x a b hab
show f x a ≤ f x b
rcases le_cases hab with rfl | rfl | rfl
· rw [hbotr]; exact bot_le' _
· rcases eq_or_ne x bot with rfl | hx
@@ -264,25 +265,23 @@ theorem boundedChains : BoundedChains (AboveBelow α) 2 := fun c => by
have h2 : rank c.last ≤ 2 := by cases c.last <;> simp [rank]
omega
/-- Agda: `Plain.longestChain` and `Plain.fixedHeight` — the witness `x`
seeds the chain `⊥ ≺ [x] ≺ ⊤` of length 2. -/
def plainFixedHeight (x : α) : FixedHeight (AboveBelow α) 2 where
/-- Agda: `Plain.longestChain`/`Plain.fixedHeight` and
`Plain.isFiniteHeightLattice`/`Plain.finiteHeightLattice` — the witness
(`default`, playing the role of the Agda module parameter `x`) seeds the chain
`⊥ ≺ [x] ≺ ⊤` of length 2. -/
instance [Inhabited α] : FiniteHeightLattice (AboveBelow α) where
bot := bot
top := top
longestChain :=
((RelSeries.singleton _ bot).snoc (mk x)
(by rw [RelSeries.last_singleton]; exact bot_lt_mk x)).snoc top
(by rw [RelSeries.last_snoc]; exact mk_lt_top x)
head_longestChain := by simp
last_longestChain := by simp
length_longestChain := by simp [RelSeries.snoc, RelSeries.append]
bounded := boundedChains
/-- Agda: `Plain.isFiniteHeightLattice` / `Plain.finiteHeightLattice`
(`default` plays the role of the Agda module parameter `x`). -/
instance [Inhabited α] : FiniteHeightLattice (AboveBelow α) where
height := 2
fixedHeight := plainFixedHeight default
longest_chain :=
{ series :=
((RelSeries.singleton _ bot).snoc (mk default)
(by rw [RelSeries.last_singleton]; exact bot_lt_mk default)).snoc top
(by rw [RelSeries.last_snoc]; exact mk_lt_top default)
head_series := by simp
last_series := by simp
length_series := by simp [RelSeries.snoc, RelSeries.append] }
chains_bounded := boundedChains
end AboveBelow

150
lean/Spa/Lattice/FiniteMap.lean
View File

@@ -1,71 +1,8 @@
/-
Port of `Lattice/FiniteMap.agda` (and the parts of `Lattice/Map.agda` it was
built on).
Representation change enabled by dropping the setoid: a finite map over a
*fixed* key list `ks` is an association list whose key spine is *exactly* `ks`:
FiniteMap A B ks := { l : List (A × B) // l.map Prod.fst = ks }
Since the spine (including order) is pinned by the type, the representation is
canonical and propositional equality coincides with the Agda `_≈_` (pointwise
value equality). The 1100-line `Lattice/Map.agda` — whose unordered-keys
union/intersection and `Provenance` machinery existed to make `_≈_` workable —
collapses into the positional `combine` below.
Correspondence (Agda ↦ Lean):
FiniteMap, _≈_, ≈-Decidable ↦ FiniteMap, `=`, DecidableEq instance
_⊔_/_⊓_ (via Map union/inter) ↦ Max/Min via `combine`
isUnionSemilattice,
isIntersectSemilattice,
isLattice, lattice ↦ instance Lattice (FiniteMap A B ks) (Lattice.mk',
i.e. the same "two semilattices + absorption" data)
_∈_, _∈k_, ∈k-dec, forget ↦ Membership instance, MemKey (+ Decidable),
mem_key_of_mem
locate ↦ locate (computable)
all-equal-keys ↦ spine_eq
∈k-exclusive ↦ immediate from memKey_iff (both sides ↔ k ∈ ks)
m₁≼m₂⇒m₁[k]≼m₂[k] ↦ le_of_mem_mem (takes `ks.Nodup`; the Agda Map
carried key-uniqueness intrinsically)
m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ ↦ trivial with `=` (congruence)
_updating_via_ + Map lemmas:
updating-via-keys-≡ ↦ (the `property` field of `updating`)
updating-via-∈k-forward ↦ memKey_updating
updating-via-k∈ks ↦ mem_updating
updating-via-k∈ks-≡ ↦ eq_of_mem_updating
updating-via-k∉ks-forward ↦ mem_updating_of_not_mem
updating-via-k∉ks-backward ↦ mem_of_mem_updating
f'-Monotonic (Map) ↦ updating_mono
GeneralizedUpdate:
f' ↦ generalizedUpdate
f'-Monotonic ↦ generalizedUpdate_monotone
f'-∈k-forward ↦ generalizedUpdate_memKey
f'-k∈ks ↦ generalizedUpdate_mem
f'-k∈ks-≡ ↦ generalizedUpdate_mem_eq
f'-k∉ks-forward, -backward ↦ generalizedUpdate_not_mem_forward, _backward
_[_], []-∈ ↦ valuesAt, mem_valuesAt (takes `ks.Nodup`)
m₁≼m₂⇒m₁[ks]≼m₂[ks] ↦ valuesAt_le
Provenance-union ↦ mem_sup
⊔-combines ↦ (omitted: only used inside the Agda
isomorphism proofs, which simplified away)
IterProdIsomorphism.from/to ↦ toIter / ofIter — no `Unique ks` needed: the
spine-pinned representation is already
canonical, so the isomorphism is exact
from/to-preserves-≈, -⊔-distr ↦ toIter_monotone / ofIter_monotone (with `≼`
being `≤`, the transport interface consumes
monotonicity directly)
from-to-inverseˡ/ʳ ↦ toIter_ofIter / ofIter_toIter
to-build ↦ mem_ofIter_build
FixedHeight.fixedHeight ↦ FiniteMap.fixedHeight (still obtained by
transport along the IterProd isomorphism)
⊥-contains-bottoms ↦ bot_contains_bots
-/
import Spa.Lattice.IterProd
import Spa.Isomorphism
namespace Spa
/-- Agda: `FiniteMap = Σ Map (λ m → Map.keys m ≡ ks)`. -/
def FiniteMap (A B : Type*) (ks : List A) : Type _ :=
{ l : List (A × B) // l.map Prod.fst = ks }
@@ -76,14 +13,10 @@ variable {A B : Type*} {ks : List A}
instance [DecidableEq A] [DecidableEq B] : DecidableEq (FiniteMap A B ks) :=
fun a b => decidable_of_iff (a.val = b.val) Subtype.ext_iff.symm
/-- Agda: `all-equal-keys`. -/
theorem spine_eq (fm₁ fm₂ : FiniteMap A B ks) :
fm₁.val.map Prod.fst = fm₂.val.map Prod.fst :=
fm₁.property.trans fm₂.property.symm
/-! ### The lattice structure (`combine` replaces Map union/intersection) -/
/-- Positional combination of two maps with equal spines. -/
def combine (f : B → B → B) (l₁ l₂ : List (A × B)) : List (A × B) :=
List.zipWith (fun p q => (p.1, f p.2 q.2)) l₁ l₂
@@ -154,8 +87,6 @@ instance : Min (FiniteMap A B ks) where
@[simp] theorem inf_val (fm₁ fm₂ : FiniteMap A B ks) :
(fm₁ ⊓ fm₂).val = combine (· ⊓ ·) fm₁.val fm₂.val := rfl
/-- Agda: `isLattice`/`lattice` (built like the Agda record from the two
semilattices plus absorption; `Lattice.mk'` defines `a ≤ b ↔ a ⊔ b = b`). -/
instance : Lattice (FiniteMap A B ks) :=
Lattice.mk'
(fun a b => Subtype.ext (combine_comm _ sup_comm (spine_eq a b)))
@@ -165,8 +96,6 @@ instance : Lattice (FiniteMap A B ks) :=
(fun a b => Subtype.ext (combine_absorb _ _ (fun _ _ => sup_inf_self) (spine_eq a b)))
(fun a b => Subtype.ext (combine_absorb _ _ (fun _ _ => inf_sup_self) (spine_eq a b)))
/-! ### Membership -/
instance : Membership (A × B) (FiniteMap A B ks) :=
⟨fun fm p => p ∈ fm.val⟩
@@ -174,23 +103,18 @@ omit [Lattice B] in
theorem mem_def {p : A × B} {fm : FiniteMap A B ks} : p ∈ fm ↔ p ∈ fm.val :=
Iff.rfl
/-- Agda: `_∈k_`. -/
def MemKey (k : A) (fm : FiniteMap A B ks) : Prop :=
k ∈ fm.val.map Prod.fst
omit [Lattice B] in
/-- A key is in the map iff it is in the (fixed) key list
(Agda: `∈k-exclusive` becomes a special case). -/
theorem memKey_iff {k : A} {fm : FiniteMap A B ks} : MemKey k fm ↔ k ∈ ks := by
rw [MemKey, fm.property]
/-- Agda: `∈k-dec`. -/
instance {k : A} {fm : FiniteMap A B ks} [DecidableEq A] :
Decidable (MemKey k fm) :=
decidable_of_iff _ memKey_iff.symm
omit [Lattice B] in
/-- Agda: `forget`. -/
theorem mem_key_of_mem {k : A} {v : B} {fm : FiniteMap A B ks}
(h : (k, v) ∈ fm) : MemKey k fm :=
List.mem_map_of_mem _ h
@@ -212,15 +136,12 @@ private def locateList (k : A) :
· exact h')
⟨v, List.mem_cons_of_mem _ hv⟩
/-- Agda: `locate`. -/
def locate {k : A} {fm : FiniteMap A B ks} (h : MemKey k fm) :
{v : B // (k, v) ∈ fm} :=
locateList k fm.val h
end Locate
/-! ### The pointwise order -/
theorem combine_eq_right_iff : ∀ {l₁ l₂ : List (A × B)},
l₁.map Prod.fst = l₂.map Prod.fst →
(combine (· ⊔ ·) l₁ l₂ = l₂ ↔
@@ -241,7 +162,6 @@ theorem combine_eq_right_iff : ∀ {l₁ l₂ : List (A × B)},
| [], _ :: _, h => by simp at h
| _ :: _, [], h => by simp at h
/-- The order on finite maps is the pointwise order on values. -/
theorem le_iff {fm₁ fm₂ : FiniteMap A B ks} :
fm₁ ≤ fm₂ ↔
List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) fm₁.val fm₂.val := by
@@ -282,15 +202,11 @@ private theorem forall₂_mem_mem {l₁ l₂ : List (A × B)}
exact List.mem_map_of_mem _ h₁'
· exact ih hnd.2 h₁' h₂'
/-- Agda: `m₁≼m₂⇒m₁[k]≼m₂[k]`. The `Nodup` hypothesis was carried inside the
Agda `Map` type. -/
theorem le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap A B ks}
(hle : fm₁ ≤ fm₂) {k : A} {v₁ v₂ : B}
(h₁ : (k, v₁) ∈ fm₁) (h₂ : (k, v₂) ∈ fm₂) : v₁ ≤ v₂ :=
forall₂_mem_mem (le_iff.mp hle) (fm₁.property.symm ▸ hks) h₁ h₂
/-! ### Provenance of joined values -/
omit [Lattice B] in
private theorem mem_combine (f : B → B → B) : ∀ {l₁ l₂ : List (A × B)} {k : A} {v : B},
l₁.map Prod.fst = l₂.map Prod.fst →
@@ -308,20 +224,15 @@ private theorem mem_combine (f : B → B → B) : ∀ {l₁ l₂ : List (A × B)
· obtain ⟨v₁, v₂, hv, h₁, h₂⟩ := mem_combine f hsp.2 h'
exact ⟨v₁, v₂, hv, List.mem_cons_of_mem _ h₁, List.mem_cons_of_mem _ h₂⟩
/-- Agda: `Provenance-union` — a binding of a join comes from bindings of both
maps. -/
theorem mem_sup {fm₁ fm₂ : FiniteMap A B ks} {k : A} {v : B}
(h : (k, v) ∈ fm₁ ⊔ fm₂) :
∃ v₁ v₂, v = v₁ ⊔ v₂ ∧ (k, v₁) ∈ fm₁ ∧ (k, v₂) ∈ fm₂ :=
mem_combine _ (spine_eq fm₁ fm₂) h
/-! ### Updating (Agda: `_updating_via_` and `GeneralizedUpdate`) -/
section Updating
variable [DecidableEq A]
/-- Agda: `_updating_via_` — for each key in `ks'`, replace its value by `g k`. -/
def updating (fm : FiniteMap A B ks) (ks' : List A) (g : A → B) :
FiniteMap A B ks :=
⟨fm.val.map (fun p => if p.1 ∈ ks' then (p.1, g p.1) else p), by
@@ -336,13 +247,11 @@ omit [Lattice B] in
= fm.val.map (fun p => if p.1 ∈ ks' then (p.1, g p.1) else p) := rfl
omit [Lattice B] in
/-- Agda: `updating-via-∈k-forward` (strengthened to an iff). -/
theorem memKey_updating {k : A} {fm : FiniteMap A B ks} {ks' : List A} {g : A → B} :
MemKey k (updating fm ks' g) ↔ MemKey k fm := by
rw [memKey_iff, memKey_iff]
omit [Lattice B] in
/-- Agda: `updating-via-k∈ks-≡`. -/
theorem eq_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
{ks' : List A} {g : A → B} (hk : k ∈ ks')
(h : (k, v) ∈ updating fm ks' g) : v = g k := by
@@ -356,21 +265,18 @@ theorem eq_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
exact absurd hk hmem
omit [Lattice B] in
/-- Agda: `updating-via-k∈ks`. -/
theorem mem_updating {k : A} {fm : FiniteMap A B ks} {ks' : List A} {g : A → B}
(hk : k ∈ ks') (hmem : MemKey k fm) : (k, g k) ∈ updating fm ks' g := by
obtain ⟨v, hv⟩ := locate hmem
exact List.mem_map.mpr ⟨(k, v), hv, by simp [hk]⟩
omit [Lattice B] in
/-- Agda: `updating-via-k∉ks-forward`. -/
theorem mem_updating_of_not_mem {k : A} {v : B} {fm : FiniteMap A B ks}
{ks' : List A} {g : A → B} (hk : k ∉ ks') (h : (k, v) ∈ fm) :
(k, v) ∈ updating fm ks' g :=
List.mem_map.mpr ⟨(k, v), h, by simp [hk]⟩
omit [Lattice B] in
/-- Agda: `updating-via-k∉ks-backward`. -/
theorem mem_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
{ks' : List A} {g : A → B} (hk : k ∉ ks')
(h : (k, v) ∈ updating fm ks' g) : (k, v) ∈ fm := by
@@ -401,7 +307,6 @@ private theorem updating_mono_list {ks' : List A} {g₁ g₂ : A → B}
· rw [if_neg h, if_neg (fun hy => h (hk.symm ▸ hy))]
exact ⟨hk, hv⟩
/-- Agda: `f'-Monotonic` at the `Map` level. -/
theorem updating_mono {fm₁ fm₂ : FiniteMap A B ks} {ks' : List A}
{g₁ g₂ : A → B} (hfm : fm₁ ≤ fm₂) (hg : ∀ k, g₁ k ≤ g₂ k) :
updating fm₁ ks' g₁ ≤ updating fm₂ ks' g₂ := by
@@ -413,52 +318,43 @@ end Updating
section GeneralizedUpdate
/-! Agda: `GeneralizedUpdate` (the "Exercise 4.26" construction). -/
variable [DecidableEq A] {L : Type*} [Lattice L]
/-- Agda: `GeneralizedUpdate.f'`. -/
def generalizedUpdate (f : L → FiniteMap A B ks) (g : A → L → B)
(ks' : List A) (l : L) : FiniteMap A B ks :=
(f l).updating ks' (fun k => g k l)
variable {f : L → FiniteMap A B ks} {g : A → L → B} {ks' : List A}
/-- Agda: `f'-Monotonic`. -/
theorem generalizedUpdate_monotone (hf : Monotone f)
(hg : ∀ k, Monotone (g k)) : Monotone (generalizedUpdate f g ks') :=
fun _ _ hl => updating_mono (hf hl) (fun k => hg k hl)
omit [Lattice B] [Lattice L] in
/-- Agda: `f'-∈k-forward`. -/
theorem generalizedUpdate_memKey {k : A} {l : L}
(h : MemKey k (f l)) : MemKey k (generalizedUpdate f g ks' l) := by
unfold generalizedUpdate
exact memKey_updating.mpr h
omit [Lattice B] [Lattice L] in
/-- Agda: `f'-k∈ks`. -/
theorem generalizedUpdate_mem {k : A} {l : L} (hk : k ∈ ks')
(h : MemKey k (f l)) : (k, g k l) ∈ generalizedUpdate f g ks' l := by
unfold generalizedUpdate
exact mem_updating hk h
omit [Lattice B] [Lattice L] in
/-- Agda: `f'-k∈ks-≡`. -/
theorem generalizedUpdate_mem_eq {k : A} {v : B} {l : L} (hk : k ∈ ks')
(h : (k, v) ∈ generalizedUpdate f g ks' l) : v = g k l := by
unfold generalizedUpdate at h
exact eq_of_mem_updating (g := fun k => g k l) hk h
omit [Lattice B] [Lattice L] in
/-- Agda: `f'-k∉ks-forward`. -/
theorem generalizedUpdate_not_mem_forward {k : A} {v : B} {l : L} (hk : k ∉ ks')
(h : (k, v) ∈ f l) : (k, v) ∈ generalizedUpdate f g ks' l := by
unfold generalizedUpdate
exact mem_updating_of_not_mem hk h
omit [Lattice B] [Lattice L] in
/-- Agda: `f'-k∉ks-backward`. -/
theorem generalizedUpdate_not_mem_backward {k : A} {v : B} {l : L} (hk : k ∉ ks')
(h : (k, v) ∈ generalizedUpdate f g ks' l) : (k, v) ∈ f l := by
unfold generalizedUpdate at h
@@ -466,8 +362,6 @@ theorem generalizedUpdate_not_mem_backward {k : A} {v : B} {l : L} (hk : k ∉ k
end GeneralizedUpdate
/-! ### Reading off values at a list of keys (Agda: `_[_]`) -/
section ValuesAt
variable [DecidableEq A]
@@ -476,7 +370,6 @@ private def lookup? (k : A) : List (A × B) → Option B
| [] => none
| p :: l' => if p.1 = k then some p.2 else lookup? k l'
/-- Agda: `_[_]`. -/
def valuesAt (fm : FiniteMap A B ks) (ks' : List A) : List B :=
ks'.filterMap (fun k => lookup? k fm.val)
@@ -498,7 +391,6 @@ private theorem lookup?_eq_some_of_mem : ∀ {l : List (A × B)},
exact hnd.1 this
omit [Lattice B] in
/-- Agda: `[]-∈`. -/
theorem mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap A B ks} {k : A} {v : B}
{ks' : List A} (hk : k ∈ ks') (h : (k, v) ∈ fm) : v ∈ valuesAt fm ks' :=
List.mem_filterMap.mpr
@@ -517,7 +409,6 @@ private theorem lookup?_forall₂ {l₁ l₂ : List (A × B)}
· rw [if_neg hc, if_neg (fun hp => hc (hpq.1 ▸ hp))]
exact ih
/-- Agda: `m₁≼m₂⇒m₁[ks]≼m₂[ks]`. -/
theorem valuesAt_le {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂)
(ks' : List A) :
List.Forall₂ (· ≤ ·) (valuesAt fm₁ ks') (valuesAt fm₂ ks') := by
@@ -536,8 +427,6 @@ theorem valuesAt_le {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂)
end ValuesAt
/-! ### The isomorphism with `IterProd` and the fixed height -/
section Iso
omit [Lattice B] in
@@ -551,7 +440,6 @@ def headVal {k : A} {ks' : List A} : FiniteMap A B (k :: ks') → B
| ⟨[], h⟩ => absurd h (by simp)
| ⟨p :: _, _⟩ => p.2
/-- Agda: `pop`. -/
def pop {k : A} {ks' : List A} : FiniteMap A B (k :: ks') → FiniteMap A B ks'
| ⟨[], h⟩ => absurd h (by simp)
| ⟨_ :: l, h⟩ =>
@@ -565,13 +453,10 @@ theorem val_eq_cons {k : A} {ks' : List A} :
simp only [List.map_cons, List.cons.injEq] at h
simp [headVal, pop, ← h.1]
/-- Agda: `IterProdIsomorphism.from`. -/
def toIter : {ks : List A} → FiniteMap A B ks → IterProd B PUnit ks.length
| [], _ => PUnit.unit
| _ :: _, fm => (fm.headVal, toIter fm.pop)
/-- Agda: `IterProdIsomorphism.to` (no `Unique ks` needed: the spine-pinned
representation is canonical). -/
def ofIter : (ks : List A) → IterProd B PUnit ks.length → FiniteMap A B ks
| [], _ => ⟨[], rfl⟩
| k :: ks', ip =>
@@ -579,7 +464,6 @@ def ofIter : (ks : List A) → IterProd B PUnit ks.length → FiniteMap A B ks
simp [(ofIter ks' ip.2).property]⟩
omit [Lattice B] in
/-- Agda: `from-to-inverseʳ`. -/
theorem ofIter_toIter : ∀ {ks : List A} (fm : FiniteMap A B ks),
ofIter ks (toIter fm) = fm
| [], fm => by
@@ -592,7 +476,6 @@ theorem ofIter_toIter : ∀ {ks : List A} (fm : FiniteMap A B ks),
rw [ofIter_toIter fm.pop, ← val_eq_cons fm])
omit [Lattice B] in
/-- Agda: `from-to-inverseˡ`. -/
theorem toIter_ofIter : ∀ (ks : List A) (ip : IterProd B PUnit ks.length),
toIter (ofIter ks ip) = ip
| [], _ => rfl
@@ -615,14 +498,12 @@ theorem pop_le {k : A} {ks' : List A} {fm₁ fm₂ : FiniteMap A B (k :: ks')}
rw [val_eq_cons fm₁, val_eq_cons fm₂] at h'
exact (List.forall₂_cons.mp h').2
/-- Agda: `from-preserves-≈` and `from-⊔-distr` (see header note). -/
theorem toIter_monotone : ∀ {ks : List A},
Monotone (toIter : FiniteMap A B ks → IterProd B PUnit ks.length)
| [] => fun _ _ _ => le_refl _
| _ :: _ => fun _ _ h =>
Prod.mk_le_mk.mpr ⟨headVal_le h, toIter_monotone (pop_le h)⟩
/-- Agda: `to-preserves-≈` and `to-⊔-distr` (see header note). -/
theorem ofIter_monotone : ∀ (ks : List A), Monotone (ofIter (A := A) (B := B) ks)
| [] => fun _ _ _ => le_refl _
| k :: ks' => fun ip₁ ip₂ h => by
@@ -631,22 +512,16 @@ theorem ofIter_monotone : ∀ (ks : List A), Monotone (ofIter (A := A) (B := B)
((k, ip₂.1) :: (ofIter ks' ip₂.2).val)
exact List.Forall₂.cons ⟨rfl, h.1⟩ (le_iff.mp (ofIter_monotone ks' h.2))
/-- Agda: `FixedHeight.fixedHeight` — a finite map into a lattice of height
`hB` has height `|ks| · hB`, by transport along the `IterProd` isomorphism. -/
def fixedHeight {hB : ℕ} (fhB : FixedHeight B hB) (ks : List A) :
FixedHeight (FiniteMap A B ks) (ks.length * hB) :=
((IterProd.fixedHeight fhB punitFixedHeight ks.length).transport
(ofIter ks) toIter (ofIter_monotone ks) toIter_monotone
(toIter_ofIter ks) (fun fm => ofIter_toIter fm)).cast (by ring)
def fixedHeight [FiniteHeightLattice B] (ks : List A) :
FiniteHeightLattice (FiniteMap A B ks) :=
FiniteHeightLattice.transport
(ofIter ks) toIter (ofIter_monotone ks) toIter_monotone
(toIter_ofIter ks) (fun fm => ofIter_toIter fm)
/-- Agda: `isFiniteHeightLattice`/`finiteHeightLattice` of `Lattice/FiniteMap.agda`
(there instance arguments; here an instance). -/
instance [IB : FiniteHeightLattice B] : FiniteHeightLattice (FiniteMap A B ks) where
height := ks.length * IB.height
fixedHeight := fixedHeight IB.fixedHeight ks
instance [FiniteHeightLattice B] : FiniteHeightLattice (FiniteMap A B ks) :=
fixedHeight ks
omit [Lattice B] in
/-- Agda: `to-build`. -/
theorem mem_ofIter_build {b : B} : ∀ {ks : List A} {k : A} {v : B},
(k, v) ∈ ofIter ks (IterProd.build b PUnit.unit ks.length) → v = b
| [], _, _, h => by simp [ofIter, mem_def] at h
@@ -655,12 +530,11 @@ theorem mem_ofIter_build {b : B} : ∀ {ks : List A} {k : A} {v : B},
· exact (Prod.ext_iff.mp heq).2
· exact mem_ofIter_build h'
/-- Agda: `⊥-contains-bottoms`. -/
theorem bot_contains_bots {hB : ℕ} (fhB : FixedHeight B hB) {k : A} {v : B}
(h : (k, v) ∈ (fixedHeight fhB ks).bot) : v = fhB.bot := by
have hbot : (fixedHeight fhB ks).bot
= ofIter ks (IterProd.build fhB.bot PUnit.unit ks.length) := by
show ofIter ks (IterProd.fixedHeight fhB punitFixedHeight ks.length).bot = _
theorem bot_contains_bots [FiniteHeightLattice B] {k : A} {v : B}
(h : (k, v) ∈ (fixedHeight ks).bot) : v = (⊥ : B) := by
have hbot : (fixedHeight ks).bot
= ofIter ks (IterProd.build (⊥ : B) (⊥ : PUnit) ks.length) := by
show ofIter ks (IterProd.fixedHeight (A := B) (B := PUnit) ks.length).bot = _
rw [IterProd.bot_fixedHeight]
rw [hbot] at h
exact mem_ofIter_build h

31
lean/Spa/Lattice/IterProd.lean
View File

@@ -13,12 +13,11 @@ Correspondence:
isLattice/lattice ↦ instance Spa.IterProd.instLattice
fixedHeight,
isFiniteHeightLattice,
finiteHeightLattice ↦ Spa.IterProd.fixedHeight (+ FiniteHeightLattice instance)
finiteHeightLattice ↦ Spa.IterProd.fixedHeight (+ instFiniteHeight instance)
⊥-built ↦ Spa.IterProd.bot_fixedHeight
-/
import Spa.Lattice.Prod
import Spa.Lattice.Unit
import Mathlib.Tactic.Ring
namespace Spa
@@ -51,25 +50,21 @@ def build (a : A) (b : B) : (k : ℕ) → IterProd A B k
variable [Lattice A] [Lattice B]
/-- Agda: `fixedHeight` (the `isFiniteHeightIfSupported` recursion). -/
def fixedHeight {hA hB : ℕ} (fhA : FixedHeight A hA) (fhB : FixedHeight B hB) :
(k : ℕ) → FixedHeight (IterProd A B k) (k * hA + hB)
| 0 => fhB.cast (by ring)
| k + 1 => (fhA.prod (fixedHeight fhA fhB k)).cast (by ring)
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) _ (instLattice k) _ (fixedHeight k)
/-- Agda: `⊥-built` — the bottom of the iterated product is built from the
component bottoms. -/
theorem bot_fixedHeight {hA hB : ℕ} (fhA : FixedHeight A hA) (fhB : FixedHeight B hB) :
∀ k, (fixedHeight fhA fhB k).bot = build fhA.bot fhB.bot k
instance instFiniteHeight [FiniteHeightLattice A] [FiniteHeightLattice B] (k : ℕ) :
FiniteHeightLattice (IterProd A B k) := fixedHeight k
theorem bot_fixedHeight [FiniteHeightLattice A] [FiniteHeightLattice B] :
∀ k, (fixedHeight (A := A) (B := B) k).bot = build (⊥ : A) (⊥ : B) k
| 0 => rfl
| k + 1 => by
show (fhA.bot, (fixedHeight fhA fhB k).bot) = (fhA.bot, build fhA.bot fhB.bot k)
rw [bot_fixedHeight fhA fhB k]
instance [IA : FiniteHeightLattice A] [IB : FiniteHeightLattice B] (k : ℕ) :
FiniteHeightLattice (IterProd A B k) where
height := k * IA.height + IB.height
fixedHeight := fixedHeight IA.fixedHeight IB.fixedHeight k
show ((⊥ : A), (fixedHeight (A := A) (B := B) k).bot)
= ((⊥ : A), build (⊥ : A) (⊥ : B) k)
rw [bot_fixedHeight k]
end IterProd

71
lean/Spa/Lattice/Prod.lean
View File

@@ -1,16 +1,3 @@
/-
Port of `Lattice/Prod.agda`.
The component-wise lattice structure on `α × β` is lifted into mathlib
(`Prod.instLattice`), as is decidability of equality. What remains custom is
the fixed-height content:
unzip ↦ LTSeries.exists_unzip
a,∙-Monotonic/∙,b-Monotonic ↦ Prod.mk_lt_mk_iff_right/left (strict mono of
the two injections, used to map the chains)
fixedHeight (h₁ + h₂) ↦ FixedHeight.prod
isFiniteHeightLattice ↦ instance FiniteHeightLattice (α × β)
-/
import Spa.Lattice
namespace Spa
@@ -19,8 +6,6 @@ section Unzip
variable {α β : Type*} [PartialOrder α] [PartialOrder β]
/-- Agda: `unzip` — a chain in the product splits into chains of the
components whose lengths sum to at least the original length. -/
theorem LTSeries.exists_unzip (c : LTSeries (α × β)) :
∃ (c₁ : LTSeries α) (c₂ : LTSeries β),
c₁.head = c.head.1 ∧ c₁.last = c.last.1 ∧
@@ -78,35 +63,35 @@ section FixedHeight
variable {α β : Type*} [Lattice α] [Lattice β]
/-- Agda: `Lattice/Prod.agda`'s `fixedHeight` — the product of lattices of
heights `h₁` and `h₂` has height `h₁ + h₂`. The longest chain climbs the first
component (at `⊥₂`), then the second component (at `⊤₁`). -/
def FixedHeight.prod {h₁ h₂ : ℕ} (fhA : FixedHeight α h₁) (fhB : FixedHeight β h₂) :
FixedHeight (α × β) (h₁ + h₂) where
bot := (fhA.bot, fhB.bot)
top := (fhA.top, fhB.top)
longestChain :=
RelSeries.smash
(fhA.longestChain.map (fun a => (a, fhB.bot))
(fun _ _ h => Prod.mk_lt_mk_iff_left.mpr h))
(fhB.longestChain.map (fun b => (fhA.top, b))
(fun _ _ h => Prod.mk_lt_mk_iff_right.mpr h))
(by simp [fhA.last_longestChain, fhB.head_longestChain])
head_longestChain := by simp [fhA.head_longestChain]
last_longestChain := by simp [fhB.last_longestChain]
length_longestChain := by
simp [fhA.length_longestChain, fhB.length_longestChain]
bounded := fun c => by
obtain ⟨c₁, c₂, -, -, -, -, hlen⟩ := LTSeries.exists_unzip c
have h₁ := fhA.bounded c₁
have h₂ := fhB.bounded c₂
omega
/-- Agda: `Lattice/Prod.agda`'s `isFiniteHeightLattice`/`finiteHeightLattice`. -/
instance [IA : FiniteHeightLattice α] [IB : FiniteHeightLattice β] :
instance prod [A : FiniteHeightLattice α] [B : FiniteHeightLattice β] :
FiniteHeightLattice (α × β) where
height := IA.height + IB.height
fixedHeight := IA.fixedHeight.prod IB.fixedHeight
bot := ((⊥ : α), (⊥ : β))
top := ((⊤ : α), (⊤ : β))
height := A.height + B.height
longest_chain :=
{ series :=
RelSeries.smash
(A.longest_chain.series.map (fun a => (a, (⊥ : β)))
(fun _ _ h => Prod.mk_lt_mk_iff_left.mpr h))
(B.longest_chain.series.map (fun b => ((⊤ : α), b))
(fun _ _ h => Prod.mk_lt_mk_iff_right.mpr h))
(by simp [A.longest_chain.last_series, B.longest_chain.head_series])
head_series :=
(RelSeries.head_smash _).trans
((LTSeries.head_map _ _ _).trans
(congrArg (·, (⊥ : β)) A.longest_chain.head_series))
last_series :=
(RelSeries.last_smash _).trans
((LTSeries.last_map _ _ _).trans
(congrArg ((⊤ : α), ·) B.longest_chain.last_series))
length_series := by
show A.longest_chain.series.length + B.longest_chain.series.length = _
rw [A.longest_chain.length_series, B.longest_chain.length_series] }
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₂
omega
end FixedHeight

13
lean/Spa/Lattice/Unit.lean
View File

@@ -18,18 +18,11 @@ theorem boundedChains_of_subsingleton (α : Type*) [Preorder α] [Subsingleton
exact (c.step ⟨0, by omega⟩).ne (Subsingleton.elim _ _)
/-- Agda: `Lattice/Unit.agda`'s `fixedHeight`. -/
def punitFixedHeight : FixedHeight PUnit 0 where
instance : FiniteHeightLattice PUnit where
bot := PUnit.unit
top := PUnit.unit
longestChain := RelSeries.singleton _ PUnit.unit
head_longestChain := rfl
last_longestChain := rfl
length_longestChain := rfl
bounded := boundedChains_of_subsingleton PUnit 0
/-- Agda: `Lattice/Unit.agda`'s `isFiniteHeightLattice`. -/
instance : FiniteHeightLattice PUnit where
height := 0
fixedHeight := punitFixedHeight
longest_chain := { series := RelSeries.singleton _ PUnit.unit, head_series := refl _, last_series := refl _, length_series := refl _ }
chains_bounded := boundedChains_of_subsingleton PUnit 0
end Spa