From: Mart Lubbers <mart@martlubbers.net>
Date: Sun, 15 Nov 2015 16:40:28 +0000 (+0100)
Subject: a8 done
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=b581746031ac3188fd1f83425a377c8a719016b7;p=ap2015.git

a8 done
---

diff --git a/a8/mart/skeleton8.icl b/a8/mart/skeleton8.icl
index 3ba9d63..1d0e15f 100644
--- a/a8/mart/skeleton8.icl
+++ b/a8/mart/skeleton8.icl
@@ -6,22 +6,24 @@ import qualified Text
 from Text import class Text, instance Text String
 from StdFunc import o
 from StdTuple import fst
-from Data.Map import :: Map, put, get, newMap
+import qualified Data.Map as DM
 import Data.Either
 import qualified Data.List as List
 
-:: Element :== Sem Int
-:: Set :== Sem [Int]
+:: Element :== Stmt Int
+:: Set :== Stmt [Int]
 :: Val = I Int | S [Int] | B Bool
 :: State :== Map String Val
 :: Sem a = Sem (State -> (Either String a, State)) 
+:: Stmt a = {v :: Sem a, p :: [String]}
 
-unsem :: (Sem a) -> (State -> (Either String a, State))
-unsem (Sem a) = a
+:: THEN = THEN
+:: ELSE = ELSE
+:: DO = DO
 
 instance Functor Sem where
 	fmap :: (a -> b) (Sem a) -> Sem b
-	fmap f s = Sem \st.let (a, st`) = unsem s st in (fmap f a, st`)
+	fmap f (Sem s) = Sem \st.let (a, st`) = s st in (fmap f a, st`)
 
 instance Applicative Sem where
 	pure :: a -> Sem a
@@ -32,108 +34,92 @@ instance Applicative Sem where
 instance Monad Sem where
 	bind :: (Sem a) (a -> Sem b) -> Sem b
 	bind (Sem s) f = Sem \st.case s st of
-		(Right v, st`) = unsem (f v) st`
+		(Right v, st`) = let (Sem r) = f v in r st`
 		(Left e, st`) = (Left e, st`)
 
-store :: String Val -> Sem Val
-store i v = Sem \st.(pure v, put i v st)
-
-read :: String -> Sem Val
-read i = Sem \st.case get i st of
-		(Just v) = (Right v, st)
-		_ = unsem (fail "variable not found") st
-
 fail :: String -> Sem a
 fail s = Sem \st.(Left s,st)
 
-instance + Element where (+) s1 s2 = fmap (+) s1 <*> s2
-instance - Element where (-) s1 s2 = fmap (-) s1 <*> s2
-instance * Element where (*) s1 s2 = fmap (*) s1 <*> s2
+instance + Element where 
+	(+) s1 s2 = {v=(+) <$> s1.v <*> s2.v, p=s1.p ++ ["+"] ++ s2.p}
+instance - Element where
+	(-) s1 s2 = {v=(-) <$> s1.v <*> s2.v, p=s1.p ++ ["-"] ++ s2.p}
+instance * Element where
+	(*) s1 s2 = {v=(*) <$> s1.v <*> s2.v, p=s1.p ++ ["*"] ++ s2.p}
 
 integer :: Int -> Element
-integer i = return i
+integer i = {v=return i, p=[toString i]}
 
 size :: Set -> Element
-size s = fmap length s
+size s = {v=length <$> s.v, p=["|":s.p++["|"]]}
 
 new :: Set
-new = return []
+new = {v=return [], p=["∅"]}
 
 insert :: Element Set -> Set
-insert e s = union (fmap (\x.[x]) e) s
+insert e s = union {v=((\x.[x]) <$> e.v), p=["{":e.p++["}"]]} s
 
 delete :: Element Set -> Set
-delete e s = difference (fmap (\x.[x]) e) s
+delete e s = difference {v=((\x.[x]) <$> e.v), p=["{":e.p++["}"]]} s
 
 union :: Set Set -> Set
-union s1 s2 = fmap 'List'.union s1 <*> s2
+union s1 s2 = {v='List'.union <$> s1.v <*> s2.v, p=s1.p++["∪":s2.p]}
 
 difference :: Set Set -> Set
-difference s1 s2 = fmap 'List'.difference s1 <*> s2
+difference s1 s2 = {v='List'.difference <$> s1.v <*> s2.v, p=s1.p++["\\":s2.p]}
 
 intersection :: Set Set -> Set
-intersection s1 s2 = fmap 'List'.intersect s1 <*> s2
-
-class eval a :: (Sem a) -> (Either String a, State)
-
-instance eval Element where
-	eval (Sem e) = e newMap
-
-instance eval Set where
-	eval (Sem s) = s newMap
-
-instance eval Int where
-	eval (Sem s) = s newMap
-
-instance eval [Int] where
-	eval (Sem s) = s newMap
+intersection s1 s2 = {v='List'.intersect <$> s1.v <*> s2.v, p=s1.p++["∩":s2.p]}
 
 class variable a :: String -> a
 
 instance variable Element where
-	variable k = Sem \st.case get k st of
+	variable k = {v=Sem \st.case 'DM'.get k st of
 		(Just (I v)) = (Right v, st)
 		(Just _) = (Left "Wrong type, expected Int", st)
-		_ = (Left "Variable not found", st)
+		_ = (Left ("Variable '"+++ k +++ "' not found"), st), p=[k]}
 
 instance variable Set where
-	variable k = Sem \st.case get k st of
+	variable k = {v=Sem \st.case 'DM'.get k st of
 		(Just (S v)) = ((Right v), st)
 		(Just _) = (Left "Wrong type, expected Set", st)
-		_ = (Left "Variable not found", st)
-
+		_ = (Left ("Variable '" +++ k +++ "' not found"), st), p=[k]}
 class (=.) infix 2 a :: String a -> a
 
 instance =. Element where
-	(=.) k (Sem v) = Sem \st.case v st of
-		(Right v, st) = (Right v, put k (I v) st)
-		(Left e, st) = (Left e, st)
+	(=.) k v = {v=Sem \st.let (Sem v`) = v.v in case v` st of
+		(Right v`, st) = (Right v`, 'DM'.put k (I v`) st)
+		(Left e, st) = (Left e, st), p=[k:[":=":v.p]]}
 
 instance =. Set where
-	(=.) k (Sem v) = Sem \st.case v st of
-		(Right v, st) = (Right v, put k (S v) st)
-		(Left e, st) = (Left e, st)
+	(=.) k v = {v=Sem \st.let (Sem v`) = v.v in case v` st of
+		(Right v`, st) = (Right v`, 'DM'.put k (S v`) st)
+		(Left e, st) = (Left e, st), p=[k:[":=":v.p]]}
 
-(:.) infixl 1 :: (Sem a) (Sem b) -> (Sem b)
-(:.) s1 s2 = s1 >>| s2
+(:.) infixl 1 :: (Stmt a) (Stmt b) -> (Stmt b)
+(:.) s1 s2 = {v=s1.v >>| s2.v, p=s1.p ++ [";\n":s2.p]}
 
-(==.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | == a
-(==.) s1 s2 = fmap (==) s1 <*> s2
+(==.) infix 4 :: (Stmt a) (Stmt a) -> (Stmt Bool) | == a
+(==.) s1 s2 = {v=(==) <$> s1.v <*> s2.v, p=s1.p++["==":s2.p]}
 
-(<.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | < a
-(<.) s1 s2 = fmap (<) s1 <*> s2
+(<.) infix 4 :: (Stmt a) (Stmt a) -> (Stmt Bool) | < a
+(<.) s1 s2 = {v=(<) <$> s1.v <*> s2.v, p=s1.p++["<":s2.p]}
 
-IF :: (Sem Bool) THEN (Sem a) ELSE (Sem a) -> Sem a
-IF c _ t _ e = c >>= \c.if c t e
+IF :: (Stmt Bool) THEN (Stmt a) ELSE (Stmt a) -> Stmt a
+IF c _ t _ e = {v=c.v >>= \c`.if c` t.v e.v,
+		p=["IF ":c.p]++[" THEN\n":t.p]++ ["\nELSE\n":e.p] ++ ["\nFI"]}
 
-WHILE :: (Sem Bool) DO (Sem a) -> Sem Int
-WHILE c _ b = c >>= \c`.if c` (fmap ((+) 1) (b >>| WHILE c DO b)) (return 0)
+WHILE :: (Stmt Bool) DO (Stmt a) -> Stmt Int
+WHILE c _ b = {v=while c.v b.v, p=["WHILE ":c.p]++[" DO\n":b.p]++["\nOD"]}
+	where
+		while c b = c >>= \c`.if c` (((+) 1) <$> (b >>| while c b)) (return 0)
 
-:: THEN = THEN
-:: ELSE = ELSE
-:: DO = DO
+eval e = let (Sem ev) = e.v in let (_, st) = ev 'DM'.newMap in 'DM'.toList st
+print e = 'Text'.concat e.p
+
+Start = print expr10
+//Start = eval expr10
 
-// examples
 expr1 :: Element
 expr1 = integer 2
 
@@ -190,5 +176,3 @@ expr10 =
 x = "x"
 y = "y"
 z = "z"
-
-Start = (eval expr10)
diff --git a/a8/mart/skeleton8_without_printing.icl b/a8/mart/skeleton8_without_printing.icl
new file mode 100644
index 0000000..7496c12
--- /dev/null
+++ b/a8/mart/skeleton8_without_printing.icl
@@ -0,0 +1,183 @@
+module skeleton8
+
+import StdList, StdInt, Data.Tuple, StdClass, iTasks._Framework.Generic, Text.JSON, Data.Functor, Control.Applicative, Control.Monad, Data.Void
+import qualified iTasks
+import qualified Text
+from Text import class Text, instance Text String
+from StdFunc import o
+from StdTuple import fst
+from Data.Map import :: Map, put, get, newMap
+import Data.Either
+import qualified Data.List as List
+
+:: Element :== Sem Int
+:: Set :== Sem [Int]
+:: Val = I Int | S [Int] | B Bool
+:: State :== Map String Val
+:: Sem a = Sem (State -> (Either String a, State)) 
+
+instance Functor Sem where
+	fmap :: (a -> b) (Sem a) -> Sem b
+	fmap f (Sem s) = Sem \st.let (a, st`) = s st in (fmap f a, st`)
+
+instance Applicative Sem where
+	pure :: a -> Sem a
+	pure s = Sem \st.(pure s, st)
+	(<*>) infixl 4  :: (Sem (a -> b)) (Sem a) -> Sem b
+	(<*>) a f = ap a f
+
+instance Monad Sem where
+	bind :: (Sem a) (a -> Sem b) -> Sem b
+	bind (Sem s) f = Sem \st.case s st of
+		(Right v, st`) = let (Sem r) = f v in r st`
+		(Left e, st`) = (Left e, st`)
+
+fail :: String -> Sem a
+fail s = Sem \st.(Left s,st)
+
+instance + Element where (+) s1 s2 = (+) <$> s1 <*> s2
+instance - Element where (-) s1 s2 = (-) <$> s1 <*> s2
+instance * Element where (*) s1 s2 = (*) <$> s1 <*> s2
+
+integer :: Int -> Element
+integer i = return i
+
+size :: Set -> Element
+size s = length <$> s
+
+new :: Set
+new = return []
+
+insert :: Element Set -> Set
+insert e s = union ((\x.[x]) <$> e) s
+
+delete :: Element Set -> Set
+delete e s = difference ((\x.[x]) <$> e) s
+
+union :: Set Set -> Set
+union s1 s2 = fmap 'List'.union s1 <*> s2
+
+difference :: Set Set -> Set
+difference s1 s2 = fmap 'List'.difference s1 <*> s2
+
+intersection :: Set Set -> Set
+intersection s1 s2 = fmap 'List'.intersect s1 <*> s2
+
+class eval a :: (Sem a) -> (Either String a, State)
+
+instance eval Element where
+	eval (Sem e) = e newMap
+
+instance eval Set where
+	eval (Sem s) = s newMap
+
+instance eval Int where
+	eval (Sem s) = s newMap
+
+instance eval [Int] where
+	eval (Sem s) = s newMap
+
+class variable a :: String -> a
+
+instance variable Element where
+	variable k = Sem \st.case get k st of
+		(Just (I v)) = (Right v, st)
+		(Just _) = (Left "Wrong type, expected Int", st)
+		_ = (Left "Variable not found", st)
+
+instance variable Set where
+	variable k = Sem \st.case get k st of
+		(Just (S v)) = ((Right v), st)
+		(Just _) = (Left "Wrong type, expected Set", st)
+		_ = (Left "Variable not found", st)
+
+class (=.) infix 2 a :: String a -> a
+
+instance =. Element where
+	(=.) k (Sem v) = Sem \st.case v st of
+		(Right v, st) = (Right v, put k (I v) st)
+		(Left e, st) = (Left e, st)
+
+instance =. Set where
+	(=.) k (Sem v) = Sem \st.case v st of
+		(Right v, st) = (Right v, put k (S v) st)
+		(Left e, st) = (Left e, st)
+
+(:.) infixl 1 :: (Sem a) (Sem b) -> (Sem b)
+(:.) s1 s2 = s1 >>| s2
+
+(==.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | == a
+(==.) s1 s2 = fmap (==) s1 <*> s2
+
+(<.) infix 4 :: (Sem a) (Sem a) -> (Sem Bool) | < a
+(<.) s1 s2 = fmap (<) s1 <*> s2
+
+IF :: (Sem Bool) THEN (Sem a) ELSE (Sem a) -> Sem a
+IF c _ t _ e = c >>= \c.if c t e
+
+WHILE :: (Sem Bool) DO (Sem a) -> Sem Int
+WHILE c _ b = c >>= \c`.if c` (fmap ((+) 1) (b >>| WHILE c DO b)) (return 0)
+
+:: THEN = THEN
+:: ELSE = ELSE
+:: DO = DO
+
+// examples
+expr1 :: Element
+expr1 = integer 2
+
+expr2 :: Element
+expr2 = expr1 + expr1
+
+expr3 :: Element
+expr3 = expr1 + expr1 * integer 3
+
+expr4 :: Set
+expr4 = union new (insert expr1 (insert expr3 new))
+
+expr5 :: Set
+expr5 =
+    x =. expr4 :.
+    variable x
+
+expr6 :: Element
+expr6 =
+    x =. insert (integer 11) new :.
+    x =. size (variable x) :.
+    variable x
+
+expr7 :: Set
+expr7 =
+    x =. insert (integer 11) new :.
+    y =. variable x
+
+expr8 :: Set
+expr8 =
+    x =. insert (integer 11) new :.
+    x =. insert (size (variable x)) (variable x) :.
+    variable x
+
+expr9 :: Set
+expr9 =
+    x =. insert (integer 0) new :.
+    IF (size (variable x) ==. integer 0) THEN
+        (x =. insert (integer 0) (variable x))
+    ELSE
+        (x =. delete (integer 0) (variable x)) :.
+    variable x
+
+expr10 :: Set
+expr10 =
+	z =. integer 7 :.
+	x =. new :.
+	x =. insert (variable z) (variable x) :.
+	y =. union (variable x) (variable x) :.
+	WHILE (size (variable x) <. integer 5) DO
+		(x =. insert (size (variable x)) (variable x)) :.
+	z =. difference (variable x) (intersection (variable x) (insert (variable z) new))
+
+x = "x"
+y = "y"
+z = "z"
+
+Start = expr10