agda-spa/Analysis/Sign.agda
Danila Fedorin 7d2928ed81 Prove that the sign analysis is correct
Signed-off-by: Danila Fedorin <danila.fedorin@gmail.com>
2024-05-10 22:31:47 -07:00

297 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.PropositionalEquality using (_≡_; refl; sym; trans; subst)
open import Relation.Nullary using (¬_; yes; no)
open import Language
open import Lattice
open import Showable using (Showable; show)
open import Utils using (_⇒_; _∧_; __)
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.
_≟ᵍ_ : IsDecidable (_≡_ {_} {Sign})
_≟ᵍ_ + + = yes refl
_≟ᵍ_ + - = no (λ ())
_≟ᵍ_ + 0ˢ = no (λ ())
_≟ᵍ_ - + = no (λ ())
_≟ᵍ_ - - = yes refl
_≟ᵍ_ - 0ˢ = no (λ ())
_≟ᵍ_ 0ˢ + = no (λ ())
_≟ᵍ_ 0ˢ - = no (λ ())
_≟ᵍ_ 0ˢ 0ˢ = yes refl
-- embelish 'sign' with a top and bottom element.
open import Lattice.AboveBelow Sign _≡_ (record { ≈-refl = refl; ≈-sym = sym; ≈-trans = trans }) _≟ᵍ_ as AB
using ()
renaming
( AboveBelow to SignLattice
; ≈-dec to ≈ᵍ-dec
; 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ᵍ
; fixedHeight to fixedHeightᵍ
; _≼_ to _≼ᵍ_
; _⊔_ to _⊔ᵍ_
; _⊓_ to _⊓ᵍ_
)
open IsLattice isLatticeᵍ using ()
renaming
( ≼-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₁)
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₁)
⟦_⟧ᵍ : 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₁
latticeInterpretationᵍ : LatticeInterpretation isLatticeᵍ
latticeInterpretationᵍ = record
{ ⟦_⟧ = ⟦_⟧ᵍ
; ⟦⟧-respects-≈ = ⟦⟧ᵍ-respects-≈ᵍ
; ⟦⟧-⊔- = ⟦⟧ᵍ-⊔ᵍ-
; ⟦⟧-⊓-∧ = ⟦⟧ᵍ-⊓ᵍ-∧
}
module WithProg (prog : Program) where
open Program prog
module ForwardWithProg = Analysis.Forward.WithProg (record { isLattice = isLatticeᵍ; fixedHeight = fixedHeightᵍ }) ≈ᵍ-dec prog
open ForwardWithProg
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₂ =
let
-- TODO: can this be done with less boilerplate?
g₁vs₁ = eval e₁ vs₁
g₂vs₁ = eval e₂ vs₁
g₁vs₂ = eval e₁ vs₂
g₂vs₂ = eval e₂ vs₂
in
≼ᵍ-trans
{plus g₁vs₁ g₂vs₁} {plus g₁vs₂ g₂vs₁} {plus g₁vs₂ g₂vs₂}
(plus-Monoˡ g₂vs₁ {g₁vs₁} {g₁vs₂} (eval-Mono e₁ {vs₁} {vs₂} vs₁≼vs₂))
(plus-Monoʳ g₁vs₂ {g₂vs₁} {g₂vs₂} (eval-Mono e₂ {vs₁} {vs₂} vs₁≼vs₂))
eval-Mono (e₁ - e₂) {vs₁} {vs₂} vs₁≼vs₂ =
let
-- TODO: here too -- can this be done with less boilerplate?
g₁vs₁ = eval e₁ vs₁
g₂vs₁ = eval e₂ vs₁
g₁vs₂ = eval e₁ vs₂
g₂vs₂ = eval e₂ vs₂
in
≼ᵍ-trans
{minus g₁vs₁ g₂vs₁} {minus g₁vs₂ g₂vs₁} {minus g₁vs₂ g₂vs₂}
(minus-Monoˡ g₂vs₁ {g₁vs₁} {g₁vs₂} (eval-Mono e₁ {vs₁} {vs₂} vs₁≼vs₂))
(minus-Monoʳ g₁vs₂ {g₂vs₁} {g₂vs₂} (eval-Mono e₂ {vs₁} {vs₂} vs₁≼vs₂))
eval-Mono (` k) {vs₁@((kvs₁ , _) , _)} {vs₂@((kvs₂ , _), _)} vs₁≼vs₂
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
module ForwardWithEval = ForwardWithProg.WithEvaluator eval eval-Mono
open ForwardWithEval using (result)
-- For debugging purposes, print out the result.
output = show result
module ForwardWithInterp = ForwardWithEval.WithInterpretation latticeInterpretationᵍ
open ForwardWithInterp using (⟦_⟧ᵛ; InterpretationValid)
-- 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 : InterpretationValid
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)
open ForwardWithInterp.WithValidity eval-Valid using (analyze-correct) public