From b9661b6d185fcb92e9106cfd174484489e0c8d78 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Mon, 2 Oct 2017 20:15:34 +0200 Subject: dos2unix --- assignment-2/serialize2start.icl | 520 +++++++++++++++++++------------------- assignment-3/genericMap.icl | 74 +++--- assignment-3/serialize3Start.icl | 526 +++++++++++++++++++-------------------- assignment-4/monad.dcl | 70 +++--- assignment-4/monad.icl | 16 +- assignment-4/serialize4.icl | 462 +++++++++++++++++----------------- assignment-4/student.icl | 324 ++++++++++++------------ 7 files changed, 1005 insertions(+), 987 deletions(-) diff --git a/assignment-2/serialize2start.icl b/assignment-2/serialize2start.icl index 3717b9c..291b837 100644 --- a/assignment-2/serialize2start.icl +++ b/assignment-2/serialize2start.icl @@ -1,260 +1,260 @@ -module serialize2start - -/* - Definition for assignment 2 in AFP 2017 - Pieter Koopman pieter@cs.ru.nl - September 2017 - - Laurens Kuiper (s4467299) - Camil Staps (s4498062) -*/ - -import StdEnv, StdMaybe - -/** - * Review questions - * - * 1. A type is a set of values. In the case of UNIT, UNIT = {UNIT}. The set of - * possible arguments to == on a type T is {(x,y) | x <- T, y <- T}, so in the - * case of UNIT we have {(UNIT,UNIT)}. Hence, this alternative matches always. - * The other suggestions are equivalent, as the pattern match is because of - * this meaningless and therefore all alternatives in the question are - * equivalent. - * - * 2. The name of the constructor is redundant information, since the same - * information can also be derived (compile-time only, hence it has to be - * stored) from the LEFT/RIGHT-path through the ADT tree. Hence, checking on - * the constructor name is not needed. - * - * 3. - * - [] = LEFT (CONS "_Nil" UNIT) - * - Leaf = LEFT (CONS "Leaf" UNIT) - * == has type a a -> Bool, so we cannot apply it to Leaf and [], which are not - * of the same type. So no, this does not yield True (it does not yield - * anything, as you won't be able to compile it). - */ - -/** - * The number of elements in an expression that will be placed on the outer - * level w.r.t. parentheses when pretty-printing. - * - * For instance: - * - "37" -> 1 - * - "_Nil" -> 1 - * - "_Cons 1 _Nil" -> 3 - * - "(_Cons 1 _Nil)" -> 1 - */ -class outerElems a -where - outerElems :: a -> Int - - /** - * An expression needs parentheses when it has more than one element on the - * outer level. - */ - needsParens x :== outerElems x > 1 - -/** - * In the default case, parentheses are placed around the whole expression, so - * the number of elements on the outer level is 1. - */ -instance outerElems a where outerElems _ = 1 - -//* UNITs are not printed. -instance outerElems UNIT where outerElems _ = 0 - -//* The arguments and the constructor -instance outerElems (CONS a) | outerElems a -where outerElems (CONS _ x) = 1 + outerElems x - -//* Both elements appear on the outer level -instance outerElems (PAIR a b) | outerElems a & outerElems b -where outerElems (PAIR x y) = outerElems x + outerElems y - -instance outerElems (EITHER a b) | outerElems a & outerElems b -where - outerElems (LEFT x) = outerElems x - outerElems (RIGHT x) = outerElems x - -/** - * We extended the definition with a restriction on outerElems. This extra - * restriction is OK, since there is an instance of outerElems for every type - * (and hence, this restriction does not exclude any type). - */ -class serialize a | outerElems a -where - write :: a [String] -> [String] - read :: [String] -> Maybe (a,[String]) - -instance serialize Bool where - write b c = [toString b:c] - read ["True":r] = Just (True,r) - read ["False":r] = Just (False,r) - read _ = Nothing - -instance serialize Int where - write i c = [toString i:c] - read [s:r] - # i = toInt s - | s == toString i - = Just (i,r) - = Nothing - read _ = Nothing - -// --- - -:: UNIT = UNIT -:: EITHER a b = LEFT a | RIGHT b -:: PAIR a b = PAIR a b -:: CONS a = CONS String a - -// --- - -writeP :: a [String] -> [String] | serialize a -writeP x s = if (needsParens x) ["(":write x [")":s]] (write x s) - -readP :: [String] -> Maybe (a, [String]) | serialize a -readP ["(":r] = case read r of - Just (x,[")":r]) -> Just (x,r) - _ -> read ["(":r] -readP r = case read r of - Just (x,r) -> if (needsParens x) Nothing (Just (x,r)) - _ -> Nothing - -instance serialize UNIT -where - write _ c = c - read r = Just (UNIT,r) - -instance serialize (EITHER a b) | serialize a & serialize b -where - write (LEFT x) c = write x c - write (RIGHT x) c = write x c - read r = case read r of - Just (x,r) -> Just (LEFT x, r) - Nothing -> case read r of - Just (x,r) -> Just (RIGHT x,r) - Nothing -> Nothing - // This goes wrong if the two type variables of EITHER are equal (and - // hence read for LEFT is the same as read for RIGHT: we will always - // return a LEFT. Therefore, given a type - // - // :: T = C1 Int | C2 Int - // - // it is not possible to write and read C2 (C1 will be read, since LEFT - // has precedence). Like the example given as the answer to the - // reflection questin below, we don't think this to be fixable in the - // current setup. - -instance serialize (PAIR a b) | serialize a & serialize b -where - write (PAIR x y) c = writeP x [" ":writeP y c] - read r = case readP r of - Just (x,[" ":r]) -> case readP r of - Nothing -> Nothing - Just (y,r) -> Just (PAIR x y, r) - _ -> Nothing - -instance serialize (CONS a) | serialize a -where - write e=:(CONS s x) c - | needsParens e = ["(":s:" ":write x [")":c]] - | otherwise = [s:c] - read ["(":s:" ":r] = case read r of - Just (x,[")":r]) -> Just (CONS s x,r) - _ -> Nothing - read [s:r] = case read r of - Just (x,r) -> let e = CONS s x in if (needsParens e) Nothing (Just (e,r)) - Nothing -> Nothing - read _ = Nothing - -:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) - -fromList :: [a] -> ListG a -fromList [] = LEFT (CONS "_Nil" UNIT) -fromList [x:xs] = RIGHT (CONS "_Cons" (PAIR x xs)) - -toList :: (ListG a) -> [a] -toList (LEFT _) = [] -toList (RIGHT (CONS _ (PAIR x xs))) = [x:xs] - -instance serialize [a] | serialize a -where - write l c = write (fromList l) c - read l = case read l of - Just (g,r) -> Just (toList g,r) - Nothing -> Nothing - -:: Bin a = Leaf | Bin (Bin a) a (Bin a) -:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) - -fromBin :: (Bin a) -> BinG a -fromBin Leaf = LEFT (CONS "Leaf" UNIT) -fromBin (Bin l x r) = RIGHT (CONS "Bin" (PAIR l (PAIR x r))) - -toBin :: (BinG a) -> Bin a -toBin (LEFT _) = Leaf -toBin (RIGHT (CONS _ (PAIR l (PAIR x r)))) = Bin l x r - -instance serialize (Bin a) | serialize a -where - write a c = write (fromBin a) c - read l = case read l of - Just (g,r) -> Just (toBin g,r) - Nothing -> Nothing - -instance == (Bin a) | == a where // better use the generic approach - (==) Leaf Leaf = True - (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s - (==) _ _ = False - -// --- - -/** - * Reflection: - * The following is parsed as Just ([], []), which shows that the fact that - * there is no check on the name of the constructor can be exploited. - * - * In the actual Clean implementation, there is the construct `CONS of d` where - * d :: GenericConsDescriptor. This way, the name, arity, etc. of the - * constructor are available as part of the CONS type (even though this type - * does not explicitly contain the information). It is essentially a very - * restricted form of dependent typing, which makes it possible to distinguish - * the _Nil-CONS and the _Cons-CONS at compile-time. - * - * This requires the `CONS of d` construct, so I don't think this exploit is - * fixable in the current setup. It would of course be possible to redefine - * toList and toBin to result in a Maybe and check on the constructor there. - */ -Start :: Maybe ([Int], [String]) -Start = read ["_Cons"] - -Start = - [ test True - , test False - , test 0 - , test 123 - , test -36 - , test [42] - , test [0..4] - , test [[True],[]] - , test (Bin Leaf True Leaf) - , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] - , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] - ] - -test :: a -> ([String],[String]) | serialize, == a -test a = - (if (isJust r) - (if (fst jr == a) - (if (isEmpty (tl (snd jr))) - ["Oke "] - ["Fail: not all input is consumed! ":snd jr]) - ["Fail: Wrong result ":write (fst jr) []]) - ["Fail: read result is Nothing "] - , ["write produces ": s] - ) - where - s = write a ["\n"] - r = read s - jr = fromJust r +module serialize2start + +/* + Definition for assignment 2 in AFP 2017 + Pieter Koopman pieter@cs.ru.nl + September 2017 + + Laurens Kuiper (s4467299) + Camil Staps (s4498062) +*/ + +import StdEnv, StdMaybe + +/** + * Review questions + * + * 1. A type is a set of values. In the case of UNIT, UNIT = {UNIT}. The set of + * possible arguments to == on a type T is {(x,y) | x <- T, y <- T}, so in the + * case of UNIT we have {(UNIT,UNIT)}. Hence, this alternative matches always. + * The other suggestions are equivalent, as the pattern match is because of + * this meaningless and therefore all alternatives in the question are + * equivalent. + * + * 2. The name of the constructor is redundant information, since the same + * information can also be derived (compile-time only, hence it has to be + * stored) from the LEFT/RIGHT-path through the ADT tree. Hence, checking on + * the constructor name is not needed. + * + * 3. + * - [] = LEFT (CONS "_Nil" UNIT) + * - Leaf = LEFT (CONS "Leaf" UNIT) + * == has type a a -> Bool, so we cannot apply it to Leaf and [], which are not + * of the same type. So no, this does not yield True (it does not yield + * anything, as you won't be able to compile it). + */ + +/** + * The number of elements in an expression that will be placed on the outer + * level w.r.t. parentheses when pretty-printing. + * + * For instance: + * - "37" -> 1 + * - "_Nil" -> 1 + * - "_Cons 1 _Nil" -> 3 + * - "(_Cons 1 _Nil)" -> 1 + */ +class outerElems a +where + outerElems :: a -> Int + + /** + * An expression needs parentheses when it has more than one element on the + * outer level. + */ + needsParens x :== outerElems x > 1 + +/** + * In the default case, parentheses are placed around the whole expression, so + * the number of elements on the outer level is 1. + */ +instance outerElems a where outerElems _ = 1 + +//* UNITs are not printed. +instance outerElems UNIT where outerElems _ = 0 + +//* The arguments and the constructor +instance outerElems (CONS a) | outerElems a +where outerElems (CONS _ x) = 1 + outerElems x + +//* Both elements appear on the outer level +instance outerElems (PAIR a b) | outerElems a & outerElems b +where outerElems (PAIR x y) = outerElems x + outerElems y + +instance outerElems (EITHER a b) | outerElems a & outerElems b +where + outerElems (LEFT x) = outerElems x + outerElems (RIGHT x) = outerElems x + +/** + * We extended the definition with a restriction on outerElems. This extra + * restriction is OK, since there is an instance of outerElems for every type + * (and hence, this restriction does not exclude any type). + */ +class serialize a | outerElems a +where + write :: a [String] -> [String] + read :: [String] -> Maybe (a,[String]) + +instance serialize Bool where + write b c = [toString b:c] + read ["True":r] = Just (True,r) + read ["False":r] = Just (False,r) + read _ = Nothing + +instance serialize Int where + write i c = [toString i:c] + read [s:r] + # i = toInt s + | s == toString i + = Just (i,r) + = Nothing + read _ = Nothing + +// --- + +:: UNIT = UNIT +:: EITHER a b = LEFT a | RIGHT b +:: PAIR a b = PAIR a b +:: CONS a = CONS String a + +// --- + +writeP :: a [String] -> [String] | serialize a +writeP x s = if (needsParens x) ["(":write x [")":s]] (write x s) + +readP :: [String] -> Maybe (a, [String]) | serialize a +readP ["(":r] = case read r of + Just (x,[")":r]) -> Just (x,r) + _ -> read ["(":r] +readP r = case read r of + Just (x,r) -> if (needsParens x) Nothing (Just (x,r)) + _ -> Nothing + +instance serialize UNIT +where + write _ c = c + read r = Just (UNIT,r) + +instance serialize (EITHER a b) | serialize a & serialize b +where + write (LEFT x) c = write x c + write (RIGHT x) c = write x c + read r = case read r of + Just (x,r) -> Just (LEFT x, r) + Nothing -> case read r of + Just (x,r) -> Just (RIGHT x,r) + Nothing -> Nothing + // This goes wrong if the two type variables of EITHER are equal (and + // hence read for LEFT is the same as read for RIGHT: we will always + // return a LEFT. Therefore, given a type + // + // :: T = C1 Int | C2 Int + // + // it is not possible to write and read C2 (C1 will be read, since LEFT + // has precedence). Like the example given as the answer to the + // reflection questin below, we don't think this to be fixable in the + // current setup. + +instance serialize (PAIR a b) | serialize a & serialize b +where + write (PAIR x y) c = writeP x [" ":writeP y c] + read r = case readP r of + Just (x,[" ":r]) -> case readP r of + Nothing -> Nothing + Just (y,r) -> Just (PAIR x y, r) + _ -> Nothing + +instance serialize (CONS a) | serialize a +where + write e=:(CONS s x) c + | needsParens e = ["(":s:" ":write x [")":c]] + | otherwise = [s:c] + read ["(":s:" ":r] = case read r of + Just (x,[")":r]) -> Just (CONS s x,r) + _ -> Nothing + read [s:r] = case read r of + Just (x,r) -> let e = CONS s x in if (needsParens e) Nothing (Just (e,r)) + Nothing -> Nothing + read _ = Nothing + +:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) + +fromList :: [a] -> ListG a +fromList [] = LEFT (CONS "_Nil" UNIT) +fromList [x:xs] = RIGHT (CONS "_Cons" (PAIR x xs)) + +toList :: (ListG a) -> [a] +toList (LEFT _) = [] +toList (RIGHT (CONS _ (PAIR x xs))) = [x:xs] + +instance serialize [a] | serialize a +where + write l c = write (fromList l) c + read l = case read l of + Just (g,r) -> Just (toList g,r) + Nothing -> Nothing + +:: Bin a = Leaf | Bin (Bin a) a (Bin a) +:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) + +fromBin :: (Bin a) -> BinG a +fromBin Leaf = LEFT (CONS "Leaf" UNIT) +fromBin (Bin l x r) = RIGHT (CONS "Bin" (PAIR l (PAIR x r))) + +toBin :: (BinG a) -> Bin a +toBin (LEFT _) = Leaf +toBin (RIGHT (CONS _ (PAIR l (PAIR x r)))) = Bin l x r + +instance serialize (Bin a) | serialize a +where + write a c = write (fromBin a) c + read l = case read l of + Just (g,r) -> Just (toBin g,r) + Nothing -> Nothing + +instance == (Bin a) | == a where // better use the generic approach + (==) Leaf Leaf = True + (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s + (==) _ _ = False + +// --- + +/** + * Reflection: + * The following is parsed as Just ([], []), which shows that the fact that + * there is no check on the name of the constructor can be exploited. + * + * In the actual Clean implementation, there is the construct `CONS of d` where + * d :: GenericConsDescriptor. This way, the name, arity, etc. of the + * constructor are available as part of the CONS type (even though this type + * does not explicitly contain the information). It is essentially a very + * restricted form of dependent typing, which makes it possible to distinguish + * the _Nil-CONS and the _Cons-CONS at compile-time. + * + * This requires the `CONS of d` construct, so I don't think this exploit is + * fixable in the current setup. It would of course be possible to redefine + * toList and toBin to result in a Maybe and check on the constructor there. + */ +Start :: Maybe ([Int], [String]) +Start = read ["_Cons"] + +Start = + [ test True + , test False + , test 0 + , test 123 + , test -36 + , test [42] + , test [0..4] + , test [[True],[]] + , test (Bin Leaf True Leaf) + , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] + , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] + ] + +test :: a -> ([String],[String]) | serialize, == a +test a = + (if (isJust r) + (if (fst jr == a) + (if (isEmpty (tl (snd jr))) + ["Oke "] + ["Fail: not all input is consumed! ":snd jr]) + ["Fail: Wrong result ":write (fst jr) []]) + ["Fail: read result is Nothing "] + , ["write produces ": s] + ) + where + s = write a ["\n"] + r = read s + jr = fromJust r diff --git a/assignment-3/genericMap.icl b/assignment-3/genericMap.icl index 6ea1bf4..f2d99e2 100644 --- a/assignment-3/genericMap.icl +++ b/assignment-3/genericMap.icl @@ -1,37 +1,37 @@ -module genericMap - -import StdEnv -import StdGeneric -import GenEq - -generic gMap a b :: a -> b -gMap{|Int|} x = x -gMap{|Real|} x = x -gMap{|UNIT|} x = x -gMap{|PAIR|} f g (PAIR x y) = PAIR (f x) (g y) -gMap{|EITHER|} f g (LEFT x) = LEFT (f x) -gMap{|EITHER|} f g (RIGHT x) = RIGHT (g x) -gMap{|CONS|} f (CONS x) = CONS (f x) -gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x) - -:: Bin a = Leaf | Bin (Bin a) a (Bin a) - -derive gMap [], (,), Bin - -t = Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 4 Leaf) -l = [1..7] - -// Part 1 -Start = gMap{|*->*|} fac t - // (Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 5 Leaf)) -Start = gMap{|*->*|} (\i -> (i, fac i)) l - // [(1,1),(2,2),(3,3),(4,5),(5,8),(6,13),(7,21)] -Start = gMap{|*->*->*|} (gMap{|*->*|} fac) (gMap{|*->*|} fac) (l,t) - // ([1,2,3,5,8,13,21],(Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 5 Leaf))) - -// Part 2 -Start = gEq{|*|} [1,2] [1,2] // True -Start = gEq{|*|} [1,2] [2,3] // False -Start = gEq{|*->*|} (\a b -> not (a < b || b < a)) [1,2] [2,3] // False - -fac n = let fs = [1:1:[(fs!!(i-1)) + (fs!!(i-2)) \\ i <- [2..]]] in fs !! n +module genericMap + +import StdEnv +import StdGeneric +import GenEq + +generic gMap a b :: a -> b +gMap{|Int|} x = x +gMap{|Real|} x = x +gMap{|UNIT|} x = x +gMap{|PAIR|} f g (PAIR x y) = PAIR (f x) (g y) +gMap{|EITHER|} f g (LEFT x) = LEFT (f x) +gMap{|EITHER|} f g (RIGHT x) = RIGHT (g x) +gMap{|CONS|} f (CONS x) = CONS (f x) +gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x) + +:: Bin a = Leaf | Bin (Bin a) a (Bin a) + +derive gMap [], (,), Bin + +t = Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 4 Leaf) +l = [1..7] + +// Part 1 +Start = gMap{|*->*|} fac t + // (Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 5 Leaf)) +Start = gMap{|*->*|} (\i -> (i, fac i)) l + // [(1,1),(2,2),(3,3),(4,5),(5,8),(6,13),(7,21)] +Start = gMap{|*->*->*|} (gMap{|*->*|} fac) (gMap{|*->*|} fac) (l,t) + // ([1,2,3,5,8,13,21],(Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 5 Leaf))) + +// Part 2 +Start = gEq{|*|} [1,2] [1,2] // True +Start = gEq{|*|} [1,2] [2,3] // False +Start = gEq{|*->*|} (\a b -> not (a < b || b < a)) [1,2] [2,3] // False + +fac n = let fs = [1:1:[(fs!!(i-1)) + (fs!!(i-2)) \\ i <- [2..]]] in fs !! n diff --git a/assignment-3/serialize3Start.icl b/assignment-3/serialize3Start.icl index 962716a..73f7df4 100644 --- a/assignment-3/serialize3Start.icl +++ b/assignment-3/serialize3Start.icl @@ -1,263 +1,263 @@ -module serialize3Start - -/* - Definitions for assignment 3 in AFP 2017 - Kind indexed gennerics - Pieter Koopman, pieter@cs.ru.nl - September 2017 - - use environment: StdMaybe from Libraries/StdLib -*/ - -import StdEnv, StdMaybe - -:: Write a :== a [String] -> [String] -:: Read a :== [String] -> Maybe (a,[String]) - -// use this as serialize0 for kind * -class serialize a -where - write :: a [String] -> [String] - read :: [String] -> Maybe (a,[String]) - -class serialize1 t -where - write1 :: (Write a) (t a) [String] -> [String] - read1 :: (Read a) [String] -> Maybe (t a, [String]) - -class serialize2 t -where - write2 :: (Write a) (Write b) (t a b) [String] -> [String] - read2 :: (Read a) (Read b) [String] -> Maybe (t a b, [String]) - -// --- - -instance serialize Bool where - write b c = [toString b:c] - read ["True":r] = Just (True,r) - read ["False":r] = Just (False,r) - read _ = Nothing - -instance serialize Int where - write i c = [toString i:c] - read [s:r] - # i = toInt s - | s == toString i - = Just (i,r) - = Nothing - read _ = Nothing - -// --- - -:: UNIT = UNIT -:: EITHER a b = LEFT a | RIGHT b -:: PAIR a b = PAIR a b -:: CONS a = CONS String a - -instance serialize UNIT -where - write UNIT s = s - read l = Just (UNIT, l) - -instance serialize2 EITHER -where - write2 f _ (LEFT x) s = f x s - write2 _ g (RIGHT x) s = g x s - read2 f g s = case f s of - Just (x,s) -> Just (LEFT x,s) - Nothing -> case g s of - Just (x,s) -> Just (RIGHT x,s) - Nothing -> Nothing - -instance serialize2 PAIR -where - write2 f g (PAIR x y) s = f x [" ":g y s] - read2 f g s = case f s of - Just (x,[" ":s]) -> case g s of - Just (y,s) -> Just (PAIR x y,s) - Nothing -> Nothing - _ -> Nothing - -instance serialize1 CONS -where - write1 f (CONS c x) s = cleanup ["(":c:" ":f x [")":s]] - where - // Remove redundant parentheses - cleanup :: [String] -> [String] - cleanup ["(":c:" ":")":s] = [c:s] - cleanup s = s - read1 _ _ = abort "Use read1Cons instead\n" - -/** - * Special read1 variant which checks for a constructor name. - * @param The constructor name to match - * @param The read function for the constructor argument - * @param The stream - * @result The parsed constructor and the rest of the stream, if successful - */ -read1Cons :: String (Read a) [String] -> Maybe (CONS a, [String]) -read1Cons n f ["(":c:" ":s] -| c == n = case f s of - Just (x,[")":s]) -> Just (CONS c x,s) - _ -> Nothing -| otherwise = Nothing -// Special case for constructors without parentheses. After reading the -// argument, we continue with the original stream, because cleanup only removes -// parentheses for constructors where the write of the argument did not write -// anything. It is probably equivalent to continuing with the new stream (as -// the read should not read anything), but this seems safer. -read1Cons n f [c:s] -| c == n = case f s of - Just (x,_) -> Just (CONS c x,s) - Nothing -> Nothing -| otherwise = Nothing -read1Cons _ _ _ = Nothing - -// --- - -:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) - -fromList :: [a] -> ListG a -fromList [] = LEFT (CONS NilString UNIT) -fromList [a:x] = RIGHT (CONS ConsString (PAIR a x)) - -toList :: (ListG a) -> [a] -toList (LEFT (CONS NilString UNIT)) = [] -toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x] - -NilString :== "Nil" -ConsString :== "Cons" - -instance serialize [a] | serialize a -where - write xs s = write2 (write1 write) (write1 (write2 write write)) (fromList xs) s - read s = case read2 (read1Cons NilString read) (read1Cons ConsString (read2 read read)) s of - Just (xs,s) -> Just (toList xs,s) - Nothing -> Nothing - -// --- - -:: Bin a = Leaf | Bin (Bin a) a (Bin a) - -:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) - -fromBin :: (Bin a) -> BinG a -fromBin Leaf = LEFT (CONS LeafString UNIT) -fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r))) - -toBin :: (BinG a) -> Bin a -toBin (LEFT (CONS _ UNIT)) = Leaf -toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r - -LeafString :== "Leaf" -BinString :== "Bin" - -instance == (Bin a) | == a where - (==) Leaf Leaf = True - (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s - (==) _ _ = False - -instance serialize (Bin a) | serialize a where - write b s = write2 (write1 write) (write1 (write2 write (write2 write write))) (fromBin b) s - read l = case read2 (read1Cons LeafString read) (read1Cons BinString (read2 read (read2 read read))) l of - Just (b,s) -> Just (toBin b,s) - Nothing -> Nothing - -// --- - -:: Coin = Head | Tail -:: CoinG :== EITHER (CONS UNIT) (CONS UNIT) - -fromCoin :: Coin -> CoinG -fromCoin Head = LEFT (CONS "Head" UNIT) -fromCoin Tail = RIGHT (CONS "Tail" UNIT) - -toCoin :: CoinG -> Coin -toCoin (LEFT (CONS _ UNIT)) = Head -toCoin (RIGHT (CONS _ UNIT)) = Tail - -instance == Coin where - (==) Head Head = True - (==) Tail Tail = True - (==) _ _ = False - -instance serialize Coin where - write c s = write2 (write1 write) (write1 write) (fromCoin c) s - read l = case read2 (read1Cons "Head" read) (read1Cons "Tail" read) l of - Just (c,l) -> Just (toCoin c,l) - Nothing -> Nothing - -/* - Define a special purpose version for this type that writes and reads - the value (7,True) as ["(","7",",","True",")"] -*/ -instance serialize (a,b) | serialize a & serialize b where - write t c = write2 write write t c - read l = read2 read read l - -instance serialize2 (,) -where - write2 f g (x,y) s = ["(":f x [",":g y [")":s]]] - read2 f g ["(":s] = case f s of - Just (x,[",":s]) -> case g s of - Just (y,[")":s]) -> Just ((x,y), s) - _ -> Nothing - _ -> Nothing - read2 _ _ _ = Nothing - -// --- -// output looks nice if compiled with "Basic Values Only" for console in project options -Start = - [test True - ,test False - ,test 0 - ,test 123 - ,test -36 - ,test [42] - ,test [0..4] - ,test [[True],[]] - ,test [[[1]],[[2],[3,4]],[[]]] - ,test (Bin Leaf True Leaf) - ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] - ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] - ,test Head - ,test Tail - ,test (7,True) - ,test (Head,(7,[Tail])) - ,["End of the tests.\n"] - ] - -test :: a -> [String] | serialize, == a -test a = - (if (isJust r) - (if (fst jr == a) - (if (isEmpty (tl (snd jr))) - ["Oke"] - ["Not all input is consumed! ":snd jr]) - ["Wrong result: ":write (fst jr) []]) - ["read result is Nothing"] - ) ++ [", write produces: ": s] - where - s = write a ["\n"] - r = read s - jr = fromJust r - -/* -Oke, write produces: True -Oke, write produces: False -Oke, write produces: 0 -Oke, write produces: 123 -Oke, write produces: -36 -Oke, write produces: (Cons 42 Nil) -Oke, write produces: (Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) -Oke, write produces: (Cons (Cons True Nil) (Cons Nil Nil)) -Oke, write produces: (Cons (Cons (Cons 1 Nil) Nil) (Cons (Cons (Cons 2 Nil) (Cons (Cons 3 (Cons 4 Nil)) Nil)) (Cons (Cons Nil Nil) Nil))) -Oke, write produces: (Bin Leaf True Leaf) -Oke, write produces: (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf))) Nil) -Oke, write produces: (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf) (Cons 6 (Cons 7 Nil)) (Bin Leaf (Cons 8 (Cons 9 Nil)) Leaf)))) Nil) -Oke, write produces: Head -Oke, write produces: Tail -Oke, write produces: (7,True) -Oke, write produces: (Head,(7,(Cons Tail Nil))) -End of the tests. -*/ +module serialize3Start + +/* + Definitions for assignment 3 in AFP 2017 + Kind indexed gennerics + Pieter Koopman, pieter@cs.ru.nl + September 2017 + + use environment: StdMaybe from Libraries/StdLib +*/ + +import StdEnv, StdMaybe + +:: Write a :== a [String] -> [String] +:: Read a :== [String] -> Maybe (a,[String]) + +// use this as serialize0 for kind * +class serialize a +where + write :: a [String] -> [String] + read :: [String] -> Maybe (a,[String]) + +class serialize1 t +where + write1 :: (Write a) (t a) [String] -> [String] + read1 :: (Read a) [String] -> Maybe (t a, [String]) + +class serialize2 t +where + write2 :: (Write a) (Write b) (t a b) [String] -> [String] + read2 :: (Read a) (Read b) [String] -> Maybe (t a b, [String]) + +// --- + +instance serialize Bool where + write b c = [toString b:c] + read ["True":r] = Just (True,r) + read ["False":r] = Just (False,r) + read _ = Nothing + +instance serialize Int where + write i c = [toString i:c] + read [s:r] + # i = toInt s + | s == toString i + = Just (i,r) + = Nothing + read _ = Nothing + +// --- + +:: UNIT = UNIT +:: EITHER a b = LEFT a | RIGHT b +:: PAIR a b = PAIR a b +:: CONS a = CONS String a + +instance serialize UNIT +where + write UNIT s = s + read l = Just (UNIT, l) + +instance serialize2 EITHER +where + write2 f _ (LEFT x) s = f x s + write2 _ g (RIGHT x) s = g x s + read2 f g s = case f s of + Just (x,s) -> Just (LEFT x,s) + Nothing -> case g s of + Just (x,s) -> Just (RIGHT x,s) + Nothing -> Nothing + +instance serialize2 PAIR +where + write2 f g (PAIR x y) s = f x [" ":g y s] + read2 f g s = case f s of + Just (x,[" ":s]) -> case g s of + Just (y,s) -> Just (PAIR x y,s) + Nothing -> Nothing + _ -> Nothing + +instance serialize1 CONS +where + write1 f (CONS c x) s = cleanup ["(":c:" ":f x [")":s]] + where + // Remove redundant parentheses + cleanup :: [String] -> [String] + cleanup ["(":c:" ":")":s] = [c:s] + cleanup s = s + read1 _ _ = abort "Use read1Cons instead\n" + +/** + * Special read1 variant which checks for a constructor name. + * @param The constructor name to match + * @param The read function for the constructor argument + * @param The stream + * @result The parsed constructor and the rest of the stream, if successful + */ +read1Cons :: String (Read a) [String] -> Maybe (CONS a, [String]) +read1Cons n f ["(":c:" ":s] +| c == n = case f s of + Just (x,[")":s]) -> Just (CONS c x,s) + _ -> Nothing +| otherwise = Nothing +// Special case for constructors without parentheses. After reading the +// argument, we continue with the original stream, because cleanup only removes +// parentheses for constructors where the write of the argument did not write +// anything. It is probably equivalent to continuing with the new stream (as +// the read should not read anything), but this seems safer. +read1Cons n f [c:s] +| c == n = case f s of + Just (x,_) -> Just (CONS c x,s) + Nothing -> Nothing +| otherwise = Nothing +read1Cons _ _ _ = Nothing + +// --- + +:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) + +fromList :: [a] -> ListG a +fromList [] = LEFT (CONS NilString UNIT) +fromList [a:x] = RIGHT (CONS ConsString (PAIR a x)) + +toList :: (ListG a) -> [a] +toList (LEFT (CONS NilString UNIT)) = [] +toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x] + +NilString :== "Nil" +ConsString :== "Cons" + +instance serialize [a] | serialize a +where + write xs s = write2 (write1 write) (write1 (write2 write write)) (fromList xs) s + read s = case read2 (read1Cons NilString read) (read1Cons ConsString (read2 read read)) s of + Just (xs,s) -> Just (toList xs,s) + Nothing -> Nothing + +// --- + +:: Bin a = Leaf | Bin (Bin a) a (Bin a) + +:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) + +fromBin :: (Bin a) -> BinG a +fromBin Leaf = LEFT (CONS LeafString UNIT) +fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r))) + +toBin :: (BinG a) -> Bin a +toBin (LEFT (CONS _ UNIT)) = Leaf +toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r + +LeafString :== "Leaf" +BinString :== "Bin" + +instance == (Bin a) | == a where + (==) Leaf Leaf = True + (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s + (==) _ _ = False + +instance serialize (Bin a) | serialize a where + write b s = write2 (write1 write) (write1 (write2 write (write2 write write))) (fromBin b) s + read l = case read2 (read1Cons LeafString read) (read1Cons BinString (read2 read (read2 read read))) l of + Just (b,s) -> Just (toBin b,s) + Nothing -> Nothing + +// --- + +:: Coin = Head | Tail +:: CoinG :== EITHER (CONS UNIT) (CONS UNIT) + +fromCoin :: Coin -> CoinG +fromCoin Head = LEFT (CONS "Head" UNIT) +fromCoin Tail = RIGHT (CONS "Tail" UNIT) + +toCoin :: CoinG -> Coin +toCoin (LEFT (CONS _ UNIT)) = Head +toCoin (RIGHT (CONS _ UNIT)) = Tail + +instance == Coin where + (==) Head Head = True + (==) Tail Tail = True + (==) _ _ = False + +instance serialize Coin where + write c s = write2 (write1 write) (write1 write) (fromCoin c) s + read l = case read2 (read1Cons "Head" read) (read1Cons "Tail" read) l of + Just (c,l) -> Just (toCoin c,l) + Nothing -> Nothing + +/* + Define a special purpose version for this type that writes and reads + the value (7,True) as ["(","7",",","True",")"] +*/ +instance serialize (a,b) | serialize a & serialize b where + write t c = write2 write write t c + read l = read2 read read l + +instance serialize2 (,) +where + write2 f g (x,y) s = ["(":f x [",":g y [")":s]]] + read2 f g ["(":s] = case f s of + Just (x,[",":s]) -> case g s of + Just (y,[")":s]) -> Just ((x,y), s) + _ -> Nothing + _ -> Nothing + read2 _ _ _ = Nothing + +// --- +// output looks nice if compiled with "Basic Values Only" for console in project options +Start = + [test True + ,test False + ,test 0 + ,test 123 + ,test -36 + ,test [42] + ,test [0..4] + ,test [[True],[]] + ,test [[[1]],[[2],[3,4]],[[]]] + ,test (Bin Leaf True Leaf) + ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] + ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] + ,test Head + ,test Tail + ,test (7,True) + ,test (Head,(7,[Tail])) + ,["End of the tests.\n"] + ] + +test :: a -> [String] | serialize, == a +test a = + (if (isJust r) + (if (fst jr == a) + (if (isEmpty (tl (snd jr))) + ["Oke"] + ["Not all input is consumed! ":snd jr]) + ["Wrong result: ":write (fst jr) []]) + ["read result is Nothing"] + ) ++ [", write produces: ": s] + where + s = write a ["\n"] + r = read s + jr = fromJust r + +/* +Oke, write produces: True +Oke, write produces: False +Oke, write produces: 0 +Oke, write produces: 123 +Oke, write produces: -36 +Oke, write produces: (Cons 42 Nil) +Oke, write produces: (Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) +Oke, write produces: (Cons (Cons True Nil) (Cons Nil Nil)) +Oke, write produces: (Cons (Cons (Cons 1 Nil) Nil) (Cons (Cons (Cons 2 Nil) (Cons (Cons 3 (Cons 4 Nil)) Nil)) (Cons (Cons Nil Nil) Nil))) +Oke, write produces: (Bin Leaf True Leaf) +Oke, write produces: (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf))) Nil) +Oke, write produces: (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf) (Cons 6 (Cons 7 Nil)) (Bin Leaf (Cons 8 (Cons 9 Nil)) Leaf)))) Nil) +Oke, write produces: Head +Oke, write produces: Tail +Oke, write produces: (7,True) +Oke, write produces: (Head,(7,(Cons Tail Nil))) +End of the tests. +*/ diff --git a/assignment-4/monad.dcl b/assignment-4/monad.dcl index 6b0b2b5..531a191 100644 --- a/assignment-4/monad.dcl +++ b/assignment-4/monad.dcl @@ -1,35 +1,35 @@ -definition module monad - -/* - Pieter Koopman, pieter@cs.ru.nl - Advanced Programming, week 4 -*/ - -import StdMisc - -class Functor f where - fmap :: (a->b) (f a) -> (f b) - (<$>) infixl 4 :: (a->b) (f a) -> (f b) | Functor f - (<$>) f x :== fmap f x - -class Applicative f | Functor f where - pure :: a -> f a - (<*>) infixl 4 :: (f (a->b)) (f a) -> f b - -class Monad m | Applicative m where - bind :: (m a) (a->m b) -> m b - (>>=) infixl 1 :: (m a) (a->m b) -> m b | Monad m - (>>=) a f :== bind a f - (>>|) infixl 1 :: (m a) (m b) -> m b | Monad m - (>>|) a b :== a >>= \_.b - rtrn :: a -> m a | Monad m - rtrn a :== pure a - -class fail m | Applicative m where - fail :: m a - guard :: Bool -> m a | fail m - guard b :== if b (pure undef) fail - -class OrMonad m where - (<|>) infixl 0 :: (m a) (m a) -> m a - +definition module monad + +/* + Pieter Koopman, pieter@cs.ru.nl + Advanced Programming, week 4 +*/ + +import StdMisc + +class Functor f where + fmap :: (a->b) (f a) -> (f b) + (<$>) infixl 4 :: (a->b) (f a) -> (f b) | Functor f + (<$>) f x :== fmap f x + +class Applicative f | Functor f where + pure :: a -> f a + (<*>) infixl 4 :: (f (a->b)) (f a) -> f b + +class Monad m | Applicative m where + bind :: (m a) (a->m b) -> m b + (>>=) infixl 1 :: (m a) (a->m b) -> m b | Monad m + (>>=) a f :== bind a f + (>>|) infixl 1 :: (m a) (m b) -> m b | Monad m + (>>|) a b :== a >>= \_.b + rtrn :: a -> m a | Monad m + rtrn a :== pure a + +class fail m | Applicative m where + fail :: m a + guard :: Bool -> m a | fail m + guard b :== if b (pure undef) fail + +class OrMonad m where + (<|>) infixl 0 :: (m a) (m a) -> m a + diff --git a/assignment-4/monad.icl b/assignment-4/monad.icl index fb9b491..bb0a2ac 100644 --- a/assignment-4/monad.icl +++ b/assignment-4/monad.icl @@ -1,8 +1,8 @@ -implementation module monad - -/* - Pieter Koopman, pieter@cs.ru.nl - Advanced Programming, week 4 -*/ - - +implementation module monad + +/* + Pieter Koopman, pieter@cs.ru.nl + Advanced Programming, week 4 +*/ + + diff --git a/assignment-4/serialize4.icl b/assignment-4/serialize4.icl index edbcc32..9abccbc 100644 --- a/assignment-4/serialize4.icl +++ b/assignment-4/serialize4.icl @@ -1,231 +1,231 @@ -module serialize4 - -import StdEnv, StdMaybe, monad - -/* - * Pieter Koopman, pieter@cs.ru.nl - * Advanced Programming, week 4, 2017 - * - * import StdMaybe from Libraries/StdLib - * use StdEnv or StdEnv 64 - * use Basic Values Only as conclose option for a nicer output. - */ - -// --- - -:: State s a = S (s -> (Maybe a,s)) - -unS :: (State s a) -> s -> (Maybe a,s) -unS (S f) = f - -instance Functor (State s) where - fmap f s = fail -instance Applicative (State s) where - pure a = fail - (<*>) f x = fail -instance fail (State s) where - fail = S \s.(Nothing,s) -instance Monad (State s) where - bind a f = fail -instance OrMonad (State s) where - (<|>) f g = fail - -// --- - -:: Serialized = Serialized - -ser :: Serialized -ser = Serialized - -toStrings :: Serialized -> [String] -toStrings _ = ["to be done\n"] - -:: Serialize a :== State Serialized a - -wrt :: a -> Serialize String | toString a -wrt a = fail - -rd :: Serialize String -rd = fail - -match :: a -> Serialize a | toString a -match a = fail - -pred :: (String->Bool) -> Serialize String -pred f = fail - -// --- - -:: UNIT = UNIT -:: EITHER a b = LEFT a | RIGHT b -:: PAIR a b = PAIR a b -:: CONS a = CONS String a - -:: Write a :== a -> Serialize String -:: Read a :== Serialize a - -class serialize a | isUNIT a where - write :: a -> Serialize String - read :: Serialize a - -class serialize1 t where - write1 :: (Write a) (t a) -> Serialize String - read1 :: (Read a) -> Serialize (t a) - -class serializeCONS a where - writeCons :: (Write a) (CONS a) -> Serialize String - readCons :: String (Read a) -> Serialize (CONS a) - -class serialize2 t where - write2 :: (Write a) (Write b) (t a b) -> Serialize String - read2 :: (Read a) (Read b) -> Serialize (t a b) - -class isUNIT a :: a -> Bool -instance isUNIT UNIT where isUNIT _ = True -instance isUNIT a where isUNIT _ = False - -instance serialize Bool where - write b = fail - read = fail - -instance serialize Int where - write i = fail - read = fail - -instance serialize String where - write s = wrt s - read = fail - -instance serialize UNIT where - write _ = fail - read = fail - -instance serializeCONS UNIT where - writeCons wa (CONS name a) = fail - readCons name ra = fail - -instance serializeCONS a where - writeCons wa (CONS name a) = fail - readCons name ra =fail - -instance serialize2 EITHER where - write2 wa wb (LEFT a) = fail - write2 wa wb (RIGHT b) = fail - read2 ra rb = fail - -instance serialize2 PAIR where - write2 wa wb (PAIR a b) = fail - read2 ra rb = fail - -// --- - -:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) - -fromList :: [a] -> ListG a -fromList [] = LEFT (CONS NilString UNIT) -fromList [a:x] = RIGHT (CONS ConsString (PAIR a x)) - -toList :: (ListG a) -> [a] -toList (LEFT (CONS NilString UNIT)) = [] -toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x] - -NilString :== "Nil" -ConsString :== "Cons" - -instance serialize [a] | serialize a where - write a = write1 write a - read = read1 read - -instance serialize1 [] where - write1 writea l = fail - read1 reada = fail -// --- - -:: Bin a = Leaf | Bin (Bin a) a (Bin a) - -:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) - -fromBin :: (Bin a) -> BinG a -fromBin Leaf = LEFT (CONS LeafString UNIT) -fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r))) - -toBin :: (BinG a) -> Bin a -toBin (LEFT (CONS _ UNIT)) = Leaf -toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r - -LeafString :== "Leaf" -BinString :== "Bin" - -instance == (Bin a) | == a where - (==) Leaf Leaf = True - (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s - (==) _ _ = False - -instance serialize (Bin a) | serialize a where - write b = fail - read = fail - -instance serialize1 Bin where - write1 writea b = fail - read1 reada = fail -// --- - -:: Coin = Head | Tail -:: CoinG :== EITHER (CONS UNIT) (CONS UNIT) - -fromCoin :: Coin -> CoinG -fromCoin Head = LEFT (CONS "Head" UNIT) -fromCoin Tail = RIGHT (CONS "Tail" UNIT) - -toCoin :: CoinG -> Coin -toCoin (LEFT (CONS _ UNIT)) = Head -toCoin (RIGHT (CONS _ UNIT)) = Tail - -instance == Coin where - (==) Head Head = True - (==) Tail Tail = True - (==) _ _ = False - -instance serialize Coin where - write c = fail - read = fail - -// --- - -instance serialize (a,b) | serialize a & serialize b where - write (a,b) = fail - read = fail - -// --- - -Start = - [ test True - , test False - , test 0 - , test 123 - , test -36 - , test Head - , test Tail - , test [42] - , test [0..4] - , test [[True],[]] - , test [[[1]],[[2],[3,4]],[[]]] - , test [[True],[]] - , test (Bin Leaf True Leaf) - , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] - , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] - , test Head - , test Tail - , test (7,True) - , test (Head,(7,[Tail])) - , ["End of the tests.\n"] - ] - -test :: a -> [String] | serialize, == a -test a = toStrings (snd ((unS t) ser)) -where - t = write a - >>| read - >>= \b. guard (a == b) - >>| write "Oke " - <|> write "Failure " +module serialize4 + +import StdEnv, StdMaybe, monad + +/* + * Pieter Koopman, pieter@cs.ru.nl + * Advanced Programming, week 4, 2017 + * + * import StdMaybe from Libraries/StdLib + * use StdEnv or StdEnv 64 + * use Basic Values Only as conclose option for a nicer output. + */ + +// --- + +:: State s a = S (s -> (Maybe a,s)) + +unS :: (State s a) -> s -> (Maybe a,s) +unS (S f) = f + +instance Functor (State s) where + fmap f s = fail +instance Applicative (State s) where + pure a = fail + (<*>) f x = fail +instance fail (State s) where + fail = S \s.(Nothing,s) +instance Monad (State s) where + bind a f = fail +instance OrMonad (State s) where + (<|>) f g = fail + +// --- + +:: Serialized = Serialized + +ser :: Serialized +ser = Serialized + +toStrings :: Serialized -> [String] +toStrings _ = ["to be done\n"] + +:: Serialize a :== State Serialized a + +wrt :: a -> Serialize String | toString a +wrt a = fail + +rd :: Serialize String +rd = fail + +match :: a -> Serialize a | toString a +match a = fail + +pred :: (String->Bool) -> Serialize String +pred f = fail + +// --- + +:: UNIT = UNIT +:: EITHER a b = LEFT a | RIGHT b +:: PAIR a b = PAIR a b +:: CONS a = CONS String a + +:: Write a :== a -> Serialize String +:: Read a :== Serialize a + +class serialize a | isUNIT a where + write :: a -> Serialize String + read :: Serialize a + +class serialize1 t where + write1 :: (Write a) (t a) -> Serialize String + read1 :: (Read a) -> Serialize (t a) + +class serializeCONS a where + writeCons :: (Write a) (CONS a) -> Serialize String + readCons :: String (Read a) -> Serialize (CONS a) + +class serialize2 t where + write2 :: (Write a) (Write b) (t a b) -> Serialize String + read2 :: (Read a) (Read b) -> Serialize (t a b) + +class isUNIT a :: a -> Bool +instance isUNIT UNIT where isUNIT _ = True +instance isUNIT a where isUNIT _ = False + +instance serialize Bool where + write b = fail + read = fail + +instance serialize Int where + write i = fail + read = fail + +instance serialize String where + write s = wrt s + read = fail + +instance serialize UNIT where + write _ = fail + read = fail + +instance serializeCONS UNIT where + writeCons wa (CONS name a) = fail + readCons name ra = fail + +instance serializeCONS a where + writeCons wa (CONS name a) = fail + readCons name ra =fail + +instance serialize2 EITHER where + write2 wa wb (LEFT a) = fail + write2 wa wb (RIGHT b) = fail + read2 ra rb = fail + +instance serialize2 PAIR where + write2 wa wb (PAIR a b) = fail + read2 ra rb = fail + +// --- + +:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) + +fromList :: [a] -> ListG a +fromList [] = LEFT (CONS NilString UNIT) +fromList [a:x] = RIGHT (CONS ConsString (PAIR a x)) + +toList :: (ListG a) -> [a] +toList (LEFT (CONS NilString UNIT)) = [] +toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x] + +NilString :== "Nil" +ConsString :== "Cons" + +instance serialize [a] | serialize a where + write a = write1 write a + read = read1 read + +instance serialize1 [] where + write1 writea l = fail + read1 reada = fail +// --- + +:: Bin a = Leaf | Bin (Bin a) a (Bin a) + +:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a)))) + +fromBin :: (Bin a) -> BinG a +fromBin Leaf = LEFT (CONS LeafString UNIT) +fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r))) + +toBin :: (BinG a) -> Bin a +toBin (LEFT (CONS _ UNIT)) = Leaf +toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r + +LeafString :== "Leaf" +BinString :== "Bin" + +instance == (Bin a) | == a where + (==) Leaf Leaf = True + (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s + (==) _ _ = False + +instance serialize (Bin a) | serialize a where + write b = fail + read = fail + +instance serialize1 Bin where + write1 writea b = fail + read1 reada = fail +// --- + +:: Coin = Head | Tail +:: CoinG :== EITHER (CONS UNIT) (CONS UNIT) + +fromCoin :: Coin -> CoinG +fromCoin Head = LEFT (CONS "Head" UNIT) +fromCoin Tail = RIGHT (CONS "Tail" UNIT) + +toCoin :: CoinG -> Coin +toCoin (LEFT (CONS _ UNIT)) = Head +toCoin (RIGHT (CONS _ UNIT)) = Tail + +instance == Coin where + (==) Head Head = True + (==) Tail Tail = True + (==) _ _ = False + +instance serialize Coin where + write c = fail + read = fail + +// --- + +instance serialize (a,b) | serialize a & serialize b where + write (a,b) = fail + read = fail + +// --- + +Start = + [ test True + , test False + , test 0 + , test 123 + , test -36 + , test Head + , test Tail + , test [42] + , test [0..4] + , test [[True],[]] + , test [[[1]],[[2],[3,4]],[[]]] + , test [[True],[]] + , test (Bin Leaf True Leaf) + , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))] + , test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))] + , test Head + , test Tail + , test (7,True) + , test (Head,(7,[Tail])) + , ["End of the tests.\n"] + ] + +test :: a -> [String] | serialize, == a +test a = toStrings (snd ((unS t) ser)) +where + t = write a + >>| read + >>= \b. guard (a == b) + >>| write "Oke " + <|> write "Failure " diff --git a/assignment-4/student.icl b/assignment-4/student.icl index 0356a04..96c01e0 100644 --- a/assignment-4/student.icl +++ b/assignment-4/student.icl @@ -1,153 +1,171 @@ -module student - -import StdEnv, StdMaybe, monad -/* - * Pieter Koopman, pieter@cs.ru.nl - * Advanced Programming, week 4 - */ - -// ---- an IO monad with maybe results --- // - -:: *State = {w :: *World, c :: *Maybe *File} -:: IO a = IO (State -> *(Maybe a, State)) - -open :: State -> State -open {w, c=Nothing} - # (console, w) = stdio w - = {w = w, c = Just console} -open s = s - -close :: State -> State -close { w, c=Just f} = { w = snd (fclose f w), c = Nothing} -close s = s - -unIO :: (IO a) -> State -> *(Maybe a, State) -unIO (IO f) = f - -run :: (IO a) *World -> *World -run m w = (close (snd (unIO m {w=w, c=Nothing}))).w - -// ---- reading from console --- // - -class read a :: IO a - -instance read String where - read = IO r where - r s - #! {w,c=Just c} = open s - (line, c) = freadline c - s = rmNL line - | size s > 0 - = (Just s,{w = w, c = Just c}) - #! c = c <<< "String must be not empty " - (line, c) = freadline c - s = rmNL line - | size s > 0 - = (Just s, {w = w, c = Just c}) - = (Nothing, {w = w, c = Just c}) - -instance read Int where - read = IO r where - r s - #! {w,c=Just c} = open s - (b,i,c) = freadi c - | b - = (Just i, {w = w, c = Just c}) - #! (_, c) = freadline c - c = c <<< "An integer please " - (b,i,c) = freadi c - | b - = (Just i, {w = w, c = Just c}) - #! (_, c) = freadline c - = (Nothing, {w = w, c = Just c}) - -write :: String -> IO String -write mess = IO w where - w s - #! {w,c=Just c} = open s - = (Just mess,{w=w,c=Just (c <<< mess)}) - -// ---- make IO a monad --- // - -instance Functor IO where - fmap f (IO g) - = IO \s.case g s of - (Just a, s) = (Just (f a),s) - (Nothing,s) = (Nothing , s) - -instance Applicative IO where - pure a = IO \s.(Just a, s) - (<*>) (IO f) (IO g) = IO \s.case f s of - (Just f,s) = case g s of - (Just a,s) = (Just (f a),s) - (n, s) = (Nothing, s) - (n, s) = (Nothing, s) - -instance Monad IO where - bind (IO f) g = IO \s.case f s of - (Just a, s) = unIO (g a) s - (n, s) = (Nothing, s) - -instance fail IO where fail = IO \s.(Nothing,s) - -instance OrMonad IO where - <|> (IO f) (IO g) = - IO \s.case f s of - (Nothing, s) = g s - other = other - -// ---- reading a student record --- // - -Start w = run f2 w - -:: Student = - { fname :: String - , lname :: String - , snum :: Int - } - -instance toString Student where - toString {fname,lname,snum} = "{Student|fname=" + fname + ",lname=" + lname + ",snum=" + toString snum + "}" -instance + String where + s t = s +++ t - -f0 :: *World -> (Student, *World) -f0 world = ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world2) where - (console1, world1) = stdio world - console2 = console1 <<< "Your first name please: " - (fname,console3) = freadline console2 - console4 = console3 <<< "Your last name please: " - (lname,console5) = freadline console4 - console6 = console5 <<< "Your student nmber please: " - (b1,snum,console7) = freadi console6 - (b2, world2) = fclose console7 world1 - -f1 :: *World -> (Student, *World) -f1 world -#! (console, world) = stdio world - console = console <<< "Your first name please: " - (fname,console) = freadline console - console = console <<< "Your last name please: " - (lname,console) = freadline console - console = console <<< "Your student nmber please: " - (b1,snum,console) = freadi console - (b2, world) = fclose console world -= ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world) - -f2 :: IO String -f2 - = ( write "Your first name please: " - >>| read - >>= \fname.write "Your last name please: " - >>| read - >>= \lname.write "Your student nmber please: " - >>| read - >>= \snum. rtrn {fname = rmNL fname, lname = rmNL lname, snum = snum} - >>= write o toString) - <|> write "failed to read a student" - -rmNL :: String -> String -rmNL string - # len = size string - | len > 0 && string.[len-1] == '\n' - = string % (0, len - 2) - = string +module student + +import StdEnv, StdMaybe, monad +/* + * Pieter Koopman, pieter@cs.ru.nl + * Advanced Programming, week 4 + */ + +// ---- an IO monad with maybe results --- // + +:: *State = {w :: *World, c :: *Maybe *File} +:: IO a = IO (State -> *(Maybe a, State)) + +open :: State -> State +open {w, c=Nothing} + # (console, w) = stdio w + = {w = w, c = Just console} +open s = s + +close :: State -> State +close { w, c=Just f} = { w = snd (fclose f w), c = Nothing} +close s = s + +unIO :: (IO a) -> State -> *(Maybe a, State) +unIO (IO f) = f + +run :: (IO a) *World -> *World +run m w = (close (snd (unIO m {w=w, c=Nothing}))).w + +// ---- reading from console --- // + +class read a :: IO a + +instance read String where + read = IO r where + r s + #! {w,c=Just c} = open s + (line, c) = freadline c + s = rmNL line + | size s > 0 + = (Just s,{w = w, c = Just c}) + #! c = c <<< "String must be not empty " + (line, c) = freadline c + s = rmNL line + | size s > 0 + = (Just s, {w = w, c = Just c}) + = (Nothing, {w = w, c = Just c}) + +instance read Int where + read = IO r where + r s + #! {w,c=Just c} = open s + (b,i,c) = freadi c + | b + = (Just i, {w = w, c = Just c}) + #! (_, c) = freadline c + c = c <<< "An integer please " + (b,i,c) = freadi c + | b + = (Just i, {w = w, c = Just c}) + #! (_, c) = freadline c + = (Nothing, {w = w, c = Just c}) + +write :: String -> IO String +write mess = IO w where + w s + #! {w,c=Just c} = open s + = (Just mess,{w=w,c=Just (c <<< mess)}) + +// ---- make IO a monad --- // + +instance Functor IO where + fmap f (IO g) + = IO \s.case g s of + (Just a, s) = (Just (f a),s) + (Nothing,s) = (Nothing , s) + +instance Applicative IO where + pure a = IO \s.(Just a, s) + (<*>) (IO f) (IO g) = IO \s.case f s of + (Just f,s) = case g s of + (Just a,s) = (Just (f a),s) + (n, s) = (Nothing, s) + (n, s) = (Nothing, s) + +instance Monad IO where + bind (IO f) g = IO \s.case f s of + (Just a, s) = unIO (g a) s + (n, s) = (Nothing, s) + +instance fail IO where fail = IO \s.(Nothing,s) + +instance OrMonad IO where + <|> (IO f) (IO g) = + IO \s.case f s of + (Nothing, s) = g s + other = other + +// ---- reading a student record --- // + +Start w = run (f3 >>= write) w + +:: Student = + { fname :: String + , lname :: String + , snum :: Int + } + +instance toString Student where + toString {fname,lname,snum} = "{Student|fname=" + fname + ",lname=" + lname + ",snum=" + toString snum + "}" +instance + String where + s t = s +++ t + +f0 :: *World -> (Student, *World) +f0 world = ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world2) where + (console1, world1) = stdio world + console2 = console1 <<< "Your first name please: " + (fname,console3) = freadline console2 + console4 = console3 <<< "Your last name please: " + (lname,console5) = freadline console4 + console6 = console5 <<< "Your student nmber please: " + (b1,snum,console7) = freadi console6 + (b2, world2) = fclose console7 world1 + +f1 :: *World -> (Student, *World) +f1 world +#! (console, world) = stdio world + console = console <<< "Your first name please: " + (fname,console) = freadline console + console = console <<< "Your last name please: " + (lname,console) = freadline console + console = console <<< "Your student nmber please: " + (b1,snum,console) = freadi console + (b2, world) = fclose console world += ({fname = rmNL fname, lname = rmNL lname, snum = snum}, world) + +f2 :: IO String +f2 + = ( write "Your first name please: " + >>| read + >>= \fname.write "Your last name please: " + >>| read + >>= \lname.write "Your student nmber please: " + >>| read + >>= \snum. rtrn {fname = rmNL fname, lname = rmNL lname, snum = snum} + >>= write o toString) + <|> write "failed to read a student" + +f3 :: IO String +f3 = + ((\f l s -> (toString {fname=rmNL f, lname=rmNL l, snum=s}) +++ "\n") <$> + input "Your first name please: " <*> + input "Your last name please: " <*> + input "Your student number please: ") + <|> write "Failed to read a student.\n" +where + input :: String -> IO a | read a + input s = write s *> read + + // It would really be much easier if we would use Platform from the start in this course. + (*>) infixl 4 :: (f a) (f b) -> f b | Applicative f + (*>) fa fb = id <$ fa <*> fb + + (<$) infixl 4 :: a (f b) -> f a | Functor f + (<$) x fa = fmap (const x) fa + +rmNL :: String -> String +rmNL string + # len = size string + | len > 0 && string.[len-1] == '\n' + = string % (0, len - 2) + = string -- cgit v1.2.3