--- /dev/null
+module a8
+
+/*
+ Advanced Progrmming 2018, Assignment 8
+ Pieter Koopman, pieter@cs.ru.nl
+*/
+import StdEnv
+
+import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Func
+import Data.Functor
+import Data.Either
+import Data.Maybe
+
+import Text => qualified join
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+
+:: Expression
+ = New [Int]
+ | Elem Int
+ | Variable Ident
+ | Size Set
+ | (+.) infixl 6 Expression Expression
+ | (-.) infixl 6 Expression Expression
+ | (*.) infixl 7 Expression Expression
+ | (=.) infixl 2 Ident Expression
+
+:: Logical
+ = TRUE | FALSE
+ | (In) infix 4 Elem Set
+ | (==.) infix 4 Expression Expression
+ | (<=.) infix 4 Expression Expression
+ | Not Logical
+ | (||.) infixr 2 Logical Logical
+ | (&&.) infixr 3 Logical Logical
+
+:: Stmt
+ = Expression Expression
+ | Logical Logical
+ | For Ident Set Stmt
+ | If Logical Stmt Stmt
+
+:: Set :== Expression
+:: Elem :== Expression
+:: Ident :== String
+
+// === State
+:: Val :== Either Int [Int]
+:: SemState :== 'Map'.Map String Val
+
+:: Sem a :== StateT SemState (Either String) a
+store :: Ident Val -> Sem Val
+store k v = modify ('Map'.put k v) *> pure v
+
+read :: Ident -> Sem Val
+read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure
+
+fail :: String -> Sem a
+fail s = liftT (Left s)
+
+// === semantics
+isset :: (Sem Val) -> Sem [Int]
+isset s = s >>= either (\_->fail "Expected Set, got Elem") pure
+
+iselem :: (Sem Val) -> Sem Int
+iselem s = s >>= either pure (\_->fail "Expected Elem, got Set")
+
+evalExpr :: Expression -> Sem Val
+evalExpr (New s) = pure $ Right s
+evalExpr (Elem i) = pure $ Left i
+evalExpr (Variable i) = read i
+evalExpr (Size s) = isset (evalExpr s) >>= pure o Left o length
+evalExpr (l +. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+ (Left x, Left y) = pure $ Left (x + y)
+ (Left x, Right y) = pure $ Right $ 'List'.union [x] y
+ (Right x, Left y) = pure $ Right $ 'List'.union x [y]
+ (Right x, Right y) = pure $ Right $ 'List'.union x y
+evalExpr (l -. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+ (Left x, Left y) = pure $ Left (x - y)
+ (Left x, Right y) = fail "Elem -. Set is illegal"
+ (Right x, Left y) = pure $ Right $ 'List'.intersect x [y]
+ (Right x, Right y) = pure $ Right $ 'List'.intersect x y
+evalExpr (l *. r) = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+ (Left x, Left y) = pure $ Left (x * y)
+ (Left x, Right y) = pure $ Right [x*y\\y<-y]
+ (Right x, Left y) = fail "Set *. Elem is illegal"
+ (Right x, Right y) = pure $ Right $ 'List'.intersect x y
+evalExpr (v =. b) = evalExpr b >>= store v
+
+evalLogic :: Logical -> Sem Bool
+evalLogic TRUE = pure True
+evalLogic FALSE = pure False
+evalLogic (e In s) = liftM2 'List'.elem (iselem (evalExpr e)) (isset (evalExpr s))
+evalLogic (e1 ==. e2) = liftM2 (===) (evalExpr e1) (evalExpr e2)
+evalLogic (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of
+ (Left e1, Left e2) = pure $ e1 < e2
+ (Left e1, Right e2) = pure $ True
+ (Right e1, Left e2) = pure $ False
+ (Right e1, Right e2) = pure $ length e1 < length e2
+evalLogic (Not l) = not <$> evalLogic l
+evalLogic (l1 ||. l2) = liftM2 (||) (evalLogic l1) (evalLogic l2)
+evalLogic (l1 &&. l2) = liftM2 (&&) (evalLogic l1) (evalLogic l2)
+
+evalStmt :: Stmt -> Sem ()
+evalStmt (Expression e) = evalExpr e >>| pure ()
+evalStmt (Logical l) = evalLogic l >>| pure ()
+evalStmt (For i e s) = (evalExpr e >>= store i) *> evalStmt s
+evalStmt (If l s1 s2) = evalLogic l >>= \b->if b (evalStmt s1) (evalStmt s2)
+
+printExpr :: Expression [String] -> [String]
+printExpr (New s) c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c]
+printExpr (Elem i) c = [toString i:c]
+printExpr (Variable i) c = [i:c]
+printExpr (Size s) c = ["size(":printExpr s [")":c]]
+printExpr (l +. r) c = ["(":printExpr l ["+.":printExpr r [")":c]]]
+printExpr (l -. r) c = ["(":printExpr l ["-.":printExpr r [")":c]]]
+printExpr (l *. r) c = ["(":printExpr l ["*.":printExpr r [")":c]]]
+printExpr (l =. r) c = [l,"=.":printExpr r c]
+
+printLogic :: Logical [String] -> [String]
+printLogic TRUE c = ["True":c]
+printLogic FALSE c = ["False":c]
+printLogic (e In s) c = printExpr e [" in ":printExpr s c]
+printLogic (e1 ==. e2) c = ["(":printExpr e1 ["==.":printExpr e2 [")":c]]]
+printLogic (e1 <=. e2) c = ["(":printExpr e1 ["<=.":printExpr e2 [")":c]]]
+printLogic (Not l) c = ["not (":printLogic l [")":c]]
+printLogic (l1 ||. l2) c = ["(":printLogic l1 ["||.":printLogic l2 [")":c]]]
+printLogic (l1 &&. l2) c = ["(":printLogic l1 ["&&.":printLogic l2 [")":c]]]
+
+printStmt :: Stmt [String] -> [String]
+printStmt (Expression e) c = printExpr e c
+printStmt (Logical l) c = printLogic l c
+printStmt (For i e s) c = ["For ",i,"=":printExpr e ["in":printStmt s ["Rof":c]]]
+printStmt (If l s1 s2) c = ["If":printLogic l ["then":printStmt s1 ["else":printStmt s2 ["Fi":c]]]]
+
+// === simulation
+stateShared :: Shared SemState
+stateShared = sharedStore "sharedSemState" 'Map'.newMap
+
+derive class iTask Expression, Logical, Stmt
+
+main :: Task SemState
+main = 'iTasks'.forever $
+ enterInformation "Enter a statement" []
+ -|| viewSharedInformation "Old state" [ViewAs printState] stateShared
+ >&^ viewSharedInformation "Print" [ViewAs viewer]
+ >&> viewSharedInformation "New state" [ViewAs $ fmap printState] o mapRead evaler o ((>*<) stateShared)
+ >>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared]
+where
+ viewer = maybe
+ "No expression selected"
+ ('Text'.join " " o flip printStmt [])
+ evaler (s, t) = maybe
+ (Left "No expression selected")
+ (\e->execStateT (evalStmt e) s) t
+ printState m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m]
+
+Start w = doTasks main w
repositories / clean-tests.git / blobdiff