summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--assignment-2/serialize2start.icl520
-rw-r--r--assignment-3/genericMap.icl74
-rw-r--r--assignment-3/serialize3Start.icl526
-rw-r--r--assignment-4/monad.dcl70
-rw-r--r--assignment-4/monad.icl16
-rw-r--r--assignment-4/serialize4.icl462
-rw-r--r--assignment-4/student.icl324
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-16 23:49:55 +0000