added extra note

[ap2015.git] / a9 / charlie / Main.hs

diff --git a/a9/charlie/Main.hs b/a9/charlie/Main.hs
new file mode 100644 (file)
index 0000000..a58359c
--- /dev/null
+++ b/a9/charlie/Main.hs
@@ -0,0 +1,127 @@
+{-#LANGUAGE GADTs #-}\r
+{-#LANGUAGE StandaloneDeriving #-}\r
+\r
+-- Mart Lubbers s4109503\r
+-- Charlie Gerhardus s3050009\r
+\r
+-- for union and intersect\r
+import Data.List\r
+\r
+-- type aliases and data structures\r
+type Ident = String\r
+type Set = Expr [Int]\r
+type Elem = Expr Int\r
+data Op = Add |Sub | Mul deriving Show\r
+data Val = Error String | IVal Int | ISVal [Int] deriving Show\r
+type State = [(String, Val)]\r
+data Sem a = Sem (State -> (a, State))\r
+\r
+-- the expression GADT\r
+data Expr a where\r
+    New :: Set\r
+    Ins :: Elem -> Set -> Set\r
+    Del :: Elem -> Set -> Set\r
+    Var :: Ident -> Expr a\r
+    Union :: Set -> Set -> Set\r
+    Diff :: Set -> Set -> Set\r
+    Intersect :: Set -> Set -> Set\r
+    Lit :: Int -> Elem\r
+    Size :: Set -> Elem\r
+    Oper :: Elem -> Op -> Elem -> Elem\r
+    Store :: Ident -> Expr a -> Expr a\r
+\r
+-- make it printable\r
+deriving instance Show (Expr a)\r
+\r
+-- Execute Sem by applying state\r
+execSem :: Sem a -> State -> (a, State)\r
+execSem (Sem f) st = f st\r
+\r
+-- Apply result to functor and preserve state\r
+mapSem :: (a -> b) -> (a, State) -> (b, State)\r
+mapSem f (x, st) = (f x, st)\r
+\r
+-- Functor instance for monad\r
+instance Functor Sem where\r
+    fmap f (Sem g) = Sem $ \st -> let (x, st') = g st in (f x, st')\r
+\r
+-- Applicative instance for monad\r
+instance Applicative Sem where\r
+    pure x = Sem $ \st -> (x, st)\r
+    Sem f <*> (Sem g) = Sem $ \st -> let (h, st') = f st in mapSem h (g st')\r
+\r
+-- The monad\r
+instance Monad Sem where\r
+    Sem f >>= g = Sem $ \st -> let (x, st') = f st in execSem (g x) st'\r
+\r
+-- Read a variable\r
+varRead :: String -> Sem Val\r
+varRead id = Sem $ \st -> maybe (Error "undefined variable reference!", st) (\v -> (v, st)) (lookup id st)\r
+\r
+-- Var write\r
+varWrite :: String -> Val -> Sem Val\r
+varWrite id v = Sem $ \st -> (v, (id, v):st)\r
+\r
+-- fail\r
+expFail :: String -> Sem Val\r
+expFail msg = Sem $ \st -> (Error msg, st)\r
+\r
+-- insert value into set\r
+setInsert :: Val -> Val -> Sem Val\r
+setInsert (ISVal is) (IVal i) = Sem $ \st -> (ISVal (i:is), st)\r
+setInsert _ _ = expFail "insert fail!"\r
+\r
+-- remove value from set\r
+setDelete :: Val -> Val -> Sem Val\r
+setDelete (ISVal is) (IVal i) = Sem $ \st -> (ISVal (delete i is), st)\r
+setDelete _ _ = expFail "delete fail!"\r
+\r
+-- set union\r
+setUnion :: Val -> Val -> Sem Val\r
+setUnion (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (union is1 is2), st)\r
+setUnion _ _ = expFail "union fail!"\r
+\r
+-- set difference\r
+setDiff :: Val -> Val -> Sem Val\r
+setDiff (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (is1 \\ is2), st)\r
+setDiff _ _ = expFail "difference fail!"\r
+\r
+-- set intersection\r
+setIntersect :: Val -> Val -> Sem Val\r
+setIntersect (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (intersect is1 is2), st)\r
+setIntersect _ _ = expFail "intersection fail!"\r
+\r
+-- set size\r
+setSize :: Val -> Sem Val\r
+setSize (ISVal is) = Sem $ \st -> (IVal (length is), st)\r
+setSize _ = expFail "size fail!"\r
+\r
+-- integer operation\r
+intOper :: Val -> Op -> Val -> Val\r
+intOper (IVal i1) Add (IVal i2) = IVal (i1+i2)\r
+intOper (IVal i1) Sub (IVal i2) = IVal (i1-i2)\r
+intOper (IVal i1) Mul (IVal i2) = IVal (i1*i2)\r
+intOper _ _ _ = Error "Invalid integer operation!"\r
+\r
+-- Evaluate expression\r
+eval :: Expr a -> Sem Val\r
+eval New = Sem $ \st -> (ISVal [], st)\r
+eval (Ins e exp) = eval exp >>= \set -> eval e >>= \el -> setInsert set el\r
+eval (Del e exp) = eval exp >>= \set -> eval e >>= \el -> setDelete set el\r
+eval (Union exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setUnion s1 s2\r
+eval (Diff exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setDiff s1 s2\r
+eval (Intersect exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setIntersect s1 s2\r
+eval (Lit i) = Sem $ \st -> (IVal i, st)\r
+eval (Var id) = varRead id\r
+eval (Size exp) = eval exp >>= setSize\r
+eval (Oper exp1 op exp2) = eval exp1 >>= \l -> eval exp2 >>= \r -> Sem $ \st -> (intOper l op r, st)\r
+eval (Store id exp) = eval exp >>= varWrite id\r
+\r
+-- expression without error\r
+e = Store "y" (Ins (Lit 4) (Union (Ins (Lit 8) New) (Ins (Store "x" (Lit 55)) New)))\r
+\r
+-- expression with error\r
+--e = Size (Lit 1)\r
+\r
+-- entry point\r
+main = putStrLn (show (execSem (eval e) []))\r