Nearly complete w10

week10-reg/w10reg.icl

+module w10reg
+
+/*
+  Advanved Progrmming 2019, Assignment 10
+  Pieter Koopman, pieter@cs.ru.nl
+*/
+
+import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
+/*
+  qualified import of the named objects to avoid name conflicts.
+  Use this as 'iTasks'.return. All other parts of iTasks are available.
+*/
+import Data.Functor, Control.Applicative, Control.Monad
+import Data.Tuple
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+from Data.Set import instance == (Set a), instance < (Set a), instance Foldable Set
+
+
+from Text.GenJSON import JSONEncode
+derive class iTask State
+derive class iTask Stmt
+derive class iTask Expression
+derive class iTask Logical
+derive class iTask Val
+derive class iTask Res
+derive JSONEncode Map
+derive JSONDecode Map
+
+// use this as: 'List'.union
+
+// ================ the DSL ===============
+:: Expression
+  = New      [Int]
+  | Elem     Int
+  | Variable Ident
+  | Size     SetA
+  | (+.) infixl 6 Expression Expression
+  | (-.) infixl 6 Expression Expression
+  | (*.) infixl 7 Expression Expression
+  | (=.) infixl 2 Ident Expression
+
+:: Logical
+  = TRUE | FALSE
+  | (In) infix 4 Elem SetA
+  | (==.) 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 SetA Stmt
+  | If Logical Stmt Stmt
+
+:: SetA   :== Expression
+:: Elem  :== Expression
+:: Ident :== String
+
+// === State
+
+:: Val = I Int | SetA [Int]//('iTasks'.Set Int)
+
+:: State = State (Map Ident Val)
+
+// === semantics
+
+:: Res a = Res a | Err String
+:: Sem a = Sem (State -> (Res a, State))
+
+instance Functor Sem where
+  fmap f (Sem g) = Sem \s.case g s of
+                    (Res a,s) = (Res (f a), s) 
+                    (Err e,s) = (Err e, s) 
+
+
+instance <*> Sem where
+  (<*>) (Sem f) (Sem g)
+    = Sem \s.case f s of
+      (Res f, s) = case g s of
+        (Res a,s) = (Res (f a),s)
+        (Err e,     s) = (Err e,   s)
+      (Err e,s) = (Err e,s)
+
+unres :: (Sem a) -> (State -> (Res a, State))
+unres (Sem f) = f 
+instance Monad Sem where // !(m a) (a -> m b) -> m b
+  bind (Sem f) g = Sem \s. case f s of 
+            (Res a, s) =  unres (g a) s
+            (Err e, s) = (Err e, s)
+
+
+instance pure Sem where
+  pure a = Sem \s.(pure a, s)
+
+instance pure Res where
+  pure a = (Res a)
+
+fromMaybe :: (Maybe a) -> (Res a)
+fromMaybe (Just a)  = Res a
+fromMaybe (Nothing) = Err "ERROR while getting from state"
+
+store :: Ident Val -> Sem Val
+store i v = Sem \(State mp). (pure v, State ('Map'.put i v mp))
+
+read :: Ident -> Sem Val
+read i = Sem \(State mp).(fromMaybe ('Map'.get i mp), State mp)
+
+
+fail :: String -> Sem a
+fail str = Sem \s.(Err str, s)
+
+ourMap :: Int ('iTasks'.Set Int) -> ('iTasks'.Set Int)
+ourMap i s = 'Set'.fromList (map (\x->(x*i)) ('Set'.toList s))
+
+eval :: Expression -> Sem Val
+eval (Elem i) = pure (I i) 
+//eval (New i) = pure (map 'List'.union i)//(Set ('List'.union i)) 
+
+eval (New list) = pure (SetA ('Set'.toList ('Set'.fromList list)))
+
+eval (+. e1 e2) = eval e1 >>= \a1. 
+                    eval e2 >>= \a2. 
+                      case a1 of
+                      I a1 -> case a2 of
+                        I a2 -> pure (I (a1 + a2))
+                        SetA s1 -> pure (SetA ('Set'.toList ( 'Set'.union ('Set'.singleton a1) ('Set'.fromList s1) )))
+                      SetA s1 -> case a2 of 
+                        SetA s2 -> pure (SetA ('Set'.toList ('Set'.union ('Set'.fromList s1) ('Set'.fromList s2))))
+                        I a2 -> pure (SetA ('Set'.toList ('Set'.union ('Set'.fromList s1) ('Set'.singleton a2))))
+
+eval (-. e1 e2) = eval e1 >>= \a1. 
+                    eval e2 >>= \a2. 
+                      case a1 of
+                      I a1 -> case a2 of
+                        I a2 -> pure (I (a1 - a2))
+                        SetA s1 -> fail "Cannot subtract set from int"
+                      SetA s1 -> case a2 of 
+                        SetA s2 -> pure (SetA ('Set'.toList ('Set'.difference ('Set'.fromList s1) ('Set'.fromList s2))))
+                        I a2 -> pure (SetA ('Set'.toList ('Set'.difference ('Set'.fromList s1) ('Set'.singleton a2))))
+
+
+
+eval (*. e1 e2) = eval e1 >>= \a1.
+                    eval e2 >>= \a2. case a1 of
+                      I a1 -> case a2 of
+                        I a2 -> pure (I (a1 * a2))
+                        SetA s1 -> pure (SetA ('Set'.toList (ourMap (a1) ('Set'.fromList s1))))
+                      SetA s1 -> case a2 of 
+                        SetA s2 -> pure (SetA ('Set'.toList ('Set'.intersection ('Set'.fromList s1) ('Set'.fromList s2))))
+                        I a2 -> fail "Set *. Int is impossible"
+
+
+eval (=. id expr) = eval expr >>= \val. store id val
+eval (Variable id) = read id
+
+eval (Size e) = eval e >>= \a.case a of
+  I i -> fail "Can't have size of number"
+  SetA s -> pure (I (length s))
+
+//eval a = fail "not implemented"
+
+logiceval :: Logical -> Sem Bool
+logiceval TRUE = pure (True) 
+logiceval FALSE = pure (False) 
+logiceval (In e s) = eval e >>= \elem. case elem of
+        (I af) -> eval s >>= \st. case st of
+                SetA s -> pure ('Set'.member af ('Set'.fromList s))
+                _ -> fail "Can only check for element in a set" 
+        _ -> fail "Can not check for a set in a set"
+//  | (In) infix 4 Elem Set
+
+
+//  | (==.) infix 4 Expression Expression
+logiceval (==. a b) = eval a >>= \aa.
+        eval b >>= \bb.
+        case aa of
+          I a -> 
+            case bb of
+            I b -> pure (a == b)  
+            SetA b -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
+          SetA a -> case bb of 
+            SetA b -> pure (a == b) 
+            I _ -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
+
+
+//eval b >>= \bb. 
+//  | (<=.) infix 4 Expression Expression
+logiceval (<=. a b) = eval a >>= \aa.
+        eval b >>= \bb.
+        case aa of
+          I a -> 
+            case bb of
+            I b -> pure (a <= b)  
+            SetA b -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
+          SetA a -> case bb of 
+            SetA b -> pure (a <= b) 
+            I _ -> fail "CANNOT COMPARE AN ELEMENT AND A SET"
+
+//  | Not Logical
+logiceval (Not l1) = logiceval l1 >>= \b. pure (not b)
+
+logiceval (&&. l1 l2) = 
+  logiceval l1 >>= \b1.
+  logiceval l2 >>= \b2. pure (b1 && b2)
+logiceval (||. l1 l2) = 
+  logiceval l1 >>= \b1.
+  logiceval l2 >>= \b2. pure (b1 || b2)
+
+stmteval :: Stmt -> Sem ()
+stmteval (Expression expr) = eval expr >>= \e. pure ()
+stmteval (Logical l) = logiceval l >>= \e. pure ()
+stmteval (If l st1 st2) = logiceval l >>= \e. if e
+                                      (stmteval st1)
+                                      (stmteval st2)
+stmteval (For id st stmt) = eval st >>= \s. case s of
+    I _ -> fail "f" 
+    SetA s -> pure (\ elem. (store id (I elem))) >>= \e.pure ()
+
+
+
+// === Printing
+class printable a where
+  print :: a -> String
+
+instance printable Expression where
+  print (New ls)      = "[" +++ (foldr (\x y.x+++","+++y) "" (map toString ls)) +++ "]"
+  print (Elem i)      = toString i
+  print (Variable id) = id
+  print (Size expr)   = "size(" +++ print expr +++ ")"
+  print (+. e1 e2)    = print e1+++ " + "+++ print e2
+  print (-. e1 e2)    = print e1+++ " - "+++ print e2
+  print (*. e1 e2)    = print e1+++ " * "+++ print e2
+  print (=. id expr)  = id+++ " = "+++ print expr
+
+instance printable Logical where
+  print TRUE        = toString True
+  print FALSE       = toString False
+  print (In e s)    = print s +++ ".contains(" +++ print e +++ ")"
+  print (==. e s)   = print e +++ "==" +++ print e
+  print (<=. e s)   = print e +++ "<=" +++ print e
+  print (Not l)     = "!" +++ print l
+  print (&&. l1 l2) = print l1 +++ "&&" +++ print l2
+  print (||. l1 l2) = print l1 +++ "||" +++ print l2
+
+//    Set s -> pure (map (\ elem. (store id (I elem)) >>= \e.pure (stmteval stmt)  ) ('Set'.toList s)) >>= \e.pure ()
+
+
+
+
+/*eval (*. e1 e2) = eval e1 >>= \a1. 
+                    eval e2 >>= \a2. 
+                      case a1 of
+                      I a1 -> case a2 of
+                        I a2 -> pure (I (a1 * a2))
+                        Set s1 -> pure (Set ('Set'.difference s1 ('Set'.singleton a2)))
+                      Set s1 -> case a2 of 
+                        Set s2 -> pure (Set ('Set'.intersection s1 s2))
+                        I a2 -> fail "Cannot subtract set from int" 
+*/
+
+
+
+/*
+eval (-. e1 e2) = eval e1 >>= \a1. 
+                    eval e2 >>= \a2. 
+                      case a1 of
+                      I a1 -> case a2 of
+                        I a2 -> pure (I (a1 - a2))
+                        Set s1 -> fail "Oof, we cannot remove a set from an element"
+                      Set s1 -> case a2 of 
+                        Set s2 -> fail "impl missing"//pure (Set (s1 ++ s2))
+                        I a2 -> fail "impl missing"//pure (Set (a2:s1))
+*/
+
+//:: Sem a = Sem (State -> (Res a, State))
+//eval (+. e1 e2) = (eval e1)
+
+
+// !(m a) (a -> m b) -> m b
+
+// (I (a1+a2)))
+ //(eval e1) >>=  \Sem s. I 1     //\Sem s1. (eval e2) >>= \Sem s2. (Just (e1))  
+
+
+
+/*case (eval e1) of 
+  (I i1) -> case (eval e2) of
+      I i2 -> pure (I (i1+i2)) 
+      Set s -> fail "Cannot add int and set"
+  (Set s1) -> case (eval e2) of
+      I i -> fail "Cannot add set and int"
+      Set s2 -> pure (Set (s1+s2))
+*/
+
+//eval (+. e1 e2) = pure (I ((eval e1) + (eval e2))) 
+//eval (+. (Elem e1) (Elem e2)) = pure (I (e1 + e2)) 
+//eval (+. e1 e2) = fail "Cannot add" 
+
+anexpr = Elem 1
+anotherexpr = Elem 1 +. Elem 1
+//Start = let (State f) = (eval anexpr) in 'Map'.newMap >>= f   
+
+
+anotherexpr1 = Elem 1 +. New [1]
+anotherexpr2 = (New [2] +. ("henk" =. Elem 9) ) -. Variable "henk" //(New [4,5,6] +. Elem 7 +. Elem 7) -. Elem 7
+
+stt :: Stmt
+stt = If (Variable "a" ==. (Elem 9)) (Expression ("henk" =. Elem 9)) (Expression (Elem 2)) 
+aSet :: Expression
+aSet = New [0,1,9]
+astmt :: Stmt
+//astmt = If FALSE (Expression anotherexpr2) (Expression ("henk" =. Elem 10))
+astmt = For "a" aSet stt
+
+//Start = let (Sem f) = (eval anotherexpr2) in f (State 'Map'.newMap)
+//Start = let (Sem f) = (stmteval astmt) in f (State 'Map'.newMap)
+
+//f = 'Set'.toList ('Set'.fromList [1])
+// res : ((Err "Cannot add int with set"),(State Tip))
+
+// of //'Map'.newMap >>= f   
+
+
+
+// === simulation
+
+//derive JSONEncode Set
+//'derive JSONDecode Set
+//derive class iTask 'iTasks'.Set
+//derive class iTask Map String Val
+//derive class iTask (Map Ident Val)
+
+
+
+//:: Sem a = Sem (State -> (Res a, State))
+
+
+(>>>=)     :== tbind
+(>>>|) a b :== tbind a (\_ -> b)
+
+//evl e = let (Sem f) = (eval e) in f (State 'Map'.newMap)
+
+//myFTask :: Task (Res Val)
+//myFTask = enterInformation [] >>>= (\ex. let (res, stat) = (evl ex) in viewInformation [] res ) //viewInformation []
+                                  //(res, stat) = (f (State 'Map'.newMap))
+
+
+evl :: Expression State -> (Res Val,State)
+evl e s = let (Sem f) = (eval e) in f s
+
+//loopert s = enterInformation [] >>>=  (\ex. let (res, stat) = (evl2 ex s) in (viewInformation [] res) >>>= (loopert stat) )
+emptyState = State 'Map'.newMap
+loopert :: State (Maybe (Res Val)) (Maybe Expression) -> Task String//(Expression)
+//loopert s prv =(  (Title "Edit" @>> enterInformation [] >>>=  (\ex. let (res, stat) = (evl2 ex s) in (loopert stat (Just res)) ) ) 
+loopert prev_state prev_res prev_expr = (  (Title "Edit" @>> enterInformation [] ) 
+        -||  (Title "Pretty print" @>> viewInformation [] case prev_expr of 
+                                                                  (Just prev_expr) -> (print prev_expr)
+                                                                  Nothing -> "")
+        -||  (Title "Result" @>> viewInformation [] prev_res)
+        -||  (Title "Result state" @>>  viewInformation [] prev_state) 
+        )
+         >>* [  OnAction (Action "Add") (hasValue   (\ex. let (res, stat) = (evl ex prev_state) in (loopert stat (Just res) (Just ex)) ))
+         , OnAction (Action "Reset state") (always   ( (loopert emptyState prev_res prev_expr) ))
+         , OnAction (Action "Quit") (always   ( treturn "Goodbye"))
+       //, OnAction  ActionCancel     (always   (return []))
+       ]
+        
+            
+//loopert s = enterInformation [] >>>=  (\ex. let (res, stat) = (evl2 ex s) in (viewInformation [] res) ) 
+
+Start world = doTasks ((loopert emptyState Nothing Nothing ) >>>= \s. viewInformation [] s) world 
+
+
+