agda-spa/Analysis/Sign.agda
Danila Fedorin 9f2790c500 Actually force proof of 'analyze-correct'
Signed-off-by: Danila Fedorin <danila.fedorin@gmail.com>
2025-01-05 19:39:12 -08:00

300 lines
13 KiB
Agda
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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
: 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