agda-spa/Language.agda

module Language where

open import Data.Nat using (ℕ; suc; pred)
open import Data.String using (String) renaming (_≟_ to _≟ˢ_)
open import Data.Product using (Σ; _,_; proj₁; proj₂)
open import Data.Vec using (Vec; foldr; lookup; _∷_)
open import Data.List using ([]; _∷_; List) renaming (foldr to foldrˡ; map to mapˡ)
open import Data.List.Membership.Propositional as MemProp using () renaming (_∈_ to _∈ˡ_)
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.List.Relation.Unary.Any as RelAny using ()
open import Data.Fin using (Fin; suc; zero; fromℕ; inject₁) renaming (_≟_ to _≟ᶠ_)
open import Data.Fin.Properties using (suc-injective)
open import Relation.Binary.PropositionalEquality using (cong; _≡_; refl)
open import Relation.Nullary using (¬_)
open import Function using (_∘_)

open import Lattice
open import Utils using (Unique; Unique-map; empty; push)

data Expr : Set where
    _+_ : Expr → Expr → Expr
    _-_ : Expr → Expr → Expr
    `_ : String → Expr
    #_ : ℕ → Expr

data Stmt : Set where
    _←_ : String → Expr → Stmt

open import Lattice.MapSet String _≟ˢ_
    renaming
        ( MapSet to StringSet
        ; insert to insertˢ
        ; to-List to to-Listˢ
        ; empty to emptyˢ
        ; singleton to singletonˢ
        ; _⊔_ to _⊔ˢ_
        ; `_ to `ˢ_
        ; _∈_ to _∈ˢ_
        ; ⊔-preserves-∈k₁ to ⊔ˢ-preserves-∈k₁
        ; ⊔-preserves-∈k₂ to ⊔ˢ-preserves-∈k₂
        )

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 → Stmt → Set where
    in←₁ : ∀ {k : String} {e : Expr} → k ∈ᵗ (k ← e)
    in←₂ : ∀ {k k' : String} {e : Expr} → k ∈ᵉ e → k ∈ᵗ (k' ← e)

private
    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

    Stmt-vars : Stmt → StringSet
    Stmt-vars (x ← e) = (singletonˢ x) ⊔ˢ (Expr-vars e)

    ∈-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')

    -- Creating a new number from a natural number can never create one
    -- equal to one you get from weakening the bounds on another number.
    z≢sf : ∀ {n : ℕ} (f : Fin n) → ¬ (zero ≡ 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'

    indices : ∀ (n : ℕ) → Σ (List (Fin n)) Unique
    indices 0 = ([] , empty)
    indices (suc n') =
        let
            (inds' , unids') = indices n'
        in
            ( zero ∷ mapˡ suc inds'
            , push (z≢mapsfs inds') (Unique-map suc suc-injective unids')
            )


-- For now, just represent the program and CFG as one type, without branching.
record Program : Set where
    field
        length : ℕ
        stmts : Vec Stmt length

    private
        vars-Set : StringSet
        vars-Set = Stmts-vars stmts

    vars : List String
    vars = to-Listˢ vars-Set

    vars-Unique : Unique vars
    vars-Unique = proj₂ vars-Set

    State : Set
    State = Fin length

    states : List State
    states = proj₁ (indices length)

    states-Unique : Unique states
    states-Unique = proj₂ (indices length)

    code : State → Stmt
    code = lookup stmts

    vars-complete : ∀ {k : String} (s : State) → k ∈ᵗ (code s) → k ∈ˡ vars
    vars-complete {k} s = ∈⇒∈-Stmts-vars {length} {k} {stmts} {s}

    _≟_ : IsDecidable (_≡_ {_} {State})
    _≟_ = _≟ᶠ_

    -- Computations for incoming and outgoing edged  will have to change too
    -- when we support branching etc.

    incoming : State → List State
    incoming
        with length
    ...   | 0 = (λ ())
    ...   | suc n' = (λ
            { zero → []
            ; (suc f') → (inject₁ f') ∷ []
            })