Lean migration: typeclass-based parameter passing, as in the Agda original

The port had flattened Agda's instance arguments ({{flA}}, {{evaluator}},
{{latticeInterpretation}}, {{validEvaluator}}) into explicitly threaded
values (fhL, E, I, hE). Restore them as typeclasses:

- Spa.FiniteHeightLattice: now actually used — Fixedpoint takes the
  instance instead of a FixedHeight value; FiniteMap gets the missing
  instance (height = ks.length * height B), so varsFixedHeight /
  statesFixedHeight / signFixedHeight / constFixedHeight plumbing
  disappears (instance bottoms are defeq to the old ones)
- Spa.Analysis.Forward.Evaluation: StmtEvaluator/ExprEvaluator become
  classes; the Valid* Props become Prop-classes, as in Agda
- Spa.Analysis.Forward.Adapters: the expr→stmt adapter and its validity
  are instances (Agda: the ExprToStmtAdapter instances)
- LatticeInterpretation is a class; sign/const interpretations,
  evaluators and validity proofs are instances; use sites read like the
  Agda module applications: result SignLattice prog

Proof simplifications (same theorems, proofs factored):

- Spa.Lattice.AboveBelow.monotone₂_of_strict: any ⊥-strict/⊤-dominated
  operation on a flat lattice is monotone — replaces the four near-
  identical case bashes per analysis (postulates in Agda)
- Spa.Lattice.AboveBelow.interp_sup_of/interp_inf_of: the shared flat-
  lattice interpretation case analysis, making interpSign_sup/inf and
  interpConst_sup/inf one-liners

lake build green with zero warnings; lake exe spa output verified
byte-identical (diff) to the previous, Agda-verified output.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>

.claude/settings.json

@@ -0,0 +1,9 @@
+{
+  "permissions": {
+    "allow": [
+      "Bash(lake build)",
+      "Bash(lake build *)",
+      "Bash(export PATH=\"$HOME/.elan/bin:$PATH\")"
+    ]
+  }
+}

Analysis/Constant.agda

@@ -0,0 +1,223 @@
+
+module Analysis.Constant where
+
+open import Data.Integer as Int using (ℤ; +_; -[1+_]; _≟_)
+open import Data.Integer.Show as IntShow using ()
+open import Data.Nat as Nat using (ℕ; suc; zero)
+open import Data.Product using (Σ; proj₁; proj₂; _,_)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Empty using (⊥; ⊥-elim)
+open import Data.Unit using (⊤; tt)
+open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst)
+open import Relation.Nullary using (¬_; yes; no)
+
+open import Equivalence
+open import Language
+open import Lattice
+open import Showable using (Showable; show)
+open import Utils using (_⇒_; _∧_; _∨_)
+open import Analysis.Utils using (eval-combine₂)
+import Analysis.Forward
+
+instance
+    showable : Showable ℤ
+    showable = record
+        { show = IntShow.show
+        }
+
+instance
+    ≡-equiv : IsEquivalence ℤ _≡_
+    ≡-equiv = record
+        { ≈-refl = refl
+        ; ≈-sym = sym
+        ; ≈-trans = trans
+        }
+
+    ≡-Decidable-ℤ : IsDecidable {_} {ℤ} _≡_
+    ≡-Decidable-ℤ = record { R-dec = _≟_ }
+
+-- embelish 'ℕ' with a top and bottom element.
+open import Lattice.AboveBelow ℤ _ as AB
+    using ()
+    renaming
+        ( AboveBelow to ConstLattice
+        ; ≈-dec to ≈ᶜ-dec
+        ; ⊥ to ⊥ᶜ
+        ; ⊤ to ⊤ᶜ
+        ; [_] to [_]ᶜ
+        ; _≈_ to _≈ᶜ_
+        ; ≈-⊥-⊥ to ≈ᶜ-⊥ᶜ-⊥ᶜ
+        ; ≈-⊤-⊤ to ≈ᶜ-⊤ᶜ-⊤ᶜ
+        ; ≈-lift to ≈ᶜ-lift
+        ; ≈-refl to ≈ᶜ-refl
+        )
+-- 'ℕ''s structure is not finite, so just use a 'plain' above-below Lattice.
+open AB.Plain (+ 0) using ()
+    renaming
+        ( isLattice to isLatticeᶜ
+        ; isFiniteHeightLattice to isFiniteHeightLatticeᵍ
+        ; _≼_ to _≼ᶜ_
+        ; _⊔_ to _⊔ᶜ_
+        ; _⊓_ to _⊓ᶜ_
+        ; ≼-trans to ≼ᶜ-trans
+        ; ≼-refl to ≼ᶜ-refl
+        )
+
+plus : ConstLattice → ConstLattice → ConstLattice
+plus ⊥ᶜ _ = ⊥ᶜ
+plus _ ⊥ᶜ = ⊥ᶜ
+plus ⊤ᶜ _ = ⊤ᶜ
+plus _ ⊤ᶜ = ⊤ᶜ
+plus [ z₁ ]ᶜ [ z₂ ]ᶜ = [ z₁ Int.+ z₂ ]ᶜ
+
+-- this is incredibly tedious: 125 cases per monotonicity proof, and tactics
+-- are hard. postulate for now.
+postulate plus-Monoˡ : ∀ (s₂ : ConstLattice) → Monotonic _≼ᶜ_ _≼ᶜ_ (λ s₁ → plus s₁ s₂)
+postulate plus-Monoʳ : ∀ (s₁ : ConstLattice) → Monotonic _≼ᶜ_ _≼ᶜ_ (plus s₁)
+
+plus-Mono₂ : Monotonic₂ _≼ᶜ_ _≼ᶜ_ _≼ᶜ_ plus
+plus-Mono₂ = (plus-Monoˡ , plus-Monoʳ)
+
+minus : ConstLattice → ConstLattice → ConstLattice
+minus ⊥ᶜ _ = ⊥ᶜ
+minus _ ⊥ᶜ = ⊥ᶜ
+minus ⊤ᶜ _ = ⊤ᶜ
+minus _ ⊤ᶜ = ⊤ᶜ
+minus [ z₁ ]ᶜ [ z₂ ]ᶜ = [ z₁ Int.- z₂ ]ᶜ
+
+postulate minus-Monoˡ : ∀ (s₂ : ConstLattice) → Monotonic _≼ᶜ_ _≼ᶜ_ (λ s₁ → minus s₁ s₂)
+postulate minus-Monoʳ : ∀ (s₁ : ConstLattice) → Monotonic _≼ᶜ_ _≼ᶜ_ (minus s₁)
+
+minus-Mono₂ : Monotonic₂ _≼ᶜ_ _≼ᶜ_ _≼ᶜ_ minus
+minus-Mono₂ = (minus-Monoˡ , minus-Monoʳ)
+
+⟦_⟧ᶜ : ConstLattice → Value → Set
+⟦_⟧ᶜ ⊥ᶜ _ = ⊥
+⟦_⟧ᶜ ⊤ᶜ _ = ⊤
+⟦_⟧ᶜ [ z ]ᶜ v = v ≡ ↑ᶻ z
+
+⟦⟧ᶜ-respects-≈ᶜ : ∀ {s₁ s₂ : ConstLattice} → s₁ ≈ᶜ s₂ → ⟦ s₁ ⟧ᶜ ⇒ ⟦ s₂ ⟧ᶜ
+⟦⟧ᶜ-respects-≈ᶜ ≈ᶜ-⊥ᶜ-⊥ᶜ v bot = bot
+⟦⟧ᶜ-respects-≈ᶜ ≈ᶜ-⊤ᶜ-⊤ᶜ v top = top
+⟦⟧ᶜ-respects-≈ᶜ (≈ᶜ-lift { z } { z } refl) v proof = proof
+
+⟦⟧ᶜ-⊔ᶜ-∨ : ∀ {s₁ s₂ : ConstLattice} → (⟦ s₁ ⟧ᶜ ∨ ⟦ s₂ ⟧ᶜ) ⇒ ⟦ s₁ ⊔ᶜ s₂ ⟧ᶜ
+⟦⟧ᶜ-⊔ᶜ-∨ {⊥ᶜ} x (inj₂ px₂) = px₂
+⟦⟧ᶜ-⊔ᶜ-∨ {⊤ᶜ} x _ = tt
+⟦⟧ᶜ-⊔ᶜ-∨ {[ s₁ ]ᶜ} {[ s₂ ]ᶜ} x px
+    with s₁ ≟ s₂
+...   | no _ = tt
+...   | yes refl
+        with px
+...       | inj₁ px₁ = px₁
+...       | inj₂ px₂ = px₂
+⟦⟧ᶜ-⊔ᶜ-∨ {[ s₁ ]ᶜ} {⊥ᶜ} x (inj₁ px₁) = px₁
+⟦⟧ᶜ-⊔ᶜ-∨ {[ s₁ ]ᶜ} {⊤ᶜ} x _ = tt
+
+s₁≢s₂⇒¬s₁∧s₂ : ∀ {z₁ z₂ : ℤ} → ¬ z₁ ≡ z₂ → ∀ {v} → ¬ ((⟦ [ z₁ ]ᶜ ⟧ᶜ ∧ ⟦ [ z₂ ]ᶜ ⟧ᶜ) v)
+s₁≢s₂⇒¬s₁∧s₂ { z₁ } { z₂ } z₁≢z₂ {v} (v≡z₁ , v≡z₂)
+    with refl ← trans (sym v≡z₁) v≡z₂ = z₁≢z₂ refl
+
+⟦⟧ᶜ-⊓ᶜ-∧ : ∀ {s₁ s₂ : ConstLattice} → (⟦ s₁ ⟧ᶜ ∧ ⟦ s₂ ⟧ᶜ) ⇒ ⟦ s₁ ⊓ᶜ s₂ ⟧ᶜ
+⟦⟧ᶜ-⊓ᶜ-∧ {⊥ᶜ} x (bot , _) = bot
+⟦⟧ᶜ-⊓ᶜ-∧ {⊤ᶜ} x (_ , px₂) = px₂
+⟦⟧ᶜ-⊓ᶜ-∧ {[ s₁ ]ᶜ} {[ s₂ ]ᶜ} x (px₁ , px₂)
+    with s₁ ≟ s₂
+...   | no s₁≢s₂ = s₁≢s₂⇒¬s₁∧s₂ s₁≢s₂ (px₁ , px₂)
+...   | yes refl = px₁
+⟦⟧ᶜ-⊓ᶜ-∧ {[ g₁ ]ᶜ} {⊥ᶜ} x (_ , bot) = bot
+⟦⟧ᶜ-⊓ᶜ-∧ {[ g₁ ]ᶜ} {⊤ᶜ} x (px₁ , _) = px₁
+
+instance
+    latticeInterpretationᶜ : LatticeInterpretation isLatticeᶜ
+    latticeInterpretationᶜ = record
+        { ⟦_⟧ = ⟦_⟧ᶜ
+        ; ⟦⟧-respects-≈ = ⟦⟧ᶜ-respects-≈ᶜ
+        ; ⟦⟧-⊔-∨ = ⟦⟧ᶜ-⊔ᶜ-∨
+        ; ⟦⟧-⊓-∧ = ⟦⟧ᶜ-⊓ᶜ-∧
+        }
+
+module WithProg (prog : Program) where
+    open Program prog
+
+    open import Analysis.Forward.Lattices ConstLattice prog
+    open import Analysis.Forward.Evaluation ConstLattice prog
+    open import Analysis.Forward.Adapters ConstLattice prog
+
+    eval : ∀ (e : Expr) → VariableValues → ConstLattice
+    eval (e₁ + e₂) vs = plus (eval e₁ vs) (eval e₂ vs)
+    eval (e₁ - e₂) vs = minus (eval e₁ vs) (eval e₂ vs)
+    eval (` k) vs
+        with ∈k-decᵛ k (proj₁ (proj₁ vs))
+    ...   | yes k∈vs = proj₁ (locateᵛ {k} {vs} k∈vs)
+    ...   | no _ = ⊤ᶜ
+    eval (# n) _ = [ + n ]ᶜ
+
+    eval-Monoʳ : ∀ (e : Expr) → Monotonic _≼ᵛ_ _≼ᶜ_ (eval e)
+    eval-Monoʳ (e₁ + e₂) {vs₁} {vs₂} vs₁≼vs₂ =
+        eval-combine₂ (λ {x} {y} {z} →  ≼ᶜ-trans {x} {y} {z})
+                      plus plus-Mono₂ {o₁ = eval e₁ vs₁}
+                      (eval-Monoʳ e₁ vs₁≼vs₂) (eval-Monoʳ e₂ vs₁≼vs₂)
+    eval-Monoʳ (e₁ - e₂) {vs₁} {vs₂} vs₁≼vs₂ =
+        eval-combine₂ (λ {x} {y} {z} →  ≼ᶜ-trans {x} {y} {z})
+                      minus minus-Mono₂ {o₁ = eval e₁ vs₁}
+                      (eval-Monoʳ e₁ vs₁≼vs₂) (eval-Monoʳ e₂ vs₁≼vs₂)
+    eval-Monoʳ (` k) {vs₁@((kvs₁ , _) , _)} {vs₂@((kvs₂ , _), _)} vs₁≼vs₂
+        with ∈k-decᵛ k kvs₁ | ∈k-decᵛ k kvs₂
+    ...   | yes k∈kvs₁ | yes k∈kvs₂ =
+            let
+                (v₁ , k,v₁∈vs₁) = locateᵛ {k} {vs₁} k∈kvs₁
+                (v₂ , k,v₂∈vs₂) = locateᵛ {k} {vs₂} k∈kvs₂
+            in
+                m₁≼m₂⇒m₁[k]ᵛ≼m₂[k]ᵛ vs₁ vs₂ vs₁≼vs₂ k,v₁∈vs₁ k,v₂∈vs₂
+    ...   | yes k∈kvs₁ | no k∉kvs₂ = ⊥-elim (k∉kvs₂ (subst (λ l → k ∈ˡ l) (all-equal-keysᵛ vs₁ vs₂) k∈kvs₁))
+    ...   | no k∉kvs₁ | yes k∈kvs₂ = ⊥-elim (k∉kvs₁ (subst (λ l → k ∈ˡ l) (all-equal-keysᵛ vs₂ vs₁) k∈kvs₂))
+    ...   | no k∉kvs₁ | no k∉kvs₂ = IsLattice.≈-refl isLatticeᶜ
+    eval-Monoʳ (# n) _ = ≼ᶜ-refl ([ + n ]ᶜ)
+
+    instance
+        ConstEval : ExprEvaluator
+        ConstEval = record { eval = eval; eval-Monoʳ = eval-Monoʳ }
+
+    -- For debugging purposes, print out the result.
+    output = show (Analysis.Forward.WithProg.result ConstLattice prog)
+
+    -- This should have fewer cases -- the same number as the actual 'plus' above.
+    -- But agda only simplifies on first argument, apparently, so we are stuck
+    -- listing them all.
+    plus-valid : ∀ {g₁ g₂} {z₁ z₂} → ⟦ g₁ ⟧ᶜ (↑ᶻ z₁) → ⟦ g₂ ⟧ᶜ (↑ᶻ z₂) → ⟦ plus g₁ g₂ ⟧ᶜ (↑ᶻ (z₁ Int.+ z₂))
+    plus-valid {⊥ᶜ} {_} ⊥ _ = ⊥
+    plus-valid {[ z ]ᶜ} {⊥ᶜ} _ ⊥ = ⊥
+    plus-valid {⊤ᶜ} {⊥ᶜ} _ ⊥ = ⊥
+    plus-valid {⊤ᶜ} {[ z ]ᶜ} _ _ = tt
+    plus-valid {⊤ᶜ} {⊤ᶜ} _ _ = tt
+    plus-valid {[ z₁ ]ᶜ} {[ z₂ ]ᶜ} refl refl = refl
+    plus-valid {[ z ]ᶜ} {⊤ᶜ} _ _ = tt
+    --
+    -- Same for this one. It should be easier, but Agda won't simplify.
+    minus-valid : ∀ {g₁ g₂} {z₁ z₂} → ⟦ g₁ ⟧ᶜ (↑ᶻ z₁) → ⟦ g₂ ⟧ᶜ (↑ᶻ z₂) → ⟦ minus g₁ g₂ ⟧ᶜ (↑ᶻ (z₁ Int.- z₂))
+    minus-valid {⊥ᶜ} {_} ⊥ _ = ⊥
+    minus-valid {[ z ]ᶜ} {⊥ᶜ} _ ⊥ = ⊥
+    minus-valid {⊤ᶜ} {⊥ᶜ} _ ⊥ = ⊥
+    minus-valid {⊤ᶜ} {[ z ]ᶜ} _ _ = tt
+    minus-valid {⊤ᶜ} {⊤ᶜ} _ _ = tt
+    minus-valid {[ z₁ ]ᶜ} {[ z₂ ]ᶜ} refl refl = refl
+    minus-valid {[ z ]ᶜ} {⊤ᶜ} _ _ = tt
+
+    eval-valid : IsValidExprEvaluator
+    eval-valid (⇒ᵉ-+ ρ e₁ e₂ z₁ z₂ ρ,e₁⇒z₁ ρ,e₂⇒z₂) ⟦vs⟧ρ =
+        plus-valid (eval-valid ρ,e₁⇒z₁ ⟦vs⟧ρ) (eval-valid ρ,e₂⇒z₂ ⟦vs⟧ρ)
+    eval-valid (⇒ᵉ-- ρ e₁ e₂ z₁ z₂ ρ,e₁⇒z₁ ρ,e₂⇒z₂) ⟦vs⟧ρ =
+        minus-valid (eval-valid ρ,e₁⇒z₁ ⟦vs⟧ρ) (eval-valid ρ,e₂⇒z₂ ⟦vs⟧ρ)
+    eval-valid {vs} (⇒ᵉ-Var ρ x v x,v∈ρ) ⟦vs⟧ρ
+        with ∈k-decᵛ x (proj₁ (proj₁ vs))
+    ...   | yes x∈kvs = ⟦vs⟧ρ (proj₂ (locateᵛ {x} {vs} x∈kvs)) x,v∈ρ
+    ...   | no x∉kvs = tt
+    eval-valid (⇒ᵉ-ℕ ρ n) _ = refl
+
+    instance
+        ConstEvalValid : ValidExprEvaluator ConstEval latticeInterpretationᶜ
+        ConstEvalValid = record { valid = eval-valid }
+
+    analyze-correct = Analysis.Forward.WithProg.analyze-correct ConstLattice prog tt

Analysis/Forward.agda

@@ -2,180 +2,35 @@ open import Language hiding (_[_])
 open import Lattice
 
 module Analysis.Forward
-    {L : Set} {h}
+    (L : Set) {h}
     {_≈ˡ_ : L → L → Set} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
-    (isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_)
-    (≈ˡ-dec : IsDecidable _≈ˡ_) where
+    {{isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+    {{≈ˡ-dec : IsDecidable _≈ˡ_}} where
 
 open import Data.Empty using (⊥-elim)
-open import Data.String using (String) renaming (_≟_ to _≟ˢ_)
-open import Data.Nat using (suc)
-open import Data.Product using (_×_; proj₁; _,_)
-open import Data.List using (List; _∷_; []; foldr; foldl; cartesianProduct; cartesianProductWith)
-open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
-open import Data.List.Relation.Unary.Any as Any using ()
-open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst)
-open import Relation.Nullary using (¬_; Dec; yes; no)
 open import Data.Unit using (⊤)
+open import Data.String using (String)
+open import Data.Product using (_,_)
+open import Data.List using (_∷_; []; foldr; foldl)
+open import Data.List.Relation.Unary.Any as Any using ()
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym; subst)
+open import Relation.Nullary using (yes; no)
 open import Function using (_∘_; flip)
 
-open import Utils using (Pairwise; _⇒_)
-import Lattice.FiniteValueMap
-
 open IsFiniteHeightLattice isFiniteHeightLatticeˡ
-    using ()
-    renaming
-        ( isLattice to isLatticeˡ
-        ; fixedHeight to fixedHeightˡ
-        ; _≼_ to _≼ˡ_
-        ; ≈-sym to ≈ˡ-sym
-        )
+    using () renaming (isLattice to isLatticeˡ)
 
 module WithProg (prog : Program) where
+    open import Analysis.Forward.Lattices L prog hiding (≈ᵛ-Decidable; ≈ᵐ-Decidable) -- to disambiguate instance resolution
+    open import Analysis.Forward.Evaluation L prog
     open Program prog
 
-    -- The variable -> abstract value (e.g. sign) map is a finite value-map
-    -- with keys strings. Use a bundle to avoid explicitly specifying operators.
-    module VariableValuesFiniteMap = Lattice.FiniteValueMap.WithKeys _≟ˢ_ isLatticeˡ vars
-    open VariableValuesFiniteMap
-        using ()
-        renaming
-            ( FiniteMap to VariableValues
-            ; isLattice to isLatticeᵛ
-            ; _≈_ to _≈ᵛ_
-            ; _⊔_ to _⊔ᵛ_
-            ; _≼_ to _≼ᵛ_
-            ; ≈₂-dec⇒≈-dec to ≈ˡ-dec⇒≈ᵛ-dec
-            ; _∈_ to _∈ᵛ_
-            ; _∈k_ to _∈kᵛ_
-            ; _updating_via_ to _updatingᵛ_via_
-            ; locate to locateᵛ
-            ; m₁≼m₂⇒m₁[k]≼m₂[k] to m₁≼m₂⇒m₁[k]ᵛ≼m₂[k]ᵛ
-            ; ∈k-dec to ∈k-decᵛ
-            ; all-equal-keys to all-equal-keysᵛ
-            )
-        public
-    open IsLattice isLatticeᵛ
-        using ()
-        renaming
-            ( ⊔-Monotonicˡ to ⊔ᵛ-Monotonicˡ
-            ; ⊔-Monotonicʳ to ⊔ᵛ-Monotonicʳ
-            ; ⊔-idemp to ⊔ᵛ-idemp
-            )
-    open Lattice.FiniteValueMap.IterProdIsomorphism.WithUniqueKeysAndFixedHeight _≟ˢ_ isLatticeˡ vars-Unique ≈ˡ-dec _ fixedHeightˡ
-        using ()
-        renaming
-            ( isFiniteHeightLattice to isFiniteHeightLatticeᵛ
-            )
-
-    ≈ᵛ-dec = ≈ˡ-dec⇒≈ᵛ-dec ≈ˡ-dec
-    joinSemilatticeᵛ = IsFiniteHeightLattice.joinSemilattice isFiniteHeightLatticeᵛ
-    fixedHeightᵛ = IsFiniteHeightLattice.fixedHeight isFiniteHeightLatticeᵛ
-    ⊥ᵛ = proj₁ (proj₁ (proj₁ fixedHeightᵛ))
-
-    -- Finally, the map we care about is (state -> (variables -> value)). Bring that in.
-    module StateVariablesFiniteMap = Lattice.FiniteValueMap.WithKeys _≟_ isLatticeᵛ states
-    open StateVariablesFiniteMap
-        using (_[_]; m₁≼m₂⇒m₁[ks]≼m₂[ks])
-        renaming
-            ( FiniteMap to StateVariables
-            ; isLattice to isLatticeᵐ
-            ; _∈k_ to _∈kᵐ_
-            ; locate to locateᵐ
-            ; _≼_ to _≼ᵐ_
-            ; ≈₂-dec⇒≈-dec to ≈ᵛ-dec⇒≈ᵐ-dec
-            ; m₁≼m₂⇒m₁[k]≼m₂[k] to m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ
-            )
-        public
-    open Lattice.FiniteValueMap.IterProdIsomorphism.WithUniqueKeysAndFixedHeight _≟_ isLatticeᵛ states-Unique ≈ᵛ-dec _ fixedHeightᵛ
-        using ()
-        renaming
-            ( isFiniteHeightLattice to isFiniteHeightLatticeᵐ
-            )
-
-    ≈ᵐ-dec = ≈ᵛ-dec⇒≈ᵐ-dec ≈ᵛ-dec
-    fixedHeightᵐ = IsFiniteHeightLattice.fixedHeight isFiniteHeightLatticeᵐ
-
-    -- We now have our (state -> (variables -> value)) map.
-    -- Define a couple of helpers to retrieve values from it. Specifically,
-    -- since the State type is as specific as possible, it's always possible to
-    -- retrieve the variable values at each state.
-
-    states-in-Map : ∀ (s : State) (sv : StateVariables) → s ∈kᵐ sv
-    states-in-Map s sv@(m , ksv≡states) rewrite ksv≡states = states-complete s
-
-    variablesAt : State → StateVariables → VariableValues
-    variablesAt s sv = proj₁ (locateᵐ {s} {sv} (states-in-Map s sv))
-
-    -- build up the 'join' function, which follows from Exercise 4.26's
-    --
-    --    L₁ → (A → L₂)
-    --
-    -- Construction, with L₁ = (A → L₂), and f = id
-
-    joinForKey : State → StateVariables → VariableValues
-    joinForKey k states = foldr _⊔ᵛ_ ⊥ᵛ (states [ incoming k ])
-
-    -- The per-key join is made up of map key accesses (which are monotonic)
-    -- and folds using the join operation (also monotonic)
-
-    joinForKey-Mono : ∀ (k : State) → Monotonic _≼ᵐ_ _≼ᵛ_ (joinForKey k)
-    joinForKey-Mono k {fm₁} {fm₂} fm₁≼fm₂ =
-        foldr-Mono joinSemilatticeᵛ joinSemilatticeᵛ (fm₁ [ incoming k ]) (fm₂ [ incoming k ]) _⊔ᵛ_ ⊥ᵛ ⊥ᵛ
-                   (m₁≼m₂⇒m₁[ks]≼m₂[ks] fm₁ fm₂ (incoming k) fm₁≼fm₂)
-                   (⊔ᵛ-idemp ⊥ᵛ) ⊔ᵛ-Monotonicʳ ⊔ᵛ-Monotonicˡ
-
-    -- The name f' comes from the formulation of Exercise 4.26.
-    open StateVariablesFiniteMap.GeneralizedUpdate states isLatticeᵐ (λ x → x) (λ a₁≼a₂ → a₁≼a₂) joinForKey joinForKey-Mono states
-        renaming
-            ( f' to joinAll
-            ; f'-Monotonic to joinAll-Mono
-            ; f'-k∈ks-≡ to joinAll-k∈ks-≡
-            )
-
-    variablesAt-joinAll : ∀ (s : State) (sv : StateVariables) →
-                          variablesAt s (joinAll sv) ≡ joinForKey s sv
-    variablesAt-joinAll s sv
-        with (vs , s,vs∈usv) ← locateᵐ {s} {joinAll sv} (states-in-Map s (joinAll sv)) =
-        joinAll-k∈ks-≡ {l = sv} (states-complete s) s,vs∈usv
-
-    -- With 'join' in hand, we need to perform abstract evaluation.
-    module WithEvaluator (eval : Expr → VariableValues → L)
-                         (eval-Mono : ∀ (e : Expr) → Monotonic _≼ᵛ_ _≼ˡ_ (eval e)) where
-
-        -- For a particular evaluation function, we need to perform an evaluation
-        -- for an assignment, and update the corresponding key. Use Exercise 4.26's
-        -- generalized update to set the single key's value.
-
-        private module _ (k : String) (e : Expr) where
-            open VariableValuesFiniteMap.GeneralizedUpdate vars isLatticeᵛ (λ x → x) (λ a₁≼a₂ → a₁≼a₂) (λ _ → eval e) (λ _ {vs₁} {vs₂} vs₁≼vs₂ → eval-Mono e {vs₁} {vs₂} vs₁≼vs₂) (k ∷ [])
-                renaming
-                    ( f' to updateVariablesFromExpression
-                    ; f'-Monotonic to updateVariablesFromExpression-Mono
-                    ; f'-k∈ks-≡ to updateVariablesFromExpression-k∈ks-≡
-                    ; f'-k∉ks-backward to updateVariablesFromExpression-k∉ks-backward
-                    )
-                public
-
-        -- The per-state update function makes use of the single-key setter,
-        -- updateVariablesFromExpression, for the case where the statement
-        -- is an assignment.
-        --
-        -- This per-state function adjusts the variables in that state,
-        -- also monotonically; we derive the for-each-state update from
-        -- the Exercise 4.26 again.
-
-        updateVariablesFromStmt : BasicStmt → VariableValues → VariableValues
-        updateVariablesFromStmt (k ← e) vs = updateVariablesFromExpression k e vs
-        updateVariablesFromStmt noop vs = vs
-
-        updateVariablesFromStmt-Monoʳ : ∀ (bs : BasicStmt) → Monotonic _≼ᵛ_ _≼ᵛ_ (updateVariablesFromStmt bs)
-        updateVariablesFromStmt-Monoʳ (k ← e) {vs₁} {vs₂} vs₁≼vs₂ = updateVariablesFromExpression-Mono k e {vs₁} {vs₂} vs₁≼vs₂
-        updateVariablesFromStmt-Monoʳ noop vs₁≼vs₂ = vs₁≼vs₂
+    private module WithStmtEvaluator {{evaluator : StmtEvaluator}} where
+        open StmtEvaluator evaluator
 
         updateVariablesForState : State → StateVariables → VariableValues
         updateVariablesForState s sv =
-            foldl (flip updateVariablesFromStmt) (variablesAt s sv) (code s)
+            foldl (flip (eval s)) (variablesAt s sv) (code s)
 
         updateVariablesForState-Monoʳ : ∀ (s : State) → Monotonic _≼ᵐ_ _≼ᵛ_ (updateVariablesForState s)
         updateVariablesForState-Monoʳ s {sv₁} {sv₂} sv₁≼sv₂ =
@@ -186,15 +41,17 @@ module WithProg (prog : Program) where
                 vs₁≼vs₂ = m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ sv₁ sv₂ sv₁≼sv₂ s,vs₁∈sv₁ s,vs₂∈sv₂
             in
                 foldl-Mono' (IsLattice.joinSemilattice isLatticeᵛ) bss
-                            (flip updateVariablesFromStmt) updateVariablesFromStmt-Monoʳ
+                            (flip (eval s)) (eval-Monoʳ s)
                             vs₁≼vs₂
 
-        open StateVariablesFiniteMap.GeneralizedUpdate states isLatticeᵐ (λ x → x) (λ a₁≼a₂ → a₁≼a₂) updateVariablesForState updateVariablesForState-Monoʳ states
+        open StateVariablesFiniteMap.GeneralizedUpdate {{isLatticeᵐ}} (λ x → x) (λ a₁≼a₂ → a₁≼a₂) updateVariablesForState updateVariablesForState-Monoʳ states
+            using ()
             renaming
                 ( f' to updateAll
                 ; f'-Monotonic to updateAll-Mono
                 ; f'-k∈ks-≡ to updateAll-k∈ks-≡
                 )
+            public
 
         -- Finally, the whole analysis consists of getting the 'join'
         -- of all incoming states, then applying the per-state evaluation
@@ -209,7 +66,7 @@ module WithProg (prog : Program) where
                            (joinAll-Mono {sv₁} {sv₂} sv₁≼sv₂)
 
         -- The fixed point of the 'analyze' function is our final goal.
-        open import Fixedpoint ≈ᵐ-dec isFiniteHeightLatticeᵐ analyze (λ {m₁} {m₂} m₁≼m₂ → analyze-Mono {m₁} {m₂} m₁≼m₂)
+        open import Fixedpoint analyze (λ {m₁} {m₂} m₁≼m₂ → analyze-Mono {m₁} {m₂} m₁≼m₂)
             using ()
             renaming (aᶠ to result; aᶠ≈faᶠ to result≈analyze-result)
             public
@@ -220,53 +77,68 @@ module WithProg (prog : Program) where
             with (vs , s,vs∈usv) ← locateᵐ {s} {updateAll sv} (states-in-Map s (updateAll sv)) =
             updateAll-k∈ks-≡ {l = sv} (states-complete s) s,vs∈usv
 
-        module WithInterpretation (latticeInterpretationˡ : LatticeInterpretation isLatticeˡ) where
-            open LatticeInterpretation latticeInterpretationˡ
-                using ()
-                renaming (⟦_⟧ to ⟦_⟧ˡ; ⟦⟧-respects-≈ to ⟦⟧ˡ-respects-≈ˡ)
+        module WithValidInterpretation {{latticeInterpretationˡ : LatticeInterpretation isLatticeˡ}}
+                                       {{validEvaluator : ValidStmtEvaluator evaluator latticeInterpretationˡ}} (dummy : ⊤) where
+            open ValidStmtEvaluator validEvaluator
 
-            ⟦_⟧ᵛ : VariableValues → Env → Set
-            ⟦_⟧ᵛ vs ρ = ∀ {k l} → (k , l) ∈ᵛ vs → ∀ {v} → (k , v) Language.∈ ρ → ⟦ l ⟧ˡ v
-
-
-            ⟦⟧ᵛ-respects-≈ᵛ : ∀ {vs₁ vs₂ : VariableValues} → vs₁ ≈ᵛ vs₂ → ⟦ vs₁ ⟧ᵛ ⇒ ⟦ vs₂ ⟧ᵛ
-            ⟦⟧ᵛ-respects-≈ᵛ {m₁ , _} {m₂ , _}
-                            (m₁⊆m₂ , m₂⊆m₁) ρ ⟦vs₁⟧ρ {k} {l} k,l∈m₂ {v} k,v∈ρ =
-                let
-                    (l' , (l≈l' , k,l'∈m₁)) = m₂⊆m₁ _ _ k,l∈m₂
-                    ⟦l'⟧v = ⟦vs₁⟧ρ k,l'∈m₁ k,v∈ρ
-                in
-                    ⟦⟧ˡ-respects-≈ˡ (≈ˡ-sym l≈l') v ⟦l'⟧v
-
-            InterpretationValid : Set
-            InterpretationValid = ∀ {vs ρ e v} → ρ , e ⇒ᵉ v → ⟦ vs ⟧ᵛ ρ → ⟦ eval e vs ⟧ˡ v
-
-            module WithValidity (interpretationValidˡ : InterpretationValid) where
-
-                updateVariablesFromStmt-matches : ∀ {bs vs ρ₁ ρ₂} → ρ₁ , bs ⇒ᵇ ρ₂ → ⟦ vs ⟧ᵛ ρ₁ → ⟦ updateVariablesFromStmt bs vs ⟧ᵛ ρ₂
-                updateVariablesFromStmt-matches {_} {vs} {ρ₁} {ρ₁} (⇒ᵇ-noop ρ₁) ⟦vs⟧ρ₁ = ⟦vs⟧ρ₁
-                updateVariablesFromStmt-matches {_} {vs} {ρ₁} {_} (⇒ᵇ-← ρ₁ k e v ρ,e⇒v) ⟦vs⟧ρ₁ {k'} {l} k',l∈vs' {v'} k',v'∈ρ₂
-                    with k ≟ˢ k' | k',v'∈ρ₂
-                ...   | yes refl | here _ v _
-                        rewrite updateVariablesFromExpression-k∈ks-≡ k e {l = vs} (Any.here refl) k',l∈vs' =
-                        interpretationValidˡ ρ,e⇒v ⟦vs⟧ρ₁
-                ...   | yes k≡k' | there _ _ _ _ _ k'≢k _ = ⊥-elim (k'≢k (sym k≡k'))
-                ...   | no k≢k' | here _ _ _ = ⊥-elim (k≢k' refl)
-                ...   | no k≢k'  | there _ _ _ _ _ _ k',v'∈ρ₁ =
-                        let
-                            k'∉[k] = (λ { (Any.here refl) → k≢k' refl })
-                            k',l∈vs = updateVariablesFromExpression-k∉ks-backward k e {l = vs} k'∉[k] k',l∈vs'
-                        in
-                            ⟦vs⟧ρ₁ k',l∈vs k',v'∈ρ₁
-
-                updateVariablesFromStmt-fold-matches : ∀ {bss vs ρ₁ ρ₂} → ρ₁ , bss ⇒ᵇˢ ρ₂ → ⟦ vs ⟧ᵛ ρ₁ → ⟦ foldl (flip updateVariablesFromStmt) vs bss ⟧ᵛ ρ₂
-                updateVariablesFromStmt-fold-matches [] ⟦vs⟧ρ = ⟦vs⟧ρ
-                updateVariablesFromStmt-fold-matches {bs ∷ bss'} {vs} {ρ₁} {ρ₂} (ρ₁,bs⇒ρ ∷ ρ,bss'⇒ρ₂) ⟦vs⟧ρ₁ =
-                    updateVariablesFromStmt-fold-matches {bss'} {updateVariablesFromStmt bs vs} ρ,bss'⇒ρ₂ (updateVariablesFromStmt-matches ρ₁,bs⇒ρ ⟦vs⟧ρ₁)
+            eval-fold-valid : ∀ {s bss vs ρ₁ ρ₂} → ρ₁ , bss ⇒ᵇˢ ρ₂ → ⟦ vs ⟧ᵛ ρ₁ → ⟦ foldl (flip (eval s)) vs bss ⟧ᵛ ρ₂
+            eval-fold-valid {_} [] ⟦vs⟧ρ = ⟦vs⟧ρ
+            eval-fold-valid {s} {bs ∷ bss'} {vs} {ρ₁} {ρ₂} (ρ₁,bs⇒ρ ∷ ρ,bss'⇒ρ₂) ⟦vs⟧ρ₁ =
+                eval-fold-valid
+                    {bss = bss'} {eval s bs vs} ρ,bss'⇒ρ₂
+                    (valid ρ₁,bs⇒ρ ⟦vs⟧ρ₁)
 
             updateVariablesForState-matches : ∀ {s sv ρ₁ ρ₂} → ρ₁ , (code s) ⇒ᵇˢ ρ₂ → ⟦ variablesAt s sv ⟧ᵛ ρ₁ → ⟦ updateVariablesForState s sv ⟧ᵛ ρ₂
-                updateVariablesForState-matches = updateVariablesFromStmt-fold-matches
+            updateVariablesForState-matches = eval-fold-valid
 
             updateAll-matches : ∀ {s sv ρ₁ ρ₂} → ρ₁ , (code s) ⇒ᵇˢ ρ₂ → ⟦ variablesAt s sv ⟧ᵛ ρ₁ → ⟦ variablesAt s (updateAll sv) ⟧ᵛ ρ₂
-                updateAll-matches {s} {sv} ρ₁,bss⇒ρ₂ ⟦vs⟧ρ₁ rewrite variablesAt-updateAll s sv =
+            updateAll-matches {s} {sv} ρ₁,bss⇒ρ₂ ⟦vs⟧ρ₁
+                rewrite variablesAt-updateAll s sv =
                 updateVariablesForState-matches {s} {sv} ρ₁,bss⇒ρ₂ ⟦vs⟧ρ₁
+
+            stepTrace : ∀ {s₁ ρ₁ ρ₂} → ⟦ joinForKey s₁ result ⟧ᵛ ρ₁ → ρ₁ , (code s₁) ⇒ᵇˢ ρ₂ → ⟦ variablesAt s₁ result ⟧ᵛ ρ₂
+            stepTrace {s₁} {ρ₁} {ρ₂} ⟦joinForKey-s₁⟧ρ₁ ρ₁,bss⇒ρ₂ =
+                    let
+                        -- I'd use rewrite, but Agda gets a memory overflow (?!).
+                        ⟦joinAll-result⟧ρ₁ =
+                            subst (λ vs → ⟦ vs ⟧ᵛ ρ₁)
+                                  (sym (variablesAt-joinAll s₁ result))
+                                  ⟦joinForKey-s₁⟧ρ₁
+                        ⟦analyze-result⟧ρ₂ =
+                            updateAll-matches {sv = joinAll result}
+                                              ρ₁,bss⇒ρ₂ ⟦joinAll-result⟧ρ₁
+                        analyze-result≈result =
+                            ≈ᵐ-sym {result} {updateAll (joinAll result)}
+                                   result≈analyze-result
+                        analyze-s₁≈s₁ =
+                            variablesAt-≈ s₁ (updateAll (joinAll result))
+                                             result (analyze-result≈result)
+                    in
+                        ⟦⟧ᵛ-respects-≈ᵛ {variablesAt s₁ (updateAll (joinAll result))} {variablesAt s₁ result} (analyze-s₁≈s₁) ρ₂ ⟦analyze-result⟧ρ₂
+
+            walkTrace : ∀ {s₁ s₂ ρ₁ ρ₂} → ⟦ joinForKey s₁ result ⟧ᵛ ρ₁ → Trace {graph} s₁ s₂ ρ₁ ρ₂ → ⟦ variablesAt s₂ result ⟧ᵛ ρ₂
+            walkTrace {s₁} {s₁} {ρ₁} {ρ₂} ⟦joinForKey-s₁⟧ρ₁ (Trace-single ρ₁,bss⇒ρ₂) =
+                stepTrace {s₁} {ρ₁} {ρ₂} ⟦joinForKey-s₁⟧ρ₁ ρ₁,bss⇒ρ₂
+            walkTrace {s₁} {s₂} {ρ₁} {ρ₂} ⟦joinForKey-s₁⟧ρ₁ (Trace-edge {ρ₂ = ρ} {idx₂ = s} ρ₁,bss⇒ρ s₁→s₂ tr) =
+                let
+                    ⟦result-s₁⟧ρ =
+                        stepTrace {s₁} {ρ₁} {ρ} ⟦joinForKey-s₁⟧ρ₁ ρ₁,bss⇒ρ
+                    s₁∈incomingStates =
+                        []-∈ result (edge⇒incoming s₁→s₂)
+                                    (variablesAt-∈ s₁ result)
+                    ⟦joinForKey-s⟧ρ =
+                        ⟦⟧ᵛ-foldr ⟦result-s₁⟧ρ s₁∈incomingStates
+                in
+                    walkTrace ⟦joinForKey-s⟧ρ tr
+
+            joinForKey-initialState-⊥ᵛ : joinForKey initialState result ≡ ⊥ᵛ
+            joinForKey-initialState-⊥ᵛ = cong (λ ins → foldr _⊔ᵛ_ ⊥ᵛ (result [ ins ])) initialState-pred-∅
+
+            ⟦joinAll-initialState⟧ᵛ∅ : ⟦ joinForKey initialState result ⟧ᵛ []
+            ⟦joinAll-initialState⟧ᵛ∅ = subst (λ vs → ⟦ vs ⟧ᵛ []) (sym joinForKey-initialState-⊥ᵛ) ⟦⊥ᵛ⟧ᵛ∅
+
+            analyze-correct : ∀ {ρ : Env} → [] , rootStmt ⇒ˢ ρ → ⟦ variablesAt finalState result ⟧ᵛ ρ
+            analyze-correct {ρ} ∅,s⇒ρ = walkTrace {initialState} {finalState} {[]} {ρ} ⟦joinAll-initialState⟧ᵛ∅ (trace ∅,s⇒ρ)
+
+    open WithStmtEvaluator using (result; analyze; result≈analyze-result) public
+    open WithStmtEvaluator.WithValidInterpretation using (analyze-correct) public

Analysis/Forward/Adapters.agda

@@ -0,0 +1,100 @@
+open import Language hiding (_[_])
+open import Lattice
+
+module Analysis.Forward.Adapters
+    (L : Set) {h}
+    {_≈ˡ_ : L → L → Set} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
+    {{isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+    {{≈ˡ-dec : IsDecidable _≈ˡ_}}
+    (prog : Program) where
+
+open import Analysis.Forward.Lattices L prog
+open import Analysis.Forward.Evaluation L prog
+
+open import Data.Empty using (⊥-elim)
+open import Data.String using (String) renaming (_≟_ to _≟ˢ_)
+open import Data.Product using (_,_)
+open import Data.List using (_∷_; []; foldr; foldl)
+open import Data.List.Relation.Unary.Any as Any using ()
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym; subst)
+open import Relation.Nullary using (yes; no)
+open import Function using (_∘_; flip)
+
+open IsFiniteHeightLattice isFiniteHeightLatticeˡ
+    using ()
+    renaming
+        ( isLattice to isLatticeˡ
+        ; _≼_ to _≼ˡ_
+        )
+open Program prog
+
+-- Now, allow StmtEvaluators to be auto-constructed from ExprEvaluators.
+module ExprToStmtAdapter {{ exprEvaluator : ExprEvaluator }} where
+    open ExprEvaluator exprEvaluator
+        using ()
+        renaming
+            ( eval to evalᵉ
+            ; eval-Monoʳ to evalᵉ-Monoʳ
+            )
+
+    -- For a particular evaluation function, we need to perform an evaluation
+    -- for an assignment, and update the corresponding key. Use Exercise 4.26's
+    -- generalized update to set the single key's value.
+    private module _ (k : String) (e : Expr) where
+        open VariableValuesFiniteMap.GeneralizedUpdate {{isLatticeᵛ}} (λ x → x) (λ a₁≼a₂ → a₁≼a₂) (λ _ → evalᵉ e) (λ _ {vs₁} {vs₂} vs₁≼vs₂ → evalᵉ-Monoʳ e {vs₁} {vs₂} vs₁≼vs₂) (k ∷ [])
+            using ()
+            renaming
+                ( f' to updateVariablesFromExpression
+                ; f'-Monotonic to updateVariablesFromExpression-Mono
+                ; f'-k∈ks-≡ to updateVariablesFromExpression-k∈ks-≡
+                ; f'-k∉ks-backward to updateVariablesFromExpression-k∉ks-backward
+                )
+            public
+
+    -- The per-state update function makes use of the single-key setter,
+    -- updateVariablesFromExpression, for the case where the statement
+    -- is an assignment.
+    --
+    -- This per-state function adjusts the variables in that state,
+    -- also monotonically; we derive the for-each-state update from
+    -- the Exercise 4.26 again.
+
+    evalᵇ : State → BasicStmt → VariableValues → VariableValues
+    evalᵇ _ (k ← e) vs = updateVariablesFromExpression k e vs
+    evalᵇ _ noop vs = vs
+
+    evalᵇ-Monoʳ : ∀ (s : State) (bs : BasicStmt) → Monotonic _≼ᵛ_ _≼ᵛ_ (evalᵇ s bs)
+    evalᵇ-Monoʳ _ (k ← e) {vs₁} {vs₂} vs₁≼vs₂ = updateVariablesFromExpression-Mono k e {vs₁} {vs₂} vs₁≼vs₂
+    evalᵇ-Monoʳ _ noop vs₁≼vs₂ = vs₁≼vs₂
+
+    instance
+        stmtEvaluator : StmtEvaluator
+        stmtEvaluator = record { eval = evalᵇ ; eval-Monoʳ = evalᵇ-Monoʳ }
+
+    -- Moreover, correct StmtEvaluators can be constructed from correct
+    -- ExprEvaluators.
+    module _ {{latticeInterpretationˡ : LatticeInterpretation isLatticeˡ}}
+             {{isValid : ValidExprEvaluator exprEvaluator latticeInterpretationˡ}} where
+        open ValidExprEvaluator isValid using () renaming (valid to validᵉ)
+
+        evalᵇ-valid : ∀ {s vs ρ₁ ρ₂ bs} → ρ₁ , bs ⇒ᵇ ρ₂ → ⟦ vs ⟧ᵛ ρ₁ → ⟦ evalᵇ s bs vs ⟧ᵛ ρ₂
+        evalᵇ-valid {_} {vs} {ρ₁} {ρ₁} {_} (⇒ᵇ-noop ρ₁) ⟦vs⟧ρ₁ = ⟦vs⟧ρ₁
+        evalᵇ-valid {_} {vs} {ρ₁} {_} {_} (⇒ᵇ-← ρ₁ k e v ρ,e⇒v) ⟦vs⟧ρ₁ {k'} {l} k',l∈vs' {v'} k',v'∈ρ₂
+            with k ≟ˢ k' | k',v'∈ρ₂
+        ...   | yes refl | here _ v _
+                rewrite updateVariablesFromExpression-k∈ks-≡ k e {l = vs} (Any.here refl) k',l∈vs' =
+                validᵉ ρ,e⇒v ⟦vs⟧ρ₁
+        ...   | yes k≡k' | there _ _ _ _ _ k'≢k _ = ⊥-elim (k'≢k (sym k≡k'))
+        ...   | no k≢k' | here _ _ _ = ⊥-elim (k≢k' refl)
+        ...   | no k≢k'  | there _ _ _ _ _ _ k',v'∈ρ₁ =
+                let
+                    k'∉[k] = (λ { (Any.here refl) → k≢k' refl })
+                    k',l∈vs = updateVariablesFromExpression-k∉ks-backward k e {l = vs} k'∉[k] k',l∈vs'
+                in
+                    ⟦vs⟧ρ₁ k',l∈vs k',v'∈ρ₁
+
+        instance
+            validStmtEvaluator : ValidStmtEvaluator stmtEvaluator latticeInterpretationˡ
+            validStmtEvaluator = record
+                { valid = λ {a} {b} {c} {d} →  evalᵇ-valid {a} {b} {c} {d}
+                }

Analysis/Forward/Evaluation.agda

@@ -0,0 +1,66 @@
+open import Language hiding (_[_])
+open import Lattice
+
+module Analysis.Forward.Evaluation
+    (L : Set) {h}
+    {_≈ˡ_ : L → L → Set} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
+    {{isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+    {{≈ˡ-dec : IsDecidable _≈ˡ_}}
+    (prog : Program) where
+
+open import Analysis.Forward.Lattices L prog
+open import Data.Product using (_,_)
+
+open IsFiniteHeightLattice isFiniteHeightLatticeˡ
+    using ()
+    renaming
+        ( isLattice to isLatticeˡ
+        ; _≼_ to _≼ˡ_
+        )
+open Program prog
+
+-- The "full" version of the analysis ought to define a function
+-- that analyzes each basic statement. For some analyses, the state ID
+-- is used as part of the lattice, so include it here.
+record StmtEvaluator : Set where
+    field
+        eval : State → BasicStmt → VariableValues → VariableValues
+        eval-Monoʳ : ∀ (s : State) (bs : BasicStmt) → Monotonic _≼ᵛ_ _≼ᵛ_ (eval s bs)
+
+-- For some "simpler" analyes, all we need to do is analyze the expressions.
+-- For that purpose, provide a simpler evaluator type.
+record ExprEvaluator : Set where
+    field
+        eval : Expr → VariableValues → L
+        eval-Monoʳ : ∀ (e : Expr) → Monotonic _≼ᵛ_ _≼ˡ_ (eval e)
+
+-- Evaluators have a notion of being "valid", in which the (symbolic)
+-- manipulations on lattice elements they perform match up with
+-- the semantics. Define what it means to be valid for statement and
+-- expression-based evaluators. Define "IsValidExprEvaluator"
+-- and "IsValidStmtEvaluator" standalone so that users can use them
+-- in their type expressions.
+
+module _ {{evaluator : ExprEvaluator}} {{interpretation : LatticeInterpretation isLatticeˡ}} where
+    open ExprEvaluator evaluator
+    open LatticeInterpretation interpretation
+
+    IsValidExprEvaluator : Set
+    IsValidExprEvaluator = ∀ {vs ρ e v} → ρ , e ⇒ᵉ v → ⟦ vs ⟧ᵛ ρ → ⟦ eval e vs ⟧ˡ v
+
+record ValidExprEvaluator (evaluator : ExprEvaluator)
+                          (interpretation : LatticeInterpretation isLatticeˡ) : Set₁ where
+    field
+        valid : IsValidExprEvaluator {{evaluator}} {{interpretation}}
+
+module _ {{evaluator : StmtEvaluator}} {{interpretation : LatticeInterpretation isLatticeˡ}} where
+    open StmtEvaluator evaluator
+    open LatticeInterpretation interpretation
+
+    IsValidStmtEvaluator : Set
+    IsValidStmtEvaluator = ∀ {s vs ρ₁ ρ₂ bs} → ρ₁ , bs ⇒ᵇ ρ₂ → ⟦ vs ⟧ᵛ ρ₁ → ⟦ eval s bs vs ⟧ᵛ ρ₂
+
+record ValidStmtEvaluator (evaluator : StmtEvaluator)
+                           (interpretation : LatticeInterpretation isLatticeˡ) : Set₁ where
+    field
+        valid : IsValidStmtEvaluator {{evaluator}} {{interpretation}}

Analysis/Forward/Lattices.agda

@@ -0,0 +1,195 @@
+open import Language hiding (_[_])
+open import Lattice
+
+module Analysis.Forward.Lattices
+    (L : Set) {h}
+    {_≈ˡ_ : L → L → Set} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
+    {{isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+    {{≈ˡ-Decidable : IsDecidable _≈ˡ_}}
+    (prog : Program) where
+
+open import Data.String using (String) renaming (_≟_ to _≟ˢ_)
+open import Data.Product using (proj₁; proj₂; _,_)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.List using (List; _∷_; []; foldr)
+open import Data.List.Membership.Propositional using () renaming (_∈_ to _∈ˡ_)
+open import Data.List.Relation.Unary.Any as Any using ()
+open import Relation.Binary.PropositionalEquality using (_≡_; refl)
+open import Utils using (Pairwise; _⇒_; _∨_; it)
+
+open IsFiniteHeightLattice isFiniteHeightLatticeˡ
+    using ()
+    renaming
+        ( isLattice to isLatticeˡ
+        ; fixedHeight to fixedHeightˡ
+        ; ≈-sym to ≈ˡ-sym
+        )
+open Program prog
+
+import Lattice.FiniteMap
+import Chain
+
+instance
+    ≡-Decidable-String = record { R-dec = _≟ˢ_ }
+    ≡-Decidable-State = record { R-dec = _≟_ }
+
+-- The variable -> abstract value (e.g. sign) map is a finite value-map
+-- with keys strings. Use a bundle to avoid explicitly specifying operators.
+-- It's helpful to export these via 'public' since consumers tend to
+-- use various variable lattice operations.
+module VariableValuesFiniteMap = Lattice.FiniteMap String L vars
+open VariableValuesFiniteMap
+    using ()
+    renaming
+        ( FiniteMap to VariableValues
+        ; isLattice to isLatticeᵛ
+        ; _≈_ to _≈ᵛ_
+        ; _⊔_ to _⊔ᵛ_
+        ; _≼_ to _≼ᵛ_
+        ; ≈-Decidable to ≈ᵛ-Decidable
+        ; _∈_ to _∈ᵛ_
+        ; _∈k_ to _∈kᵛ_
+        ; _updating_via_ to _updatingᵛ_via_
+        ; locate to locateᵛ
+        ; m₁≼m₂⇒m₁[k]≼m₂[k] to m₁≼m₂⇒m₁[k]ᵛ≼m₂[k]ᵛ
+        ; ∈k-dec to ∈k-decᵛ
+        ; all-equal-keys to all-equal-keysᵛ
+        ; Provenance-union to Provenance-unionᵛ
+        ; ⊔-Monotonicˡ to ⊔ᵛ-Monotonicˡ
+        ; ⊔-Monotonicʳ to ⊔ᵛ-Monotonicʳ
+        ; ⊔-idemp to ⊔ᵛ-idemp
+        )
+    public
+open VariableValuesFiniteMap.FixedHeight vars-Unique
+    using ()
+    renaming
+        ( isFiniteHeightLattice to isFiniteHeightLatticeᵛ
+        ; fixedHeight to fixedHeightᵛ
+        ; ⊥-contains-bottoms to ⊥ᵛ-contains-bottoms
+        )
+    public
+
+⊥ᵛ = Chain.Height.⊥ fixedHeightᵛ
+
+-- Finally, the map we care about is (state -> (variables -> value)). Bring that in.
+module StateVariablesFiniteMap = Lattice.FiniteMap State VariableValues states
+open StateVariablesFiniteMap
+    using (_[_]; []-∈; m₁≼m₂⇒m₁[ks]≼m₂[ks]; m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂)
+    renaming
+        ( FiniteMap to StateVariables
+        ; isLattice to isLatticeᵐ
+        ; _≈_ to _≈ᵐ_
+        ; _∈_ to _∈ᵐ_
+        ; _∈k_ to _∈kᵐ_
+        ; locate to locateᵐ
+        ; _≼_ to _≼ᵐ_
+        ; ≈-Decidable to ≈ᵐ-Decidable
+        ; m₁≼m₂⇒m₁[k]≼m₂[k] to m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ
+        ; ≈-sym to ≈ᵐ-sym
+        )
+    public
+open StateVariablesFiniteMap.FixedHeight states-Unique
+    using ()
+    renaming
+        ( isFiniteHeightLattice to isFiniteHeightLatticeᵐ
+        )
+    public
+
+-- We now have our (state -> (variables -> value)) map.
+-- Define a couple of helpers to retrieve values from it. Specifically,
+-- since the State type is as specific as possible, it's always possible to
+-- retrieve the variable values at each state.
+
+states-in-Map : ∀ (s : State) (sv : StateVariables) → s ∈kᵐ sv
+states-in-Map s sv@(m , ksv≡states) rewrite ksv≡states = states-complete s
+
+variablesAt : State → StateVariables → VariableValues
+variablesAt s sv = proj₁ (locateᵐ {s} {sv} (states-in-Map s sv))
+
+variablesAt-∈ : ∀ (s : State) (sv : StateVariables) → (s , variablesAt s sv) ∈ᵐ sv
+variablesAt-∈ s sv = proj₂ (locateᵐ {s} {sv} (states-in-Map s sv))
+
+variablesAt-≈ : ∀ s sv₁ sv₂ → sv₁ ≈ᵐ sv₂ → variablesAt s sv₁ ≈ᵛ variablesAt s sv₂
+variablesAt-≈ s sv₁ sv₂ sv₁≈sv₂ =
+    m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ sv₁ sv₂ sv₁≈sv₂
+                           (states-in-Map s sv₁) (states-in-Map s sv₂)
+
+-- build up the 'join' function, which follows from Exercise 4.26's
+--
+--    L₁ → (A → L₂)
+--
+-- Construction, with L₁ = (A → L₂), and f = id
+
+joinForKey : State → StateVariables → VariableValues
+joinForKey k states = foldr _⊔ᵛ_ ⊥ᵛ (states [ incoming k ])
+
+-- The per-key join is made up of map key accesses (which are monotonic)
+-- and folds using the join operation (also monotonic)
+
+joinForKey-Mono : ∀ (k : State) → Monotonic _≼ᵐ_ _≼ᵛ_ (joinForKey k)
+joinForKey-Mono k {fm₁} {fm₂} fm₁≼fm₂ =
+    foldr-Mono it it (fm₁ [ incoming k ]) (fm₂ [ incoming k ]) _⊔ᵛ_ ⊥ᵛ ⊥ᵛ
+               (m₁≼m₂⇒m₁[ks]≼m₂[ks] fm₁ fm₂ (incoming k) fm₁≼fm₂)
+               (⊔ᵛ-idemp ⊥ᵛ) ⊔ᵛ-Monotonicʳ ⊔ᵛ-Monotonicˡ
+
+-- The name f' comes from the formulation of Exercise 4.26.
+open StateVariablesFiniteMap.GeneralizedUpdate {{isLatticeᵐ}} (λ x → x) (λ a₁≼a₂ → a₁≼a₂) joinForKey joinForKey-Mono states
+    using ()
+    renaming
+        ( f' to joinAll
+        ; f'-Monotonic to joinAll-Mono
+        ; f'-k∈ks-≡ to joinAll-k∈ks-≡
+        )
+    public
+
+variablesAt-joinAll : ∀ (s : State) (sv : StateVariables) →
+                      variablesAt s (joinAll sv) ≡ joinForKey s sv
+variablesAt-joinAll s sv
+    with (vs , s,vs∈usv) ← locateᵐ {s} {joinAll sv} (states-in-Map s (joinAll sv)) =
+    joinAll-k∈ks-≡ {l = sv} (states-complete s) s,vs∈usv
+
+-- Elements of the lattice type L describe individual variables. What
+-- exactly each lattice element says about the variable is defined
+-- by a LatticeInterpretation element. We've now constructed the
+-- (Variable → L) lattice, which describes states, and we need to lift
+-- the "meaning" of the element lattice to a descriptions of states.
+module _ {{latticeInterpretationˡ : LatticeInterpretation isLatticeˡ}} where
+    open LatticeInterpretation latticeInterpretationˡ
+        using ()
+        renaming
+            ( ⟦_⟧ to ⟦_⟧ˡ
+            ; ⟦⟧-respects-≈ to ⟦⟧ˡ-respects-≈ˡ
+            ; ⟦⟧-⊔-∨ to ⟦⟧ˡ-⊔ˡ-∨
+            )
+        public
+
+    ⟦_⟧ᵛ : VariableValues → Env → Set
+    ⟦_⟧ᵛ vs ρ = ∀ {k l} → (k , l) ∈ᵛ vs → ∀ {v} → (k , v) Language.∈ ρ → ⟦ l ⟧ˡ v
+
+    ⟦⊥ᵛ⟧ᵛ∅ : ⟦ ⊥ᵛ ⟧ᵛ []
+    ⟦⊥ᵛ⟧ᵛ∅ _ ()
+
+    ⟦⟧ᵛ-respects-≈ᵛ : ∀ {vs₁ vs₂ : VariableValues} → vs₁ ≈ᵛ vs₂ → ⟦ vs₁ ⟧ᵛ ⇒ ⟦ vs₂ ⟧ᵛ
+    ⟦⟧ᵛ-respects-≈ᵛ {m₁ , _} {m₂ , _}
+                    (m₁⊆m₂ , m₂⊆m₁) ρ ⟦vs₁⟧ρ {k} {l} k,l∈m₂ {v} k,v∈ρ =
+        let
+            (l' , (l≈l' , k,l'∈m₁)) = m₂⊆m₁ _ _ k,l∈m₂
+            ⟦l'⟧v = ⟦vs₁⟧ρ k,l'∈m₁ k,v∈ρ
+        in
+            ⟦⟧ˡ-respects-≈ˡ (≈ˡ-sym l≈l') v ⟦l'⟧v
+
+    ⟦⟧ᵛ-⊔ᵛ-∨ : ∀ {vs₁ vs₂ : VariableValues} → (⟦ vs₁ ⟧ᵛ ∨ ⟦ vs₂ ⟧ᵛ) ⇒ ⟦ vs₁ ⊔ᵛ vs₂ ⟧ᵛ
+    ⟦⟧ᵛ-⊔ᵛ-∨ {vs₁} {vs₂} ρ ⟦vs₁⟧ρ∨⟦vs₂⟧ρ {k} {l} k,l∈vs₁₂ {v} k,v∈ρ
+        with ((l₁ , l₂) , (refl , (k,l₁∈vs₁ , k,l₂∈vs₂)))
+             ← Provenance-unionᵛ vs₁ vs₂ k,l∈vs₁₂
+        with ⟦vs₁⟧ρ∨⟦vs₂⟧ρ
+    ...   | inj₁ ⟦vs₁⟧ρ = ⟦⟧ˡ-⊔ˡ-∨ {l₁} {l₂} v (inj₁ (⟦vs₁⟧ρ k,l₁∈vs₁ k,v∈ρ))
+    ...   | inj₂ ⟦vs₂⟧ρ = ⟦⟧ˡ-⊔ˡ-∨ {l₁} {l₂} v (inj₂ (⟦vs₂⟧ρ k,l₂∈vs₂ k,v∈ρ))
+
+    ⟦⟧ᵛ-foldr : ∀ {vs : VariableValues} {vss : List VariableValues} {ρ : Env} →
+                ⟦ vs ⟧ᵛ ρ → vs ∈ˡ vss → ⟦ foldr _⊔ᵛ_ ⊥ᵛ vss ⟧ᵛ ρ
+    ⟦⟧ᵛ-foldr {vs} {vs ∷ vss'} {ρ = ρ} ⟦vs⟧ρ (Any.here refl) =
+        ⟦⟧ᵛ-⊔ᵛ-∨ {vs₁ = vs} {vs₂ = foldr _⊔ᵛ_ ⊥ᵛ vss'} ρ (inj₁ ⟦vs⟧ρ)
+    ⟦⟧ᵛ-foldr {vs} {vs' ∷ vss'} {ρ = ρ} ⟦vs⟧ρ (Any.there vs∈vss') =
+        ⟦⟧ᵛ-⊔ᵛ-∨ {vs₁ = vs'} {vs₂ = foldr _⊔ᵛ_ ⊥ᵛ vss'} ρ
+                 (inj₂ (⟦⟧ᵛ-foldr ⟦vs⟧ρ vs∈vss'))

Analysis/Sign.agda

@@ -1,19 +1,22 @@
 module Analysis.Sign where
 
-open import Data.Integer using (ℤ; +_; -[1+_])
-open import Data.Nat using (ℕ; suc; zero)
-open import Data.Product using (Σ; proj₁; _,_)
+open import Data.Integer as Int using (ℤ; +_; -[1+_])
+open import Data.Nat as Nat using (ℕ; suc; zero)
+open import Data.Product using (Σ; proj₁; proj₂; _,_)
 open import Data.Sum using (inj₁; inj₂)
 open import Data.Empty using (⊥; ⊥-elim)
 open import Data.Unit using (⊤; tt)
 open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
+open import Relation.Binary.Definitions using (Decidable)
 open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst)
 open import Relation.Nullary using (¬_; yes; no)
 
 open import Language
 open import Lattice
+open import Equivalence
 open import Showable using (Showable; show)
 open import Utils using (_⇒_; _∧_; _∨_)
+open import Analysis.Utils using (eval-combine₂)
 import Analysis.Forward
 
 data Sign : Set where
@@ -32,7 +35,7 @@ instance
         }
 
 -- g for siGn; s is used for strings and i is not very descriptive.
-_≟ᵍ_ : IsDecidable (_≡_ {_} {Sign})
+_≟ᵍ_ : Decidable (_≡_ {_} {Sign})
 _≟ᵍ_ + + = yes refl
 _≟ᵍ_ + - = no (λ ())
 _≟ᵍ_ + 0ˢ = no (λ ())
@@ -43,12 +46,22 @@ _≟ᵍ_ 0ˢ + = no (λ ())
 _≟ᵍ_ 0ˢ - = no (λ ())
 _≟ᵍ_ 0ˢ 0ˢ = yes refl
 
+instance
+    ≡-equiv : IsEquivalence Sign _≡_
+    ≡-equiv = record
+        { ≈-refl = refl
+        ; ≈-sym = sym
+        ; ≈-trans = trans
+        }
+
+    ≡-Decidable-Sign : IsDecidable {_} {Sign} _≡_
+    ≡-Decidable-Sign = record { R-dec = _≟ᵍ_ }
+
 -- embelish 'sign' with a top and bottom element.
-open import Lattice.AboveBelow Sign _≡_ (record { ≈-refl = refl; ≈-sym = sym; ≈-trans = trans }) _≟ᵍ_ as AB
+open import Lattice.AboveBelow Sign _ as AB
     using ()
     renaming
         ( AboveBelow to SignLattice
-        ; ≈-dec to ≈ᵍ-dec
         ; ⊥ to ⊥ᵍ
         ; ⊤ to ⊤ᵍ
         ; [_] to [_]ᵍ
@@ -62,15 +75,11 @@ open import Lattice.AboveBelow Sign _≡_ (record { ≈-refl = refl; ≈-sym = s
 open AB.Plain 0ˢ using ()
     renaming
         ( isLattice to isLatticeᵍ
-        ; fixedHeight to fixedHeightᵍ
+        ; isFiniteHeightLattice to isFiniteHeightLatticeᵍ
         ; _≼_ to _≼ᵍ_
         ; _⊔_ to _⊔ᵍ_
         ; _⊓_ to _⊓ᵍ_
-        )
-
-open IsLattice isLatticeᵍ using ()
-    renaming
-        ( ≼-trans to ≼ᵍ-trans
+        ; ≼-trans to ≼ᵍ-trans
         )
 
 plus : SignLattice → SignLattice → SignLattice
@@ -93,6 +102,9 @@ plus [ 0ˢ ]ᵍ [ 0ˢ ]ᵍ = [ 0ˢ ]ᵍ
 postulate plus-Monoˡ : ∀ (s₂ : SignLattice) → Monotonic _≼ᵍ_ _≼ᵍ_ (λ s₁ → plus s₁ s₂)
 postulate plus-Monoʳ : ∀ (s₁ : SignLattice) → Monotonic _≼ᵍ_ _≼ᵍ_ (plus s₁)
 
+plus-Mono₂ : Monotonic₂ _≼ᵍ_ _≼ᵍ_ _≼ᵍ_ plus
+plus-Mono₂ = (plus-Monoˡ , plus-Monoʳ)
+
 minus : SignLattice → SignLattice → SignLattice
 minus ⊥ᵍ _ = ⊥ᵍ
 minus _ ⊥ᵍ = ⊥ᵍ
@@ -111,11 +123,14 @@ minus [ 0ˢ ]ᵍ [ 0ˢ ]ᵍ = [ 0ˢ ]ᵍ
 postulate minus-Monoˡ : ∀ (s₂ : SignLattice) → Monotonic _≼ᵍ_ _≼ᵍ_ (λ s₁ → minus s₁ s₂)
 postulate minus-Monoʳ : ∀ (s₁ : SignLattice) → Monotonic _≼ᵍ_ _≼ᵍ_ (minus s₁)
 
+minus-Mono₂ : Monotonic₂ _≼ᵍ_ _≼ᵍ_ _≼ᵍ_ minus
+minus-Mono₂ = (minus-Monoˡ , minus-Monoʳ)
+
 ⟦_⟧ᵍ : SignLattice → Value → Set
 ⟦_⟧ᵍ ⊥ᵍ _ = ⊥
 ⟦_⟧ᵍ ⊤ᵍ _ = ⊤
 ⟦_⟧ᵍ [ + ]ᵍ v = Σ ℕ (λ n → v ≡ ↑ᶻ (+_ (suc n)))
-⟦_⟧ᵍ [ 0ˢ ]ᵍ v = Σ ℕ (λ n → v ≡ ↑ᶻ (+_ zero))
+⟦_⟧ᵍ [ 0ˢ ]ᵍ v = v ≡ ↑ᶻ (+_ zero)
 ⟦_⟧ᵍ [ - ]ᵍ v = Σ ℕ (λ n → v ≡ ↑ᶻ -[1+ n ])
 
 ⟦⟧ᵍ-respects-≈ᵍ : ∀ {s₁ s₂ : SignLattice} → s₁ ≈ᵍ s₂ → ⟦ s₁ ⟧ᵍ ⇒ ⟦ s₂ ⟧ᵍ
@@ -141,12 +156,12 @@ postulate minus-Monoʳ : ∀ (s₁ : SignLattice) → Monotonic _≼ᵍ_ _≼ᵍ
 s₁≢s₂⇒¬s₁∧s₂ : ∀ {s₁ s₂ : Sign} → ¬ s₁ ≡ s₂ → ∀ {v} → ¬ ((⟦ [ s₁ ]ᵍ ⟧ᵍ ∧ ⟦ [ s₂ ]ᵍ ⟧ᵍ) v)
 s₁≢s₂⇒¬s₁∧s₂ { + } { + } +≢+ _ = ⊥-elim (+≢+ refl)
 s₁≢s₂⇒¬s₁∧s₂ { + } { - } _ ((n , refl) , (m , ()))
-s₁≢s₂⇒¬s₁∧s₂ { + } { 0ˢ } _ ((n , refl) , (m , ()))
-s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { + } _ ((n , refl) , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { + } { 0ˢ } _ ((n , refl) , ())
+s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { + } _ (refl , (m , ()))
 s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { 0ˢ } +≢+ _ = ⊥-elim (+≢+ refl)
-s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { - } _ ((n , refl) , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { - } _ (refl , (m , ()))
 s₁≢s₂⇒¬s₁∧s₂ { - } { + } _ ((n , refl) , (m , ()))
-s₁≢s₂⇒¬s₁∧s₂ { - } { 0ˢ } _ ((n , refl) , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { - } { 0ˢ } _ ((n , refl) , ())
 s₁≢s₂⇒¬s₁∧s₂ { - } { - } +≢+ _ = ⊥-elim (+≢+ refl)
 
 ⟦⟧ᵍ-⊓ᵍ-∧ : ∀ {s₁ s₂ : SignLattice} → (⟦ s₁ ⟧ᵍ ∧ ⟦ s₂ ⟧ᵍ) ⇒ ⟦ s₁ ⊓ᵍ s₂ ⟧ᵍ
@@ -159,8 +174,9 @@ s₁≢s₂⇒¬s₁∧s₂ { - } { - } +≢+ _ = ⊥-elim (+≢+ refl)
 ⟦⟧ᵍ-⊓ᵍ-∧ {[ g₁ ]ᵍ} {⊥ᵍ} x (_ , bot) = bot
 ⟦⟧ᵍ-⊓ᵍ-∧ {[ g₁ ]ᵍ} {⊤ᵍ} x (px₁ , _) = px₁
 
-latticeInterpretationᵍ : LatticeInterpretation isLatticeᵍ
-latticeInterpretationᵍ = record
+instance
+    latticeInterpretationᵍ : LatticeInterpretation isLatticeᵍ
+    latticeInterpretationᵍ = record
         { ⟦_⟧ = ⟦_⟧ᵍ
         ; ⟦⟧-respects-≈ = ⟦⟧ᵍ-respects-≈ᵍ
         ; ⟦⟧-⊔-∨ = ⟦⟧ᵍ-⊔ᵍ-∨
@@ -170,8 +186,9 @@ latticeInterpretationᵍ = record
 module WithProg (prog : Program) where
     open Program prog
 
-    module ForwardWithProg = Analysis.Forward.WithProg (record { isLattice = isLatticeᵍ; fixedHeight = fixedHeightᵍ }) ≈ᵍ-dec prog
-    open ForwardWithProg
+    open import Analysis.Forward.Lattices SignLattice prog
+    open import Analysis.Forward.Evaluation SignLattice prog
+    open import Analysis.Forward.Adapters SignLattice prog
 
     eval : ∀ (e : Expr) → VariableValues → SignLattice
     eval (e₁ + e₂) vs = plus (eval e₁ vs) (eval e₂ vs)
@@ -183,32 +200,16 @@ module WithProg (prog : Program) where
     eval (# 0) _ = [ 0ˢ ]ᵍ
     eval (# (suc n')) _ = [ + ]ᵍ
 
-    eval-Mono : ∀ (e : Expr) → Monotonic _≼ᵛ_ _≼ᵍ_ (eval e)
-    eval-Mono (e₁ + e₂) {vs₁} {vs₂} vs₁≼vs₂ =
-        let
-            -- TODO: can this be done with less boilerplate?
-            g₁vs₁ = eval e₁ vs₁
-            g₂vs₁ = eval e₂ vs₁
-            g₁vs₂ = eval e₁ vs₂
-            g₂vs₂ = eval e₂ vs₂
-        in
-            ≼ᵍ-trans
-                {plus g₁vs₁ g₂vs₁} {plus g₁vs₂ g₂vs₁} {plus g₁vs₂ g₂vs₂}
-                (plus-Monoˡ g₂vs₁ {g₁vs₁} {g₁vs₂} (eval-Mono e₁ {vs₁} {vs₂} vs₁≼vs₂))
-                (plus-Monoʳ g₁vs₂ {g₂vs₁} {g₂vs₂} (eval-Mono e₂ {vs₁} {vs₂} vs₁≼vs₂))
-    eval-Mono (e₁ - e₂) {vs₁} {vs₂} vs₁≼vs₂ =
-        let
-            -- TODO: here too -- can this be done with less boilerplate?
-            g₁vs₁ = eval e₁ vs₁
-            g₂vs₁ = eval e₂ vs₁
-            g₁vs₂ = eval e₁ vs₂
-            g₂vs₂ = eval e₂ vs₂
-        in
-            ≼ᵍ-trans
-                {minus g₁vs₁ g₂vs₁} {minus g₁vs₂ g₂vs₁} {minus g₁vs₂ g₂vs₂}
-                (minus-Monoˡ g₂vs₁ {g₁vs₁} {g₁vs₂} (eval-Mono e₁ {vs₁} {vs₂} vs₁≼vs₂))
-                (minus-Monoʳ g₁vs₂ {g₂vs₁} {g₂vs₂} (eval-Mono e₂ {vs₁} {vs₂} vs₁≼vs₂))
-    eval-Mono (` k) {vs₁@((kvs₁ , _) , _)} {vs₂@((kvs₂ , _), _)} vs₁≼vs₂
+    eval-Monoʳ : ∀ (e : Expr) → Monotonic _≼ᵛ_ _≼ᵍ_ (eval e)
+    eval-Monoʳ (e₁ + e₂) {vs₁} {vs₂} vs₁≼vs₂ =
+        eval-combine₂ (λ {x} {y} {z} →  ≼ᵍ-trans {x} {y} {z})
+                      plus plus-Mono₂ {o₁ = eval e₁ vs₁}
+                      (eval-Monoʳ e₁ vs₁≼vs₂) (eval-Monoʳ e₂ vs₁≼vs₂)
+    eval-Monoʳ (e₁ - e₂) {vs₁} {vs₂} vs₁≼vs₂ =
+        eval-combine₂ (λ {x} {y} {z} →  ≼ᵍ-trans {x} {y} {z})
+                      minus minus-Mono₂ {o₁ = eval e₁ vs₁}
+                      (eval-Monoʳ e₁ vs₁≼vs₂) (eval-Monoʳ e₂ vs₁≼vs₂)
+    eval-Monoʳ (` k) {vs₁@((kvs₁ , _) , _)} {vs₂@((kvs₂ , _), _)} vs₁≼vs₂
         with ∈k-decᵛ k kvs₁ | ∈k-decᵛ k kvs₂
     ...   | yes k∈kvs₁ | yes k∈kvs₂ =
             let
@@ -219,10 +220,80 @@ module WithProg (prog : Program) where
     ...   | yes k∈kvs₁ | no k∉kvs₂ = ⊥-elim (k∉kvs₂ (subst (λ l → k ∈ˡ l) (all-equal-keysᵛ vs₁ vs₂) k∈kvs₁))
     ...   | no k∉kvs₁ | yes k∈kvs₂ = ⊥-elim (k∉kvs₁ (subst (λ l → k ∈ˡ l) (all-equal-keysᵛ vs₂ vs₁) k∈kvs₂))
     ...   | no k∉kvs₁ | no k∉kvs₂ = IsLattice.≈-refl isLatticeᵍ
-    eval-Mono (# 0) _ = ≈ᵍ-refl
-    eval-Mono (# (suc n')) _ = ≈ᵍ-refl
+    eval-Monoʳ (# 0) _ = ≈ᵍ-refl
+    eval-Monoʳ (# (suc n')) _ = ≈ᵍ-refl
 
-    open ForwardWithProg.WithEvaluator eval eval-Mono using (result)
+    instance
+        SignEval : ExprEvaluator
+        SignEval = record { eval = eval; eval-Monoʳ = eval-Monoʳ }
 
     -- For debugging purposes, print out the result.
-    output = show result
+    output = show (Analysis.Forward.WithProg.result SignLattice prog)
+
+    -- This should have fewer cases -- the same number as the actual 'plus' above.
+    -- But agda only simplifies on first argument, apparently, so we are stuck
+    -- listing them all.
+    plus-valid : ∀ {g₁ g₂} {z₁ z₂} → ⟦ g₁ ⟧ᵍ (↑ᶻ z₁) → ⟦ g₂ ⟧ᵍ (↑ᶻ z₂) → ⟦ plus g₁ g₂ ⟧ᵍ (↑ᶻ (z₁ Int.+ z₂))
+    plus-valid {⊥ᵍ} {_} ⊥ _ = ⊥
+    plus-valid {[ + ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    plus-valid {[ - ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    plus-valid {[ 0ˢ ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    plus-valid {⊤ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    plus-valid {⊤ᵍ} {[ + ]ᵍ} _ _ = tt
+    plus-valid {⊤ᵍ} {[ - ]ᵍ} _ _ = tt
+    plus-valid {⊤ᵍ} {[ 0ˢ ]ᵍ} _ _ = tt
+    plus-valid {⊤ᵍ} {⊤ᵍ} _ _ = tt
+    plus-valid {[ + ]ᵍ} {[ + ]ᵍ} (n₁ , refl) (n₂ , refl) = (_ , refl)
+    plus-valid {[ + ]ᵍ} {[ - ]ᵍ} _ _ = tt
+    plus-valid {[ + ]ᵍ} {[ 0ˢ ]ᵍ} (n₁ , refl) refl = (_ , refl)
+    plus-valid {[ + ]ᵍ} {⊤ᵍ} _ _ = tt
+    plus-valid {[ - ]ᵍ} {[ + ]ᵍ} _ _ = tt
+    plus-valid {[ - ]ᵍ} {[ - ]ᵍ} (n₁ , refl) (n₂ , refl) = (_ , refl)
+    plus-valid {[ - ]ᵍ} {[ 0ˢ ]ᵍ} (n₁ , refl) refl = (_ , refl)
+    plus-valid {[ - ]ᵍ} {⊤ᵍ} _ _ = tt
+    plus-valid {[ 0ˢ ]ᵍ} {[ + ]ᵍ} refl (n₂ , refl) = (_ , refl)
+    plus-valid {[ 0ˢ ]ᵍ} {[ - ]ᵍ} refl (n₂ , refl) = (_ , refl)
+    plus-valid {[ 0ˢ ]ᵍ} {[ 0ˢ ]ᵍ} refl refl = refl
+    plus-valid {[ 0ˢ ]ᵍ} {⊤ᵍ} _ _ = tt
+
+    -- Same for this one. It should be easier, but Agda won't simplify.
+    minus-valid : ∀ {g₁ g₂} {z₁ z₂} → ⟦ g₁ ⟧ᵍ (↑ᶻ z₁) → ⟦ g₂ ⟧ᵍ (↑ᶻ z₂) → ⟦ minus g₁ g₂ ⟧ᵍ (↑ᶻ (z₁ Int.- z₂))
+    minus-valid {⊥ᵍ} {_} ⊥ _ = ⊥
+    minus-valid {[ + ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    minus-valid {[ - ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    minus-valid {[ 0ˢ ]ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    minus-valid {⊤ᵍ} {⊥ᵍ} _ ⊥ = ⊥
+    minus-valid {⊤ᵍ} {[ + ]ᵍ} _ _ = tt
+    minus-valid {⊤ᵍ} {[ - ]ᵍ} _ _ = tt
+    minus-valid {⊤ᵍ} {[ 0ˢ ]ᵍ} _ _ = tt
+    minus-valid {⊤ᵍ} {⊤ᵍ} _ _ = tt
+    minus-valid {[ + ]ᵍ} {[ + ]ᵍ} _ _ = tt
+    minus-valid {[ + ]ᵍ} {[ - ]ᵍ} (n₁ , refl) (n₂ , refl) = (_ , refl)
+    minus-valid {[ + ]ᵍ} {[ 0ˢ ]ᵍ} (n₁ , refl) refl = (_ , refl)
+    minus-valid {[ + ]ᵍ} {⊤ᵍ} _ _ = tt
+    minus-valid {[ - ]ᵍ} {[ + ]ᵍ} (n₁ , refl) (n₂ , refl) = (_ , refl)
+    minus-valid {[ - ]ᵍ} {[ - ]ᵍ} _ _ = tt
+    minus-valid {[ - ]ᵍ} {[ 0ˢ ]ᵍ} (n₁ , refl) refl = (_ , refl)
+    minus-valid {[ - ]ᵍ} {⊤ᵍ} _ _ = tt
+    minus-valid {[ 0ˢ ]ᵍ} {[ + ]ᵍ} refl (n₂ , refl) = (_ , refl)
+    minus-valid {[ 0ˢ ]ᵍ} {[ - ]ᵍ} refl (n₂ , refl) = (_ , refl)
+    minus-valid {[ 0ˢ ]ᵍ} {[ 0ˢ ]ᵍ} refl refl = refl
+    minus-valid {[ 0ˢ ]ᵍ} {⊤ᵍ} _ _ = tt
+
+    eval-valid : IsValidExprEvaluator
+    eval-valid (⇒ᵉ-+ ρ e₁ e₂ z₁ z₂ ρ,e₁⇒z₁ ρ,e₂⇒z₂) ⟦vs⟧ρ =
+        plus-valid (eval-valid ρ,e₁⇒z₁ ⟦vs⟧ρ) (eval-valid ρ,e₂⇒z₂ ⟦vs⟧ρ)
+    eval-valid (⇒ᵉ-- ρ e₁ e₂ z₁ z₂ ρ,e₁⇒z₁ ρ,e₂⇒z₂) ⟦vs⟧ρ =
+        minus-valid (eval-valid ρ,e₁⇒z₁ ⟦vs⟧ρ) (eval-valid ρ,e₂⇒z₂ ⟦vs⟧ρ)
+    eval-valid {vs} (⇒ᵉ-Var ρ x v x,v∈ρ) ⟦vs⟧ρ
+        with ∈k-decᵛ x (proj₁ (proj₁ vs))
+    ...   | yes x∈kvs = ⟦vs⟧ρ (proj₂ (locateᵛ {x} {vs} x∈kvs)) x,v∈ρ
+    ...   | no x∉kvs = tt
+    eval-valid (⇒ᵉ-ℕ ρ 0) _ = refl
+    eval-valid (⇒ᵉ-ℕ ρ (suc n')) _ = (n' , refl)
+
+    instance
+        SignEvalValid : ValidExprEvaluator SignEval latticeInterpretationᵍ
+        SignEvalValid = record { valid = eval-valid }
+
+    analyze-correct = Analysis.Forward.WithProg.analyze-correct SignLattice prog tt

Analysis/Utils.agda

@@ -0,0 +1,15 @@
+module Analysis.Utils where
+
+open import Data.Product using (_,_)
+open import Lattice
+
+module _ {o} {O : Set o} {_≼ᴼ_ : O → O → Set o}
+         (≼ᴼ-trans : ∀ {o₁ o₂ o₃} → o₁ ≼ᴼ o₂ → o₂ ≼ᴼ o₃ → o₁ ≼ᴼ o₃)
+         (combine : O → O → O) (combine-Mono₂ : Monotonic₂ _≼ᴼ_ _≼ᴼ_ _≼ᴼ_ combine) where
+
+    eval-combine₂ : {o₁ o₂ o₃ o₄ : O} → o₁ ≼ᴼ o₃ → o₂ ≼ᴼ o₄ →
+                    combine o₁ o₂ ≼ᴼ combine o₃ o₄
+    eval-combine₂ {o₁} {o₂} {o₃} {o₄} o₁≼o₃ o₂≼o₄ =
+        let (combine-Monoˡ , combine-Monoʳ) = combine-Mono₂
+        in ≼ᴼ-trans (combine-Monoˡ o₂ o₁≼o₃)
+                    (combine-Monoʳ o₃ o₂≼o₄)

Chain.agda

@@ -10,7 +10,7 @@ open import Data.Nat using (ℕ; suc; _+_; _≤_)
 open import Data.Nat.Properties using (+-comm; m+1+n≰m)
 open import Data.Product using (_×_; Σ; _,_)
 open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl)
-open import Data.Empty using (⊥)
+open import Data.Empty as Empty using ()
 
 open IsEquivalence ≈-equiv
 
@@ -38,11 +38,16 @@ module _  where
     Bounded : ℕ → Set a
     Bounded bound = ∀ {a₁ a₂ : A} {n : ℕ} → Chain a₁ a₂ n → n ≤ bound
 
-    Bounded-suc-n : ∀ {a₁ a₂ : A} {n : ℕ} → Bounded n → Chain a₁ a₂ (suc n) → ⊥
+    Bounded-suc-n : ∀ {a₁ a₂ : A} {n : ℕ} → Bounded n → Chain a₁ a₂ (suc n) → Empty.⊥
     Bounded-suc-n {a₁} {a₂} {n} bounded c = (m+1+n≰m n n+1≤n)
         where
             n+1≤n : n + 1 ≤ n
             n+1≤n rewrite (+-comm n 1) = bounded c
 
-    Height : ℕ → Set a
-    Height height = (Σ (A × A) (λ (a₁ , a₂) → Chain a₁ a₂ height) × Bounded height)
+    record Height (height : ℕ) : Set a where
+        field
+            ⊥ : A
+            ⊤ : A
+
+            longestChain : Chain ⊥ ⊤ height
+            bounded : Bounded height

Equivalence.agda

@@ -2,7 +2,7 @@ module Equivalence where
 
 open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂)
 open import Relation.Binary.Definitions
-open import Relation.Binary.PropositionalEquality as Eq using (_≡_; sym)
+open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym; trans)
 
 module _ {a} (A : Set a) (_≈_ : A → A → Set a) where
     IsReflexive : Set a
@@ -19,3 +19,10 @@ module _ {a} (A : Set a) (_≈_ : A → A → Set a) where
             ≈-refl : IsReflexive
             ≈-sym : IsSymmetric
             ≈-trans : IsTransitive
+
+isEquivalence-≡ : ∀ {a} {A : Set a} → IsEquivalence A _≡_
+isEquivalence-≡ = record
+    { ≈-refl = refl
+    ; ≈-sym = sym
+    ; ≈-trans = trans
+    }

Fixedpoint.agda

@@ -5,8 +5,8 @@ module Fixedpoint {a} {A : Set a}
                   {h : ℕ}
                   {_≈_ : A → A → Set a}
                   {_⊔_ : A → A → A} {_⊓_ : A → A → A}
-                  (≈-dec : IsDecidable _≈_)
-                  (flA : IsFiniteHeightLattice A h _≈_ _⊔_ _⊓_)
+                  {{ ≈-Decidable : IsDecidable _≈_ }}
+                  {{flA : IsFiniteHeightLattice A h _≈_ _⊔_ _⊓_}}
                   (f : A → A)
                   (Monotonicᶠ : Monotonic (IsFiniteHeightLattice._≼_ flA)
                                           (IsFiniteHeightLattice._≼_ flA) f) where
@@ -17,27 +17,19 @@ open import Data.Empty using (⊥-elim)
 open import Relation.Binary.PropositionalEquality using (_≡_; sym)
 open import Relation.Nullary using (Dec; ¬_; yes; no)
 
+open IsDecidable ≈-Decidable using () renaming (R-dec to ≈-dec)
 open IsFiniteHeightLattice flA
 
 import Chain
 module ChainA = Chain _≈_ ≈-equiv _≺_ ≺-cong
 
 private
-    ⊥ᴬ : A
-    ⊥ᴬ = proj₁ (proj₁ (proj₁ fixedHeight))
-
-    ⊥ᴬ≼ : ∀ (a : A) → ⊥ᴬ ≼ a
-    ⊥ᴬ≼ a with ≈-dec a ⊥ᴬ
-    ...   | yes a≈⊥ᴬ = ≼-cong a≈⊥ᴬ ≈-refl (≼-refl a)
-    ...   | no a̷≈⊥ᴬ with ≈-dec ⊥ᴬ (a ⊓ ⊥ᴬ)
-    ...         | yes ⊥ᴬ≈a⊓⊥ᴬ = ≈-trans (⊔-comm ⊥ᴬ a) (≈-trans (≈-⊔-cong (≈-refl {a}) ⊥ᴬ≈a⊓⊥ᴬ) (absorb-⊔-⊓ a ⊥ᴬ))
-    ...         | no ⊥ᴬ̷≈a⊓⊥ᴬ = ⊥-elim (ChainA.Bounded-suc-n (proj₂ fixedHeight) (ChainA.step x≺⊥ᴬ ≈-refl (proj₂ (proj₁ fixedHeight))))
-                    where
-                        ⊥ᴬ⊓a̷≈⊥ᴬ : ¬ (⊥ᴬ ⊓ a) ≈ ⊥ᴬ
-                        ⊥ᴬ⊓a̷≈⊥ᴬ = λ ⊥ᴬ⊓a≈⊥ᴬ → ⊥ᴬ̷≈a⊓⊥ᴬ (≈-trans (≈-sym ⊥ᴬ⊓a≈⊥ᴬ) (⊓-comm _ _))
-
-                        x≺⊥ᴬ : (⊥ᴬ ⊓ a) ≺ ⊥ᴬ
-                        x≺⊥ᴬ = (≈-trans (⊔-comm _ _) (≈-trans (≈-refl {⊥ᴬ ⊔ (⊥ᴬ ⊓ a)}) (absorb-⊔-⊓ ⊥ᴬ a)) , ⊥ᴬ⊓a̷≈⊥ᴬ)
+    open ChainA.Height fixedHeight
+        using ()
+        renaming
+            ( ⊥ to ⊥ᴬ
+            ; bounded to boundedᴬ
+            )
 
     -- using 'g', for gas, here helps make sure the function terminates.
     -- since A forms a fixed-height lattice, we must find a solution after
@@ -45,7 +37,7 @@ private
     -- out, we have exceeded h steps, which shouldn't be possible.
 
     doStep : ∀ (g hᶜ : ℕ) (a₁ a₂ : A) (c : ChainA.Chain a₁ a₂ hᶜ) (g+hᶜ≡h : g + hᶜ ≡ suc h) (a₂≼fa₂ : a₂ ≼ f a₂) → Σ A (λ a → a ≈ f a)
-    doStep 0 hᶜ a₁ a₂ c g+hᶜ≡sh a₂≼fa₂ rewrite g+hᶜ≡sh = ⊥-elim (ChainA.Bounded-suc-n (proj₂ fixedHeight) c)
+    doStep 0 hᶜ a₁ a₂ c g+hᶜ≡sh a₂≼fa₂ rewrite g+hᶜ≡sh = ⊥-elim (ChainA.Bounded-suc-n boundedᴬ c)
     doStep (suc g') hᶜ a₁ a₂ c g+hᶜ≡sh a₂≼fa₂ rewrite sym (+-suc g' hᶜ)
         with ≈-dec a₂ (f a₂)
     ...   | yes a₂≈fa₂ = (a₂ , a₂≈fa₂)
@@ -58,7 +50,7 @@ private
                     c' rewrite +-comm 1 hᶜ = ChainA.concat c (ChainA.step a₂≺fa₂ ≈-refl (ChainA.done (≈-refl {f a₂})))
 
     fix : Σ A (λ a → a ≈ f a)
-    fix = doStep (suc h) 0 ⊥ᴬ ⊥ᴬ (ChainA.done ≈-refl) (+-comm (suc h) 0) (⊥ᴬ≼ (f ⊥ᴬ))
+    fix = doStep (suc h) 0 ⊥ᴬ ⊥ᴬ (ChainA.done ≈-refl) (+-comm (suc h) 0) (⊥≼ (f ⊥ᴬ))
 
 aᶠ : A
 aᶠ = proj₁ fix
@@ -67,15 +59,15 @@ aᶠ≈faᶠ : aᶠ ≈ f aᶠ
 aᶠ≈faᶠ = proj₂ fix
 
 private
-    stepPreservesLess : ∀ (g hᶜ : ℕ) (a₁ a₂ a : A) (a≈fa : a ≈ f a) (a₂≼a : a₂ ≼ a)
+    stepPreservesLess : ∀ (g hᶜ : ℕ) (a₁ a₂ b : A) (b≈fb : b ≈ f b) (a₂≼a : a₂ ≼ b)
                      (c : ChainA.Chain a₁ a₂ hᶜ) (g+hᶜ≡h : g + hᶜ ≡ suc h)
                      (a₂≼fa₂ : a₂ ≼ f a₂) →
-                     proj₁ (doStep g hᶜ a₁ a₂ c g+hᶜ≡h a₂≼fa₂) ≼ a
-    stepPreservesLess 0 _ _ _ _ _ _ c g+hᶜ≡sh _ rewrite g+hᶜ≡sh = ⊥-elim (ChainA.Bounded-suc-n (proj₂ fixedHeight) c)
-    stepPreservesLess (suc g') hᶜ a₁ a₂ a a≈fa a₂≼a c g+hᶜ≡sh a₂≼fa₂ rewrite sym (+-suc g' hᶜ)
+                     proj₁ (doStep g hᶜ a₁ a₂ c g+hᶜ≡h a₂≼fa₂) ≼ b
+    stepPreservesLess 0 _ _ _ _ _ _ c g+hᶜ≡sh _ rewrite g+hᶜ≡sh = ⊥-elim (ChainA.Bounded-suc-n boundedᴬ c)
+    stepPreservesLess (suc g') hᶜ a₁ a₂ b b≈fb a₂≼b c g+hᶜ≡sh a₂≼fa₂ rewrite sym (+-suc g' hᶜ)
         with ≈-dec a₂ (f a₂)
-    ...   | yes _ = a₂≼a
-    ...   | no  _ = stepPreservesLess g' _ _ _ a a≈fa (≼-cong ≈-refl (≈-sym a≈fa) (Monotonicᶠ a₂≼a)) _ _ _
+    ...   | yes _ = a₂≼b
+    ...   | no  _ = stepPreservesLess g' _ _ _ b b≈fb (≼-cong ≈-refl (≈-sym b≈fb) (Monotonicᶠ a₂≼b)) _ _ _
 
 aᶠ≼ : ∀ (a : A) → a ≈ f a → aᶠ ≼ a
-aᶠ≼ a a≈fa = stepPreservesLess (suc h) 0 ⊥ᴬ ⊥ᴬ a a≈fa (⊥ᴬ≼ a) (ChainA.done ≈-refl) (+-comm (suc h) 0) (⊥ᴬ≼ (f ⊥ᴬ))
+aᶠ≼ a a≈fa = stepPreservesLess (suc h) 0 ⊥ᴬ ⊥ᴬ a a≈fa (⊥≼ a) (ChainA.done ≈-refl) (+-comm (suc h) 0) (⊥≼ (f ⊥ᴬ))

Isomorphism.agda

@@ -38,8 +38,9 @@ module TransportFiniteHeight
     open IsEquivalence ≈₁-equiv using () renaming (≈-sym to ≈₁-sym; ≈-trans to ≈₁-trans)
     open IsEquivalence ≈₂-equiv using () renaming (≈-sym to ≈₂-sym; ≈-trans to ≈₂-trans)
 
-    open import Chain _≈₁_ ≈₁-equiv _≺₁_ ≺₁-cong using () renaming (Chain to Chain₁; done to done₁; step to step₁)
-    open import Chain _≈₂_ ≈₂-equiv _≺₂_ ≺₂-cong using () renaming (Chain to Chain₂; done to done₂; step to step₂)
+    import Chain
+    open Chain _≈₁_ ≈₁-equiv _≺₁_ ≺₁-cong using () renaming (Chain to Chain₁; done to done₁; step to step₁)
+    open Chain _≈₂_ ≈₂-equiv _≺₂_ ≺₂-cong using () renaming (Chain to Chain₂; done to done₂; step to step₂)
 
     private
         f-Injective : Injective _≈₁_ _≈₂_ f
@@ -62,13 +63,23 @@ module TransportFiniteHeight
         portChain₂ (done₂ a₂≈a₁) = done₁ (g-preserves-≈₂ a₂≈a₁)
         portChain₂ (step₂ {b₁} {b₂} (b₁≼b₂ , b₁̷≈b₂) b₂≈b₂' c) = step₁ (≈₁-trans (≈₁-sym (g-⊔-distr b₁ b₂)) (g-preserves-≈₂ b₁≼b₂) , g-preserves-̷≈ b₁̷≈b₂) (g-preserves-≈₂ b₂≈b₂') (portChain₂ c)
 
+    open Chain.Height (IsFiniteHeightLattice.fixedHeight fhlA)
+        using ()
+        renaming (⊥ to ⊥₁; ⊤ to ⊤₁; bounded to bounded₁; longestChain to c)
+
+    instance
+        fixedHeight : IsLattice.FixedHeight lB height
+        fixedHeight = record
+            { ⊥ = f ⊥₁
+            ; ⊤ = f ⊤₁
+            ; longestChain = portChain₁ c
+            ; bounded = λ c' → bounded₁ (portChain₂ c')
+            }
+
         isFiniteHeightLattice : IsFiniteHeightLattice B height _≈₂_ _⊔₂_ _⊓₂_
-    isFiniteHeightLattice =
-        let
-            (((a₁ , a₂) , c) , bounded₁) = IsFiniteHeightLattice.fixedHeight fhlA
-        in record
+        isFiniteHeightLattice = record
             { isLattice = lB
-            ; fixedHeight = (((f a₁ , f a₂), portChain₁ c) , λ c' → bounded₁ (portChain₂ c'))
+            ; fixedHeight = fixedHeight
             }
 
         finiteHeightLattice : FiniteHeightLattice B

LEAN_MIGRATION.md

@@ -0,0 +1,117 @@
+# Agda → Lean 4 (mathlib) migration plan
+
+Goal: port the static-analysis framework to Lean 4 + mathlib, preserving the
+overall structure and **the same theorems/lemmas** (modulo language details),
+while lifting custom machinery into mathlib wherever a standard counterpart
+exists. Per discussion, the setoid equality (`_≈_`) is **dropped in favor of
+propositional `=`** — it existed mainly so that unordered key-value maps could
+be "equal"; representations below are chosen to be canonical so `=` works.
+
+The Lean project lives in `lean/` (library root `Spa`). Each phase ends with a
+green `lake build` and a correspondence table appended to this file, so you can
+validate phase by phase.
+
+## Design mapping
+
+| Agda | Lean | Notes |
+|---|---|---|
+| `Equivalence.agda` | *lifted*: `Eq`, `Equivalence` | module disappears |
+| `IsDecidable` | *lifted*: `DecidableEq` / `DecidableRel` | mathlib is classical; decidability kept only where functions compute (e.g. the fixpoint iteration) |
+| `Showable.agda` | *lifted*: `ToString` | |
+| `Lattice.agda` `IsSemilattice` (`⊔-assoc/comm/idemp`, `≼`, `≼-refl/trans/antisym`, `x≼x⊔y`, `⊔-Monotonicˡ/ʳ`) | *lifted*: `SemilatticeSup` (`sup_assoc`, `sup_comm`, `sup_idem`, `≤` with `sup_eq_right`, `le_refl`, `le_trans`, `le_antisymm`, `le_sup_left`, `sup_le_sup_left/right`) | `a ≼ b := a ⊔ b ≈ b` becomes `a ≤ b` with bridge lemma `sup_eq_right` |
+| `IsLattice` (`absorb-⊔-⊓`, `absorb-⊓-⊔`) | *lifted*: `Lattice` (`sup_inf_self`, `inf_sup_self`) | |
+| `Monotonic`, `Monotonicˡ/ʳ/₂` | *lifted*: `Monotone` (+ tiny aliases) | |
+| `foldr-Mono`, `foldl-Mono`, `foldr-Mono'`, `foldl-Mono'` | custom, `Spa/Lattice.lean` | stated with `List.Forall₂` (≙ `Utils.Pairwise`) |
+| `Chain.agda` (`Chain`, `concat`, `Chain-map` in `ChainMapping`) | *lifted*: `LTSeries` (`RelSeries.smash`, `LTSeries.map` + `Monotone.strictMono_of_injective`) | with `=`, the ≈-congruence steps in chains vanish |
+| `Chain.Height`, `Bounded`, `Bounded-suc-n` | custom: `Spa.FixedHeight` structure (`⊥`, `⊤`, longest `LTSeries`, `bounded`) | |
+| `IsFiniteHeightLattice`, `FiniteHeightLattice` | custom class `Spa.FiniteHeightLattice` | |
+| `⊥≼` (chain bottom is least, given decidable eq) | custom, same proof shape (prepend `⊥⊓a ≺ ⊥` to longest chain) | decidability hypothesis dropped (classical) |
+| `Fixedpoint.agda` (`doStep` with gas, `aᶠ`, `aᶠ≈faᶠ`, `aᶠ≼`) | custom, `Spa/Fixedpoint.lean`, same gas-based algorithm | **not** replaced by mathlib `lfp` (would change the proof approach and lose computability) |
+| `Isomorphism.agda` (`TransportFiniteHeight`) | custom, `Spa/Isomorphism.lean` | much smaller: with `=`, f/g monotone inverse pair transports `FixedHeight` via `LTSeries.map` |
+| `Lattice/Unit.agda` | *lifted*: mathlib `Lattice PUnit`; custom `FixedHeight PUnit 0` | |
+| `Lattice/Nat.agda` (max/min lattice) | *lifted*: mathlib `Lattice ℕ` (`Nat.instLattice`) | kept only as a remark; file had no fixed-height content |
+| `Lattice/Prod.agda` | instance *lifted* (`Prod.instLattice`); custom: `unzip` + `FixedHeight (A×B) (h₁+h₂)` | same proof: split a product chain into component chains |
+| `Lattice/AboveBelow.agda` (flat lattice ⊥/[x]/⊤) | custom, same datatype; `Plain` module ⇒ `FixedHeight 2` | mathlib has no flat-lattice-on-discrete-type |
+| `Lattice/ExtendBelow.agda` | *lifted*: `WithBot A` lattice instance; custom `FixedHeight (h+1)` | unused by the pipeline; ported for parity (optional) |
+| `Lattice/IterProd.agda` | custom, same induction (`IterProd k = A × … × B`), lattice + height-sum by recursion | the `Everything` record trick survives as a recursive definition of bundled instances |
+| `Lattice/Map.agda` (assoc list with `Unique` keys, setoid) | **deleted**: only existed to support setoid map equality | its consumers move to `Finset` / spine-fixed `FiniteMap` |
+| `Lattice/MapSet.agda` (`StringSet`) | *lifted*: `Finset String` (`∪`, `{·}`, `∅`, `.toList`, `nodup_toList`) | |
+| `Lattice/FiniteMap.agda` | custom: `{ l : List (A × B) // l.map Prod.fst = ks }` — key spine fixed ⇒ `=` is pointwise value equality | same API: `locate`, `_[_]`, `GeneralizedUpdate` (`f'`, `f'-Monotonic`, `f'-k∈ks-≡`, `f'-k∉ks-backward`), `m₁≼m₂⇒m₁[k]≼m₂[k]`, `Provenance-union` analog; fixed height **still via isomorphism to `IterProd`** (same approach) |
+| `Lattice/Builder.agda` | **skipped** — not imported by anything in the repo | flag if you want it |
+| `Utils.agda` | *lifted*: `Unique`→`List.Nodup`, `Pairwise`→`List.Forall₂`, `fins`→`List.finRange`, `∈-cartesianProduct`→`List.product`/`pair_mem_product`, `x∈xs⇒fx∈fxs`→`List.mem_map_of_mem`, `filter-++`→`List.filter_append`, `iterate`→`f^[n]`, `concat-∈`→`List.mem_join`, `All¬-¬Any` etc. → `List.All`/`Any` API | leftovers (if any) in `Spa/Utils.lean` |
+| `Language/Base.agda` | custom; `Expr-vars`/`Stmt-vars : Finset String` | commented-out `∈-vars` lemmas stay omitted |
+| `Language/Semantics.agda` | custom, same big-step relations; `Value`, `Env = List (String × Value)`, custom `∈` | `ℤ` → `Int` |
+| `Language/Graphs.agda` | custom; `Vec` → `Vector` (mathlib `List.Vector`), `Fin._↑ˡ/_↑ʳ` → `Fin.castAdd`/`Fin.natAdd` | same `Graph` record, `∙`/`↦`/`loop`/`skipto`/`singleton`/`wrap`/`buildCfg`, `predecessors` + edge lemmas |
+| `Language/Traces.agda` | custom, same `Trace`/`EndToEndTrace`/`++⟨_⟩` | |
+| `Language/Properties.agda` | custom, same lemma inventory (`Trace-∙ˡ/ʳ`, `Trace-↦ˡ/ʳ`, `Trace-loop`, `EndToEndTrace-*`, `wrap-preds-∅`, `buildCfg-sufficient`) | the "ugly" `↑-≢` Fin-disjointness block should shrink via `Fin.castAdd_ne_natAdd`-style mathlib lemmas |
+| `Language.agda` (`Program` record) | custom, same fields/lemmas (`trace`, `vars`, `states`, `incoming`, `initialState-pred-∅`, …) | |
+| `Analysis/Forward/{Lattices,Evaluation,Adapters}.agda`, `Analysis/Forward.agda` | custom, same structure: `VariableValues`, `StateVariables`, `joinForKey`/`joinAll`, `StmtEvaluator`/`ExprEvaluator` + validity, expr→stmt adapter, `analyze`, `result`, `analyze-correct` | section variables instead of parameterized modules; everything Agda passed as an instance argument (`IsFiniteHeightLattice`, the evaluators, `LatticeInterpretation`, the validity records) is a typeclass resolved by instance search |
+| `Analysis/Sign.agda`, `Analysis/Constant.agda` | custom, same definitions | the four monotonicity **postulates** become real proofs (any `⊥`-strict/`⊤`-dominating operation on a flat lattice is monotone: `AboveBelow.monotone₂_of_strict`) |
+| `Main.agda` | `lake exe spa` | same test programs, same printed output |
+
+## Phases & checkpoints
+
+- **Phase 0 — scaffold.** `lean/` lake project, mathlib pinned to toolchain
+  v4.17.0 (already installed). ✅ checkpoint: `lake build` green on empty lib.
+- **Phase 1 — core order theory.** `Spa/Lattice.lean` (Monotone aliases, fold
+  monotonicity, `FixedHeight`, `Bounded`, `FiniteHeightLattice`, chain-bottom-
+  is-least). ✅ checkpoint: build + table below.
+- **Phase 2 — fixpoint & transport.** `Spa/Fixedpoint.lean`,
+  `Spa/Isomorphism.lean`. ✅ checkpoint: `fix`, `fix_eq`, `fix_le`,
+  `TransportFiniteHeight`.
+- **Phase 3 — basic lattice instances.** Unit, Prod (+height), AboveBelow
+  (+`Plain`, height 2), ExtendBelow. ✅ checkpoint.
+- **Phase 4 — map lattices.** IterProd, FiniteMap (+fixed height via IterProd
+  isomorphism), MapSet→`Finset` shims. ✅ checkpoint.
+- **Phase 5 — language.** Base, Semantics, Graphs, Traces, Properties,
+  `Program`. ✅ checkpoint: `buildCfg_sufficient`, `Program.trace`.
+- **Phase 6 — forward analysis framework.** Lattices/Evaluation/Adapters/
+  Forward. ✅ checkpoint: `analyze_correct`.
+- **Phase 7 — concrete analyses + executable.** Sign, Constant, Main.
+  ✅ checkpoint: `lake exe spa` output vs Agda `Main` output; postulates now
+  proved.
+
+## Status
+
+- [x] Phase 0
+- [x] Phase 1
+- [x] Phase 2
+- [x] Phase 3
+- [x] Phase 4
+- [x] Phase 5
+- [x] Phase 6
+- [x] Phase 7
+
+All phases complete: `lake build` is green with zero warnings, zero `sorry`s
+and zero axioms, and `lake exe spa` prints output **byte-for-byte identical**
+to the compiled Agda `Main` (verified with `diff`). Per-file `Agda ↦ Lean`
+correspondence tables live in the header comment of each Lean file.
+
+## Wins from the migration
+
+- The four monotonicity **postulates** in `Analysis/Sign.agda` and
+  `Analysis/Constant.agda` are now proved theorems (via
+  `AboveBelow.monotone₂_of_strict`: any operation on the flat lattice that
+  is strict in `⊥` and dominated by `⊤` is monotone, whatever its table),
+  so the Lean development is postulate-free.
+- ~2200 lines of map machinery (`Lattice/Map.agda`, `Lattice/MapSet.agda`,
+  much of `Lattice/FiniteMap.agda`) collapse into the spine-pinned
+  `FiniteMap` + `Finset`; the `IterProd` isomorphism no longer needs
+  `Unique ks` (the representation is canonical).
+- `Equivalence.agda`, `Chain.agda`, the `IsSemilattice`/`IsLattice`
+  hierarchy, and most of `Utils.agda` lift into mathlib.
+
+## Deviations & deferred items
+
+- `Lattice/Builder.agda`: not ported (nothing in the repo imports it).
+- `Lattice/ExtendBelow.agda`, `Lattice/Nat.agda`: not ported (unused by the
+  pipeline; `Nat`'s lattice is mathlib's, `ExtendBelow` would be `WithBot` +
+  a small height proof). Say the word if you want them for parity.
+- `Program.vars` lists variables in **sorted** order (`Finset.sort`, since
+  `Finset.toList` is noncomputable). For the test program this coincides
+  with the Agda MapSet order.
+- Chains are mathlib `LTSeries`, so chain-manipulating proofs
+  (`Prod` `unzip`, `AboveBelow`'s `isLongest` → a `rank`-based bound) are
+  restated against that API rather than pattern-matching a custom `Chain`
+  inductive.
+- `Trace`/`EndToEndTrace` are `Prop`-valued and destructured in proofs.

Language.agda

@@ -2,6 +2,7 @@ module Language where
 
 open import Language.Base public
 open import Language.Semantics public
+open import Language.Traces public
 open import Language.Graphs public
 open import Language.Properties public
 
@@ -9,60 +10,44 @@ open import Data.Fin using (Fin; suc; zero)
 open import Data.Fin.Properties as FinProp using (suc-injective)
 open import Data.List as List using (List; []; _∷_)
 open import Data.List.Membership.Propositional as ListMem using ()
-open import Data.List.Relation.Unary.All using (All; []; _∷_)
+open import Data.List.Membership.Propositional.Properties as ListMemProp using (∈-filter⁺)
 open import Data.List.Relation.Unary.Any as RelAny using ()
 open import Data.Nat using (ℕ; suc)
 open import Data.Product using (_,_; Σ; proj₁; proj₂)
 open import Data.Product.Properties as ProdProp using ()
 open import Data.String using (String) renaming (_≟_ to _≟ˢ_)
+open import Relation.Binary.Definitions using (Decidable)
 open import Relation.Binary.PropositionalEquality using (_≡_; refl)
 open import Relation.Nullary using (¬_)
 
 open import Lattice
 open import Utils using (Unique; push; Unique-map; x∈xs⇒fx∈fxs)
-open import Lattice.MapSet _≟ˢ_ using ()
+open import Lattice.MapSet String {{record { R-dec = _≟ˢ_ }}} _ using ()
     renaming
         ( MapSet to StringSet
         ; to-List to to-Listˢ
         )
 
-private
-    z≢sf : ∀ {n : ℕ} (f : Fin n) → ¬ (zero ≡ suc f)
-    z≢sf f ()
-
-    z≢mapsfs : ∀ {n : ℕ} (fs : List (Fin n)) → All (λ sf → ¬ zero ≡ sf) (List.map suc fs)
-    z≢mapsfs [] = []
-    z≢mapsfs (f ∷ fs') = z≢sf f ∷ z≢mapsfs fs'
-
-    indices : ∀ (n : ℕ) → Σ (List (Fin n)) Unique
-    indices 0 = ([] , Utils.empty)
-    indices (suc n') =
-        let
-            (inds' , unids') = indices n'
-        in
-            ( zero ∷ List.map suc inds'
-            , push (z≢mapsfs inds') (Unique-map suc suc-injective unids')
-            )
-
-    indices-complete : ∀ (n : ℕ) (f : Fin n) → f ListMem.∈ (proj₁ (indices n))
-    indices-complete (suc n') zero = RelAny.here refl
-    indices-complete (suc n') (suc f') = RelAny.there (x∈xs⇒fx∈fxs suc (indices-complete n' f'))
-
 record Program : Set where
     field
         rootStmt : Stmt
 
     graph : Graph
-    graph = buildCfg rootStmt
+    graph = wrap (buildCfg rootStmt)
 
     State : Set
     State = Graph.Index graph
 
     initialState : State
-    initialState = proj₁ (buildCfg-input rootStmt)
+    initialState = proj₁ (wrap-input (buildCfg rootStmt))
 
     finalState : State
-    finalState = proj₁ (buildCfg-output rootStmt)
+    finalState = proj₁ (wrap-output (buildCfg rootStmt))
+
+    trace : ∀ {ρ : Env} → [] , rootStmt ⇒ˢ ρ → Trace {graph} initialState finalState [] ρ
+    trace {ρ} ∅,s⇒ρ
+        with MkEndToEndTrace idx₁ (RelAny.here refl) idx₂ (RelAny.here refl) tr
+             ← EndToEndTrace-wrap (buildCfg-sufficient ∅,s⇒ρ) = tr
 
     private
         vars-Set : StringSet
@@ -75,13 +60,13 @@ record Program : Set where
     vars-Unique = proj₂ vars-Set
 
     states : List State
-    states = proj₁ (indices (Graph.size graph))
+    states = indices graph
 
     states-complete : ∀ (s : State) → s ListMem.∈ states
-    states-complete = indices-complete (Graph.size graph)
+    states-complete = indices-complete graph
 
     states-Unique : Unique states
-    states-Unique = proj₂ (indices (Graph.size graph))
+    states-Unique = indices-Unique graph
 
     code : State → List BasicStmt
     code st = graph [ st ]
@@ -89,13 +74,21 @@ record Program : Set where
     -- vars-complete : ∀ {k : String} (s : State) → k ∈ᵇ (code s) → k ListMem.∈ vars
     -- vars-complete {k} s = ∈⇒∈-Stmts-vars {length} {k} {stmts} {s}
 
-    _≟_ : IsDecidable (_≡_ {_} {State})
+    _≟_ : Decidable (_≡_ {_} {State})
     _≟_ = FinProp._≟_
 
-    _≟ᵉ_ : IsDecidable (_≡_ {_} {Graph.Edge graph})
+    _≟ᵉ_ : Decidable (_≡_ {_} {Graph.Edge graph})
     _≟ᵉ_ = ProdProp.≡-dec _≟_ _≟_
 
     open import Data.List.Membership.DecPropositional _≟ᵉ_ using (_∈?_)
 
     incoming : State → List State
-    incoming idx = List.filter (λ idx' → (idx' , idx) ∈? (Graph.edges graph)) states
+    incoming = predecessors graph
+
+    initialState-pred-∅ : incoming initialState ≡ []
+    initialState-pred-∅ =
+        wrap-preds-∅ (buildCfg rootStmt) initialState (RelAny.here refl)
+
+    edge⇒incoming : ∀ {s₁ s₂ : State} → (s₁ , s₂) ListMem.∈ (Graph.edges graph) →
+                    s₁ ListMem.∈ (incoming s₂)
+    edge⇒incoming = edge⇒predecessor graph

Language/Base.agda

@@ -39,7 +39,7 @@ data _∈ᵇ_ : String → BasicStmt → Set where
     in←₁ : ∀ {k : String} {e : Expr} → k ∈ᵇ (k ← e)
     in←₂ : ∀ {k k' : String} {e : Expr} → k ∈ᵉ e → k ∈ᵇ (k' ← e)
 
-open import Lattice.MapSet (String._≟_)
+open import Lattice.MapSet String {{record { R-dec = String._≟_ }}} _
     renaming
         ( MapSet to StringSet
         ; insert to insertˢ

Language/Graphs.agda

@@ -6,16 +6,19 @@ open import Data.Fin as Fin using (Fin; suc; zero)
 open import Data.Fin.Properties as FinProp using (suc-injective)
 open import Data.List as List using (List; []; _∷_)
 open import Data.List.Membership.Propositional as ListMem using ()
-open import Data.List.Membership.Propositional.Properties as ListMemProp using ()
+open import Data.List.Membership.Propositional.Properties as ListMemProp using (∈-filter⁺; ∈-filter⁻)
+open import Data.List.Relation.Unary.All using (All; []; _∷_)
+open import Data.List.Relation.Unary.Any as RelAny using ()
 open import Data.Nat as Nat using (ℕ; suc)
 open import Data.Nat.Properties using (+-assoc; +-comm)
-open import Data.Product using (_×_; Σ; _,_)
+open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂)
 open import Data.Vec using (Vec; []; _∷_; lookup; cast; _++_)
 open import Data.Vec.Properties using (cast-is-id; ++-assoc; lookup-++ˡ; cast-sym; ++-identityʳ; lookup-++ʳ)
 open import Relation.Binary.PropositionalEquality as Eq using (_≡_; sym; refl; subst; trans)
+open import Relation.Nullary using (¬_)
 
 open import Lattice
-open import Utils using (x∈xs⇒fx∈fxs; ∈-cartesianProduct)
+open import Utils using (Unique; push; Unique-map; x∈xs⇒fx∈fxs; ∈-cartesianProduct; fins; fins-complete)
 
 record Graph : Set where
     constructor MkGraph
@@ -112,8 +115,41 @@ singleton bss = record
     ; outputs = zero ∷ []
     }
 
+wrap : Graph → Graph
+wrap g = singleton [] ↦ g ↦ singleton []
+
 buildCfg : Stmt → Graph
 buildCfg ⟨ bs₁ ⟩ = singleton (bs₁ ∷ [])
 buildCfg (s₁ then s₂) = buildCfg s₁ ↦ buildCfg s₂
-buildCfg (if _ then s₁ else s₂) = singleton [] ↦ (buildCfg s₁ ∙ buildCfg s₂) ↦ singleton []
+buildCfg (if _ then s₁ else s₂) = buildCfg s₁ ∙ buildCfg s₂
 buildCfg (while _ repeat s) = loop (buildCfg s)
+
+module _ (g : Graph) where
+    open import Data.Product.Properties as ProdProp using ()
+    private _≟_ = ProdProp.≡-dec (FinProp._≟_ {Graph.size g})
+                                 (FinProp._≟_ {Graph.size g})
+
+    open import Data.List.Membership.DecPropositional (_≟_) using (_∈?_)
+
+    indices : List (Graph.Index g)
+    indices = proj₁ (fins (Graph.size g))
+
+    indices-complete : ∀ (idx : (Graph.Index g)) → idx ListMem.∈ indices
+    indices-complete = fins-complete (Graph.size g)
+
+    indices-Unique : Unique indices
+    indices-Unique = proj₂ (fins (Graph.size g))
+
+    predecessors : (Graph.Index g) → List (Graph.Index g)
+    predecessors idx = List.filter (λ idx' → (idx' , idx) ∈? (Graph.edges g)) indices
+
+    edge⇒predecessor : ∀ {idx₁ idx₂ : Graph.Index g} → (idx₁ , idx₂) ListMem.∈ (Graph.edges g) →
+                    idx₁ ListMem.∈ (predecessors idx₂)
+    edge⇒predecessor {idx₁} {idx₂} idx₁,idx₂∈es =
+        ∈-filter⁺ (λ idx' → (idx' , idx₂) ∈? (Graph.edges g))
+                  (indices-complete idx₁) idx₁,idx₂∈es
+
+    predecessor⇒edge : ∀ {idx₁ idx₂ : Graph.Index g} → idx₁ ListMem.∈ (predecessors idx₂) →
+                       (idx₁ , idx₂) ListMem.∈ (Graph.edges g)
+    predecessor⇒edge {idx₁} {idx₂} idx₁∈pred =
+        proj₂ (∈-filter⁻ (λ idx' → (idx' , idx₂) ∈? (Graph.edges g)) {v = idx₁} {xs = indices} idx₁∈pred )

Language/Properties.agda

@@ -6,34 +6,84 @@ open import Language.Graphs
 open import Language.Traces
 
 open import Data.Fin as Fin using (suc; zero)
+open import Data.Fin.Properties as FinProp using (suc-injective)
 open import Data.List as List using (List; _∷_; [])
+open import Data.List.Properties using (filter-none)
 open import Data.List.Relation.Unary.Any using (here; there)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; map; tabulate)
 open import Data.List.Membership.Propositional as ListMem using ()
 open import Data.List.Membership.Propositional.Properties as ListMemProp using ()
-open import Data.Product using (Σ; _,_; _×_)
+open import Data.Nat as Nat using ()
+open import Data.Product using (Σ; _,_; _×_; proj₂)
+open import Data.Product.Properties as ProdProp using ()
+open import Data.Sum using (inj₁; inj₂)
 open import Data.Vec as Vec using (_∷_)
 open import Data.Vec.Properties using (lookup-++ˡ; ++-identityʳ; lookup-++ʳ)
 open import Function using (_∘_)
-open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym)
+open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym; cong)
+open import Relation.Nullary using (¬_)
 
 open import Utils using (x∈xs⇒fx∈fxs; ∈-cartesianProduct; concat-∈)
 
+-- All of the below helpers are to reason about what edges aren't included
+-- when combinings graphs. The currenty most important use for this is proving
+-- that the entry node has no incoming edges.
+--
+-- -------------- Begin ugly code to make this work ----------------
+↑-≢ : ∀ {n m} (f₁ : Fin.Fin n) (f₂ : Fin.Fin m) → ¬ (f₁ Fin.↑ˡ m) ≡ (n Fin.↑ʳ f₂)
+↑-≢ zero f₂ ()
+↑-≢ (suc f₁') f₂ f₁≡f₂ = ↑-≢ f₁' f₂ (suc-injective f₁≡f₂)
 
-buildCfg-input : ∀ (s : Stmt) → let g = buildCfg s in Σ (Graph.Index g) (λ idx → Graph.inputs g ≡ idx ∷ [])
-buildCfg-input ⟨ bs₁ ⟩ = (zero , refl)
-buildCfg-input (s₁ then s₂)
-    with (idx , p) ← buildCfg-input s₁ rewrite p = (_ , refl)
-buildCfg-input (if _ then s₁ else s₂) = (zero , refl)
-buildCfg-input (while _ repeat s)
-    with (idx , p) ← buildCfg-input s rewrite p = (_ , refl)
+idx→f∉↑ʳᵉ : ∀ {n m} (idx : Fin.Fin (n Nat.+ m)) (f : Fin.Fin n) (es₂ : List (Fin.Fin m × Fin.Fin m)) → ¬ (idx , f Fin.↑ˡ m) ListMem.∈ (n ↑ʳᵉ es₂)
+idx→f∉↑ʳᵉ idx f ((idx₁ , idx₂) ∷ es') (here idx,f≡idx₁,idx₂) = ↑-≢ f idx₂ (cong proj₂ idx,f≡idx₁,idx₂)
+idx→f∉↑ʳᵉ idx f (_ ∷ es₂') (there idx→f∈es₂') = idx→f∉↑ʳᵉ idx f es₂' idx→f∈es₂'
 
-buildCfg-output : ∀ (s : Stmt) → let g = buildCfg s in Σ (Graph.Index g) (λ idx → Graph.outputs g ≡ idx ∷ [])
-buildCfg-output ⟨ bs₁ ⟩ = (zero , refl)
-buildCfg-output (s₁ then s₂)
-    with (idx , p) ← buildCfg-output s₂ rewrite p = (_ , refl)
-buildCfg-output (if _ then s₁ else s₂) = (_ , refl)
-buildCfg-output (while _ repeat s)
-    with (idx , p) ← buildCfg-output s rewrite p = (_ , refl)
+idx→f∉pair : ∀ {n m} (idx idx' : Fin.Fin (n Nat.+ m)) (f : Fin.Fin n) (inputs₂ : List (Fin.Fin m)) → ¬ (idx , f Fin.↑ˡ m) ListMem.∈ (List.map (idx' ,_) (n ↑ʳⁱ inputs₂))
+idx→f∉pair idx idx' f [] ()
+idx→f∉pair idx idx' f (input ∷ inputs') (here idx,f≡idx',input) = ↑-≢ f input (cong proj₂ idx,f≡idx',input)
+idx→f∉pair idx idx' f (_ ∷ inputs₂') (there idx,f∈inputs₂') = idx→f∉pair idx idx' f inputs₂' idx,f∈inputs₂'
+
+idx→f∉cart : ∀ {n m} (idx : Fin.Fin (n Nat.+ m)) (f : Fin.Fin n) (outputs₁ : List (Fin.Fin n)) (inputs₂ : List (Fin.Fin m)) → ¬ (idx , f Fin.↑ˡ m) ListMem.∈ (List.cartesianProduct (outputs₁ ↑ˡⁱ m) (n ↑ʳⁱ inputs₂))
+idx→f∉cart idx f [] inputs₂ ()
+idx→f∉cart {n} {m} idx f (output ∷ outputs₁') inputs₂ idx,f∈pair++cart
+    with ListMemProp.∈-++⁻ (List.map (output Fin.↑ˡ m ,_) (n ↑ʳⁱ inputs₂)) idx,f∈pair++cart
+...   | inj₁ idx,f∈pair = idx→f∉pair idx (output Fin.↑ˡ m) f inputs₂ idx,f∈pair
+...   | inj₂ idx,f∈cart = idx→f∉cart idx f outputs₁' inputs₂ idx,f∈cart
+
+help : let g₁ = singleton [] in
+       ∀ (g₂ : Graph) (idx₁ : Graph.Index g₁) (idx : Graph.Index (g₁ ↦ g₂)) →
+       ¬ (idx , idx₁ Fin.↑ˡ Graph.size g₂) ListMem.∈ ((Graph.size g₁ ↑ʳᵉ Graph.edges g₂) List.++
+                                                      (List.cartesianProduct (Graph.outputs g₁ ↑ˡⁱ Graph.size g₂)
+                                                                             (Graph.size g₁ ↑ʳⁱ Graph.inputs g₂)))
+help g₂ idx₁ idx idx,idx₁∈g
+    with ListMemProp.∈-++⁻ (Graph.size (singleton []) ↑ʳᵉ Graph.edges g₂) idx,idx₁∈g
+...   | inj₁ idx,idx₁∈edges₂ = idx→f∉↑ʳᵉ idx idx₁ (Graph.edges g₂) idx,idx₁∈edges₂
+...   | inj₂ idx,idx₁∈cart = idx→f∉cart idx idx₁ (Graph.outputs (singleton [])) (Graph.inputs g₂) idx,idx₁∈cart
+
+helpAll : let g₁ = singleton [] in
+       ∀ (g₂ : Graph) (idx₁ : Graph.Index g₁) →
+       All (λ idx → ¬ (idx , idx₁ Fin.↑ˡ Graph.size g₂) ListMem.∈ ((Graph.size g₁ ↑ʳᵉ Graph.edges g₂) List.++
+                                                                   (List.cartesianProduct (Graph.outputs g₁ ↑ˡⁱ Graph.size g₂)
+                                                                                          (Graph.size g₁ ↑ʳⁱ Graph.inputs g₂)))) (indices (g₁ ↦ g₂))
+helpAll g₂ idx₁ = tabulate (λ {idx} _ → help g₂ idx₁ idx)
+
+module _ (g : Graph) where
+    wrap-preds-∅ : (idx : Graph.Index (wrap g)) →
+                   idx ListMem.∈ Graph.inputs (wrap g) → predecessors (wrap g) idx ≡ []
+    wrap-preds-∅ zero (here refl) =
+        filter-none (λ idx' → (idx' , zero) ∈?
+                              (Graph.edges (wrap g)))
+                    (helpAll (g ↦ singleton []) zero)
+        where open import Data.List.Membership.DecPropositional (ProdProp.≡-dec (FinProp._≟_ {Graph.size (wrap g)}) (FinProp._≟_ {Graph.size (wrap g)})) using (_∈?_)
+-- -------------- End ugly code to make this work ----------------
+
+
+module _ (g : Graph) where
+    wrap-input : Σ (Graph.Index (wrap g)) (λ idx → Graph.inputs (wrap g) ≡ idx ∷ [])
+    wrap-input = (_ , refl)
+
+    wrap-output : Σ (Graph.Index (wrap g)) (λ idx → Graph.outputs (wrap g) ≡ idx ∷ [])
+    wrap-output = (_ , refl)
 
 Trace-∙ˡ : ∀ {g₁ g₂ : Graph} {idx₁ idx₂ : Graph.Index g₁} {ρ₁ ρ₂ : Env} →
            Trace {g₁} idx₁ idx₂ ρ₁ ρ₂ →
@@ -224,6 +274,10 @@ EndToEndTrace-singleton ρ₁⇒ρ₂ = record
 EndToEndTrace-singleton[] : ∀ (ρ : Env) → EndToEndTrace {singleton []} ρ ρ
 EndToEndTrace-singleton[] env = EndToEndTrace-singleton []
 
+EndToEndTrace-wrap : ∀ {g : Graph} {ρ₁ ρ₂ : Env} →
+                     EndToEndTrace {g} ρ₁ ρ₂ → EndToEndTrace {wrap g} ρ₁ ρ₂
+EndToEndTrace-wrap {g} {ρ₁} {ρ₂} etr = EndToEndTrace-singleton[] ρ₁ ++ etr ++ EndToEndTrace-singleton[] ρ₂
+
 buildCfg-sufficient : ∀ {s : Stmt} {ρ₁ ρ₂ : Env} → ρ₁ , s ⇒ˢ ρ₂ →
                       EndToEndTrace {buildCfg s} ρ₁ ρ₂
 buildCfg-sufficient (⇒ˢ-⟨⟩ ρ₁ ρ₂ bs ρ₁,bs⇒ρ₂) =
@@ -231,13 +285,9 @@ buildCfg-sufficient (⇒ˢ-⟨⟩ ρ₁ ρ₂ bs ρ₁,bs⇒ρ₂) =
 buildCfg-sufficient (⇒ˢ-then ρ₁ ρ₂ ρ₃ s₁ s₂ ρ₁,s₁⇒ρ₂ ρ₂,s₂⇒ρ₃) =
     buildCfg-sufficient ρ₁,s₁⇒ρ₂ ++ buildCfg-sufficient ρ₂,s₂⇒ρ₃
 buildCfg-sufficient (⇒ˢ-if-true ρ₁ ρ₂ _ _ s₁ s₂ _ _ ρ₁,s₁⇒ρ₂) =
-    EndToEndTrace-singleton[] ρ₁ ++
-    (EndToEndTrace-∙ˡ (buildCfg-sufficient ρ₁,s₁⇒ρ₂)) ++
-    EndToEndTrace-singleton[] ρ₂
+    EndToEndTrace-∙ˡ (buildCfg-sufficient ρ₁,s₁⇒ρ₂)
 buildCfg-sufficient (⇒ˢ-if-false ρ₁ ρ₂ _ s₁ s₂ _ ρ₁,s₂⇒ρ₂) =
-    EndToEndTrace-singleton[] ρ₁ ++
-    (EndToEndTrace-∙ʳ {buildCfg s₁} (buildCfg-sufficient ρ₁,s₂⇒ρ₂)) ++
-    EndToEndTrace-singleton[] ρ₂
+    EndToEndTrace-∙ʳ {buildCfg s₁} (buildCfg-sufficient ρ₁,s₂⇒ρ₂)
 buildCfg-sufficient (⇒ˢ-while-true ρ₁ ρ₂ ρ₃ _ _ s _ _ ρ₁,s⇒ρ₂ ρ₂,ws⇒ρ₃) =
     EndToEndTrace-loop² {buildCfg s}
                         (EndToEndTrace-loop {buildCfg s} (buildCfg-sufficient ρ₁,s⇒ρ₂))

Lattice.agda

@@ -4,15 +4,17 @@ open import Equivalence
 import Chain
 
 open import Relation.Binary.Core using (_Preserves_⟶_ )
-open import Relation.Nullary using (Dec; ¬_)
+open import Relation.Nullary using (Dec; ¬_; yes; no)
+open import Data.Empty using (⊥-elim)
 open import Data.Nat as Nat using (ℕ)
 open import Data.Product using (_×_; Σ; _,_)
 open import Data.Sum using (_⊎_; inj₁; inj₂)
 open import Agda.Primitive using (lsuc; Level) renaming (_⊔_ to _⊔ℓ_)
 open import Function.Definitions using (Injective)
 
-IsDecidable : ∀ {a} {A : Set a} (R : A → A → Set a) → Set a
-IsDecidable {a} {A} R = ∀ (a₁ a₂ : A) → Dec (R a₁ a₂)
+record IsDecidable {a} {A : Set a} (R : A → A → Set a) : Set a where
+    field
+        R-dec : ∀ (a₁ a₂ : A) → Dec (R a₁ a₂)
 
 module _ {a b} {A : Set a} {B : Set b}
     (_≼₁_ : A → A → Set a) (_≼₂_ : B → B → Set b) where
@@ -20,6 +22,18 @@ module _ {a b} {A : Set a} {B : Set b}
     Monotonic : (A → B) → Set (a ⊔ℓ b)
     Monotonic f = ∀ {a₁ a₂ : A} → a₁ ≼₁ a₂ → f a₁ ≼₂ f a₂
 
+    Monotonicˡ : ∀ {c} {C : Set c} → (A → C → B) →  Set (a ⊔ℓ b ⊔ℓ c)
+    Monotonicˡ f = ∀ c →  Monotonic (λ a → f a c)
+
+    Monotonicʳ : ∀ {c} {C : Set c} → (C → A → B) →  Set (a ⊔ℓ b ⊔ℓ c)
+    Monotonicʳ f = ∀ a → Monotonic (f a)
+
+module _ {a b c} {A : Set a} {B : Set b} {C : Set c}
+    (_≼₁_ : A → A → Set a) (_≼₂_ : B → B → Set b) (_≼₃_ : C → C → Set c) where
+
+    Monotonic₂ : (A → B → C) → Set (a ⊔ℓ b ⊔ℓ c)
+    Monotonic₂ f = Monotonicˡ _≼₁_ _≼₃_ f × Monotonicʳ _≼₂_ _≼₃_ f
+
 record IsSemilattice {a} (A : Set a)
     (_≈_ : A → A → Set a)
     (_⊔_ : A → A → A) : Set a where
@@ -82,6 +96,12 @@ record IsSemilattice {a} (A : Set a)
                     (a₁ ⊔ a) ⊔ (a₂ ⊔ a)
                 ∎
 
+    -- need to show: a₁ ⊔ (a₁ ⊔ a₂) ≈ a₁ ⊔ a₂
+    -- (a₁ ⊔ a₁) ⊔ a₂ ≈ a₁ ⊔ (a₁ ⊔ a₂)
+
+    x≼x⊔y : ∀ (a₁ a₂ : A) → a₁ ≼ (a₁ ⊔ a₂)
+    x≼x⊔y a₁ a₂ = ≈-sym (≈-trans (≈-⊔-cong (≈-sym (⊔-idemp a₁)) (≈-refl {a₂})) (⊔-assoc a₁ a₁ a₂))
+
     ≼-refl : ∀ (a : A) → a ≼ a
     ≼-refl a = ⊔-idemp a
 
@@ -99,6 +119,18 @@ record IsSemilattice {a} (A : Set a)
             a₃
         ∎
 
+    ≼-antisym : ∀ {a₁ a₂ : A} → a₁ ≼ a₂ → a₂ ≼ a₁ → a₁ ≈ a₂
+    ≼-antisym {a₁} {a₂} a₁⊔a₂≈a₂ a₂⊔a₁≈a₁ =
+        begin
+            a₁
+        ∼⟨ ≈-sym a₂⊔a₁≈a₁ ⟩
+            a₂ ⊔ a₁
+        ∼⟨ ⊔-comm _ _ ⟩
+            a₁ ⊔ a₂
+        ∼⟨ a₁⊔a₂≈a₂ ⟩
+            a₂
+        ∎
+
     ≼-cong : ∀ {a₁ a₂ a₃ a₄ : A} → a₁ ≈ a₂ → a₃ ≈ a₄ → a₁ ≼ a₃ → a₂ ≼ a₄
     ≼-cong {a₁} {a₂} {a₃} {a₄} a₁≈a₂ a₃≈a₄ a₁⊔a₃≈a₃ =
         begin
@@ -186,8 +218,8 @@ record IsLattice {a} (A : Set a)
     (_⊓_ : A → A → A) : Set a where
 
     field
-        joinSemilattice : IsSemilattice A _≈_ _⊔_
-        meetSemilattice : IsSemilattice A _≈_ _⊓_
+        {{joinSemilattice}} : IsSemilattice A _≈_ _⊔_
+        {{meetSemilattice}} : IsSemilattice A _≈_ _⊓_
 
         absorb-⊔-⊓ : (x y : A) → (x ⊔ (x ⊓ y)) ≈ x
         absorb-⊓-⊔ : (x y : A) → (x ⊓ (x ⊔ y)) ≈ x
@@ -216,12 +248,43 @@ record IsFiniteHeightLattice {a} (A : Set a)
     (_⊓_ : A → A → A) : Set (lsuc a) where
 
     field
-        isLattice : IsLattice A _≈_ _⊔_ _⊓_
+        {{isLattice}} : IsLattice A _≈_ _⊔_ _⊓_
 
     open IsLattice isLattice public
 
     field
-        fixedHeight : FixedHeight h
+        {{fixedHeight}} : FixedHeight h
+
+    private
+        module MyChain = Chain _≈_ ≈-equiv _≺_ ≺-cong
+
+    open MyChain.Height fixedHeight using (⊥; ⊤) public
+
+    Known-⊥ : Set a
+    Known-⊥ = ∀ (a : A) → ⊥ ≼ a
+
+    Known-⊤ : Set a
+    Known-⊤ = ∀ (a : A) → a ≼ ⊤
+
+    -- If the equality is decidable, we can prove that the top and bottom
+    -- elements of the chain are least and greatest elements of the lattice
+    module _ {{≈-Decidable : IsDecidable _≈_}} where
+        open IsDecidable ≈-Decidable using () renaming (R-dec to ≈-dec)
+
+        open MyChain.Height fixedHeight using (bounded; longestChain)
+
+        ⊥≼ : Known-⊥
+        ⊥≼ a with ≈-dec a ⊥
+        ...   | yes a≈⊥ = ≼-cong a≈⊥ ≈-refl (≼-refl a)
+        ...   | no a̷≈⊥ with ≈-dec ⊥ (a ⊓ ⊥)
+        ...         | yes ⊥≈a⊓⊥ = ≈-trans (⊔-comm ⊥ a) (≈-trans (≈-⊔-cong (≈-refl {a}) ⊥≈a⊓⊥) (absorb-⊔-⊓ a ⊥))
+        ...         | no ⊥ᴬ̷≈a⊓⊥ = ⊥-elim (MyChain.Bounded-suc-n bounded (MyChain.step x≺⊥ ≈-refl longestChain))
+                        where
+                            ⊥⊓a̷≈⊥ : ¬ (⊥ ⊓ a) ≈ ⊥
+                            ⊥⊓a̷≈⊥ = λ ⊥⊓a≈⊥ → ⊥ᴬ̷≈a⊓⊥ (≈-trans (≈-sym ⊥⊓a≈⊥) (⊓-comm _ _))
+
+                            x≺⊥ : (⊥ ⊓ a) ≺ ⊥
+                            x≺⊥ = (≈-trans (⊔-comm _ _) (≈-trans (≈-refl {⊥ ⊔ (⊥ ⊓ a)}) (absorb-⊔-⊓ ⊥ a)) , ⊥⊓a̷≈⊥)
 
 module ChainMapping {a b} {A : Set a} {B : Set b}
     {_≈₁_ : A → A → Set a} {_≈₂_ : B → B → Set b}
@@ -251,7 +314,7 @@ record Semilattice {a} (A : Set a) : Set (lsuc a) where
         _≈_ : A → A → Set a
         _⊔_ : A → A → A
 
-        isSemilattice : IsSemilattice A _≈_ _⊔_
+        {{isSemilattice}} : IsSemilattice A _≈_ _⊔_
 
     open IsSemilattice isSemilattice public
 
@@ -262,7 +325,7 @@ record Lattice {a} (A : Set a) : Set (lsuc a) where
         _⊔_ : A → A → A
         _⊓_ : A → A → A
 
-        isLattice : IsLattice A _≈_ _⊔_ _⊓_
+        {{isLattice}} : IsLattice A _≈_ _⊔_ _⊓_
 
     open IsLattice isLattice public
 
@@ -273,6 +336,6 @@ record FiniteHeightLattice {a} (A : Set a) : Set (lsuc a) where
         _⊔_ : A → A → A
         _⊓_ : A → A → A
 
-        isFiniteHeightLattice : IsFiniteHeightLattice A height _≈_ _⊔_ _⊓_
+        {{isFiniteHeightLattice}} : IsFiniteHeightLattice A height _≈_ _⊔_ _⊓_
 
     open IsFiniteHeightLattice isFiniteHeightLattice public

Lattice/AboveBelow.agda

@@ -1,17 +1,19 @@
 open import Lattice
 open import Equivalence
 open import Relation.Nullary using (Dec; ¬_; yes; no)
+open import Data.Unit using () renaming (⊤ to ⊤ᵘ)
 
 module Lattice.AboveBelow {a} (A : Set a)
-                          (_≈₁_ : A → A → Set a)
-                          (≈₁-equiv : IsEquivalence A _≈₁_)
-                          (≈₁-dec : IsDecidable _≈₁_) where
+                          {_≈₁_ : A → A → Set a}
+                          {{≈₁-equiv : IsEquivalence A _≈₁_}}
+                          {{≈₁-Decidable : IsDecidable _≈₁_}} (dummy : ⊤ᵘ) where
 
 open import Data.Empty using (⊥-elim)
 open import Data.Product using (_,_)
 open import Data.Nat using (_≤_; ℕ; z≤n; s≤s; suc)
 open import Function using (_∘_)
 open import Showable using (Showable; show)
+open import Relation.Binary.Definitions using (Decidable)
 open import Relation.Binary.PropositionalEquality as Eq
     using (_≡_; sym; subst; refl)
 
@@ -20,6 +22,8 @@ import Chain
 open IsEquivalence ≈₁-equiv using ()
     renaming (≈-refl to ≈₁-refl; ≈-sym to ≈₁-sym; ≈-trans to ≈₁-trans)
 
+open IsDecidable ≈₁-Decidable using () renaming (R-dec to ≈₁-dec)
+
 data AboveBelow : Set a where
     ⊥ : AboveBelow
     ⊤ : AboveBelow
@@ -62,7 +66,7 @@ data _≈_ : AboveBelow → AboveBelow → Set a where
     ; ≈-trans = ≈-trans
     }
 
-≈-dec : IsDecidable _≈_
+≈-dec : Decidable _≈_
 ≈-dec ⊥ ⊥ = yes ≈-⊥-⊥
 ≈-dec ⊤ ⊤ = yes ≈-⊤-⊤
 ≈-dec [ x ] [ y ]
@@ -76,6 +80,10 @@ data _≈_ : AboveBelow → AboveBelow → Set a where
 ≈-dec [ x ] ⊥ = no λ ()
 ≈-dec [ x ] ⊤ = no λ ()
 
+instance
+    ≈-Decidable : IsDecidable _≈_
+    ≈-Decidable = record { R-dec = ≈-dec }
+
 -- Any object can be wrapped in an 'above below' to make it a lattice,
 -- since ⊤ and ⊥ are the largest and least elements, and the rest are left
 -- unordered. That's what this module does.
@@ -169,6 +177,7 @@ module Plain (x : A) where
     ⊔-idemp ⊥ = ≈-⊥-⊥
     ⊔-idemp [ x ] rewrite x≈y⇒[x]⊔[y]≡[x] (≈₁-refl {x}) = ≈-refl
 
+    instance
         isJoinSemilattice : IsSemilattice AboveBelow _≈_ _⊔_
         isJoinSemilattice = record
             { ≈-equiv = ≈-equiv
@@ -262,6 +271,7 @@ module Plain (x : A) where
     ⊓-idemp ⊤ = ≈-⊤-⊤
     ⊓-idemp [ x ] rewrite x≈y⇒[x]⊓[y]≡[x] (≈₁-refl {x}) = ≈-refl
 
+    instance
         isMeetSemilattice : IsSemilattice AboveBelow _≈_ _⊓_
         isMeetSemilattice = record
             { ≈-equiv = ≈-equiv
@@ -294,6 +304,7 @@ module Plain (x : A) where
     ...   | no x̷≈y rewrite x̷≈y⇒[x]⊔[y]≡⊤ x̷≈y rewrite x⊓⊤≡x [ x ] = ≈-refl
 
 
+    instance
         isLattice : IsLattice AboveBelow _≈_ _⊔_ _⊓_
         isLattice = record
             { joinSemilattice = isJoinSemilattice
@@ -310,7 +321,7 @@ module Plain (x : A) where
             ; isLattice = isLattice
             }
 
-    open IsLattice isLattice using (_≼_; _≺_; ⊔-Monotonicˡ; ⊔-Monotonicʳ) public
+    open IsLattice isLattice using (_≼_; _≺_; ≼-trans; ≼-refl; ⊔-Monotonicˡ; ⊔-Monotonicʳ) public
 
     ⊥≺[x] : ∀ (x : A) → ⊥ ≺ [ x ]
     ⊥≺[x] x = (≈-refl , λ ())
@@ -354,8 +365,14 @@ module Plain (x : A) where
     isLongest {⊥} (step {_} {[ x ]} _ (≈-lift _) (step [x]≺y y≈z c@(step _ _ _)))
         rewrite [x]≺y⇒y≡⊤ _ _ [x]≺y with ≈-⊤-⊤ ← y≈z = ⊥-elim (¬-Chain-⊤ c)
 
+    instance
         fixedHeight : IsLattice.FixedHeight isLattice 2
-    fixedHeight = (((⊥ , ⊤) , longestChain) , isLongest)
+        fixedHeight = record
+            { ⊥ = ⊥
+            ; ⊤ = ⊤
+            ; longestChain = longestChain
+            ; bounded = isLongest
+            }
 
         isFiniteHeightLattice : IsFiniteHeightLattice AboveBelow 2 _≈_ _⊔_ _⊓_
         isFiniteHeightLattice = record

Lattice/Builder.agda

@@ -0,0 +1,885 @@
+module Lattice.Builder where
+
+open import Lattice
+open import Equivalence
+open import Utils using (Unique; push; empty; Unique-append; Unique-++⁻ˡ; Unique-++⁻ʳ; Unique-narrow; All¬-¬Any; ¬Any-map; fins; fins-complete; findUniversal; Decidable-¬; ∈-cartesianProduct; foldr₁; x∷xs≢[])
+open import Data.Nat as Nat using (ℕ)
+open import Data.Fin as Fin using (Fin; suc; zero; _≟_)
+open import Data.Maybe as Maybe using (Maybe; just; nothing; _>>=_; maybe)
+open import Data.Maybe.Properties using (just-injective)
+open import Data.List.NonEmpty using (List⁺; tail; toList) renaming (_∷_ to _∷⁺_)
+open import Data.List.Membership.Propositional as MemProp using (lose) renaming (_∈_ to _∈ˡ_; mapWith∈ to mapWith∈ˡ)
+open import Data.List.Membership.Propositional.Properties using () renaming (∈-++⁺ʳ to ∈ˡ-++⁺ʳ; ∈-++⁺ˡ to ∈ˡ-++⁺ˡ; ∈-cartesianProductWith⁺ to ∈ˡ-cartesianProductWith⁺; ∈-filter⁻ to ∈ˡ-filter⁻; ∈-filter⁺ to ∈ˡ-filter⁺; ∈-lookup to ∈ˡ-lookup)
+open import Data.List.Relation.Unary.Any as Any using (Any; here; there; any?; satisfied; index)
+open import Data.List.Relation.Unary.Any.Properties using (¬Any[]; lookup-result)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; map; lookup; zipWith; tabulate; universal; all?)
+open import Data.List.Relation.Unary.All.Properties using () renaming (++⁺ to ++ˡ⁺; ++⁻ʳ to ++ˡ⁻ʳ)
+open import Data.List using (List; _∷_; []; cartesianProduct; cartesianProductWith; foldr; filter) renaming (_++_ to _++ˡ_)
+open import Data.List.Properties using () renaming (++-conicalʳ to ++ˡ-conicalʳ; ++-identityʳ to ++ˡ-identityʳ; ++-assoc to ++ˡ-assoc)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Product using (Σ; _,_; _×_; proj₁; proj₂; uncurry)
+open import Data.Empty using (⊥-elim)
+open import Relation.Nullary using (¬_; Dec; yes; no; ¬?; _×-dec_)
+open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym; trans; cong; subst)
+open import Relation.Binary.PropositionalEquality.Properties using (decSetoid)
+open import Relation.Binary using () renaming (Decidable to Decidable²)
+open import Relation.Unary using (Decidable)
+open import Relation.Unary.Properties using (_∩?_)
+open import Agda.Primitive using (lsuc; Level) renaming (_⊔_ to _⊔ℓ_)
+
+record Graph : Set where
+    constructor mkGraph
+    field
+        size : ℕ
+
+    Node : Set
+    Node = Fin (Nat.suc size)
+
+    nodes = fins (Nat.suc size)
+
+    nodes-complete = fins-complete (Nat.suc size)
+
+    Edge : Set
+    Edge = Node × Node
+
+    field
+        edges : List Edge
+
+    nodes-nonempty : ¬ (proj₁ nodes ≡ [])
+    nodes-nonempty ()
+
+    data Path : Node → Node → Set where
+        done : ∀ {n : Node} → Path n n
+        step : ∀ {n₁ n₂ n₃ : Node} →  (n₁ , n₂) ∈ˡ edges → Path n₂ n₃ → Path n₁ n₃
+
+    data IsDone : ∀ {n₁ n₂} → Path n₁ n₂ → Set where
+        isDone : ∀ {n : Node} → IsDone (done {n})
+
+    IsDone? : ∀ {n₁ n₂} → Decidable (IsDone {n₁} {n₂})
+    IsDone? done = yes isDone
+    IsDone? (step _ _) = no (λ {()})
+
+    _++_ : ∀ {n₁ n₂ n₃} → Path n₁ n₂ → Path n₂ n₃ → Path n₁ n₃
+    done ++ p = p
+    (step e p₁) ++ p₂ = step e (p₁ ++ p₂)
+
+    ++-done : ∀ {n₁ n₂} (p : Path n₁ n₂) → p ++ done ≡ p
+    ++-done done = refl
+    ++-done (step e∈edges p) rewrite ++-done p = refl
+
+    ++-assoc : ∀ {n₁ n₂ n₃ n₄} (p₁ : Path n₁ n₂) (p₂ : Path n₂ n₃) (p₃ : Path n₃ n₄) →
+                 (p₁ ++ p₂) ++ p₃ ≡ p₁ ++ (p₂ ++ p₃)
+    ++-assoc done p₂ p₃ = refl
+    ++-assoc (step n₁,n∈edges p₁) p₂ p₃ rewrite ++-assoc p₁ p₂ p₃ = refl
+
+    IsDone-++ˡ : ∀ {n₁ n₂ n₃} (p₁ : Path n₁ n₂) (p₂ : Path n₂ n₃) →
+                 ¬ IsDone p₁ → ¬ IsDone (p₁ ++ p₂)
+    IsDone-++ˡ done _ done≢done = ⊥-elim (done≢done isDone)
+
+    interior : ∀ {n₁ n₂} → Path n₁ n₂ → List Node
+    interior done = []
+    interior (step _ done) = []
+    interior (step {n₂ = n₂} _ p) = n₂ ∷ interior p
+
+    interior-extend : ∀ {n₁ n₂ n₃} → (p : Path n₁ n₂) →  (n₂,n₃∈edges : (n₂ , n₃) ∈ˡ edges) →
+                      let p' = (p ++ (step n₂,n₃∈edges done))
+                      in (interior p' ≡ interior p) ⊎ (interior p' ≡ interior p ++ˡ (n₂ ∷ []))
+    interior-extend done _ = inj₁ refl
+    interior-extend (step n₁,n₂∈edges done) n₂n₃∈edges = inj₂ refl
+    interior-extend {n₂ = n₂} (step {n₂ = n} n₁,n∈edges p@(step _ _)) n₂n₃∈edges
+        with p ++ (step n₂n₃∈edges done) | interior-extend p n₂n₃∈edges
+    ...   | done | inj₁ []≡intp rewrite sym []≡intp = inj₁ refl
+    ...   | done | inj₂ []=intp++[n₂] with () ← ++ˡ-conicalʳ (interior p) (n₂ ∷ []) (sym []=intp++[n₂])
+    ...   | step _ p | inj₁ IH rewrite IH = inj₁ refl
+    ...   | step _ p | inj₂ IH rewrite IH = inj₂ refl
+
+    interior-++ : ∀ {n₁ n₂ n₃} → (p₁ : Path n₁ n₂) →  (p₂ : Path n₂ n₃) →
+                    ¬ IsDone p₁ → ¬ IsDone p₂ →
+                    interior (p₁ ++ p₂) ≡ interior p₁ ++ˡ (n₂ ∷ interior p₂)
+    interior-++ done _ done≢done _ = ⊥-elim (done≢done isDone)
+    interior-++ _ done _ done≢done = ⊥-elim (done≢done isDone)
+    interior-++ (step _ done) (step _ _) _ _ = refl
+    interior-++ (step n₁,n∈edges p@(step n,n'∈edges p')) p₂ _ p₂≢done
+        rewrite interior-++ p p₂ (λ {()}) p₂≢done = refl
+
+    SimpleWalkVia : List Node → Node → Node → Set
+    SimpleWalkVia ns n₁ n₂ = Σ (Path n₁ n₂) (λ p → Unique (interior p) × All (_∈ˡ ns) (interior p))
+
+    SimpleWalk-extend : ∀ {n₁ n₂ n₃ ns} →  (w : SimpleWalkVia ns n₁ n₂) → (n₂ , n₃) ∈ˡ edges →  All (λ nʷ →  ¬ nʷ ≡ n₂) (interior (proj₁ w)) → n₂ ∈ˡ ns → SimpleWalkVia ns n₁ n₃
+    SimpleWalk-extend (p , (Unique-intp , intp⊆ns)) n₂,n₃∈edges w≢n₂ n₂∈ns
+        with p ++ (step n₂,n₃∈edges done) | interior-extend p n₂,n₃∈edges
+    ...   | p' | inj₁ intp'≡intp rewrite sym intp'≡intp = (p' , Unique-intp , intp⊆ns)
+    ...   | p' | inj₂ intp'≡intp++[n₂]
+            with intp++[n₂]⊆ns ←  ++ˡ⁺ intp⊆ns (n₂∈ns ∷ [])
+            rewrite sym intp'≡intp++[n₂] = (p' , (subst Unique (sym intp'≡intp++[n₂]) (Unique-append (¬Any-map sym (All¬-¬Any w≢n₂)) Unique-intp) , intp++[n₂]⊆ns))
+
+    ∈ˡ-narrow : ∀ {x y : Node} {ys : List Node} → x ∈ˡ (y ∷ ys) → ¬ y ≡ x → x ∈ˡ ys
+    ∈ˡ-narrow (here refl) x≢y = ⊥-elim (x≢y refl)
+    ∈ˡ-narrow (there x∈ys) _ = x∈ys
+
+    SplitSimpleWalkViaHelp : ∀ {n n₁ n₂ ns} (nⁱ : Node)
+                                            (w : SimpleWalkVia (n ∷ ns) n₁ n₂)
+                                            (p₁ : Path n₁ nⁱ) (p₂ : Path nⁱ n₂) →
+                                            ¬ IsDone p₁ → ¬ IsDone p₂ →
+                                            All (_∈ˡ ns) (interior p₁) →
+                                            proj₁ w ≡ p₁ ++ p₂ →
+                                            (Σ (SimpleWalkVia ns n₁ n × SimpleWalkVia ns n n₂) λ (w₁ , w₂) → proj₁ w₁ ++ proj₁ w₂ ≡ proj₁ w) ⊎ (Σ (SimpleWalkVia ns n₁ n₂) λ w' → proj₁ w' ≡ proj₁ w)
+    SplitSimpleWalkViaHelp nⁱ w done _ done≢done _ _ _ = ⊥-elim (done≢done isDone)
+    SplitSimpleWalkViaHelp nⁱ w p₁ done _ done≢done _ _ = ⊥-elim (done≢done isDone)
+    SplitSimpleWalkViaHelp {n} {ns = ns} nⁱ w@(p , (Unique-intp , intp⊆ns)) p₁@(step _ _) p₂@(step {n₂ = nⁱ'} nⁱ,nⁱ',∈edges p₂') p₁≢done p₂≢done intp₁⊆ns p≡p₁++p₂
+        with intp≡intp₁++[n]++intp₂ ← trans (cong interior p≡p₁++p₂) (interior-++ p₁ p₂ p₁≢done p₂≢done)
+        with nⁱ∈n∷ns ∷ intp₂⊆n∷ns ← ++ˡ⁻ʳ (interior p₁) (subst (All (_∈ˡ (n ∷ ns))) intp≡intp₁++[n]++intp₂ intp⊆ns)
+        with nⁱ ≟ n
+    ...   | yes refl
+            with Unique-intp₁ ← Unique-++⁻ˡ (interior p₁) (subst Unique intp≡intp₁++[n]++intp₂ Unique-intp)
+            with (push n≢intp₂ Unique-intp₂) ← Unique-++⁻ʳ (interior p₁) (subst Unique intp≡intp₁++[n]++intp₂ Unique-intp)
+            = inj₁ (((p₁ , (Unique-intp₁ , intp₁⊆ns)) , (p₂ , (Unique-intp₂ , zipWith (uncurry ∈ˡ-narrow) (intp₂⊆n∷ns , n≢intp₂)))) , sym p≡p₁++p₂)
+    ...   | no nⁱ≢n
+            with p₂'
+    ...       | done
+                = let
+                      -- note: copied with below branch. can't use with <- to
+                      --       share and re-use because the termination checker loses the thread.
+                      p₁' = (p₁ ++ (step nⁱ,nⁱ',∈edges done))
+                      n≢nⁱ n≡nⁱ = nⁱ≢n (sym n≡nⁱ)
+                      intp₁'=intp₁++[nⁱ] = subst (λ xs → interior p₁' ≡ interior p₁ ++ˡ xs) (++ˡ-identityʳ (nⁱ ∷ [])) (interior-++ p₁ (step nⁱ,nⁱ',∈edges done) p₁≢done (λ {()}))
+                      intp₁++[nⁱ]⊆ns = ++ˡ⁺ intp₁⊆ns (∈ˡ-narrow nⁱ∈n∷ns n≢nⁱ ∷ [])
+                      intp₁'⊆ns = subst (All (_∈ˡ ns)) (sym intp₁'=intp₁++[nⁱ]) intp₁++[nⁱ]⊆ns
+                      -- end shared with below branch.
+                      Unique-intp₁++[nⁱ] = Unique-++⁻ˡ (interior p₁ ++ˡ (nⁱ ∷ [])) (subst Unique (trans intp≡intp₁++[n]++intp₂ (sym (++ˡ-assoc (interior p₁) (nⁱ ∷ []) []))) Unique-intp)
+                  in inj₂ ((p₁ ++ (step nⁱ,nⁱ',∈edges done) , (subst Unique (sym intp₁'=intp₁++[nⁱ]) Unique-intp₁++[nⁱ] , intp₁'⊆ns)) , sym p≡p₁++p₂)
+    ...       | p₂'@(step _ _)
+                = let p₁' = (p₁ ++ (step nⁱ,nⁱ',∈edges done))
+                      n≢nⁱ n≡nⁱ = nⁱ≢n (sym n≡nⁱ)
+                      intp₁'=intp₁++[nⁱ] = subst (λ xs → interior p₁' ≡ interior p₁ ++ˡ xs) (++ˡ-identityʳ (nⁱ ∷ [])) (interior-++ p₁ (step nⁱ,nⁱ',∈edges done) p₁≢done (λ {()}))
+                      intp₁++[nⁱ]⊆ns = ++ˡ⁺ intp₁⊆ns (∈ˡ-narrow nⁱ∈n∷ns n≢nⁱ ∷ [])
+                      intp₁'⊆ns = subst (All (_∈ˡ ns)) (sym intp₁'=intp₁++[nⁱ]) intp₁++[nⁱ]⊆ns
+                      p≡p₁'++p₂' = trans p≡p₁++p₂ (sym (++-assoc p₁ (step nⁱ,nⁱ',∈edges done) p₂'))
+                  in SplitSimpleWalkViaHelp nⁱ' w p₁' p₂' (IsDone-++ˡ _ _ p₁≢done) (λ {()}) intp₁'⊆ns p≡p₁'++p₂'
+
+    SplitSimpleWalkVia : ∀ {n n₁ n₂ ns} (w : SimpleWalkVia (n ∷ ns) n₁ n₂) →  (Σ (SimpleWalkVia ns n₁ n × SimpleWalkVia ns n n₂) λ (w₁ , w₂) → proj₁ w₁ ++ proj₁ w₂ ≡ proj₁ w) ⊎ (Σ (SimpleWalkVia ns n₁ n₂) λ w' → proj₁ w' ≡ proj₁ w)
+    SplitSimpleWalkVia (done , (_ , _)) = inj₂ ((done , (empty , [])) , refl)
+    SplitSimpleWalkVia (step n₁,n₂∈edges done , (_ , _)) = inj₂ ((step n₁,n₂∈edges done , (empty , [])) , refl)
+    SplitSimpleWalkVia w@(step {n₂ = nⁱ} n₁,nⁱ∈edges p@(step  _ _) , (push nⁱ≢intp Unique-intp , nⁱ∈ns ∷ intp⊆ns)) = SplitSimpleWalkViaHelp nⁱ w (step n₁,nⁱ∈edges done) p (λ {()}) (λ {()}) [] refl
+
+    open import Data.List.Membership.DecSetoid (decSetoid {A = Node} _≟_) using () renaming (_∈?_ to _∈ˡ?_)
+
+    splitFromInteriorʳ : ∀ {n₁ n₂ n} (p : Path n₁ n₂) → n ∈ˡ (interior p) →
+                        Σ (Path n n₂) (λ p' → ¬ IsDone p' × (Σ (List Node) λ ns → interior p ≡ ns ++ˡ n ∷ interior p'))
+    splitFromInteriorʳ done ()
+    splitFromInteriorʳ (step _ done) ()
+    splitFromInteriorʳ (step {n₂ = n'} n₁,n'∈edges p'@(step _ _)) (here refl) = (p' , ((λ {()}) , ([] , refl)))
+    splitFromInteriorʳ (step {n₂ = n'} n₁,n'∈edges p'@(step _ _)) (there n∈intp')
+        with (p'' , (¬IsDone-p'' , (ns , intp'≡ns++intp''))) ← splitFromInteriorʳ p' n∈intp'
+        rewrite intp'≡ns++intp'' = (p'' , (¬IsDone-p'' , (n' ∷ ns , refl)))
+
+    splitFromInteriorˡ : ∀ {n₁ n₂ n} (p : Path n₁ n₂) → n ∈ˡ (interior p) →
+                        Σ (Path n₁ n) (λ p' → ¬ IsDone p' × (Σ (List Node) λ ns → interior p ≡ interior p' ++ˡ ns))
+    splitFromInteriorˡ done ()
+    splitFromInteriorˡ (step _ done) ()
+    splitFromInteriorˡ p@(step {n₂ = n'} n₁,n'∈edges p'@(step _ _)) (here refl) = (step n₁,n'∈edges done , ((λ {()}) , (interior p , refl)))
+    splitFromInteriorˡ p@(step {n₂ = n'} n₁,n'∈edges p'@(step _ _)) (there n∈intp')
+        with splitFromInteriorˡ p' n∈intp'
+    ...   | (p''@(step _ _) , (¬IsDone-p'' , (ns , intp'≡intp''++ns)))
+            rewrite intp'≡intp''++ns
+            = (step n₁,n'∈edges p'' , ((λ { () }) , (ns , refl)))
+    ...   | (done , (¬IsDone-Done , _)) = ⊥-elim (¬IsDone-Done isDone)
+
+    findCycleHelp : ∀ {n₁ nⁱ n₂} (p : Path n₁ n₂) (p₁ : Path n₁ nⁱ) (p₂ : Path nⁱ n₂) →
+                      ¬ IsDone p₁ → Unique (interior p₁) →
+                      p ≡ p₁ ++ p₂ →
+                      (Σ (SimpleWalkVia (proj₁ nodes) n₁ n₂) λ w → proj₁ w ≡ p) ⊎ (Σ Node (λ n → Σ (SimpleWalkVia (proj₁ nodes) n n) λ w →  ¬ IsDone (proj₁ w)))
+    findCycleHelp p p₁ done ¬IsDonep₁ Unique-intp₁ p≡p₁++done rewrite ++-done p₁ = inj₁ ((p₁ , (Unique-intp₁ , tabulate (λ {x} _ → nodes-complete x))) , sym p≡p₁++done)
+    findCycleHelp {nⁱ = nⁱ} p p₁ (step nⁱ,nⁱ'∈edges p₂') ¬IsDone-p₁ Unique-intp₁ p≡p₁++p₂
+        with nⁱ ∈ˡ? interior p₁
+    ...   | no nⁱ∉intp₁ =
+            let p₁' = p₁ ++ step nⁱ,nⁱ'∈edges done
+                intp₁'≡intp₁++[nⁱ] = subst (λ xs → interior p₁' ≡ interior p₁ ++ˡ xs) (++ˡ-identityʳ (nⁱ ∷ [])) (interior-++ p₁ (step nⁱ,nⁱ'∈edges done) ¬IsDone-p₁ (λ {()}))
+                ¬IsDone-p₁' = IsDone-++ˡ p₁ (step nⁱ,nⁱ'∈edges done) ¬IsDone-p₁
+                p≡p₁'++p₂' = trans p≡p₁++p₂ (sym (++-assoc p₁ (step nⁱ,nⁱ'∈edges done) p₂'))
+                Unique-intp₁' = subst Unique (sym intp₁'≡intp₁++[nⁱ]) (Unique-append nⁱ∉intp₁ Unique-intp₁)
+            in findCycleHelp p p₁' p₂' ¬IsDone-p₁' Unique-intp₁' p≡p₁'++p₂'
+    ...   | yes nⁱ∈intp₁
+            with (pᶜ , (¬IsDone-pᶜ , (ns , intp₁≡ns++intpᶜ))) ← splitFromInteriorʳ p₁ nⁱ∈intp₁
+            rewrite sym (++ˡ-assoc ns (nⁱ ∷ []) (interior pᶜ)) =
+            let Unique-intp₁' = subst Unique intp₁≡ns++intpᶜ Unique-intp₁
+            in inj₂ (nⁱ , ((pᶜ , (Unique-++⁻ʳ (ns ++ˡ nⁱ ∷ [])  Unique-intp₁' , tabulate (λ {x} _ → nodes-complete x))) , ¬IsDone-pᶜ))
+
+    findCycle : ∀ {n₁ n₂} (p : Path n₁ n₂) →  (Σ (SimpleWalkVia (proj₁ nodes) n₁ n₂) λ w → proj₁ w ≡ p) ⊎ (Σ Node (λ n → Σ (SimpleWalkVia (proj₁ nodes) n n) λ w →  ¬ IsDone (proj₁ w)))
+    findCycle done = inj₁ ((done , (empty , [])) , refl)
+    findCycle (step n₁,n₂∈edges done) = inj₁ ((step n₁,n₂∈edges done , (empty , [])) , refl)
+    findCycle p@(step {n₂ = n'} n₁,n'∈edges p'@(step _ _)) = findCycleHelp p (step n₁,n'∈edges done) p' (λ {()}) empty refl
+
+    toSimpleWalk : ∀ {n₁ n₂} (p : Path n₁ n₂) → SimpleWalkVia (proj₁ nodes) n₁ n₂
+    toSimpleWalk done = (done , (empty , []))
+    toSimpleWalk (step {n₂ = nⁱ} n₁,nⁱ∈edges p')
+        with toSimpleWalk p'
+    ...   | (done , _) = (step n₁,nⁱ∈edges done , (empty , []))
+    ...   | (p''@(step _ _) , (Unique-intp'' , intp''⊆nodes))
+            with nⁱ ∈ˡ? interior p''
+    ...       | no nⁱ∉intp'' = (step n₁,nⁱ∈edges p'' , (push (tabulate (λ { n∈intp'' refl →  nⁱ∉intp'' n∈intp'' })) Unique-intp'' , (nodes-complete nⁱ) ∷ intp''⊆nodes))
+    ...       | yes nⁱ∈intp''
+                with splitFromInteriorʳ p'' nⁱ∈intp''
+    ...           | (done , (¬IsDone=p''ʳ , (ns , intp''≡ns++intp''ʳ))) = ⊥-elim (¬IsDone=p''ʳ isDone)
+    ...           | (p''ʳ@(step _ _) , (¬IsDone=p''ʳ , (ns , intp''≡ns++intp''ʳ))) =
+                    -- no rewrites because then I can't reason about the return value of toSimpleWalk
+                    -- rewrite intp''≡ns++intp''ʳ
+                    -- rewrite sym (++ˡ-assoc ns (nⁱ ∷ []) (interior p''ʳ)) =
+                    let reassoc-intp''≡ns++intp''ʳ = subst (interior p'' ≡_) (sym (++ˡ-assoc ns (nⁱ ∷ []) (interior p''ʳ))) intp''≡ns++intp''ʳ
+                        intp''ʳ⊆nodes = ++ˡ⁻ʳ (ns ++ˡ nⁱ ∷ []) (subst (All (_∈ˡ (proj₁ nodes))) reassoc-intp''≡ns++intp''ʳ intp''⊆nodes)
+                        Unique-ns++intp''ʳ = subst Unique reassoc-intp''≡ns++intp''ʳ Unique-intp''
+                        nⁱ∈p''ˡ = ∈ˡ-++⁺ʳ ns {ys = nⁱ ∷ []} (here refl)
+                    in (step n₁,nⁱ∈edges p''ʳ , (Unique-narrow (ns ++ˡ nⁱ ∷ []) Unique-ns++intp''ʳ nⁱ∈p''ˡ , nodes-complete nⁱ ∷ intp''ʳ⊆nodes ))
+
+    toSimpleWalk-IsDone⁻ : ∀ {n₁ n₂} (p : Path n₁ n₂) →
+                          ¬ IsDone p → ¬ IsDone (proj₁ (toSimpleWalk p))
+    toSimpleWalk-IsDone⁻ done ¬IsDone-p _ = ¬IsDone-p isDone
+    toSimpleWalk-IsDone⁻ (step {n₂ = nⁱ} n₁,nⁱ∈edges p') _ isDone-w
+        with toSimpleWalk p'
+    ...   | (done , _) with () ← isDone-w
+    ...   | (p''@(step _ _) , (Unique-intp'' , intp''⊆nodes))
+            with nⁱ ∈ˡ? interior p''
+    ...       | no nⁱ∉intp'' with () ← isDone-w
+    ...       | yes nⁱ∈intp''
+                with splitFromInteriorʳ p'' nⁱ∈intp''
+    ...           | (done , (¬IsDone=p''ʳ , (ns , intp''≡ns++intp''ʳ))) = ¬IsDone=p''ʳ isDone
+    ...           | (p''ʳ@(step _ _) , (¬IsDone=p''ʳ , (ns , intp''≡ns++intp''ʳ)))
+                    with () ← isDone-w
+
+    Adjacency : Set
+    Adjacency = ∀ (n₁ n₂ : Node) → List (Path n₁ n₂)
+
+    Adjacency-update : ∀ (n₁ n₂ : Node) → (List (Path n₁ n₂) → List (Path n₁ n₂)) → Adjacency → Adjacency
+    Adjacency-update n₁ n₂ f adj n₁' n₂'
+        with n₁ ≟ n₁' | n₂ ≟ n₂'
+    ...  | yes refl | yes refl = f (adj n₁ n₂)
+    ...  | _        | _        = adj n₁' n₂'
+
+    Adjacency-append : ∀ {n₁ n₂ : Node} → List (Path n₁ n₂) → Adjacency → Adjacency
+    Adjacency-append {n₁} {n₂} ps = Adjacency-update n₁ n₂ (ps ++ˡ_)
+
+    Adjacency-append-monotonic : ∀ {adj n₁ n₂ n₁' n₂'} {ps : List (Path n₁ n₂)} {p : Path n₁' n₂'} → p ∈ˡ adj n₁' n₂' → p ∈ˡ Adjacency-append ps adj n₁' n₂'
+    Adjacency-append-monotonic {adj} {n₁} {n₂} {n₁'} {n₂'} {ps} p∈adj
+        with n₁ ≟ n₁' | n₂ ≟ n₂'
+    ...   | yes refl | yes refl = ∈ˡ-++⁺ʳ ps p∈adj
+    ...   | yes refl | no _ = p∈adj
+    ...   | no _ | no _ = p∈adj
+    ...   | no _ | yes _ = p∈adj
+
+    adj⁰ : Adjacency
+    adj⁰ n₁ n₂
+        with n₁ ≟ n₂
+    ... | yes refl = done ∷ []
+    ... | no _ = []
+
+    adj⁰-done : ∀ n →  done ∈ˡ adj⁰ n n
+    adj⁰-done n
+        with n ≟ n
+    ... | yes refl = here refl
+    ... | no n≢n = ⊥-elim (n≢n refl)
+
+    seedWithEdges : ∀ (es : List Edge) →  (∀ {e} → e ∈ˡ es → e ∈ˡ edges) → Adjacency → Adjacency
+    seedWithEdges es e∈es⇒e∈edges adj = foldr (λ ((n₁ , n₂) , n₁n₂∈edges) → Adjacency-update n₁ n₂ ((step n₁n₂∈edges done) ∷_)) adj (mapWith∈ˡ es (λ {e} e∈es →  (e , e∈es⇒e∈edges e∈es)))
+
+    seedWithEdges-monotonic : ∀ {n₁ n₂ es adj} → (e∈es⇒e∈edges : ∀ {e} → e ∈ˡ es → e ∈ˡ edges) → ∀ {p} → p ∈ˡ adj n₁ n₂ → p ∈ˡ seedWithEdges es e∈es⇒e∈edges adj n₁ n₂
+    seedWithEdges-monotonic {es = []} e∈es⇒e∈edges p∈adj = p∈adj
+    seedWithEdges-monotonic {es = (n₁ , n₂) ∷ es} e∈es⇒e∈edges p∈adj = Adjacency-append-monotonic {ps = step (e∈es⇒e∈edges (here refl)) done ∷ []} (seedWithEdges-monotonic (λ e∈es → e∈es⇒e∈edges (there e∈es)) p∈adj)
+
+    e∈seedWithEdges : ∀ {n₁ n₂ es adj} → (e∈es⇒e∈edges : ∀ {e} → e ∈ˡ es → e ∈ˡ edges) → ∀ (n₁n₂∈es : (n₁ , n₂) ∈ˡ es) →  (step (e∈es⇒e∈edges n₁n₂∈es) done) ∈ˡ seedWithEdges es e∈es⇒e∈edges adj n₁ n₂
+    e∈seedWithEdges {es = []} e∈es⇒e∈edges ()
+    e∈seedWithEdges {es = (n₁' , n₂') ∷ es} e∈es⇒e∈edges (here refl)
+        with n₁' ≟ n₁' | n₂' ≟ n₂'
+    ...   | yes refl | yes refl = here refl
+    ...   | no n₁'≢n₁' | _ = ⊥-elim (n₁'≢n₁' refl)
+    ...   | _ | no n₂'≢n₂' = ⊥-elim (n₂'≢n₂' refl)
+    e∈seedWithEdges {n₁} {n₂} {es = (n₁' , n₂') ∷ es} {adj} e∈es⇒e∈edges (there n₁n₂∈es) = Adjacency-append-monotonic {ps = step (e∈es⇒e∈edges (here refl)) done ∷ []} (e∈seedWithEdges (λ e∈es → e∈es⇒e∈edges (there e∈es)) n₁n₂∈es)
+
+    adj¹ : Adjacency
+    adj¹ = seedWithEdges edges (λ x → x) adj⁰
+
+    adj¹-adj⁰ : ∀ {n₁ n₂ p} → p ∈ˡ adj⁰ n₁ n₂ → p ∈ˡ adj¹ n₁ n₂
+    adj¹-adj⁰ p∈adj⁰ = seedWithEdges-monotonic (λ x → x) p∈adj⁰
+
+    edge∈adj¹ : ∀ {n₁ n₂} (n₁n₂∈edges : (n₁ , n₂) ∈ˡ edges) →  (step n₁n₂∈edges done) ∈ˡ adj¹ n₁ n₂
+    edge∈adj¹ = e∈seedWithEdges (λ x → x)
+
+    through : Node → Adjacency → Adjacency
+    through n adj n₁ n₂ = cartesianProductWith _++_ (adj n₁ n) (adj n n₂) ++ˡ adj n₁ n₂
+
+    through-monotonic : ∀ adj n {n₁ n₂ p} → p ∈ˡ adj n₁ n₂ → p ∈ˡ (through n adj) n₁ n₂
+    through-monotonic adj n p∈adjn₁n₂ = ∈ˡ-++⁺ʳ _ p∈adjn₁n₂
+
+    through-++ : ∀ adj n {n₁ n₂} {p₁ : Path n₁ n} {p₂ : Path n n₂} → p₁ ∈ˡ adj n₁ n → p₂ ∈ˡ adj n n₂ → (p₁ ++ p₂) ∈ˡ through n adj n₁ n₂
+    through-++ adj n p₁∈adj p₂∈adj = ∈ˡ-++⁺ˡ (∈ˡ-cartesianProductWith⁺ _++_ p₁∈adj p₂∈adj)
+
+    throughAll : List Node → Adjacency
+    throughAll = foldr through adj¹
+
+    throughAll-adj₁ : ∀ {n₁ n₂ p} ns → p ∈ˡ adj¹ n₁ n₂ → p ∈ˡ throughAll ns n₁ n₂
+    throughAll-adj₁ [] p∈adj¹ = p∈adj¹
+    throughAll-adj₁ (n ∷ ns) p∈adj¹ = through-monotonic (throughAll ns) n (throughAll-adj₁ ns p∈adj¹)
+
+    paths-throughAll : ∀ {n₁ n₂ : Node} (ns : List Node) (w : SimpleWalkVia ns n₁ n₂) →  proj₁ w ∈ˡ throughAll ns n₁ n₂
+    paths-throughAll {n₁} [] (done , (_ , _)) = adj¹-adj⁰ (adj⁰-done n₁)
+    paths-throughAll {n₁} [] (step e∈edges done , (_ , _)) = edge∈adj¹ e∈edges
+    paths-throughAll {n₁} [] (step _ (step _ _) , (_ , (() ∷ _)))
+    paths-throughAll (n ∷ ns) w
+        with SplitSimpleWalkVia w
+    ...  | inj₁ ((w₁ , w₂) , w₁++w₂≡w) rewrite sym w₁++w₂≡w = through-++ (throughAll ns) n (paths-throughAll ns w₁) (paths-throughAll ns w₂)
+    ...  | inj₂ (w' , w'≡w) rewrite sym w'≡w = through-monotonic (throughAll ns) n (paths-throughAll ns w')
+
+    adj : Adjacency
+    adj = throughAll (proj₁ nodes)
+
+    PathExists : Node → Node → Set
+    PathExists n₁ n₂ = Path n₁ n₂
+
+    PathExists? : Decidable² PathExists
+    PathExists? n₁ n₂
+        with allSimplePathsNoted ← paths-throughAll {n₁ = n₁} {n₂ = n₂} (proj₁ nodes)
+        with adj n₁ n₂
+    ...   | [] = no (λ p →  let w = toSimpleWalk p in ¬Any[] (allSimplePathsNoted w))
+    ...   | (p ∷ ps) = yes p
+
+    NoCycles : Set
+    NoCycles = ∀ {n} (p : Path n n) →  IsDone p
+
+    NoCycles? : Dec NoCycles
+    NoCycles? with any? (λ n → any? (Decidable-¬ IsDone?) (adj n n)) (proj₁ nodes)
+    ... | yes existsCycle =
+          no (λ ∀p,IsDonep →  let (n , n,n-cycle) = satisfied existsCycle in
+                              let (p , ¬IsDone-p) = satisfied n,n-cycle in
+                              ¬IsDone-p (∀p,IsDonep p))
+    ... | no noCycles =
+          yes (λ { done →  isDone
+                 ; p@(step {n₁ = n} _ _) →
+                    let w = toSimpleWalk p in
+                    let ¬IsDone-w = toSimpleWalk-IsDone⁻ p (λ {()}) in
+                    let w∈adj = paths-throughAll (proj₁ nodes) w in
+                    ⊥-elim (noCycles (lose (nodes-complete n) (lose w∈adj ¬IsDone-w)))
+                 })
+
+    NoCycles⇒adj-complete : NoCycles → ∀ {n₁ n₂} {p : Path n₁ n₂} →  p ∈ˡ adj n₁ n₂
+    NoCycles⇒adj-complete noCycles {n₁} {n₂} {p}
+        with findCycle p
+    ...   | inj₁ (w , w≡p) rewrite sym w≡p = paths-throughAll (proj₁ nodes) w
+    ...   | inj₂ (nᶜ , (wᶜ , wᶜ≢done)) = ⊥-elim (wᶜ≢done (noCycles (proj₁ wᶜ)))
+
+    Is-⊤ : Node → Set
+    Is-⊤ n = All (PathExists n) (proj₁ nodes)
+
+    Is-⊥ : Node → Set
+    Is-⊥ n = All (λ n' → PathExists n' n) (proj₁ nodes)
+
+    Has-⊤ : Set
+    Has-⊤ = Any Is-⊤ (proj₁ nodes)
+
+    Has-⊤? : Dec Has-⊤
+    Has-⊤? = findUniversal (proj₁ nodes) PathExists?
+
+    Has-⊥ : Set
+    Has-⊥ = Any Is-⊥ (proj₁ nodes)
+
+    Has-⊥? : Dec Has-⊥
+    Has-⊥? = findUniversal (proj₁ nodes) (λ n₁ n₂ → PathExists? n₂ n₁)
+
+    Pred : Node → Node → Node → Set
+    Pred n₁ n₂ n = PathExists n n₁ × PathExists n n₂
+
+    Succ : Node → Node → Node → Set
+    Succ n₁ n₂ n = PathExists n₁ n × PathExists n₂ n
+
+    Pred? : ∀ (n₁ n₂ : Node) → Decidable (Pred n₁ n₂)
+    Pred? n₁ n₂ n = PathExists? n n₁ ×-dec PathExists? n n₂
+
+    Suc? : ∀ (n₁ n₂ : Node) → Decidable (Succ n₁ n₂)
+    Suc? n₁ n₂ n = PathExists? n₁ n ×-dec PathExists? n₂ n
+
+    preds : Node → Node → List Node
+    preds n₁ n₂ = filter (Pred? n₁ n₂) (proj₁ nodes)
+
+    sucs : Node → Node → List Node
+    sucs n₁ n₂ = filter (Suc? n₁ n₂) (proj₁ nodes)
+
+    Have-⊔ : Node → Node → Set
+    Have-⊔ n₁ n₂ = Σ Node (λ n →  Pred n₁ n₂ n × (∀ n' →  Pred n₁ n₂ n' → PathExists n' n))
+
+    Have-⊓ : Node → Node → Set
+    Have-⊓ n₁ n₂ = Σ Node (λ n →  Succ n₁ n₂ n × (∀ n' →  Succ n₁ n₂ n' → PathExists n n'))
+
+    -- when filtering nodes by a predicate P, then trying to find a universal
+    -- element according to another predicate Q, the universality can be
+    -- extended from "element of the filtered list for to which all other elements relate" to
+    -- "node satisfying P to which all other nodes satisfying P relate".
+    filter-nodes-universal : ∀ {P : Node → Set} (P? : Decidable P) -- e.g. Pred n₁ n₂
+                               {Q : Node → Node → Set} (Q? : Decidable² Q) -- e.g. PathExists? n' n
+                               → Dec (Σ Node λ n → P n × (∀ n' → P n' → Q n n'))
+    filter-nodes-universal {P = P} P? {Q = Q} Q?
+        with findUniversal (filter P? (proj₁ nodes)) Q?
+    ...   | yes founduni =
+            let idx = index founduni
+                n = Any.lookup founduni
+                n∈filter = ∈ˡ-lookup idx
+                (_ , Pn) = ∈ˡ-filter⁻ P? {xs = proj₁ nodes} n∈filter
+                nuni = lookup-result founduni
+            in yes (n , (Pn , λ n' Pn' →
+                                    let n'∈filter = ∈ˡ-filter⁺ P? (nodes-complete n') Pn'
+                                    in lookup nuni n'∈filter))
+    ...   | no nouni = no λ (n , (Pn , nuni')) →
+                           let n∈filter = ∈ˡ-filter⁺ P? (nodes-complete n) Pn
+                               nuni = tabulate {xs = filter P? (proj₁ nodes)} (λ {n'} n'∈filter →  nuni' n' (proj₂ (∈ˡ-filter⁻ P? {xs = proj₁ nodes} n'∈filter)))
+                           in nouni (lose n∈filter nuni)
+
+    Have-⊔? : Decidable² Have-⊔
+    Have-⊔? n₁ n₂ = filter-nodes-universal (Pred? n₁ n₂) (λ n₁ n₂ → PathExists? n₂ n₁)
+
+    Have-⊓? : Decidable² Have-⊓
+    Have-⊓? n₁ n₂ = filter-nodes-universal (Suc? n₁ n₂) PathExists?
+
+    Total-⊔ : Set
+    Total-⊔ = ∀ n₁ n₂ → Have-⊔ n₁ n₂
+
+    Total-⊓ : Set
+    Total-⊓ = ∀ n₁ n₂ → Have-⊓ n₁ n₂
+
+    P-Total? : ∀ {P : Node → Node → Set} (P? : Decidable² P) → Dec (∀ n₁ n₂ → P n₁ n₂)
+    P-Total? {P} P?
+        with all? (λ (n₁ , n₂) → P? n₁ n₂) (cartesianProduct (proj₁ nodes) (proj₁ nodes))
+    ...   | yes allP = yes λ n₁ n₂ →
+            let n₁n₂∈prod = ∈-cartesianProduct (nodes-complete n₁) (nodes-complete n₂)
+            in lookup allP n₁n₂∈prod
+    ...   | no ¬allP = no λ allP → ¬allP (universal (λ (n₁ , n₂) → allP n₁ n₂) _)
+
+    Total-⊔? : Dec Total-⊔
+    Total-⊔? = P-Total? Have-⊔?
+
+    Total-⊓? : Dec Total-⊓
+    Total-⊓? = P-Total? Have-⊓?
+
+    module Basic (noCycles : NoCycles) (total-⊔ : Total-⊔) (total-⊓ : Total-⊓) where
+        n₁→n₂×n₂→n₁⇒n₁≡n₂ : ∀ {n₁ n₂} → PathExists n₁ n₂ → PathExists n₂ n₁ → n₁ ≡ n₂
+        n₁→n₂×n₂→n₁⇒n₁≡n₂ n₁→n₂ n₂→n₁
+            with n₁→n₂ | n₂→n₁ | noCycles (n₁→n₂ ++ n₂→n₁)
+        ...   | done | done | _ = refl
+        ...   | step _ _ | done | _ = refl
+        ...   | done | step _ _ | _ = refl
+        ...   | step _ _ | step _ _ | ()
+
+        _⊔_ : Node → Node → Node
+        _⊔_ n₁ n₂ = proj₁ (total-⊔ n₁ n₂)
+
+        _⊓_ : Node → Node → Node
+        _⊓_ n₁ n₂ = proj₁ (total-⊓ n₁ n₂)
+
+        ⊤ : Node
+        ⊤ = foldr₁ nodes-nonempty _⊔_
+
+        ⊥ : Node
+        ⊥ = foldr₁ nodes-nonempty _⊓_
+
+        _≼_ : Node → Node → Set
+        _≼_ n₁ n₂ = n₁ ⊔ n₂ ≡ n₂
+
+        n₁≼n₂→PathExistsn₂n₁ : ∀ n₁ n₂ → (n₁ ≼ n₂) → PathExists n₂ n₁
+        n₁≼n₂→PathExistsn₂n₁ n₁ n₂ n₁⊔n₂≡n₂
+            with total-⊔ n₁ n₂ | n₁⊔n₂≡n₂
+        ...   | (_ , ((n₂→n₁ , _) , _)) | refl = n₂→n₁
+
+        PathExistsn₂n₁→n₁≼n₂ : ∀ n₁ n₂ → PathExists n₂ n₁ → (n₁ ≼ n₂)
+        PathExistsn₂n₁→n₁≼n₂ n₁ n₂ n₂→n₁
+            with total-⊔ n₁ n₂
+        ...   | (n , ((n→n₁ , n→n₂) , n'→n₁×n'→n₂⇒n'→n))
+                rewrite n₁→n₂×n₂→n₁⇒n₁≡n₂ n→n₂ (n'→n₁×n'→n₂⇒n'→n n₂ (n₂→n₁ , done)) = refl
+
+        foldr₁⊔-Pred : ∀ {ns : List Node} (ns≢[] : ¬ (ns ≡ [])) → let n = foldr₁ ns≢[] _⊔_ in All (PathExists n) ns
+        foldr₁⊔-Pred {ns = []} []≢[] = ⊥-elim ([]≢[] refl)
+        foldr₁⊔-Pred {ns = n₁ ∷ []} _ = done ∷ []
+        foldr₁⊔-Pred {ns = n₁ ∷ ns'@(n₂ ∷ ns'')} ns≢[] =
+            let
+                ns'≢[] = x∷xs≢[] n₂ ns''
+                n' = foldr₁ ns'≢[] _⊔_
+                (n , ((n→n₁ , n→n') , r)) = total-⊔ n₁ n'
+            in
+                n→n₁ ∷ map (n→n' ++_) (foldr₁⊔-Pred ns'≢[])
+
+        -- TODO: this is very similar structurally to foldr₁⊔-Pred
+        foldr₁⊓-Suc : ∀ {ns : List Node} (ns≢[] : ¬ (ns ≡ [])) → let n = foldr₁ ns≢[] _⊓_ in All (λ n' → PathExists n' n) ns
+        foldr₁⊓-Suc {ns = []} []≢[] = ⊥-elim ([]≢[] refl)
+        foldr₁⊓-Suc {ns = n₁ ∷ []} _ = done ∷ []
+        foldr₁⊓-Suc {ns = n₁ ∷ ns'@(n₂ ∷ ns'')} ns≢[] =
+            let
+                ns'≢[] = x∷xs≢[] n₂ ns''
+                n' = foldr₁ ns'≢[] _⊓_
+                (n , ((n₁→n , n'→n) , r)) = total-⊓ n₁ n'
+            in
+                n₁→n ∷ map (_++ n'→n) (foldr₁⊓-Suc ns'≢[])
+
+        ⊤-is-⊤ : Is-⊤ ⊤
+        ⊤-is-⊤ = foldr₁⊔-Pred nodes-nonempty
+
+        ⊥-is-⊥ : Is-⊥ ⊥
+        ⊥-is-⊥ = foldr₁⊓-Suc nodes-nonempty
+
+        ⊔-idemp : ∀ n → n ⊔ n ≡ n
+        ⊔-idemp n
+            with (n' , ((n'→n , _) , n''→n×n''→n⇒n''→n')) ← total-⊔ n n
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ n'→n (n''→n×n''→n⇒n''→n' n (done , done))
+
+        ⊓-idemp : ∀ n → n ⊓ n ≡ n
+        ⊓-idemp n
+            with (n' , ((n→n' , _) , n→n''×n→n''⇒n'→n'')) ← total-⊓ n n
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ (n→n''×n→n''⇒n'→n'' n (done , done)) n→n'
+
+        ⊔-comm : ∀ n₁ n₂ → n₁ ⊔ n₂ ≡ n₂ ⊔ n₁
+        ⊔-comm n₁ n₂
+            with (n₁₂ , ((n₁n₂→n₁ , n₁n₂→n₂) , n'→n₁×n'→n₂⇒n'→n₁₂)) ← total-⊔ n₁ n₂
+            with (n₂₁ , ((n₂n₁→n₂ , n₂n₁→n₁) , n'→n₂×n'→n₁⇒n'→n₂₁)) ← total-⊔ n₂ n₁
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ (n'→n₂×n'→n₁⇒n'→n₂₁ n₁₂ (n₁n₂→n₂ , n₁n₂→n₁))
+                                (n'→n₁×n'→n₂⇒n'→n₁₂ n₂₁ (n₂n₁→n₁ , n₂n₁→n₂))
+
+        ⊓-comm : ∀ n₁ n₂ → n₁ ⊓ n₂ ≡ n₂ ⊓ n₁
+        ⊓-comm n₁ n₂
+            with (n₁₂ , ((n₁→n₁n₂ , n₂→n₁n₂) , n₁→n'×n₂→n'⇒n₁₂→n')) ← total-⊓ n₁ n₂
+            with (n₂₁ , ((n₂→n₂n₁ , n₁→n₂n₁) , n₂→n'×n₁→n'⇒n₂₁→n')) ← total-⊓ n₂ n₁
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ (n₁→n'×n₂→n'⇒n₁₂→n' n₂₁ (n₁→n₂n₁ , n₂→n₂n₁))
+                                (n₂→n'×n₁→n'⇒n₂₁→n' n₁₂ (n₂→n₁n₂ , n₁→n₁n₂))
+
+        ⊔-assoc : ∀ n₁ n₂ n₃ → (n₁ ⊔ n₂) ⊔ n₃ ≡ n₁ ⊔ (n₂ ⊔ n₃)
+        ⊔-assoc n₁ n₂ n₃
+            with (n₁₂ , ((n₁₂→n₁ , n₁₂→n₂) , n'→n₁×n'→n₂⇒n'→n₁₂)) ← total-⊔ n₁ n₂
+            with (n₁₂,₃ , ((n₁₂,₃→n₁₂ , n₁₂,₃→n₃) , n'→n₁₂×n'→n₃⇒n'→n₁₂,₃)) ← total-⊔ n₁₂ n₃
+            with (n₂₃ , ((n₂₃→n₂ , n₂₃→n₃) , n'→n₂×n'→n₃⇒n'→n₂₃)) ← total-⊔ n₂ n₃
+            with (n₁,₂₃ , ((n₁,₂₃→n₁ , n₁,₂₃→n₂₃) , n'→n₁×n'→n₂₃⇒n'→n₁,₂₃)) ← total-⊔ n₁ n₂₃
+            =
+                let n₁₂,₃→n₂₃ = n'→n₂×n'→n₃⇒n'→n₂₃ n₁₂,₃ (n₁₂,₃→n₁₂ ++ n₁₂→n₂ , n₁₂,₃→n₃)
+                    n₁₂,₃→n₁,₂₃ = n'→n₁×n'→n₂₃⇒n'→n₁,₂₃ n₁₂,₃ (n₁₂,₃→n₁₂ ++ n₁₂→n₁ , n₁₂,₃→n₂₃)
+                    n₁,₂₃→n₁₂ = n'→n₁×n'→n₂⇒n'→n₁₂ n₁,₂₃ (n₁,₂₃→n₁ , n₁,₂₃→n₂₃ ++ n₂₃→n₂)
+                    n₁,₂₃→n₁₂,₃ = n'→n₁₂×n'→n₃⇒n'→n₁₂,₃ n₁,₂₃ (n₁,₂₃→n₁₂ , n₁,₂₃→n₂₃ ++ n₂₃→n₃)
+                in n₁→n₂×n₂→n₁⇒n₁≡n₂ n₁₂,₃→n₁,₂₃ n₁,₂₃→n₁₂,₃
+
+        ⊓-assoc : ∀ n₁ n₂ n₃ → (n₁ ⊓ n₂) ⊓ n₃ ≡ n₁ ⊓ (n₂ ⊓ n₃)
+        ⊓-assoc n₁ n₂ n₃
+          with (n₁₂ , ((n₁→n₁₂ , n₂→n₁₂) , n₁→n'×n₂→n'⇒n₁₂→n')) ← total-⊓ n₁ n₂
+          with (n₁₂,₃ , ((n₁₂→n₁₂,₃ , n₃→n₁₂,₃) , n₁₂→n'×n₃→n'⇒n₁₂,₃→n')) ← total-⊓ n₁₂ n₃
+          with (n₂₃ , ((n₂→n₂₃ , n₃→n₂₃) ,  n₂→n'×n₃→n'⇒n₂₃→n')) ← total-⊓ n₂ n₃
+          with (n₁,₂₃ , ((n₁→n₁,₂₃ , n₂₃→n₁,₂₃) ,  n₁→n'×n₂₃→n'⇒n₁,₂₃→n')) ← total-⊓ n₁ n₂₃
+          =
+            let n₁₂→n₁,₂₃ = n₁→n'×n₂→n'⇒n₁₂→n' n₁,₂₃ (n₁→n₁,₂₃ , n₂→n₂₃ ++ n₂₃→n₁,₂₃)
+                n₁₂,₃→n₁,₂₃ = n₁₂→n'×n₃→n'⇒n₁₂,₃→n' n₁,₂₃ (n₁₂→n₁,₂₃ , n₃→n₂₃ ++ n₂₃→n₁,₂₃)
+                n₂₃→n₁₂,₃ = n₂→n'×n₃→n'⇒n₂₃→n' n₁₂,₃ (n₂→n₁₂ ++ n₁₂→n₁₂,₃ , n₃→n₁₂,₃)
+                n₁,₂₃→n₁₂,₃ = n₁→n'×n₂₃→n'⇒n₁,₂₃→n' n₁₂,₃ (n₁→n₁₂ ++ n₁₂→n₁₂,₃ , n₂₃→n₁₂,₃)
+            in n₁→n₂×n₂→n₁⇒n₁≡n₂ n₁₂,₃→n₁,₂₃ n₁,₂₃→n₁₂,₃
+
+        absorb-⊔-⊓ : ∀ n₁ n₂ → n₁ ⊔ (n₁ ⊓ n₂) ≡ n₁
+        absorb-⊔-⊓ n₁ n₂
+            with (n₁₂ , ((n₁→n₁₂ , n₂→n₁₂) , n₁→n'×n₂→n'⇒n₁₂→n')) ← total-⊓ n₁ n₂
+            with (n₁,₁₂ , ((n₁,₁₂→n₁ , n₁,₁₂→n₁₂) , n'→n₁×n'→n₁₂⇒n'→n₁,₁₂)) ← total-⊔ n₁ n₁₂
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ n₁,₁₂→n₁ (n'→n₁×n'→n₁₂⇒n'→n₁,₁₂ n₁ (done , n₁→n₁₂))
+
+        absorb-⊓-⊔ : ∀ n₁ n₂ → n₁ ⊓ (n₁ ⊔ n₂) ≡ n₁
+        absorb-⊓-⊔ n₁ n₂
+            with (n₁₂ , ((n₁₂→n₁ , n₁₂→n₂) , n'→n₁×n'→n₂⇒n'→n₁₂)) ← total-⊔ n₁ n₂
+            with (n₁,₁₂ , ((n₁→n₁,₁₂ , n₁₂→n₁,₁₂) , n₁→n'×n₁₂→n'⇒n₁,₁₂→n')) ← total-⊓ n₁ n₁₂
+            = n₁→n₂×n₂→n₁⇒n₁≡n₂ (n₁→n'×n₁₂→n'⇒n₁,₁₂→n' n₁ (done , n₁₂→n₁)) n₁→n₁,₁₂
+
+        instance
+            isJoinSemilattice : IsSemilattice Node _≡_ _⊔_
+            isJoinSemilattice = record
+                { ≈-equiv = isEquivalence-≡
+                ; ≈-⊔-cong = (λ { refl refl → refl })
+                ; ⊔-idemp = ⊔-idemp
+                ; ⊔-comm = ⊔-comm
+                ; ⊔-assoc = ⊔-assoc
+                }
+
+            isMeetSemilattice : IsSemilattice Node _≡_ _⊓_
+            isMeetSemilattice = record
+                { ≈-equiv = isEquivalence-≡
+                ; ≈-⊔-cong = (λ { refl refl → refl })
+                ; ⊔-idemp = ⊓-idemp
+                ; ⊔-comm = ⊓-comm
+                ; ⊔-assoc = ⊓-assoc
+                }
+
+            isLattice : IsLattice Node _≡_ _⊔_ _⊓_
+            isLattice = record
+                { absorb-⊔-⊓ = absorb-⊔-⊓
+                ; absorb-⊓-⊔ = absorb-⊓-⊔
+                }
+
+    module Tagged (noCycles : NoCycles) (total-⊔ : Total-⊔) (total-⊓ : Total-⊓) (𝓛 : Node → Σ Set λ L → Σ (FiniteHeightLattice L) λ fhl → FiniteHeightLattice.Known-⊥ fhl × FiniteHeightLattice.Known-⊤ fhl) where
+        open Basic noCycles total-⊔ total-⊓ using () renaming (_⊔_ to _⊔ᵇ_; _⊓_ to _⊓ᵇ_; ⊔-idemp to ⊔ᵇ-idemp; ⊔-comm to ⊔ᵇ-comm; ⊔-assoc to ⊔ᵇ-assoc; _≼_ to _≼ᵇ_; isJoinSemilattice to isJoinSemilatticeᵇ; isMeetSemilattice to isMeetSemilatticeᵇ; isLattice to isLatticeᵇ)
+
+        open IsLattice isLatticeᵇ using () renaming (≈-⊔-cong to ≡-⊔ᵇ-cong; x≼x⊔y to x≼ᵇx⊔ᵇy; ≼-antisym to ≼ᵇ-antisym; ⊔-Monotonicʳ to ⊔ᵇ-Monotonicʳ)
+
+        Elem : Set
+        Elem = Σ Node λ n → (proj₁ (𝓛 n))
+
+        LatticeT : Node → Set
+        LatticeT n = proj₁ (𝓛 n)
+
+        FHL : (n : Node) → FiniteHeightLattice (LatticeT n)
+        FHL n = proj₁ (proj₂ (𝓛 n))
+
+        ⊥≼x : ∀ {n : Node} (l : LatticeT n) → FiniteHeightLattice._≼_ (FHL n) (FiniteHeightLattice.⊥ (FHL n)) l
+        ⊥≼x {n} = proj₁ (proj₂ (proj₂ (𝓛 n)))
+
+        data _≈_ : Elem → Elem → Set where
+            ≈-lift : ∀ {n : Node} {l₁ l₂ : LatticeT n} →
+                     FiniteHeightLattice._≈_ (FHL n) l₁ l₂ →
+                     (n , l₁) ≈ (n , l₂)
+
+        ≈-refl : ∀ {e : Elem} → e ≈ e
+        ≈-refl {n , l} = ≈-lift (FiniteHeightLattice.≈-refl (FHL n))
+
+        ≈-sym : ∀ {e₁ e₂ : Elem} → e₁ ≈ e₂ → e₂ ≈ e₁
+        ≈-sym {n₁ , l₁} (≈-lift l₁≈l₂) = ≈-lift (FiniteHeightLattice.≈-sym (FHL n₁) l₁≈l₂)
+
+        ≈-trans : ∀ {e₁ e₂ e₃ : Elem} → e₁ ≈ e₂ → e₂ ≈ e₃ → e₁ ≈ e₃
+        ≈-trans {n₁ , l₁} (≈-lift l₁≈l₂) (≈-lift l₂≈l₃) = ≈-lift (FiniteHeightLattice.≈-trans (FHL n₁) l₁≈l₂ l₂≈l₃)
+
+        _⊔_ : Elem → Elem → Elem
+        _⊔_ e₁ e₂
+            using n₁ ← proj₁ e₁ using n₂ ← proj₁ e₂
+            using n' ← n₁ ⊔ᵇ n₂ = (n' , select n' e₁ e₂)
+            where
+                select : ∀ n' e₁ e₂ → LatticeT n'
+                select n' (n₁ , l₁) (n₂ , l₂)
+                    with n' ≟ n₁ | n' ≟ n₂
+                ...   | yes refl | yes refl = FiniteHeightLattice._⊔_ (FHL n') l₁ l₂
+                ...   | yes refl | _ = l₁
+                ...   | _ | yes refl = l₂
+                ...   | no _ | no _ = FiniteHeightLattice.⊥ (FHL n')
+
+        ⊔-idemp : ∀ e → (e ⊔ e) ≈ e
+        ⊔-idemp (n , l) rewrite ⊔ᵇ-idemp n
+            with n ≟ n
+        ...   | yes refl = ≈-lift (FiniteHeightLattice.⊔-idemp (FHL n) l)
+        ...   | no n≢n = ⊥-elim (n≢n refl)
+
+        ⊔-comm : ∀ (e₁ e₂ : Elem) → (e₁ ⊔ e₂) ≈ (e₂ ⊔ e₁)
+        ⊔-comm (n₁ , l₁) (n₂ , l₂)
+            rewrite ⊔ᵇ-comm n₁ n₂
+            with n ← n₂ ⊔ᵇ n₁
+            with n ≟ n₁ | n ≟ n₂
+        ...   | yes refl | yes refl = ≈-lift (FiniteHeightLattice.⊔-comm (FHL n) l₁ l₂)
+        ...   | no _ | yes refl = ≈-lift (FiniteHeightLattice.≈-refl (FHL n))
+        ...   | yes refl | no _ = ≈-lift (FiniteHeightLattice.≈-refl (FHL n))
+        ...   | no _ | no _ = ≈-lift (FiniteHeightLattice.≈-refl (FHL n))
+
+        private
+            scary : ∀ (n₁ n₂ : Node) → (p : n₁ ≡ n₂) → (n₁ ≟ n₂) ≡ subst (λ n → Dec (n₁ ≡ n)) p (yes refl)
+            scary n₁ n₂ refl with n₁ ≟ n₂
+            ... | yes refl = refl
+            ... | no n₁≢n₂ = ⊥-elim (n₁≢n₂ refl)
+
+            payloadˡ : ∀ e₁ e₂ e₃ → let n = proj₁ ((e₁ ⊔ e₂) ⊔ e₃)
+                                    in LatticeT n
+            payloadˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                with n ← (n₁ ⊔ᵇ n₂) ⊔ᵇ n₃
+                using _⊔ⁿ_ ← FiniteHeightLattice._⊔_ (FHL n)
+                with n ≟ n₁ | n ≟ n₂ | n ≟ n₃
+            ...   | yes refl | yes refl | yes refl = (l₁ ⊔ⁿ l₂) ⊔ⁿ l₃
+            ...   | yes refl | yes refl | no _ = l₁ ⊔ⁿ l₂
+            ...   | yes refl | no _ | yes refl = l₁ ⊔ⁿ l₃
+            ...   | yes refl | no _ | no _ = l₁
+            ...   | no _ | yes refl | yes refl = l₂ ⊔ⁿ l₃
+            ...   | no _ | yes refl | no _ = l₂
+            ...   | no _ | no _ | yes refl = l₃
+            ...   | no _ | no _ | no _ = FiniteHeightLattice.⊥ (FHL n)
+
+            payloadʳ : ∀ e₁ e₂ e₃ → let n = proj₁ (e₁ ⊔ (e₂ ⊔ e₃))
+                                    in LatticeT n
+            payloadʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                with n ← n₁ ⊔ᵇ (n₂ ⊔ᵇ n₃)
+                using _⊔ⁿ_ ← FiniteHeightLattice._⊔_ (FHL n)
+                with n ≟ n₁ | n ≟ n₂ | n ≟ n₃
+            ...   | yes refl | yes refl | yes refl = l₁ ⊔ⁿ (l₂ ⊔ⁿ l₃)
+            ...   | yes refl | yes refl | no _ = l₁ ⊔ⁿ l₂
+            ...   | yes refl | no _ | yes refl = l₁ ⊔ⁿ l₃
+            ...   | yes refl | no _ | no _ = l₁
+            ...   | no _ | yes refl | yes refl = l₂ ⊔ⁿ l₃
+            ...   | no _ | yes refl | no _ = l₂
+            ...   | no _ | no _ | yes refl = l₃
+            ...   | no _ | no _ | no _ = FiniteHeightLattice.⊥ (FHL n)
+
+            ⊔ᵇ-prop : ∀ n₁ n₂ n₃ → (n₁ ⊔ᵇ n₂) ⊔ᵇ n₃ ≡ n₁ →
+                                   (n₁ ⊔ᵇ n₂ ≡ n₁) × (n₁ ⊔ᵇ n₃ ≡ n₁)
+            ⊔ᵇ-prop n₁ n₂ n₃ pⁿ =
+                let n₁≼n₁⊔n₂ = x≼ᵇx⊔ᵇy n₁ n₂
+                    n₁⊔n₂≼n₁₂⊔n₃ = x≼ᵇx⊔ᵇy (n₁ ⊔ᵇ n₂) n₃
+                    n₁⊔n₂≼n₁ = trans (trans (≡-⊔ᵇ-cong refl (sym pⁿ)) (n₁⊔n₂≼n₁₂⊔n₃)) pⁿ
+                    n₁⊔n₂≡n₁ = ≼ᵇ-antisym n₁⊔n₂≼n₁ n₁≼n₁⊔n₂
+                    n₁≼n₁⊔n₃ = x≼ᵇx⊔ᵇy n₁ n₃
+                    n₁⊔n₃≼n₁₂⊔n₃ = ⊔ᵇ-Monotonicʳ n₃ n₁≼n₁⊔n₂
+                    n₁⊔n₃≼n₁ = trans (trans (≡-⊔ᵇ-cong refl (sym pⁿ)) (n₁⊔n₃≼n₁₂⊔n₃)) pⁿ
+                    n₁⊔n₃≡n₁ = ≼ᵇ-antisym n₁⊔n₃≼n₁ n₁≼n₁⊔n₃
+                in (n₁⊔n₂≡n₁ , n₁⊔n₃≡n₁)
+
+            Reassocˡ : ∀ e₁ e₂ e₃ →
+                      ((e₁ ⊔ e₂) ⊔ e₃) ≈ (proj₁ ((e₁ ⊔ e₂) ⊔ e₃) , payloadˡ e₁ e₂ e₃)
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                with n ← (n₁ ⊔ᵇ n₂) ⊔ᵇ n₃ in pⁿ
+                with n ≟ n₁ in d₁ | n ≟ n₂ in d₂ | n ≟ n₃ in d₃
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | yes refl | yes refl
+                    with (n₁ ⊔ᵇ n₁) ≟ n₁
+            ...       | no n₁≢n₁ = ⊥-elim (n₁≢n₁ (⊔ᵇ-idemp n₁))
+            ...       | yes p rewrite p
+                        with n₁ ≟ n₁
+            ...           | no n₁≢n₁ = ⊥-elim (n₁≢n₁ refl)
+            ...           | yes refl = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | yes refl | no _
+                    with (n₁ ⊔ᵇ n₁) ≟ n₁
+            ...       | no n₁≢n₁ = ⊥-elim (n₁≢n₁ (⊔ᵇ-idemp n₁))
+            ...       | yes p rewrite p
+                        with n₁ ≟ n₁
+            ...           | no n₁≢n₁ = ⊥-elim (n₁≢n₁ refl)
+            ...           | yes refl = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes p₁@refl | no n₁≢n₂ | yes p₃@refl
+                    using n₁⊔n₂≡n₁ ← trans (trans (trans (≡-⊔ᵇ-cong (sym (⊔ᵇ-idemp n₁)) (refl {x = n₂})) (⊔ᵇ-assoc n₁ n₁ n₂)) (⊔ᵇ-comm n₁ (n₁ ⊔ᵇ n₂))) pⁿ
+                    with (n₁ ⊔ᵇ n₂) ≟ n₁
+            ...       | no n₁⊔n₂≢n₁ = ⊥-elim (n₁⊔n₂≢n₁ n₁⊔n₂≡n₁)
+            ...       | yes p rewrite p
+                        with n₁ ≟ n₁ | n₁ ≟ n₂
+            ...           | no n₁≢n₁ | _ = ⊥-elim (n₁≢n₁ refl)
+            ...           | _ | yes n₁≡n₂ = ⊥-elim (n₁≢n₂ n₁≡n₂)
+            ...           | yes refl | no _ = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes p₁@refl | no n₁≢n₂ | no n₁≢n₃
+                    using (n₁⊔n₂≡n₁ , n₁⊔n₃≡n₁) ← ⊔ᵇ-prop n₁ n₂ n₃ pⁿ
+                    with n₁ ⊔ᵇ n₂ ≟ n₁
+            ...       | no n₁⊔n₂≢n₁ = ⊥-elim (n₁⊔n₂≢n₁ n₁⊔n₂≡n₁)
+            ...       | yes p rewrite p
+                        with n₁ ≟ n₁ | n₁ ≟ n₂
+            ...           | no n₁≢n₁ | _ = ⊥-elim (n₁≢n₁ refl)
+            ...           | _ | yes n₁≡n₂ = ⊥-elim (n₁≢n₂ n₁≡n₂)
+            ...           | yes refl | no _ = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₂≢n₁ | yes p₂@refl | yes p₃@refl
+                    using n₁⊔n₂≡n₂ ← trans (trans (≡-⊔ᵇ-cong (refl {x = n₁}) (sym (⊔ᵇ-idemp n₂))) (sym (⊔ᵇ-assoc n₁ n₂ n₂))) pⁿ
+                    with (n₁ ⊔ᵇ n₂) ≟ n₂
+            ...       | no n₁⊔n₂≢n₂ = ⊥-elim (n₁⊔n₂≢n₂ n₁⊔n₂≡n₂)
+            ...       | yes p rewrite p
+                        with n₂ ≟ n₁ | n₂ ≟ n₂
+            ...           | yes n₂≡n₁ | _ = ⊥-elim (n₂≢n₁ n₂≡n₁)
+            ...           | _ | no n₂≢n₂ = ⊥-elim (n₂≢n₂ refl)
+            ...           | no _ | yes refl = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₂≢n₁ | yes p₂@refl | no n₂≢n₃
+                    using (n₂⊔n₁≡n₂ , n₂⊔n₃≡n₂) ← ⊔ᵇ-prop n₂ n₁ n₃ (trans (≡-⊔ᵇ-cong (⊔ᵇ-comm n₂ n₁) (refl {x = n₃})) pⁿ)
+                    with (n₁ ⊔ᵇ n₂) ≟ n₁ | (n₁ ⊔ᵇ n₂) ≟ n₂
+            ...       | yes n₁⊔n₂≡n₁ | _ = ⊥-elim (n₂≢n₁ (trans (sym n₂⊔n₁≡n₂) (trans (⊔ᵇ-comm n₂ n₁) (n₁⊔n₂≡n₁))))
+            ...       | _ | no n₁⊔n₂≢n₂ = ⊥-elim (n₁⊔n₂≢n₂ (trans (⊔ᵇ-comm n₁ n₂) n₂⊔n₁≡n₂))
+            ...       | no n₁⊔n₂≢n₁ | yes p rewrite p
+                        with n₂ ≟ n₂
+            ...           | no n₂≢n₂ = ⊥-elim (n₂≢n₂ refl)
+            ...           | yes refl = ≈-refl
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₃≢n₁ | no n₃≢n₂ | yes p₃@refl
+                    with n₁₂ ← n₁ ⊔ᵇ n₂
+                    with n₃ ≟ n₁₂
+            ...       | no n₃≢n₁₂ = ≈-refl
+            ...       | yes refl rewrite d₁ rewrite d₂ = ≈-lift (⊥≼x l₃) -- TODO: need ⊥ ⊔ n₃ ≡ n₃
+            Reassocˡ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n≢n₁ | no n≢n₂ | no n≢n₃
+                    with n₁₂ ← n₁ ⊔ᵇ n₂
+                    with n₁₂ ≟ n₁ | n₁₂ ≟ n₂ | n ≟ n₃ | n ≟ n₁₂
+            ...       | _ | _ | yes n≡n₃ | _ = ⊥-elim (n≢n₃ n≡n₃)
+            ...       | _ | _ | no _ | no n≢n₁₂ = ≈-refl
+            ...       | yes refl | yes refl | no _ | yes refl = ⊥-elim (n≢n₁ refl)
+            ...       | yes refl | no n₁₂≢n₂ | no _ | yes refl = ⊥-elim (n≢n₁ refl)
+            ...       | no n₁₂≢n₁ | yes refl | no _ | yes refl = ⊥-elim (n≢n₂ refl)
+            ...       | no _ | no _ | no _ | yes refl = ≈-refl
+
+            Reassocʳ : ∀ e₁ e₂ e₃ →
+                       (e₁ ⊔ (e₂ ⊔ e₃)) ≈ (proj₁ (e₁ ⊔ (e₂ ⊔ e₃)) , payloadʳ e₁ e₂ e₃)
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                with n ← n₁ ⊔ᵇ (n₂ ⊔ᵇ n₃) in pⁿ
+                with n ≟ n₁ in d₁ | n ≟ n₂ in d₂ | n ≟ n₃ in d₃
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | yes refl | yes refl
+                    with (n₁ ⊔ᵇ n₁) ≟ n₁
+            ...       | no n₁≢n₁ = ⊥-elim (n₁≢n₁ (⊔ᵇ-idemp n₁))
+            ...       | yes p rewrite p
+                        with n₁ ≟ n₁
+            ...           | no n₁≢n₁ = ⊥-elim (n₁≢n₁ refl)
+            ...           | yes refl = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | yes refl | no n₁≢n₃
+                    using n₁⊔n₃≡n₁ ← trans (≡-⊔ᵇ-cong (sym (⊔ᵇ-idemp n₁)) (refl {x = n₃})) (trans (⊔ᵇ-assoc n₁ n₁ n₃) pⁿ)
+                    rewrite n₁⊔n₃≡n₁
+                    with n₁ ≟ n₁ | n₁ ≟ n₃
+            ...     | no n₁≢n₁ | _ = ⊥-elim (n₁≢n₁ refl)
+            ...     | _ | yes n₁≡n₃ = ⊥-elim (n₁≢n₃ n₁≡n₃)
+            ...     | yes refl | no _ = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | no n₁≢n₂ | yes refl
+                    using n₂⊔n₁≡n₁ ← trans (trans (trans (≡-⊔ᵇ-cong (refl {x = n₂}) (sym (⊔ᵇ-idemp n₁))) (sym (⊔ᵇ-assoc n₂ n₁ n₁))) (⊔ᵇ-comm _ _)) pⁿ
+                    rewrite n₂⊔n₁≡n₁
+                    with n₁ ≟ n₁ | n₁ ≟ n₂
+            ...       | no n₁≢n₁ | _ = ⊥-elim (n₁≢n₁ refl)
+            ...       | _ | yes n₁≡n₂ = ⊥-elim (n₁≢n₂ n₁≡n₂)
+            ...       | yes refl | no _ = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | yes refl | no n₁≢n₂ | no n₁≢n₃
+                    with n₂₃ ← n₂ ⊔ᵇ n₃
+                    with n₁ ≟ n₂₃
+            ...       | no n₁≢n₂₃ = ≈-refl
+            ...       | yes refl rewrite d₂ rewrite d₃ = ≈-lift (FiniteHeightLattice.≈-trans (FHL n₁) (FiniteHeightLattice.⊔-comm (FHL n₁) _ _) (⊥≼x l₁))
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₂≢n₁ | yes refl | yes refl
+                    rewrite ⊔ᵇ-idemp n₂
+                    with n₂ ≟ n₂
+            ...       | no n₂≢n₂ = ⊥-elim (n₂≢n₂ refl)
+            ...       | yes refl = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₂≢n₁ | yes refl | no n₂≢n₃
+                  using (n₂⊔n₃=n₂ , n₂⊔n₁=n₂) ← ⊔ᵇ-prop n₂ n₃ n₁ (trans (⊔ᵇ-comm _ _) pⁿ)
+                  rewrite n₂⊔n₃=n₂
+                  with n₂ ≟ n₂ | n₂ ≟ n₃
+            ...     | no n₂≢n₂ | _ = ⊥-elim (n₂≢n₂ refl)
+            ...     | _ | yes n₂≡n₃ = ⊥-elim (n₂≢n₃ n₂≡n₃)
+            ...     | yes refl | no _ = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n₃≢n₁ | no n₃≢n₂ | yes refl
+                    using (n₃⊔n₂≡n₃ , n₃⊔n₁≡n₃) ← ⊔ᵇ-prop n₃ n₂ n₁ (trans (⊔ᵇ-comm _ _) (trans (≡-⊔ᵇ-cong (refl {x = n₁}) (⊔ᵇ-comm n₃ n₂)) pⁿ))
+                    rewrite trans (⊔ᵇ-comm _ _) n₃⊔n₂≡n₃
+                    with n₃ ≟ n₃ | n₃ ≟ n₂
+            ...       | no n₃≢n₃ | _ = ⊥-elim (n₃≢n₃ refl)
+            ...       | _ | yes n₃≡n₂ = ⊥-elim (n₃≢n₂ n₃≡n₂)
+            ...       | yes refl | no _ = ≈-refl
+            Reassocʳ (n₁ , l₁) (n₂ , l₂) (n₃ , l₃)
+                  | no n≢n₁ | no n≢n₂ | no n≢n₃
+                    with n₂₃ ← n₂ ⊔ᵇ n₃
+                    with n₂₃ ≟ n₂ | n₂₃ ≟ n₃ | n ≟ n₁ | n ≟ n₂₃
+            ...       | _ | _ | yes n≡n₁ | _ = ⊥-elim (n≢n₁ n≡n₁)
+            ...       | _ | _ | no _ | no _ = ≈-refl
+            ...       | yes refl | yes refl | no _ | yes refl = ⊥-elim (n≢n₂ refl)
+            ...       | yes refl | no n₁₂≢n₂ | no _ | yes refl = ⊥-elim (n≢n₂ refl)
+            ...       | no n₁₂≢n₁ | yes refl | no _ | yes refl = ⊥-elim (n≢n₃ refl)
+            ...       | no n₁₂≢n₁ | no n₁₂≢n₂ | no _ | yes refl = ≈-refl
+
+
+        ⊔-assoc : ∀ (e₁ e₂ e₃ : Elem) → ((e₁ ⊔ e₂) ⊔ e₃) ≈ (e₁ ⊔ (e₂ ⊔ e₃))
+        ⊔-assoc e₁@(n₁ , l₁) e₂@(n₂ , l₂) e₃@(n₃ , l₃)
+            with nˡ ← proj₁ ((e₁ ⊔ e₂) ⊔ e₃) in pˡ
+            with nʳ ← proj₁ (e₁ ⊔ (e₂ ⊔ e₃)) in pʳ
+            with final₁ ← Reassocˡ e₁ e₂ e₃
+            with final₂ ← Reassocʳ e₁ e₂ e₃
+            rewrite pˡ rewrite pʳ
+            rewrite ⊔ᵇ-assoc n₁ n₂ n₃
+            rewrite trans (sym pˡ ) pʳ
+            with nʳ ≟ n₁ | nʳ ≟ n₂ | nʳ ≟ n₃
+        ...   | yes refl | yes refl | yes refl =
+            let l-assoc = FiniteHeightLattice.⊔-assoc (FHL n₁) l₁ l₂ l₃
+            in ≈-trans final₁ (≈-trans (≈-lift l-assoc) (≈-sym final₂))
+        ...   | yes refl | yes refl | no _ = ≈-trans final₁ (≈-sym final₂)
+        ...   | yes refl | no _ | yes refl = ≈-trans final₁ (≈-sym final₂)
+        ...   | yes refl | no _ | no _ = ≈-trans final₁ (≈-sym final₂)
+        ...   | no _ | yes refl | yes refl = ≈-trans final₁ (≈-sym final₂)
+        ...   | no _ | yes refl | no _ = ≈-trans final₁ (≈-sym final₂)
+        ...   | no _ | no _ | yes refl = ≈-trans final₁ (≈-sym final₂)
+        ...   | no _ | no _ | no _ = ≈-trans final₁ (≈-sym final₂)

Lattice/ExtendBelow.agda

@@ -0,0 +1,169 @@
+open import Lattice
+
+module Lattice.ExtendBelow {a} (A : Set a)
+    {_≈₁_ : A → A → Set a} {_⊔₁_ : A → A → A} {_⊓₁_ : A → A → A}
+    {{lA : IsLattice A _≈₁_ _⊔₁_ _⊓₁_}} where
+
+open import Equivalence
+open import Showable using (Showable; show)
+open import Relation.Binary.Definitions using (Decidable)
+open import Relation.Binary.PropositionalEquality using (refl)
+open import Relation.Nullary using (Dec; ¬_; yes; no)
+
+open IsLattice lA using ()
+    renaming ( ≈-equiv to ≈₁-equiv
+             ; ≈-⊔-cong to ≈₁-⊔₁-cong
+             ; ⊔-assoc to ⊔₁-assoc; ⊔-comm to ⊔₁-comm; ⊔-idemp to ⊔₁-idemp
+             ; ≈-⊓-cong to ≈₁-⊓₁-cong
+             ; ⊓-assoc to ⊓₁-assoc; ⊓-comm to ⊓₁-comm; ⊓-idemp to ⊓₁-idemp
+             ; absorb-⊔-⊓ to absorb-⊔₁-⊓₁; absorb-⊓-⊔ to absorb-⊓₁-⊔₁
+             )
+
+open IsEquivalence ≈₁-equiv using ()
+    renaming (≈-refl to ≈₁-refl; ≈-sym to ≈₁-sym; ≈-trans to ≈₁-trans)
+
+data ExtendBelow : Set a where
+    [_] : A → ExtendBelow
+    ⊥ : ExtendBelow
+
+instance
+    showable : {{ showableA : Showable A }} → Showable ExtendBelow
+    showable = record
+        { show = (λ
+            { ⊥ → "⊥"
+            ; [ a ] → show a
+            })
+        }
+
+data _≈_ : ExtendBelow → ExtendBelow → Set a where
+    ≈-⊥-⊥ : ⊥ ≈ ⊥
+    ≈-lift : ∀ {x y : A} → x ≈₁ y → [ x ] ≈ [ y ]
+
+≈-refl : ∀ {ab : ExtendBelow} → ab ≈ ab
+≈-refl {⊥} = ≈-⊥-⊥
+≈-refl {[ x ]} = ≈-lift ≈₁-refl
+
+≈-sym : ∀ {ab₁ ab₂ : ExtendBelow} → ab₁ ≈ ab₂ → ab₂ ≈ ab₁
+≈-sym ≈-⊥-⊥ = ≈-⊥-⊥
+≈-sym (≈-lift x≈₁y) = ≈-lift (≈₁-sym x≈₁y)
+
+≈-trans : ∀ {ab₁ ab₂ ab₃ : ExtendBelow} → ab₁ ≈ ab₂ → ab₂ ≈ ab₃ → ab₁ ≈ ab₃
+≈-trans ≈-⊥-⊥ ≈-⊥-⊥ = ≈-⊥-⊥
+≈-trans (≈-lift a₁≈a₂) (≈-lift a₂≈a₃) = ≈-lift (≈₁-trans a₁≈a₂ a₂≈a₃)
+
+instance
+    ≈-equiv : IsEquivalence ExtendBelow _≈_
+    ≈-equiv = record
+        { ≈-refl = ≈-refl
+        ; ≈-sym = ≈-sym
+        ; ≈-trans = ≈-trans
+        }
+
+_⊔_ : ExtendBelow → ExtendBelow → ExtendBelow
+_⊔_ ⊥ x = x
+_⊔_ [ a₁ ] ⊥ = [ a₁ ]
+_⊔_ [ a₁ ] [ a₂ ] = [ a₁ ⊔₁ a₂ ]
+
+_⊓_ : ExtendBelow → ExtendBelow → ExtendBelow
+_⊓_ ⊥ x = ⊥
+_⊓_ [ _ ] ⊥ = ⊥
+_⊓_ [ a₁ ] [ a₂ ] = [ a₁ ⊓₁ a₂ ]
+
+≈-⊔-cong : ∀ {x₁ x₂ x₃ x₄} → x₁ ≈ x₂ → x₃ ≈ x₄ →
+           (x₁ ⊔ x₃) ≈ (x₂ ⊔ x₄)
+≈-⊔-cong .{⊥} .{⊥} {x₃} {x₄} ≈-⊥-⊥ [a₃]≈[a₄] = [a₃]≈[a₄]
+≈-⊔-cong {x₁ = [ a₁ ]} {x₂ = [ a₂ ]} .{⊥} .{⊥} [a₁]≈[a₂] ≈-⊥-⊥ = [a₁]≈[a₂]
+≈-⊔-cong {x₁ = [ a₁ ]} {x₂ = [ a₂ ]} {x₃ = [ a₃ ]} {x₄ = [ a₄ ]} (≈-lift a₁≈a₂) (≈-lift a₃≈a₄) = ≈-lift (≈₁-⊔₁-cong a₁≈a₂ a₃≈a₄)
+
+⊔-assoc : ∀ (x₁ x₂ x₃ : ExtendBelow) →  ((x₁ ⊔ x₂) ⊔ x₃) ≈ (x₁ ⊔ (x₂ ⊔ x₃))
+⊔-assoc ⊥ x₁ x₂ = ≈-refl
+⊔-assoc [ a₁ ] ⊥ x₂ = ≈-refl
+⊔-assoc [ a₁ ] [ a₂ ] ⊥ = ≈-refl
+⊔-assoc [ a₁ ] [ a₂ ] [ a₃ ] = ≈-lift (⊔₁-assoc a₁ a₂ a₃)
+
+⊔-comm : ∀ (x₁ x₂ : ExtendBelow) →  (x₁ ⊔ x₂) ≈ (x₂ ⊔ x₁)
+⊔-comm ⊥ ⊥ = ≈-refl
+⊔-comm ⊥ [ a₂ ] = ≈-refl
+⊔-comm [ a₁ ] ⊥ = ≈-refl
+⊔-comm [ a₁ ] [ a₂ ] = ≈-lift (⊔₁-comm a₁ a₂)
+
+⊔-idemp : ∀ (x : ExtendBelow) →  (x ⊔ x) ≈ x
+⊔-idemp ⊥ = ≈-refl
+⊔-idemp [ a ] = ≈-lift (⊔₁-idemp a)
+
+≈-⊓-cong : ∀ {x₁ x₂ x₃ x₄} → x₁ ≈ x₂ → x₃ ≈ x₄ →
+           (x₁ ⊓ x₃) ≈ (x₂ ⊓ x₄)
+≈-⊓-cong .{⊥} .{⊥} {x₃} {x₄} ≈-⊥-⊥ [a₃]≈[a₄] = ≈-⊥-⊥
+≈-⊓-cong {x₁ = [ a₁ ]} {x₂ = [ a₂ ]} .{⊥} .{⊥} [a₁]≈[a₂] ≈-⊥-⊥ = ≈-⊥-⊥
+≈-⊓-cong {x₁ = [ a₁ ]} {x₂ = [ a₂ ]} {x₃ = [ a₃ ]} {x₄ = [ a₄ ]} (≈-lift a₁≈a₂) (≈-lift a₃≈a₄) = ≈-lift (≈₁-⊓₁-cong a₁≈a₂ a₃≈a₄)
+
+⊓-assoc : ∀ (x₁ x₂ x₃ : ExtendBelow) →  ((x₁ ⊓ x₂) ⊓ x₃) ≈ (x₁ ⊓ (x₂ ⊓ x₃))
+⊓-assoc ⊥ x₁ x₂ = ≈-refl
+⊓-assoc [ a₁ ] ⊥ x₂ = ≈-refl
+⊓-assoc [ a₁ ] [ a₂ ] ⊥ = ≈-refl
+⊓-assoc [ a₁ ] [ a₂ ] [ a₃ ] = ≈-lift (⊓₁-assoc a₁ a₂ a₃)
+
+⊓-comm : ∀ (x₁ x₂ : ExtendBelow) →  (x₁ ⊓ x₂) ≈ (x₂ ⊓ x₁)
+⊓-comm ⊥ ⊥ = ≈-refl
+⊓-comm ⊥ [ a₂ ] = ≈-refl
+⊓-comm [ a₁ ] ⊥ = ≈-refl
+⊓-comm [ a₁ ] [ a₂ ] = ≈-lift (⊓₁-comm a₁ a₂)
+
+⊓-idemp : ∀ (x : ExtendBelow) →  (x ⊓ x) ≈ x
+⊓-idemp ⊥ = ≈-refl
+⊓-idemp [ a ] = ≈-lift (⊓₁-idemp a)
+
+absorb-⊔-⊓ : (x₁ x₂ : ExtendBelow) → (x₁ ⊔ (x₁ ⊓ x₂)) ≈ x₁
+absorb-⊔-⊓ ⊥ ⊥ = ≈-refl
+absorb-⊔-⊓ ⊥ [ a₂ ] = ≈-refl
+absorb-⊔-⊓ [ a₁ ] ⊥ = ≈-refl
+absorb-⊔-⊓ [ a₁ ] [ a₂ ] = ≈-lift (absorb-⊔₁-⊓₁ a₁ a₂)
+
+absorb-⊓-⊔ : (x₁ x₂ : ExtendBelow) → (x₁ ⊓ (x₁ ⊔ x₂)) ≈ x₁
+absorb-⊓-⊔ ⊥ ⊥ = ≈-refl
+absorb-⊓-⊔ ⊥ [ a₂ ] = ≈-refl
+absorb-⊓-⊔ [ a₁ ] ⊥ = ⊓-idemp [ a₁ ]
+absorb-⊓-⊔ [ a₁ ] [ a₂ ] = ≈-lift (absorb-⊓₁-⊔₁ a₁ a₂)
+
+instance
+    isJoinSemilattice : IsSemilattice ExtendBelow _≈_ _⊔_
+    isJoinSemilattice = record
+        { ≈-equiv = ≈-equiv
+        ; ≈-⊔-cong = ≈-⊔-cong
+        ; ⊔-assoc = ⊔-assoc
+        ; ⊔-comm = ⊔-comm
+        ; ⊔-idemp = ⊔-idemp
+        }
+
+    isMeetSemilattice : IsSemilattice ExtendBelow _≈_ _⊓_
+    isMeetSemilattice = record
+        { ≈-equiv = ≈-equiv
+        ; ≈-⊔-cong = ≈-⊓-cong
+        ; ⊔-assoc = ⊓-assoc
+        ; ⊔-comm = ⊓-comm
+        ; ⊔-idemp = ⊓-idemp
+        }
+
+    isLattice : IsLattice ExtendBelow _≈_ _⊔_ _⊓_
+    isLattice = record
+        { joinSemilattice = isJoinSemilattice
+        ; meetSemilattice = isMeetSemilattice
+        ; absorb-⊔-⊓ = absorb-⊔-⊓
+        ; absorb-⊓-⊔ = absorb-⊓-⊔
+        }
+
+module _ {{≈₁-Decidable : IsDecidable _≈₁_}} where
+    open IsDecidable ≈₁-Decidable using () renaming (R-dec to ≈₁-dec)
+
+    ≈-dec : Decidable _≈_
+    ≈-dec ⊥ ⊥ = yes ≈-⊥-⊥
+    ≈-dec [ a₁ ] [ a₂ ]
+        with ≈₁-dec a₁ a₂
+    ...   | yes a₁≈a₂ = yes (≈-lift a₁≈a₂)
+    ...   | no a₁̷≈a₂ = no (λ { (≈-lift a₁≈a₂) → a₁̷≈a₂ a₁≈a₂ })
+    ≈-dec ⊥ [ _ ] = no (λ ())
+    ≈-dec [ _ ] ⊥ = no (λ ())
+
+    instance
+        ≈-Decidable : IsDecidable _≈_
+        ≈-Decidable = record { R-dec = ≈-dec }

Lattice/FiniteMap.agda

@@ -3,16 +3,28 @@ open import Relation.Binary.PropositionalEquality as Eq
     using (_≡_;refl; sym; trans; cong; subst)
 open import Agda.Primitive using (Level) renaming (_⊔_ to _⊔ℓ_)
 open import Data.List using (List; _∷_; [])
+open import Data.Unit using (⊤)
 
-module Lattice.FiniteMap {a b : Level} {A : Set a} {B : Set b}
-    {_≈₂_ : B → B → Set b}
+module Lattice.FiniteMap (A : Set) (B : Set)
+    {_≈₂_ : B → B → Set}
     {_⊔₂_ : B → B → B} {_⊓₂_ : B → B → B}
-    (≡-dec-A : IsDecidable (_≡_ {a} {A}))
-    (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+    {{≡-Decidable-A : IsDecidable {_} {A} _≡_}}
+    {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}} (ks : List A) where
 
 open IsLattice lB using () renaming (_≼_ to _≼₂_)
-open import Lattice.Map ≡-dec-A lB as Map
-    using (Map; ⊔-equal-keys; ⊓-equal-keys)
+open import Lattice.Map A B _ as Map
+    using
+        ( Map
+        ; ⊔-equal-keys
+        ; ⊓-equal-keys
+        ; subset-impl
+        ; Map-functional
+        ; Expr-Provenance
+        ; Expr-Provenance-≡
+        ; `_; _∪_; _∩_
+        ; in₁; in₂; bothᵘ; single
+        ; ⊔-combines
+        )
     renaming
         ( _≈_ to _≈ᵐ_
         ; _⊔_ to _⊔ᵐ_
@@ -28,9 +40,11 @@ open import Lattice.Map ≡-dec-A lB as Map
         ; ⊓-idemp to ⊓ᵐ-idemp
         ; absorb-⊔-⊓ to absorb-⊔ᵐ-⊓ᵐ
         ; absorb-⊓-⊔ to absorb-⊓ᵐ-⊔ᵐ
-        ; ≈-dec to ≈ᵐ-dec
+        ; ≈-Decidable to ≈ᵐ-Decidable
         ; _[_] to _[_]ᵐ
+        ; []-∈ to []ᵐ-∈
         ; m₁≼m₂⇒m₁[k]≼m₂[k] to m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ
+        ; m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ to m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ᵐ
         ; locate to locateᵐ
         ; keys to keysᵐ
         ; _updating_via_ to _updatingᵐ_via_
@@ -44,17 +58,24 @@ open import Lattice.Map ≡-dec-A lB as Map
         ; _≼_ to _≼ᵐ_
         ; ∈k-dec to ∈k-decᵐ
         )
+open import Data.Empty using (⊥-elim)
+open import Data.List using (List; length; []; _∷_; map)
 open import Data.List.Membership.Propositional using () renaming (_∈_ to _∈ˡ_)
-open import Data.Product using (_×_; _,_; Σ; proj₁ ; proj₂)
+open import Data.List.Properties using (∷-injectiveʳ)
+open import Data.List.Relation.Unary.All using (All)
+open import Data.List.Relation.Unary.Any using (Any; here; there)
+open import Data.Nat using (ℕ)
+open import Data.Product using (_×_; _,_; Σ; proj₁; proj₂)
 open import Equivalence
 open import Function using (_∘_)
 open import Relation.Nullary using (¬_; Dec; yes; no)
-open import Utils using (Pairwise; _∷_; [])
-open import Data.Empty using (⊥-elim)
+open import Utils using (Pairwise; _∷_; []; Unique; push; empty; All¬-¬Any)
 open import Showable using (Showable; show)
+open import Isomorphism using (IsInverseˡ; IsInverseʳ)
+open import Chain using (Height)
 
-module WithKeys (ks : List A) where
-    FiniteMap : Set (a ⊔ℓ b)
+private module WithKeys (ks : List A) where
+    FiniteMap : Set
     FiniteMap = Σ Map (λ m → Map.keys m ≡ ks)
 
     instance
@@ -62,11 +83,15 @@ module WithKeys (ks : List A) where
                    Showable FiniteMap
         showable = record { show = λ (m₁ , _) → show m₁ }
 
-    _≈_ : FiniteMap → FiniteMap → Set (a ⊔ℓ b)
+    _≈_ : FiniteMap → FiniteMap → Set
     _≈_ (m₁ , _) (m₂ , _) = m₁ ≈ᵐ m₂
 
-    ≈₂-dec⇒≈-dec : IsDecidable _≈₂_ → IsDecidable _≈_
-    ≈₂-dec⇒≈-dec ≈₂-dec fm₁ fm₂ = ≈ᵐ-dec ≈₂-dec (proj₁ fm₁) (proj₁ fm₂)
+    instance
+        ≈-Decidable : {{ IsDecidable _≈₂_ }} → IsDecidable _≈_
+        ≈-Decidable {{≈₂-Decidable}} = record
+            { R-dec = λ fm₁ fm₂ →  IsDecidable.R-dec (≈ᵐ-Decidable {{≈₂-Decidable}})
+                                                     (proj₁ fm₁) (proj₁ fm₂)
+            }
 
     _⊔_ : FiniteMap → FiniteMap → FiniteMap
     _⊔_ (m₁ , km₁≡ks) (m₂ , km₂≡ks) =
@@ -82,10 +107,10 @@ module WithKeys (ks : List A) where
                 km₁≡ks
         )
 
-    _∈_ : A × B → FiniteMap → Set (a ⊔ℓ b)
+    _∈_ : A × B → FiniteMap → Set
     _∈_ k,v (m₁ , _) = k,v ∈ˡ (proj₁ m₁)
 
-    _∈k_ : A → FiniteMap → Set a
+    _∈k_ : A → FiniteMap → Set
     _∈k_ k (m₁ , _) = k ∈ˡ (keysᵐ m₁)
 
     open Map using (forget) public
@@ -104,6 +129,10 @@ module WithKeys (ks : List A) where
     _[_] : FiniteMap → List A → List B
     _[_] (m₁ , _) ks = m₁ [ ks ]ᵐ
 
+    []-∈ : ∀ {k : A} {v : B} {ks' : List A} (fm : FiniteMap) →
+           k ∈ˡ ks' → (k , v) ∈ fm → v ∈ˡ (fm [ ks' ])
+    []-∈ {k} {v} {ks'} (m , _) k∈ks' k,v∈fm = []ᵐ-∈ m k,v∈fm k∈ks'
+
     ≈-equiv : IsEquivalence FiniteMap _≈_
     ≈-equiv = record
         { ≈-refl =
@@ -114,7 +143,9 @@ module WithKeys (ks : List A) where
             λ {(m₁ , _)} {(m₂ , _)} {(m₃ , _)} →
                 IsEquivalence.≈-trans ≈ᵐ-equiv {m₁} {m₂} {m₃}
         }
+    open IsEquivalence ≈-equiv public
 
+    instance
         isUnionSemilattice : IsSemilattice FiniteMap _≈_ _⊔_
         isUnionSemilattice = record
             { ≈-equiv = ≈-equiv
@@ -145,8 +176,6 @@ module WithKeys (ks : List A) where
             ; absorb-⊓-⊔ = λ (m₁ , _) (m₂ , _) → absorb-⊓ᵐ-⊔ᵐ m₁ m₂
             }
 
-    open IsLattice isLattice using (_≼_; ⊔-Monotonicˡ; ⊔-Monotonicʳ) public
-
         lattice : Lattice FiniteMap
         lattice = record
             { _≈_ = _≈_
@@ -155,14 +184,21 @@ module WithKeys (ks : List A) where
             ; isLattice = isLattice
             }
 
+    open IsLattice isLattice using (_≼_; ⊔-idemp; ⊔-Monotonicˡ; ⊔-Monotonicʳ) public
+
     m₁≼m₂⇒m₁[k]≼m₂[k] : ∀ (fm₁ fm₂ : FiniteMap) {k : A} {v₁ v₂ : B} →
                         fm₁ ≼ fm₂ → (k , v₁) ∈ fm₁ → (k , v₂) ∈ fm₂ → v₁ ≼₂ v₂
     m₁≼m₂⇒m₁[k]≼m₂[k] (m₁ , _) (m₂ , _) m₁≼m₂ k,v₁∈m₁ k,v₂∈m₂ = m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ m₁ m₂ m₁≼m₂ k,v₁∈m₁ k,v₂∈m₂
 
+    m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ : ∀ (fm₁ fm₂ : FiniteMap) {k : A} →
+                             fm₁ ≈ fm₂ → ∀ (k∈kfm₁ : k ∈k fm₁) (k∈kfm₂ : k ∈k fm₂) →
+                             proj₁ (locate {fm = fm₁} k∈kfm₁) ≈₂ proj₁ (locate {fm = fm₂} k∈kfm₂)
+    m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ (m₁ , _) (m₂ , _) = m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ᵐ m₁ m₂
+
     module GeneralizedUpdate
              {l} {L : Set l}
              {_≈ˡ_ : L → L → Set l} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
-             (lL : IsLattice L _≈ˡ_ _⊔ˡ_ _⊓ˡ_)
+             {{lL : IsLattice L _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
              (f : L → FiniteMap) (f-Monotonic : Monotonic (IsLattice._≼_ lL) _≼_ f)
              (g : A → L → B) (g-Monotonicʳ : ∀ k → Monotonic (IsLattice._≼_ lL) _≼₂_ (g k))
              (ks : List A) where
@@ -176,7 +212,7 @@ module WithKeys (ks : List A) where
         f' l = (f l) updating ks via (updater l)
 
         f'-Monotonic : Monotonic _≼ˡ_ _≼_ f'
-        f'-Monotonic {l₁} {l₂} l₁≼l₂ = f'-Monotonicᵐ lL (proj₁ ∘ f) f-Monotonic g g-Monotonicʳ ks l₁≼l₂
+        f'-Monotonic {l₁} {l₂} l₁≼l₂ = f'-Monotonicᵐ (proj₁ ∘ f) f-Monotonic g g-Monotonicʳ ks l₁≼l₂
 
         f'-∈k-forward : ∀ {k l} → k ∈k (f l) → k ∈k (f' l)
         f'-∈k-forward {k} {l} = updatingᵐ-via-∈k-forward (proj₁ (f l)) ks (updater l)
@@ -218,4 +254,382 @@ module WithKeys (ks : List A) where
     ...   | yes k∈km₁ | no k∉km₂ = ⊥-elim (∈k-exclusive fm₁ fm₂ (k∈km₁ , k∉km₂))
     ...   | no k∉km₁ | yes k∈km₂ = ⊥-elim (∈k-exclusive fm₂ fm₁ (k∈km₂ , k∉km₁))
 
-open WithKeys public
+private
+    _⊆ᵐ_ : ∀ {ks₁ ks₂ : List A} → WithKeys.FiniteMap ks₁ → WithKeys.FiniteMap ks₂ → Set
+    _⊆ᵐ_ fm₁ fm₂ = subset-impl (proj₁ (proj₁ fm₁)) (proj₁ (proj₁ fm₂))
+
+    _∈ᵐ_ : ∀ {ks : List A} → A × B → WithKeys.FiniteMap ks → Set
+    _∈ᵐ_ {ks} = WithKeys._∈_ ks
+
+FromBothMaps : ∀ (k : A) (v : B) {ks : List A} (fm₁ fm₂ : WithKeys.FiniteMap ks) → Set
+FromBothMaps k v fm₁ fm₂ =
+    Σ (B × B)
+      (λ (v₁ , v₂) → ( (v ≡ v₁ ⊔₂ v₂) × ((k , v₁) ∈ᵐ fm₁ × (k , v₂) ∈ᵐ fm₂)))
+
+Provenance-union : ∀ {ks : List A} (fm₁ fm₂ : WithKeys.FiniteMap ks) {k : A} {v : B} →
+                   (k , v) ∈ᵐ (WithKeys._⊔_ ks fm₁ fm₂) → FromBothMaps k v fm₁ fm₂
+Provenance-union fm₁@(m₁ , ks₁≡ks) fm₂@(m₂ , ks₂≡ks) {k} {v} k,v∈fm₁fm₂
+    with Expr-Provenance-≡ ((` m₁) ∪ (` m₂)) k,v∈fm₁fm₂
+...   | in₁ (single k,v∈m₁) k∉km₂
+        with k∈km₁ ← (WithKeys.forget k,v∈m₁)
+        rewrite trans ks₁≡ks (sym ks₂≡ks) =
+        ⊥-elim (k∉km₂ k∈km₁)
+...   | in₂ k∉km₁ (single k,v∈m₂)
+        with k∈km₂ ← (WithKeys.forget k,v∈m₂)
+        rewrite trans ks₁≡ks (sym ks₂≡ks) =
+        ⊥-elim (k∉km₁ k∈km₂)
+...   | bothᵘ {v₁} {v₂} (single k,v₁∈m₁) (single k,v₂∈m₂) =
+        ((v₁ , v₂) , (refl , (k,v₁∈m₁ , k,v₂∈m₂)))
+
+private module IterProdIsomorphism where
+    open WithKeys
+    open import Data.Unit using (tt)
+    open import Lattice.Unit using ()
+        renaming
+            ( _≈_ to _≈ᵘ_
+            ; _⊔_ to _⊔ᵘ_
+            ; _⊓_ to _⊓ᵘ_
+            ; ≈-Decidable to ≈ᵘ-Decidable
+            ; isLattice to isLatticeᵘ
+            ; ≈-equiv to ≈ᵘ-equiv
+            ; fixedHeight to fixedHeightᵘ
+            )
+    open import Lattice.IterProd B ⊤ _
+        as IP
+        using (IterProd)
+    open IsLattice lB using ()
+        renaming
+            ( ≈-trans to ≈₂-trans
+            ; ≈-sym to ≈₂-sym
+            ; FixedHeight to FixedHeight₂
+            )
+
+    from : ∀ {ks : List A} → FiniteMap ks → IterProd (length ks)
+    from {[]} (([] , _) , _) = tt
+    from {k ∷ ks'} (((k' , v) ∷ fm' , push _ uks') , refl) =
+        (v , from ((fm' , uks'), refl))
+
+    to : ∀ {ks : List A} → Unique ks → IterProd (length ks) → FiniteMap ks
+    to {[]} _ ⊤ = (([] , empty) , refl)
+    to {k ∷ ks'} (push k≢ks' uks') (v , rest) =
+        let
+            ((fm' , ufm') , fm'≡ks') = to uks' rest
+
+            -- This would be easier if we pattern matched on the equiality proof
+            -- to get refl, but that makes it harder to reason about 'to' when
+            -- the arguments are not known to be refl.
+            k≢fm' = subst (λ ks → All (λ k' → ¬ k ≡ k') ks) (sym fm'≡ks') k≢ks'
+            kvs≡ks = cong (k ∷_) fm'≡ks'
+        in
+            (((k , v) ∷ fm' , push k≢fm' ufm') , kvs≡ks)
+
+    _≈ⁱᵖ_ : ∀ {n : ℕ} → IterProd n → IterProd n → Set
+    _≈ⁱᵖ_ {n} = IP._≈_ {n}
+
+    _⊔ⁱᵖ_ : ∀ {ks : List A} →
+            IterProd (length ks) → IterProd (length ks) → IterProd (length ks)
+    _⊔ⁱᵖ_ {ks} = IP._⊔_ {length ks}
+
+    to-build : ∀ {b : B} {ks : List A} (uks : Unique ks) →
+               let fm = to uks (IP.build b tt (length ks))
+               in ∀ (k : A) (v : B) → (k , v) ∈ᵐ fm → v ≡ b
+    to-build {b} {k ∷ ks'} (push _ uks') k v (here refl) = refl
+    to-build {b} {k ∷ ks'} (push _ uks') k' v (there k',v∈m') =
+        to-build {ks = ks'} uks' k' v k',v∈m'
+
+
+    -- The left inverse is: from (to x) = x
+    from-to-inverseˡ : ∀ {ks : List A} (uks : Unique ks) →
+                      IsInverseˡ (_≈_ ks) (_≈ⁱᵖ_ {length ks})
+                                 (from {ks}) (to {ks} uks)
+    from-to-inverseˡ {[]} _ _ = IsEquivalence.≈-refl (IP.≈-equiv {0})
+    from-to-inverseˡ {k ∷ ks'} (push k≢ks' uks') (v , rest)
+        with ((fm' , ufm') , refl) ← to uks' rest in p rewrite sym p =
+            (IsLattice.≈-refl lB , from-to-inverseˡ {ks'} uks' rest)
+            -- the rewrite here is needed because the IH is in terms of `to uks' rest`,
+            -- but we end up with the 'unpacked' form (fm', ...). So, put it back
+            -- in the 'packed' form after we've performed enough inspection
+            -- to know we take the cons branch of `to`.
+
+    -- The map has its own uniqueness proof, but the call to 'to' needs a standalone
+    -- uniqueness proof too. Work with both proofs as needed to thread things through.
+    --
+    -- The right inverse is: to (from x) = x
+    from-to-inverseʳ : ∀ {ks : List A} (uks : Unique ks) →
+                       IsInverseʳ (_≈_ ks) (_≈ⁱᵖ_ {length ks})
+                                  (from {ks}) (to {ks} uks)
+    from-to-inverseʳ {[]} _ (([] , empty) , kvs≡ks) rewrite kvs≡ks =
+        ( (λ k v ())
+        , (λ k v ())
+        )
+    from-to-inverseʳ {k ∷ ks'} uks@(push _ uks'₁) fm₁@(((k , v) ∷ fm'₁ , push _ uks'₂) , refl)
+        with to uks'₁ (from ((fm'₁ , uks'₂) , refl))
+          | from-to-inverseʳ {ks'} uks'₁ ((fm'₁ , uks'₂) , refl)
+    ...   | ((fm'₂ , ufm'₂) , _)
+          | (fm'₂⊆fm'₁ , fm'₁⊆fm'₂) = (m₂⊆m₁ , m₁⊆m₂)
+                where
+                    kvs₁ = (k , v) ∷ fm'₁
+                    kvs₂ = (k , v) ∷ fm'₂
+
+                    m₁⊆m₂ : subset-impl kvs₁ kvs₂
+                    m₁⊆m₂ k' v' (here refl) =
+                        (v' , (IsLattice.≈-refl lB , here refl))
+                    m₁⊆m₂ k' v' (there k',v'∈fm'₁) =
+                        let (v'' , (v'≈v'' , k',v''∈fm'₂)) =
+                                fm'₁⊆fm'₂ k' v' k',v'∈fm'₁
+                        in (v'' , (v'≈v'' , there k',v''∈fm'₂))
+
+                    m₂⊆m₁ : subset-impl kvs₂ kvs₁
+                    m₂⊆m₁ k' v' (here refl) =
+                        (v' , (IsLattice.≈-refl lB , here refl))
+                    m₂⊆m₁ k' v' (there k',v'∈fm'₂) =
+                        let (v'' , (v'≈v'' , k',v''∈fm'₁)) =
+                                fm'₂⊆fm'₁ k' v' k',v'∈fm'₂
+                        in (v'' , (v'≈v'' , there k',v''∈fm'₁))
+
+    private
+        first-key-in-map : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
+                           Σ B (λ v → (k , v) ∈ᵐ fm)
+        first-key-in-map (((k , v) ∷ _ , _) , refl) = (v , here refl)
+
+        from-first-value : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
+                           proj₁ (from fm) ≡ proj₁ (first-key-in-map fm)
+        from-first-value {k} {ks} (((k , v) ∷ _ , push _ _) , refl) = refl
+
+        -- We need pop because reasoning about two distinct 'refl' pattern
+        -- matches is giving us unification errors. So, stash the 'refl' pattern
+        -- matching into a helper functions, and write solutions in terms
+        -- of that.
+        pop : ∀ {k : A} {ks : List A} → FiniteMap (k ∷ ks) → FiniteMap ks
+        pop (((_ ∷ fm') , push _ ufm') , refl) = ((fm' , ufm') , refl)
+
+        pop-≈ : ∀ {k : A} {ks : List A} (fm₁ fm₂ : FiniteMap (k ∷ ks)) →
+                _≈_ _ fm₁ fm₂ →  _≈_ _ (pop fm₁) (pop fm₂)
+        pop-≈ {k} {ks} fm₁ fm₂ (fm₁⊆fm₂ , fm₂⊆fm₁) =
+            (narrow fm₁⊆fm₂ , narrow fm₂⊆fm₁)
+            where
+                narrow₁ : ∀ {fm₁ fm₂ : FiniteMap (k ∷ ks)} →
+                         fm₁ ⊆ᵐ fm₂ → pop fm₁ ⊆ᵐ fm₂
+                narrow₁ {(_ ∷ _ , push _ _) , refl} kvs₁⊆kvs₂ k' v' k',v'∈fm'₁ =
+                    kvs₁⊆kvs₂ k' v' (there k',v'∈fm'₁)
+
+                narrow₂ : ∀ {fm₁ : FiniteMap ks} {fm₂ : FiniteMap (k ∷ ks)} →
+                          fm₁ ⊆ᵐ fm₂  → fm₁ ⊆ᵐ pop fm₂
+                narrow₂ {fm₁} {fm₂ = (_ ∷ fm'₂ , push k≢ks _) , kvs≡ks@refl} kvs₁⊆kvs₂ k' v' k',v'∈fm'₁
+                    with kvs₁⊆kvs₂ k' v' k',v'∈fm'₁
+                ...   | (v'' , (v'≈v'' , here refl)) rewrite sym (proj₂ fm₁) =
+                        ⊥-elim (All¬-¬Any k≢ks (forget k',v'∈fm'₁))
+                ...   | (v'' , (v'≈v'' , there k',v'∈fm'₂)) =
+                        (v'' , (v'≈v'' , k',v'∈fm'₂))
+
+                narrow : ∀ {fm₁ fm₂ : FiniteMap (k ∷ ks)} →
+                         fm₁ ⊆ᵐ fm₂ → pop fm₁ ⊆ᵐ pop fm₂
+                narrow {fm₁} {fm₂} x = narrow₂ {pop fm₁} (narrow₁ {fm₂ = fm₂} x)
+
+        k,v∈pop⇒k,v∈ : ∀ {k : A} {ks : List A} {k' : A} {v : B} (fm : FiniteMap (k ∷ ks)) →
+                       (k' , v) ∈ᵐ pop fm → (¬ k ≡ k' × ((k' , v) ∈ᵐ fm))
+        k,v∈pop⇒k,v∈ {k} {ks} {k'} {v} (m@((k , _) ∷ fm' , push k≢ks uks') , refl) k',v∈fm =
+            ( (λ { refl → All¬-¬Any k≢ks (forget k',v∈fm) })
+            , there k',v∈fm
+            )
+
+        k,v∈⇒k,v∈pop : ∀ {k : A} {ks : List A} {k' : A} {v : B} (fm : FiniteMap (k ∷ ks)) →
+                       ¬ k ≡ k' → (k' , v) ∈ᵐ fm → (k' , v) ∈ᵐ pop fm
+        k,v∈⇒k,v∈pop (m@(_ ∷ _ , push k≢ks _) , refl) k≢k' (here refl) = ⊥-elim (k≢k' refl)
+        k,v∈⇒k,v∈pop (m@(_ ∷ _ , push k≢ks _) , refl) k≢k' (there k,v'∈fm') = k,v'∈fm'
+
+        pop-⊔-distr : ∀ {k : A} {ks : List A} (fm₁ fm₂ : FiniteMap (k ∷ ks)) →
+                      _≈_ _ (pop (_⊔_ _ fm₁ fm₂)) ((_⊔_ _ (pop fm₁) (pop fm₂)))
+        pop-⊔-distr {k} {ks} fm₁@(m₁ , _) fm₂@(m₂ , _) =
+            (pfm₁fm₂⊆pfm₁pfm₂ , pfm₁pfm₂⊆pfm₁fm₂)
+            where
+                -- pfm₁fm₂⊆pfm₁pfm₂ = {!!}
+                pfm₁fm₂⊆pfm₁pfm₂ : pop (_⊔_ _ fm₁ fm₂) ⊆ᵐ (_⊔_ _ (pop fm₁) (pop fm₂))
+                pfm₁fm₂⊆pfm₁pfm₂ k' v' k',v'∈pfm₁fm₂
+                    with (k≢k' , k',v'∈fm₁fm₂) ← k,v∈pop⇒k,v∈ (_⊔_ _ fm₁ fm₂) k',v'∈pfm₁fm₂
+                    with ((v₁ , v₂) , (refl , (k,v₁∈fm₁ , k,v₂∈fm₂)))
+                         ← Provenance-union fm₁ fm₂ k',v'∈fm₁fm₂
+                    with k',v₁∈pfm₁ ← k,v∈⇒k,v∈pop fm₁ k≢k' k,v₁∈fm₁
+                    with k',v₂∈pfm₂ ← k,v∈⇒k,v∈pop fm₂ k≢k' k,v₂∈fm₂
+                    =
+                        ( v₁ ⊔₂ v₂
+                        , (IsLattice.≈-refl lB
+                          , ⊔-combines {m₁ = proj₁ (pop fm₁)}
+                                       {m₂ = proj₁ (pop fm₂)}
+                                       k',v₁∈pfm₁ k',v₂∈pfm₂
+                          )
+                        )
+
+                pfm₁pfm₂⊆pfm₁fm₂ : (_⊔_ _ (pop fm₁) (pop fm₂)) ⊆ᵐ pop (_⊔_ _ fm₁ fm₂)
+                pfm₁pfm₂⊆pfm₁fm₂ k' v' k',v'∈pfm₁pfm₂
+                    with ((v₁ , v₂) , (refl , (k,v₁∈pfm₁ , k,v₂∈pfm₂)))
+                         ← Provenance-union (pop fm₁) (pop fm₂) k',v'∈pfm₁pfm₂
+                    with (k≢k' , k',v₁∈fm₁) ← k,v∈pop⇒k,v∈ fm₁ k,v₁∈pfm₁
+                    with (_    , k',v₂∈fm₂) ← k,v∈pop⇒k,v∈ fm₂ k,v₂∈pfm₂
+                    =
+                        ( v₁ ⊔₂ v₂
+                        , ( IsLattice.≈-refl lB
+                          , k,v∈⇒k,v∈pop (_⊔_ _ fm₁ fm₂) k≢k'
+                                         (⊔-combines {m₁ = m₁} {m₂ = m₂}
+                                                     k',v₁∈fm₁ k',v₂∈fm₂)
+                          )
+                        )
+
+        from-rest : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
+                    proj₂ (from fm) ≡ from (pop fm)
+        from-rest (((_ ∷ fm') , push _ ufm') , refl) = refl
+
+    from-preserves-≈ : ∀ {ks : List A} → {fm₁ fm₂ : FiniteMap ks} →
+                       _≈_ _ fm₁ fm₂ → (_≈ⁱᵖ_ {length ks}) (from fm₁) (from fm₂)
+    from-preserves-≈ {[]} {_} {_} _ = IsEquivalence.≈-refl ≈ᵘ-equiv
+    from-preserves-≈ {k ∷ ks'} {fm₁@(m₁ , _)} {fm₂@(m₂ , _)} fm₁≈fm₂@(kvs₁⊆kvs₂ , kvs₂⊆kvs₁)
+        with first-key-in-map fm₁
+          | first-key-in-map fm₂
+          | from-first-value fm₁
+          | from-first-value fm₂
+    ...   | (v₁ , k,v₁∈fm₁) | (v₂ , k,v₂∈fm₂) | refl | refl
+            with kvs₁⊆kvs₂ _ _ k,v₁∈fm₁
+    ...       | (v₁' , (v₁≈v₁' , k,v₁'∈fm₂))
+                rewrite Map-functional {m = m₂} k,v₂∈fm₂ k,v₁'∈fm₂
+                rewrite from-rest fm₁ rewrite from-rest fm₂
+                =
+                    ( v₁≈v₁'
+                    , from-preserves-≈ {ks'} {pop fm₁} {pop fm₂}
+                                       (pop-≈ fm₁ fm₂ fm₁≈fm₂)
+                    )
+
+    to-preserves-≈ : ∀ {ks : List A} (uks : Unique ks) {ip₁ ip₂ : IterProd (length ks)} →
+                     _≈ⁱᵖ_ {length ks} ip₁ ip₂ → _≈_ _ (to uks ip₁) (to uks ip₂)
+    to-preserves-≈ {[]} empty {tt} {tt} _ = ((λ k v ()), (λ k v ()))
+    to-preserves-≈ {k ∷ ks'} uks@(push k≢ks' uks') {ip₁@(v₁ , rest₁)} {ip₂@(v₂ , rest₂)} (v₁≈v₂ , rest₁≈rest₂) = (fm₁⊆fm₂ , fm₂⊆fm₁)
+        where
+            inductive-step : ∀ {v₁ v₂ : B} {rest₁ rest₂ : IterProd (length ks')} →
+                               v₁ ≈₂ v₂ → _≈ⁱᵖ_ {length ks'} rest₁ rest₂ →
+                               to uks (v₁ , rest₁) ⊆ᵐ to uks (v₂ , rest₂)
+            inductive-step {v₁} {v₂} {rest₁} {rest₂} v₁≈v₂ rest₁≈rest₂ k v k,v∈kvs₁
+                with ((fm'₁ , ufm'₁) , fm'₁≡ks') ← to uks' rest₁ in p₁
+                with ((fm'₂ , ufm'₂) , fm'₂≡ks') ← to uks' rest₂ in p₂
+                with k,v∈kvs₁
+            ...   | here refl = (v₂ , (v₁≈v₂ , here refl))
+            ...   | there k,v∈fm'₁ with refl ← p₁ with refl ← p₂ =
+                    let
+                        (fm'₁⊆fm'₂ , _) = to-preserves-≈ uks' {rest₁} {rest₂}
+                                                         rest₁≈rest₂
+                        (v' , (v≈v' , k,v'∈kvs₁)) = fm'₁⊆fm'₂ k v k,v∈fm'₁
+                    in
+                        (v' , (v≈v' , there k,v'∈kvs₁))
+
+            fm₁⊆fm₂ : to uks ip₁ ⊆ᵐ to uks ip₂
+            fm₁⊆fm₂ = inductive-step v₁≈v₂ rest₁≈rest₂
+
+            fm₂⊆fm₁ : to uks ip₂ ⊆ᵐ to uks ip₁
+            fm₂⊆fm₁ = inductive-step (≈₂-sym v₁≈v₂)
+                                     (IP.≈-sym {length ks'} rest₁≈rest₂)
+
+    from-⊔-distr : ∀ {ks : List A} → (fm₁ fm₂ : FiniteMap ks) →
+                  _≈ⁱᵖ_ {length ks} (from (_⊔_ _ fm₁ fm₂))
+                                    (_⊔ⁱᵖ_ {ks} (from fm₁) (from fm₂))
+    from-⊔-distr {[]} fm₁ fm₂ = IsEquivalence.≈-refl ≈ᵘ-equiv
+    from-⊔-distr {k ∷ ks} fm₁@(m₁ , _) fm₂@(m₂ , _)
+        with first-key-in-map (_⊔_ _ fm₁ fm₂)
+          | first-key-in-map fm₁
+          | first-key-in-map fm₂
+          | from-first-value (_⊔_ _ fm₁ fm₂)
+          | from-first-value fm₁ | from-first-value fm₂
+    ...   | (v , k,v∈fm₁fm₂) | (v₁ , k,v₁∈fm₁) | (v₂ , k,v₂∈fm₂) | refl | refl | refl
+            with Expr-Provenance k ((` m₁) ∪ (` m₂)) (forget k,v∈fm₁fm₂)
+    ...       | (_ , (in₁ _ k∉km₂ , _)) = ⊥-elim (k∉km₂ (forget k,v₂∈fm₂))
+    ...       | (_ , (in₂ k∉km₁ _ , _)) = ⊥-elim (k∉km₁ (forget k,v₁∈fm₁))
+    ...       | (v₁⊔v₂ , (bothᵘ {v₁'} {v₂'} (single k,v₁'∈m₁) (single k,v₂'∈m₂) , k,v₁⊔v₂∈m₁m₂))
+                rewrite Map-functional {m = m₁} k,v₁∈fm₁ k,v₁'∈m₁
+                rewrite Map-functional {m = m₂} k,v₂∈fm₂ k,v₂'∈m₂
+                rewrite Map-functional {m = proj₁ (_⊔_ _ fm₁ fm₂)} k,v∈fm₁fm₂ k,v₁⊔v₂∈m₁m₂
+                rewrite from-rest (_⊔_ _ fm₁ fm₂) rewrite from-rest fm₁ rewrite from-rest fm₂
+                = ( IsLattice.≈-refl lB
+                  , IsEquivalence.≈-trans
+                        (IP.≈-equiv {length ks})
+                        (from-preserves-≈ {_} {pop (_⊔_ _ fm₁ fm₂)}
+                                              {_⊔_ _ (pop fm₁) (pop fm₂)}
+                                              (pop-⊔-distr fm₁ fm₂))
+                        ((from-⊔-distr (pop fm₁) (pop fm₂)))
+                  )
+
+
+    to-⊔-distr : ∀ {ks : List A} (uks : Unique ks) → (ip₁ ip₂ : IterProd (length ks)) →
+                 _≈_ _ (to uks (_⊔ⁱᵖ_ {ks} ip₁ ip₂)) ((_⊔_ _ (to uks ip₁) (to uks ip₂)))
+    to-⊔-distr {[]} empty tt tt = ((λ k v ()), (λ k v ()))
+    to-⊔-distr {ks@(k ∷ ks')} uks@(push k≢ks' uks') ip₁@(v₁ , rest₁) ip₂@(v₂ , rest₂) = (fm⊆fm₁fm₂ , fm₁fm₂⊆fm)
+        where
+            fm₁ = to uks ip₁
+            fm₁' = to uks' rest₁
+            fm₂ = to uks ip₂
+            fm₂' = to uks' rest₂
+            fm = to uks (_⊔ⁱᵖ_ {k ∷ ks'} ip₁ ip₂)
+
+            fm⊆fm₁fm₂ : fm ⊆ᵐ (_⊔_ _ fm₁ fm₂)
+            fm⊆fm₁fm₂ k v (here refl) =
+                (v₁ ⊔₂ v₂
+                , (IsLattice.≈-refl lB
+                  , ⊔-combines {k} {v₁} {v₂} {proj₁ fm₁} {proj₁ fm₂}
+                               (here refl) (here refl)
+                  )
+                )
+            fm⊆fm₁fm₂ k' v (there k',v∈fm')
+                with (fm'⊆fm'₁fm'₂ , _) ← to-⊔-distr uks' rest₁ rest₂
+                with (v' , (v₁⊔v₂≈v' , k',v'∈fm'₁fm'₂))
+                     ← fm'⊆fm'₁fm'₂ k' v k',v∈fm'
+                with (_ , (refl , (v₁∈fm'₁ , v₂∈fm'₂)))
+                     ← Provenance-union fm₁' fm₂' k',v'∈fm'₁fm'₂ =
+                ( v'
+                , ( v₁⊔v₂≈v'
+                  , ⊔-combines {m₁ = proj₁ fm₁} {m₂ = proj₁ fm₂}
+                               (there v₁∈fm'₁) (there v₂∈fm'₂)
+                  )
+                )
+
+            fm₁fm₂⊆fm : (_⊔_ _ fm₁ fm₂) ⊆ᵐ fm
+            fm₁fm₂⊆fm k' v k',v∈fm₁fm₂
+                with (_ , fm'₁fm'₂⊆fm')
+                     ← to-⊔-distr uks' rest₁ rest₂
+                with (_ , (refl , (v₁∈fm₁ , v₂∈fm₂)))
+                     ← Provenance-union fm₁ fm₂ k',v∈fm₁fm₂
+                with v₁∈fm₁ | v₂∈fm₂
+            ...   | here refl | here refl =
+                    (v , (IsLattice.≈-refl lB , here refl))
+            ...   | here refl | there k',v₂∈fm₂' =
+                    ⊥-elim (All¬-¬Any k≢ks' (subst (k' ∈ˡ_) (proj₂ fm₂')
+                                                   (forget k',v₂∈fm₂')))
+            ...   | there k',v₁∈fm₁' | here refl =
+                    ⊥-elim (All¬-¬Any k≢ks' (subst (k' ∈ˡ_) (proj₂ fm₁')
+                                                   (forget k',v₁∈fm₁')))
+            ...   | there k',v₁∈fm₁' | there k',v₂∈fm₂' =
+                        let
+                            k',v₁v₂∈fm₁'fm₂' =
+                                ⊔-combines {m₁ = proj₁ fm₁'} {m₂ = proj₁ fm₂'}
+                                           k',v₁∈fm₁' k',v₂∈fm₂'
+                            (v' , (v₁⊔v₂≈v' , v'∈fm')) =
+                                fm'₁fm'₂⊆fm' _ _ k',v₁v₂∈fm₁'fm₂'
+                        in
+                            (v' , (v₁⊔v₂≈v' , there v'∈fm'))
+
+    module FixedHeight {ks : List A} {{≈₂-Decidable : IsDecidable _≈₂_}} {h₂ : ℕ} {{fhB : FixedHeight₂ h₂}} (uks : Unique ks) where
+        import Isomorphism
+        open Isomorphism.TransportFiniteHeight
+            (IP.isFiniteHeightLattice {k = length ks} {{fhB = fixedHeightᵘ}}) (isLattice ks)
+            {f = to uks} {g = from {ks}}
+            (to-preserves-≈ uks) (from-preserves-≈ {ks})
+            (to-⊔-distr uks) (from-⊔-distr {ks})
+            (from-to-inverseʳ uks) (from-to-inverseˡ uks)
+            using (isFiniteHeightLattice; finiteHeightLattice; fixedHeight) public
+
+        -- Helpful lemma: all entries of the 'bottom' map are assigned to bottom.
+
+        open Height (IsFiniteHeightLattice.fixedHeight isFiniteHeightLattice) using (⊥)
+
+        ⊥-contains-bottoms : ∀ {k : A} {v : B} → (k , v) ∈ᵐ ⊥ → v ≡ (Height.⊥ fhB)
+        ⊥-contains-bottoms {k} {v} k,v∈⊥
+            rewrite IP.⊥-built {length ks} {{fhB = fixedHeightᵘ}} =
+            to-build uks k v k,v∈⊥
+
+open WithKeys ks public
+module FixedHeight = IterProdIsomorphism.FixedHeight

Lattice/FiniteValueMap.agda

@@ -1,409 +0,0 @@
--- Because iterated products currently require both A and B to be of the same
--- universe, and the FiniteMap is written in a universe-polymorphic way,
--- specialize the FiniteMap module with Set-typed types only.
-
-open import Lattice
-open import Equivalence
-open import Relation.Binary.PropositionalEquality as Eq
-    using (_≡_; refl; sym; trans; cong; subst)
-open import Relation.Binary.Definitions using (Decidable)
-open import Agda.Primitive using (Level) renaming (_⊔_ to _⊔ℓ_)
-open import Function.Definitions using (Inverseˡ; Inverseʳ)
-
-module Lattice.FiniteValueMap {A : Set} {B : Set}
-    {_≈₂_ : B → B → Set}
-    {_⊔₂_ : B → B → B} {_⊓₂_ : B → B → B}
-    (≡-dec-A : Decidable (_≡_ {_} {A}))
-    (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
-
-open import Data.List using (List; length; []; _∷_; map)
-open import Data.List.Membership.Propositional using () renaming (_∈_ to _∈ˡ_)
-open import Data.Nat using (ℕ)
-open import Data.Product using (Σ; proj₁; proj₂; _×_)
-open import Data.Empty using (⊥-elim)
-open import Utils using (Unique; push; empty; All¬-¬Any)
-open import Data.Product using (_,_)
-open import Data.List.Properties using (∷-injectiveʳ)
-open import Data.List.Relation.Unary.All using (All)
-open import Data.List.Relation.Unary.Any using (Any; here; there)
-open import Relation.Nullary using (¬_)
-open import Isomorphism using (IsInverseˡ; IsInverseʳ)
-
-open import Lattice.Map ≡-dec-A lB
-    using
-        ( subset-impl
-        ; locate
-        ; Map-functional
-        ; Expr-Provenance
-        ; Expr-Provenance-≡
-        ; _∩_; _∪_; `_
-        ; in₁; in₂; bothᵘ; single
-        ; ⊔-combines
-        )
-open import Lattice.FiniteMap ≡-dec-A lB public
-
-module IterProdIsomorphism where
-    open import Data.Unit using (⊤; tt)
-    open import Lattice.Unit using ()
-        renaming
-            ( _≈_ to _≈ᵘ_
-            ; _⊔_ to _⊔ᵘ_
-            ; _⊓_ to _⊓ᵘ_
-            ; ≈-dec to ≈ᵘ-dec
-            ; isLattice to isLatticeᵘ
-            ; ≈-equiv to ≈ᵘ-equiv
-            ; fixedHeight to fixedHeightᵘ
-            )
-    open import Lattice.IterProd _≈₂_ _≈ᵘ_ _⊔₂_ _⊔ᵘ_ _⊓₂_ _⊓ᵘ_ lB isLatticeᵘ
-        as IP
-        using (IterProd)
-    open IsLattice lB using ()
-        renaming
-            ( ≈-trans to ≈₂-trans
-            ; ≈-sym to ≈₂-sym
-            ; FixedHeight to FixedHeight₂
-            )
-
-    from : ∀ {ks : List A} → FiniteMap ks → IterProd (length ks)
-    from {[]} (([] , _) , _) = tt
-    from {k ∷ ks'} (((k' , v) ∷ fm' , push _ uks') , refl) =
-        (v , from ((fm' , uks'), refl))
-
-    to : ∀ {ks : List A} → Unique ks → IterProd (length ks) → FiniteMap ks
-    to {[]} _ ⊤ = (([] , empty) , refl)
-    to {k ∷ ks'} (push k≢ks' uks') (v , rest) =
-        let
-            ((fm' , ufm') , fm'≡ks') = to uks' rest
-
-            -- This would be easier if we pattern matched on the equiality proof
-            -- to get refl, but that makes it harder to reason about 'to' when
-            -- the arguments are not known to be refl.
-            k≢fm' = subst (λ ks → All (λ k' → ¬ k ≡ k') ks) (sym fm'≡ks') k≢ks'
-            kvs≡ks = cong (k ∷_) fm'≡ks'
-        in
-            (((k , v) ∷ fm' , push k≢fm' ufm') , kvs≡ks)
-
-
-    private
-        _≈ᵐ_ : ∀ {ks : List A} → FiniteMap ks → FiniteMap ks → Set
-        _≈ᵐ_ {ks} = _≈_ ks
-
-        _⊔ᵐ_ : ∀ {ks : List A} → FiniteMap ks → FiniteMap ks → FiniteMap ks
-        _⊔ᵐ_ {ks} = _⊔_ ks
-
-        _⊆ᵐ_ : ∀ {ks₁ ks₂ : List A} → FiniteMap ks₁ → FiniteMap ks₂ → Set
-        _⊆ᵐ_ fm₁ fm₂ = subset-impl (proj₁ (proj₁ fm₁)) (proj₁ (proj₁ fm₂))
-
-        _≈ⁱᵖ_ : ∀ {n : ℕ} → IterProd n → IterProd n → Set
-        _≈ⁱᵖ_ {n} = IP._≈_ n
-
-        _⊔ⁱᵖ_ : ∀ {ks : List A} →
-                IterProd (length ks) → IterProd (length ks) → IterProd (length ks)
-        _⊔ⁱᵖ_ {ks} = IP._⊔_ (length ks)
-
-        _∈ᵐ_ : ∀ {ks : List A} → A × B → FiniteMap ks → Set
-        _∈ᵐ_ {ks} = _∈_ ks
-
-    -- The left inverse is: from (to x) = x
-    from-to-inverseˡ : ∀ {ks : List A} (uks : Unique ks) →
-                      IsInverseˡ (_≈ᵐ_ {ks}) (_≈ⁱᵖ_ {length ks})
-                                 (from {ks}) (to {ks} uks)
-    from-to-inverseˡ {[]} _ _ = IsEquivalence.≈-refl (IP.≈-equiv 0)
-    from-to-inverseˡ {k ∷ ks'} (push k≢ks' uks') (v , rest)
-        with ((fm' , ufm') , refl) ← to uks' rest in p rewrite sym p =
-            (IsLattice.≈-refl lB , from-to-inverseˡ {ks'} uks' rest)
-            -- the rewrite here is needed because the IH is in terms of `to uks' rest`,
-            -- but we end up with the 'unpacked' form (fm', ...). So, put it back
-            -- in the 'packed' form after we've performed enough inspection
-            -- to know we take the cons branch of `to`.
-
-    -- The map has its own uniqueness proof, but the call to 'to' needs a standalone
-    -- uniqueness proof too. Work with both proofs as needed to thread things through.
-    --
-    -- The right inverse is: to (from x) = x
-    from-to-inverseʳ : ∀ {ks : List A} (uks : Unique ks) →
-                       IsInverseʳ (_≈ᵐ_ {ks}) (_≈ⁱᵖ_ {length ks})
-                                  (from {ks}) (to {ks} uks)
-    from-to-inverseʳ {[]} _ (([] , empty) , kvs≡ks) rewrite kvs≡ks =
-        ( (λ k v ())
-        , (λ k v ())
-        )
-    from-to-inverseʳ {k ∷ ks'} uks@(push _ uks'₁) fm₁@(((k , v) ∷ fm'₁ , push _ uks'₂) , refl)
-        with to uks'₁ (from ((fm'₁ , uks'₂) , refl))
-          | from-to-inverseʳ {ks'} uks'₁ ((fm'₁ , uks'₂) , refl)
-    ...   | ((fm'₂ , ufm'₂) , _)
-          | (fm'₂⊆fm'₁ , fm'₁⊆fm'₂) = (m₂⊆m₁ , m₁⊆m₂)
-                where
-                    kvs₁ = (k , v) ∷ fm'₁
-                    kvs₂ = (k , v) ∷ fm'₂
-
-                    m₁⊆m₂ : subset-impl kvs₁ kvs₂
-                    m₁⊆m₂ k' v' (here refl) =
-                        (v' , (IsLattice.≈-refl lB , here refl))
-                    m₁⊆m₂ k' v' (there k',v'∈fm'₁) =
-                        let (v'' , (v'≈v'' , k',v''∈fm'₂)) =
-                                fm'₁⊆fm'₂ k' v' k',v'∈fm'₁
-                        in (v'' , (v'≈v'' , there k',v''∈fm'₂))
-
-                    m₂⊆m₁ : subset-impl kvs₂ kvs₁
-                    m₂⊆m₁ k' v' (here refl) =
-                        (v' , (IsLattice.≈-refl lB , here refl))
-                    m₂⊆m₁ k' v' (there k',v'∈fm'₂) =
-                        let (v'' , (v'≈v'' , k',v''∈fm'₁)) =
-                                fm'₂⊆fm'₁ k' v' k',v'∈fm'₂
-                        in (v'' , (v'≈v'' , there k',v''∈fm'₁))
-
-    private
-        first-key-in-map : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
-                           Σ B (λ v → (k , v) ∈ᵐ fm)
-        first-key-in-map (((k , v) ∷ _ , _) , refl) = (v , here refl)
-
-        from-first-value : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
-                           proj₁ (from fm) ≡ proj₁ (first-key-in-map fm)
-        from-first-value {k} {ks} (((k , v) ∷ _ , push _ _) , refl) = refl
-
-        -- We need pop because reasoning about two distinct 'refl' pattern
-        -- matches is giving us unification errors. So, stash the 'refl' pattern
-        -- matching into a helper functions, and write solutions in terms
-        -- of that.
-        pop : ∀ {k : A} {ks : List A} → FiniteMap (k ∷ ks) → FiniteMap ks
-        pop (((_ ∷ fm') , push _ ufm') , refl) = ((fm' , ufm') , refl)
-
-        pop-≈ : ∀ {k : A} {ks : List A} (fm₁ fm₂ : FiniteMap (k ∷ ks)) →
-                fm₁ ≈ᵐ fm₂ → pop fm₁ ≈ᵐ pop fm₂
-        pop-≈ {k} {ks} fm₁ fm₂ (fm₁⊆fm₂ , fm₂⊆fm₁) =
-            (narrow fm₁⊆fm₂ , narrow fm₂⊆fm₁)
-            where
-                narrow₁ : ∀ {fm₁ fm₂ : FiniteMap (k ∷ ks)} →
-                         fm₁ ⊆ᵐ fm₂ → pop fm₁ ⊆ᵐ fm₂
-                narrow₁ {(_ ∷ _ , push _ _) , refl} kvs₁⊆kvs₂ k' v' k',v'∈fm'₁ =
-                    kvs₁⊆kvs₂ k' v' (there k',v'∈fm'₁)
-
-                narrow₂ : ∀ {fm₁ : FiniteMap ks} {fm₂ : FiniteMap (k ∷ ks)} →
-                          fm₁ ⊆ᵐ fm₂  → fm₁ ⊆ᵐ pop fm₂
-                narrow₂ {fm₁} {fm₂ = (_ ∷ fm'₂ , push k≢ks _) , kvs≡ks@refl} kvs₁⊆kvs₂ k' v' k',v'∈fm'₁
-                    with kvs₁⊆kvs₂ k' v' k',v'∈fm'₁
-                ...   | (v'' , (v'≈v'' , here refl)) rewrite sym (proj₂ fm₁) =
-                        ⊥-elim (All¬-¬Any k≢ks (forget k',v'∈fm'₁))
-                ...   | (v'' , (v'≈v'' , there k',v'∈fm'₂)) =
-                        (v'' , (v'≈v'' , k',v'∈fm'₂))
-
-                narrow : ∀ {fm₁ fm₂ : FiniteMap (k ∷ ks)} →
-                         fm₁ ⊆ᵐ fm₂ → pop fm₁ ⊆ᵐ pop fm₂
-                narrow {fm₁} {fm₂} x = narrow₂ {pop fm₁} (narrow₁ {fm₂ = fm₂} x)
-
-        k,v∈pop⇒k,v∈ : ∀ {k : A} {ks : List A} {k' : A} {v : B} (fm : FiniteMap (k ∷ ks)) →
-                       (k' , v) ∈ᵐ pop fm → (¬ k ≡ k' × ((k' , v) ∈ᵐ fm))
-        k,v∈pop⇒k,v∈ {k} {ks} {k'} {v} (m@((k , _) ∷ fm' , push k≢ks uks') , refl) k',v∈fm =
-            ( (λ { refl → All¬-¬Any k≢ks (forget k',v∈fm) })
-            , there k',v∈fm
-            )
-
-        k,v∈⇒k,v∈pop : ∀ {k : A} {ks : List A} {k' : A} {v : B} (fm : FiniteMap (k ∷ ks)) →
-                       ¬ k ≡ k' → (k' , v) ∈ᵐ fm → (k' , v) ∈ᵐ pop fm
-        k,v∈⇒k,v∈pop (m@(_ ∷ _ , push k≢ks _) , refl) k≢k' (here refl) = ⊥-elim (k≢k' refl)
-        k,v∈⇒k,v∈pop (m@(_ ∷ _ , push k≢ks _) , refl) k≢k' (there k,v'∈fm') = k,v'∈fm'
-
-        FromBothMaps : ∀ (k : A) (v : B) {ks : List A} (fm₁ fm₂ : FiniteMap ks) → Set
-        FromBothMaps k v fm₁ fm₂ =
-            Σ (B × B)
-              (λ (v₁ , v₂) → ( (v ≡ v₁ ⊔₂ v₂) × ((k , v₁) ∈ᵐ fm₁ × (k , v₂) ∈ᵐ fm₂)))
-
-        Provenance-union : ∀ {ks : List A} (fm₁ fm₂ : FiniteMap ks) {k : A} {v : B} →
-                           (k , v) ∈ᵐ (fm₁ ⊔ᵐ fm₂) → FromBothMaps k v fm₁ fm₂
-        Provenance-union fm₁@(m₁ , ks₁≡ks) fm₂@(m₂ , ks₂≡ks) {k} {v} k,v∈fm₁fm₂
-            with Expr-Provenance-≡ ((` m₁) ∪ (` m₂)) k,v∈fm₁fm₂
-        ...   | in₁ (single k,v∈m₁) k∉km₂
-                with k∈km₁ ← (forget k,v∈m₁)
-                rewrite trans ks₁≡ks (sym ks₂≡ks) =
-                ⊥-elim (k∉km₂ k∈km₁)
-        ...   | in₂ k∉km₁ (single k,v∈m₂)
-                with k∈km₂ ← (forget k,v∈m₂)
-                rewrite trans ks₁≡ks (sym ks₂≡ks) =
-                ⊥-elim (k∉km₁ k∈km₂)
-        ...   | bothᵘ {v₁} {v₂} (single k,v₁∈m₁) (single k,v₂∈m₂) =
-                ((v₁ , v₂) , (refl , (k,v₁∈m₁ , k,v₂∈m₂)))
-
-        pop-⊔-distr : ∀ {k : A} {ks : List A} (fm₁ fm₂ : FiniteMap (k ∷ ks)) →
-                      pop (fm₁ ⊔ᵐ fm₂) ≈ᵐ (pop fm₁ ⊔ᵐ pop fm₂)
-        pop-⊔-distr {k} {ks} fm₁@(m₁ , _) fm₂@(m₂ , _) =
-            (pfm₁fm₂⊆pfm₁pfm₂ , pfm₁pfm₂⊆pfm₁fm₂)
-            where
-                -- pfm₁fm₂⊆pfm₁pfm₂ = {!!}
-                pfm₁fm₂⊆pfm₁pfm₂ : pop (fm₁ ⊔ᵐ fm₂) ⊆ᵐ (pop fm₁ ⊔ᵐ pop fm₂)
-                pfm₁fm₂⊆pfm₁pfm₂ k' v' k',v'∈pfm₁fm₂
-                    with (k≢k' , k',v'∈fm₁fm₂) ← k,v∈pop⇒k,v∈ (fm₁ ⊔ᵐ fm₂) k',v'∈pfm₁fm₂
-                    with ((v₁ , v₂) , (refl , (k,v₁∈fm₁ , k,v₂∈fm₂)))
-                         ← Provenance-union fm₁ fm₂ k',v'∈fm₁fm₂
-                    with k',v₁∈pfm₁ ← k,v∈⇒k,v∈pop fm₁ k≢k' k,v₁∈fm₁
-                    with k',v₂∈pfm₂ ← k,v∈⇒k,v∈pop fm₂ k≢k' k,v₂∈fm₂
-                    =
-                        ( v₁ ⊔₂ v₂
-                        , (IsLattice.≈-refl lB
-                          , ⊔-combines {m₁ = proj₁ (pop fm₁)}
-                                       {m₂ = proj₁ (pop fm₂)}
-                                       k',v₁∈pfm₁ k',v₂∈pfm₂
-                          )
-                        )
-
-                pfm₁pfm₂⊆pfm₁fm₂ : (pop fm₁ ⊔ᵐ pop fm₂) ⊆ᵐ pop (fm₁ ⊔ᵐ fm₂)
-                pfm₁pfm₂⊆pfm₁fm₂ k' v' k',v'∈pfm₁pfm₂
-                    with ((v₁ , v₂) , (refl , (k,v₁∈pfm₁ , k,v₂∈pfm₂)))
-                         ← Provenance-union (pop fm₁) (pop fm₂) k',v'∈pfm₁pfm₂
-                    with (k≢k' , k',v₁∈fm₁) ← k,v∈pop⇒k,v∈ fm₁ k,v₁∈pfm₁
-                    with (_    , k',v₂∈fm₂) ← k,v∈pop⇒k,v∈ fm₂ k,v₂∈pfm₂
-                    =
-                        ( v₁ ⊔₂ v₂
-                        , ( IsLattice.≈-refl lB
-                          , k,v∈⇒k,v∈pop (fm₁ ⊔ᵐ fm₂) k≢k'
-                                         (⊔-combines {m₁ = m₁} {m₂ = m₂}
-                                                     k',v₁∈fm₁ k',v₂∈fm₂)
-                          )
-                        )
-
-        from-rest : ∀ {k : A} {ks : List A} (fm : FiniteMap (k ∷ ks)) →
-                    proj₂ (from fm) ≡ from (pop fm)
-        from-rest (((_ ∷ fm') , push _ ufm') , refl) = refl
-
-    from-preserves-≈ : ∀ {ks : List A} → {fm₁ fm₂ : FiniteMap ks} →
-                       fm₁ ≈ᵐ fm₂ → (_≈ⁱᵖ_ {length ks}) (from fm₁) (from fm₂)
-    from-preserves-≈ {[]} {_} {_} _ = IsEquivalence.≈-refl ≈ᵘ-equiv
-    from-preserves-≈ {k ∷ ks'} {fm₁@(m₁ , _)} {fm₂@(m₂ , _)} fm₁≈fm₂@(kvs₁⊆kvs₂ , kvs₂⊆kvs₁)
-        with first-key-in-map fm₁
-          | first-key-in-map fm₂
-          | from-first-value fm₁
-          | from-first-value fm₂
-    ...   | (v₁ , k,v₁∈fm₁) | (v₂ , k,v₂∈fm₂) | refl | refl
-            with kvs₁⊆kvs₂ _ _ k,v₁∈fm₁
-    ...       | (v₁' , (v₁≈v₁' , k,v₁'∈fm₂))
-                rewrite Map-functional {m = m₂} k,v₂∈fm₂ k,v₁'∈fm₂
-                rewrite from-rest fm₁ rewrite from-rest fm₂
-                =
-                    ( v₁≈v₁'
-                    , from-preserves-≈ {ks'} {pop fm₁} {pop fm₂}
-                                       (pop-≈ fm₁ fm₂ fm₁≈fm₂)
-                    )
-
-    to-preserves-≈ : ∀ {ks : List A} (uks : Unique ks) {ip₁ ip₂ : IterProd (length ks)} →
-                     _≈ⁱᵖ_ {length ks} ip₁ ip₂ → to uks ip₁ ≈ᵐ to uks ip₂
-    to-preserves-≈ {[]} empty {tt} {tt} _ = ((λ k v ()), (λ k v ()))
-    to-preserves-≈ {k ∷ ks'} uks@(push k≢ks' uks') {ip₁@(v₁ , rest₁)} {ip₂@(v₂ , rest₂)} (v₁≈v₂ , rest₁≈rest₂) = (fm₁⊆fm₂ , fm₂⊆fm₁)
-        where
-            inductive-step : ∀ {v₁ v₂ : B} {rest₁ rest₂ : IterProd (length ks')} →
-                               v₁ ≈₂ v₂ → _≈ⁱᵖ_ {length ks'} rest₁ rest₂ →
-                               to uks (v₁ , rest₁) ⊆ᵐ to uks (v₂ , rest₂)
-            inductive-step {v₁} {v₂} {rest₁} {rest₂} v₁≈v₂ rest₁≈rest₂ k v k,v∈kvs₁
-                with ((fm'₁ , ufm'₁) , fm'₁≡ks') ← to uks' rest₁ in p₁
-                with ((fm'₂ , ufm'₂) , fm'₂≡ks') ← to uks' rest₂ in p₂
-                with k,v∈kvs₁
-            ...   | here refl = (v₂ , (v₁≈v₂ , here refl))
-            ...   | there k,v∈fm'₁ with refl ← p₁ with refl ← p₂ =
-                    let
-                        (fm'₁⊆fm'₂ , _) = to-preserves-≈ uks' {rest₁} {rest₂}
-                                                         rest₁≈rest₂
-                        (v' , (v≈v' , k,v'∈kvs₁)) = fm'₁⊆fm'₂ k v k,v∈fm'₁
-                    in
-                        (v' , (v≈v' , there k,v'∈kvs₁))
-
-            fm₁⊆fm₂ : to uks ip₁ ⊆ᵐ to uks ip₂
-            fm₁⊆fm₂ = inductive-step v₁≈v₂ rest₁≈rest₂
-
-            fm₂⊆fm₁ : to uks ip₂ ⊆ᵐ to uks ip₁
-            fm₂⊆fm₁ = inductive-step (≈₂-sym v₁≈v₂)
-                                     (IP.≈-sym (length ks') rest₁≈rest₂)
-
-    from-⊔-distr : ∀ {ks : List A} → (fm₁ fm₂ : FiniteMap ks) →
-                  _≈ⁱᵖ_ {length ks} (from (fm₁ ⊔ᵐ fm₂))
-                                    (_⊔ⁱᵖ_ {ks} (from fm₁) (from fm₂))
-    from-⊔-distr {[]} fm₁ fm₂ = IsEquivalence.≈-refl ≈ᵘ-equiv
-    from-⊔-distr {k ∷ ks} fm₁@(m₁ , _) fm₂@(m₂ , _)
-        with first-key-in-map (fm₁ ⊔ᵐ fm₂)
-          | first-key-in-map fm₁
-          | first-key-in-map fm₂
-          | from-first-value (fm₁ ⊔ᵐ fm₂)
-          | from-first-value fm₁ | from-first-value fm₂
-    ...   | (v , k,v∈fm₁fm₂) | (v₁ , k,v₁∈fm₁) | (v₂ , k,v₂∈fm₂) | refl | refl | refl
-            with Expr-Provenance k ((` m₁) ∪ (` m₂)) (forget k,v∈fm₁fm₂)
-    ...       | (_ , (in₁ _ k∉km₂ , _)) = ⊥-elim (k∉km₂ (forget k,v₂∈fm₂))
-    ...       | (_ , (in₂ k∉km₁ _ , _)) = ⊥-elim (k∉km₁ (forget k,v₁∈fm₁))
-    ...       | (v₁⊔v₂ , (bothᵘ {v₁'} {v₂'} (single k,v₁'∈m₁) (single k,v₂'∈m₂) , k,v₁⊔v₂∈m₁m₂))
-                rewrite Map-functional {m = m₁} k,v₁∈fm₁ k,v₁'∈m₁
-                rewrite Map-functional {m = m₂} k,v₂∈fm₂ k,v₂'∈m₂
-                rewrite Map-functional {m = proj₁ (fm₁ ⊔ᵐ fm₂)} k,v∈fm₁fm₂ k,v₁⊔v₂∈m₁m₂
-                rewrite from-rest (fm₁ ⊔ᵐ fm₂) rewrite from-rest fm₁ rewrite from-rest fm₂
-                = ( IsLattice.≈-refl lB
-                  , IsEquivalence.≈-trans
-                        (IP.≈-equiv (length ks))
-                        (from-preserves-≈ {_} {pop (fm₁ ⊔ᵐ fm₂)}
-                                              {pop fm₁ ⊔ᵐ pop fm₂}
-                                              (pop-⊔-distr fm₁ fm₂))
-                        ((from-⊔-distr (pop fm₁) (pop fm₂)))
-                  )
-
-
-    to-⊔-distr : ∀ {ks : List A} (uks : Unique ks) → (ip₁ ip₂ : IterProd (length ks)) →
-                 to uks (_⊔ⁱᵖ_ {ks} ip₁ ip₂) ≈ᵐ (to uks ip₁ ⊔ᵐ to uks ip₂)
-    to-⊔-distr {[]} empty tt tt = ((λ k v ()), (λ k v ()))
-    to-⊔-distr {ks@(k ∷ ks')} uks@(push k≢ks' uks') ip₁@(v₁ , rest₁) ip₂@(v₂ , rest₂) = (fm⊆fm₁fm₂ , fm₁fm₂⊆fm)
-        where
-            fm₁ = to uks ip₁
-            fm₁' = to uks' rest₁
-            fm₂ = to uks ip₂
-            fm₂' = to uks' rest₂
-            fm = to uks (_⊔ⁱᵖ_ {k ∷ ks'} ip₁ ip₂)
-
-            fm⊆fm₁fm₂ : fm ⊆ᵐ (fm₁ ⊔ᵐ fm₂)
-            fm⊆fm₁fm₂ k v (here refl) =
-                (v₁ ⊔₂ v₂
-                , (IsLattice.≈-refl lB
-                  , ⊔-combines {k} {v₁} {v₂} {proj₁ fm₁} {proj₁ fm₂}
-                               (here refl) (here refl)
-                  )
-                )
-            fm⊆fm₁fm₂ k' v (there k',v∈fm')
-                with (fm'⊆fm'₁fm'₂ , _) ← to-⊔-distr uks' rest₁ rest₂
-                with (v' , (v₁⊔v₂≈v' , k',v'∈fm'₁fm'₂))
-                     ← fm'⊆fm'₁fm'₂ k' v k',v∈fm'
-                with (_ , (refl , (v₁∈fm'₁ , v₂∈fm'₂)))
-                     ← Provenance-union fm₁' fm₂' k',v'∈fm'₁fm'₂ =
-                ( v'
-                , ( v₁⊔v₂≈v'
-                  , ⊔-combines {m₁ = proj₁ fm₁} {m₂ = proj₁ fm₂}
-                               (there v₁∈fm'₁) (there v₂∈fm'₂)
-                  )
-                )
-
-            fm₁fm₂⊆fm : (fm₁ ⊔ᵐ fm₂) ⊆ᵐ fm
-            fm₁fm₂⊆fm k' v k',v∈fm₁fm₂
-                with (_ , fm'₁fm'₂⊆fm')
-                     ← to-⊔-distr uks' rest₁ rest₂
-                with (_ , (refl , (v₁∈fm₁ , v₂∈fm₂)))
-                     ← Provenance-union fm₁ fm₂ k',v∈fm₁fm₂
-                with v₁∈fm₁ | v₂∈fm₂
-            ...   | here refl | here refl =
-                    (v , (IsLattice.≈-refl lB , here refl))
-            ...   | here refl | there k',v₂∈fm₂' =
-                    ⊥-elim (All¬-¬Any k≢ks' (subst (k' ∈ˡ_) (proj₂ fm₂')
-                                                   (forget k',v₂∈fm₂')))
-            ...   | there k',v₁∈fm₁' | here refl =
-                    ⊥-elim (All¬-¬Any k≢ks' (subst (k' ∈ˡ_) (proj₂ fm₁')
-                                                   (forget k',v₁∈fm₁')))
-            ...   | there k',v₁∈fm₁' | there k',v₂∈fm₂' =
-                        let
-                            k',v₁v₂∈fm₁'fm₂' =
-                                ⊔-combines {m₁ = proj₁ fm₁'} {m₂ = proj₁ fm₂'}
-                                           k',v₁∈fm₁' k',v₂∈fm₂'
-                            (v' , (v₁⊔v₂≈v' , v'∈fm')) =
-                                fm'₁fm'₂⊆fm' _ _ k',v₁v₂∈fm₁'fm₂'
-                        in
-                            (v' , (v₁⊔v₂≈v' , there v'∈fm'))
-
-    module WithUniqueKeysAndFixedHeight {ks : List A} (uks : Unique ks) (≈₂-dec : Decidable _≈₂_) (h₂ : ℕ) (fhB : FixedHeight₂ h₂) where
-        import Isomorphism
-        open Isomorphism.TransportFiniteHeight
-            (IP.isFiniteHeightLattice (length ks) ≈₂-dec ≈ᵘ-dec h₂ 0 fhB fixedHeightᵘ) (isLattice ks)
-            {f = to uks} {g = from {ks}}
-            (to-preserves-≈ uks) (from-preserves-≈ {ks})
-            (to-⊔-distr uks) (from-⊔-distr {ks})
-            (from-to-inverseʳ uks) (from-to-inverseˡ uks)
-            using (isFiniteHeightLattice; finiteHeightLattice) public

Lattice/IterProd.agda

@@ -1,19 +1,22 @@
 open import Lattice
+open import Data.Unit using (⊤)
 
 -- Due to universe levels, it becomes relatively annoying to handle the case
 -- where the levels of A and B are not the same. For the time being, constrain
 -- them to be the same.
 
-module Lattice.IterProd {a} {A B : Set a}
-    (_≈₁_ : A → A → Set a) (_≈₂_ : B → B → Set a)
-    (_⊔₁_ : A → A → A) (_⊔₂_ : B → B → B)
-    (_⊓₁_ : A → A → A) (_⊓₂_ : B → B → B)
-    (lA : IsLattice A _≈₁_ _⊔₁_ _⊓₁_) (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+module Lattice.IterProd {a} (A B : Set a)
+    {_≈₁_ : A → A → Set a} {_≈₂_ : B → B → Set a}
+    {_⊔₁_ : A → A → A} {_⊔₂_ : B → B → B}
+    {_⊓₁_ : A → A → A} {_⊓₂_ : B → B → B}
+    {{lA : IsLattice A _≈₁_ _⊔₁_ _⊓₁_}} {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}} (dummy : ⊤) where
 
 open import Agda.Primitive using (lsuc)
-open import Data.Nat using (ℕ; suc; _+_)
-open import Data.Product using (_×_)
+open import Data.Nat using (ℕ; zero; suc; _+_)
+open import Data.Product using (_×_; _,_; proj₁; proj₂)
+open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; cong)
 open import Utils using (iterate)
+open import Chain using (Height)
 
 open IsLattice lA renaming (FixedHeight to FixedHeight₁)
 open IsLattice lB renaming (FixedHeight to FixedHeight₂)
@@ -30,31 +33,50 @@ IterProd k = iterate k (λ t → A × t) B
 -- that are built up by the two iterations. So, do everything in one iteration.
 -- This requires some odd code.
 
+build : A → B → (k : ℕ) → IterProd k
+build _ b zero = b
+build a b (suc s) = (a , build a b s)
+
 private
     record RequiredForFixedHeight : Set (lsuc a) where
         field
-            ≈₁-dec : IsDecidable _≈₁_
-            ≈₂-dec : IsDecidable _≈₂_
+            {{≈₁-Decidable}} : IsDecidable _≈₁_
+            {{≈₂-Decidable}} : IsDecidable _≈₂_
             h₁ h₂ : ℕ
-            fhA : FixedHeight₁ h₁
-            fhB : FixedHeight₂ h₂
+            {{fhA}} : FixedHeight₁ h₁
+            {{fhB}} : FixedHeight₂ h₂
 
-    record IsFiniteHeightAndDecEq {A : Set a} {_≈_ : A → A → Set a} {_⊔_ : A → A → A} {_⊓_ : A → A → A} (isLattice : IsLattice A _≈_ _⊔_ _⊓_) : Set (lsuc a) where
+        ⊥₁ : A
+        ⊥₁ = Height.⊥ fhA
+
+        ⊥₂ : B
+        ⊥₂ = Height.⊥ fhB
+
+        ⊥k : ∀ (k : ℕ) → IterProd k
+        ⊥k = build ⊥₁ ⊥₂
+
+    record IsFiniteHeightWithBotAndDecEq {A : Set a} {_≈_ : A → A → Set a} {_⊔_ : A → A → A} {_⊓_ : A → A → A} (isLattice : IsLattice A _≈_ _⊔_ _⊓_) (⊥ : A) : Set (lsuc a) where
         field
             height : ℕ
             fixedHeight : IsLattice.FixedHeight isLattice height
-            ≈-dec : IsDecidable _≈_
+            ≈-Decidable : IsDecidable _≈_
+
+            ⊥-correct : Height.⊥ fixedHeight ≡ ⊥
+
+    record Everything (k : ℕ) : Set (lsuc a) where
+        T = IterProd k
 
-    record Everything (A : Set a) : Set (lsuc a) where
         field
-            _≈_ : A → A → Set a
-            _⊔_ : A → A → A
-            _⊓_ : A → A → A
+            _≈_ : T → T → Set a
+            _⊔_ : T → T → T
+            _⊓_ : T → T → T
 
-            isLattice : IsLattice A _≈_ _⊔_ _⊓_
-            isFiniteHeightIfSupported : RequiredForFixedHeight → IsFiniteHeightAndDecEq isLattice
+            isLattice : IsLattice T _≈_ _⊔_ _⊓_
+            isFiniteHeightIfSupported :
+                ∀ (req : RequiredForFixedHeight) →
+                IsFiniteHeightWithBotAndDecEq isLattice (RequiredForFixedHeight.⊥k req k)
 
-    everything : ∀ (k : ℕ) → Everything (IterProd k)
+    everything : ∀ (k : ℕ) → Everything k
     everything 0 = record
         { _≈_ = _≈₂_
         ; _⊔_ = _⊔₂_
@@ -63,7 +85,8 @@ private
         ; isFiniteHeightIfSupported = λ req → record
             { height = RequiredForFixedHeight.h₂ req
             ; fixedHeight = RequiredForFixedHeight.fhB req
-            ; ≈-dec = RequiredForFixedHeight.≈₂-dec req
+            ; ≈-Decidable = RequiredForFixedHeight.≈₂-Decidable req
+            ; ⊥-correct = refl
             }
         }
     everything (suc k') = record
@@ -76,27 +99,27 @@ private
                 fhlRest = Everything.isFiniteHeightIfSupported everythingRest req
             in
                 record
-                    { height = (RequiredForFixedHeight.h₁ req) + IsFiniteHeightAndDecEq.height fhlRest
+                    { height = (RequiredForFixedHeight.h₁ req) + IsFiniteHeightWithBotAndDecEq.height fhlRest
                     ; fixedHeight =
                         P.fixedHeight
-                        (RequiredForFixedHeight.≈₁-dec req) (IsFiniteHeightAndDecEq.≈-dec fhlRest)
-                        (RequiredForFixedHeight.h₁ req) (IsFiniteHeightAndDecEq.height fhlRest)
-                        (RequiredForFixedHeight.fhA req) (IsFiniteHeightAndDecEq.fixedHeight fhlRest)
-                    ; ≈-dec = P.≈-dec (RequiredForFixedHeight.≈₁-dec req) (IsFiniteHeightAndDecEq.≈-dec fhlRest)
+                            {{≈₂-Decidable = IsFiniteHeightWithBotAndDecEq.≈-Decidable fhlRest}}
+                            {{fhB = IsFiniteHeightWithBotAndDecEq.fixedHeight fhlRest}}
+                    ; ≈-Decidable = P.≈-Decidable {{≈₂-Decidable = IsFiniteHeightWithBotAndDecEq.≈-Decidable fhlRest}}
+                    ; ⊥-correct =
+                        cong ((Height.⊥ (RequiredForFixedHeight.fhA req)) ,_)
+                             (IsFiniteHeightWithBotAndDecEq.⊥-correct fhlRest)
                     }
         }
         where
             everythingRest = everything k'
+            import Lattice.Prod A (IterProd k') {{lB = Everything.isLattice everythingRest}} as P
 
-            import Lattice.Prod
-                _≈₁_ (Everything._≈_ everythingRest)
-                _⊔₁_ (Everything._⊔_ everythingRest)
-                _⊓₁_ (Everything._⊓_ everythingRest)
-                lA  (Everything.isLattice everythingRest) as P
+module _ {k : ℕ} where
+    open Everything (everything k) using (_≈_; _⊔_; _⊓_) public
+    open Lattice.IsLattice (Everything.isLattice (everything k)) public
 
-module _ (k : ℕ) where
-    open Everything (everything k) using (_≈_; _⊔_; _⊓_; isLattice) public
-    open Lattice.IsLattice isLattice public
+    instance
+        isLattice = Everything.isLattice (everything k)
 
         lattice : Lattice (IterProd k)
         lattice = record
@@ -106,31 +129,40 @@ module _ (k : ℕ) where
             ; isLattice = isLattice
             }
 
-    module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_)
-             (h₁ h₂ : ℕ)
-             (fhA : FixedHeight₁ h₁) (fhB : FixedHeight₂ h₂) where
+    module _ {{≈₁-Decidable : IsDecidable _≈₁_}} {{≈₂-Decidable : IsDecidable _≈₂_}}
+             {h₁ h₂ : ℕ}
+             {{fhA : FixedHeight₁ h₁}} {{fhB : FixedHeight₂ h₂}} where
 
         private
-            required : RequiredForFixedHeight
-            required = record
-                { ≈₁-dec = ≈₁-dec
-                ; ≈₂-dec = ≈₂-dec
+            isFiniteHeightWithBotAndDecEq =
+                Everything.isFiniteHeightIfSupported (everything k)
+                    record
+                        { ≈₁-Decidable = ≈₁-Decidable
+                        ; ≈₂-Decidable = ≈₂-Decidable
                         ; h₁ = h₁
                         ; h₂ = h₂
                         ; fhA = fhA
                         ; fhB = fhB
                         }
+        open IsFiniteHeightWithBotAndDecEq isFiniteHeightWithBotAndDecEq using (height; ⊥-correct)
+
+        instance
+            fixedHeight = IsFiniteHeightWithBotAndDecEq.fixedHeight isFiniteHeightWithBotAndDecEq
 
             isFiniteHeightLattice = record
                 { isLattice = isLattice
-            ; fixedHeight = IsFiniteHeightAndDecEq.fixedHeight (Everything.isFiniteHeightIfSupported (everything k) required)
+                ; fixedHeight = fixedHeight
                 }
 
             finiteHeightLattice : FiniteHeightLattice (IterProd k)
             finiteHeightLattice = record
-            { height = IsFiniteHeightAndDecEq.height (Everything.isFiniteHeightIfSupported (everything k) required)
+                { height = height
                 ; _≈_ = _≈_
                 ; _⊔_ = _⊔_
                 ; _⊓_ = _⊓_
                 ; isFiniteHeightLattice = isFiniteHeightLattice
                 }
+
+        ⊥-built : Height.⊥ fixedHeight ≡ (build (Height.⊥ fhA) (Height.⊥ fhB) k)
+        ⊥-built = ⊥-correct
+

Lattice/Map.agda

@@ -1,13 +1,14 @@
 open import Lattice
 open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym; trans; cong; subst)
-open import Relation.Binary.Definitions using (Decidable)
 open import Agda.Primitive using (Level) renaming (_⊔_ to _⊔ℓ_)
+open import Data.Unit using (⊤)
 
-module Lattice.Map {a b : Level} {A : Set a} {B : Set b}
+module Lattice.Map {a b : Level} (A : Set a) (B : Set b)
     {_≈₂_ : B → B → Set b}
     {_⊔₂_ : B → B → B} {_⊓₂_ : B → B → B}
-    (≡-dec-A : Decidable (_≡_ {a} {A}))
-    (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+    {{≡-Decidable-A : IsDecidable {a} {A} _≡_}}
+    {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}}
+    (dummy : ⊤) where
 
 open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
 
@@ -23,6 +24,8 @@ open import Utils using (Unique; push; Unique-append; All¬-¬Any; All-x∈xs)
 open import Data.String using () renaming (_++_ to _++ˢ_)
 open import Showable using (Showable; show)
 
+open IsDecidable ≡-Decidable-A using () renaming (R-dec to _≟ᴬ_)
+
 open IsLattice lB using () renaming
     ( ≈-refl to ≈₂-refl; ≈-sym to ≈₂-sym; ≈-trans to ≈₂-trans
     ; ≈-⊔-cong to ≈₂-⊔₂-cong; ≈-⊓-cong to ≈₂-⊓₂-cong
@@ -41,7 +44,7 @@ private module ImplKeys where
 ∈k-dec : ∀ (k : A) (l : List (A × B)) → Dec (k ∈ˡ (ImplKeys.keys l))
 ∈k-dec k [] = no (λ ())
 ∈k-dec k ((k' , v) ∷ xs)
-    with (≡-dec-A k k')
+    with (k ≟ᴬ k')
 ...   | yes k≡k' = yes (here k≡k')
 ...   | no k≢k' with (∈k-dec k xs)
 ...       | yes k∈kxs = yes (there k∈kxs)
@@ -76,7 +79,7 @@ private module _ where
     k∈-dec : ∀ (k : A) (l : List A) → Dec (k ∈ l)
     k∈-dec k [] = no (λ ())
     k∈-dec k (x ∷ xs)
-        with (≡-dec-A k x)
+        with (k ≟ᴬ x)
     ...   | yes refl = yes (here refl)
     ...   | no k≢x with (k∈-dec k xs)
     ...       | yes k∈xs = yes (there k∈xs)
@@ -113,7 +116,7 @@ private module ImplInsert (f : B → B → B) where
 
     insert : A → B → List (A × B) → List (A × B)
     insert k v [] = (k , v) ∷ []
-    insert k v (x@(k' , v') ∷ xs) with ≡-dec-A k k'
+    insert k v (x@(k' , v') ∷ xs) with k ≟ᴬ k'
     ...                             | yes _ = (k' , f v v') ∷ xs
     ...                             | no _ = x ∷ insert k v xs
 
@@ -123,11 +126,11 @@ private module ImplInsert (f : B → B → B) where
     insert-keys-∈ : ∀ {k : A} {v : B} {l : List (A × B)} →
                     k ∈k l → keys l ≡ keys (insert k v l)
     insert-keys-∈ {k} {v} {(k' , v') ∷ xs} (here k≡k')
-        with (≡-dec-A k k')
+        with (k ≟ᴬ k')
     ...   | yes _ = refl
     ...   | no k≢k' = ⊥-elim (k≢k' k≡k')
     insert-keys-∈ {k} {v} {(k' , _) ∷ xs} (there k∈kxs)
-        with (≡-dec-A k k')
+        with (k ≟ᴬ k')
     ...   | yes _ = refl
     ...   | no _ = cong (λ xs' → k' ∷ xs') (insert-keys-∈ k∈kxs)
 
@@ -135,7 +138,7 @@ private module ImplInsert (f : B → B → B) where
                     ¬ (k ∈k l) → (keys l ++ (k ∷ [])) ≡ keys (insert k v l)
     insert-keys-∉ {k} {v} {[]} _ = refl
     insert-keys-∉ {k} {v} {(k' , v') ∷ xs} k∉kl
-        with (≡-dec-A k k')
+        with (k ≟ᴬ k')
     ...   | yes k≡k' = ⊥-elim (k∉kl (here k≡k'))
     ...   | no _ = cong (λ xs' → k' ∷ xs')
                         (insert-keys-∉ (λ k∈kxs → k∉kl (there k∈kxs)))
@@ -171,7 +174,7 @@ private module ImplInsert (f : B → B → B) where
                                  ¬ k ∈k l → (k , v) ∈ insert k v l
     insert-fresh {l = []} k∉kl = here refl
     insert-fresh {k} {l = (k' , v') ∷ xs} k∉kl
-        with ≡-dec-A k k'
+        with k ≟ᴬ k'
     ...   | yes k≡k' = ⊥-elim (k∉kl (here k≡k'))
     ...   | no _ = there (insert-fresh (λ k∈kxs → k∉kl (there k∈kxs)))
 
@@ -180,9 +183,9 @@ private module ImplInsert (f : B → B → B) where
     insert-preserves-∉k {l = []} k≢k' k∉kl (here k≡k') = k≢k' k≡k'
     insert-preserves-∉k {l = []} k≢k' k∉kl (there ())
     insert-preserves-∉k {k} {k'} {v'} {(k'' , v'') ∷ xs} k≢k' k∉kl k∈kil
-        with ≡-dec-A k k''
+        with k ≟ᴬ k''
     ...   | yes k≡k'' = k∉kl (here k≡k'')
-    ...   | no k≢k'' with ≡-dec-A k' k'' | k∈kil
+    ...   | no k≢k'' with k' ≟ᴬ k'' | k∈kil
     ...       | yes k'≡k'' | here k≡k'' = k≢k'' k≡k''
     ...       | yes k'≡k'' | there k∈kxs = k∉kl (there k∈kxs)
     ...       | no k'≢k''  | here k≡k'' = k∉kl (here k≡k'')
@@ -193,18 +196,18 @@ private module ImplInsert (f : B → B → B) where
                         ¬ k ∈k l₁ → ¬ k ∈k l₂ → ¬ k ∈k union l₁ l₂
     union-preserves-∉ {l₁ = []} _ k∉kl₂ = k∉kl₂
     union-preserves-∉ {k} {(k' , v') ∷ xs₁} k∉kl₁ k∉kl₂
-        with ≡-dec-A k k'
+        with k ≟ᴬ k'
     ...   | yes k≡k' = ⊥-elim (k∉kl₁ (here k≡k'))
     ...   | no k≢k' = insert-preserves-∉k k≢k' (union-preserves-∉ (λ k∈kxs₁ → k∉kl₁ (there k∈kxs₁)) k∉kl₂)
 
     insert-preserves-∈k : ∀ {k k' : A} {v' : B} {l : List (A × B)} →
                           k ∈k l → k ∈k insert k' v' l
     insert-preserves-∈k {k} {k'} {v'} {(k'' , v'') ∷ xs} (here k≡k'')
-        with (≡-dec-A k' k'')
+        with k' ≟ᴬ k''
     ...   | yes _ = here k≡k''
     ...   | no _ = here k≡k''
     insert-preserves-∈k {k} {k'} {v'} {(k'' , v'') ∷ xs} (there k∈kxs)
-        with (≡-dec-A k' k'')
+        with k' ≟ᴬ k''
     ...   | yes _ = there k∈kxs
     ...   | no _ = there (insert-preserves-∈k k∈kxs)
 
@@ -236,11 +239,11 @@ private module ImplInsert (f : B → B → B) where
     insert-preserves-∈ : ∀ {k k' : A} {v v' : B} {l : List (A × B)} →
                          ¬ k ≡ k' → (k , v) ∈ l → (k , v) ∈ insert k' v' l
     insert-preserves-∈ {k} {k'} {l = x ∷ xs} k≢k' (here k,v=x)
-        rewrite sym k,v=x with ≡-dec-A k' k
+        rewrite sym k,v=x with k' ≟ᴬ k
     ...   | yes k'≡k = ⊥-elim (k≢k' (sym k'≡k))
     ...   | no _ = here refl
     insert-preserves-∈ {k} {k'} {l = (k'' , _) ∷ xs} k≢k' (there k,v∈xs)
-        with ≡-dec-A k' k''
+        with k' ≟ᴬ k''
     ...   | yes _ = there k,v∈xs
     ...   | no _ = there (insert-preserves-∈ k≢k' k,v∈xs)
 
@@ -259,7 +262,7 @@ private module ImplInsert (f : B → B → B) where
             k,v∈mxs₁l = union-preserves-∈₁ uxs₁ k,v∈xs₁ k∉kl₂
 
             k≢k' : ¬ k ≡ k'
-            k≢k' with ≡-dec-A k k'
+            k≢k' with k ≟ᴬ k'
             ...    | yes k≡k' rewrite k≡k' = ⊥-elim (All¬-¬Any k'≢xs₁ (∈-cong proj₁ k,v∈xs₁))
             ...    | no  k≢k' = k≢k'
     union-preserves-∈₁ {l₁ = (k' , v') ∷ xs₁} (push k'≢xs₁ uxs₁) (here k,v≡k',v') k∉kl₂
@@ -270,11 +273,11 @@ private module ImplInsert (f : B → B → B) where
                       Unique (keys l) → (k , v') ∈ l → (k , f v v') ∈ (insert k v l)
     insert-combines {l = (k' , v'') ∷ xs} _ (here k,v'≡k',v'')
         rewrite cong proj₁ k,v'≡k',v'' rewrite cong proj₂ k,v'≡k',v''
-        with ≡-dec-A k' k'
+        with k' ≟ᴬ k'
     ...   | yes _ = here refl
     ...   | no k≢k' = ⊥-elim (k≢k' refl)
     insert-combines {k} {l = (k' , v'') ∷ xs} (push k'≢xs uxs) (there k,v'∈xs)
-        with ≡-dec-A k k'
+        with k ≟ᴬ k'
     ...   | yes k≡k' rewrite k≡k' = ⊥-elim (All¬-¬Any k'≢xs (∈-cong proj₁ k,v'∈xs))
     ...   | no k≢k' = there (insert-combines uxs k,v'∈xs)
 
@@ -288,13 +291,13 @@ private module ImplInsert (f : B → B → B) where
         insert-preserves-∈ k≢k' (union-combines uxs₁ ul₂ k,v₁∈xs₁ k,v₂∈l₂)
         where
             k≢k' : ¬ k ≡ k'
-            k≢k' with ≡-dec-A k k'
+            k≢k' with k ≟ᴬ k'
             ...    | yes k≡k' rewrite k≡k' = ⊥-elim (All¬-¬Any k'≢xs₁ (∈-cong proj₁ k,v₁∈xs₁))
             ...    | no  k≢k' = k≢k'
 
     update : A → B → List (A × B) → List (A × B)
     update k v [] = []
-    update k v ((k' , v') ∷ xs) with ≡-dec-A k k'
+    update k v ((k' , v') ∷ xs) with k ≟ᴬ k'
     ...                            | yes _ = (k' , f v v') ∷ xs
     ...                            | no _ = (k' , v') ∷ update k v xs
 
@@ -314,7 +317,7 @@ private module ImplInsert (f : B → B → B) where
                   keys l ≡ keys (update k v l)
     update-keys {l = []} = refl
     update-keys {k} {v} {l = (k' , v') ∷ xs}
-        with ≡-dec-A k k'
+        with k ≟ᴬ k'
     ...   | yes _ = refl
     ...   | no _ rewrite update-keys {k} {v} {xs} = refl
 
@@ -431,11 +434,11 @@ private module ImplInsert (f : B → B → B) where
                          ¬ k ≡ k' → (k , v) ∈ l → (k , v) ∈ update k' v' l
     update-preserves-∈ {k} {k'} {v} {v'} {(k'' , v'') ∷ xs} k≢k' (here k,v≡k'',v'')
         rewrite cong proj₁ k,v≡k'',v'' rewrite cong proj₂ k,v≡k'',v''
-        with ≡-dec-A k' k''
+        with k' ≟ᴬ k''
     ...   | yes k'≡k'' = ⊥-elim (k≢k' (sym k'≡k''))
     ...   | no _ = here refl
     update-preserves-∈ {k} {k'} {v} {v'} {(k'' , v'') ∷ xs} k≢k' (there k,v∈xs)
-        with ≡-dec-A k' k''
+        with k' ≟ᴬ k''
     ...   | yes _ = there k,v∈xs
     ...   | no _ = there (update-preserves-∈ k≢k' k,v∈xs)
 
@@ -449,11 +452,11 @@ private module ImplInsert (f : B → B → B) where
                       Unique (keys l) → (k , v) ∈ l → (k , f v' v) ∈ update k v' l
     update-combines {k} {v} {v'} {(k' , v'') ∷ xs} _ (here k,v=k',v'')
         rewrite cong proj₁ k,v=k',v'' rewrite cong proj₂ k,v=k',v''
-        with ≡-dec-A k' k'
+        with k' ≟ᴬ k'
     ...   | yes _ = here refl
     ...   | no k'≢k' = ⊥-elim (k'≢k' refl)
     update-combines {k} {v} {v'} {(k' , v'') ∷ xs} (push k'≢xs uxs) (there k,v∈xs)
-        with ≡-dec-A k k'
+        with k ≟ᴬ k'
     ...   | yes k≡k' rewrite k≡k' = ⊥-elim (All¬-¬Any k'≢xs (∈-cong proj₁ k,v∈xs))
     ...   | no _ = there (update-combines uxs k,v∈xs)
 
@@ -467,7 +470,7 @@ private module ImplInsert (f : B → B → B) where
         update-preserves-∈ k≢k' (updates-combine uxs₁ u₂ k,v₁∈xs k,v₂∈l₂)
         where
             k≢k' : ¬ k ≡ k'
-            k≢k' with ≡-dec-A k k'
+            k≢k' with k ≟ᴬ k'
             ...    | yes k≡k' rewrite k≡k' = ⊥-elim (All¬-¬Any k'≢xs (∈-cong proj₁ k,v₁∈xs))
             ...    | no  k≢k' = k≢k'
 
@@ -625,7 +628,8 @@ Expr-Provenance-≡ {k} {v} e k,v∈e
     with (v' , (p , k,v'∈e)) ← Expr-Provenance k e (forget k,v∈e)
     rewrite Map-functional {m = ⟦ e ⟧} k,v∈e k,v'∈e = p
 
-module _ (≈₂-dec : IsDecidable _≈₂_) where
+module _ {{≈₂-Decidable : IsDecidable _≈₂_}} where
+    open IsDecidable ≈₂-Decidable using () renaming (R-dec to ≈₂-dec)
     private module _ where
         data SubsetInfo (m₁ m₂ : Map) : Set (a ⊔ℓ b) where
             extra : (k : A) → k ∈k m₁ → ¬ k ∈k m₂ → SubsetInfo m₁ m₂
@@ -676,6 +680,9 @@ module _ (≈₂-dec : IsDecidable _≈₂_) where
     ...   | _         | no  m₂̷⊆m₁ = no (λ (_ , m₂⊆m₁) → m₂̷⊆m₁ m₂⊆m₁)
     ...   | no  m₁̷⊆m₂ | _         = no (λ (m₁⊆m₂ , _) → m₁̷⊆m₂ m₁⊆m₂)
 
+    ≈-Decidable : IsDecidable _≈_
+    ≈-Decidable = record { R-dec = ≈-dec }
+
 private module I⊔ = ImplInsert _⊔₂_
 private module I⊓ = ImplInsert _⊓₂_
 
@@ -1026,7 +1033,7 @@ updating-via-k∉ks-backward m = transform-k∉ks-backward
 
 module _ {l} {L : Set l}
          {_≈ˡ_ : L → L → Set l} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
-         (lL : IsLattice L _≈ˡ_ _⊔ˡ_ _⊓ˡ_) where
+         {{lL : IsLattice L _≈ˡ_ _⊔ˡ_ _⊓ˡ_}} where
     open IsLattice lL using () renaming (_≼_ to _≼ˡ_)
 
     module _ (f : L → Map) (f-Monotonic : Monotonic _≼ˡ_ _≼_ f)
@@ -1112,6 +1119,19 @@ _[_] m (k ∷ ks)
 ...   | yes k∈km = proj₁ (locate {m = m} k∈km) ∷ (m [ ks ])
 ...   | no _ = m [ ks ]
 
+[]-∈ : ∀ {k : A} {v : B} {ks : List A} (m : Map) →
+       (k , v) ∈ m → k ∈ˡ ks → v ∈ˡ (m [ ks ])
+[]-∈ {k} {v} {ks} m k,v∈m (here refl)
+    with ∈k-dec k (proj₁ m)
+...    | no k∉km = ⊥-elim (k∉km (forget k,v∈m))
+...    | yes k∈km
+         with (v' , k,v'∈m) ← locate {m = m} k∈km
+         rewrite Map-functional {m = m} k,v'∈m k,v∈m = here refl
+[]-∈ {k} {v} {k' ∷ ks'} m k,v∈m (there k∈ks')
+    with ∈k-dec k' (proj₁ m)
+...   | no _  = []-∈ m k,v∈m k∈ks'
+...   | yes _ = there ([]-∈ m k,v∈m k∈ks')
+
 m₁≼m₂⇒m₁[k]≼m₂[k] : ∀ (m₁ m₂ : Map) {k : A} {v₁ v₂ : B} →
                     m₁ ≼ m₂ → (k , v₁) ∈ m₁ → (k , v₂) ∈ m₂ → v₁ ≼₂ v₂
 m₁≼m₂⇒m₁[k]≼m₂[k] m₁ m₂ m₁≼m₂ k,v₁∈m₁ k,v₂∈m₂
@@ -1129,3 +1149,12 @@ m₁≼m₂⇒k∈km₁⇒k∈km₂ m₁ m₂ m₁≼m₂ k∈km₁ =
         (v' , (v≈v' , k,v'∈m₂)) = (proj₁ m₁≼m₂) _ _ k,v∈m₁m₂
     in
         forget k,v'∈m₂
+
+m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ : ∀ (m₁ m₂ : Map) {k : A} →
+                         m₁ ≈ m₂ → ∀ (k∈km₁ : k ∈k m₁) (k∈km₂ : k ∈k m₂) →
+                         proj₁ (locate {m = m₁} k∈km₁) ≈₂ proj₁ (locate {m = m₂} k∈km₂)
+m₁≈m₂⇒k∈m₁⇒k∈km₂⇒v₁≈v₂ m₁ m₂ {k} (m₁⊆m₂ , m₂⊆m₁) k∈km₁ k∈km₂
+    with (v₁ , k,v₁∈m₁) ← locate {m = m₁} k∈km₁
+    with (v₂ , k,v₂∈m₂) ← locate {m = m₂} k∈km₂
+    with (v₂' , (v₁≈v₂' , k,v₂'∈m₂)) ← m₁⊆m₂ k v₁ k,v₁∈m₁
+    rewrite Map-functional {m = m₂} k,v₂∈m₂ k,v₂'∈m₂ = v₁≈v₂'

Lattice/MapSet.agda

@@ -1,9 +1,9 @@
 open import Lattice
 open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; sym; trans; cong; subst)
-open import Relation.Binary.Definitions using (Decidable)
 open import Agda.Primitive using (Level) renaming (_⊔_ to _⊔ℓ_)
+open import Data.Unit using (⊤)
 
-module Lattice.MapSet {a : Level} {A : Set a} (≡-dec-A : Decidable (_≡_ {a} {A})) where
+module Lattice.MapSet {a : Level} (A : Set a) {{≡-Decidable-A : IsDecidable (_≡_ {a} {A})}} (dummy : ⊤) where
 
 open import Data.List using (List; map)
 open import Data.Product using (_,_; proj₁)
@@ -12,7 +12,7 @@ open import Function using (_∘_)
 open import Lattice.Unit using (⊤; tt) renaming (_≈_ to _≈₂_; _⊔_ to _⊔₂_; _⊓_ to _⊓₂_; isLattice to ⊤-isLattice)
 import Lattice.Map
 
-private module UnitMap = Lattice.Map ≡-dec-A ⊤-isLattice
+private module UnitMap = Lattice.Map A ⊤ dummy
 open UnitMap
     using (Map; Expr; ⟦_⟧)
     renaming

Lattice/Nat.agda

@@ -18,8 +18,9 @@ private
     ≡-⊓-cong : ∀ {a₁ a₂ a₃ a₄} → a₁ ≡ a₂ → a₃ ≡ a₄ → (a₁ ⊓ a₃) ≡ (a₂ ⊓ a₄)
     ≡-⊓-cong a₁≡a₂ a₃≡a₄ rewrite a₁≡a₂ rewrite a₃≡a₄ = refl
 
-isMaxSemilattice : IsSemilattice ℕ _≡_ _⊔_
-isMaxSemilattice = record
+instance
+    isMaxSemilattice : IsSemilattice ℕ _≡_ _⊔_
+    isMaxSemilattice = record
         { ≈-equiv = record
             { ≈-refl = refl
             ; ≈-sym = sym
@@ -31,8 +32,8 @@ isMaxSemilattice = record
         ; ⊔-idemp = ⊔-idem
         }
 
-isMinSemilattice : IsSemilattice ℕ _≡_ _⊓_
-isMinSemilattice = record
+    isMinSemilattice : IsSemilattice ℕ _≡_ _⊓_
+    isMinSemilattice = record
         { ≈-equiv = record
             { ≈-refl = refl
             ; ≈-sym = sym
@@ -74,16 +75,17 @@ private
             helper : x ⊔ (x ⊓ y) ≤ x ⊔ x  → x ⊔ x ≡ x → x ⊔ (x ⊓ y) ≤ x
             helper x⊔x⊓y≤x⊔x x⊔x≡x rewrite x⊔x≡x = x⊔x⊓y≤x⊔x
 
-isLattice : IsLattice ℕ _≡_ _⊔_ _⊓_
-isLattice = record
+instance
+    isLattice : IsLattice ℕ _≡_ _⊔_ _⊓_
+    isLattice = record
         { joinSemilattice = isMaxSemilattice
         ; meetSemilattice = isMinSemilattice
         ; absorb-⊔-⊓ = λ x y → maxmin-absorb {x} {y}
         ; absorb-⊓-⊔ = λ x y → minmax-absorb {x} {y}
         }
 
-lattice : Lattice ℕ
-lattice = record
+    lattice : Lattice ℕ
+    lattice = record
         { _≈_ = _≡_
         ; _⊔_ = _⊔_
         ; _⊓_ = _⊓_

Lattice/Prod.agda

@@ -1,10 +1,10 @@
 open import Lattice
 
-module Lattice.Prod {a b} {A : Set a} {B : Set b}
-    (_≈₁_ : A → A → Set a) (_≈₂_ : B → B → Set b)
-    (_⊔₁_ : A → A → A) (_⊔₂_ : B → B → B)
-    (_⊓₁_ : A → A → A) (_⊓₂_ : B → B → B)
-    (lA : IsLattice A _≈₁_ _⊔₁_ _⊓₁_) (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+module Lattice.Prod {a b} (A : Set a) (B : Set b)
+    {_≈₁_ : A → A → Set a} {_≈₂_ : B → B → Set b}
+    {_⊔₁_ : A → A → A} {_⊔₂_ : B → B → B}
+    {_⊓₁_ : A → A → A} {_⊓₂_ : B → B → B}
+    {{lA : IsLattice A _≈₁_ _⊔₁_ _⊓₁_}} {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}} where
 
 open import Agda.Primitive using (Level) renaming (_⊔_ to _⊔ℓ_)
 open import Data.Nat using (ℕ; _≤_; _+_; suc)
@@ -12,6 +12,7 @@ open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂)
 open import Data.Empty using (⊥-elim)
 open import Relation.Binary.Core using (_Preserves_⟶_ )
 open import Relation.Binary.PropositionalEquality using (sym; subst)
+open import Relation.Binary.Definitions using (Decidable)
 open import Relation.Nullary using (¬_; yes; no)
 open import Equivalence
 import Chain
@@ -39,8 +40,9 @@ open IsLattice lB using () renaming
 _≈_ : A × B → A × B → Set (a ⊔ℓ b)
 (a₁ , b₁) ≈ (a₂ , b₂) = (a₁ ≈₁ a₂) × (b₁ ≈₂ b₂)
 
-≈-equiv : IsEquivalence (A × B) _≈_
-≈-equiv = record
+instance
+    ≈-equiv : IsEquivalence (A × B) _≈_
+    ≈-equiv = record
         { ≈-refl = λ {p} → (≈₁-refl , ≈₂-refl)
         ; ≈-sym = λ {p₁} {p₂} (a₁≈a₂ , b₁≈b₂) → (≈₁-sym a₁≈a₂ , ≈₂-sym b₁≈b₂)
         ; ≈-trans = λ {p₁} {p₂} {p₃} (a₁≈a₂ , b₁≈b₂) (a₂≈a₃ , b₂≈b₃) →
@@ -75,14 +77,15 @@ private module ProdIsSemilattice (f₁ : A → A → A) (f₂ : B → B → B) (
             )
         }
 
-isJoinSemilattice : IsSemilattice (A × B) _≈_ _⊔_
-isJoinSemilattice = ProdIsSemilattice.isSemilattice _⊔₁_ _⊔₂_ joinSemilattice₁ joinSemilattice₂
+instance
+    isJoinSemilattice : IsSemilattice (A × B) _≈_ _⊔_
+    isJoinSemilattice = ProdIsSemilattice.isSemilattice _⊔₁_ _⊔₂_ joinSemilattice₁ joinSemilattice₂
 
-isMeetSemilattice : IsSemilattice (A × B) _≈_ _⊓_
-isMeetSemilattice = ProdIsSemilattice.isSemilattice _⊓₁_ _⊓₂_ meetSemilattice₁ meetSemilattice₂
+    isMeetSemilattice : IsSemilattice (A × B) _≈_ _⊓_
+    isMeetSemilattice = ProdIsSemilattice.isSemilattice _⊓₁_ _⊓₂_ meetSemilattice₁ meetSemilattice₂
 
-isLattice : IsLattice (A × B) _≈_ _⊔_ _⊓_
-isLattice = record
+    isLattice : IsLattice (A × B) _≈_ _⊔_ _⊓_
+    isLattice = record
         { joinSemilattice = isJoinSemilattice
         ; meetSemilattice = isMeetSemilattice
         ; absorb-⊔-⊓ = λ (a₁ , b₁) (a₂ , b₂) →
@@ -95,29 +98,35 @@ isLattice = record
             )
         }
 
-lattice : Lattice (A × B)
-lattice = record
+    lattice : Lattice (A × B)
+    lattice = record
         { _≈_ = _≈_
         ; _⊔_ = _⊔_
         ; _⊓_ = _⊓_
         ; isLattice = isLattice
         }
 
-module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_) where
-    ≈-dec : IsDecidable _≈_
+open IsLattice isLattice using (_≼_; _≺_; ≺-cong) public
+
+module _ {{≈₁-Decidable : IsDecidable _≈₁_}} {{≈₂-Decidable : IsDecidable _≈₂_}} where
+    open IsDecidable ≈₁-Decidable using () renaming (R-dec to ≈₁-dec)
+    open IsDecidable ≈₂-Decidable using () renaming (R-dec to ≈₂-dec)
+
+    ≈-dec : Decidable _≈_
     ≈-dec (a₁ , b₁) (a₂ , b₂)
         with ≈₁-dec a₁ a₂ | ≈₂-dec b₁ b₂
     ...   | yes a₁≈a₂ | yes b₁≈b₂ = yes (a₁≈a₂ , b₁≈b₂)
     ...   | no a₁̷≈a₂ | _ = no (λ (a₁≈a₂ , _) → a₁̷≈a₂ a₁≈a₂)
     ...   | _ | no b₁̷≈b₂ = no (λ (_ , b₁≈b₂) → b₁̷≈b₂ b₁≈b₂)
 
+    instance
+        ≈-Decidable : IsDecidable _≈_
+        ≈-Decidable = record { R-dec = ≈-dec }
 
-module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_)
-         (h₁ h₂ : ℕ)
-         (fhA : FixedHeight₁ h₁) (fhB : FixedHeight₂ h₂) where
+    module _ {h₁ h₂ : ℕ}
+             {{fhA : FixedHeight₁ h₁}} {{fhB : FixedHeight₂ h₂}} where
 
         open import Data.Nat.Properties
-    open IsLattice isLattice using (_≼_; _≺_; ≺-cong)
 
         module ChainMapping₁ = ChainMapping joinSemilattice₁ isJoinSemilattice
         module ChainMapping₂ = ChainMapping joinSemilattice₂ isJoinSemilattice
@@ -143,17 +152,8 @@ module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_)
             ∙,b-Preserves-≈₁ : ∀ (b : B) → (λ a → (a , b)) Preserves _≈₁_ ⟶  _≈_
             ∙,b-Preserves-≈₁ b {a₁} {a₂} a₁≈a₂ = (a₁≈a₂ , ≈₂-refl)
 
-        amin : A
-        amin = proj₁ (proj₁ (proj₁ fhA))
-
-        amax : A
-        amax = proj₂ (proj₁ (proj₁ fhA))
-
-        bmin : B
-        bmin = proj₁ (proj₁ (proj₁ fhB))
-
-        bmax : B
-        bmax = proj₂ (proj₁ (proj₁ fhB))
+            open ChainA.Height fhA using () renaming (⊥ to ⊥₁; ⊤ to ⊤₁; longestChain to longestChain₁; bounded to bounded₁)
+            open ChainB.Height fhB using () renaming (⊥ to ⊥₂; ⊤ to ⊤₂; longestChain to longestChain₂; bounded to bounded₂)
 
             unzip : ∀ {a₁ a₂ : A} {b₁ b₂ : B} {n : ℕ} → Chain (a₁ , b₁) (a₂ , b₂) n → Σ (ℕ × ℕ) (λ (n₁ , n₂) → ((Chain₁ a₁ a₂ n₁ × Chain₂ b₁ b₂ n₂) × (n ≤ n₁ + n₂)))
             unzip (done (a₁≈a₂ , b₁≈b₂)) = ((0 , 0) , ((done₁ a₁≈a₂ , done₂ b₁≈b₂) , ≤-refl))
@@ -171,16 +171,18 @@ module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_)
                                          , m≤n⇒m≤o+n 1 (subst (n ≤_) (sym (+-suc n₁ n₂)) (+-monoʳ-≤ 1 n≤n₁+n₂))
                                          ))
 
+        instance
             fixedHeight : IsLattice.FixedHeight isLattice (h₁ + h₂)
-    fixedHeight =
-      ( ( ((amin , bmin) , (amax , bmax))
-        , concat
-            (ChainMapping₁.Chain-map (λ a → (a , bmin)) (∙,b-Monotonic _) proj₁ (∙,b-Preserves-≈₁ _) (proj₂ (proj₁ fhA)))
-            (ChainMapping₂.Chain-map (λ b → (amax , b)) (a,∙-Monotonic _) proj₂ (a,∙-Preserves-≈₂ _) (proj₂ (proj₁ fhB)))
-        )
-      , λ a₁b₁a₂b₂ → let ((n₁ , n₂) , ((a₁a₂ , b₁b₂) , n≤n₁+n₂)) = unzip a₁b₁a₂b₂
-                     in ≤-trans n≤n₁+n₂ (+-mono-≤ (proj₂ fhA a₁a₂) (proj₂ fhB b₁b₂))
-      )
+            fixedHeight = record
+              { ⊥ = (⊥₁ , ⊥₂)
+              ; ⊤ = (⊤₁ , ⊤₂)
+              ; longestChain = concat
+                    (ChainMapping₁.Chain-map (λ a → (a , ⊥₂)) (∙,b-Monotonic _) proj₁ (∙,b-Preserves-≈₁ _) longestChain₁)
+                    (ChainMapping₂.Chain-map (λ b → (⊤₁ , b)) (a,∙-Monotonic _) proj₂ (a,∙-Preserves-≈₂ _) longestChain₂)
+              ; bounded = λ a₁b₁a₂b₂ →
+                    let ((n₁ , n₂) , ((a₁a₂ , b₁b₂) , n≤n₁+n₂)) = unzip a₁b₁a₂b₂
+                    in ≤-trans n≤n₁+n₂ (+-mono-≤ (bounded₁ a₁a₂) (bounded₂ b₁b₂))
+              }
 
             isFiniteHeightLattice : IsFiniteHeightLattice (A × B) (h₁ + h₂) _≈_ _⊔_ _⊓_
             isFiniteHeightLattice = record

Lattice/Unit.agda

@@ -7,6 +7,7 @@ open import Data.Unit using (⊤; tt) public
 open import Data.Unit.Properties using (_≟_; ≡-setoid)
 open import Relation.Binary using (Setoid)
 open import Relation.Binary.PropositionalEquality as Eq using (_≡_)
+open import Relation.Binary.Definitions using (Decidable)
 open import Relation.Nullary using (Dec; ¬_; yes; no)
 open import Equivalence
 open import Lattice
@@ -24,9 +25,13 @@ _≈_ = _≡_
     ; ≈-trans = trans
     }
 
-≈-dec : IsDecidable _≈_
+≈-dec : Decidable _≈_
 ≈-dec = _≟_
 
+instance
+    ≈-Decidable : IsDecidable _≈_
+    ≈-Decidable = record { R-dec = ≈-dec }
+
 _⊔_ : ⊤ → ⊤ → ⊤
 tt ⊔ tt = tt
 
@@ -45,8 +50,9 @@ tt ⊓ tt = tt
 ⊔-idemp : (x : ⊤) → (x ⊔ x) ≈ x
 ⊔-idemp tt = Eq.refl
 
-isJoinSemilattice : IsSemilattice ⊤ _≈_ _⊔_
-isJoinSemilattice = record
+instance
+    isJoinSemilattice : IsSemilattice ⊤ _≈_ _⊔_
+    isJoinSemilattice = record
         { ≈-equiv = ≈-equiv
         ; ≈-⊔-cong = ≈-⊔-cong
         ; ⊔-assoc = ⊔-assoc
@@ -66,8 +72,9 @@ isJoinSemilattice = record
 ⊓-idemp : (x : ⊤) → (x ⊓ x) ≈ x
 ⊓-idemp tt = Eq.refl
 
-isMeetSemilattice : IsSemilattice ⊤ _≈_ _⊓_
-isMeetSemilattice = record
+instance
+    isMeetSemilattice : IsSemilattice ⊤ _≈_ _⊓_
+    isMeetSemilattice = record
         { ≈-equiv = ≈-equiv
         ; ≈-⊔-cong = ≈-⊓-cong
         ; ⊔-assoc = ⊓-assoc
@@ -75,22 +82,17 @@ isMeetSemilattice = record
         ; ⊔-idemp = ⊓-idemp
         }
 
-absorb-⊔-⊓ : (x y : ⊤) → (x ⊔ (x ⊓ y)) ≈ x
-absorb-⊔-⊓ tt tt = Eq.refl
-
-absorb-⊓-⊔ : (x y : ⊤) → (x ⊓ (x ⊔ y)) ≈ x
-absorb-⊓-⊔ tt tt = Eq.refl
-
-isLattice : IsLattice ⊤ _≈_ _⊔_ _⊓_
-isLattice = record
+instance
+    isLattice : IsLattice ⊤ _≈_ _⊔_ _⊓_
+    isLattice = record
         { joinSemilattice = isJoinSemilattice
         ; meetSemilattice = isMeetSemilattice
-    ; absorb-⊔-⊓ = absorb-⊔-⊓
-    ; absorb-⊓-⊔ = absorb-⊓-⊔
+        ; absorb-⊔-⊓ = λ { tt tt → Eq.refl }
+        ; absorb-⊓-⊔ = λ { tt tt → Eq.refl }
         }
 
-lattice : Lattice ⊤
-lattice = record
+    lattice : Lattice ⊤
+    lattice = record
         { _≈_ = _≈_
         ; _⊔_ = _⊔_
         ; _⊓_ = _⊓_
@@ -107,17 +109,23 @@ private
     isLongest {tt} {tt} (step (tt⊔tt≈tt , tt̷≈tt) _ _) = ⊥-elim (tt̷≈tt refl)
     isLongest (done _) = z≤n
 
-fixedHeight : IsLattice.FixedHeight isLattice 0
-fixedHeight = (((tt , tt) , longestChain) , isLongest)
+instance
+    fixedHeight : IsLattice.FixedHeight isLattice 0
+    fixedHeight = record
+        { ⊥ = tt
+        ; ⊤ = tt
+        ; longestChain = longestChain
+        ; bounded = isLongest
+        }
 
-isFiniteHeightLattice : IsFiniteHeightLattice ⊤ 0 _≈_ _⊔_ _⊓_
-isFiniteHeightLattice = record
+    isFiniteHeightLattice : IsFiniteHeightLattice ⊤ 0 _≈_ _⊔_ _⊓_
+    isFiniteHeightLattice = record
         { isLattice = isLattice
         ; fixedHeight = fixedHeight
         }
 
-finiteHeightLattice : FiniteHeightLattice ⊤
-finiteHeightLattice = record
+    finiteHeightLattice : FiniteHeightLattice ⊤
+    finiteHeightLattice = record
         { height = 0
         ; _≈_ = _≈_
         ; _⊔_ = _⊔_

Main.agda

@@ -1,10 +1,13 @@
+{-# OPTIONS --guardedness #-}
 module Main where
 
-open import Language
-open import Analysis.Sign
+open import Language hiding (_++_)
 open import Data.Vec using (Vec; _∷_; [])
 open import IO
 open import Level using (0ℓ)
+open import Data.String using (_++_)
+import Analysis.Constant as ConstantAnalysis
+import Analysis.Sign as SignAnalysis
 
 testCode : Stmt
 testCode =
@@ -13,11 +16,31 @@ testCode =
     ⟨ "neg" ← ((` "zero") Expr.- (# 1)) ⟩ then
     ⟨ "unknown" ← ((` "pos") Expr.+ (` "neg")) ⟩
 
+testCodeCond₁ : Stmt
+testCodeCond₁ =
+    ⟨ "var" ← (# 1) ⟩ then
+    if (` "var") then (
+        ⟨ "var" ← ((` "var") Expr.+ (# 1)) ⟩
+    ) else (
+        ⟨ "var" ← ((` "var") Expr.- (# 1)) ⟩ then
+        ⟨ "var" ← (# 1) ⟩
+    )
+
+testCodeCond₂ : Stmt
+testCodeCond₂ =
+    ⟨ "var" ← (# 1) ⟩ then
+    if (` "var") then (
+        ⟨ "x" ← (# 1) ⟩
+    ) else (
+        ⟨ noop ⟩
+    )
+
 testProgram : Program
 testProgram = record
     { rootStmt = testCode
     }
 
-open WithProg testProgram using (output)
+open SignAnalysis.WithProg testProgram using (analyze-correct) renaming (output to output-Sign)
+open ConstantAnalysis.WithProg testProgram using (analyze-correct) renaming (output to output-Const)
 
-main = run {0ℓ} (putStrLn output)
+main = run {0ℓ} (putStrLn (output-Const ++ "\n" ++ output-Sign))

Utils.agda

@@ -1,17 +1,31 @@
 module Utils where
 
 open import Agda.Primitive using () renaming (_⊔_ to _⊔ℓ_)
-open import Data.Product as Prod using (_×_)
+open import Data.Product as Prod using (Σ; _×_; _,_; proj₁; proj₂)
+open import Data.Empty using (⊥-elim)
 open import Data.Nat using (ℕ; suc)
-open import Data.List using (List; cartesianProduct; []; _∷_; _++_; foldr) renaming (map to mapˡ)
-open import Data.List.Membership.Propositional using (_∈_)
+open import Data.Fin as Fin using (Fin; suc; zero)
+open import Data.Fin.Properties using (suc-injective)
+open import Data.List using (List; cartesianProduct; []; _∷_; _++_; foldr; filter) renaming (map to mapˡ)
+open import Data.List.Membership.Propositional using (_∈_; lose)
 open import Data.List.Membership.Propositional.Properties as ListMemProp using ()
-open import Data.List.Relation.Unary.All using (All; []; _∷_; map)
-open import Data.List.Relation.Unary.Any using (Any; here; there) -- TODO: re-export these with nicer names from map
+open import Data.List.Relation.Unary.All using (All; []; _∷_; map; all?; lookup)
+open import Data.List.Relation.Unary.All.Properties using (++⁻ˡ; ++⁻ʳ)
+open import Data.List.Relation.Unary.Any as Any using (Any; here; there; any?) -- TODO: re-export these with nicer names from map
 open import Data.Sum using (_⊎_)
 open import Function.Definitions using (Injective)
-open import Relation.Binary.PropositionalEquality using (_≡_; sym; refl)
-open import Relation.Nullary using (¬_)
+open import Relation.Binary using (Antisymmetric) renaming (Decidable to Decidable²)
+open import Relation.Binary.PropositionalEquality using (_≡_; sym; refl; cong)
+open import Relation.Nullary using (¬_; yes; no; Dec)
+open import Relation.Nullary.Decidable using (¬?)
+open import Relation.Unary using (Decidable)
+
+All¬-¬Any : ∀ {p c} {C : Set c} {P : C → Set p} {l : List C} → All (λ x → ¬ P x) l → ¬ Any P l
+All¬-¬Any {l = x ∷ xs} (¬Px ∷ _) (here Px) = ¬Px Px
+All¬-¬Any {l = x ∷ xs} (_ ∷ ¬Pxs) (there Pxs) = All¬-¬Any ¬Pxs Pxs
+
+Decidable-¬ : ∀ {p c} {C : Set c} {P : C → Set p} → Decidable P → Decidable (λ x → ¬ P x)
+Decidable-¬ Decidable-P x = ¬? (Decidable-P x)
 
 data Unique {c} {C : Set c} : List C → Set c where
     empty : Unique []
@@ -33,6 +47,24 @@ Unique-append {c} {C} {x} {x' ∷ xs'} x∉xs (push x'≢ uxs') =
         help {[]} _ = x'≢x ∷ []
         help {e ∷ es} (x'≢e ∷ x'≢es) = x'≢e ∷ help x'≢es
 
+Unique-++⁻ˡ : ∀ {c} {C : Set c} (xs : List C) {ys : List C} → Unique (xs ++ ys) → Unique xs
+Unique-++⁻ˡ [] Unique-ys = empty
+Unique-++⁻ˡ (x ∷ xs) {ys} (push x≢xs++ys Unique-xs++ys) = push (++⁻ˡ xs {ys = ys} x≢xs++ys) (Unique-++⁻ˡ xs Unique-xs++ys)
+
+Unique-++⁻ʳ : ∀ {c} {C : Set c} (xs : List C) {ys : List C} → Unique (xs ++ ys) → Unique ys
+Unique-++⁻ʳ [] Unique-ys = Unique-ys
+Unique-++⁻ʳ (x ∷ xs) {ys} (push x≢xs++ys Unique-xs++ys) = Unique-++⁻ʳ xs Unique-xs++ys
+
+Unique-∈-++ˡ : ∀ {c} {C : Set c} {x : C} (xs : List C) {ys : List C} →  Unique (xs ++ ys) → x ∈ xs → ¬ x ∈ ys
+Unique-∈-++ˡ [] _ ()
+Unique-∈-++ˡ {x = x} (x' ∷ xs) (push x≢xs++ys _) (here refl) = All¬-¬Any (++⁻ʳ xs x≢xs++ys)
+Unique-∈-++ˡ {x = x} (x' ∷ xs) (push _ Unique-xs++ys) (there x̷∈xs) = Unique-∈-++ˡ xs Unique-xs++ys x̷∈xs
+
+Unique-narrow : ∀ {c} {C : Set c} {x : C} (xs : List C) {ys : List C} →  Unique (xs ++ ys) → x ∈ xs →  Unique (x ∷ ys)
+Unique-narrow [] _ ()
+Unique-narrow {x = x} (x' ∷ xs) (push x≢xs++ys Unique-xs++ys) (here refl) = push (++⁻ʳ xs x≢xs++ys) (Unique-++⁻ʳ xs Unique-xs++ys)
+Unique-narrow {x = x} (x' ∷ xs) (push _ Unique-xs++ys) (there x̷∈xs) = Unique-narrow xs Unique-xs++ys x̷∈xs
+
 All-≢-map : ∀ {c d} {C : Set c} {D : Set d} (x : C) {xs : List C} (f : C → D) →
             Injective (_≡_ {_} {C}) (_≡_ {_} {D}) f →
             All (λ x' → ¬ x ≡ x') xs → All (λ y' → ¬ (f x) ≡ y') (mapˡ f xs)
@@ -45,9 +77,8 @@ Unique-map : ∀ {c d} {C : Set c} {D : Set d} {l : List C} (f : C → D) →
 Unique-map {l = []} _ _ _ = empty
 Unique-map {l = x ∷ xs} f f-Injecitve (push x≢xs uxs) = push (All-≢-map x f f-Injecitve x≢xs) (Unique-map f f-Injecitve uxs)
 
-All¬-¬Any : ∀ {p c} {C : Set c} {P : C → Set p} {l : List C} → All (λ x → ¬ P x) l → ¬ Any P l
-All¬-¬Any {l = x ∷ xs} (¬Px ∷ _) (here Px) = ¬Px Px
-All¬-¬Any {l = x ∷ xs} (_ ∷ ¬Pxs) (there Pxs) = All¬-¬Any ¬Pxs Pxs
+¬Any-map : ∀ {p₁ p₂ c} {C : Set c} {P₁ : C → Set p₁} {P₂ : C → Set p₂} {l : List C} → (∀ {x} → P₁ x → P₂ x) → ¬ Any P₂ l → ¬ Any P₁ l
+¬Any-map f ¬Any-P₂ Any-P₁ = ¬Any-P₂ (Any.map f Any-P₁)
 
 All-single : ∀ {p c} {C : Set c} {P : C → Set p} {c : C} {l : List C} → All P l → c ∈ l → P c
 All-single {c = c} {l = x ∷ xs} (p ∷ ps) (here refl) = p
@@ -83,6 +114,14 @@ concat-∈ : ∀ {a} {A : Set a} {x : A} {l : List A} {ls : List (List A)} →
 concat-∈ x∈l (here refl) = ListMemProp.∈-++⁺ˡ x∈l
 concat-∈ {ls = l' ∷ ls'} x∈l (there l∈ls') = ListMemProp.∈-++⁺ʳ l' (concat-∈ x∈l l∈ls')
 
+filter-++ : ∀ {a p} {A : Set a} (l₁ l₂ : List A) {P : A → Set p} (P? : Decidable P) →
+            filter P? (l₁ ++ l₂) ≡ filter P? l₁ ++ filter P? l₂
+filter-++ [] l₂ P? = refl
+filter-++ (x ∷ xs) l₂ P?
+    with P? x
+...   | yes _ = cong (x ∷_) (filter-++ xs l₂ P?)
+...   | no _ = (filter-++ xs l₂ P?)
+
 _⇒_ : ∀ {a p₁ p₂} {A : Set a} (P : A → Set p₁) (Q : A → Set p₂) →
       Set (a ⊔ℓ p₁ ⊔ℓ p₂)
 _⇒_ P Q = ∀ a → P a → Q a
@@ -94,3 +133,45 @@ _∨_ P Q a = P a ⊎ Q a
 _∧_ : ∀ {a p₁ p₂} {A : Set a} (P : A → Set p₁) (Q : A → Set p₂) →
       A → Set (p₁ ⊔ℓ p₂)
 _∧_ P Q a = P a × Q a
+
+it : ∀ {a} {A : Set a} {{_ : A}} → A
+it {{x}} = x
+
+z≢sf : ∀ {n : ℕ} (f : Fin n) → ¬ (Fin.zero ≡ Fin.suc f)
+z≢sf f ()
+
+z≢mapsfs : ∀ {n : ℕ} (fs : List (Fin n)) → All (λ sf → ¬ zero ≡ sf) (mapˡ suc fs)
+z≢mapsfs [] = []
+z≢mapsfs (f ∷ fs') = z≢sf f ∷ z≢mapsfs fs'
+
+fins : ∀ (n : ℕ) → Σ (List (Fin n)) Unique
+fins 0 = ([] , empty)
+fins (suc n') =
+    let
+        (inds' , unids') = fins n'
+    in
+        ( zero ∷ mapˡ suc inds'
+        , push (z≢mapsfs inds') (Unique-map suc suc-injective unids')
+        )
+
+fins-complete : ∀ (n : ℕ) (f : Fin n) → f ∈ (proj₁ (fins n))
+fins-complete (suc n') zero = here refl
+fins-complete (suc n') (suc f') = there (x∈xs⇒fx∈fxs suc (fins-complete n' f'))
+
+findUniversal : ∀ {p c} {C : Set c} {R : C → C → Set p} (l : List C) →  Decidable² R →
+                Dec (Any (λ x → All (R x) l) l)
+findUniversal l Rdec = any? (λ x → all? (Rdec x) l) l
+
+findUniversal-unique : ∀ {p c} {C : Set c} (R : C → C → Set p) (l : List C) →
+                       Antisymmetric _≡_ R →
+                       ∀ x₁ x₂ → x₁ ∈ l → x₂ ∈ l → All (R x₁) l → All (R x₂) l →
+                       x₁ ≡ x₂
+findUniversal-unique R l Rantisym x₁ x₂ x₁∈l x₂∈l Allx₁ Allx₂ = Rantisym (lookup Allx₁ x₂∈l) (lookup Allx₂ x₁∈l)
+
+x∷xs≢[] : ∀ {a} {A : Set a} (x : A) (xs : List A) → ¬ (x ∷ xs ≡ [])
+x∷xs≢[] x xs ()
+
+foldr₁ : ∀ {a} {A : Set a} {l : List A} → ¬ (l ≡ []) → (A → A → A) → A
+foldr₁ {l = x ∷ []} _ _ = x
+foldr₁ {l = x ∷ x' ∷ xs} _ f = f x (foldr₁ {l = x' ∷ xs} (x∷xs≢[] x' xs) f)
+foldr₁ {l = []} l≢[] _ = ⊥-elim (l≢[] refl)

lean/.gitignore

@@ -0,0 +1 @@
+.lake/

lean/Main.lean

@@ -0,0 +1,40 @@
+/-
+Port of `Main.agda`. Prints the constant- and sign-analysis results for the
+test program (Agda: `putStrLn (output-Const ++ "\n" ++ output-Sign)`).
+-/
+import Spa.Analysis.Sign
+import Spa.Analysis.Constant
+
+namespace Spa
+
+/-- Agda: `testCode`. -/
+def testCode : Stmt :=
+  .andThen (.basic (.assign "zero" (.num 0)))
+    (.andThen (.basic (.assign "pos" (.add (.var "zero") (.num 1))))
+      (.andThen (.basic (.assign "neg" (.sub (.var "zero") (.num 1))))
+        (.basic (.assign "unknown" (.add (.var "pos") (.var "neg"))))))
+
+/-- Agda: `testCodeCond₁`. -/
+def testCodeCond₁ : Stmt :=
+  .andThen (.basic (.assign "var" (.num 1)))
+    (.ifElse (.var "var")
+      (.basic (.assign "var" (.add (.var "var") (.num 1))))
+      (.andThen (.basic (.assign "var" (.sub (.var "var") (.num 1))))
+        (.basic (.assign "var" (.num 1)))))
+
+/-- Agda: `testCodeCond₂`. -/
+def testCodeCond₂ : Stmt :=
+  .andThen (.basic (.assign "var" (.num 1)))
+    (.ifElse (.var "var")
+      (.basic (.assign "x" (.num 1)))
+      (.basic .noop))
+
+/-- Agda: `testProgram`. -/
+def testProgram : Program := ⟨testCode⟩
+
+end Spa
+
+/-- Agda: `main`. -/
+def main : IO Unit :=
+  IO.println (Spa.ConstAnalysis.output Spa.testProgram ++ "\n" ++
+              Spa.SignAnalysis.output Spa.testProgram)

lean/Spa.lean

@@ -0,0 +1,22 @@
+import Spa.Lattice
+import Spa.Fixedpoint
+import Spa.Isomorphism
+import Spa.Lattice.Unit
+import Spa.Lattice.Prod
+import Spa.Lattice.AboveBelow
+import Spa.Lattice.IterProd
+import Spa.Lattice.FiniteMap
+import Spa.Language.Base
+import Spa.Language.Semantics
+import Spa.Language.Graphs
+import Spa.Language.Traces
+import Spa.Language.Properties
+import Spa.Language
+import Spa.Analysis.Forward.Lattices
+import Spa.Analysis.Forward.Evaluation
+import Spa.Analysis.Forward.Adapters
+import Spa.Analysis.Forward
+import Spa.Showable
+import Spa.Analysis.Utils
+import Spa.Analysis.Sign
+import Spa.Analysis.Constant

lean/Spa/Analysis/Constant.lean

@@ -0,0 +1,228 @@
+/-
+Port of `Analysis/Constant.agda`.
+
+Correspondence:
+  showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
+  ConstLattice (AboveBelow ℤ)      ↦ ConstLattice
+  AB.Plain (+ 0)                   ↦ the AboveBelow FiniteHeightLattice instance,
+                                     seeded by `Inhabited ℤ` (default `0`)
+  plus, minus                      ↦ plus, minus
+  plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
+                                   ↦ plus_mono_left/right, minus_mono_left/right
+                                     — now actually proved, via
+                                     AboveBelow.monotone₂_of_strict
+  plus-Mono₂, minus-Mono₂          ↦ plus_mono₂, minus_mono₂
+  ⟦_⟧ᶜ                             ↦ interpConst
+  ⟦⟧ᶜ-respects-≈ᶜ                  ↦ (trivial with `=`)
+  ⟦⟧ᶜ-⊔ᶜ-∨, ⟦⟧ᶜ-⊓ᶜ-∧               ↦ interpConst_sup, interpConst_inf
+  s₁≢s₂⇒¬s₁∧s₂                     ↦ interpConst_mk_disjoint
+  latticeInterpretationᶜ           ↦ constInterpretation
+  WithProg.eval, eval-Monoʳ        ↦ ConstAnalysis.eval, eval_mono
+  ConstEval                        ↦ ConstAnalysis.exprEvaluator
+  plus-valid, minus-valid          ↦ plus_valid, minus_valid
+  eval-valid, ConstEvalValid       ↦ eval_valid
+  output                           ↦ ConstAnalysis.output
+  analyze-correct                  ↦ ConstAnalysis.analyze_correct
+-/
+import Spa.Analysis.Forward
+import Spa.Analysis.Utils
+import Spa.Showable
+
+namespace Spa
+
+abbrev ConstLattice : Type := AboveBelow ℤ
+
+namespace ConstAnalysis
+
+open AboveBelow in
+/-- Agda: `plus`. -/
+def plus : ConstLattice → ConstLattice → ConstLattice
+  | bot, _ => bot
+  | _, bot => bot
+  | top, _ => top
+  | _, top => top
+  | mk z₁, mk z₂ => mk (z₁ + z₂)
+
+open AboveBelow in
+/-- Agda: `minus`. -/
+def minus : ConstLattice → ConstLattice → ConstLattice
+  | bot, _ => bot
+  | _, bot => bot
+  | top, _ => top
+  | _, top => top
+  | mk z₁, mk z₂ => mk (z₁ - z₂)
+
+/-- Agda: `plus-Mono₂` (its components were postulates in Agda; `plus` is a
+strict operation on the flat lattice, so monotonicity holds regardless of the
+constant table). -/
+theorem plus_mono₂ : Monotone₂ plus :=
+  AboveBelow.monotone₂_of_strict plus
+    (fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
+    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
+
+/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
+theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
+
+/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
+theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
+
+/-- Agda: `minus-Mono₂` (likewise from strictness of `minus`). -/
+theorem minus_mono₂ : Monotone₂ minus :=
+  AboveBelow.monotone₂_of_strict minus
+    (fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
+    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
+
+/-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/
+theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
+
+/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
+theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
+
+/-- Agda: `⟦_⟧ᶜ`. -/
+def interpConst : ConstLattice → Value → Prop
+  | .bot, _ => False
+  | .top, _ => True
+  | .mk z, v => v = .int z
+
+/-- Agda: `s₁≢s₂⇒¬s₁∧s₂`. -/
+theorem interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Value} :
+    ¬(interpConst (.mk z₁) v ∧ interpConst (.mk z₂) v) := by
+  rintro ⟨h₁, h₂⟩
+  rw [h₁] at h₂
+  injection h₂ with hz
+  exact hne hz
+
+/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨` (via the factored flat-lattice lemma). -/
+theorem interpConst_sup {s₁ s₂ : ConstLattice} (v : Value)
+    (h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v :=
+  AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
+
+/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧` (via the factored flat-lattice lemma). -/
+theorem interpConst_inf {s₁ s₂ : ConstLattice} (v : Value)
+    (h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v :=
+  AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) v h
+
+/-- Agda: `latticeInterpretationᶜ` (an instance there too). -/
+instance constInterpretation : LatticeInterpretation ConstLattice where
+  interp := interpConst
+  interp_sup := fun {l₁ l₂} v h => interpConst_sup (s₁ := l₁) (s₂ := l₂) v h
+  interp_inf := fun {l₁ l₂} v h => interpConst_inf (s₁ := l₁) (s₂ := l₂) v h
+
+variable (prog : Program)
+
+/-- Agda: `WithProg.eval`. -/
+def eval : Expr → VariableValues ConstLattice prog → ConstLattice
+  | .add e₁ e₂, vs => plus (eval e₁ vs) (eval e₂ vs)
+  | .sub e₁ e₂, vs => minus (eval e₁ vs) (eval e₂ vs)
+  | .var k, vs =>
+    if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
+  | .num n, _ => .mk n
+
+/-- Agda: `WithProg.eval-Monoʳ`. -/
+theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
+  induction e with
+  | add e₁ e₂ ih₁ ih₂ =>
+    intro vs₁ vs₂ h
+    exact eval_combine₂ plus_mono₂ (ih₁ h) (ih₂ h)
+  | sub e₁ e₂ ih₁ ih₂ =>
+    intro vs₁ vs₂ h
+    exact eval_combine₂ minus_mono₂ (ih₁ h) (ih₂ h)
+  | var k =>
+    intro vs₁ vs₂ h
+    simp only [eval]
+    by_cases hk : k ∈ prog.vars
+    · rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
+          dif_pos (FiniteMap.memKey_iff.mpr hk)]
+      exact FiniteMap.le_of_mem_mem prog.vars_nodup h
+        (FiniteMap.locate _).2 (FiniteMap.locate _).2
+    · rw [dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm)),
+          dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm))]
+  | num n =>
+    intro vs₁ vs₂ _
+    exact le_refl _
+
+/-- Agda: the `ConstEval` instance. -/
+instance exprEvaluator : ExprEvaluator ConstLattice prog :=
+  ⟨eval prog, eval_mono prog⟩
+
+/-- Agda: `WithProg.result`/`output`. -/
+def output : String :=
+  show' (result ConstLattice prog)
+
+/-- Agda: `plus-valid`. -/
+theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
+    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
+    interpConst (plus g₁ g₂) (.int (z₁ + z₂)) := by
+  rcases g₁ with _ | _ | c₁
+  · exact h₁.elim
+  · rcases g₂ with _ | _ | c₂
+    · exact h₂.elim
+    · exact trivial
+    · exact trivial
+  · rcases g₂ with _ | _ | c₂
+    · exact h₂.elim
+    · exact trivial
+    · injection h₁ with hz₁
+      injection h₂ with hz₂
+      show Value.int (z₁ + z₂) = Value.int (c₁ + c₂)
+      rw [hz₁, hz₂]
+
+/-- Agda: `minus-valid`. -/
+theorem minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
+    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
+    interpConst (minus g₁ g₂) (.int (z₁ - z₂)) := by
+  rcases g₁ with _ | _ | c₁
+  · exact h₁.elim
+  · rcases g₂ with _ | _ | c₂
+    · exact h₂.elim
+    · exact trivial
+    · exact trivial
+  · rcases g₂ with _ | _ | c₂
+    · exact h₂.elim
+    · exact trivial
+    · injection h₁ with hz₁
+      injection h₂ with hz₂
+      show Value.int (z₁ - z₂) = Value.int (c₁ - c₂)
+      rw [hz₁, hz₂]
+
+/-- Agda: `eval-valid` / the `ConstEvalValid` instance. -/
+instance eval_valid : ValidExprEvaluator ConstLattice prog := by
+  constructor
+  intro vs ρ e v hev
+  induction hev with
+  | num n =>
+    intro _
+    show interpConst (eval prog (.num n) vs) (.int n)
+    rfl
+  | var x v hxv =>
+    intro hvs
+    show interpConst (eval prog (.var x) vs) v
+    simp only [eval]
+    by_cases hk : FiniteMap.MemKey x vs
+    · rw [dif_pos hk]
+      exact hvs _ _ (FiniteMap.locate hk).2 _ hxv
+    · rw [dif_neg hk]
+      exact trivial
+  | add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
+    intro hvs
+    have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    show interpConst (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
+    exact plus_valid h₁ h₂
+  | sub e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
+    intro hvs
+    have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    show interpConst (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
+    exact minus_valid h₁ h₂
+
+/-- Agda: `WithProg.analyze-correct`. -/
+theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    interpV (variablesAt prog.finalState (result ConstLattice prog)) ρ :=
+  Spa.analyze_correct ConstLattice prog hrun
+
+end ConstAnalysis
+
+end Spa

lean/Spa/Analysis/Forward.lean

@@ -0,0 +1,167 @@
+/-
+Port of `Analysis/Forward.agda` (`WithProg`, `WithStmtEvaluator`,
+`WithValidInterpretation`).
+
+As in Agda, the statement evaluator, the lattice interpretation and the
+evaluator's validity proof are instance arguments (`{{evaluator}}`,
+`{{latticeInterpretationˡ}}`, `{{validEvaluator}}`); `result` and
+`analyze_correct` take `L` and `prog` explicitly, mirroring the Agda call
+shape `WithProg.result L prog`.
+
+Correspondence:
+  updateVariablesForState, -Monoʳ   ↦ updateVariablesForState, _mono
+  updateAll, updateAll-Mono,
+  updateAll-k∈ks-≡                  ↦ updateAll, updateAll_mono, updateAll_mem_eq
+  analyze, analyze-Mono             ↦ analyze, analyze_mono
+  result, result≈analyze-result     ↦ result, result_eq
+  variablesAt-updateAll             ↦ variablesAt_updateAll
+  eval-fold-valid                   ↦ eval_fold_valid
+  updateVariablesForState-matches   ↦ updateVariablesForState_matches
+  updateAll-matches                 ↦ updateAll_matches
+  stepTrace                         ↦ stepTrace   (the `subst`/`⟦⟧ᵛ-respects-≈ᵛ`
+                                       plumbing becomes plain rewriting with `=`)
+  walkTrace                         ↦ walkTrace
+  joinForKey-initialState-⊥ᵛ        ↦ joinForKey_initialState
+  ⟦joinAll-initialState⟧ᵛ∅          ↦ interpV_joinForKey_initialState
+  analyze-correct                   ↦ analyze_correct
+-/
+import Spa.Analysis.Forward.Lattices
+import Spa.Analysis.Forward.Evaluation
+import Spa.Analysis.Forward.Adapters
+import Spa.Fixedpoint
+
+namespace Spa
+
+variable {L : Type} [Lattice L] {prog : Program} [E : StmtEvaluator L prog]
+
+/-- Agda: `updateVariablesForState`. -/
+def updateVariablesForState (s : prog.State) (sv : StateVariables L prog) :
+    VariableValues L prog :=
+  (prog.code s).foldl (fun vs bs => E.eval s bs vs) (variablesAt s sv)
+
+/-- Agda: `updateVariablesForState-Monoʳ`. -/
+theorem updateVariablesForState_mono (s : prog.State) :
+    Monotone (updateVariablesForState (L := L) s) := fun _ _ hle =>
+  foldl_mono' (prog.code s) _ (fun bs => E.eval_mono s bs) (variablesAt_le hle s)
+
+/-- Agda: `updateAll`. -/
+def updateAll (sv : StateVariables L prog) : StateVariables L prog :=
+  FiniteMap.generalizedUpdate id (fun s sv => updateVariablesForState s sv)
+    prog.states sv
+
+/-- Agda: `updateAll-Mono`. -/
+theorem updateAll_mono : Monotone (updateAll (L := L) (prog := prog)) :=
+  FiniteMap.generalizedUpdate_monotone monotone_id updateVariablesForState_mono
+
+/-- Agda: `updateAll-k∈ks-≡`. -/
+theorem updateAll_mem_eq {s : prog.State} {vs : VariableValues L prog}
+    {sv : StateVariables L prog} (hmem : (s, vs) ∈ updateAll sv) :
+    vs = updateVariablesForState s sv :=
+  FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) hmem
+
+/-- Agda: `variablesAt-updateAll`. -/
+theorem variablesAt_updateAll (s : prog.State) (sv : StateVariables L prog) :
+    variablesAt s (updateAll sv) = updateVariablesForState s sv :=
+  updateAll_mem_eq (variablesAt_mem s (updateAll sv))
+
+variable [FiniteHeightLattice L]
+
+/-- Agda: `analyze`. -/
+def analyze (sv : StateVariables L prog) : StateVariables L prog :=
+  updateAll (joinAll sv)
+
+/-- Agda: `analyze-Mono`. -/
+theorem analyze_mono : Monotone (analyze (L := L) (prog := prog)) := fun _ _ hle =>
+  updateAll_mono (joinAll_mono hle)
+
+variable [DecidableEq L]
+
+variable (L prog) in
+/-- Agda: `result` (the least fixpoint of `analyze`). -/
+def result : StateVariables L prog :=
+  Fixedpoint.aFix analyze analyze_mono
+
+variable (L prog) in
+/-- Agda: `result≈analyze-result`. -/
+theorem result_eq : result L prog = analyze (result L prog) :=
+  Fixedpoint.aFix_eq analyze analyze_mono
+
+/-- Agda: `joinForKey-initialState-⊥ᵛ`. -/
+theorem joinForKey_initialState :
+    joinForKey prog.initialState (result L prog) = botV L prog := by
+  rw [joinForKey, prog.incoming_initialState_eq_nil]
+  rfl
+
+/-! ### Semantic correctness (Agda: `WithValidInterpretation`) -/
+
+variable [I : LatticeInterpretation L] [V : ValidStmtEvaluator L prog]
+
+omit [FiniteHeightLattice L] [DecidableEq L] in
+/-- Agda: `eval-fold-valid`. -/
+theorem eval_fold_valid {s : prog.State} {bss : List BasicStmt}
+    {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
+    (hbss : EvalBasicStmts ρ₁ bss ρ₂) (hvs : interpV vs ρ₁) :
+    interpV (bss.foldl (fun vs bs => E.eval s bs vs) vs) ρ₂ := by
+  induction hbss generalizing vs with
+  | nil => exact hvs
+  | cons hbs _ ih => exact ih (ValidStmtEvaluator.valid hbs hvs)
+
+omit [FiniteHeightLattice L] [DecidableEq L] in
+/-- Agda: `updateVariablesForState-matches`. -/
+theorem updateVariablesForState_matches {s : prog.State}
+    {sv : StateVariables L prog} {ρ₁ ρ₂ : Env}
+    (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
+    (hvs : interpV (variablesAt s sv) ρ₁) :
+    interpV (updateVariablesForState s sv) ρ₂ :=
+  eval_fold_valid hbss hvs
+
+omit [FiniteHeightLattice L] [DecidableEq L] in
+/-- Agda: `updateAll-matches`. -/
+theorem updateAll_matches {s : prog.State} {sv : StateVariables L prog}
+    {ρ₁ ρ₂ : Env} (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
+    (hvs : interpV (variablesAt s sv) ρ₁) :
+    interpV (variablesAt s (updateAll sv)) ρ₂ := by
+  rw [variablesAt_updateAll]
+  exact updateVariablesForState_matches hbss hvs
+
+/-- Agda: `stepTrace`. -/
+theorem stepTrace {s₁ : prog.State} {ρ₁ ρ₂ : Env}
+    (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
+    (hbss : EvalBasicStmts ρ₁ (prog.code s₁) ρ₂) :
+    interpV (variablesAt s₁ (result L prog)) ρ₂ := by
+  rw [result_eq L prog]
+  refine updateAll_matches hbss ?_
+  rw [variablesAt_joinAll]
+  exact hjoin
+
+/-- Agda: `walkTrace`. -/
+theorem walkTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
+    (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
+    (tr : Trace prog.graph s₁ s₂ ρ₁ ρ₂) :
+    interpV (variablesAt s₂ (result L prog)) ρ₂ := by
+  induction tr with
+  | single hbss => exact stepTrace hjoin hbss
+  | @edge _ ρ' _ i₁ i₂ _ hbss hedge _ ih =>
+    have hstep : interpV (variablesAt i₁ (result L prog)) ρ' :=
+      stepTrace hjoin hbss
+    have hmem : variablesAt i₁ (result L prog)
+        ∈ (result L prog).valuesAt (prog.incoming i₂) :=
+      FiniteMap.mem_valuesAt prog.states_nodup
+        (prog.mem_incoming_of_edge hedge) (variablesAt_mem i₁ (result L prog))
+    exact ih (interpV_foldr hstep hmem)
+
+omit V in
+/-- Agda: `⟦joinAll-initialState⟧ᵛ∅`. -/
+theorem interpV_joinForKey_initialState :
+    interpV (joinForKey prog.initialState (result L prog)) [] := by
+  rw [joinForKey_initialState]
+  exact interpV_botV_nil
+
+variable (L prog) in
+/-- Agda: `analyze-correct` — the analysis result at the final state soundly
+describes every terminating execution of the program. -/
+theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    interpV (variablesAt prog.finalState (result L prog)) ρ :=
+  walkTrace interpV_joinForKey_initialState (prog.trace hrun)
+
+end Spa

lean/Spa/Analysis/Forward/Adapters.lean

@@ -0,0 +1,75 @@
+/-
+Port of `Analysis/Forward/Adapters.agda` (`ExprToStmtAdapter`).
+
+Correspondence:
+  updateVariablesFromExpression           ↦ updateVariablesFromExpression
+  updateVariablesFromExpression-Mono      ↦ updateVariablesFromExpression_mono
+  (the -k∈ks-≡ / -k∉ks-backward renames   ↦ used directly from FiniteMap)
+  evalᵇ, evalᵇ-Monoʳ                      ↦ evalB, evalB_mono
+  stmtEvaluator (instance)                ↦ instance StmtEvaluator L prog
+  evalᵇ-valid, validStmtEvaluator         ↦ instance ValidStmtEvaluator L prog
+                                            (the Agda `k ≟ˢ k'` case split is
+                                            subsumed by `cases` on `Env.Mem`,
+                                            whose `here` case forces `k' = k`)
+-/
+import Spa.Analysis.Forward.Evaluation
+
+namespace Spa
+
+variable {L : Type} [Lattice L] {prog : Program} [E : ExprEvaluator L prog]
+
+/-- Agda: `updateVariablesFromExpression` — set the single key `k` to the
+value of `e` (the `GeneralizedUpdate` with `ks = [k]`). -/
+def updateVariablesFromExpression (k : String) (e : Expr)
+    (vs : VariableValues L prog) : VariableValues L prog :=
+  FiniteMap.generalizedUpdate id (fun _ vs => E.eval e vs) [k] vs
+
+/-- Agda: `updateVariablesFromExpression-Mono`. -/
+theorem updateVariablesFromExpression_mono (k : String) (e : Expr) :
+    Monotone (updateVariablesFromExpression (L := L) (prog := prog) k e) :=
+  FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => E.eval_mono e)
+
+/-- Agda: `evalᵇ`. -/
+def evalB (_ : prog.State) (bs : BasicStmt)
+    (vs : VariableValues L prog) : VariableValues L prog :=
+  match bs with
+  | .assign k e => updateVariablesFromExpression k e vs
+  | .noop => vs
+
+/-- Agda: `evalᵇ-Monoʳ`. -/
+theorem evalB_mono (s : prog.State) (bs : BasicStmt) :
+    Monotone (evalB (L := L) (prog := prog) s bs) := by
+  cases bs with
+  | assign k e => exact updateVariablesFromExpression_mono k e
+  | noop => exact monotone_id
+
+/-- Agda: the `stmtEvaluator` instance of `ExprToStmtAdapter`. -/
+instance ExprEvaluator.toStmtEvaluator : StmtEvaluator L prog :=
+  ⟨evalB, evalB_mono⟩
+
+/-- Agda: `evalᵇ-valid` / the `validStmtEvaluator` instance. -/
+instance ExprEvaluator.toStmtEvaluator_valid [LatticeInterpretation L]
+    [ValidExprEvaluator L prog] : ValidStmtEvaluator L prog := by
+  constructor
+  intro s vs ρ₁ ρ₂ bs hbs hvs
+  cases hbs with
+  | noop => exact hvs
+  | assign k e v hev =>
+    intro k' l hk'l v' hv'
+    cases hv' with
+    | here =>
+      have hk'l₀ : (k, l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
+          (fun _ vs => E.eval e vs) [k] vs := hk'l
+      have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
+        (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hk'l₀
+      rw [hl]
+      exact ValidExprEvaluator.valid hev hvs
+    | there _ _ _ _ _ hne hmem' =>
+      have hk'l₀ : (k', l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
+          (fun _ vs => E.eval e vs) [k] vs := hk'l
+      have hk'l' : (k', l) ∈ (id vs : VariableValues L prog) :=
+        FiniteMap.generalizedUpdate_not_mem_backward
+          (fun hmem => hne (List.mem_singleton.mp hmem)) hk'l₀
+      exact hvs _ _ hk'l' _ hmem'
+
+end Spa

lean/Spa/Analysis/Forward/Evaluation.lean

@@ -0,0 +1,43 @@
+/-
+Port of `Analysis/Forward/Evaluation.agda`.
+
+All four records were consumed through Agda instance arguments (`{{evaluator :
+StmtEvaluator}}`, `{{validEvaluator : ValidStmtEvaluator …}}`), so they are
+typeclasses here as well.
+
+Correspondence:
+  StmtEvaluator (eval, eval-Monoʳ)  ↦ StmtEvaluator (eval, eval_mono)
+  ExprEvaluator (eval, eval-Monoʳ)  ↦ ExprEvaluator (eval, eval_mono)
+  ValidExprEvaluator                ↦ ValidExprEvaluator (valid)
+  ValidStmtEvaluator                ↦ ValidStmtEvaluator (valid)
+-/
+import Spa.Analysis.Forward.Lattices
+
+namespace Spa
+
+variable (L : Type) [Lattice L] (prog : Program)
+
+/-- Agda: `StmtEvaluator`. -/
+class StmtEvaluator where
+  eval : prog.State → BasicStmt → VariableValues L prog → VariableValues L prog
+  eval_mono : ∀ s bs, Monotone (eval s bs)
+
+/-- Agda: `ExprEvaluator`. -/
+class ExprEvaluator where
+  eval : Expr → VariableValues L prog → L
+  eval_mono : ∀ e, Monotone (eval e)
+
+/-- Agda: `ValidExprEvaluator`. -/
+class ValidExprEvaluator [ExprEvaluator L prog] [I : LatticeInterpretation L] :
+    Prop where
+  valid : ∀ {vs : VariableValues L prog} {ρ : Env} {e : Expr} {v : Value},
+    EvalExpr ρ e v → interpV vs ρ → I.interp (ExprEvaluator.eval e vs) v
+
+/-- Agda: `ValidStmtEvaluator`. -/
+class ValidStmtEvaluator [E : StmtEvaluator L prog] [LatticeInterpretation L] :
+    Prop where
+  valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
+    {bs : BasicStmt},
+    EvalBasicStmt ρ₁ bs ρ₂ → interpV vs ρ₁ → interpV (E.eval s bs vs) ρ₂
+
+end Spa

lean/Spa/Analysis/Forward/Lattices.lean

@@ -0,0 +1,143 @@
+/-
+Port of `Analysis/Forward/Lattices.agda`.
+
+The Agda module instantiates `Lattice.FiniteMap` twice (variables ↦ abstract
+values, states ↦ variable maps) and re-exports everything with ᵛ/ᵐ suffixes.
+In Lean the two instantiations are `abbrev`s and the FiniteMap API is used
+directly; the module parameters (the finite-height lattice `L`, the program)
+become section variables, with the finite-height structure and the lattice
+interpretation arriving by instance resolution as in Agda.
+
+Correspondence:
+  VariableValues, StateVariables  ↦ VariableValues, StateVariables
+  isLatticeᵛ/isLatticeᵐ, ⊔ᵛ, ≼ᵛ … ↦ (the FiniteMap Lattice instances)
+  fixedHeightᵛ, fixedHeightᵐ      ↦ (the FiniteMap FiniteHeightLattice instance)
+  ⊥ᵛ, ⊥ᵛ-contains-bottoms         ↦ botV, FiniteMap.bot_contains_bots
+  states-in-Map                   ↦ states_memKey
+  variablesAt                     ↦ variablesAt
+  variablesAt-∈                   ↦ variablesAt_mem
+  variablesAt-≈                   ↦ (congruence, trivial with `=`)
+  joinForKey, joinForKey-Mono     ↦ joinForKey, joinForKey_mono
+  joinAll, joinAll-Mono,
+  joinAll-k∈ks-≡                  ↦ joinAll, joinAll_mono, joinAll_mem_eq
+  variablesAt-joinAll             ↦ variablesAt_joinAll
+  ⟦_⟧ᵛ                            ↦ interpV
+  ⟦⊥ᵛ⟧ᵛ∅                          ↦ interpV_botV_nil
+  ⟦⟧ᵛ-respects-≈ᵛ                 ↦ (trivial with `=`)
+  ⟦⟧ᵛ-⊔ᵛ-∨                        ↦ interpV_sup
+  ⟦⟧ᵛ-foldr                       ↦ interpV_foldr
+-/
+import Spa.Language
+import Spa.Lattice.FiniteMap
+
+namespace Spa
+
+variable (L : Type) [Lattice L] (prog : Program)
+
+/-- Agda: `VariableValues`. -/
+abbrev VariableValues : Type := FiniteMap String L prog.vars
+
+/-- Agda: `StateVariables`. -/
+abbrev StateVariables : Type := FiniteMap prog.State (VariableValues L prog) prog.states
+
+/-- Agda: `⊥ᵛ` (the bottom of `fixedHeightᵛ`, now found by instance search). -/
+def botV [FiniteHeightLattice L] : VariableValues L prog :=
+  FiniteHeightLattice.bot (VariableValues L prog)
+
+variable {L prog}
+
+omit [Lattice L] in
+/-- Agda: `states-in-Map`. -/
+theorem states_memKey (s : prog.State) (sv : StateVariables L prog) :
+    FiniteMap.MemKey s sv :=
+  FiniteMap.memKey_iff.mpr (prog.states_complete s)
+
+/-- Agda: `variablesAt`. -/
+def variablesAt (s : prog.State) (sv : StateVariables L prog) :
+    VariableValues L prog :=
+  (FiniteMap.locate (states_memKey s sv)).1
+
+omit [Lattice L] in
+/-- Agda: `variablesAt-∈`. -/
+theorem variablesAt_mem (s : prog.State) (sv : StateVariables L prog) :
+    (s, variablesAt s sv) ∈ sv :=
+  (FiniteMap.locate (states_memKey s sv)).2
+
+/-- Agda: `m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ`, specialized the way `Forward.agda` uses it. -/
+theorem variablesAt_le {sv₁ sv₂ : StateVariables L prog} (hle : sv₁ ≤ sv₂)
+    (s : prog.State) : variablesAt s sv₁ ≤ variablesAt s sv₂ :=
+  FiniteMap.le_of_mem_mem prog.states_nodup hle
+    (variablesAt_mem s sv₁) (variablesAt_mem s sv₂)
+
+variable [FiniteHeightLattice L]
+
+/-- Agda: `joinForKey`. -/
+def joinForKey (k : prog.State) (sv : StateVariables L prog) :
+    VariableValues L prog :=
+  (sv.valuesAt (prog.incoming k)).foldr (· ⊔ ·) (botV L prog)
+
+/-- Agda: `joinForKey-Mono`. -/
+theorem joinForKey_mono (k : prog.State) :
+    Monotone (joinForKey (L := L) k) := by
+  intro sv₁ sv₂ hle
+  exact foldr_mono _ (FiniteMap.valuesAt_le hle (prog.incoming k)) (le_refl _)
+    (fun b _ _ hab => sup_le_sup_right hab b)
+    (fun a _ _ hab => sup_le_sup_left hab a)
+
+/-- Agda: `joinAll` (the "Exercise 4.26" generalized update with `f = id`). -/
+def joinAll (sv : StateVariables L prog) : StateVariables L prog :=
+  FiniteMap.generalizedUpdate id joinForKey prog.states sv
+
+/-- Agda: `joinAll-Mono`. -/
+theorem joinAll_mono : Monotone (joinAll (L := L) (prog := prog)) :=
+  FiniteMap.generalizedUpdate_monotone monotone_id joinForKey_mono
+
+/-- Agda: `joinAll-k∈ks-≡`. -/
+theorem joinAll_mem_eq {s : prog.State} {vs : VariableValues L prog}
+    {sv : StateVariables L prog} (h : (s, vs) ∈ joinAll sv) :
+    vs = joinForKey s sv :=
+  FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) h
+
+/-- Agda: `variablesAt-joinAll`. -/
+theorem variablesAt_joinAll (s : prog.State) (sv : StateVariables L prog) :
+    variablesAt s (joinAll sv) = joinForKey s sv :=
+  joinAll_mem_eq (variablesAt_mem s (joinAll sv))
+
+/-! ### Lifting an interpretation to variable maps -/
+
+variable [I : LatticeInterpretation L]
+
+omit [FiniteHeightLattice L] in
+/-- Agda: `⟦_⟧ᵛ`. -/
+def interpV (vs : VariableValues L prog) (ρ : Env) : Prop :=
+  ∀ (k : String) (l : L), (k, l) ∈ vs →
+    ∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v
+
+/-- Agda: `⟦⊥ᵛ⟧ᵛ∅`. -/
+theorem interpV_botV_nil : interpV (botV L prog) [] := by
+  intro k l _ v hmem
+  cases hmem
+
+omit [FiniteHeightLattice L] in
+/-- Agda: `⟦⟧ᵛ-⊔ᵛ-∨`. -/
+theorem interpV_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env}
+    (h : interpV vs₁ ρ ∨ interpV vs₂ ρ) : interpV (vs₁ ⊔ vs₂) ρ := by
+  intro k l hmem v hv
+  obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem
+  rcases h with h | h
+  · exact I.interp_sup v (Or.inl (h _ _ h₁ _ hv))
+  · exact I.interp_sup v (Or.inr (h _ _ h₂ _ hv))
+
+/-- Agda: `⟦⟧ᵛ-foldr`. -/
+theorem interpV_foldr {vs : VariableValues L prog}
+    {vss : List (VariableValues L prog)} {ρ : Env}
+    (hvs : interpV vs ρ) (hmem : vs ∈ vss) :
+    interpV (vss.foldr (· ⊔ ·) (botV L prog)) ρ := by
+  induction vss with
+  | nil => cases hmem
+  | cons vs' vss' ih =>
+    rcases List.mem_cons.mp hmem with rfl | hmem'
+    · exact interpV_sup (Or.inl hvs)
+    · exact interpV_sup (Or.inr (ih hmem'))
+
+end Spa

lean/Spa/Analysis/Sign.lean

@@ -0,0 +1,335 @@
+/-
+Port of `Analysis/Sign.agda`.
+
+Correspondence:
+  Sign (+ / - / 0ˢ)         ↦ Sign.plus / Sign.minus / Sign.zero
+  _≟ᵍ_, ≡-equiv, ≡-Decidable ↦ deriving DecidableEq
+  SignLattice (AboveBelow)  ↦ SignLattice
+  AB.Plain 0ˢ               ↦ the AboveBelow FiniteHeightLattice instance,
+                              seeded by `Inhabited Sign := ⟨.zero⟩`
+  plus, minus               ↦ plus, minus
+  plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
+                            ↦ plus_mono_left/right, minus_mono_left/right —
+                              now actually proved, via
+                              AboveBelow.monotone₂_of_strict
+  plus-Mono₂, minus-Mono₂   ↦ plus_mono₂, minus_mono₂
+  ⟦_⟧ᵍ                      ↦ interpSign
+  ⟦⟧ᵍ-respects-≈ᵍ           ↦ (trivial with `=`)
+  ⟦⟧ᵍ-⊔ᵍ-∨, ⟦⟧ᵍ-⊓ᵍ-∧        ↦ interpSign_sup, interpSign_inf
+  s₁≢s₂⇒¬s₁∧s₂              ↦ interpSign_mk_disjoint
+  latticeInterpretationᵍ    ↦ signInterpretation
+  WithProg.eval, eval-Monoʳ ↦ SignAnalysis.eval, eval_mono
+  SignEval (instance)       ↦ SignAnalysis.exprEvaluator
+  plus-valid, minus-valid   ↦ plus_valid, minus_valid
+  eval-valid, SignEvalValid ↦ eval_valid
+  output                    ↦ SignAnalysis.output
+  analyze-correct           ↦ SignAnalysis.analyze_correct
+-/
+import Spa.Analysis.Forward
+import Spa.Analysis.Utils
+import Spa.Showable
+
+namespace Spa
+
+inductive Sign where
+  | plus
+  | minus
+  | zero
+  deriving DecidableEq
+
+instance : Showable Sign :=
+  ⟨fun
+    | .plus => "+"
+    | .minus => "-"
+    | .zero => "0"⟩
+
+/-- Agda: the module parameter `x = 0ˢ` of `AB.Plain` (it seeds the
+`FiniteHeightLattice (AboveBelow Sign)` instance). -/
+instance : Inhabited Sign := ⟨.zero⟩
+
+abbrev SignLattice : Type := AboveBelow Sign
+
+open AboveBelow in
+/-- Agda: `plus`. -/
+def plus : SignLattice → SignLattice → SignLattice
+  | bot, _ => bot
+  | _, bot => bot
+  | top, _ => top
+  | _, top => top
+  | mk .plus, mk .plus => mk .plus
+  | mk .plus, mk .minus => top
+  | mk .plus, mk .zero => mk .plus
+  | mk .minus, mk .plus => top
+  | mk .minus, mk .minus => mk .minus
+  | mk .minus, mk .zero => mk .minus
+  | mk .zero, mk .plus => mk .plus
+  | mk .zero, mk .minus => mk .minus
+  | mk .zero, mk .zero => mk .zero
+
+open AboveBelow in
+/-- Agda: `minus`. -/
+def minus : SignLattice → SignLattice → SignLattice
+  | bot, _ => bot
+  | _, bot => bot
+  | top, _ => top
+  | _, top => top
+  | mk .plus, mk .plus => top
+  | mk .plus, mk .minus => mk .plus
+  | mk .plus, mk .zero => mk .plus
+  | mk .minus, mk .plus => mk .minus
+  | mk .minus, mk .minus => top
+  | mk .minus, mk .zero => mk .minus
+  | mk .zero, mk .plus => mk .minus
+  | mk .zero, mk .minus => mk .plus
+  | mk .zero, mk .zero => mk .zero
+
+/-- Agda: `plus-Mono₂` (its components were postulates in Agda; `plus` is a
+strict operation on the flat lattice, so monotonicity holds regardless of the
+sign table). -/
+theorem plus_mono₂ : Monotone₂ plus :=
+  AboveBelow.monotone₂_of_strict plus
+    (fun y => by cases y <;> rfl)
+    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
+    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun x hx => by
+      rcases x with _ | _ | s <;>
+        first | exact absurd rfl hx | rfl | (cases s <;> rfl))
+
+/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
+theorem plus_mono_left (s₂ : SignLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
+
+/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
+theorem plus_mono_right (s₁ : SignLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
+
+/-- Agda: `minus-Mono₂` (likewise from strictness of `minus`). -/
+theorem minus_mono₂ : Monotone₂ minus :=
+  AboveBelow.monotone₂_of_strict minus
+    (fun y => by cases y <;> rfl)
+    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
+    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun x hx => by
+      rcases x with _ | _ | s <;>
+        first | exact absurd rfl hx | rfl | (cases s <;> rfl))
+
+/-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/
+theorem minus_mono_left (s₂ : SignLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
+
+/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
+theorem minus_mono_right (s₁ : SignLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
+
+/-- Agda: `⟦_⟧ᵍ`. -/
+def interpSign : SignLattice → Value → Prop
+  | .bot, _ => False
+  | .top, _ => True
+  | .mk .plus, v => ∃ n : ℕ, v = .int (n + 1)
+  | .mk .zero, v => v = .int 0
+  | .mk .minus, v => ∃ n : ℕ, v = .int (-(n + 1))
+
+/-- Agda: `s₁≢s₂⇒¬s₁∧s₂`. -/
+theorem interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Value} :
+    ¬(interpSign (.mk s₁) v ∧ interpSign (.mk s₂) v) := by
+  rintro ⟨h₁, h₂⟩
+  rcases s₁ <;> rcases s₂ <;> try exact hne rfl
+  all_goals simp only [interpSign] at h₁ h₂
+  · obtain ⟨n₁, rfl⟩ := h₁
+    obtain ⟨n₂, hv⟩ := h₂
+    injection hv with hz
+    omega
+  · obtain ⟨n₁, rfl⟩ := h₁
+    injection h₂ with hz
+    omega
+  · obtain ⟨n₁, rfl⟩ := h₁
+    obtain ⟨n₂, hv⟩ := h₂
+    injection hv with hz
+    omega
+  · obtain ⟨n₁, rfl⟩ := h₁
+    injection h₂ with hz
+    omega
+  · subst h₁
+    obtain ⟨n₂, hv⟩ := h₂
+    injection hv with hz
+    omega
+  · subst h₁
+    obtain ⟨n₂, hv⟩ := h₂
+    injection hv with hz
+    omega
+
+/-- Agda: `⟦⟧ᵍ-⊔ᵍ-∨` (via the factored flat-lattice lemma). -/
+theorem interpSign_sup {s₁ s₂ : SignLattice} (v : Value)
+    (h : interpSign s₁ v ∨ interpSign s₂ v) : interpSign (s₁ ⊔ s₂) v :=
+  AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
+
+/-- Agda: `⟦⟧ᵍ-⊓ᵍ-∧` (via the factored flat-lattice lemma). -/
+theorem interpSign_inf {s₁ s₂ : SignLattice} (v : Value)
+    (h : interpSign s₁ v ∧ interpSign s₂ v) : interpSign (s₁ ⊓ s₂) v :=
+  AboveBelow.interp_inf_of (fun hne _ => interpSign_mk_disjoint hne) v h
+
+/-- Agda: `latticeInterpretationᵍ` (an instance there too). -/
+instance signInterpretation : LatticeInterpretation SignLattice where
+  interp := interpSign
+  interp_sup := fun {l₁ l₂} v h => interpSign_sup (s₁ := l₁) (s₂ := l₂) v h
+  interp_inf := fun {l₁ l₂} v h => interpSign_inf (s₁ := l₁) (s₂ := l₂) v h
+
+namespace SignAnalysis
+
+/-! Agda: `module WithProg (prog : Program)`. -/
+
+variable (prog : Program)
+
+/-- Agda: `WithProg.eval`. -/
+def eval : Expr → VariableValues SignLattice prog → SignLattice
+  | .add e₁ e₂, vs => plus (eval e₁ vs) (eval e₂ vs)
+  | .sub e₁ e₂, vs => minus (eval e₁ vs) (eval e₂ vs)
+  | .var k, vs =>
+    if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
+  | .num 0, _ => .mk .zero
+  | .num (_ + 1), _ => .mk .plus
+
+/-- Agda: `WithProg.eval-Monoʳ`. -/
+theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
+  induction e with
+  | add e₁ e₂ ih₁ ih₂ =>
+    intro vs₁ vs₂ h
+    exact eval_combine₂ plus_mono₂ (ih₁ h) (ih₂ h)
+  | sub e₁ e₂ ih₁ ih₂ =>
+    intro vs₁ vs₂ h
+    exact eval_combine₂ minus_mono₂ (ih₁ h) (ih₂ h)
+  | var k =>
+    intro vs₁ vs₂ h
+    simp only [eval]
+    by_cases hk : k ∈ prog.vars
+    · rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
+          dif_pos (FiniteMap.memKey_iff.mpr hk)]
+      exact FiniteMap.le_of_mem_mem prog.vars_nodup h
+        (FiniteMap.locate _).2 (FiniteMap.locate _).2
+    · rw [dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm)),
+          dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm))]
+  | num n =>
+    intro vs₁ vs₂ _
+    cases n <;> exact le_refl _
+
+/-- Agda: the `SignEval` instance. -/
+instance exprEvaluator : ExprEvaluator SignLattice prog :=
+  ⟨eval prog, eval_mono prog⟩
+
+/-- Agda: `WithProg.result`/`output` — the analysis result, printed. -/
+def output : String :=
+  show' (result SignLattice prog)
+
+/-- Agda: `plus-valid`. -/
+theorem plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
+    (h₁ : interpSign g₁ (.int z₁)) (h₂ : interpSign g₂ (.int z₂)) :
+    interpSign (plus g₁ g₂) (.int (z₁ + z₂)) := by
+  rcases g₁ with _ | _ | s₁
+  · exact h₁.elim
+  · rcases g₂ with _ | _ | s₂
+    · exact h₂.elim
+    · exact trivial
+    · exact trivial
+  · rcases g₂ with _ | _ | s₂
+    · exact h₂.elim
+    · rcases s₁ <;> exact trivial
+    · rcases s₁ <;> rcases s₂ <;>
+        simp only [plus, interpSign, Value.int.injEq] at h₁ h₂ ⊢ <;>
+        try trivial
+      · obtain ⟨n₁, rfl⟩ := h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₁ + n₂ + 1, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        subst h₂
+        exact ⟨n₁, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₁ + n₂ + 1, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        subst h₂
+        exact ⟨n₁, by omega⟩
+      · subst h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₂, by omega⟩
+      · subst h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₂, by omega⟩
+      · subst h₁
+        subst h₂
+        omega
+
+/-- Agda: `minus-valid`. -/
+theorem minus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
+    (h₁ : interpSign g₁ (.int z₁)) (h₂ : interpSign g₂ (.int z₂)) :
+    interpSign (minus g₁ g₂) (.int (z₁ - z₂)) := by
+  rcases g₁ with _ | _ | s₁
+  · exact h₁.elim
+  · rcases g₂ with _ | _ | s₂
+    · exact h₂.elim
+    · exact trivial
+    · exact trivial
+  · rcases g₂ with _ | _ | s₂
+    · exact h₂.elim
+    · rcases s₁ <;> exact trivial
+    · rcases s₁ <;> rcases s₂ <;>
+        simp only [minus, interpSign, Value.int.injEq] at h₁ h₂ ⊢ <;>
+        try trivial
+      · obtain ⟨n₁, rfl⟩ := h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₁ + n₂ + 1, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        subst h₂
+        exact ⟨n₁, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₁ + n₂ + 1, by omega⟩
+      · obtain ⟨n₁, rfl⟩ := h₁
+        subst h₂
+        exact ⟨n₁, by omega⟩
+      · subst h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₂, by omega⟩
+      · subst h₁
+        obtain ⟨n₂, rfl⟩ := h₂
+        exact ⟨n₂, by omega⟩
+      · subst h₁
+        subst h₂
+        omega
+
+/-- Agda: `eval-valid` / the `SignEvalValid` instance. -/
+instance eval_valid : ValidExprEvaluator SignLattice prog := by
+  constructor
+  intro vs ρ e v hev
+  induction hev with
+  | num n =>
+    intro _
+    show interpSign (eval prog (.num n) vs) (.int n)
+    cases n with
+    | zero => rfl
+    | succ n' => exact ⟨n', congrArg Value.int (by push_cast; ring)⟩
+  | var x v hxv =>
+    intro hvs
+    show interpSign (eval prog (.var x) vs) v
+    simp only [eval]
+    by_cases hk : FiniteMap.MemKey x vs
+    · rw [dif_pos hk]
+      exact hvs _ _ (FiniteMap.locate hk).2 _ hxv
+    · rw [dif_neg hk]
+      exact trivial
+  | add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
+    intro hvs
+    have h₁ : interpSign (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₂ : interpSign (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    show interpSign (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
+    exact plus_valid h₁ h₂
+  | sub e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
+    intro hvs
+    have h₁ : interpSign (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₂ : interpSign (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    show interpSign (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
+    exact minus_valid h₁ h₂
+
+/-- Agda: `WithProg.analyze-correct`. -/
+theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    interpV (variablesAt prog.finalState (result SignLattice prog)) ρ :=
+  Spa.analyze_correct SignLattice prog hrun
+
+end SignAnalysis
+
+end Spa

lean/Spa/Analysis/Utils.lean

@@ -0,0 +1,15 @@
+/-
+Port of `Analysis/Utils.agda`. The `≼ᴼ-trans` module parameter lifts into the
+`Preorder` instance.
+-/
+import Spa.Lattice
+
+namespace Spa
+
+/-- Agda: `eval-combine₂`. -/
+theorem eval_combine₂ {O : Type*} [Preorder O] {combine : O → O → O}
+    (hmono : Monotone₂ combine) {o₁ o₂ o₃ o₄ : O}
+    (h₁ : o₁ ≤ o₃) (h₂ : o₂ ≤ o₄) : combine o₁ o₂ ≤ combine o₃ o₄ :=
+  le_trans (hmono.1 o₂ h₁) (hmono.2 o₃ h₂)
+
+end Spa

lean/Spa/Fixedpoint.lean

@@ -0,0 +1,82 @@
+/-
+Port of `Fixedpoint.agda`.
+
+Same gas-based algorithm: iterate `f` starting at the chain-bottom `⊥`; since
+the lattice has fixed height `h`, a fixed point must be reached within `h + 1`
+steps, or we would build a `<`-chain longer than the longest one. We
+deliberately do *not* use mathlib's `OrderHom.lfp` (different proof approach,
+and not computable).
+
+As in Agda — where the module took `{{flA : IsFiniteHeightLattice A h …}}` —
+the finite-height structure arrives by instance resolution
+(`[FiniteHeightLattice α]`); only `f` and its monotonicity are explicit.
+
+Correspondence:
+  doStep             ↦ Spa.Fixedpoint.doStep   (the chain argument now carries
+                                                 `a₁ = ⊥` and its length in the
+                                                 `LTSeries` structure itself)
+  fix                ↦ Spa.Fixedpoint.fix
+  aᶠ                 ↦ Spa.Fixedpoint.aFix
+  aᶠ≈faᶠ             ↦ Spa.Fixedpoint.aFix_eq
+  stepPreservesLess  ↦ Spa.Fixedpoint.doStep_le
+  aᶠ≼                ↦ Spa.Fixedpoint.aFix_le
+-/
+import Spa.Lattice
+
+namespace Spa.Fixedpoint
+
+open FiniteHeightLattice (height fixedHeight)
+
+variable {α : Type*} [Lattice α] [DecidableEq α] [FiniteHeightLattice α]
+
+/-- Agda: `doStep`. `g` is gas; the invariant `c.length + g = h + 1` guarantees
+that when gas runs out the chain contradicts boundedness. -/
+def doStep (f : α → α) (hf : Monotone f) :
+    ∀ (g : ℕ) (c : LTSeries α), c.length + g = height (α := α) + 1 →
+      c.last ≤ f c.last → {a : α // a = f a}
+  | 0, c, hlen, _ =>
+    absurd ((fixedHeight (α := α)).bounded c) (by omega)
+  | g + 1, c, hlen, hle =>
+    if heq : c.last = f c.last then
+      ⟨c.last, heq⟩
+    else
+      doStep f hf g (c.snoc (f c.last) (lt_of_le_of_ne hle heq))
+        (by simp [RelSeries.snoc]; omega)
+        (by rw [RelSeries.last_snoc]; exact hf hle)
+
+/-- Agda: `fix`. Start iterating from `⊥`. -/
+def fix (f : α → α) (hf : Monotone f) : {a : α // a = f a} :=
+  doStep f hf (height (α := α) + 1) (RelSeries.singleton _ (FiniteHeightLattice.bot α))
+    (by simp)
+    (by simpa [RelSeries.last_singleton]
+          using FiniteHeightLattice.bot_le α (f (FiniteHeightLattice.bot α)))
+
+/-- Agda: `aᶠ`. -/
+def aFix (f : α → α) (hf : Monotone f) : α :=
+  (fix f hf).1
+
+/-- Agda: `aᶠ≈faᶠ`. -/
+theorem aFix_eq (f : α → α) (hf : Monotone f) :
+    aFix f hf = f (aFix f hf) :=
+  (fix f hf).2
+
+/-- Agda: `stepPreservesLess` — iteration stays below any fixed point. -/
+theorem doStep_le (f : α → α) (hf : Monotone f)
+    {b : α} (hb : b = f b) :
+    ∀ (g : ℕ) (c : LTSeries α) (hlen : c.length + g = height (α := α) + 1)
+      (hle : c.last ≤ f c.last), c.last ≤ b →
+      (doStep f hf g c hlen hle : α) ≤ b
+  | 0, c, hlen, _ => fun _ => absurd ((fixedHeight (α := α)).bounded c) (by omega)
+  | g + 1, c, hlen, hle => fun hcb => by
+    rw [doStep]
+    split
+    · exact hcb
+    · exact doStep_le f hf hb g _ _ _
+        (by rw [RelSeries.last_snoc]; exact le_of_le_of_eq (hf hcb) hb.symm)
+
+/-- Agda: `aᶠ≼` — `aFix` is below every fixed point of `f`. -/
+theorem aFix_le (f : α → α) (hf : Monotone f)
+    {a : α} (ha : a = f a) : aFix f hf ≤ a :=
+  doStep_le f hf ha _ _ _ _ (by simpa using FiniteHeightLattice.bot_le α a)
+
+end Spa.Fixedpoint

lean/Spa/Isomorphism.lean

@@ -0,0 +1,58 @@
+/-
+Port of `Isomorphism.agda` (`TransportFiniteHeight`).
+
+With propositional equality this module shrinks dramatically: the Agda
+hypotheses `f-preserves-≈`, `g-preserves-≈` are free, and `f-⊔-distr` /
+`g-⊔-distr` (which in the setoid world encoded monotonicity of `f` and `g`
+w.r.t. the derived order) become plain `Monotone` hypotheses. The chain
+transport `portChain₁` / `portChain₂` is mathlib's `LTSeries.map`, using that
+a monotone injective map between partial orders is strictly monotone.
+
+Correspondence:
+  IsInverseˡ / IsInverseʳ     ↦ explicit inverse hypotheses `hfg` / `hgf`
+  f-Injective / g-Injective   ↦ local `Function.LeftInverse.injective`
+  portChain₁ / portChain₂     ↦ LTSeries.map
+  instance fixedHeight        ↦ Spa.FixedHeight.transport
+  isFiniteHeightLattice,
+  finiteHeightLattice         ↦ Spa.FiniteHeightLattice.transport
+-/
+import Spa.Lattice
+
+namespace Spa
+
+namespace FixedHeight
+
+variable {α β : Type*} [PartialOrder α] [PartialOrder β] {h : ℕ}
+
+/-- Agda: `TransportFiniteHeight.fixedHeight`. Transport a `FixedHeight`
+structure along a monotone inverse pair `f : α → β`, `g : β → α`. -/
+def transport (fh : FixedHeight α h) (f : α → β) (g : β → α)
+    (hf : Monotone f) (hg : Monotone g)
+    (hgf : ∀ a, g (f a) = a) (hfg : ∀ b, f (g b) = b) :
+    FixedHeight β h where
+  bot := f fh.bot
+  top := f fh.top
+  longestChain :=
+    fh.longestChain.map f
+      (hf.strictMono_of_injective (Function.LeftInverse.injective hgf))
+  head_longestChain := by
+    rw [LTSeries.head_map, fh.head_longestChain]
+  last_longestChain := by
+    rw [LTSeries.last_map, fh.last_longestChain]
+  length_longestChain := fh.length_longestChain
+  bounded := fun c =>
+    fh.bounded
+      (c.map g (hg.strictMono_of_injective (Function.LeftInverse.injective hfg)))
+
+end FixedHeight
+
+/-- Agda: `TransportFiniteHeight.finiteHeightLattice`. -/
+def FiniteHeightLattice.transport {α β : Type*} [Lattice α] [Lattice β]
+    (I : FiniteHeightLattice α) (f : α → β) (g : β → α)
+    (hf : Monotone f) (hg : Monotone g)
+    (hgf : ∀ a, g (f a) = a) (hfg : ∀ b, f (g b) = b) :
+    FiniteHeightLattice β where
+  height := I.height
+  fixedHeight := I.fixedHeight.transport f g hf hg hgf hfg
+
+end Spa

lean/Spa/Language.lean

@@ -0,0 +1,90 @@
+/-
+Port of `Language.agda` (the `Program` record and re-exports).
+
+Correspondence:
+  Program record      ↦ structure Program (defs in the `Program` namespace)
+  graph               ↦ Program.graph
+  State               ↦ Program.State
+  initialState        ↦ Program.initialState
+  finalState          ↦ Program.finalState
+  trace               ↦ Program.trace
+  vars, vars-Unique   ↦ Program.vars, Program.vars_nodup
+                        (Finset.toList + Finset.nodup_toList replace
+                        `to-Listˢ` and the intrinsic MapSet uniqueness)
+  states, states-complete, states-Unique
+                      ↦ Program.states, .states_complete, .states_nodup
+  code                ↦ Program.code
+  _≟_, _≟ᵉ_           ↦ (instances, automatic for Fin/products)
+  incoming            ↦ Program.incoming
+  initialState-pred-∅ ↦ Program.incoming_initialState_eq_nil
+  edge⇒incoming       ↦ Program.mem_incoming_of_edge
+-/
+import Spa.Language.Base
+import Spa.Language.Semantics
+import Spa.Language.Graphs
+import Spa.Language.Traces
+import Spa.Language.Properties
+import Mathlib.Data.Finset.Sort
+import Mathlib.Data.String.Basic
+
+namespace Spa
+
+structure Program where
+  rootStmt : Stmt
+
+namespace Program
+
+variable (p : Program)
+
+def graph : Graph := Graph.wrap (buildCfg p.rootStmt)
+
+abbrev State : Type := p.graph.Index
+
+def initialState : p.State := (buildCfg p.rootStmt).wrapInput
+
+def finalState : p.State := (buildCfg p.rootStmt).wrapOutput
+
+/-- Agda: `Program.trace`. -/
+theorem trace {ρ : Env} (h : EvalStmt [] p.rootStmt ρ) :
+    Trace p.graph p.initialState p.finalState [] ρ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := EndToEndTrace.wrap (buildCfg_sufficient h)
+  rw [Graph.wrap_inputs, List.mem_singleton] at h₁
+  rw [Graph.wrap_outputs, List.mem_singleton] at h₂
+  subst h₁; subst h₂
+  exact tr
+
+/-- Agda: `vars` (via `vars-Set = Stmt-vars rootStmt`). `Finset.toList` is
+noncomputable, so the variables are listed in sorted order instead — this is
+the computable stand-in for MapSet's `to-List`. -/
+def vars : List String := p.rootStmt.vars.sort (· ≤ ·)
+
+/-- Agda: `vars-Unique`. -/
+theorem vars_nodup : p.vars.Nodup := Finset.sort_nodup _ _
+
+def states : List p.State := p.graph.indices
+
+/-- Agda: `states-complete`. -/
+theorem states_complete (s : p.State) : s ∈ p.states := p.graph.mem_indices s
+
+/-- Agda: `states-Unique`. -/
+theorem states_nodup : p.states.Nodup := p.graph.nodup_indices
+
+/-- Agda: `code`. -/
+def code (st : p.State) : List BasicStmt := p.graph.nodes st
+
+/-- Agda: `incoming`. -/
+def incoming (s : p.State) : List p.State := p.graph.predecessors s
+
+/-- Agda: `initialState-pred-∅`. -/
+theorem incoming_initialState_eq_nil : p.incoming p.initialState = [] :=
+  Graph.wrap_predecessors_eq_nil (buildCfg p.rootStmt) p.initialState
+    (by rw [Graph.wrap_inputs]; exact List.mem_singleton_self _)
+
+/-- Agda: `edge⇒incoming`. -/
+theorem mem_incoming_of_edge {s₁ s₂ : p.State}
+    (h : (s₁, s₂) ∈ p.graph.edges) : s₁ ∈ p.incoming s₂ :=
+  p.graph.mem_predecessors_of_edge h
+
+end Program
+
+end Spa

lean/Spa/Language/Base.lean

@@ -0,0 +1,78 @@
+/-
+Port of `Language/Base.agda`.
+
+`StringSet` (built on `Lattice/MapSet.agda`, itself on `Lattice/Map.agda`) is
+lifted to mathlib's `Finset String`: `insertˢ ↦ insert`, `emptyˢ ↦ ∅`,
+`singletonˢ ↦ {·}`, `_⊔ˢ_ ↦ ∪`, `to-List ↦ Finset.toList` (with
+`Finset.nodup_toList` standing in for the intrinsic `Unique` proof).
+
+Constructor renaming (Agda mixfix has no direct Lean counterpart):
+  _+_ ↦ Expr.add      _-_ ↦ Expr.sub     `_ ↦ Expr.var    #_ ↦ Expr.num
+  _←_ ↦ BasicStmt.assign              noop ↦ BasicStmt.noop
+  ⟨_⟩ ↦ Stmt.basic    _then_ ↦ Stmt.andThen
+  if_then_else_ ↦ Stmt.ifElse         while_repeat_ ↦ Stmt.whileLoop
+
+The `_∈ᵉ_` / `_∈ᵇ_` variable-occurrence relations are ported as
+`Expr.HasVar` / `BasicStmt.HasVar`; the commented-out lemmas relating them to
+`Expr-vars` remain unported (they were commented out in the Agda, too).
+-/
+import Mathlib.Data.Finset.Basic
+
+namespace Spa
+
+inductive Expr where
+  | add (e₁ e₂ : Expr)
+  | sub (e₁ e₂ : Expr)
+  | var (x : String)
+  | num (n : ℕ)
+  deriving DecidableEq
+
+inductive BasicStmt where
+  | assign (x : String) (e : Expr)
+  | noop
+  deriving DecidableEq
+
+inductive Stmt where
+  | basic (bs : BasicStmt)
+  | andThen (s₁ s₂ : Stmt)
+  | ifElse (e : Expr) (s₁ s₂ : Stmt)
+  | whileLoop (e : Expr) (s : Stmt)
+  deriving DecidableEq
+
+/-- Agda: `_∈ᵉ_`. -/
+inductive Expr.HasVar : String → Expr → Prop
+  | addLeft {e₁ e₂ k} : Expr.HasVar k e₁ → Expr.HasVar k (.add e₁ e₂)
+  | addRight {e₁ e₂ k} : Expr.HasVar k e₂ → Expr.HasVar k (.add e₁ e₂)
+  | subLeft {e₁ e₂ k} : Expr.HasVar k e₁ → Expr.HasVar k (.sub e₁ e₂)
+  | subRight {e₁ e₂ k} : Expr.HasVar k e₂ → Expr.HasVar k (.sub e₁ e₂)
+  | here {k} : Expr.HasVar k (.var k)
+
+/-- Agda: `_∈ᵇ_`. -/
+inductive BasicStmt.HasVar : String → BasicStmt → Prop
+  | assignLeft {k e} : BasicStmt.HasVar k (.assign k e)
+  | assignRight {k k' e} : Expr.HasVar k e → BasicStmt.HasVar k (.assign k' e)
+
+/-- Agda: `Expr-vars`. -/
+def Expr.vars : Expr → Finset String
+  | .add l r => l.vars ∪ r.vars
+  | .sub l r => l.vars ∪ r.vars
+  | .var s => {s}
+  | .num _ => ∅
+
+/-- Agda: `BasicStmt-vars`. -/
+def BasicStmt.vars : BasicStmt → Finset String
+  | .assign x e => {x} ∪ e.vars
+  | .noop => ∅
+
+/-- Agda: `Stmt-vars`. -/
+def Stmt.vars : Stmt → Finset String
+  | .basic bs => bs.vars
+  | .andThen s₁ s₂ => s₁.vars ∪ s₂.vars
+  | .ifElse e s₁ s₂ => (e.vars ∪ s₁.vars) ∪ s₂.vars
+  | .whileLoop e s => e.vars ∪ s.vars
+
+/-- Agda: `Stmts-vars`. -/
+def Stmt.varsList (ss : List Stmt) : Finset String :=
+  ss.foldr (fun s acc => s.vars ∪ acc) ∅
+
+end Spa

lean/Spa/Language/Graphs.lean

@@ -0,0 +1,169 @@
+/-
+Port of `Language/Graphs.agda`.
+
+Representation note: `nodes : Vec (List BasicStmt) size` becomes
+`nodes : Fin size → List BasicStmt`. With that, the `Data.Vec` lookup/append
+lemma stack (`lookup-++ˡ/ʳ`, `cast-is-id`, …) lifts into mathlib's
+`Fin.append` with `Fin.append_left` / `Fin.append_right`.
+
+Correspondence:
+  _↑ˡ_/_↑ʳ_ (on Fin)  ↦ Fin.castAdd / Fin.natAdd (mathlib)
+  _↑ˡⁱ_/_↑ʳⁱ_         ↦ liftIdxL / liftIdxR
+  _↑ˡᵉ_/_↑ʳᵉ_         ↦ liftEdgeL / liftEdgeR
+  _∙_                 ↦ Graph.comp   (scoped notation ∙)
+  _↦_                 ↦ Graph.link   (scoped notation ⤳)
+  loop                ↦ Graph.loop
+  _skipto_            ↦ Graph.skipto
+  _[_]                ↦ Graph.nodes (plain application)
+  singleton, wrap     ↦ Graph.singleton, Graph.wrap
+  buildCfg            ↦ buildCfg
+  indices             ↦ List.finRange (mathlib; `fins` from Utils.agda)
+  indices-complete    ↦ List.mem_finRange
+  indices-Unique      ↦ List.nodup_finRange
+  predecessors        ↦ Graph.predecessors
+  edge⇒predecessor    ↦ Graph.mem_predecessors_of_edge
+  predecessor⇒edge    ↦ Graph.edge_of_mem_predecessors
+-/
+import Spa.Language.Base
+import Mathlib.Data.Fin.Tuple.Basic
+import Mathlib.Data.List.ProdSigma
+import Mathlib.Data.List.FinRange
+
+namespace Spa
+
+structure Graph where
+  size : ℕ
+  nodes : Fin size → List BasicStmt
+  edges : List (Fin size × Fin size)
+  inputs : List (Fin size)
+  outputs : List (Fin size)
+
+namespace Graph
+
+abbrev Index (g : Graph) : Type := Fin g.size
+
+abbrev Edge (g : Graph) : Type := g.Index × g.Index
+
+/-- Agda: `_↑ˡⁱ_`. -/
+def liftIdxL {n : ℕ} (l : List (Fin n)) (m : ℕ) : List (Fin (n + m)) :=
+  l.map (Fin.castAdd m)
+
+/-- Agda: `_↑ʳⁱ_`. -/
+def liftIdxR (n : ℕ) {m : ℕ} (l : List (Fin m)) : List (Fin (n + m)) :=
+  l.map (Fin.natAdd n)
+
+/-- Agda: `_↑ˡᵉ_` (with `_↑ˡ_` on pairs inlined). -/
+def liftEdgeL {n : ℕ} (l : List (Fin n × Fin n)) (m : ℕ) :
+    List (Fin (n + m) × Fin (n + m)) :=
+  l.map (fun e => (e.1.castAdd m, e.2.castAdd m))
+
+/-- Agda: `_↑ʳᵉ_` (with `_↑ʳ_` on pairs inlined). -/
+def liftEdgeR (n : ℕ) {m : ℕ} (l : List (Fin m × Fin m)) :
+    List (Fin (n + m) × Fin (n + m)) :=
+  l.map (fun e => (e.1.natAdd n, e.2.natAdd n))
+
+/-- Agda: `_∙_` — disjoint union. -/
+def comp (g₁ g₂ : Graph) : Graph where
+  size := g₁.size + g₂.size
+  nodes := Fin.append g₁.nodes g₂.nodes
+  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges
+  inputs := liftIdxL g₁.inputs g₂.size ++ liftIdxR g₁.size g₂.inputs
+  outputs := liftIdxL g₁.outputs g₂.size ++ liftIdxR g₁.size g₂.outputs
+
+@[inherit_doc] scoped infixr:70 " ∙ " => Graph.comp
+
+/-- Agda: `_↦_` — sequencing: all outputs of `g₁` feed all inputs of `g₂`. -/
+def link (g₁ g₂ : Graph) : Graph where
+  size := g₁.size + g₂.size
+  nodes := Fin.append g₁.nodes g₂.nodes
+  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges ++
+    (liftIdxL g₁.outputs g₂.size).product (liftIdxR g₁.size g₂.inputs)
+  inputs := liftIdxL g₁.inputs g₂.size
+  outputs := liftIdxR g₁.size g₂.outputs
+
+@[inherit_doc] scoped infixr:70 " ⤳ " => Graph.link
+
+/-- The entry node of a `loop` graph. -/
+def loopIn (g : Graph) : Fin (2 + g.size) := (0 : Fin 2).castAdd g.size
+
+/-- The exit node of a `loop` graph. -/
+def loopOut (g : Graph) : Fin (2 + g.size) := (1 : Fin 2).castAdd g.size
+
+/-- Agda: `loop`. -/
+def loop (g : Graph) : Graph where
+  size := 2 + g.size
+  nodes := Fin.append (fun _ : Fin 2 => []) g.nodes
+  edges := liftEdgeR 2 g.edges ++
+    (liftIdxR 2 g.inputs).map (g.loopIn, ·) ++
+    (liftIdxR 2 g.outputs).map (·, g.loopOut) ++
+    [(g.loopOut, g.loopIn), (g.loopIn, g.loopOut)]
+  inputs := [g.loopIn]
+  outputs := [g.loopOut]
+
+@[simp] theorem loop_inputs (g : Graph) : (loop g).inputs = [g.loopIn] := rfl
+
+@[simp] theorem loop_outputs (g : Graph) : (loop g).outputs = [g.loopOut] := rfl
+
+/-- Agda: `_skipto_` (unused by `buildCfg`, ported for parity). -/
+def skipto (g₁ g₂ : Graph) : Graph where
+  size := g₁.size + g₂.size
+  nodes := Fin.append g₁.nodes g₂.nodes
+  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges ++
+    (liftIdxL g₁.inputs g₂.size).product (liftIdxR g₁.size g₂.inputs)
+  inputs := liftIdxL g₁.inputs g₂.size
+  outputs := liftIdxR g₁.size g₂.inputs
+
+/-- Agda: `singleton`. -/
+def singleton (bss : List BasicStmt) : Graph where
+  size := 1
+  nodes := fun _ => bss
+  edges := []
+  inputs := [0]
+  outputs := [0]
+
+/-- Agda: `wrap`. -/
+def wrap (g : Graph) : Graph :=
+  singleton [] ⤳ g ⤳ singleton []
+
+end Graph
+
+open Graph in
+/-- Agda: `buildCfg`. -/
+def buildCfg : Stmt → Graph
+  | .basic bs => Graph.singleton [bs]
+  | .andThen s₁ s₂ => buildCfg s₁ ⤳ buildCfg s₂
+  | .ifElse _ s₁ s₂ => buildCfg s₁ ∙ buildCfg s₂
+  | .whileLoop _ s => Graph.loop (buildCfg s)
+
+namespace Graph
+
+variable (g : Graph)
+
+/-- Agda: `indices` (`fins` is mathlib's `List.finRange`). -/
+def indices : List g.Index := List.finRange g.size
+
+/-- Agda: `indices-complete`. -/
+theorem mem_indices (idx : g.Index) : idx ∈ g.indices :=
+  List.mem_finRange idx
+
+/-- Agda: `indices-Unique`. -/
+theorem nodup_indices : g.indices.Nodup :=
+  List.nodup_finRange g.size
+
+/-- Agda: `predecessors`. -/
+def predecessors (idx : g.Index) : List g.Index :=
+  g.indices.filter (fun idx' => (idx', idx) ∈ g.edges)
+
+/-- Agda: `edge⇒predecessor`. -/
+theorem mem_predecessors_of_edge {idx₁ idx₂ : g.Index}
+    (h : (idx₁, idx₂) ∈ g.edges) : idx₁ ∈ g.predecessors idx₂ :=
+  List.mem_filter.mpr ⟨g.mem_indices idx₁, by simpa using h⟩
+
+/-- Agda: `predecessor⇒edge`. -/
+theorem edge_of_mem_predecessors {idx₁ idx₂ : g.Index}
+    (h : idx₁ ∈ g.predecessors idx₂) : (idx₁, idx₂) ∈ g.edges := by
+  simpa using (List.mem_filter.mp h).2
+
+end Graph
+
+end Spa

lean/Spa/Language/Properties.lean

@@ -0,0 +1,282 @@
+/-
+Port of `Language/Properties.agda`.
+
+Correspondence:
+  ↑-≢ (and the whole "ugly" Fin-disjointness block:
+    idx→f∉↑ʳᵉ, idx→f∉pair, idx→f∉cart, help, helpAll)
+                          ↦ Fin.castAdd_ne_natAdd + not_mem_edges_castAdd_link
+                            (mathlib `List.mem_append`/`mem_map`/`mem_product`
+                            replace the hand-rolled membership eliminations)
+  wrap-preds-∅            ↦ wrap_predecessors_eq_nil
+  wrap-input, wrap-output ↦ Graph.wrapInput/wrapOutput + wrap_inputs/wrap_outputs
+  Trace-∙ˡ/ʳ              ↦ Trace.comp_left / Trace.comp_right
+  Trace-↦ˡ/ʳ              ↦ Trace.link_left / Trace.link_right
+  Trace-loop              ↦ Trace.loop
+  EndToEndTrace-∙ˡ/ʳ      ↦ EndToEndTrace.comp_left / .comp_right
+  loop-edge-groups,
+  loop-edge-help          ↦ (inlined: the four edge groups are reached through
+                            `List.mem_append` directly)
+  EndToEndTrace-loop      ↦ EndToEndTrace.loop
+  EndToEndTrace-loop²     ↦ EndToEndTrace.loop_concat
+  EndToEndTrace-loop⁰     ↦ EndToEndTrace.loop_empty
+  _++_                    ↦ EndToEndTrace.concat
+  EndToEndTrace-singleton ↦ EndToEndTrace.singleton (+ .singleton_nil)
+  EndToEndTrace-wrap      ↦ EndToEndTrace.wrap
+  buildCfg-sufficient     ↦ buildCfg_sufficient
+-/
+import Spa.Language.Traces
+
+namespace Spa
+
+open Graph
+
+/-- Agda: `↑-≢`. -/
+theorem Fin.castAdd_ne_natAdd {n m : ℕ} (i : Fin n) (j : Fin m) :
+    Fin.castAdd m i ≠ Fin.natAdd n j := by
+  intro h
+  have := congrArg Fin.val h
+  simp only [Fin.coe_castAdd, Fin.coe_natAdd] at this
+  omega
+
+/-! ### Trace embeddings -/
+
+section Embeddings
+
+variable {g₁ g₂ : Graph} {ρ₁ ρ₂ : Env}
+
+/-- Agda: `Trace-∙ˡ`. -/
+theorem Trace.comp_left {idx₁ idx₂ : g₁.Index}
+    (tr : Trace g₁ idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (g₁ ∙ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ := by
+  induction tr with
+  | single hbs =>
+    exact Trace.single (by rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
+      Fin.append_left])
+  | edge hbs he _ ih =>
+    refine Trace.edge ?_ ?_ ih
+    · rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_left]
+    · exact List.mem_append_left _ (List.mem_map_of_mem _ he)
+
+/-- Agda: `Trace-∙ʳ`. -/
+theorem Trace.comp_right {idx₁ idx₂ : g₂.Index}
+    (tr : Trace g₂ idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (g₁ ∙ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ := by
+  induction tr with
+  | single hbs =>
+    exact Trace.single (by rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
+      Fin.append_right])
+  | edge hbs he _ ih =>
+    refine Trace.edge ?_ ?_ ih
+    · rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_right]
+    · exact List.mem_append_right _ (List.mem_map_of_mem _ he)
+
+/-- Agda: `Trace-↦ˡ`. -/
+theorem Trace.link_left {idx₁ idx₂ : g₁.Index}
+    (tr : Trace g₁ idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (g₁ ⤳ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ := by
+  induction tr with
+  | single hbs =>
+    exact Trace.single (by rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
+      Fin.append_left])
+  | edge hbs he _ ih =>
+    refine Trace.edge ?_ ?_ ih
+    · rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_left]
+    · exact List.mem_append_left _ (List.mem_append_left _ (List.mem_map_of_mem _ he))
+
+/-- Agda: `Trace-↦ʳ`. -/
+theorem Trace.link_right {idx₁ idx₂ : g₂.Index}
+    (tr : Trace g₂ idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (g₁ ⤳ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ := by
+  induction tr with
+  | single hbs =>
+    exact Trace.single (by rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
+      Fin.append_right])
+  | edge hbs he _ ih =>
+    refine Trace.edge ?_ ?_ ih
+    · rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_right]
+    · exact List.mem_append_left _
+        (List.mem_append_right _ (List.mem_map_of_mem _ he))
+
+/-- Agda: `EndToEndTrace-∙ˡ`. -/
+theorem EndToEndTrace.comp_left (etr : EndToEndTrace g₁ ρ₁ ρ₂) :
+    EndToEndTrace (g₁ ∙ g₂) ρ₁ ρ₂ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
+  exact ⟨i₁.castAdd g₂.size, List.mem_append_left _ (List.mem_map_of_mem _ h₁),
+         i₂.castAdd g₂.size, List.mem_append_left _ (List.mem_map_of_mem _ h₂),
+         tr.comp_left⟩
+
+/-- Agda: `EndToEndTrace-∙ʳ`. -/
+theorem EndToEndTrace.comp_right (etr : EndToEndTrace g₂ ρ₁ ρ₂) :
+    EndToEndTrace (g₁ ∙ g₂) ρ₁ ρ₂ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
+  exact ⟨i₁.natAdd g₁.size, List.mem_append_right _ (List.mem_map_of_mem _ h₁),
+         i₂.natAdd g₁.size, List.mem_append_right _ (List.mem_map_of_mem _ h₂),
+         tr.comp_right⟩
+
+/-- Agda: `_++_` — sequencing end-to-end traces over `⤳`. -/
+theorem EndToEndTrace.concat {ρ₃ : Env} (etr₁ : EndToEndTrace g₁ ρ₁ ρ₂)
+    (etr₂ : EndToEndTrace g₂ ρ₂ ρ₃) : EndToEndTrace (g₁ ⤳ g₂) ρ₁ ρ₃ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr₁⟩ := etr₁
+  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
+  refine ⟨i₁.castAdd g₂.size, List.mem_map_of_mem _ h₁,
+          j₂.natAdd g₁.size, List.mem_map_of_mem _ k₂,
+          Trace.concat tr₁.link_left ?_ tr₂.link_right⟩
+  exact List.mem_append_right _
+    (List.mem_product.mpr ⟨List.mem_map_of_mem _ h₂, List.mem_map_of_mem _ k₁⟩)
+
+end Embeddings
+
+/-! ### Loops -/
+
+section Loop
+
+variable {g : Graph} {ρ₁ ρ₂ ρ₃ : Env}
+
+/-- Agda: `Trace-loop`. -/
+theorem Trace.loop {idx₁ idx₂ : g.Index} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (Graph.loop g) (idx₁.natAdd 2) (idx₂.natAdd 2) ρ₁ ρ₂ := by
+  induction tr with
+  | single hbs =>
+    exact Trace.single (by
+      rwa [show (Graph.loop g).nodes = Fin.append (fun _ : Fin 2 => []) g.nodes from rfl,
+        Fin.append_right])
+  | edge hbs he _ ih =>
+    refine Trace.edge ?_ ?_ ih
+    · rwa [show (Graph.loop g).nodes = Fin.append (fun _ : Fin 2 => []) g.nodes from rfl,
+        Fin.append_right]
+    · exact List.mem_append_left _ (List.mem_append_left _
+        (List.mem_append_left _ (List.mem_map_of_mem _ he)))
+
+private theorem loop_nodes_at_in :
+    (Graph.loop g).nodes g.loopIn = [] :=
+  Fin.append_left (fun _ : Fin 2 => []) g.nodes 0
+
+private theorem loop_nodes_at_out :
+    (Graph.loop g).nodes g.loopOut = [] :=
+  Fin.append_left (fun _ : Fin 2 => []) g.nodes 1
+
+/-- Agda: `EndToEndTrace-loop`. -/
+theorem EndToEndTrace.loop (etr : EndToEndTrace g ρ₁ ρ₂) :
+    EndToEndTrace (Graph.loop g) ρ₁ ρ₂ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
+  -- the edge in → (2 ↑ʳ i₁), reached through the second edge group
+  have hin : (g.loopIn, i₁.natAdd 2) ∈ (Graph.loop g).edges := by
+    refine List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ ?_))
+    exact List.mem_map_of_mem _ (List.mem_map_of_mem _ h₁)
+  -- the edge (2 ↑ʳ i₂) → out, reached through the third edge group
+  have hout : (i₂.natAdd 2, g.loopOut) ∈ (Graph.loop g).edges := by
+    refine List.mem_append_left _ (List.mem_append_right _ ?_)
+    exact List.mem_map_of_mem _ (List.mem_map_of_mem _ h₂)
+  refine ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _, ?_⟩
+  exact Trace.concat (Trace.single (loop_nodes_at_in ▸ EvalBasicStmts.nil)) hin
+    (Trace.concat tr.loop hout (Trace.single (loop_nodes_at_out ▸ EvalBasicStmts.nil)))
+
+private theorem loop_edge_out_in :
+    ((g.loopOut, g.loopIn) : (Graph.loop g).Edge) ∈ (Graph.loop g).edges := by
+  refine List.mem_append_right _ ?_
+  exact List.mem_cons_self _ _
+
+/-- Agda: `EndToEndTrace-loop²`. -/
+theorem EndToEndTrace.loop_concat (etr₁ : EndToEndTrace (Graph.loop g) ρ₁ ρ₂)
+    (etr₂ : EndToEndTrace (Graph.loop g) ρ₂ ρ₃) :
+    EndToEndTrace (Graph.loop g) ρ₁ ρ₃ := by
+  obtain ⟨i₁, h₁, i₂, h₂, tr₁⟩ := etr₁
+  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
+  simp only [Graph.loop_inputs, Graph.loop_outputs, List.mem_singleton] at h₁ h₂ k₁ k₂
+  subst h₁; subst h₂; subst k₁; subst k₂
+  exact ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _,
+    Trace.concat tr₁ loop_edge_out_in tr₂⟩
+
+/-- Agda: `EndToEndTrace-loop⁰`. -/
+theorem EndToEndTrace.loop_empty {ρ : Env} : EndToEndTrace (Graph.loop g) ρ ρ := by
+  have hedge : ((g.loopIn, g.loopOut) : (Graph.loop g).Edge) ∈ (Graph.loop g).edges :=
+    List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_cons_self _ _))
+  exact ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _,
+    Trace.concat (Trace.single (loop_nodes_at_in ▸ EvalBasicStmts.nil)) hedge
+      (Trace.single (loop_nodes_at_out ▸ EvalBasicStmts.nil))⟩
+
+end Loop
+
+/-! ### Singletons, wrap, and the main result -/
+
+/-- Agda: `EndToEndTrace-singleton`. -/
+theorem EndToEndTrace.singleton {bss : List BasicStmt} {ρ₁ ρ₂ : Env}
+    (h : EvalBasicStmts ρ₁ bss ρ₂) : EndToEndTrace (Graph.singleton bss) ρ₁ ρ₂ :=
+  ⟨(0 : Fin 1), List.mem_singleton_self _, (0 : Fin 1), List.mem_singleton_self _,
+   Trace.single h⟩
+
+/-- Agda: `EndToEndTrace-singleton[]`. -/
+theorem EndToEndTrace.singleton_nil (ρ : Env) :
+    EndToEndTrace (Graph.singleton []) ρ ρ :=
+  EndToEndTrace.singleton EvalBasicStmts.nil
+
+/-- Agda: `EndToEndTrace-wrap`. -/
+theorem EndToEndTrace.wrap {g : Graph} {ρ₁ ρ₂ : Env}
+    (etr : EndToEndTrace g ρ₁ ρ₂) : EndToEndTrace (Graph.wrap g) ρ₁ ρ₂ :=
+  (EndToEndTrace.singleton_nil ρ₁).concat (etr.concat (EndToEndTrace.singleton_nil ρ₂))
+
+/-- Agda: `buildCfg-sufficient` — every terminating execution is witnessed by
+an end-to-end trace through the control-flow graph. -/
+theorem buildCfg_sufficient {s : Stmt} {ρ₁ ρ₂ : Env}
+    (h : EvalStmt ρ₁ s ρ₂) : EndToEndTrace (buildCfg s) ρ₁ ρ₂ := by
+  induction h with
+  | basic ρ₁ ρ₂ bs hbs =>
+    exact EndToEndTrace.singleton (EvalBasicStmts.cons hbs EvalBasicStmts.nil)
+  | andThen ρ₁ ρ₂ ρ₃ s₁ s₂ _ _ ih₁ ih₂ =>
+    exact ih₁.concat ih₂
+  | ifTrue ρ₁ ρ₂ e z s₁ s₂ _ _ _ ih =>
+    exact ih.comp_left
+  | ifFalse ρ₁ ρ₂ e s₁ s₂ _ _ ih =>
+    exact ih.comp_right
+  | whileTrue ρ₁ ρ₂ ρ₃ e z s _ _ _ _ ih₁ ih₂ =>
+    exact (ih₁.loop).loop_concat ih₂
+  | whileFalse ρ e s _ =>
+    exact EndToEndTrace.loop_empty
+
+/-! ### The wrapped graph's entry has no predecessors (Agda's "ugly" block) -/
+
+/-- The input of `wrap g` (Agda: `wrap-input`). -/
+def Graph.wrapInput (g : Graph) : (Graph.wrap g).Index :=
+  (0 : Fin 1).castAdd ((g ⤳ Graph.singleton []).size)
+
+/-- The output of `wrap g` (Agda: `wrap-output`). -/
+def Graph.wrapOutput (g : Graph) : (Graph.wrap g).Index :=
+  Fin.natAdd 1 ((Fin.natAdd g.size (0 : Fin 1)))
+
+theorem Graph.wrap_inputs (g : Graph) :
+    (Graph.wrap g).inputs = [g.wrapInput] := rfl
+
+theorem Graph.wrap_outputs (g : Graph) :
+    (Graph.wrap g).outputs = [g.wrapOutput] := rfl
+
+/-- Agda: `help`/`helpAll` — no edge of `singleton [] ⤳ g₂` ends at a
+`castAdd`-injected node (all edge targets are `natAdd`s). -/
+private theorem not_mem_edges_castAdd_link {g₂ : Graph} (i : Fin 1)
+    (idx : (Graph.singleton [] ⤳ g₂).Index) :
+    ((idx, i.castAdd g₂.size) : (Graph.singleton [] ⤳ g₂).Edge)
+      ∉ (Graph.singleton [] ⤳ g₂).edges := by
+  intro h
+  rcases List.mem_append.mp h with h' | h'
+  · rcases List.mem_append.mp h' with h'' | h''
+    · -- lifted edges of `singleton []`: there are none
+      simp [Graph.singleton, Graph.liftEdgeL] at h''
+    · -- lifted edges of g₂: targets are natAdd
+      obtain ⟨e, _, heq⟩ := List.mem_map.mp h''
+      exact Fin.castAdd_ne_natAdd i e.2 (congrArg Prod.snd heq).symm
+  · -- product edges: targets are natAdd'd inputs of g₂
+    obtain ⟨-, hb⟩ := List.mem_product.mp h'
+    obtain ⟨j, -, heq⟩ := List.mem_map.mp hb
+    exact Fin.castAdd_ne_natAdd i j heq.symm
+
+/-- Agda: `wrap-preds-∅` — the entry node of a wrapped graph has no
+incoming edges. -/
+theorem Graph.wrap_predecessors_eq_nil (g : Graph) (idx : (Graph.wrap g).Index)
+    (h : idx ∈ (Graph.wrap g).inputs) :
+    (Graph.wrap g).predecessors idx = [] := by
+  rw [Graph.wrap_inputs, List.mem_singleton] at h
+  subst h
+  rw [Graph.predecessors, List.filter_eq_nil_iff]
+  intro idx' _
+  simpa using not_mem_edges_castAdd_link (g₂ := g ⤳ Graph.singleton []) 0 idx'
+
+end Spa

lean/Spa/Language/Semantics.lean

@@ -0,0 +1,91 @@
+/-
+Port of `Language/Semantics.agda`.
+
+Correspondence:
+  Value (↑ᶻ)        ↦ Value.int
+  Env               ↦ Env (= List (String × Value))
+  _∈_ (env lookup)  ↦ Env.Mem
+  _,_⇒ᵉ_            ↦ EvalExpr
+  _,_⇒ᵇ_            ↦ EvalBasicStmt
+  _,_⇒ᵇˢ_           ↦ EvalBasicStmts
+  _,_⇒ˢ_            ↦ EvalStmt
+  LatticeInterpretation:
+    ⟦_⟧             ↦ interp
+    ⟦⟧-respects-≈   ↦ (trivial with `=`; field dropped)
+    ⟦⟧-⊔-∨          ↦ interp_sup
+    ⟦⟧-⊓-∧          ↦ interp_inf
+    (the `Utils` combinators `_⇒_`, `_∨_`, `_∧_` are inlined as plain logic)
+-/
+import Spa.Language.Base
+import Spa.Lattice
+
+namespace Spa
+
+inductive Value where
+  | int (z : ℤ)
+  deriving DecidableEq
+
+def Env : Type := List (String × Value)
+
+/-- Agda: `_∈_` on environments — lookup respecting shadowing. -/
+inductive Env.Mem : String × Value → Env → Prop
+  | here (s : String) (v : Value) (ρ : Env) : Env.Mem (s, v) ((s, v) :: ρ)
+  | there (s s' : String) (v v' : Value) (ρ : Env) :
+      ¬(s = s') → Env.Mem (s, v) ρ → Env.Mem (s, v) ((s', v') :: ρ)
+
+/-- Agda: `_,_⇒ᵉ_`. -/
+inductive EvalExpr : Env → Expr → Value → Prop
+  | num (ρ : Env) (n : ℕ) : EvalExpr ρ (.num n) (.int n)
+  | var (ρ : Env) (x : String) (v : Value) :
+      Env.Mem (x, v) ρ → EvalExpr ρ (.var x) v
+  | add (ρ : Env) (e₁ e₂ : Expr) (z₁ z₂ : ℤ) :
+      EvalExpr ρ e₁ (.int z₁) → EvalExpr ρ e₂ (.int z₂) →
+      EvalExpr ρ (.add e₁ e₂) (.int (z₁ + z₂))
+  | sub (ρ : Env) (e₁ e₂ : Expr) (z₁ z₂ : ℤ) :
+      EvalExpr ρ e₁ (.int z₁) → EvalExpr ρ e₂ (.int z₂) →
+      EvalExpr ρ (.sub e₁ e₂) (.int (z₁ - z₂))
+
+/-- Agda: `_,_⇒ᵇ_`. -/
+inductive EvalBasicStmt : Env → BasicStmt → Env → Prop
+  | noop (ρ : Env) : EvalBasicStmt ρ .noop ρ
+  | assign (ρ : Env) (x : String) (e : Expr) (v : Value) :
+      EvalExpr ρ e v → EvalBasicStmt ρ (.assign x e) ((x, v) :: ρ)
+
+/-- Agda: `_,_⇒ᵇˢ_`. -/
+inductive EvalBasicStmts : Env → List BasicStmt → Env → Prop
+  | nil {ρ : Env} : EvalBasicStmts ρ [] ρ
+  | cons {ρ₁ ρ₂ ρ₃ : Env} {bs : BasicStmt} {bss : List BasicStmt} :
+      EvalBasicStmt ρ₁ bs ρ₂ → EvalBasicStmts ρ₂ bss ρ₃ →
+      EvalBasicStmts ρ₁ (bs :: bss) ρ₃
+
+/-- Agda: `_,_⇒ˢ_`. -/
+inductive EvalStmt : Env → Stmt → Env → Prop
+  | basic (ρ₁ ρ₂ : Env) (bs : BasicStmt) :
+      EvalBasicStmt ρ₁ bs ρ₂ → EvalStmt ρ₁ (.basic bs) ρ₂
+  | andThen (ρ₁ ρ₂ ρ₃ : Env) (s₁ s₂ : Stmt) :
+      EvalStmt ρ₁ s₁ ρ₂ → EvalStmt ρ₂ s₂ ρ₃ →
+      EvalStmt ρ₁ (.andThen s₁ s₂) ρ₃
+  | ifTrue (ρ₁ ρ₂ : Env) (e : Expr) (z : ℤ) (s₁ s₂ : Stmt) :
+      EvalExpr ρ₁ e (.int z) → ¬(z = 0) → EvalStmt ρ₁ s₁ ρ₂ →
+      EvalStmt ρ₁ (.ifElse e s₁ s₂) ρ₂
+  | ifFalse (ρ₁ ρ₂ : Env) (e : Expr) (s₁ s₂ : Stmt) :
+      EvalExpr ρ₁ e (.int 0) → EvalStmt ρ₁ s₂ ρ₂ →
+      EvalStmt ρ₁ (.ifElse e s₁ s₂) ρ₂
+  | whileTrue (ρ₁ ρ₂ ρ₃ : Env) (e : Expr) (z : ℤ) (s : Stmt) :
+      EvalExpr ρ₁ e (.int z) → ¬(z = 0) → EvalStmt ρ₁ s ρ₂ →
+      EvalStmt ρ₂ (.whileLoop e s) ρ₃ →
+      EvalStmt ρ₁ (.whileLoop e s) ρ₃
+  | whileFalse (ρ : Env) (e : Expr) (s : Stmt) :
+      EvalExpr ρ e (.int 0) →
+      EvalStmt ρ (.whileLoop e s) ρ
+
+/-- Agda: `LatticeInterpretation` (used there as an instance argument `⦃·⦄`,
+hence a typeclass here). -/
+class LatticeInterpretation (L : Type*) [Lattice L] where
+  interp : L → Value → Prop
+  interp_sup : ∀ {l₁ l₂ : L} (v : Value),
+    interp l₁ v ∨ interp l₂ v → interp (l₁ ⊔ l₂) v
+  interp_inf : ∀ {l₁ l₂ : L} (v : Value),
+    interp l₁ v ∧ interp l₂ v → interp (l₁ ⊓ l₂) v
+
+end Spa

lean/Spa/Language/Traces.lean

@@ -0,0 +1,38 @@
+/-
+Port of `Language/Traces.agda`.
+
+Correspondence:
+  Trace          ↦ Trace (a `Prop`-valued inductive; only used in proofs)
+  _++⟨_⟩_        ↦ Trace.concat
+  EndToEndTrace  ↦ EndToEndTrace (a `Prop`-valued structure, like `∃`; its
+                   fields are accessed by destructuring inside proofs)
+-/
+import Spa.Language.Semantics
+import Spa.Language.Graphs
+
+namespace Spa
+
+/-- Agda: `Trace`. -/
+inductive Trace (g : Graph) : g.Index → g.Index → Env → Env → Prop
+  | single {ρ₁ ρ₂ : Env} {idx : g.Index} :
+      EvalBasicStmts ρ₁ (g.nodes idx) ρ₂ → Trace g idx idx ρ₁ ρ₂
+  | edge {ρ₁ ρ₂ ρ₃ : Env} {idx₁ idx₂ idx₃ : g.Index} :
+      EvalBasicStmts ρ₁ (g.nodes idx₁) ρ₂ → (idx₁, idx₂) ∈ g.edges →
+      Trace g idx₂ idx₃ ρ₂ ρ₃ → Trace g idx₁ idx₃ ρ₁ ρ₃
+
+/-- Agda: `_++⟨_⟩_`. -/
+theorem Trace.concat {g : Graph} {idx₁ idx₂ idx₃ idx₄ : g.Index}
+    {ρ₁ ρ₂ ρ₃ : Env} (tr₁ : Trace g idx₁ idx₂ ρ₁ ρ₂)
+    (he : (idx₂, idx₃) ∈ g.edges) (tr₂ : Trace g idx₃ idx₄ ρ₂ ρ₃) :
+    Trace g idx₁ idx₄ ρ₁ ρ₃ := by
+  induction tr₁ with
+  | single hbs => exact Trace.edge hbs he tr₂
+  | edge hbs he' _ ih => exact Trace.edge hbs he' (ih he tr₂)
+
+/-- Agda: `EndToEndTrace` (an existential package, destructured in proofs). -/
+inductive EndToEndTrace (g : Graph) (ρ₁ ρ₂ : Env) : Prop
+  | intro (idx₁ : g.Index) (idx₁_mem : idx₁ ∈ g.inputs)
+      (idx₂ : g.Index) (idx₂_mem : idx₂ ∈ g.outputs)
+      (trace : Trace g idx₁ idx₂ ρ₁ ρ₂) : EndToEndTrace g ρ₁ ρ₂
+
+end Spa

lean/Spa/Lattice.lean

@@ -0,0 +1,168 @@
+/-
+Port of `Lattice.agda`.
+
+Most of the Agda module is *lifted* into mathlib, since we now work with
+propositional equality instead of a setoid:
+
+  IsSemilattice A _≈_ _⊔_   ↦  SemilatticeSup α
+  IsLattice A _≈_ _⊔_ _⊓_   ↦  Lattice α
+  _≼_ (a ⊔ b ≈ b)           ↦  a ≤ b           (bridge: `sup_eq_right`)
+  _≺_                       ↦  a < b
+  Monotonic                 ↦  Monotone
+  ⊔-assoc/⊔-comm/⊔-idemp    ↦  sup_assoc/sup_comm/sup_idem
+  absorb-⊔-⊓/absorb-⊓-⊔     ↦  sup_inf_self/inf_sup_self
+  ≼-refl/≼-trans/≼-antisym  ↦  le_refl/le_trans/le_antisymm
+  x≼x⊔y                     ↦  le_sup_left
+  ⊔-Monotonicˡ/ʳ            ↦  sup_le_sup_left/sup_le_sup_right
+  id-Mono/const-Mono        ↦  monotone_id/monotone_const
+  IsDecidable               ↦  DecidableEq (kept only where computation needs it)
+  Chain (Chain.agda)        ↦  LTSeries (chains of `<`); concat ↦ RelSeries.smash
+  ChainMapping.Chain-map    ↦  LTSeries.map (Monotone + Injective ⇒ StrictMono)
+
+What remains custom is exactly what mathlib does not have:
+  * monotonicity of folds over pairwise-related lists (foldr-Mono & friends),
+  * the fixed-height machinery (Chain.Height ↦ FixedHeight, Bounded),
+  * the proof that the bottom of the longest chain is a least element (⊥≼).
+-/
+import Mathlib.Order.Lattice
+import Mathlib.Order.RelSeries
+
+namespace Spa
+
+/-! ### Monotonicity helpers (Lattice.agda, `Monotonic₂` and fold lemmas) -/
+
+/-- Agda: `Monotonic₂` (a pair of one-sided monotonicity proofs). -/
+def Monotone₂ {α β γ : Type*} [Preorder α] [Preorder β] [Preorder γ]
+    (f : α → β → γ) : Prop :=
+  (∀ b, Monotone fun a => f a b) ∧ (∀ a, Monotone (f a))
+
+section Folds
+
+variable {α β : Type*} [Preorder α] [Preorder β]
+
+/-- Agda: `foldr-Mono`. `Pairwise _≼₁_` becomes `List.Forall₂ (· ≤ ·)`. -/
+theorem foldr_mono {l₁ l₂ : List α} (f : α → β → β) {b₁ b₂ : β}
+    (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
+    (hf₁ : ∀ b, Monotone fun a => f a b) (hf₂ : ∀ a, Monotone (f a)) :
+    l₁.foldr f b₁ ≤ l₂.foldr f b₂ := by
+  induction hl with
+  | nil => exact hb
+  | cons hxy _ ih =>
+    exact le_trans (hf₁ _ hxy) (hf₂ _ ih)
+
+/-- Agda: `foldl-Mono`. -/
+theorem foldl_mono {l₁ l₂ : List α} (f : β → α → β) {b₁ b₂ : β}
+    (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
+    (hf₁ : ∀ a, Monotone fun b => f b a) (hf₂ : ∀ b, Monotone (f b)) :
+    l₁.foldl f b₁ ≤ l₂.foldl f b₂ := by
+  induction hl generalizing b₁ b₂ with
+  | nil => exact hb
+  | cons hxy _ ih =>
+    exact ih (le_trans (hf₁ _ hb) (hf₂ _ hxy))
+
+omit [Preorder α] in
+/-- Agda: `foldr-Mono'` (fixed list, varying accumulator). -/
+theorem foldr_mono' (l : List α) (f : α → β → β)
+    (hf : ∀ a, Monotone (f a)) : Monotone fun b => l.foldr f b := by
+  intro b₁ b₂ hb
+  induction l with
+  | nil => exact hb
+  | cons x xs ih => exact hf x ih
+
+omit [Preorder α] in
+/-- Agda: `foldl-Mono'`. -/
+theorem foldl_mono' (l : List α) (f : β → α → β)
+    (hf : ∀ a, Monotone fun b => f b a) : Monotone fun b => l.foldl f b := by
+  intro b₁ b₂ hb
+  induction l generalizing b₁ b₂ with
+  | nil => exact hb
+  | cons x xs ih => exact ih (hf x hb)
+
+end Folds
+
+/-! ### Fixed height (Chain.agda `Bounded`/`Height`, Lattice.agda `FixedHeight`) -/
+
+/-- Agda: `Chain.Bounded`. Every `<`-chain has length at most `n`. -/
+def BoundedChains (α : Type*) [Preorder α] (n : ℕ) : Prop :=
+  ∀ c : LTSeries α, c.length ≤ n
+
+/-- Agda: `Chain.Height` (with `FixedHeight h = Height h` from Lattice.agda).
+A longest chain runs from `⊥` to `⊤` and has length exactly `height`;
+no chain is longer. -/
+structure FixedHeight (α : Type*) [Preorder α] (height : ℕ) where
+  bot : α
+  top : α
+  longestChain : LTSeries α
+  head_longestChain : longestChain.head = bot
+  last_longestChain : longestChain.last = top
+  length_longestChain : longestChain.length = height
+  bounded : BoundedChains α height
+
+/-- Agda: `Chain.Bounded-suc-n` (a bounded order admits no chain one longer). -/
+theorem BoundedChains.no_longer {α : Type*} [Preorder α] {n : ℕ}
+    (h : BoundedChains α n) (c : LTSeries α) : c.length ≠ n + 1 :=
+  fun hc => absurd (h c) (by omega)
+
+/-- Re-index a `FixedHeight` along an equality of heights (used where Agda
+just rewrites with arithmetic identities). -/
+def FixedHeight.cast {α : Type*} [Preorder α] {m n : ℕ} (h : m = n)
+    (fh : FixedHeight α m) : FixedHeight α n where
+  bot := fh.bot
+  top := fh.top
+  longestChain := fh.longestChain
+  head_longestChain := fh.head_longestChain
+  last_longestChain := fh.last_longestChain
+  length_longestChain := h ▸ fh.length_longestChain
+  bounded := h ▸ fh.bounded
+
+@[simp] theorem FixedHeight.cast_bot {α : Type*} [Preorder α] {m n : ℕ}
+    (h : m = n) (fh : FixedHeight α m) : (fh.cast h).bot = fh.bot := rfl
+
+/-- Agda: `IsFiniteHeightLattice` / `FiniteHeightLattice` (bundled). Like the
+Agda code (which took `IsFiniteHeightLattice` as an instance argument `⦃·⦄`),
+this is a typeclass; downstream modules pick it up by instance resolution
+rather than threading a `FixedHeight` value. -/
+class FiniteHeightLattice (α : Type*) [Lattice α] where
+  height : ℕ
+  fixedHeight : FixedHeight α height
+
+namespace FixedHeight
+
+variable {α : Type*} [Lattice α] {h : ℕ}
+
+/-- Agda: `Known-⊥`. -/
+def KnownBot (fh : FixedHeight α h) : Prop := ∀ a : α, fh.bot ≤ a
+
+/-- Agda: `Known-⊤`. -/
+def KnownTop (fh : FixedHeight α h) : Prop := ∀ a : α, a ≤ fh.top
+
+/-- Agda: `⊥≼` — the bottom of the longest chain is a least element.
+Same proof: if `⊥ ⊓ a ≠ ⊥` then `⊥ ⊓ a < ⊥` prepends to the longest chain,
+contradicting boundedness. (The decidability hypothesis of the Agda proof is
+not needed classically.) -/
+theorem bot_le (fh : FixedHeight α h) : fh.KnownBot := by
+  intro a
+  by_cases heq : fh.bot ⊓ a = fh.bot
+  · exact inf_eq_left.mp heq
+  · exfalso
+    have hlt : fh.bot ⊓ a < fh.bot :=
+      lt_of_le_of_ne inf_le_left heq
+    exact fh.bounded.no_longer
+      (fh.longestChain.cons (fh.bot ⊓ a) (fh.head_longestChain ▸ hlt))
+      (by simp [RelSeries.cons, fh.length_longestChain])
+
+end FixedHeight
+
+namespace FiniteHeightLattice
+
+variable (α : Type*) [Lattice α] [FiniteHeightLattice α]
+
+/-- Agda: the `⊥` of `Chain.Height`, with the type explicit. -/
+def bot : α := (fixedHeight (α := α)).bot
+
+/-- Agda: `⊥≼` for the instance bottom. -/
+theorem bot_le (a : α) : bot α ≤ a := FixedHeight.bot_le _ a
+
+end FiniteHeightLattice
+
+end Spa

lean/Spa/Lattice/AboveBelow.lean

@@ -0,0 +1,289 @@
+/-
+Port of `Lattice/AboveBelow.agda`: the flat lattice obtained by adjoining a
+top and bottom element to an (unordered, decidable-equality) type.
+
+With propositional equality the `_≈_` data type and its equivalence/decidability
+proofs disappear (`deriving DecidableEq`). The lattice itself cannot be lifted:
+mathlib has no "flat lattice on a discrete type". The `Lattice` instance is
+built with `Lattice.mk'`, which — exactly like the Agda module — consumes the
+two semilattices (comm/assoc, idempotence derived) plus the absorption laws,
+and defines `a ≤ b ↔ a ⊔ b = b` (Agda's `_≼_`).
+
+The Agda module's `Plain x` submodule (the witness `x` seeds the longest chain
+`⊥ ≺ [x] ≺ ⊤`) becomes `plainFixedHeight x`; the boundedness proof `isLongest`
+is restated through a rank function since chains are mathlib `LTSeries` rather
+than a pattern-matchable inductive (the `¬-Chain-⊤`-style case analysis lives
+in `rank_strictMono`).
+-/
+import Spa.Lattice
+
+namespace Spa
+
+/-- Agda: `AboveBelow` with constructors `⊥`, `⊤`, `[_]`. -/
+inductive AboveBelow (α : Type*) where
+  | bot
+  | top
+  | mk (x : α)
+  deriving DecidableEq
+
+namespace AboveBelow
+
+/-- Agda: the `Showable` instance. -/
+instance {α : Type*} [ToString α] : ToString (AboveBelow α) where
+  toString
+    | bot => "⊥"
+    | top => "⊤"
+    | mk x => toString x
+
+variable {α : Type*} [DecidableEq α]
+
+instance : Max (AboveBelow α) where
+  max
+    | bot, x => x
+    | top, _ => top
+    | mk x, mk y => if x = y then mk x else top
+    | mk x, bot => mk x
+    | mk _, top => top
+
+instance : Min (AboveBelow α) where
+  min
+    | bot, _ => bot
+    | top, x => x
+    | mk x, mk y => if x = y then mk x else bot
+    | mk _, bot => bot
+    | mk x, top => mk x
+
+/-! Agda: `⊥⊔x≡x`, `⊤⊔x≡⊤`, `x⊔⊥≡x`, `x⊔⊤≡⊤`, and the `[x]⊔[y]` reductions
+(`x≈y⇒[x]⊔[y]≡[x]` / `x̷≈y⇒[x]⊔[y]≡⊤` are the two branches of `mk_sup_mk`). -/
+
+@[simp] theorem bot_sup (x : AboveBelow α) : bot ⊔ x = x := rfl
+@[simp] theorem top_sup (x : AboveBelow α) : top ⊔ x = top := rfl
+@[simp] theorem sup_bot (x : AboveBelow α) : x ⊔ bot = x := by cases x <;> rfl
+@[simp] theorem sup_top (x : AboveBelow α) : x ⊔ top = top := by cases x <;> rfl
+@[simp] theorem mk_sup_mk (x y : α) :
+    (mk x ⊔ mk y : AboveBelow α) = if x = y then mk x else top := rfl
+
+@[simp] theorem bot_inf (x : AboveBelow α) : bot ⊓ x = bot := rfl
+@[simp] theorem top_inf (x : AboveBelow α) : top ⊓ x = x := rfl
+@[simp] theorem inf_bot (x : AboveBelow α) : x ⊓ bot = bot := by cases x <;> rfl
+@[simp] theorem inf_top (x : AboveBelow α) : x ⊓ top = x := by cases x <;> rfl
+@[simp] theorem mk_inf_mk (x y : α) :
+    (mk x ⊓ mk y : AboveBelow α) = if x = y then mk x else bot := rfl
+
+/-- Agda: `⊔-comm`. -/
+protected theorem sup_comm (a b : AboveBelow α) : a ⊔ b = b ⊔ a := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp only
+    [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk]
+  split_ifs with h₁ h₂ h₂ <;> simp_all
+
+/-- Agda: `⊔-assoc`. -/
+protected theorem sup_assoc (a b c : AboveBelow α) : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;>
+    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk]
+  split_ifs <;> simp_all
+
+/-- Agda: `⊓-comm`. -/
+protected theorem inf_comm (a b : AboveBelow α) : a ⊓ b = b ⊓ a := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp only
+    [bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk]
+  split_ifs with h₁ h₂ h₂ <;> simp_all
+
+/-- Agda: `⊓-assoc`. -/
+protected theorem inf_assoc (a b c : AboveBelow α) : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;>
+    simp only [bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk]
+  split_ifs <;> simp_all
+
+/-- Agda: `absorb-⊔-⊓`. -/
+protected theorem sup_inf_self (a b : AboveBelow α) : a ⊔ a ⊓ b = a := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
+    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk,
+               bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk] <;>
+    try (split_ifs <;> simp_all)
+
+/-- Agda: `absorb-⊓-⊔`. -/
+protected theorem inf_sup_self (a b : AboveBelow α) : a ⊓ (a ⊔ b) = a := by
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
+    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk,
+               bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk] <;>
+    try (split_ifs <;> simp_all)
+
+/-- Agda: `isLattice` (via the two semilattices + absorption, like the Agda
+record; `Lattice.mk'` derives idempotence and sets `a ≤ b ↔ a ⊔ b = b`). -/
+instance : Lattice (AboveBelow α) :=
+  Lattice.mk' AboveBelow.sup_comm AboveBelow.sup_assoc
+    AboveBelow.inf_comm AboveBelow.inf_assoc
+    AboveBelow.sup_inf_self AboveBelow.inf_sup_self
+
+theorem le_iff {a b : AboveBelow α} : a ≤ b ↔ a ⊔ b = b := sup_eq_right.symm
+
+/-- Agda: `⊥≺[x]` (the `≤` part; `⊥` is least). -/
+theorem bot_le' (a : AboveBelow α) : (bot : AboveBelow α) ≤ a :=
+  le_iff.mpr (bot_sup a)
+
+/-- Agda: `[x]≺⊤` (the `≤` part; `⊤` is greatest). -/
+theorem le_top' (a : AboveBelow α) : a ≤ (top : AboveBelow α) :=
+  le_iff.mpr (sup_top a)
+
+theorem bot_lt_mk (x : α) : (bot : AboveBelow α) < mk x :=
+  lt_of_le_of_ne (bot_le' _) (by simp)
+
+theorem mk_lt_top (x : α) : (mk x : AboveBelow α) < top :=
+  lt_of_le_of_ne (le_top' _) (by simp)
+
+theorem bot_lt_top : (bot : AboveBelow α) < top :=
+  lt_of_le_of_ne (bot_le' _) (by simp)
+
+/-- The order of the flat lattice, by cases (used to discharge the
+monotonicity obligations that were `postulate`d in `Analysis/Sign.agda` and
+`Analysis/Constant.agda`). -/
+theorem le_cases {a b : AboveBelow α} (h : a ≤ b) :
+    a = bot ∨ b = top ∨ a = b := by
+  have hsup := le_iff.mp h
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y
+  · exact Or.inl rfl
+  · exact Or.inr (Or.inl rfl)
+  · exact Or.inl rfl
+  · exact absurd hsup (by simp)
+  · exact Or.inr (Or.inl rfl)
+  · exact absurd hsup (by simp)
+  · exact absurd hsup (by simp)
+  · exact Or.inr (Or.inl rfl)
+  · rw [mk_sup_mk] at hsup
+    by_cases hxy : x = y
+    · exact Or.inr (Or.inr (by rw [hxy]))
+    · rw [if_neg hxy] at hsup
+      exact absurd hsup (by simp)
+
+/-- Monotonicity for *strict* operations on flat lattices: if `f` sends `⊥` to
+`⊥` (in either argument) and `⊤` to `⊤` (against any non-`⊥` argument), it is
+monotone in both arguments — regardless of its values on plain elements.
+`Analysis/Sign.agda` and `Analysis/Constant.agda` postulated exactly these
+monotonicity facts for their `plus`/`minus`, all of which have this shape. -/
+theorem monotone₂_of_strict {β γ : Type*} [DecidableEq β] [DecidableEq γ]
+    (f : AboveBelow α → AboveBelow β → AboveBelow γ)
+    (hbotl : ∀ y, f bot y = bot) (hbotr : ∀ x, f x bot = bot)
+    (htopl : ∀ y, y ≠ bot → f top y = top)
+    (htopr : ∀ x, x ≠ bot → f x top = top) : Monotone₂ f := by
+  constructor
+  · intro y a b hab
+    show f a y ≤ f b y
+    rcases le_cases hab with rfl | rfl | rfl
+    · rw [hbotl]; exact bot_le' _
+    · rcases eq_or_ne y bot with rfl | hy
+      · rw [hbotr, hbotr]
+      · rw [htopl y hy]; exact le_top' _
+    · exact le_rfl
+  · intro x a b hab
+    rcases le_cases hab with rfl | rfl | rfl
+    · rw [hbotr]; exact bot_le' _
+    · rcases eq_or_ne x bot with rfl | hx
+      · rw [hbotl, hbotl]
+      · rw [htopr x hx]; exact le_top' _
+    · exact le_rfl
+
+/-! ### Interpretations of flat lattices
+
+The `⟦⟧-⊔-∨` / `⟦⟧-⊓-∧` proofs of `Analysis/Sign.agda` and
+`Analysis/Constant.agda` are the same case analysis; only the meaning of the
+plain elements differs. Factored here, they need just `P ⊥ ↦ False`,
+`P ⊤ ↦ True`, and (for `⊓`) disjointness of distinct plain elements. -/
+
+section Interp
+
+variable {V : Type*} {P : AboveBelow α → V → Prop}
+
+/-- Agda: `⟦⟧ᵍ-⊔ᵍ-∨` / `⟦⟧ᶜ-⊔ᶜ-∨`, generalized. -/
+theorem interp_sup_of (hbot : ∀ v, ¬P bot v) (htop : ∀ v, P top v)
+    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by
+  rcases s₁ with _ | _ | x
+  · rw [bot_sup]; exact h.resolve_left (hbot v)
+  · rw [top_sup]; exact htop v
+  · rcases s₂ with _ | _ | y
+    · rw [sup_bot]; exact h.resolve_right (hbot v)
+    · rw [sup_top]; exact htop v
+    · rw [mk_sup_mk]
+      split
+      · next heq => subst heq; exact h.elim id id
+      · exact htop v
+
+/-- Agda: `⟦⟧ᵍ-⊓ᵍ-∧` / `⟦⟧ᶜ-⊓ᶜ-∧`, generalized. -/
+theorem interp_inf_of
+    (hdisj : ∀ {x y : α}, x ≠ y → ∀ v, ¬(P (mk x) v ∧ P (mk y) v))
+    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∧ P s₂ v) : P (s₁ ⊓ s₂) v := by
+  rcases s₁ with _ | _ | x
+  · rw [bot_inf]; exact h.1
+  · rw [top_inf]; exact h.2
+  · rcases s₂ with _ | _ | y
+    · rw [inf_bot]; exact h.2
+    · rw [inf_top]; exact h.1
+    · rw [mk_inf_mk]
+      split
+      · next heq => subst heq; exact h.1
+      · next hne => exact absurd h (hdisj hne v)
+
+end Interp
+
+/-- Rank of an element: `⊥ ↦ 0`, `[x] ↦ 1`, `⊤ ↦ 2`. Used to bound chains
+(Agda's `isLongest` / `x≺[y]⇒x≡⊥` / `[x]≺y⇒y≡⊤` case analysis lives here). -/
+def rank : AboveBelow α → ℕ
+  | bot => 0
+  | mk _ => 1
+  | top => 2
+
+/-- Agda: the impossibility of `[x] ≺ [y]` (combines `x≺[y]⇒x≡⊥` and
+`[x]≺y⇒y≡⊤`: the flat middle layer is an antichain). -/
+theorem not_mk_lt_mk (x y : α) : ¬(mk x : AboveBelow α) < mk y := by
+  intro h
+  obtain ⟨hle, hne⟩ := lt_iff_le_and_ne.mp h
+  have hsup := le_iff.mp hle
+  rw [mk_sup_mk] at hsup
+  by_cases hxy : x = y
+  · rw [if_pos hxy] at hsup
+    exact hne hsup
+  · rw [if_neg hxy] at hsup
+    exact absurd hsup (by simp)
+
+theorem rank_strictMono : StrictMono (rank : AboveBelow α → ℕ) := by
+  intro a b hab
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y
+  · exact absurd hab (lt_irrefl _)
+  · simp [rank]
+  · simp [rank]
+  · exact absurd hab (bot_le' _).not_lt
+  · exact absurd hab (lt_irrefl _)
+  · exact absurd hab (le_top' _).not_lt
+  · exact absurd hab (bot_le' _).not_lt
+  · simp [rank]
+  · exact absurd hab (not_mk_lt_mk x y)
+
+/-- Agda: `isLongest` — no chain is longer than 2. -/
+theorem boundedChains : BoundedChains (AboveBelow α) 2 := fun c => by
+  have h := LTSeries.head_add_length_le_nat (c.map rank rank_strictMono)
+  rw [LTSeries.head_map, LTSeries.last_map, LTSeries.map_length] at h
+  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
+  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
+
+end AboveBelow
+
+end Spa

lean/Spa/Lattice/FiniteMap.lean

@@ -0,0 +1,672 @@
+/-
+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 }
+
+namespace FiniteMap
+
+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₂
+
+theorem combine_spine (f : B → B → B) : ∀ {l₁ l₂ : List (A × B)},
+    l₁.map Prod.fst = l₂.map Prod.fst →
+    (combine f l₁ l₂).map Prod.fst = l₁.map Prod.fst
+  | [], [], _ => rfl
+  | p :: l₁, q :: l₂, h => by
+    simp only [List.map_cons, List.cons.injEq] at h
+    simp only [combine, List.zipWith_cons_cons, List.map_cons]
+    exact congrArg _ (combine_spine f h.2)
+  | [], _ :: _, h => by simp at h
+  | _ :: _, [], h => by simp at h
+
+theorem combine_comm (f : B → B → B) (hf : ∀ a b, f a b = f b a) :
+    ∀ {l₁ l₂ : List (A × B)}, l₁.map Prod.fst = l₂.map Prod.fst →
+      combine f l₁ l₂ = combine f l₂ l₁
+  | [], [], _ => rfl
+  | p :: l₁, q :: l₂, h => by
+    simp only [List.map_cons, List.cons.injEq] at h
+    simp only [combine, List.zipWith_cons_cons]
+    rw [h.1, hf]
+    exact congrArg _ (combine_comm f hf h.2)
+  | [], _ :: _, h => by simp at h
+  | _ :: _, [], h => by simp at h
+
+theorem combine_assoc (f : B → B → B) (hf : ∀ a b c, f (f a b) c = f a (f b c)) :
+    ∀ {l₁ l₂ l₃ : List (A × B)},
+      l₁.map Prod.fst = l₂.map Prod.fst → l₂.map Prod.fst = l₃.map Prod.fst →
+      combine f (combine f l₁ l₂) l₃ = combine f l₁ (combine f l₂ l₃)
+  | [], [], [], _, _ => rfl
+  | p :: l₁, q :: l₂, r :: l₃, h₁₂, h₂₃ => by
+    simp only [List.map_cons, List.cons.injEq] at h₁₂ h₂₃
+    simp only [combine, List.zipWith_cons_cons]
+    rw [hf]
+    exact congrArg _ (combine_assoc f hf h₁₂.2 h₂₃.2)
+  | [], [], _ :: _, _, h => by simp at h
+  | [], _ :: _, _, h, _ => by simp at h
+  | _ :: _, [], _, h, _ => by simp at h
+  | _ :: _, _ :: _, [], _, h => by simp at h
+
+theorem combine_absorb (f g : B → B → B) (hfg : ∀ a b, f a (g a b) = a) :
+    ∀ {l₁ l₂ : List (A × B)}, l₁.map Prod.fst = l₂.map Prod.fst →
+      combine f l₁ (combine g l₁ l₂) = l₁
+  | [], [], _ => rfl
+  | p :: l₁, q :: l₂, h => by
+    simp only [List.map_cons, List.cons.injEq] at h
+    simp only [combine, List.zipWith_cons_cons, hfg]
+    exact congrArg _ (combine_absorb f g hfg h.2)
+  | [], _ :: _, h => by simp at h
+  | _ :: _, [], h => by simp at h
+
+variable [Lattice B]
+
+instance : Max (FiniteMap A B ks) where
+  max fm₁ fm₂ :=
+    ⟨combine (· ⊔ ·) fm₁.val fm₂.val,
+     (combine_spine _ (spine_eq fm₁ fm₂)).trans fm₁.property⟩
+
+instance : Min (FiniteMap A B ks) where
+  min fm₁ fm₂ :=
+    ⟨combine (· ⊓ ·) fm₁.val fm₂.val,
+     (combine_spine _ (spine_eq fm₁ fm₂)).trans fm₁.property⟩
+
+@[simp] theorem sup_val (fm₁ fm₂ : FiniteMap A B ks) :
+    (fm₁ ⊔ fm₂).val = combine (· ⊔ ·) fm₁.val fm₂.val := rfl
+
+@[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)))
+    (fun a b c => Subtype.ext (combine_assoc _ sup_assoc (spine_eq a b) (spine_eq b c)))
+    (fun a b => Subtype.ext (combine_comm _ inf_comm (spine_eq a b)))
+    (fun a b c => Subtype.ext (combine_assoc _ inf_assoc (spine_eq a b) (spine_eq b c)))
+    (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⟩
+
+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
+
+section Locate
+
+variable [DecidableEq A]
+
+private def locateList (k : A) :
+    (l : List (A × B)) → k ∈ l.map Prod.fst → {v : B // (k, v) ∈ l}
+  | [], h => absurd h (by simp)
+  | p :: l', h =>
+    if heq : p.1 = k then
+      ⟨p.2, by rw [← heq]; exact List.mem_cons_self ..⟩
+    else
+      let ⟨v, hv⟩ := locateList k l' (by
+        rcases List.mem_cons.mp h with h' | h'
+        · exact absurd h'.symm heq
+        · 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₂ ↔
+      List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂)
+  | [], [], _ => by simp [combine]
+  | p :: l₁, q :: l₂, h => by
+    simp only [List.map_cons, List.cons.injEq] at h
+    simp only [combine, List.zipWith_cons_cons, List.cons.injEq,
+               List.forall₂_cons, Prod.ext_iff]
+    rw [show List.zipWith (fun p q : A × B => (p.1, p.2 ⊔ q.2)) l₁ l₂
+          = combine (· ⊔ ·) l₁ l₂ from rfl,
+        combine_eq_right_iff h.2]
+    constructor
+    · rintro ⟨⟨hk, hv⟩, hrest⟩
+      exact ⟨⟨hk, sup_eq_right.mp hv⟩, hrest⟩
+    · rintro ⟨⟨hk, hv⟩, hrest⟩
+      exact ⟨⟨hk, sup_eq_right.mpr hv⟩, hrest⟩
+  | [], _ :: _, 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
+  rw [← sup_eq_right, ← combine_eq_right_iff (spine_eq fm₁ fm₂), Subtype.ext_iff,
+      sup_val]
+
+private theorem forall₂_spine : ∀ {l₁ l₂ : List (A × B)},
+    List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂ →
+    l₁.map Prod.fst = l₂.map Prod.fst
+  | _, _, List.Forall₂.nil => rfl
+  | _, _, List.Forall₂.cons hpq hrest => by
+    simp [List.map_cons, hpq.1, forall₂_spine hrest]
+
+private theorem forall₂_mem_mem {l₁ l₂ : List (A × B)}
+    (hf : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) :
+    (l₁.map Prod.fst).Nodup →
+    ∀ {k : A} {v₁ v₂ : B}, (k, v₁) ∈ l₁ → (k, v₂) ∈ l₂ → v₁ ≤ v₂ := by
+  induction hf with
+  | nil =>
+    intro _ k v₁ v₂ h₁ _
+    simp at h₁
+  | @cons p q l₁' l₂' hpq hrest ih =>
+    intro hnd k v₁ v₂ h₁ h₂
+    simp only [List.map_cons, List.nodup_cons] at hnd
+    have hspine := forall₂_spine hrest
+    rcases List.mem_cons.mp h₁ with heq₁ | h₁'
+    · rcases List.mem_cons.mp h₂ with heq₂ | h₂'
+      · rw [← heq₁, ← heq₂] at hpq
+        exact hpq.2
+      · exfalso
+        apply hnd.1
+        rw [show p.1 = k from (congrArg Prod.fst heq₁).symm, hspine]
+        exact List.mem_map_of_mem _ h₂'
+    · rcases List.mem_cons.mp h₂ with heq₂ | h₂'
+      · exfalso
+        apply hnd.1
+        rw [hpq.1, show q.1 = k from (congrArg Prod.fst heq₂).symm]
+        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 →
+    (k, v) ∈ combine f l₁ l₂ →
+    ∃ v₁ v₂, v = f v₁ v₂ ∧ (k, v₁) ∈ l₁ ∧ (k, v₂) ∈ l₂
+  | [], [], _, _, _, h => by simp [combine] at h
+  | p :: l₁, q :: l₂, k, v, hsp, h => by
+    simp only [List.map_cons, List.cons.injEq] at hsp
+    simp only [combine, List.zipWith_cons_cons] at h
+    rcases List.mem_cons.mp h with heq | h'
+    · injection heq with hk hv
+      exact ⟨p.2, q.2, hv,
+        by rw [hk]; simp,
+        by rw [hk, hsp.1]; simp⟩
+    · 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
+    rw [List.map_map,
+        show (Prod.fst ∘ fun p : A × B => if p.1 ∈ ks' then (p.1, g p.1) else p)
+          = Prod.fst from funext fun p => by by_cases h : p.1 ∈ ks' <;> simp [h]]
+    exact fm.property⟩
+
+omit [Lattice B] in
+@[simp] theorem updating_val (fm : FiniteMap A B ks) (ks' : List A) (g : A → B) :
+    (updating fm ks' g).val
+      = 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
+  obtain ⟨p, hp, heq⟩ := List.mem_map.mp h
+  by_cases hmem : p.1 ∈ ks'
+  · rw [if_pos hmem] at heq
+    injection heq with h1 h2
+    rw [← h2, h1]
+  · rw [if_neg hmem] at heq
+    rw [heq] at hmem
+    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
+  obtain ⟨p, hp, heq⟩ := List.mem_map.mp h
+  by_cases hmem : p.1 ∈ ks'
+  · rw [if_pos hmem] at heq
+    injection heq with h1 _
+    rw [← h1] at hk
+    exact absurd hmem hk
+  · rw [if_neg hmem] at heq
+    exact heq ▸ hp
+
+private theorem updating_mono_list {ks' : List A} {g₁ g₂ : A → B}
+    (hg : ∀ k, g₁ k ≤ g₂ k) {l₁ l₂ : List (A × B)}
+    (hl : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) :
+    List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2)
+      (l₁.map fun p => if p.1 ∈ ks' then (p.1, g₁ p.1) else p)
+      (l₂.map fun p => if p.1 ∈ ks' then (p.1, g₂ p.1) else p) := by
+  induction hl with
+  | nil => exact List.Forall₂.nil
+  | @cons x y l₁' l₂' hpq hrest ih =>
+    simp only [List.map_cons]
+    refine List.Forall₂.cons ?_ ih
+    obtain ⟨hk, hv⟩ := hpq
+    by_cases h : x.1 ∈ ks'
+    · rw [if_pos h, if_pos (hk ▸ h)]
+      exact ⟨hk, hk ▸ hg x.1⟩
+    · 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
+  rw [le_iff] at hfm ⊢
+  simp only [updating_val]
+  exact updating_mono_list hg hfm
+
+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
+  exact mem_of_mem_updating hk h
+
+end GeneralizedUpdate
+
+/-! ### Reading off values at a list of keys (Agda: `_[_]`) -/
+
+section ValuesAt
+
+variable [DecidableEq A]
+
+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)
+
+omit [Lattice B] in
+private theorem lookup?_eq_some_of_mem : ∀ {l : List (A × B)},
+    (l.map Prod.fst).Nodup → ∀ {k : A} {v : B}, (k, v) ∈ l →
+    lookup? k l = some v
+  | [], _, _, _, h => by simp at h
+  | p :: l', hnd, k, v, h => by
+    simp only [List.map_cons, List.nodup_cons] at hnd
+    rcases List.mem_cons.mp h with heq | h'
+    · rw [← heq]
+      simp [lookup?]
+    · rw [lookup?, if_neg ?_]
+      · exact lookup?_eq_some_of_mem hnd.2 h'
+      · intro hpk
+        subst hpk
+        have := List.mem_map_of_mem Prod.fst h'
+        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
+    ⟨k, hk, lookup?_eq_some_of_mem (fm.property.symm ▸ hks) h⟩
+
+private theorem lookup?_forall₂ {l₁ l₂ : List (A × B)}
+    (h : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) (k : A) :
+    Option.Rel (· ≤ ·) (lookup? k l₁) (lookup? k l₂) := by
+  induction h with
+  | nil => exact Option.Rel.none
+  | @cons p q l₁ l₂ hpq hrest ih =>
+    rw [lookup?, lookup?]
+    by_cases hc : q.1 = k
+    · rw [if_pos hc, if_pos (hpq.1.trans hc)]
+      exact Option.Rel.some hpq.2
+    · 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
+  induction ks' with
+  | nil => exact List.Forall₂.nil
+  | cons k ks'' ih =>
+    have hrel := lookup?_forall₂ (le_iff.mp hle) k
+    rw [valuesAt, valuesAt, List.filterMap_cons, List.filterMap_cons]
+    revert hrel
+    generalize lookup? k fm₁.val = o₁
+    generalize lookup? k fm₂.val = o₂
+    intro hrel
+    cases hrel with
+    | none => simpa [valuesAt] using ih
+    | some hv => exact List.Forall₂.cons hv (by simpa [valuesAt] using ih)
+
+end ValuesAt
+
+/-! ### The isomorphism with `IterProd` and the fixed height -/
+
+section Iso
+
+omit [Lattice B] in
+theorem val_ne_nil {k : A} {ks' : List A} (fm : FiniteMap A B (k :: ks')) :
+    fm.val ≠ [] := fun h => by
+  have hp := fm.property
+  rw [h] at hp
+  simp at hp
+
+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⟩ =>
+    ⟨l, by simp only [List.map_cons, List.cons.injEq] at h; exact h.2⟩
+
+omit [Lattice B] in
+theorem val_eq_cons {k : A} {ks' : List A} :
+    ∀ fm : FiniteMap A B (k :: ks'), fm.val = (k, fm.headVal) :: fm.pop.val
+  | ⟨[], h⟩ => absurd h (by simp)
+  | ⟨p :: l, h⟩ => by
+    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 =>
+    ⟨(k, ip.1) :: (ofIter ks' ip.2).val, by
+      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
+    obtain ⟨val, hprop⟩ := fm
+    cases val with
+    | nil => rfl
+    | cons p l => exact absurd hprop (by simp)
+  | k :: ks', fm => Subtype.ext (by
+      show (k, fm.headVal) :: (ofIter ks' (toIter fm.pop)).val = fm.val
+      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
+  | k :: ks', ip => by
+    show (headVal (ofIter (k :: ks') ip), toIter (pop (ofIter (k :: ks') ip))) = ip
+    rw [show pop (ofIter (k :: ks') ip) = ofIter ks' ip.2 from rfl,
+        toIter_ofIter ks' ip.2]
+    rfl
+
+theorem headVal_le {k : A} {ks' : List A} {fm₁ fm₂ : FiniteMap A B (k :: ks')}
+    (h : fm₁ ≤ fm₂) : fm₁.headVal ≤ fm₂.headVal := by
+  have h' := le_iff.mp h
+  rw [val_eq_cons fm₁, val_eq_cons fm₂] at h'
+  exact (List.forall₂_cons.mp h').1.2
+
+theorem pop_le {k : A} {ks' : List A} {fm₁ fm₂ : FiniteMap A B (k :: ks')}
+    (h : fm₁ ≤ fm₂) : fm₁.pop ≤ fm₂.pop := by
+  rw [le_iff]
+  have h' := le_iff.mp h
+  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
+    rw [le_iff]
+    show List.Forall₂ _ ((k, ip₁.1) :: (ofIter ks' ip₁.2).val)
+                        ((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)
+
+/-- 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
+
+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
+  | k' :: ks', k, v, h => by
+    rcases List.mem_cons.mp h with heq | h'
+    · 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 = _
+    rw [IterProd.bot_fixedHeight]
+  rw [hbot] at h
+  exact mem_ofIter_build h
+
+end Iso
+
+end FiniteMap
+
+end Spa

lean/Spa/Lattice/IterProd.lean

@@ -0,0 +1,76 @@
+/-
+Port of `Lattice/IterProd.agda`: the `k`-fold product `A × (A × ⋯ × B)`.
+
+With propositional equality and typeclasses, the Agda `Everything` record
+(which threaded the lattice operations and the conditional fixed-height proof
+through one recursion, so that the operations built by separate recursions
+would agree) is no longer needed: the `Lattice` instance is one recursive
+definition, and the fixed-height structure is another recursion over it.
+
+Correspondence:
+  IterProd            ↦ Spa.IterProd
+  build               ↦ Spa.IterProd.build
+  isLattice/lattice   ↦ instance Spa.IterProd.instLattice
+  fixedHeight,
+  isFiniteHeightLattice,
+  finiteHeightLattice ↦ Spa.IterProd.fixedHeight (+ FiniteHeightLattice instance)
+  ⊥-built             ↦ Spa.IterProd.bot_fixedHeight
+-/
+import Spa.Lattice.Prod
+import Spa.Lattice.Unit
+import Mathlib.Tactic.Ring
+
+namespace Spa
+
+universe u
+
+/-- Agda: `IterProd k = iterate k (A × ·) B`. (As in the Agda module, `A` and
+`B` are constrained to the same universe to keep the recursion simple.) -/
+def IterProd (A B : Type u) : ℕ → Type u
+  | 0 => B
+  | k + 1 => A × IterProd A B k
+
+namespace IterProd
+
+variable {A B : Type u}
+
+instance instLattice [Lattice A] [Lattice B] :
+    ∀ k, Lattice (IterProd A B k)
+  | 0 => inferInstanceAs (Lattice B)
+  | k + 1 => @Prod.instLattice A (IterProd A B k) _ (instLattice k)
+
+instance instDecidableEq [DecidableEq A] [DecidableEq B] :
+    ∀ k, DecidableEq (IterProd A B k)
+  | 0 => inferInstanceAs (DecidableEq B)
+  | k + 1 => @instDecidableEqProd A (IterProd A B k) _ (instDecidableEq k)
+
+/-- Agda: `build`. -/
+def build (a : A) (b : B) : (k : ℕ) → IterProd A B k
+  | 0 => b
+  | k + 1 => (a, build 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)
+
+/-- 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
+  | 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
+
+end IterProd
+
+end Spa

lean/Spa/Lattice/Prod.lean

@@ -0,0 +1,113 @@
+/-
+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
+
+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 ∧
+      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
+    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 := by
+      have h := c.step ⟨0, by omega⟩
+      have h1 : (⟨0, by omega⟩ : Fin c.length).succ = 1 := by
+        ext; simp [Fin.val_one, Nat.mod_eq_of_lt (by omega : 1 < c.length + 1)]
+      rwa [h1] at h
+    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*} [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 β] :
+    FiniteHeightLattice (α × β) where
+  height := IA.height + IB.height
+  fixedHeight := IA.fixedHeight.prod IB.fixedHeight
+
+end FixedHeight
+
+end Spa

lean/Spa/Lattice/Unit.lean

@@ -0,0 +1,35 @@
+/-
+Port of `Lattice/Unit.agda`.
+
+The lattice structure itself (`_⊔_`, `_⊓_`, all semilattice/lattice laws) is
+lifted into mathlib: `PUnit.instLinearOrder` provides `Lattice PUnit`.
+What remains is the fixed-height structure: the unit lattice has height 0.
+-/
+import Spa.Lattice
+
+namespace Spa
+
+/-- Chains in a subsingleton order are bounded by any `n` (Agda: the `bounded`
+field of `Lattice/Unit.agda`'s `fixedHeight`, generalized). -/
+theorem boundedChains_of_subsingleton (α : Type*) [Preorder α] [Subsingleton α]
+    (n : ℕ) : BoundedChains α n := fun c => by
+  by_contra hc
+  push_neg at hc
+  exact (c.step ⟨0, by omega⟩).ne (Subsingleton.elim _ _)
+
+/-- Agda: `Lattice/Unit.agda`'s `fixedHeight`. -/
+def punitFixedHeight : FixedHeight PUnit 0 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
+
+end Spa

lean/Spa/Showable.lean

@@ -0,0 +1,47 @@
+/-
+Port of `Showable.agda` (plus the `Showable` instances that lived on
+`Lattice/Map.agda` and `Lattice/AboveBelow.agda`).
+
+Lean has `ToString`, but its `String` instance does not quote (the Agda one
+does), so to reproduce the Agda output exactly we port the class as-is.
+-/
+import Spa.Lattice.FiniteMap
+import Spa.Lattice.AboveBelow
+
+namespace Spa
+
+/-- Agda: `Showable` (`show` is a Lean keyword, hence `show'`). -/
+class Showable (α : Type*) where
+  show' : α → String
+
+export Showable (show')
+
+instance : Showable String := ⟨fun s => "\"" ++ s ++ "\""⟩
+
+instance : Showable ℕ := ⟨toString⟩
+
+instance : Showable ℤ := ⟨toString⟩
+
+instance {n : ℕ} : Showable (Fin n) := ⟨fun i => toString i.val⟩
+
+instance {α β : Type*} [Showable α] [Showable β] : Showable (α × β) :=
+  ⟨fun p => "(" ++ show' p.1 ++ ", " ++ show' p.2 ++ ")"⟩
+
+instance : Showable PUnit := ⟨fun _ => "()"⟩
+
+/-- Agda: the `Showable` instance of `Lattice/AboveBelow.agda`. -/
+instance {α : Type*} [Showable α] : Showable (AboveBelow α) :=
+  ⟨fun
+    | .bot => "⊥"
+    | .top => "⊤"
+    | .mk x => show' x⟩
+
+/-- Agda: the `Showable` instance of `Lattice/Map.agda` (inherited by
+`FiniteMap`). -/
+instance {α β : Type*} {ks : List α} [Showable α] [Showable β] :
+    Showable (FiniteMap α β ks) :=
+  ⟨fun fm =>
+    "{" ++ fm.val.foldr (fun p rest => show' p.1 ++ " ↦ " ++ show' p.2 ++ ", " ++ rest) ""
+        ++ "}"⟩
+
+end Spa

lean/lake-manifest.json

@@ -0,0 +1,95 @@
+{"version": "1.1.0",
+ "packagesDir": ".lake/packages",
+ "packages":
+ [{"url": "https://github.com/leanprover-community/mathlib4",
+   "type": "git",
+   "subDir": null,
+   "scope": "",
+   "rev": "5269898d6a51d047931107c8d72d934d8d5d3753",
+   "name": "mathlib",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "v4.17.0",
+   "inherited": false,
+   "configFile": "lakefile.lean"},
+  {"url": "https://github.com/leanprover-community/plausible",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "c708be04267e3e995a14ac0d08b1530579c1525a",
+   "name": "plausible",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "main",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover-community/LeanSearchClient",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "0c169a0d55fef3763cfb3099eafd7b884ec7e41d",
+   "name": "LeanSearchClient",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "main",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover-community/import-graph",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "0447b0a7b7f41f0a1749010db3f222e4a96f9d30",
+   "name": "importGraph",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "main",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover-community/ProofWidgets4",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "799f6986de9f61b784ff7be8f6a8b101045b8ffd",
+   "name": "proofwidgets",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "v0.0.52",
+   "inherited": true,
+   "configFile": "lakefile.lean"},
+  {"url": "https://github.com/leanprover-community/aesop",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "56a2c80b209c253e0281ac4562a92122b457dcc0",
+   "name": "aesop",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "master",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover-community/quote4",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "95561f7a5811fae6a309e4a1bbe22a0a4a98bf03",
+   "name": "Qq",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "master",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover-community/batteries",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover-community",
+   "rev": "efcc7d9bd9936ecdc625baf0d033b60866565cd5",
+   "name": "batteries",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "main",
+   "inherited": true,
+   "configFile": "lakefile.toml"},
+  {"url": "https://github.com/leanprover/lean4-cli",
+   "type": "git",
+   "subDir": null,
+   "scope": "leanprover",
+   "rev": "e7fd1a415c80985ade02a021172834ca2139b0ca",
+   "name": "Cli",
+   "manifestFile": "lake-manifest.json",
+   "inputRev": "main",
+   "inherited": true,
+   "configFile": "lakefile.toml"}],
+ "name": "spa",
+ "lakeDir": ".lake"}

lean/lakefile.toml

@@ -0,0 +1,14 @@
+name = "spa"
+defaultTargets = ["Spa"]
+
+[[require]]
+name = "mathlib"
+git = "https://github.com/leanprover-community/mathlib4"
+rev = "v4.17.0"
+
+[[lean_lib]]
+name = "Spa"
+
+[[lean_exe]]
+name = "spa"
+root = "Main"

lean/lean-toolchain

@@ -0,0 +1 @@
+leanprover/lean4:v4.17.0