-- | A single register imperative language.
module Imp where

import Prelude hiding (init)


--
-- * Syntax
--

-- $ Here's the syntax of the small imperative programming language, similar
--   to the language from Homework 4, after refactoring to eliminate the
--   potential for type errors.
--
--       int  ::= (any integer)
--
--       reg  ::= `A` | `B` | `R`
--
--       expr ::= int
--             |  reg
--             |  expr + expr
--       
--       test ::= expr <= expr
--             |  `not` test
--
--       stmt ::= reg := expr
--             |  `while` test `do` stmt
--             |  `begin` stmt* `end`

-- | Named registers.
data Reg = A | B | R
  deriving (Eq,Show)

data Expr
   = Lit Int
   | Get Reg
   | Add Expr Expr
  deriving (Eq,Show)

data Test
   = LTE Expr Expr
   | Not Test
  deriving (Eq,Show)

data Stmt
   = Set Reg Expr
   | While Test Stmt
   | Begin [Stmt]
  deriving (Eq,Show)


--
-- * Examples
--

-- Example program: double R until it is greater than 100.
--   begin
--     R := 1
--     while R <= 100 do
--       R := R + R
--   end
keepDoubling :: Stmt
keepDoubling =
    Begin [
      Set R (Lit 1),
      While (LTE (Get R) (Lit 100))
        (Set R (Add (Get R) (Get R)))
    ]

-- | Generate a program that multiplies two integers together.
genMult :: Int -> Int -> Stmt
genMult x y =
    Begin [
      Set A (Lit x)
    , Set B (Lit y)
    , Set R (Lit 0)
    , While (Not (LTE (Get A) (Lit 0)))
      (Begin [
        Set R (Add (Get R) (Get B))
        , Set A (Add (Get A) (Lit (-1)))
      ])
    ]


--
-- * Semantics
--

-- | The current values of the registers.
type State = (Int, Int, Int)

-- Semantic domains:
--  * expr: State -> Int
--  * test: State -> Bool
--  * stmt: State -> State

-- What if tests were part of the syntactic category of expressions
-- (like before refactoring the syntax in Homework 4)?
--  * expr: State -> Maybe (Either Int Bool)
--  * stmt: State -> Maybe State

-- | An initial state, for convenience.
init :: State
init = (0,0,0)

-- | Get the value of a register.
get :: Reg -> State -> Int
get A (a,_,_) = a
get B (_,b,_) = b
get R (_,_,r) = r

-- | Set the value of a register.
set :: Reg -> Int -> State -> State
set A i (_,b,r) = (i,b,r)
set B i (a,_,r) = (a,i,r)
set R i (a,b,_) = (a,b,i)

-- | Valuation function for expressions.
expr :: Expr -> State -> Int
expr (Lit i)   = \s -> i
expr (Get r)   = \s -> get r s
expr (Add l r) = \s -> expr l s + expr r s

-- | Valuation function for tests.
test :: Test -> State -> Bool
test (Not t)   = \s -> not (test t s)
test (LTE l r) = \s -> expr l s <= expr r s

-- | Valuation function for statements.
stmt :: Stmt -> State -> State
stmt (Set r e)   = \s -> set r (expr e s) s
stmt (While t b) = \s -> if test t s
                         then stmt (While t b) (stmt b s)
                         else s
stmt (Begin ss)  = \s -> stmts ss s
-- stmt (Begin ss)  = \s -> foldl (flip stmt) s ss

-- | Helper function for executing a sequence of statements.
stmts :: [Stmt] -> State -> State
stmts []    s = s
stmts (h:t) s = stmts t (stmt h s)


-- ** Regaining compositionality

-- | Compute least fix point. Defined in Data.Function.
fix f = let x = f x in x

-- | Compositional valuation function for statements using least fix point.
--   (Note that in Haskell this is exactly the same as the previous definition;
--   this is just illustrating what the compositional definition looks like.)
stmt' :: Stmt -> State -> State
stmt' (Set r e)   = \s -> set r (expr e s) s
stmt' (While t b) = fix (\f s -> if test t s
                                 then f (stmt' b s)
                                 else s)
stmt' (Begin ss)  = \s -> foldl (flip stmt') s ss