agda-spa/Language/Graphs.agda

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 ()
open import Data.Nat as Nat using (ℕ; suc)
open import Data.Nat.Properties using (+-assoc; +-comm)
open import Data.Product using (_×_; Σ; _,_)
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 Lattice
open import Utils using (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 ∷ []
    }

buildCfg : Stmt → Graph
buildCfg ⟨ bs₁ ⟩ = singleton (bs₁ ∷ [])
buildCfg (s₁ then s₂) = buildCfg s₁ ↦ buildCfg s₂
buildCfg (if _ then s₁ else s₂) = singleton [] ↦ (buildCfg s₁ ∙ buildCfg s₂) ↦ singleton []
buildCfg (while _ repeat s) = loop (buildCfg s)