From 598b249accfd4133e93013d52c7df4e217598383 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 23 Nov 2018 09:11:19 +0100
Subject: [PATCH] a9

---
 afp/a9/a9.icl | 242 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 242 insertions(+)
 create mode 100644 afp/a9/a9.icl

diff --git a/afp/a9/a9.icl b/afp/a9/a9.icl
new file mode 100644
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]) []
+	)
-- 
2.20.1