a9

diff --git a/afp/a9/a9.icl b/afp/a9/a9.icl
new file mode 100644 (file)
index 0000000..5614d69
--- /dev/null
+++ b/afp/a9/a9.icl
@@ -0,0 +1,242 @@
+module a9
+
+/*
+  Advanced Progrmming 2018, Assignment 8
+  Pieter Koopman, pieter@cs.ru.nl
+*/
+import StdEnv
+
+
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Func
+import Data.Functor
+import Data.Either
+import Data.Maybe
+import Data.List
+
+import Text
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+
+:: Set   :== Sem [Int]
+:: Elem  :== Sem Int
+:: Ident :== String
+
+// === State
+:: Val :== Either Int [Int]
+:: SemState :== 'Map'.Map String Val
+
+:: Sem a =
+       { evaluator :: StateT SemState (Either String) a
+       , printer   :: [String] -> [String]
+       }
+
+fail :: String -> StateT SemState (Either String) a
+fail s = liftT (Left s)
+
+//Sets
+integer :: Int -> Elem
+integer i = {evaluator=pure i,printer = \c->[toString i:c]}
+
+set :: [Int] -> Set
+set i =
+       { evaluator = pure (removeDup i)
+       , printer   = \c->["[":intersperse "," (map toString i)] ++ ["]":c]
+       }
+
+size :: Set -> Elem
+size s =
+       { evaluator = length <$> s.evaluator
+       , printer   = \c->["size(":s.printer [")"]]
+       }
+
+class variable a :: String -> a
+instance variable Set
+where
+       variable i =
+               { evaluator
+                       = gets ('Map'.get i) >>= \v->case v of
+                               Nothing = fail ("No set with identifier " +++ i)
+                               Just (Left v) = fail (i +++ " is an element")
+                               Just (Right v) = pure v
+               , printer = \c->[i:c]
+               }
+instance variable Elem
+where
+       variable i =
+               { evaluator
+                       = gets ('Map'.get i) >>= \v->case v of
+                               Nothing = fail ("No element with identifier " +++ i)
+                               Just (Right v) = fail (i +++ " is a set")
+                               Just (Left v) = pure v
+               , printer = \c->[i:c]
+               }
+class (+.) infixl 6 a b ~c :: a b -> c
+instance +. Elem Elem Elem
+where
+       +. a b =
+               { evaluator = (+) <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["+":b.printer c]
+               }
+instance +. Elem Set Set
+where
+       +. a b =
+               { evaluator = 'List'.union <$> pure <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["+":b.printer c]
+               }
+instance +. Set Elem Set
+where
+       +. a b =
+               { evaluator = 'List'.union <$> a.evaluator <*> (pure <$> b.evaluator)
+               , printer   = \c->a.printer ["+":b.printer c]
+               }
+instance +. Set Set Set
+where
+       +. a b =
+               { evaluator = 'List'.union <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["+":b.printer c]
+               }
+class (-.) infixl 6 a b ~c :: a b -> c
+instance -. Elem Elem Elem
+where
+        -. a b =
+               { evaluator = (-) <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["-":b.printer c]
+               }
+instance -. Set Elem Set
+where
+        -. a b =
+               { evaluator = 'List'.difference <$> a.evaluator <*> (pure <$> b.evaluator)
+               , printer   = \c->a.printer ["-":b.printer c]
+               }
+instance -. Set Set Set
+where
+        -. a b =
+               { evaluator = 'List'.difference <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["-":b.printer c]
+               }
+class (*.) infixl 6 a b ~c :: a b -> c
+instance *. Elem Elem Elem
+where
+        *. a b =
+               { evaluator = (*) <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["*":b.printer c]
+               }
+instance *. Elem Set Set
+where
+        *. a b =
+               { evaluator = a.evaluator >>= \x->map ((*)x) <$> b.evaluator
+               , printer   = \c->a.printer ["*":b.printer c]
+               }
+instance *. Set Set Set
+where
+        *. a b =
+               { evaluator = 'List'.intersect <$> a.evaluator <*> b.evaluator
+               , printer   = \c->a.printer ["*":b.printer c]
+               }
+
+class (=.) infixl 2 a :: Ident a -> a
+instance =. Set
+where
+        =. n s =
+               { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Right v)) *> pure v
+               , printer   = \c->[n,"=":s.printer c]
+               }
+instance =. Elem
+where
+        =. n s =
+               { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Left v)) *> pure v
+               , printer   = \c->[n,"=":s.printer c]
+               }
+
+//Logicals
+:: Logical :== Sem Bool
+true :: Logical
+true = {evaluator = pure True, printer = \c->["True":c]}
+
+false :: Logical
+false = {evaluator = pure False, printer = \c->["False":c]}
+
+In :: Elem Set -> Logical
+In e s =
+       { evaluator = elem <$> e.evaluator <*> s.evaluator
+       , printer   = \c->e.printer ["In":s.printer c]
+       }
+
+class (==.) infix 4 a :: a a -> Logical
+instance ==. Elem
+where
+        ==. a b =
+               {evaluator = (==) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["==":b.printer c]
+               }
+instance ==. Set
+where
+        ==. a b =
+               {evaluator = (==) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["==":b.printer c]
+               }
+
+class (<=.) infixl 6 a b :: a b -> Logical
+instance <=. Elem Elem
+where
+        <=. a b =
+               {evaluator = (<=) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["<=":b.printer c]
+               }
+instance <=. Set Set
+where
+        <=. a b =
+               {evaluator = ((<=) `on` length) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["<=":b.printer c]
+               }
+
+Not :: Logical -> Logical
+Not a = {evaluator = not <$> a.evaluator, printer = \c->["not":a.printer c]}
+
+(||.) infixr 2 :: Logical Logical -> Logical
+(||.) a b =
+               {evaluator = (||) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["||":b.printer c]
+               }
+
+(&&.) infixr 2 :: Logical Logical -> Logical
+(&&.) a b =
+               {evaluator = (&&) <$> a.evaluator <*> b.evaluator
+               ,printer   = \c->a.printer ["&&":b.printer c]
+               }
+
+//Stmts
+:: Stmt :== Sem ()
+expression :: Set -> Stmt
+expression e = {evaluator = e.evaluator *> pure (), printer = e.printer}
+
+logical :: Logical -> Stmt
+logical e = {evaluator = e.evaluator *> pure (), printer = e.printer}
+
+For :: String Set Stmt -> Stmt
+For i e s =
+       { evaluator = (i =. e).evaluator *> s.evaluator
+       , printer   = \c->["For",i,"=":e.printer ["In":s.printer c]]
+       }
+
+If :: Logical Stmt Stmt -> Stmt
+If l s1 s2 =
+       { evaluator = l.evaluator >>= \b->if b s1.evaluator s2.evaluator
+       , printer   = \c->["If":l.printer ["then":s1.printer ["else":s2.printer c]]]
+       }
+
+evalSem :: (Sem a) -> (SemState -> Either String a)
+evalSem s = evalStateT s.evaluator
+
+printSem :: (Sem a) -> ([String] -> [String])
+printSem s = s.printer
+
+Start =
+       ( evalSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) 'Map'.newMap
+       , join " " $ printSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) []
+       )