From: Mart Lubbers 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)