Sovle homework 4

HW4Part1.hs

@@ -0,0 +1,46 @@
+module HW4Part1 where
+
+data Reg = A | B | R
+
+data Expr
+    = Lit Int
+    | Reg Reg
+    | Plus Expr Expr
+    | Leq Expr Expr
+    | Not Expr
+
+type Prog = [Stmt]
+
+data Stmt
+    = Store Reg Expr
+    | If Expr Prog Prog
+    | Loop Prog
+    | Break
+
+program :: Prog
+program =
+    [ Store A $ Lit 7
+    , Store B $ Lit 9
+    , Store R $ Lit 0
+    , Loop $
+        [ If (Reg A `Leq` Lit 0)
+            [ Break ]
+            [ Store R $ Reg R `Plus` Reg B
+            , Store A $ Reg A `Plus` Lit (-1)
+            ]
+        ]
+    ]
+
+while :: Expr -> Prog -> Stmt
+while cond body = Loop $ If cond [] [ Break ] : body
+
+sumFromTo :: Int -> Int -> Prog
+sumFromTo f t =
+    [ Store A $ Lit f
+    , Store B $ Lit t
+    , Store R $ Lit 0
+    , while (Leq (Reg A) (Reg B))
+        [ Store R $ Reg R `Plus` Reg A
+        , Store A $ Reg A `Plus` (Lit 1)
+        ]
+    ]

HW4Part2.hs

@@ -0,0 +1,74 @@
+{-
+ - int ::= (any integer)
+ -
+ - reg ::= A | B | R
+ -
+ - bexpr ::= not bexpr
+ -         | iexpr <= iexpr
+ -
+ - iexpr ::= int
+ -         | reg
+ -         | iexpr + iexpr
+ -
+ - stmt ::= reg ::= iexpr
+ -        | if bexpr then prog else prog endprog else prog end
+ -        | do prog end
+ -        | break
+ -
+ - prog ::= \epsilon | stmt; prog
+ -}
+
+{-# LANGUAGE GADTs #-}
+import Control.Monad.Except
+import Control.Monad.State
+import Data.Bool
+import Data.Either
+
+data Reg = A | B | R
+
+data Expr a where
+    Lit :: Int -> Expr Int
+    Reg :: Reg -> Expr Int
+    Plus :: Expr Int -> Expr Int -> Expr Int
+    Leq :: Expr Int -> Expr Int -> Expr Bool
+    Not :: Expr Bool -> Expr Bool
+
+data Stmt
+    = Store Reg (Expr Int)
+    | If (Expr Bool) Prog Prog
+    | Loop Prog
+    | Break
+
+type Prog = [Stmt]
+
+-- Quick and dirty interpreter to test my programs :)
+
+type Evaluator = ExceptT () (State (Int, Int, Int))
+
+getReg :: Reg -> (Int, Int, Int) -> Int
+getReg A (i, _, _) = i
+getReg B (_, i, _) = i
+getReg R (_, _, i) = i
+
+setReg :: Reg -> Int -> (Int, Int, Int) -> (Int, Int, Int)
+setReg A a (_, b, r) = (a, b, r)
+setReg B b (a, _, r) = (a, b, r)
+setReg R r (a, b, _) = (a, b, r)
+
+expr :: Expr a -> Evaluator a
+expr (Lit i) = return i
+expr (Reg r) = gets (getReg r)
+expr (Plus l r) = liftM2 (+) (expr l) (expr r)
+expr (Leq l r) = liftM2 (<=) (expr l) (expr r)
+expr (Not e) = not <$> expr e
+
+stmt :: Stmt -> Evaluator ()
+stmt (Store r e) = expr e >>= modify . setReg r
+stmt (If i t e) = expr i >>= bool (prog e) (prog t)
+stmt (Loop p) = prog (cycle p) `catchError` (const $ return ())
+stmt Break = throwError ()
+
+prog :: Prog -> Evaluator ()
+prog = mapM_ stmt
+
+run p = snd $ runState (runExceptT (prog p)) (0, 0, 0)