From: Mart Lubbers <mart@martlubbers.net>
Date: Sun, 15 Nov 2015 13:01:11 +0000 (+0100)
Subject: alles tot printen klaar
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=6bde083f773133ce6d5d0c418209791c481f41d1;p=ap2015.git

alles tot printen klaar
---

diff --git a/a8/mart/skeleton8.icl b/a8/mart/skeleton8.icl
index ea9960d..3ba9d63 100644
--- a/a8/mart/skeleton8.icl
+++ b/a8/mart/skeleton8.icl
@@ -7,12 +7,134 @@ from Text import class Text, instance Text String
 from StdFunc import o
 from StdTuple import fst
 from Data.Map import :: Map, put, get, newMap
-from Data.List import union, removeMember, instance Functor []
+import Data.Either
 import qualified Data.List as List
 
-// examples
+:: 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)) 
+
+unsem :: (Sem a) -> (State -> (Either String a, State))
+unsem (Sem a) = a
+
+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`)
+
+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`) = unsem (f v) 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
+
+integer :: Int -> Element
+integer i = return i
+
+size :: Set -> Element
+size s = fmap length s
+
+new :: Set
+new = return []
+
+insert :: Element Set -> Set
+insert e s = union (fmap (\x.[x]) e) s
+
+delete :: Element Set -> Set
+delete e s = difference (fmap (\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)
 
-/*expr1 :: Element
+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
@@ -22,7 +144,7 @@ expr3 :: Element
 expr3 = expr1 + expr1 * integer 3
 
 expr4 :: Set
-expr4 = insert expr3 new
+expr4 = union new (insert expr1 (insert expr3 new))
 
 expr5 :: Set
 expr5 =
@@ -67,6 +189,6 @@ expr10 =
 
 x = "x"
 y = "y"
-z = "z"*/
-	 
-Start = "implement 'eval' function"//eval expr1
+z = "z"
+
+Start = (eval expr10)