Add decidability proofs for properties

Signed-off-by: Danila Fedorin <danila.fedorin@gmail.com>

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

@@ -0,0 +1,144 @@
+open import Language hiding (_[_])
+open import Lattice
+
+module Analysis.Forward
+    (L : Set) {h}
+    {_≈ˡ_ : L → L → Set} {_⊔ˡ_ : L → L → L} {_⊓ˡ_ : L → L → L}
+    {{isFiniteHeightLatticeˡ : IsFiniteHeightLattice L h _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+    {{≈ˡ-dec : IsDecidable _≈ˡ_}} where
+
+open import Data.Empty using (⊥-elim)
+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 IsFiniteHeightLattice isFiniteHeightLatticeˡ
+    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
+
+    private module WithStmtEvaluator {{evaluator : StmtEvaluator}} where
+        open StmtEvaluator evaluator
+
+        updateVariablesForState : State → StateVariables → VariableValues
+        updateVariablesForState s sv =
+            foldl (flip (eval s)) (variablesAt s sv) (code s)
+
+        updateVariablesForState-Monoʳ : ∀ (s : State) → Monotonic _≼ᵐ_ _≼ᵛ_ (updateVariablesForState s)
+        updateVariablesForState-Monoʳ s {sv₁} {sv₂} sv₁≼sv₂ =
+            let
+                bss = code s
+                (vs₁ , s,vs₁∈sv₁) = locateᵐ {s} {sv₁} (states-in-Map s sv₁)
+                (vs₂ , s,vs₂∈sv₂) = locateᵐ {s} {sv₂} (states-in-Map s sv₂)
+                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 (eval s)) (eval-Monoʳ s)
+                            vs₁≼vs₂
+
+        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
+        -- function. This is just a composition, and is trivially monotonic.
+
+        analyze : StateVariables → StateVariables
+        analyze = updateAll ∘ joinAll
+
+        analyze-Mono : Monotonic _≼ᵐ_ _≼ᵐ_ analyze
+        analyze-Mono {sv₁} {sv₂} sv₁≼sv₂ =
+            updateAll-Mono {joinAll sv₁} {joinAll sv₂}
+                           (joinAll-Mono {sv₁} {sv₂} sv₁≼sv₂)
+
+        -- The fixed point of the 'analyze' function is our final goal.
+        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
+
+        variablesAt-updateAll : ∀ (s : State) (sv : StateVariables) →
+                                variablesAt s (updateAll sv) ≡ updateVariablesForState s sv
+        variablesAt-updateAll s sv
+            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 WithValidInterpretation {{latticeInterpretationˡ : LatticeInterpretation isLatticeˡ}}
+                                       {{validEvaluator : ValidStmtEvaluator evaluator latticeInterpretationˡ}} (dummy : ⊤) where
+            open ValidStmtEvaluator validEvaluator
+
+            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 = 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 =
+                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

@@ -0,0 +1,299 @@
+module Analysis.Sign where
+
+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
+    + : Sign
+    - : Sign
+    0ˢ : Sign
+
+instance
+    showable : Showable Sign
+    showable = record
+        { show = (λ
+            { + → "+"
+            ; - → "-"
+            ; 0ˢ → "0"
+            })
+        }
+
+-- g for siGn; s is used for strings and i is not very descriptive.
+_≟ᵍ_ : Decidable (_≡_ {_} {Sign})
+_≟ᵍ_ + + = yes refl
+_≟ᵍ_ + - = no (λ ())
+_≟ᵍ_ + 0ˢ = no (λ ())
+_≟ᵍ_ - + = no (λ ())
+_≟ᵍ_ - - = yes refl
+_≟ᵍ_ - 0ˢ = no (λ ())
+_≟ᵍ_ 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 _ as AB
+    using ()
+    renaming
+        ( AboveBelow to SignLattice
+        ; ⊥ to ⊥ᵍ
+        ; ⊤ to ⊤ᵍ
+        ; [_] to [_]ᵍ
+        ; _≈_ to _≈ᵍ_
+        ; ≈-⊥-⊥ to ≈ᵍ-⊥ᵍ-⊥ᵍ
+        ; ≈-⊤-⊤ to ≈ᵍ-⊤ᵍ-⊤ᵍ
+        ; ≈-lift to ≈ᵍ-lift
+        ; ≈-refl to ≈ᵍ-refl
+        )
+-- 'sign' has no underlying lattice structure, so use the 'plain' above-below lattice.
+open AB.Plain 0ˢ using ()
+    renaming
+        ( isLattice to isLatticeᵍ
+        ; isFiniteHeightLattice to isFiniteHeightLatticeᵍ
+        ; _≼_ to _≼ᵍ_
+        ; _⊔_ to _⊔ᵍ_
+        ; _⊓_ to _⊓ᵍ_
+        ; ≼-trans to ≼ᵍ-trans
+        )
+
+plus : SignLattice → SignLattice → SignLattice
+plus ⊥ᵍ _ = ⊥ᵍ
+plus _ ⊥ᵍ = ⊥ᵍ
+plus ⊤ᵍ _ = ⊤ᵍ
+plus _ ⊤ᵍ = ⊤ᵍ
+plus [ + ]ᵍ [ + ]ᵍ = [ + ]ᵍ
+plus [ + ]ᵍ [ - ]ᵍ = ⊤ᵍ
+plus [ + ]ᵍ [ 0ˢ ]ᵍ = [ + ]ᵍ
+plus [ - ]ᵍ [ + ]ᵍ = ⊤ᵍ
+plus [ - ]ᵍ [ - ]ᵍ = [ - ]ᵍ
+plus [ - ]ᵍ [ 0ˢ ]ᵍ = [ - ]ᵍ
+plus [ 0ˢ ]ᵍ [ + ]ᵍ = [ + ]ᵍ
+plus [ 0ˢ ]ᵍ [ - ]ᵍ = [ - ]ᵍ
+plus [ 0ˢ ]ᵍ [ 0ˢ ]ᵍ = [ 0ˢ ]ᵍ
+
+-- this is incredibly tedious: 125 cases per monotonicity proof, and tactics
+-- are hard. postulate for now.
+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 _ ⊥ᵍ = ⊥ᵍ
+minus ⊤ᵍ _ = ⊤ᵍ
+minus _ ⊤ᵍ = ⊤ᵍ
+minus [ + ]ᵍ [ + ]ᵍ = ⊤ᵍ
+minus [ + ]ᵍ [ - ]ᵍ = [ + ]ᵍ
+minus [ + ]ᵍ [ 0ˢ ]ᵍ = [ + ]ᵍ
+minus [ - ]ᵍ [ + ]ᵍ = [ - ]ᵍ
+minus [ - ]ᵍ [ - ]ᵍ = ⊤ᵍ
+minus [ - ]ᵍ [ 0ˢ ]ᵍ = [ - ]ᵍ
+minus [ 0ˢ ]ᵍ [ + ]ᵍ = [ - ]ᵍ
+minus [ 0ˢ ]ᵍ [ - ]ᵍ = [ + ]ᵍ
+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 = v ≡ ↑ᶻ (+_ zero)
+⟦_⟧ᵍ [ - ]ᵍ v = Σ ℕ (λ n → v ≡ ↑ᶻ -[1+ n ])
+
+⟦⟧ᵍ-respects-≈ᵍ : ∀ {s₁ s₂ : SignLattice} → s₁ ≈ᵍ s₂ → ⟦ s₁ ⟧ᵍ ⇒ ⟦ s₂ ⟧ᵍ
+⟦⟧ᵍ-respects-≈ᵍ ≈ᵍ-⊥ᵍ-⊥ᵍ v bot = bot
+⟦⟧ᵍ-respects-≈ᵍ ≈ᵍ-⊤ᵍ-⊤ᵍ v top = top
+⟦⟧ᵍ-respects-≈ᵍ (≈ᵍ-lift { + } { + } refl) v proof = proof
+⟦⟧ᵍ-respects-≈ᵍ (≈ᵍ-lift { - } { - } refl) v proof = proof
+⟦⟧ᵍ-respects-≈ᵍ (≈ᵍ-lift { 0ˢ } { 0ˢ } refl) v proof = proof
+
+⟦⟧ᵍ-⊔ᵍ-∨ : ∀ {s₁ s₂ : SignLattice} → (⟦ 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₂ : ∀ {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) , ())
+s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { + } _ (refl , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { 0ˢ } +≢+ _ = ⊥-elim (+≢+ refl)
+s₁≢s₂⇒¬s₁∧s₂ { 0ˢ } { - } _ (refl , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { - } { + } _ ((n , refl) , (m , ()))
+s₁≢s₂⇒¬s₁∧s₂ { - } { 0ˢ } _ ((n , refl) , ())
+s₁≢s₂⇒¬s₁∧s₂ { - } { - } +≢+ _ = ⊥-elim (+≢+ refl)
+
+⟦⟧ᵍ-⊓ᵍ-∧ : ∀ {s₁ s₂ : SignLattice} → (⟦ 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 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)
+    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 (# 0) _ = [ 0ˢ ]ᵍ
+    eval (# (suc 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ʳ (# 0) _ = ≈ᵍ-refl
+    eval-Monoʳ (# (suc n')) _ = ≈ᵍ-refl
+
+    instance
+        SignEval : ExprEvaluator
+        SignEval = record { eval = eval; eval-Monoʳ = eval-Monoʳ }
+
+    -- For debugging purposes, print out the 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

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 ⊥ᴬ))

Homomorphism.agda

@@ -1,149 +0,0 @@
-open import Equivalence
-
-module Homomorphism {a b} (A : Set a) (B : Set b)
-    (_≈₁_ : A → A → Set a) (_≈₂_ : B → B → Set b)
-    (≈₂-equiv : IsEquivalence B _≈₂_)
-    (f : A → B) where
-
-open import Agda.Primitive using (lsuc; Level) renaming (_⊔_ to _⊔ℓ_)
-open import Function.Definitions using (Surjective)
-open import Relation.Binary.Core using (_Preserves_⟶_ )
-open import Data.Product using (_,_)
-open import Lattice
-
-open IsEquivalence ≈₂-equiv using () renaming (≈-trans to ≈₂-trans; ≈-sym to ≈₂-sym; ≈-refl to ≈₂-refl)
-open import Relation.Binary.Reasoning.Base.Single _≈₂_ ≈₂-refl ≈₂-trans
-
-infixl 20 _∙₂_
-_∙₂_ = ≈₂-trans
-
-record SemilatticeHomomorphism (_⊔₁_ : A → A → A)
-                               (_⊔₂_ : B → B → B) : Set (a ⊔ℓ b) where
-    field
-        f-preserves-≈ : f Preserves _≈₁_ ⟶  _≈₂_
-        f-⊔-distr : ∀ (a₁ a₂ : A) → f (a₁ ⊔₁ a₂) ≈₂ ((f a₁) ⊔₂ (f a₂))
-
-module _ (_⊔₁_ : A → A → A) (_⊔₂_ : B → B → B)
-         (sh : SemilatticeHomomorphism _⊔₁_ _⊔₂_)
-         (≈₂-⊔₂-cong : ∀ {a₁ a₂ a₃ a₄} → a₁ ≈₂ a₂ → a₃ ≈₂ a₄ → (a₁ ⊔₂ a₃) ≈₂ (a₂ ⊔₂ a₄))
-         (surF : Surjective _≈₁_ _≈₂_ f) where
-
-    open SemilatticeHomomorphism sh
-
-    transportSemilattice : IsSemilattice A _≈₁_ _⊔₁_ → IsSemilattice B _≈₂_ _⊔₂_
-    transportSemilattice sA = record
-        { ≈-equiv = ≈₂-equiv
-        ; ≈-⊔-cong = ≈₂-⊔₂-cong
-        ; ⊔-assoc = λ b₁ b₂ b₃ →
-            let (a₁ , fa₁≈b₁) = surF b₁
-                (a₂ , fa₂≈b₂) = surF b₂
-                (a₃ , fa₃≈b₃) = surF b₃
-            in
-               begin
-                   (b₁ ⊔₂ b₂) ⊔₂ b₃
-               ∼⟨ ≈₂-⊔₂-cong (≈₂-⊔₂-cong (≈₂-sym fa₁≈b₁) (≈₂-sym fa₂≈b₂)) (≈₂-sym fa₃≈b₃) ⟩
-                   (f a₁ ⊔₂ f a₂) ⊔₂ f a₃
-               ∼⟨ ≈₂-⊔₂-cong (≈₂-sym (f-⊔-distr a₁ a₂)) ≈₂-refl ⟩
-                   f (a₁ ⊔₁ a₂) ⊔₂ f a₃
-               ∼⟨ ≈₂-sym (f-⊔-distr (a₁ ⊔₁ a₂) a₃) ⟩
-                   f ((a₁ ⊔₁ a₂) ⊔₁ a₃)
-               ∼⟨ f-preserves-≈ (IsSemilattice.⊔-assoc sA a₁ a₂ a₃) ⟩
-                   f (a₁ ⊔₁ (a₂ ⊔₁ a₃))
-               ∼⟨ f-⊔-distr a₁ (a₂ ⊔₁ a₃) ⟩
-                   f a₁ ⊔₂ f (a₂ ⊔₁ a₃)
-               ∼⟨ ≈₂-⊔₂-cong ≈₂-refl (f-⊔-distr a₂ a₃) ⟩
-                   f a₁ ⊔₂ (f a₂ ⊔₂ f a₃)
-               ∼⟨ ≈₂-⊔₂-cong fa₁≈b₁ (≈₂-⊔₂-cong fa₂≈b₂ fa₃≈b₃) ⟩
-                   b₁ ⊔₂ (b₂ ⊔₂ b₃)
-               ∎
-        ; ⊔-comm = λ b₁ b₂ →
-            let (a₁ , fa₁≈b₁) = surF b₁
-                (a₂ , fa₂≈b₂) = surF b₂
-            in
-               begin
-                   b₁ ⊔₂ b₂
-               ∼⟨ ≈₂-⊔₂-cong (≈₂-sym fa₁≈b₁) (≈₂-sym fa₂≈b₂) ⟩
-                   f a₁ ⊔₂ f a₂
-               ∼⟨ ≈₂-sym (f-⊔-distr a₁ a₂) ⟩
-                   f (a₁ ⊔₁ a₂)
-               ∼⟨ f-preserves-≈ (IsSemilattice.⊔-comm sA a₁ a₂) ⟩
-                   f (a₂ ⊔₁ a₁)
-               ∼⟨ f-⊔-distr a₂ a₁ ⟩
-                   f a₂ ⊔₂ f a₁
-               ∼⟨ ≈₂-⊔₂-cong fa₂≈b₂ fa₁≈b₁ ⟩
-                   b₂ ⊔₂ b₁
-               ∎
-        ; ⊔-idemp = λ b →
-            let (a , fa≈b) = surF b
-            in
-               begin
-                   b ⊔₂ b
-               ∼⟨ ≈₂-⊔₂-cong (≈₂-sym fa≈b) (≈₂-sym fa≈b) ⟩
-                   f a ⊔₂ f a
-               ∼⟨ ≈₂-sym (f-⊔-distr a a) ⟩
-                   f (a ⊔₁ a)
-               ∼⟨ f-preserves-≈ (IsSemilattice.⊔-idemp sA a) ⟩
-                   f a
-               ∼⟨ fa≈b ⟩
-                   b
-               ∎
-        }
-
-
-record LatticeHomomorphism (_⊔₁_ : A → A → A) (_⊔₂_ : B → B → B)
-                           (_⊓₁_ : A → A → A) (_⊓₂_ : B → B → B) : Set (a ⊔ℓ b) where
-    field
-        ⊔-homomorphism : SemilatticeHomomorphism _⊔₁_ _⊔₂_
-        ⊓-homomorphism : SemilatticeHomomorphism _⊓₁_ _⊓₂_
-
-    open SemilatticeHomomorphism ⊔-homomorphism using (f-⊔-distr; f-preserves-≈) public
-    open SemilatticeHomomorphism ⊓-homomorphism using () renaming (f-⊔-distr to f-⊓-distr) public
-
-module _ (_⊔₁_ : A → A → A) (_⊔₂_ : B → B → B)
-         (_⊓₁_ : A → A → A) (_⊓₂_ : B → B → B)
-         (lh : LatticeHomomorphism _⊔₁_ _⊔₂_ _⊓₁_ _⊓₂_)
-         (≈₂-⊔₂-cong : ∀ {a₁ a₂ a₃ a₄} → a₁ ≈₂ a₂ → a₃ ≈₂ a₄ → (a₁ ⊔₂ a₃) ≈₂ (a₂ ⊔₂ a₄))
-         (≈₂-⊓₂-cong : ∀ {a₁ a₂ a₃ a₄} → a₁ ≈₂ a₂ → a₃ ≈₂ a₄ → (a₁ ⊓₂ a₃) ≈₂ (a₂ ⊓₂ a₄))
-         (surF : Surjective _≈₁_ _≈₂_ f) where
-
-    open LatticeHomomorphism lh
-
-    transportLattice : IsLattice A _≈₁_ _⊔₁_ _⊓₁_ → IsLattice B _≈₂_ _⊔₂_ _⊓₂_
-    transportLattice lA = record
-        { joinSemilattice = transportSemilattice _⊔₁_ _⊔₂_ (LatticeHomomorphism.⊔-homomorphism lh) ≈₂-⊔₂-cong surF (IsLattice.joinSemilattice lA)
-        ; meetSemilattice = transportSemilattice _⊓₁_ _⊓₂_ (LatticeHomomorphism.⊓-homomorphism lh) ≈₂-⊓₂-cong surF (IsLattice.meetSemilattice lA)
-        ; absorb-⊔-⊓ = λ b₁ b₂ →
-            let (a₁ , fa₁≈b₁) = surF b₁
-                (a₂ , fa₂≈b₂) = surF b₂
-            in
-               begin
-                   b₁ ⊔₂ (b₁ ⊓₂ b₂)
-               ∼⟨ ≈₂-⊔₂-cong (≈₂-sym fa₁≈b₁) (≈₂-⊓₂-cong (≈₂-sym fa₁≈b₁) (≈₂-sym fa₂≈b₂)) ⟩
-                   f a₁ ⊔₂ (f a₁ ⊓₂ f a₂)
-               ∼⟨ ≈₂-⊔₂-cong ≈₂-refl (≈₂-sym (f-⊓-distr a₁ a₂)) ⟩
-                   f a₁ ⊔₂ f (a₁ ⊓₁ a₂)
-               ∼⟨ ≈₂-sym (f-⊔-distr a₁ (a₁ ⊓₁ a₂)) ⟩
-                   f (a₁ ⊔₁ (a₁ ⊓₁ a₂))
-               ∼⟨ f-preserves-≈ (IsLattice.absorb-⊔-⊓ lA a₁ a₂) ⟩
-                   f a₁
-               ∼⟨ fa₁≈b₁ ⟩
-                   b₁
-               ∎
-        ; absorb-⊓-⊔ = λ b₁ b₂ →
-            let (a₁ , fa₁≈b₁) = surF b₁
-                (a₂ , fa₂≈b₂) = surF b₂
-            in
-               begin
-                   b₁ ⊓₂ (b₁ ⊔₂ b₂)
-               ∼⟨ ≈₂-⊓₂-cong (≈₂-sym fa₁≈b₁) (≈₂-⊔₂-cong (≈₂-sym fa₁≈b₁) (≈₂-sym fa₂≈b₂)) ⟩
-                   f a₁ ⊓₂ (f a₁ ⊔₂ f a₂)
-               ∼⟨ ≈₂-⊓₂-cong ≈₂-refl (≈₂-sym (f-⊔-distr a₁ a₂)) ⟩
-                   f a₁ ⊓₂ f (a₁ ⊔₁ a₂)
-               ∼⟨ ≈₂-sym (f-⊓-distr a₁ (a₁ ⊔₁ a₂)) ⟩
-                   f (a₁ ⊓₁ (a₁ ⊔₁ a₂))
-               ∼⟨ f-preserves-≈ (IsLattice.absorb-⊓-⊔ lA a₁ a₂) ⟩
-                   f a₁
-               ∼⟨ fa₁≈b₁ ⟩
-                   b₁
-               ∎
-        }

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

Language.agda

@@ -1,10 +1,94 @@
 module Language where
 
-open import Data.String using (String)
-open import Data.Nat using (ℕ)
+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
 
-data Expr : Set where
-    _+_ : Expr → Expr → Expr
-    _-_ : Expr → Expr → Expr
-    `_ : String → Expr
-    #_ : ℕ → Expr
+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.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 String {{record { R-dec = _≟ˢ_ }}} _ using ()
+    renaming
+        ( MapSet to StringSet
+        ; to-List to to-Listˢ
+        )
+
+record Program : Set where
+    field
+        rootStmt : Stmt
+
+    graph : Graph
+    graph = wrap (buildCfg rootStmt)
+
+    State : Set
+    State = Graph.Index graph
+
+    initialState : State
+    initialState = proj₁ (wrap-input (buildCfg rootStmt))
+
+    finalState : State
+    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
+        vars-Set = Stmt-vars rootStmt
+
+    vars : List String
+    vars = to-Listˢ vars-Set
+
+    vars-Unique : Unique vars
+    vars-Unique = proj₂ vars-Set
+
+    states : List State
+    states = indices graph
+
+    states-complete : ∀ (s : State) → s ListMem.∈ states
+    states-complete = indices-complete graph
+
+    states-Unique : Unique states
+    states-Unique = indices-Unique graph
+
+    code : State → List BasicStmt
+    code st = graph [ st ]
+
+    -- vars-complete : ∀ {k : String} (s : State) → k ∈ᵇ (code s) → k ListMem.∈ vars
+    -- vars-complete {k} s = ∈⇒∈-Stmts-vars {length} {k} {stmts} {s}
+
+    _≟_ : Decidable (_≡_ {_} {State})
+    _≟_ = FinProp._≟_
+
+    _≟ᵉ_ : Decidable (_≡_ {_} {Graph.Edge graph})
+    _≟ᵉ_ = ProdProp.≡-dec _≟_ _≟_
+
+    open import Data.List.Membership.DecPropositional _≟ᵉ_ using (_∈?_)
+
+    incoming : State → List State
+    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

@@ -0,0 +1,145 @@
+module Language.Base where
+
+open import Data.List as List using (List)
+open import Data.Nat using (ℕ; suc)
+open import Data.Product using (Σ; _,_; proj₁)
+open import Data.String as String using (String)
+open import Data.Vec using (Vec; foldr; lookup)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl)
+
+open import Lattice
+
+data Expr : Set where
+    _+_ : Expr → Expr → Expr
+    _-_ : Expr → Expr → Expr
+    `_ : String → Expr
+    #_ : ℕ → Expr
+
+data BasicStmt : Set where
+    _←_ : String → Expr → BasicStmt
+    noop : BasicStmt
+
+infixr 2 _then_
+infix 3 if_then_else_
+infix 3 while_repeat_
+data Stmt : Set where
+    ⟨_⟩ : BasicStmt → Stmt
+    _then_ : Stmt → Stmt → Stmt
+    if_then_else_ : Expr → Stmt → Stmt → Stmt
+    while_repeat_ : Expr → Stmt → Stmt
+
+data _∈ᵉ_ : String → Expr → Set where
+    in⁺₁ : ∀ {e₁ e₂ : Expr} {k : String} → k ∈ᵉ e₁ → k ∈ᵉ (e₁ + e₂)
+    in⁺₂ : ∀ {e₁ e₂ : Expr} {k : String} → k ∈ᵉ e₂ → k ∈ᵉ (e₁ + e₂)
+    in⁻₁ : ∀ {e₁ e₂ : Expr} {k : String} → k ∈ᵉ e₁ → k ∈ᵉ (e₁ - e₂)
+    in⁻₂ : ∀ {e₁ e₂ : Expr} {k : String} → k ∈ᵉ e₂ → k ∈ᵉ (e₁ - e₂)
+    here : ∀ {k : String} → k ∈ᵉ (` k)
+
+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 {{record { R-dec = String._≟_ }}} _
+    renaming
+        ( MapSet to StringSet
+        ; insert to insertˢ
+        ; empty to emptyˢ
+        ; singleton to singletonˢ
+        ; _⊔_ to _⊔ˢ_
+        ; `_ to `ˢ_
+        ; _∈_ to _∈ˢ_
+        ; ⊔-preserves-∈k₁ to ⊔ˢ-preserves-∈k₁
+        ; ⊔-preserves-∈k₂ to ⊔ˢ-preserves-∈k₂
+        )
+
+Expr-vars : Expr → StringSet
+Expr-vars (l + r) = Expr-vars l ⊔ˢ Expr-vars r
+Expr-vars (l - r) = Expr-vars l ⊔ˢ Expr-vars r
+Expr-vars (` s) = singletonˢ s
+Expr-vars (# _) = emptyˢ
+
+-- ∈-Expr-vars⇒∈ : ∀ {k : String} (e : Expr) → k ∈ˢ (Expr-vars e) → k ∈ᵉ e
+-- ∈-Expr-vars⇒∈ {k} (e₁ + e₂) k∈vs
+--     with Expr-Provenance k ((`ˢ (Expr-vars e₁)) ∪ (`ˢ (Expr-vars e₂))) k∈vs
+-- ...   | in₁ (single k,tt∈vs₁) _ = (in⁺₁ (∈-Expr-vars⇒∈ e₁ (forget k,tt∈vs₁)))
+-- ...   | in₂ _ (single k,tt∈vs₂) = (in⁺₂ (∈-Expr-vars⇒∈ e₂ (forget k,tt∈vs₂)))
+-- ...   | bothᵘ (single k,tt∈vs₁) _ = (in⁺₁ (∈-Expr-vars⇒∈ e₁ (forget k,tt∈vs₁)))
+-- ∈-Expr-vars⇒∈ {k} (e₁ - e₂) k∈vs
+--     with Expr-Provenance k ((`ˢ (Expr-vars e₁)) ∪ (`ˢ (Expr-vars e₂))) k∈vs
+-- ...   | in₁ (single k,tt∈vs₁) _ = (in⁻₁ (∈-Expr-vars⇒∈ e₁ (forget k,tt∈vs₁)))
+-- ...   | in₂ _ (single k,tt∈vs₂) = (in⁻₂ (∈-Expr-vars⇒∈ e₂ (forget k,tt∈vs₂)))
+-- ...   | bothᵘ (single k,tt∈vs₁) _ = (in⁻₁ (∈-Expr-vars⇒∈ e₁ (forget k,tt∈vs₁)))
+-- ∈-Expr-vars⇒∈ {k} (` k) (RelAny.here refl) = here
+
+-- ∈⇒∈-Expr-vars : ∀ {k : String} {e : Expr} → k ∈ᵉ e → k ∈ˢ (Expr-vars e)
+-- ∈⇒∈-Expr-vars {k} {e₁ + e₂} (in⁺₁ k∈e₁) =
+--     ⊔ˢ-preserves-∈k₁ {m₁ = Expr-vars e₁}
+--                      {m₂ = Expr-vars e₂}
+--                      (∈⇒∈-Expr-vars k∈e₁)
+-- ∈⇒∈-Expr-vars {k} {e₁ + e₂} (in⁺₂ k∈e₂) =
+--     ⊔ˢ-preserves-∈k₂ {m₁ = Expr-vars e₁}
+--                      {m₂ = Expr-vars e₂}
+--                      (∈⇒∈-Expr-vars k∈e₂)
+-- ∈⇒∈-Expr-vars {k} {e₁ - e₂} (in⁻₁ k∈e₁) =
+--     ⊔ˢ-preserves-∈k₁ {m₁ = Expr-vars e₁}
+--                      {m₂ = Expr-vars e₂}
+--                      (∈⇒∈-Expr-vars k∈e₁)
+-- ∈⇒∈-Expr-vars {k} {e₁ - e₂} (in⁻₂ k∈e₂) =
+--     ⊔ˢ-preserves-∈k₂ {m₁ = Expr-vars e₁}
+--                      {m₂ = Expr-vars e₂}
+--                      (∈⇒∈-Expr-vars k∈e₂)
+-- ∈⇒∈-Expr-vars here = RelAny.here refl
+
+BasicStmt-vars : BasicStmt → StringSet
+BasicStmt-vars (x ← e) = (singletonˢ x) ⊔ˢ (Expr-vars e)
+BasicStmt-vars noop = emptyˢ
+
+Stmt-vars : Stmt → StringSet
+Stmt-vars ⟨ bs ⟩ = BasicStmt-vars bs
+Stmt-vars (s₁ then s₂) = (Stmt-vars s₁) ⊔ˢ (Stmt-vars s₂)
+Stmt-vars (if e then s₁ else s₂) = ((Expr-vars e) ⊔ˢ (Stmt-vars s₁)) ⊔ˢ (Stmt-vars s₂)
+Stmt-vars (while e repeat s) = (Expr-vars e) ⊔ˢ (Stmt-vars s)
+
+-- ∈-Stmt-vars⇒∈ : ∀ {k : String} (s : Stmt) → k ∈ˢ (Stmt-vars s) → k ∈ᵇ s
+-- ∈-Stmt-vars⇒∈ {k} (k' ← e) k∈vs
+--     with Expr-Provenance k ((`ˢ (singletonˢ k')) ∪ (`ˢ (Expr-vars e))) k∈vs
+-- ...   | in₁ (single (RelAny.here refl)) _ = in←₁
+-- ...   | in₂ _ (single k,tt∈vs') = in←₂ (∈-Expr-vars⇒∈ e (forget k,tt∈vs'))
+-- ...   | bothᵘ (single (RelAny.here refl)) _ = in←₁
+
+-- ∈⇒∈-Stmt-vars : ∀ {k : String} {s : Stmt} → k ∈ᵇ s → k ∈ˢ (Stmt-vars s)
+-- ∈⇒∈-Stmt-vars {k} {k ← e} in←₁ =
+--     ⊔ˢ-preserves-∈k₁ {m₁ = singletonˢ k}
+--                      {m₂ = Expr-vars e}
+--                      (RelAny.here refl)
+-- ∈⇒∈-Stmt-vars {k} {k' ← e} (in←₂ k∈e) =
+--     ⊔ˢ-preserves-∈k₂ {m₁ = singletonˢ k'}
+--                      {m₂ = Expr-vars e}
+--                      (∈⇒∈-Expr-vars k∈e)
+
+Stmts-vars : ∀ {n : ℕ} → Vec Stmt n → StringSet
+Stmts-vars = foldr (λ n → StringSet)
+                   (λ {k} stmt acc → (Stmt-vars stmt) ⊔ˢ acc) emptyˢ
+
+-- ∈-Stmts-vars⇒∈ : ∀ {n : ℕ} {k : String} (ss : Vec Stmt n) →
+--                  k ∈ˢ (Stmts-vars ss) → Σ (Fin n) (λ f → k ∈ᵇ lookup ss f)
+-- ∈-Stmts-vars⇒∈ {suc n'} {k} (s ∷ ss') k∈vss
+--     with Expr-Provenance k ((`ˢ (Stmt-vars s)) ∪ (`ˢ (Stmts-vars ss'))) k∈vss
+-- ...   | in₁ (single k,tt∈vs) _ = (zero , ∈-Stmt-vars⇒∈ s (forget k,tt∈vs))
+-- ...   | in₂ _ (single k,tt∈vss') =
+--         let
+--             (f' , k∈s') = ∈-Stmts-vars⇒∈ ss' (forget k,tt∈vss')
+--         in
+--             (suc f' , k∈s')
+-- ...   | bothᵘ (single k,tt∈vs) _ = (zero , ∈-Stmt-vars⇒∈ s (forget k,tt∈vs))
+
+-- ∈⇒∈-Stmts-vars : ∀ {n : ℕ} {k : String} {ss : Vec Stmt n} {f : Fin n} →
+--                  k ∈ᵇ lookup ss f → k ∈ˢ (Stmts-vars ss)
+-- ∈⇒∈-Stmts-vars {suc n} {k} {s ∷ ss'} {zero} k∈s =
+--     ⊔ˢ-preserves-∈k₁ {m₁ = Stmt-vars s}
+--                      {m₂ = Stmts-vars ss'}
+--                      (∈⇒∈-Stmt-vars k∈s)
+-- ∈⇒∈-Stmts-vars {suc n} {k} {s ∷ ss'} {suc f'} k∈ss' =
+--     ⊔ˢ-preserves-∈k₂ {m₁ = Stmt-vars s}
+--                      {m₂ = Stmts-vars ss'}
+--                      (∈⇒∈-Stmts-vars {n} {k} {ss'} {f'} k∈ss')

Language/Graphs.agda

@@ -0,0 +1,155 @@
+module Language.Graphs where
+
+open import Language.Base using (Expr; Stmt; BasicStmt; ⟨_⟩; _then_; if_then_else_; while_repeat_)
+
+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 (∈-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 (_×_; Σ; _,_; 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 (Unique; push; Unique-map; x∈xs⇒fx∈fxs; ∈-cartesianProduct)
+
+record Graph : Set where
+    constructor MkGraph
+    field
+        size : ℕ
+
+    Index : Set
+    Index = Fin size
+
+    Edge : Set
+    Edge = Index × Index
+
+    field
+        nodes : Vec (List BasicStmt) size
+        edges : List Edge
+        inputs : List Index
+        outputs : List Index
+
+_↑ˡ_ : ∀ {n} → (Fin n × Fin n) → ∀ m → (Fin (n Nat.+ m) × Fin (n Nat.+ m))
+_↑ˡ_ (idx₁ , idx₂) m = (idx₁ Fin.↑ˡ m , idx₂ Fin.↑ˡ m)
+
+_↑ʳ_ : ∀ {m} n → (Fin m × Fin m) → Fin (n Nat.+ m) × Fin (n Nat.+ m)
+_↑ʳ_ n (idx₁ , idx₂) = (n Fin.↑ʳ idx₁ , n Fin.↑ʳ idx₂)
+
+_↑ˡⁱ_ : ∀ {n} → List (Fin n) → ∀ m → List (Fin (n Nat.+ m))
+_↑ˡⁱ_ l m = List.map (Fin._↑ˡ m) l
+
+_↑ʳⁱ_ : ∀ {m} n → List (Fin m) → List (Fin (n Nat.+ m))
+_↑ʳⁱ_ n l = List.map (n Fin.↑ʳ_) l
+
+_↑ˡᵉ_ : ∀ {n} → List (Fin n × Fin n) → ∀ m → List (Fin (n Nat.+ m) × Fin (n Nat.+ m))
+_↑ˡᵉ_ l m = List.map (_↑ˡ m) l
+
+_↑ʳᵉ_ : ∀ {m} n → List (Fin m × Fin m) → List (Fin (n Nat.+ m) × Fin (n Nat.+ m))
+_↑ʳᵉ_ n l = List.map (n ↑ʳ_) l
+
+infixr 5 _∙_
+_∙_ : Graph → Graph → Graph
+_∙_ g₁ g₂ = record
+    { size = Graph.size g₁ Nat.+ Graph.size g₂
+    ; nodes = Graph.nodes g₁ ++ Graph.nodes g₂
+    ; edges = (Graph.edges g₁ ↑ˡᵉ Graph.size g₂) List.++
+              (Graph.size g₁ ↑ʳᵉ Graph.edges g₂)
+    ; inputs = (Graph.inputs g₁ ↑ˡⁱ Graph.size g₂) List.++
+               (Graph.size g₁ ↑ʳⁱ Graph.inputs g₂)
+    ; outputs = (Graph.outputs g₁ ↑ˡⁱ Graph.size g₂) List.++
+                (Graph.size g₁ ↑ʳⁱ Graph.outputs g₂)
+    }
+
+infixr 5 _↦_
+_↦_ : Graph → Graph → Graph
+_↦_ g₁ g₂ = record
+    { size = Graph.size g₁ Nat.+ Graph.size g₂
+    ; nodes = Graph.nodes g₁ ++ Graph.nodes g₂
+    ; edges = (Graph.edges g₁ ↑ˡᵉ Graph.size g₂) List.++
+              (Graph.size g₁ ↑ʳᵉ Graph.edges g₂) List.++
+              (List.cartesianProduct (Graph.outputs g₁ ↑ˡⁱ Graph.size g₂)
+                                     (Graph.size g₁ ↑ʳⁱ Graph.inputs g₂))
+    ; inputs = Graph.inputs g₁ ↑ˡⁱ Graph.size g₂
+    ; outputs = Graph.size g₁ ↑ʳⁱ Graph.outputs g₂
+    }
+
+loop : Graph → Graph
+loop g = record
+    { size = 2 Nat.+ Graph.size g
+    ; nodes = [] ∷ [] ∷ Graph.nodes g
+    ; edges = (2 ↑ʳᵉ Graph.edges g) List.++
+              List.map (zero ,_) (2 ↑ʳⁱ Graph.inputs g) List.++
+              List.map (_, suc zero) (2 ↑ʳⁱ Graph.outputs g) List.++
+              ((suc zero , zero) ∷ (zero , suc zero) ∷ [])
+    ; inputs = zero ∷ []
+    ; outputs = (suc zero) ∷ []
+    }
+
+infixr 5 _skipto_
+_skipto_ : Graph → Graph → Graph
+_skipto_ g₁ g₂ = record (g₁ ∙ g₂)
+    { edges = Graph.edges (g₁ ∙ g₂) List.++
+              (List.cartesianProduct (Graph.inputs g₁ ↑ˡⁱ Graph.size g₂)
+                                     (Graph.size g₁ ↑ʳⁱ Graph.inputs g₂))
+    ; inputs = Graph.inputs g₁ ↑ˡⁱ Graph.size g₂
+    ; outputs = Graph.size g₁ ↑ʳⁱ Graph.inputs g₂
+    }
+
+_[_] : ∀ (g : Graph) → Graph.Index g → List BasicStmt
+_[_] g idx = lookup (Graph.nodes g) idx
+
+singleton : List BasicStmt → Graph
+singleton bss = record
+    { size = 1
+    ; nodes = bss ∷ []
+    ; edges = []
+    ; inputs = zero ∷ []
+    ; 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₂) = 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

@@ -0,0 +1,296 @@
+module Language.Properties where
+
+open import Language.Base
+open import Language.Semantics
+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.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; 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₂)
+
+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₂'
+
+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₂ ρ₁ ρ₂ →
+           Trace {g₁ ∙ g₂} (idx₁ Fin.↑ˡ Graph.size g₂) (idx₂ Fin.↑ˡ Graph.size g₂) ρ₁ ρ₂
+Trace-∙ˡ {g₁} {g₂} {idx₁} {idx₁} (Trace-single ρ₁⇒ρ₂)
+    rewrite sym (lookup-++ˡ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-single ρ₁⇒ρ₂
+Trace-∙ˡ {g₁} {g₂} {idx₁} (Trace-edge ρ₁⇒ρ idx₁→idx tr')
+    rewrite sym (lookup-++ˡ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-edge ρ₁⇒ρ (ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (_↑ˡ Graph.size g₂) idx₁→idx))
+                    (Trace-∙ˡ tr')
+
+Trace-∙ʳ : ∀ {g₁ g₂ : Graph} {idx₁ idx₂ : Graph.Index g₂} {ρ₁ ρ₂ : Env} →
+           Trace {g₂} idx₁ idx₂ ρ₁ ρ₂ →
+           Trace {g₁ ∙ g₂} (Graph.size g₁ Fin.↑ʳ idx₁) (Graph.size g₁ Fin.↑ʳ idx₂) ρ₁ ρ₂
+Trace-∙ʳ {g₁} {g₂} {idx₁} {idx₁} (Trace-single ρ₁⇒ρ₂)
+    rewrite sym (lookup-++ʳ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-single ρ₁⇒ρ₂
+Trace-∙ʳ {g₁} {g₂} {idx₁} (Trace-edge ρ₁⇒ρ idx₁→idx tr')
+    rewrite sym (lookup-++ʳ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-edge ρ₁⇒ρ (ListMemProp.∈-++⁺ʳ _ (x∈xs⇒fx∈fxs (Graph.size g₁ ↑ʳ_) idx₁→idx))
+                    (Trace-∙ʳ tr')
+
+EndToEndTrace-∙ˡ : ∀ {g₁ g₂ : Graph} {ρ₁ ρ₂ : Env} →
+                   EndToEndTrace {g₁} ρ₁ ρ₂ →
+                   EndToEndTrace {g₁ ∙ g₂} ρ₁ ρ₂
+EndToEndTrace-∙ˡ {g₁} {g₂} etr = record
+    { idx₁ = EndToEndTrace.idx₁ etr Fin.↑ˡ Graph.size g₂
+    ; idx₁∈inputs = ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (Fin._↑ˡ Graph.size g₂)
+                                                    (EndToEndTrace.idx₁∈inputs etr))
+    ; idx₂ = EndToEndTrace.idx₂ etr Fin.↑ˡ Graph.size g₂
+    ; idx₂∈outputs = ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (Fin._↑ˡ Graph.size g₂)
+                                                    (EndToEndTrace.idx₂∈outputs etr))
+    ; trace = Trace-∙ˡ (EndToEndTrace.trace etr)
+    }
+
+EndToEndTrace-∙ʳ : ∀ {g₁ g₂ : Graph} {ρ₁ ρ₂ : Env} →
+           EndToEndTrace {g₂} ρ₁ ρ₂ →
+           EndToEndTrace {g₁ ∙ g₂} ρ₁ ρ₂
+EndToEndTrace-∙ʳ {g₁} {g₂} etr = record
+    { idx₁ = Graph.size g₁ Fin.↑ʳ EndToEndTrace.idx₁ etr
+    ; idx₁∈inputs = ListMemProp.∈-++⁺ʳ (Graph.inputs g₁ ↑ˡⁱ Graph.size g₂)
+                                       ((x∈xs⇒fx∈fxs (Graph.size g₁ Fin.↑ʳ_)
+                                                     (EndToEndTrace.idx₁∈inputs etr)))
+    ; idx₂ = Graph.size g₁ Fin.↑ʳ EndToEndTrace.idx₂ etr
+    ; idx₂∈outputs = ListMemProp.∈-++⁺ʳ (Graph.outputs g₁ ↑ˡⁱ Graph.size g₂)
+                                        ((x∈xs⇒fx∈fxs (Graph.size g₁ Fin.↑ʳ_)
+                                                      (EndToEndTrace.idx₂∈outputs etr)))
+
+    ; trace = Trace-∙ʳ (EndToEndTrace.trace etr)
+    }
+
+Trace-↦ˡ : ∀ {g₁ g₂ : Graph} {idx₁ idx₂ : Graph.Index g₁} {ρ₁ ρ₂ : Env} →
+           Trace {g₁} idx₁ idx₂ ρ₁ ρ₂ →
+           Trace {g₁ ↦ g₂} (idx₁ Fin.↑ˡ Graph.size g₂) (idx₂ Fin.↑ˡ Graph.size g₂) ρ₁ ρ₂
+Trace-↦ˡ {g₁} {g₂} {idx₁} {idx₁} (Trace-single ρ₁⇒ρ₂)
+    rewrite sym (lookup-++ˡ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-single ρ₁⇒ρ₂
+Trace-↦ˡ {g₁} {g₂} {idx₁} (Trace-edge ρ₁⇒ρ idx₁→idx tr')
+    rewrite sym (lookup-++ˡ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-edge ρ₁⇒ρ (ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (_↑ˡ Graph.size g₂) idx₁→idx))
+                    (Trace-↦ˡ tr')
+
+Trace-↦ʳ : ∀ {g₁ g₂ : Graph} {idx₁ idx₂ : Graph.Index g₂} {ρ₁ ρ₂ : Env} →
+           Trace {g₂} idx₁ idx₂ ρ₁ ρ₂ →
+           Trace {g₁ ↦ g₂} (Graph.size g₁ Fin.↑ʳ idx₁) (Graph.size g₁ Fin.↑ʳ idx₂) ρ₁ ρ₂
+Trace-↦ʳ {g₁} {g₂} {idx₁} {idx₁} (Trace-single ρ₁⇒ρ₂)
+    rewrite sym (lookup-++ʳ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-single ρ₁⇒ρ₂
+Trace-↦ʳ {g₁} {g₂} {idx₁} (Trace-edge ρ₁⇒ρ idx₁→idx tr')
+    rewrite sym (lookup-++ʳ (Graph.nodes g₁) (Graph.nodes g₂) idx₁) =
+    Trace-edge ρ₁⇒ρ (ListMemProp.∈-++⁺ʳ (Graph.edges g₁ ↑ˡᵉ Graph.size g₂)
+                                        (ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (Graph.size g₁ ↑ʳ_) idx₁→idx)))
+                    (Trace-↦ʳ {g₁} {g₂} tr')
+
+loop-edge-groups : ∀ (g : Graph) → List (List (Graph.Edge (loop g)))
+loop-edge-groups g =
+    (2 ↑ʳᵉ Graph.edges g) ∷
+    (List.map (zero ,_) (2 ↑ʳⁱ Graph.inputs g)) ∷
+    (List.map (_, suc zero) (2 ↑ʳⁱ Graph.outputs g)) ∷
+    ((suc zero , zero) ∷ (zero , suc zero) ∷ []) ∷
+    []
+
+loop-edge-help : ∀ (g : Graph) {l : List (Graph.Edge (loop g))} {e : Graph.Edge (loop g)} →
+                 e ListMem.∈ l → l ListMem.∈ loop-edge-groups g →
+                 e ListMem.∈ Graph.edges (loop g)
+loop-edge-help g e∈l l∈ess = concat-∈ e∈l l∈ess
+
+Trace-loop : ∀ {g : Graph} {idx₁ idx₂ : Graph.Index g} {ρ₁ ρ₂ : Env} →
+             Trace {g} idx₁ idx₂ ρ₁ ρ₂ → Trace {loop g} (2 Fin.↑ʳ idx₁) (2 Fin.↑ʳ idx₂) ρ₁ ρ₂
+Trace-loop {g} {idx₁} {idx₁} (Trace-single ρ₁⇒ρ₂)
+    rewrite sym (lookup-++ʳ (List.[] ∷ List.[] ∷ Vec.[]) (Graph.nodes g) idx₁) =
+    Trace-single ρ₁⇒ρ₂
+Trace-loop {g} {idx₁} (Trace-edge ρ₁⇒ρ idx₁→idx tr')
+    rewrite sym (lookup-++ʳ (List.[] ∷ List.[] ∷ Vec.[]) (Graph.nodes g) idx₁) =
+    Trace-edge ρ₁⇒ρ (ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (2 ↑ʳ_) idx₁→idx))
+                    (Trace-loop {g} tr')
+
+EndToEndTrace-loop : ∀ {g : Graph} {ρ₁ ρ₂ : Env} →
+                     EndToEndTrace {g} ρ₁ ρ₂ → EndToEndTrace {loop g} ρ₁ ρ₂
+EndToEndTrace-loop {g} etr =
+    let
+        zero→idx₁' = x∈xs⇒fx∈fxs (zero ,_)
+                                 (x∈xs⇒fx∈fxs (2 Fin.↑ʳ_)
+                                              (EndToEndTrace.idx₁∈inputs etr))
+        zero→idx₁ = loop-edge-help g zero→idx₁' (there (here refl))
+        idx₂→suc' = x∈xs⇒fx∈fxs (_, suc zero)
+                               (x∈xs⇒fx∈fxs (2 Fin.↑ʳ_)
+                                            (EndToEndTrace.idx₂∈outputs etr))
+        idx₂→suc = loop-edge-help g idx₂→suc' (there (there (here refl)))
+    in
+        record
+            { idx₁ = zero
+            ; idx₁∈inputs = here refl
+            ; idx₂ = suc zero
+            ; idx₂∈outputs = here refl
+            ; trace =
+                Trace-single [] ++⟨ zero→idx₁ ⟩
+                Trace-loop {g} (EndToEndTrace.trace etr) ++⟨ idx₂→suc ⟩
+                Trace-single []
+            }
+
+EndToEndTrace-loop² : ∀ {g : Graph} {ρ₁ ρ₂ ρ₃ : Env} →
+                      EndToEndTrace {loop g} ρ₁ ρ₂ →
+                      EndToEndTrace {loop g} ρ₂ ρ₃ →
+                      EndToEndTrace {loop g} ρ₁ ρ₃
+EndToEndTrace-loop² {g} (MkEndToEndTrace zero (here refl) (suc zero) (here refl) tr₁)
+                        (MkEndToEndTrace zero (here refl) (suc zero) (here refl) tr₂) =
+    let
+        suc→zero = loop-edge-help g (here refl)
+                                    (there (there (there (here refl))))
+    in
+        record
+            { idx₁ = zero
+            ; idx₁∈inputs = here refl
+            ; idx₂ = suc zero
+            ; idx₂∈outputs = here refl
+            ; trace = tr₁ ++⟨ suc→zero ⟩ tr₂
+            }
+
+EndToEndTrace-loop⁰ : ∀ {g : Graph} {ρ : Env} →
+                      EndToEndTrace {loop g} ρ ρ
+EndToEndTrace-loop⁰ {g} {ρ} =
+    let
+        zero→suc = loop-edge-help g (there (here refl))
+                                    (there (there (there (here refl))))
+    in
+        record
+            { idx₁ = zero
+            ; idx₁∈inputs = here refl
+            ; idx₂ = suc zero
+            ; idx₂∈outputs = here refl
+            ; trace = Trace-single [] ++⟨ zero→suc ⟩ Trace-single []
+            }
+
+infixr 5 _++_
+_++_ : ∀ {g₁ g₂ : Graph} {ρ₁ ρ₂ ρ₃ : Env} →
+       EndToEndTrace {g₁} ρ₁ ρ₂ → EndToEndTrace {g₂} ρ₂ ρ₃ →
+       EndToEndTrace {g₁ ↦ g₂} ρ₁ ρ₃
+_++_ {g₁} {g₂} etr₁ etr₂
+    = record
+        { idx₁ = EndToEndTrace.idx₁ etr₁ Fin.↑ˡ Graph.size g₂
+        ; idx₁∈inputs = x∈xs⇒fx∈fxs (Fin._↑ˡ Graph.size g₂) (EndToEndTrace.idx₁∈inputs etr₁)
+        ; idx₂ = Graph.size g₁ Fin.↑ʳ EndToEndTrace.idx₂ etr₂
+        ; idx₂∈outputs = x∈xs⇒fx∈fxs (Graph.size g₁ Fin.↑ʳ_) (EndToEndTrace.idx₂∈outputs etr₂)
+        ; trace =
+            let
+                o∈tr₁ = x∈xs⇒fx∈fxs (Fin._↑ˡ Graph.size g₂) (EndToEndTrace.idx₂∈outputs etr₁)
+                i∈tr₂ = x∈xs⇒fx∈fxs (Graph.size g₁ Fin.↑ʳ_) (EndToEndTrace.idx₁∈inputs etr₂)
+                oi∈es = ListMemProp.∈-++⁺ʳ (Graph.edges g₁ ↑ˡᵉ Graph.size g₂)
+                                           (ListMemProp.∈-++⁺ʳ (Graph.size g₁ ↑ʳᵉ Graph.edges g₂)
+                                                               (∈-cartesianProduct o∈tr₁ i∈tr₂))
+            in
+                (Trace-↦ˡ {g₁} {g₂} (EndToEndTrace.trace etr₁)) ++⟨ oi∈es ⟩
+                (Trace-↦ʳ {g₁} {g₂} (EndToEndTrace.trace etr₂))
+        }
+
+EndToEndTrace-singleton : ∀ {bss : List BasicStmt} {ρ₁ ρ₂ : Env} →
+                  ρ₁ , bss ⇒ᵇˢ ρ₂ → EndToEndTrace {singleton bss} ρ₁ ρ₂
+EndToEndTrace-singleton ρ₁⇒ρ₂ = record
+    { idx₁ = zero
+    ; idx₁∈inputs = here refl
+    ; idx₂ = zero
+    ; idx₂∈outputs = here refl
+    ; trace = Trace-single ρ₁⇒ρ₂
+    }
+
+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⇒ρ₂) =
+    EndToEndTrace-singleton (ρ₁,bs⇒ρ₂ ∷ [])
+buildCfg-sufficient (⇒ˢ-then ρ₁ ρ₂ ρ₃ s₁ s₂ ρ₁,s₁⇒ρ₂ ρ₂,s₂⇒ρ₃) =
+    buildCfg-sufficient ρ₁,s₁⇒ρ₂ ++ buildCfg-sufficient ρ₂,s₂⇒ρ₃
+buildCfg-sufficient (⇒ˢ-if-true ρ₁ ρ₂ _ _ s₁ s₂ _ _ ρ₁,s₁⇒ρ₂) =
+    EndToEndTrace-∙ˡ (buildCfg-sufficient ρ₁,s₁⇒ρ₂)
+buildCfg-sufficient (⇒ˢ-if-false ρ₁ ρ₂ _ s₁ s₂ _ ρ₁,s₂⇒ρ₂) =
+    EndToEndTrace-∙ʳ {buildCfg s₁} (buildCfg-sufficient ρ₁,s₂⇒ρ₂)
+buildCfg-sufficient (⇒ˢ-while-true ρ₁ ρ₂ ρ₃ _ _ s _ _ ρ₁,s⇒ρ₂ ρ₂,ws⇒ρ₃) =
+    EndToEndTrace-loop² {buildCfg s}
+                        (EndToEndTrace-loop {buildCfg s} (buildCfg-sufficient ρ₁,s⇒ρ₂))
+                        (buildCfg-sufficient ρ₂,ws⇒ρ₃)
+buildCfg-sufficient (⇒ˢ-while-false ρ _ s _) =
+    EndToEndTrace-loop⁰ {buildCfg s} {ρ}

Language/Semantics.agda

@@ -0,0 +1,73 @@
+module Language.Semantics where
+
+open import Language.Base
+
+open import Agda.Primitive using (lsuc)
+open import Data.Integer using (ℤ; +_) renaming (_+_ to _+ᶻ_; _-_ to _-ᶻ_)
+open import Data.Product using (_×_; _,_)
+open import Data.String using (String)
+open import Data.List as List using (List)
+open import Data.Nat using (ℕ)
+open import Relation.Nullary using (¬_)
+open import Relation.Binary.PropositionalEquality using (_≡_)
+
+open import Lattice
+open import Utils using (_⇒_; _∧_; _∨_)
+
+data Value : Set where
+    ↑ᶻ : ℤ → Value
+
+Env : Set
+Env = List (String × Value)
+
+data _∈_ : (String × Value) → Env → Set where
+    here : ∀ (s : String) (v : Value) (ρ : Env) → (s , v) ∈ ((s , v) List.∷ ρ)
+    there : ∀ (s s' : String) (v v' : Value) (ρ : Env) → ¬ (s ≡ s') → (s , v) ∈ ρ → (s , v) ∈ ((s' , v') List.∷ ρ)
+
+data _,_⇒ᵉ_ : Env → Expr → Value → Set where
+    ⇒ᵉ-ℕ : ∀ (ρ : Env) (n : ℕ) → ρ , (# n) ⇒ᵉ (↑ᶻ (+ n))
+    ⇒ᵉ-Var : ∀ (ρ : Env) (x : String) (v : Value) → (x , v) ∈ ρ → ρ , (` x) ⇒ᵉ v
+    ⇒ᵉ-+ : ∀ (ρ : Env) (e₁ e₂ : Expr) (z₁ z₂ : ℤ) →
+           ρ , e₁ ⇒ᵉ (↑ᶻ z₁) → ρ , e₂ ⇒ᵉ (↑ᶻ z₂) →
+           ρ , (e₁ + e₂) ⇒ᵉ (↑ᶻ (z₁ +ᶻ z₂))
+    ⇒ᵉ-- : ∀ (ρ : Env) (e₁ e₂ : Expr) (z₁ z₂ : ℤ) →
+           ρ , e₁ ⇒ᵉ (↑ᶻ z₁) → ρ , e₂ ⇒ᵉ (↑ᶻ z₂) →
+           ρ , (e₁ - e₂) ⇒ᵉ (↑ᶻ (z₁ -ᶻ z₂))
+
+data _,_⇒ᵇ_ : Env → BasicStmt → Env → Set where
+    ⇒ᵇ-noop : ∀ (ρ : Env) → ρ , noop ⇒ᵇ ρ
+    ⇒ᵇ-← : ∀ (ρ : Env) (x : String) (e : Expr) (v : Value) →
+           ρ , e ⇒ᵉ v → ρ , (x ← e) ⇒ᵇ ((x , v) List.∷ ρ)
+
+data _,_⇒ᵇˢ_ : Env → List BasicStmt → Env → Set where
+    [] : ∀ {ρ : Env} → ρ , List.[] ⇒ᵇˢ ρ
+    _∷_ : ∀ {ρ₁ ρ₂ ρ₃ : Env} {bs : BasicStmt} {bss : List BasicStmt} →
+          ρ₁ , bs ⇒ᵇ ρ₂ → ρ₂ , bss ⇒ᵇˢ ρ₃ → ρ₁ , (bs List.∷ bss) ⇒ᵇˢ ρ₃
+
+data _,_⇒ˢ_ : Env → Stmt → Env → Set where
+    ⇒ˢ-⟨⟩ : ∀ (ρ₁ ρ₂ : Env) (bs : BasicStmt) →
+            ρ₁ , bs ⇒ᵇ ρ₂ → ρ₁ , ⟨ bs ⟩ ⇒ˢ ρ₂
+    ⇒ˢ-then : ∀ (ρ₁ ρ₂ ρ₃ : Env) (s₁ s₂ : Stmt) →
+              ρ₁ , s₁ ⇒ˢ ρ₂ → ρ₂ , s₂ ⇒ˢ ρ₃ →
+              ρ₁ , (s₁ then s₂) ⇒ˢ ρ₃
+    ⇒ˢ-if-true : ∀ (ρ₁ ρ₂ : Env) (e : Expr) (z : ℤ) (s₁ s₂ : Stmt) →
+        ρ₁ , e ⇒ᵉ (↑ᶻ z) → ¬ z ≡ (+ 0) → ρ₁ , s₁ ⇒ˢ ρ₂ →
+        ρ₁ , (if e then s₁ else s₂) ⇒ˢ ρ₂
+    ⇒ˢ-if-false : ∀ (ρ₁ ρ₂ : Env) (e : Expr) (s₁ s₂ : Stmt) →
+        ρ₁ , e ⇒ᵉ (↑ᶻ (+ 0)) → ρ₁ , s₂ ⇒ˢ ρ₂ →
+        ρ₁ , (if e then s₁ else s₂) ⇒ˢ ρ₂
+    ⇒ˢ-while-true : ∀ (ρ₁ ρ₂ ρ₃ : Env) (e : Expr) (z : ℤ) (s : Stmt) →
+        ρ₁ , e ⇒ᵉ (↑ᶻ z) → ¬ z ≡ (+ 0) → ρ₁ , s ⇒ˢ ρ₂ → ρ₂ , (while e repeat s) ⇒ˢ ρ₃ →
+        ρ₁ , (while e repeat s) ⇒ˢ ρ₃
+    ⇒ˢ-while-false : ∀ (ρ : Env) (e : Expr) (s : Stmt) →
+        ρ , e ⇒ᵉ (↑ᶻ (+ 0)) →
+        ρ , (while e repeat s) ⇒ˢ ρ
+
+record LatticeInterpretation {l} {L : Set l} {_≈_ : L → L → Set l}
+                             {_⊔_ : L → L → L} {_⊓_ : L → L → L}
+                             (isLattice : IsLattice L _≈_ _⊔_ _⊓_) : Set (lsuc l) where
+    field
+        ⟦_⟧ : L → Value → Set
+        ⟦⟧-respects-≈ : ∀ {l₁ l₂ : L} → l₁ ≈ l₂ → ⟦ l₁ ⟧ ⇒ ⟦ l₂ ⟧
+        ⟦⟧-⊔-∨ : ∀ {l₁ l₂ : L} → (⟦ l₁ ⟧ ∨ ⟦ l₂ ⟧) ⇒ ⟦ l₁ ⊔ l₂ ⟧
+        ⟦⟧-⊓-∧ : ∀ {l₁ l₂ : L} → (⟦ l₁ ⟧ ∧ ⟦ l₂ ⟧) ⇒ ⟦ l₁ ⊓ l₂ ⟧

Language/Traces.agda

@@ -0,0 +1,36 @@
+module Language.Traces where
+
+open import Language.Base
+open import Language.Semantics using (Env; _,_⇒ᵇˢ_)
+open import Language.Graphs
+
+open import Data.Product using (_,_)
+open import Data.List.Membership.Propositional using (_∈_)
+
+module _ {g : Graph} where
+    open Graph g using (Index; edges; inputs; outputs)
+
+    data Trace : Index → Index → Env → Env → Set where
+        Trace-single : ∀ {ρ₁ ρ₂ : Env} {idx : Index} →
+                       ρ₁ , (g [ idx ]) ⇒ᵇˢ ρ₂ → Trace idx idx ρ₁ ρ₂
+        Trace-edge : ∀ {ρ₁ ρ₂ ρ₃ : Env} {idx₁ idx₂ idx₃ : Index} →
+                     ρ₁ , (g [ idx₁ ]) ⇒ᵇˢ ρ₂ → (idx₁ , idx₂) ∈ edges →
+                     Trace idx₂ idx₃ ρ₂ ρ₃ → Trace idx₁ idx₃ ρ₁ ρ₃
+
+    infixr 5 _++⟨_⟩_
+    _++⟨_⟩_ : ∀ {idx₁ idx₂ idx₃ idx₄ : Index} {ρ₁ ρ₂ ρ₃ : Env} →
+           Trace idx₁ idx₂ ρ₁ ρ₂ → (idx₂ , idx₃) ∈ edges →
+           Trace idx₃ idx₄ ρ₂ ρ₃ → Trace idx₁ idx₄ ρ₁ ρ₃
+    _++⟨_⟩_ (Trace-single ρ₁⇒ρ₂) idx₂→idx₃ tr = Trace-edge ρ₁⇒ρ₂ idx₂→idx₃ tr
+    _++⟨_⟩_ (Trace-edge ρ₁⇒ρ₂ idx₁→idx' tr') idx₂→idx₃ tr = Trace-edge ρ₁⇒ρ₂ idx₁→idx' (tr' ++⟨ idx₂→idx₃ ⟩ tr)
+
+    record EndToEndTrace (ρ₁ ρ₂ : Env) : Set where
+        constructor MkEndToEndTrace
+        field
+            idx₁ : Index
+            idx₁∈inputs : idx₁ ∈ inputs
+
+            idx₂ : Index
+            idx₂∈outputs : idx₂ ∈ outputs
+
+            trace : Trace idx₁ idx₂ ρ₁ ρ₂

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
@@ -124,7 +138,7 @@ module _ {a} {A : Set a}
     open IsSemilattice lA using (_≼_)
 
     id-Mono : Monotonic _≼_ _≼_ (λ x → x)
-    id-Mono a₁≼a₂ = a₁≼a₂
+    id-Mono {a₁} {a₂} a₁≼a₂ = a₁≼a₂
 
 module _ {a b} {A : Set a} {B : Set b}
          {_≈₁_ : A → A → Set a} {_⊔₁_ : A → A → A}
@@ -137,7 +151,7 @@ module _ {a b} {A : Set a} {B : Set b}
     const-Mono : ∀ (x : B) → Monotonic _≼₁_ _≼₂_ (λ _ → x)
     const-Mono x _ = ⊔₂-idemp x
 
-    open import Data.List as List using (List; foldr; _∷_)
+    open import Data.List as List using (List; foldr; foldl; _∷_)
     open import Utils using (Pairwise; _∷_)
 
     foldr-Mono : ∀ (l₁ l₂ : List A) (f : A → B → B) (b₁ b₂ : B) →
@@ -150,14 +164,44 @@ module _ {a b} {A : Set a} {B : Set b}
         ≼₂-trans (f-Mono₁ (foldr f b₁ xs) x≼y)
                  (f-Mono₂ y (foldr-Mono xs ys f b₁ b₂ xs≼ys b₁≼b₂ f-Mono₁ f-Mono₂))
 
+    foldl-Mono : ∀ (l₁ l₂ : List A) (f : B → A → B) (b₁ b₂ : B) →
+                 Pairwise _≼₁_ l₁ l₂ → b₁ ≼₂ b₂ →
+                 (∀ a → Monotonic _≼₂_ _≼₂_ (λ b → f b a)) →
+                 (∀ b → Monotonic _≼₁_ _≼₂_ (f b)) →
+                 foldl f b₁ l₁ ≼₂ foldl f b₂ l₂
+    foldl-Mono List.[] List.[] f b₁ b₂ _ b₁≼b₂ _ _ = b₁≼b₂
+    foldl-Mono (x ∷ xs) (y ∷ ys) f b₁ b₂ (x≼y ∷ xs≼ys) b₁≼b₂ f-Mono₁ f-Mono₂ =
+        foldl-Mono xs ys f (f b₁ x) (f b₂ y) xs≼ys (≼₂-trans (f-Mono₁ x b₁≼b₂) (f-Mono₂ b₂ x≼y)) f-Mono₁ f-Mono₂
+
+module _ {a b} {A : Set a} {B : Set b}
+         {_≈₂_ : B → B → Set b} {_⊔₂_ : B → B → B}
+         (lB : IsSemilattice B _≈₂_ _⊔₂_) where
+
+    open IsSemilattice lB using () renaming (_≼_ to _≼₂_; ⊔-idemp to ⊔₂-idemp; ≼-trans to ≼₂-trans)
+
+    open import Data.List as List using (List; foldr; foldl; _∷_)
+    open import Utils using (Pairwise; _∷_)
+
+    foldr-Mono' : ∀ (l : List A) (f : A → B → B) →
+                  (∀ a → Monotonic _≼₂_ _≼₂_ (f a)) →
+                  Monotonic _≼₂_ _≼₂_ (λ b → foldr f b l)
+    foldr-Mono' List.[] f _ b₁≼b₂ = b₁≼b₂
+    foldr-Mono' (x ∷ xs) f f-Mono₂ b₁≼b₂ = f-Mono₂ x (foldr-Mono' xs f f-Mono₂ b₁≼b₂)
+
+    foldl-Mono' : ∀ (l : List A) (f : B → A → B) →
+                  (∀ b → Monotonic _≼₂_ _≼₂_ (λ a → f a b)) →
+                  Monotonic _≼₂_ _≼₂_ (λ b → foldl f b l)
+    foldl-Mono' List.[] f _ b₁≼b₂ = b₁≼b₂
+    foldl-Mono' (x ∷ xs) f f-Mono₁ b₁≼b₂ = foldl-Mono' xs f f-Mono₁ (f-Mono₁ x b₁≼b₂)
+
 record IsLattice {a} (A : Set a)
     (_≈_ : A → A → Set a)
     (_⊔_ : A → A → 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
@@ -186,12 +230,34 @@ 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
+
+    -- 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)
+
+        module MyChain = Chain _≈_ ≈-equiv _≺_ ≺-cong
+        open MyChain.Height fixedHeight using (⊥; ⊤) public
+        open MyChain.Height fixedHeight using (bounded; longestChain)
+
+        ⊥≼ : ∀ (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 (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}
@@ -221,7 +287,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
 
@@ -232,7 +298,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
 
@@ -243,6 +309,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,16 +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)
 
@@ -19,11 +22,23 @@ 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
     [_] : A → AboveBelow
 
+instance
+    showable : {{ showableA : Showable A }} → Showable AboveBelow
+    showable = record
+        { show = (λ
+            { ⊥ → "⊥"
+            ; ⊤ → "⊤"
+            ; [ a ] → show a
+            })
+        }
+
 data _≈_ : AboveBelow → AboveBelow → Set a where
     ≈-⊥-⊥ : ⊥ ≈ ⊥
     ≈-⊤-⊤ : ⊤ ≈ ⊤
@@ -51,7 +66,7 @@ data _≈_ : AboveBelow → AboveBelow → Set a where
     ; ≈-trans = ≈-trans
     }
 
-≈-dec : IsDecidable _≈_
+≈-dec : Decidable _≈_
 ≈-dec ⊥ ⊥ = yes ≈-⊥-⊥
 ≈-dec ⊤ ⊤ = yes ≈-⊤-⊤
 ≈-dec [ x ] [ y ]
@@ -65,10 +80,17 @@ 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.
-module Plain where
+--
+-- For convenience, ask for the underlying type to always be inhabited, to
+-- avoid requiring additional constraints in some of the proofs below.
+module Plain (x : A) where
     _⊔_ : AboveBelow → AboveBelow → AboveBelow
     ⊥ ⊔ x = x
     ⊤ ⊔ x = ⊤
@@ -155,6 +177,7 @@ module Plain where
     ⊔-idemp ⊥ = ≈-⊥-⊥
     ⊔-idemp [ x ] rewrite x≈y⇒[x]⊔[y]≡[x] (≈₁-refl {x}) = ≈-refl
 
+    instance
         isJoinSemilattice : IsSemilattice AboveBelow _≈_ _⊔_
         isJoinSemilattice = record
             { ≈-equiv = ≈-equiv
@@ -248,6 +271,7 @@ module Plain where
     ⊓-idemp ⊤ = ≈-⊤-⊤
     ⊓-idemp [ x ] rewrite x≈y⇒[x]⊓[y]≡[x] (≈₁-refl {x}) = ≈-refl
 
+    instance
         isMeetSemilattice : IsSemilattice AboveBelow _≈_ _⊓_
         isMeetSemilattice = record
             { ≈-equiv = ≈-equiv
@@ -280,6 +304,7 @@ module Plain where
     ...   | no x̷≈y rewrite x̷≈y⇒[x]⊔[y]≡⊤ x̷≈y rewrite x⊓⊤≡x [ x ] = ≈-refl
 
 
+    instance
         isLattice : IsLattice AboveBelow _≈_ _⊔_ _⊓_
         isLattice = record
             { joinSemilattice = isJoinSemilattice
@@ -296,7 +321,7 @@ module Plain where
             ; isLattice = isLattice
             }
 
-    open IsLattice isLattice using (_≼_; _≺_)
+    open IsLattice isLattice using (_≼_; _≺_; ≼-trans; ≼-refl; ⊔-Monotonicˡ; ⊔-Monotonicʳ) public
 
     ⊥≺[x] : ∀ (x : A) → ⊥ ≺ [ x ]
     ⊥≺[x] x = (≈-refl , λ ())
@@ -322,7 +347,6 @@ module Plain where
 
     open Chain _≈_ ≈-equiv (IsLattice._≺_ isLattice) (IsLattice.≺-cong isLattice)
 
-    module _ (x : A) where
     longestChain : Chain ⊥ ⊤ 2
     longestChain = step (⊥≺[x] x) ≈-refl (step ([x]≺⊤ x) ≈-⊤-⊤ (done ≈-⊤-⊤))
 
@@ -341,10 +365,19 @@ module Plain 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 = record
+            { ⊥ = ⊥
+            ; ⊤ = ⊤
+            ; longestChain = longestChain
+            ; bounded = isLongest
+            }
+
         isFiniteHeightLattice : IsFiniteHeightLattice AboveBelow 2 _≈_ _⊔_ _⊓_
         isFiniteHeightLattice = record
             { isLattice = isLattice
-            ; fixedHeight = (((⊥ , ⊤) , longestChain) , isLongest)
+            ; fixedHeight = fixedHeight
             }
 
         finiteHeightLattice : FiniteHeightLattice AboveBelow

Lattice/Builder.agda

@@ -0,0 +1,381 @@
+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-¬)
+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.Unit using (⊤; tt)
+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⁺)
+open import Data.List.Relation.Unary.Any using (Any; here; there; any?; satisfied)
+open import Data.List.Relation.Unary.Any.Properties using (¬Any[])
+open import Data.List.Relation.Unary.All using (All; []; _∷_; map; lookup; zipWith; tabulate; all?)
+open import Data.List.Relation.Unary.All.Properties using () renaming (++⁺ to ++ˡ⁺; ++⁻ʳ to ++ˡ⁻ʳ)
+open import Data.List using (List; _∷_; []; cartesianProduct; cartesianProductWith; foldr) 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; ¬?)
+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 Agda.Primitive using (lsuc; Level) renaming (_⊔_ to _⊔ℓ_)
+
+record Graph : Set where
+    constructor mkGraph
+    field
+        size : ℕ
+
+    Node : Set
+    Node = Fin size
+
+    nodes = fins size
+
+    nodes-complete = fins-complete size
+
+    Edge : Set
+    Edge = Node × Node
+
+    field
+        edges : List Edge
+
+    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₂'
+
+    Adjecency-append : ∀ {n₁ n₂ : Node} → List (Path n₁ n₂) → Adjacency → Adjacency
+    Adjecency-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 ∈ˡ Adjecency-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-T? : Dec Has-⊤
+    Has-T? = findUniversal (proj₁ nodes) PathExists?
+
+    Has-⊥ : Set
+    Has-⊥ = Any Is-⊥ (proj₁ nodes)
+
+    Has-⊥? : Dec Has-⊥
+    Has-⊥? = findUniversal (proj₁ nodes) (λ n₁ n₂ → PathExists? n₂ n₁)

Lattice/Bundles/FiniteValueMap.agda

@@ -1,26 +0,0 @@
-open import Relation.Binary.PropositionalEquality using (_≡_)
-open import Relation.Binary.Definitions using (Decidable)
-
-module Lattice.Bundles.FiniteValueMap (A B : Set) (≡-dec-A : Decidable (_≡_ {_} {A})) where
-
-open import Lattice
-open import Data.List using (List)
-open import Data.Nat using (ℕ)
-open import Utils using (Unique)
-
-module _ (fhB : FiniteHeightLattice B) where
-    open Lattice.FiniteHeightLattice fhB using () renaming
-        ( _≈_ to _≈₂_; _⊔_ to _⊔₂_; _⊓_ to _⊓₂_
-        ; height to height₂
-        ; isLattice to isLattice₂
-        ; fixedHeight to fixedHeight₂
-        )
-
-    module _ {ks : List A} (uks : Unique ks) (≈₂-dec : Decidable _≈₂_) where
-        import Lattice.FiniteValueMap A B _≈₂_ _⊔₂_ _⊓₂_ ≡-dec-A isLattice₂ as FVM
-
-        FiniteHeightType = FVM.FiniteMap
-
-        ≈-dec = FVM.≈-dec ks ≈₂-dec
-
-        finiteHeightLattice = FVM.IterProdIsomorphism.finiteHeightLattice uks ≈₂-dec height₂ fixedHeight₂

Lattice/Bundles/IterProd.agda

@@ -1,38 +0,0 @@
-open import Lattice
-
-module Lattice.Bundles.IterProd {a} (A B : Set a) where
-open import Data.Nat using (ℕ)
-
-module _ (lA : Lattice A) (lB : Lattice B) where
-    open Lattice.Lattice lA using () renaming
-        ( _≈_ to _≈₁_; _⊔_ to _⊔₁_; _⊓_ to _⊓₁_
-        ; isLattice to isLattice₁
-        )
-
-    open Lattice.Lattice lB using () renaming
-        ( _≈_ to _≈₂_; _⊔_ to _⊔₂_; _⊓_ to _⊓₂_
-        ; isLattice to isLattice₂
-        )
-
-    module _ (k : ℕ) where
-        open import Lattice.IterProd _≈₁_ _≈₂_ _⊔₁_ _⊔₂_ _⊓₁_ _⊓₂_ isLattice₁ isLattice₂ using (lattice) public
-
-module _ (fhA : FiniteHeightLattice A) (fhB : FiniteHeightLattice B) where
-    open Lattice.FiniteHeightLattice fhA using () renaming
-        ( _≈_ to _≈₁_; _⊔_ to _⊔₁_; _⊓_ to _⊓₁_
-        ; height to height₁
-        ; isLattice to isLattice₁
-        ; fixedHeight to fixedHeight₁
-        )
-
-    open Lattice.FiniteHeightLattice fhB using () renaming
-        ( _≈_ to _≈₂_; _⊔_ to _⊔₂_; _⊓_ to _⊓₂_
-        ; height to height₂
-        ; isLattice to isLattice₂
-        ; fixedHeight to fixedHeight₂
-        )
-
-    module _ (≈₁-dec : IsDecidable _≈₁_) (≈₂-dec : IsDecidable _≈₂_) (k : ℕ) where
-        import Lattice.IterProd _≈₁_ _≈₂_ _⊔₁_ _⊔₂_ _⊓₁_ _⊓₂_ isLattice₁ isLattice₂ as IP
-
-        finiteHeightLattice = IP.finiteHeightLattice k ≈₁-dec ≈₂-dec height₁ height₂ fixedHeight₁ fixedHeight₂

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

@@ -2,16 +2,29 @@ open import Lattice
 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.List using (List; _∷_; [])
+open import Data.Unit using (⊤)
 
-module Lattice.FiniteMap {a b : Level} (A : Set a) (B : Set b)
-    (_≈₂_ : B → B → Set b)
-    (_⊔₂_ : B → B → B) (_⊓₂_ : B → B → B)
-    (≡-dec-A : IsDecidable (_≡_ {a} {A}))
-    (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+module Lattice.FiniteMap (A : Set) (B : Set)
+    {_≈₂_ : B → B → Set}
+    {_⊔₂_ : B → B → B} {_⊓₂_ : B → B → B}
+    {{≡-Decidable-A : IsDecidable {_} {A} _≡_}}
+    {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}} (ks : List A) where
 
-open import Lattice.Map A B _≈₂_ _⊔₂_ _⊓₂_ ≡-dec-A lB as Map
-    using (Map; ⊔-equal-keys; ⊓-equal-keys)
+open IsLattice lB using () renaming (_≼_ to _≼₂_)
+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 _⊔ᵐ_
@@ -27,20 +40,58 @@ open import Lattice.Map A B _≈₂_ _⊔₂_ _⊓₂_ ≡-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_
+        ; updating-via-keys-≡ to updatingᵐ-via-keys-≡
+        ; updating-via-k∈ks to updatingᵐ-via-k∈ks
+        ; updating-via-k∈ks-≡ to updatingᵐ-via-k∈ks-≡
+        ; updating-via-∈k-forward to updatingᵐ-via-∈k-forward
+        ; updating-via-k∉ks-forward to updatingᵐ-via-k∉ks-forward
+        ; updating-via-k∉ks-backward to updatingᵐ-via-k∉ks-backward
+        ; f'-Monotonic to f'-Monotonicᵐ
+        ; _≼_ to _≼ᵐ_
+        ; ∈k-dec to ∈k-decᵐ
         )
-open import Data.Product using (_×_; _,_; Σ; proj₁ ; proj₂)
+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.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; _∷_; []; Unique; push; empty; All¬-¬Any)
+open import Showable using (Showable; show)
+open import Isomorphism using (IsInverseˡ; IsInverseʳ)
+open import Chain using (Height)
 
-module _ (ks : List A) where
-    FiniteMap : Set (a ⊔ℓ b)
+private module WithKeys (ks : List A) where
+    FiniteMap : Set
     FiniteMap = Σ Map (λ m → Map.keys m ≡ ks)
 
-    _≈_ : FiniteMap → FiniteMap → Set (a ⊔ℓ b)
+    instance
+        showable : {{ showableA : Showable A }} {{ showableB : Showable B }} →
+                   Showable FiniteMap
+        showable = record { show = λ (m₁ , _) → show m₁ }
+
+    _≈_ : FiniteMap → FiniteMap → Set
     _≈_ (m₁ , _) (m₂ , _) = m₁ ≈ᵐ m₂
 
-    ≈-dec : IsDecidable _≈₂_ → IsDecidable _≈_
-    ≈-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) =
@@ -56,6 +107,32 @@ module _ (ks : List A) where
                 km₁≡ks
         )
 
+    _∈_ : A × B → FiniteMap → Set
+    _∈_ k,v (m₁ , _) = k,v ∈ˡ (proj₁ m₁)
+
+    _∈k_ : A → FiniteMap → Set
+    _∈k_ k (m₁ , _) = k ∈ˡ (keysᵐ m₁)
+
+    open Map using (forget) public
+
+    ∈k-dec = ∈k-decᵐ
+
+    locate : ∀ {k : A} {fm : FiniteMap} → k ∈k fm → Σ B (λ v → (k , v) ∈ fm)
+    locate {k} {fm = (m , _)} k∈kfm = locateᵐ {k} {m} k∈kfm
+
+    _updating_via_ : FiniteMap → List A → (A → B) → FiniteMap
+    _updating_via_ (m₁ , ksm₁≡ks) ks f =
+        ( m₁ updatingᵐ ks via f
+        , trans (sym (updatingᵐ-via-keys-≡ m₁ ks f)) ksm₁≡ks
+        )
+
+    _[_] : 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 =
@@ -66,7 +143,9 @@ module _ (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
@@ -104,3 +183,453 @@ module _ (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 _≈ˡ_ _⊔ˡ_ _⊓ˡ_}}
+             (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
+
+        open IsLattice lL using () renaming (_≼_ to _≼ˡ_)
+
+        updater : L → A → B
+        updater l k = g k l
+
+        f' : L → FiniteMap
+        f' l = (f l) updating ks via (updater l)
+
+        f'-Monotonic : Monotonic _≼ˡ_ _≼_ f'
+        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)
+
+        f'-k∈ks : ∀ {k l} → k ∈ˡ ks → k ∈k (f' l) → (k , updater l k) ∈ (f' l)
+        f'-k∈ks {k} {l} = updatingᵐ-via-k∈ks (proj₁ (f l)) (updater l)
+
+        f'-k∈ks-≡ : ∀ {k v l} → k ∈ˡ ks → (k , v) ∈ (f' l) → v ≡ updater l k
+        f'-k∈ks-≡ {k} {v} {l} = updatingᵐ-via-k∈ks-≡ (proj₁ (f l)) (updater l)
+
+        f'-k∉ks-forward : ∀ {k v l} → ¬ k ∈ˡ ks → (k , v) ∈ (f l) → (k , v) ∈ (f' l)
+        f'-k∉ks-forward {k} {v} {l} = updatingᵐ-via-k∉ks-forward (proj₁ (f l)) (updater l)
+
+        f'-k∉ks-backward : ∀ {k v l} → ¬ k ∈ˡ ks → (k , v) ∈ (f' l) → (k , v) ∈ (f l)
+        f'-k∉ks-backward {k} {v} {l} = updatingᵐ-via-k∉ks-backward (proj₁ (f l)) (updater l)
+
+    all-equal-keys : ∀ (fm₁ fm₂ : FiniteMap) → (Map.keys (proj₁ fm₁) ≡ Map.keys (proj₁ fm₂))
+    all-equal-keys (fm₁ , km₁≡ks) (fm₂ , km₂≡ks) = trans km₁≡ks (sym km₂≡ks)
+
+    ∈k-exclusive : ∀ (fm₁ fm₂ : FiniteMap) {k : A} → ¬ ((k ∈k fm₁) × (¬ k ∈k fm₂))
+    ∈k-exclusive fm₁ fm₂ {k} (k∈kfm₁ , k∉kfm₂) =
+        let
+            k∈kfm₂ = subst (λ l → k ∈ˡ l) (all-equal-keys fm₁ fm₂) k∈kfm₁
+        in
+            k∉kfm₂ k∈kfm₂
+
+    m₁≼m₂⇒m₁[ks]≼m₂[ks] : ∀ (fm₁ fm₂ : FiniteMap) (ks' : List A) →
+                          fm₁ ≼ fm₂ → Pairwise _≼₂_ (fm₁ [ ks' ]) (fm₂ [ ks' ])
+    m₁≼m₂⇒m₁[ks]≼m₂[ks] _ _ [] _ = []
+    m₁≼m₂⇒m₁[ks]≼m₂[ks] fm₁@(m₁ , km₁≡ks) fm₂@(m₂ , km₂≡ks) (k ∷ ks'') m₁≼m₂
+        with ∈k-decᵐ k (proj₁ m₁) | ∈k-decᵐ k (proj₁ m₂)
+    ...   | yes k∈km₁ | yes k∈km₂ =
+            let
+                (v₁ , k,v₁∈m₁) = locateᵐ {m = m₁} k∈km₁
+                (v₂ , k,v₂∈m₂) = locateᵐ {m = m₂} k∈km₂
+            in
+                (m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ m₁ m₂ m₁≼m₂ k,v₁∈m₁ k,v₂∈m₂) ∷ m₁≼m₂⇒m₁[ks]≼m₂[ks] fm₁ fm₂ ks'' m₁≼m₂
+    ...   | no k∉km₁ | no k∉km₂ = m₁≼m₂⇒m₁[ks]≼m₂[ks] fm₁ fm₂ ks'' m₁≼m₂
+    ...   | 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₁))
+
+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,410 +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 A B _≈₂_ _⊔₂_ _⊓₂_ ≡-dec-A lB
-    using
-        ( subset-impl
-        ; locate; forget
-        ; _∈_
-        ; Map-functional
-        ; Expr-Provenance
-        ; Expr-Provenance-≡
-        ; _∩_; _∪_; `_
-        ; in₁; in₂; bothᵘ; single
-        ; ⊔-combines
-        )
-open import Lattice.FiniteMap A B _≈₂_ _⊔₂_ _⊓₂_ ≡-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} k,v fm = k,v ∈ proj₁ fm
-
-    -- 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) ∈ proj₁ 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 _ {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,25 +1,30 @@
 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)
-    (_≈₂_ : B → B → Set b)
-    (_⊔₂_ : B → B → B) (_⊓₂_ : B → B → B)
-    (≡-dec-A : Decidable (_≡_ {a} {A}))
-    (lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_) where
+    {_≈₂_ : B → B → Set b}
+    {_⊔₂_ : B → B → B} {_⊓₂_ : B → B → B}
+    {{≡-Decidable-A : IsDecidable {a} {A} _≡_}}
+    {{lB : IsLattice B _≈₂_ _⊔₂_ _⊓₂_}}
+    (dummy : ⊤) where
 
 open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
 
 open import Relation.Nullary using (¬_; Dec; yes; no)
 open import Data.Nat using (ℕ)
-open import Data.List using (List; map; []; _∷_; _++_)
+open import Data.List using (List; map; []; _∷_; _++_) renaming (foldr to foldrˡ)
 open import Data.List.Relation.Unary.All using (All; []; _∷_)
 open import Data.List.Relation.Unary.Any using (Any; here; there) -- TODO: re-export these with nicer names from map
 open import Data.Product using (_×_; _,_; Σ; proj₁ ; proj₂)
 open import Data.Empty using (⊥; ⊥-elim)
 open import Equivalence
-open import Utils using (Unique; push; empty; Unique-append; All¬-¬Any; All-x∈xs)
+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
@@ -34,6 +39,21 @@ private module ImplKeys where
     keys : List (A × B) → List A
     keys = map proj₁
 
+-- See note on `forget` for why this is defined in global scope even though
+-- it operates on lists.
+∈k-dec : ∀ (k : A) (l : List (A × B)) → Dec (k ∈ˡ (ImplKeys.keys l))
+∈k-dec k [] = no (λ ())
+∈k-dec k ((k' , v) ∷ xs)
+    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)
+...       | no k∉kxs = no witness
+              where
+                  witness : ¬ k ∈ˡ (ImplKeys.keys ((k' , v) ∷ xs))
+                  witness (here k≡k') = k≢k' k≡k'
+                  witness (there k∈kxs) = k∉kxs k∈kxs
+
 private module _ where
     open MemProp using (_∈_)
     open ImplKeys
@@ -59,25 +79,12 @@ 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)
     ...       | no k∉xs = no (λ { (here k≡x) → k≢x k≡x; (there k∈xs) → k∉xs k∈xs })
 
-    ∈k-dec : ∀ (k : A) (l : List (A × B)) → Dec (k ∈ keys l)
-    ∈k-dec k [] = no (λ ())
-    ∈k-dec k ((k' , v) ∷ xs)
-        with (≡-dec-A k k')
-    ...   | yes k≡k' = yes (here k≡k')
-    ...   | no k≢k' with (∈k-dec k xs)
-    ...       | yes k∈kxs = yes (there k∈kxs)
-    ...       | no k∉kxs = no witness
-                  where
-                      witness : ¬ k ∈ keys ((k' , v) ∷ xs)
-                      witness (here k≡k') = k≢k' k≡k'
-                      witness (there k∈kxs) = k∉kxs k∈kxs
-
     ∈-cong : ∀ {c d} {C : Set c} {D : Set d} {c : C} {l : List C} →
              (f : C → D) → c ∈ l → f c ∈ map f l
     ∈-cong f (here c≡c') = here (cong f c≡c')
@@ -109,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
 
@@ -119,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)
 
@@ -131,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)))
@@ -167,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)))
 
@@ -176,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'')
@@ -189,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)
 
@@ -232,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)
 
@@ -255,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₂
@@ -266,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)
 
@@ -284,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
 
@@ -310,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
 
@@ -340,7 +347,7 @@ private module ImplInsert (f : B → B → B) where
 
     restrict-preserves-Unique : ∀ {l₁ l₂ : List (A × B)} →
                                 Unique (keys l₂) → Unique (keys (restrict l₁ l₂))
-    restrict-preserves-Unique {l₁} {[]} _ = empty
+    restrict-preserves-Unique {l₁} {[]} _ = Utils.empty
     restrict-preserves-Unique {l₁} {(k , v) ∷ xs} (push k≢xs uxs)
         with ∈k-dec k l₁
     ...   | yes _ = push (restrict-preserves-k≢ k≢xs) (restrict-preserves-Unique uxs)
@@ -427,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)
 
@@ -445,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)
 
@@ -463,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'
 
@@ -476,6 +483,17 @@ private module ImplInsert (f : B → B → B) where
 Map : Set (a ⊔ℓ b)
 Map = Σ (List (A × B)) (λ l → Unique (ImplKeys.keys l))
 
+instance
+    showable : {{ showableA : Showable A }} {{ showableB : Showable B }} →
+               Showable Map
+    showable = record
+        { show = λ (kvs , _) →
+            "{" ++ˢ foldrˡ (λ (x , y) rest → show x ++ˢ " ↦ " ++ˢ show y ++ˢ ", " ++ˢ rest) "" kvs ++ˢ "}"
+        }
+
+empty : Map
+empty = ([] , Utils.empty)
+
 keys : Map → List A
 keys (kvs , _) = ImplKeys.keys kvs
 
@@ -488,8 +506,9 @@ _∈k_ k m = MemProp._∈_ k (keys m)
 locate : ∀ {k : A} {m : Map} → k ∈k m → Σ B (λ v → (k , v) ∈ m)
 locate k∈km = locate-impl k∈km
 
--- defined this way because ∈ for maps uses projection, so the full map can't be guessed.
--- On the other hand, list can be guessed.
+-- `forget` and `∈k-dec` are defined this way because ∈ for maps uses
+-- projection, so the full map can't be guessed. On the other hand, list can
+-- be guessed.
 forget : ∀ {k : A} {v : B} {l : List (A × B)} → (k , v) ∈ˡ l → k ∈ˡ (ImplKeys.keys l)
 forget = ∈-cong proj₁
 
@@ -529,9 +548,12 @@ data Expr : Set (a ⊔ℓ b) where
     _∪_ : Expr → Expr → Expr
     _∩_ : Expr → Expr → Expr
 
-open ImplInsert _⊔₂_ using (union-preserves-Unique; union-equal-keys) renaming (insert to insert-impl; union to union-impl)
+open ImplInsert _⊔₂_ using (union-preserves-Unique; union-equal-keys; insert-preserves-Unique) renaming (insert to insert-impl; union to union-impl)
 open ImplInsert _⊓₂_ using (intersect-preserves-Unique; intersect-equal-keys) renaming (intersect to intersect-impl)
 
+insert : A → B → Map → Map
+insert k v (l , uks) = (insert-impl k v l , insert-preserves-Unique uks)
+
 _⊔_ : Map → Map → Map
 _⊔_ (kvs₁ , _) (kvs₂ , uks₂) = (union-impl kvs₁ kvs₂ , union-preserves-Unique kvs₁ kvs₂ uks₂)
 
@@ -544,11 +566,18 @@ open ImplInsert _⊔₂_ using
     ; union-preserves-∈₂
     ; union-preserves-∉
     ; union-preserves-∈k₁
+    ; union-preserves-∈k₂
     )
 
 ⊔-combines : ∀ {k : A} {v₁ v₂ : B} {m₁ m₂ : Map} → (k , v₁) ∈ m₁ → (k , v₂) ∈ m₂ → (k , v₁ ⊔₂ v₂) ∈ (m₁ ⊔ m₂)
 ⊔-combines {k} {v₁} {v₂} {kvs₁ , u₁} {kvs₂ , u₂} k,v₁∈m₁ k,v₂∈m₂ = union-combines u₁ u₂ k,v₁∈m₁ k,v₂∈m₂
 
+⊔-preserves-∈k₁ : ∀ {k : A} → {m₁ m₂ : Map} → k ∈k m₁ → k ∈k (m₁ ⊔ m₂)
+⊔-preserves-∈k₁ {k} {(l₁ , _)} {(l₂ , _)} k∈km₁ = union-preserves-∈k₁ {l₁ = l₁} {l₂ = l₂} k∈km₁
+
+⊔-preserves-∈k₂ : ∀ {k : A} → {m₁ m₂ : Map} → k ∈k m₂ → k ∈k (m₁ ⊔ m₂)
+⊔-preserves-∈k₂ {k} {(l₁ , _)} {(l₂ , _)} k∈km₁ = union-preserves-∈k₂ {l₁ = l₁} {l₂ = l₂} k∈km₁
+
 open ImplInsert _⊓₂_ using
     ( restrict-needs-both
     ; updates
@@ -599,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₂
@@ -650,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 _⊓₂_
 
@@ -878,6 +911,8 @@ isLattice = record
     ; absorb-⊓-⊔ = absorb-⊓-⊔
     }
 
+open IsLattice isLattice using (_≼_) public
+
 lattice : Lattice Map
 lattice = record
     { _≈_ = _≈_
@@ -958,6 +993,10 @@ _updating_via_ (kvs , uks) ks f =
     , subst Unique (transform-keys-≡ kvs ks f) uks
     )
 
+updating-via-keys-≡ : ∀ (m : Map) (ks : List A) (f : A → B) →
+                  keys m ≡ keys (m updating ks via f)
+updating-via-keys-≡ (l , _) = transform-keys-≡ l
+
 updating-via-∉k-forward : ∀ (m : Map) (ks : List A) (f : A → B) {k : A} →
                           ¬ k ∈k m → ¬ k ∈k (m updating ks via f)
 updating-via-∉k-forward m = transform-∉k-forward
@@ -994,8 +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
-    open IsLattice isLattice using (_≼_)
+         {{lL : IsLattice L _≈ˡ_ _⊔ˡ_ _⊓ˡ_}} where
     open IsLattice lL using () renaming (_≼_ to _≼ˡ_)
 
     module _ (f : L → Map) (f-Monotonic : Monotonic _≼ˡ_ _≼_ f)
@@ -1072,3 +1110,51 @@ module _ {l} {L : Set l}
                             with refl ← Map-functional {m = f' l₂} k,v∈f'l₂ k,v₂∈f'l₂
                             with refl ← Map-functional {m = f l₂} k,v'∈fl₂ k,v₂∈fl₂ =
                             (v₁ ⊔₂ v , (v'≈v'' , k,v₁v₂∈f'l₁f'l₂))
+
+
+_[_] : Map → List A → List B
+_[_] m [] = []
+_[_] m (k ∷ ks)
+    with ∈k-dec k (proj₁ m)
+...   | 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₂
+    with k,v₁v₂∈m₁m₂ ← ⊔-combines {m₁ = m₁} {m₂ = m₂} k,v₁∈m₁ k,v₂∈m₂
+    with (v' , (v₁v₂≈v' , k,v'∈m₂)) ← (proj₁ m₁≼m₂) _ _ k,v₁v₂∈m₁m₂
+    with refl ← Map-functional {m = m₂} k,v₂∈m₂ k,v'∈m₂
+    = v₁v₂≈v'
+
+m₁≼m₂⇒k∈km₁⇒k∈km₂ : ∀ (m₁ m₂ : Map) {k : A} →
+                    m₁ ≼ m₂ → k ∈k m₁ → k ∈k m₂
+m₁≼m₂⇒k∈km₁⇒k∈km₂ m₁ m₂ m₁≼m₂ k∈km₁ =
+    let
+        k∈km₁m₂ = union-preserves-∈k₁ {l₁ = proj₁ m₁} {l₂ = proj₁ m₂} k∈km₁
+        (v , k,v∈m₁m₂) = locate {m = m₁ ⊔ m₂} k∈km₁m₂
+        (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,19 +1,45 @@
 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 Lattice.Unit using (⊤) renaming (_≈_ to _≈₂_; _⊔_ to _⊔₂_; _⊓_ to _⊓₂_; isLattice to ⊤-isLattice)
+open import Data.List using (List; map)
+open import Data.Product using (_,_; proj₁)
+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 A ⊤ _≈₂_ _⊔₂_ _⊓₂_ ≡-dec-A ⊤-isLattice
-open UnitMap using (Map)
-open UnitMap using
-    ( _⊆_; _≈_; ≈-equiv; _⊔_; _⊓_
+private module UnitMap = Lattice.Map A ⊤ dummy
+open UnitMap
+    using (Map; Expr; ⟦_⟧)
+    renaming
+        ( Expr-Provenance to Expr-Provenanceᵐ
+        )
+open UnitMap
+    using
+        ( _⊆_; _≈_; ≈-equiv; _⊔_; _⊓_; _∪_ ; _∩_ ; `_; empty; forget
         ; isUnionSemilattice; isIntersectSemilattice; isLattice; lattice
-    ) public
+        ; Provenance
+        ; ⊔-preserves-∈k₁
+        ; ⊔-preserves-∈k₂
+        )
+    renaming (_∈k_ to _∈_) public
+open Provenance public
 
 MapSet : Set a
 MapSet = Map
+
+to-List : MapSet → List A
+to-List = map proj₁ ∘ proj₁
+
+insert : A → MapSet → MapSet
+insert k = UnitMap.insert k tt
+
+singleton : A → MapSet
+singleton k = UnitMap.insert k tt empty
+
+Expr-Provenance : ∀ (k : A) (e : Expr) → k ∈ ⟦ e ⟧ → Provenance k tt e
+Expr-Provenance k e k∈e = let (tt , (prov , _)) = Expr-Provenanceᵐ k e k∈e in prov

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,59 +1,46 @@
+{-# OPTIONS --guardedness #-}
 module Main where
 
+open import Language hiding (_++_)
+open import Data.Vec using (Vec; _∷_; [])
 open import IO
 open import Level using (0ℓ)
-open import Data.Nat.Show using (show)
-open import Data.List using (List; _∷_; []; foldr)
-open import Data.String using (String; _++_) renaming (_≟_ to _≟ˢ_)
-open import Data.Unit using (⊤; tt) renaming (_≟_ to _≟ᵘ_)
-open import Data.Product using (_,_; _×_; proj₁; proj₂)
-open import Data.List.Relation.Unary.All using (_∷_; [])
-open import Relation.Binary.PropositionalEquality as Eq using (_≡_; sym; subst; refl; trans)
-open import Relation.Nullary using (¬_)
+open import Data.String using (_++_)
+import Analysis.Constant as ConstantAnalysis
+import Analysis.Sign as SignAnalysis
 
-open import Utils using (Unique; push; empty)
+testCode : Stmt
+testCode =
+    ⟨ "zero" ← (# 0) ⟩ then
+    ⟨ "pos" ← ((` "zero") Expr.+ (# 1)) ⟩ then
+    ⟨ "neg" ← ((` "zero") Expr.- (# 1)) ⟩ then
+    ⟨ "unknown" ← ((` "pos") Expr.+ (` "neg")) ⟩
 
-xyzw : List String
-xyzw = "x" ∷ "y" ∷ "z" ∷ "w" ∷ []
+testCodeCond₁ : Stmt
+testCodeCond₁ =
+    ⟨ "var" ← (# 1) ⟩ then
+    if (` "var") then (
+        ⟨ "var" ← ((` "var") Expr.+ (# 1)) ⟩
+    ) else (
+        ⟨ "var" ← ((` "var") Expr.- (# 1)) ⟩ then
+        ⟨ "var" ← (# 1) ⟩
+    )
 
-xyzw-Unique : Unique xyzw
-xyzw-Unique = push ((λ ()) ∷ (λ ()) ∷ (λ ()) ∷ []) (push ((λ ()) ∷ (λ ()) ∷ []) (push ((λ ()) ∷ []) (push [] empty)))
+testCodeCond₂ : Stmt
+testCodeCond₂ =
+    ⟨ "var" ← (# 1) ⟩ then
+    if (` "var") then (
+        ⟨ "x" ← (# 1) ⟩
+    ) else (
+        ⟨ noop ⟩
+    )
 
-open import Lattice using (IsFiniteHeightLattice; FiniteHeightLattice; Monotonic)
-open import Lattice.AboveBelow ⊤ _≡_ (record { ≈-refl = refl; ≈-sym = sym; ≈-trans = trans }) _≟ᵘ_  as AB using () renaming (≈-dec to ≈ᵘ-dec)
-open AB.Plain using () renaming (finiteHeightLattice to finiteHeightLatticeᵘ)
-open import Lattice.Bundles.FiniteValueMap String AB.AboveBelow _≟ˢ_ renaming (finiteHeightLattice to finiteHeightLatticeᵐ; FiniteHeightType to FiniteHeightTypeᵐ; ≈-dec to ≈-dec)
+testProgram : Program
+testProgram = record
+    { rootStmt = testCode
+    }
 
-fhlᵘ = finiteHeightLatticeᵘ (Data.Unit.tt)
+open SignAnalysis.WithProg testProgram using (analyze-correct) renaming (output to output-Sign)
+open ConstantAnalysis.WithProg testProgram using (analyze-correct) renaming (output to output-Const)
 
-FiniteHeightMap = FiniteHeightTypeᵐ fhlᵘ xyzw-Unique ≈ᵘ-dec
-
-showAboveBelow : AB.AboveBelow → String
-showAboveBelow AB.⊤ = "⊤"
-showAboveBelow AB.⊥ = "⊥"
-showAboveBelow (AB.[_] tt) = "()"
-
-showMap : ∀ {ks : List String} → FiniteHeightMap ks → String
-showMap ((kvs , _) , _) = "{" ++ foldr (λ (x , y) rest → x ++ " ↦ " ++ showAboveBelow y ++ ", " ++ rest) "" kvs ++ "}"
-
-fhlⁱᵖ = finiteHeightLatticeᵐ fhlᵘ xyzw-Unique ≈ᵘ-dec
-
-open FiniteHeightLattice fhlⁱᵖ using (_≈_; _⊔_; _⊓_; ⊔-idemp; _≼_; ≈-⊔-cong; ≈-refl; ≈-trans; ≈-sym; ⊔-assoc; ⊔-comm; ⊔-Monotonicˡ)
-open import Relation.Binary.Reasoning.Base.Single _≈_ (λ {m} → ≈-refl {m}) (λ {m₁} {m₂} {m₃} → ≈-trans {m₁} {m₂} {m₃}) -- why am I having to eta-expand here?
-
-smallestMap = proj₁ (proj₁ (proj₁ (FiniteHeightLattice.fixedHeight fhlⁱᵖ)))
-largestMap = proj₂ (proj₁ (proj₁ (FiniteHeightLattice.fixedHeight fhlⁱᵖ)))
-
-dumb : FiniteHeightMap xyzw
-dumb = ((("x" , AB.[_] tt) ∷ ("y" , AB.⊥) ∷ ("z" , AB.⊥) ∷ ("w" , AB.⊥) ∷ [] , xyzw-Unique) , refl)
-
-dumbFunction : FiniteHeightMap xyzw → FiniteHeightMap xyzw
-dumbFunction = _⊔_ dumb
-
-dumbFunction-Monotonic : Monotonic _≼_ _≼_ dumbFunction
-dumbFunction-Monotonic {m₁} {m₂} m₁≼m₂ = ⊔-Monotonicˡ dumb {m₁} {m₂} m₁≼m₂
-
-
-open import Fixedpoint {0ℓ} {FiniteHeightMap xyzw} {8} {_≈_} {_⊔_} {_⊓_} (≈-dec fhlᵘ xyzw-Unique ≈ᵘ-dec) (FiniteHeightLattice.isFiniteHeightLattice fhlⁱᵖ) dumbFunction (λ {m₁} {m₂} m₁≼m₂ → dumbFunction-Monotonic {m₁} {m₂} m₁≼m₂)
-
-main = run {0ℓ} (putStrLn (showMap aᶠ))
+main = run {0ℓ} (putStrLn (output-Const ++ "\n" ++ output-Sign))

Showable.agda

@@ -0,0 +1,38 @@
+module Showable where
+
+open import Data.String using (String; _++_)
+open import Data.Nat using (ℕ)
+open import Data.Nat.Show using () renaming (show to showNat)
+open import Data.Fin using (Fin)
+open import Data.Fin.Show using () renaming (show to showFin)
+open import Data.Product using (_×_; _,_)
+open import Data.Unit using (⊤; tt)
+
+record Showable {a} (A : Set a) : Set a where
+    field
+        show : A → String
+
+open Showable {{ ... }} public
+
+instance
+    showableString : Showable String
+    showableString = record { show = λ s → "\"" ++ s ++ "\"" }
+
+    showableNat : Showable ℕ
+    showableNat = record { show = showNat }
+
+    showableFin : ∀ {n : ℕ} → Showable (Fin n)
+    showableFin = record { show = showFin }
+
+    showableProd : ∀ {a b} {A : Set a} {B : Set b}
+                     {{ showableA : Showable A }} {{ showableB : Showable B }} →
+                   Showable (A × B)
+    showableProd {{ showableA }} {{ showableB }} = record
+        { show = λ (a , b) →
+            "(" ++ show a ++
+            ", " ++ show b ++
+            ")"
+        }
+
+    showableUnit : Showable ⊤
+    showableUnit = record { show = λ tt → "()" }

Utils.agda

@@ -1,13 +1,30 @@
 module Utils where
 
 open import Agda.Primitive using () renaming (_⊔_ to _⊔ℓ_)
+open import Data.Product as Prod using (Σ; _×_; _,_; proj₁; proj₂)
 open import Data.Nat using (ℕ; suc)
-open import Data.List using (List; []; _∷_; _++_)
-open import Data.List.Membership.Propositional 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 Relation.Binary.PropositionalEquality using (_≡_; sym; refl)
-open import Relation.Nullary 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; 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 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 []
@@ -29,9 +46,38 @@ 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
 
-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
+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)
+All-≢-map x f f-Injecitve [] = []
+All-≢-map x {x' ∷ xs'} f f-Injecitve (x≢x' ∷ x≢xs') = (λ fx≡fx' → x≢x' (f-Injecitve fx≡fx')) ∷ All-≢-map x f f-Injecitve x≢xs'
+
+Unique-map : ∀ {c d} {C : Set c} {D : Set d} {l : List C} (f : C → D) →
+             Injective (_≡_ {_} {C}) (_≡_ {_} {D}) f →
+             Unique l → Unique (mapˡ f l)
+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)
+
+¬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
@@ -41,6 +87,11 @@ All-x∈xs : ∀ {a} {A : Set a} (xs : List A) → All (λ x → x ∈ xs) xs
 All-x∈xs [] = []
 All-x∈xs (x ∷ xs') = here refl ∷ map there (All-x∈xs xs')
 
+x∈xs⇒fx∈fxs : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) {x : A} {xs : List A} →
+              x ∈ xs → (f x) ∈ mapˡ f xs
+x∈xs⇒fx∈fxs f (here refl) = here refl
+x∈xs⇒fx∈fxs f (there x∈xs') = there (x∈xs⇒fx∈fxs f x∈xs')
+
 iterate : ∀ {a} {A : Set a} (n : ℕ) → (f : A → A) → A → A
 iterate 0 _ a = a
 iterate (suc n) f a = f (iterate n f a)
@@ -50,3 +101,68 @@ data Pairwise {a} {b} {c} {A : Set a} {B : Set b} (P : A → B → Set c) : List
     _∷_ : ∀ {x : A} {y : B} {xs : List A} {ys : List B} →
           P x y → Pairwise P xs ys →
           Pairwise P (x ∷ xs) (y ∷ ys)
+
+∈-cartesianProduct : ∀ {a b} {A : Set a} {B : Set b}
+                     {x : A} {xs : List A} {y : B} {ys : List B} →
+                     x ∈ xs → y ∈ ys → (x Prod., y) ∈ cartesianProduct xs ys
+∈-cartesianProduct {x = x} (here refl) y∈ys = ListMemProp.∈-++⁺ˡ (x∈xs⇒fx∈fxs (x Prod.,_) y∈ys)
+∈-cartesianProduct {x = x} {xs = x' ∷ _} {ys = ys} (there x∈rest) y∈ys = ListMemProp.∈-++⁺ʳ (mapˡ (x' Prod.,_) ys) (∈-cartesianProduct x∈rest y∈ys)
+
+concat-∈ : ∀ {a} {A : Set a} {x : A} {l : List A} {ls : List (List A)} →
+           x ∈ l → l ∈ ls → x ∈ foldr _++_ [] ls
+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
+
+_∨_ : ∀ {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
+
+_∧_ : ∀ {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)