afp

[clean-tests.git] / afp / a2 / a2a.icl

diff --git a/afp/a2/a2a.icl b/afp/a2/a2a.icl
new file mode 100644 (file)
index 0000000..436c05d
--- /dev/null
+++ b/afp/a2/a2a.icl
@@ -0,0 +1,97 @@
+module a2a
+
+import StdEnv
+import StdMaybe
+
+class serialize a where
+       write :: a [String] -> [String]
+       read ::  [String] -> Maybe (a, [String])
+
+:: UNIT = UNIT
+:: EITHER a b = LEFT a | RIGHT b
+:: PAIR a b = PAIR a b
+:: CONS a = CONS String a
+
+:: 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 (CONS "Nil" UNIT)) = []
+toList (RIGHT (CONS "Cons" (PAIR x xs))) = [x:xs]
+
+:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))
+:: Bin a = Leaf | Bin (Bin a) a (Bin a)
+
+fromBin :: (Bin a) -> BinG a
+fromBin Leaf = LEFT (CONS "Leaf" UNIT)
+fromBin (Bin l a b) = RIGHT (CONS "Bin" (PAIR l (PAIR a b)))
+
+toBin :: (BinG a) -> Bin a
+toBin (LEFT (CONS "Leaf" UNIT)) = Leaf
+toBin (RIGHT (CONS "Bin" (PAIR l (PAIR a b)))) = Bin l a b
+
+instance serialize Int
+where
+       write i c = [toString i:c]
+       read [i:c] = Just (toInt i, c)
+       read _ = Nothing
+
+instance serialize [a] | serialize a
+where
+       write a c = write (fromList a) c
+       read c = case read c of
+               Just (l, c) = Just (toList l, c)
+               Nothing = Nothing
+
+instance serialize UNIT
+where
+       write UNIT c = c
+       read c = Just (UNIT, c)
+
+instance serialize (EITHER a b) | serialize a & serialize b
+where
+       write (LEFT a) c = write a c
+       write (RIGHT a) c = write a c
+       read c = case read c of
+               Just (a, c) = Just (LEFT a, c)
+               Nothing = case read c of
+                       Just (a, c) = Just (RIGHT a, c)
+                       Nothing = Nothing
+
+instance serialize (PAIR a b) | serialize a & serialize b
+where
+       write (PAIR a b) c = write a (write b c)
+       read c = case read c of
+               Just (a, c) = case read c of
+                       Just (b, c) = Just (PAIR a b, c)
+                       Nothing = Nothing
+               Nothing = Nothing
+
+instance serialize (CONS UNIT)
+where
+       write (CONS n UNIT) c = [n:c]
+       read [n:c] = Just (CONS n a, c)
+       read _ = Nothing
+
+instance serialize (CONS a) | serialize a
+where
+       write (CONS n a) c
+               | write a [] == [] = [n:c]
+               = ["(",n:write a [")":c]]
+       read ["(",n:c] = case read c of
+               Just (a, [")":c]) = Just (CONS n a, c)
+               _ = Nothing
+       read [n:c] = case read c of
+               Just (a, c) = Just (CONS n a, c)
+               Nothing = Nothing
+       read _ = Nothing
+
+Start :: (Maybe ([[Int]], [String]), [String])
+Start = (read (write (fromList what) []), write (fromList what) [])
+where
+       what :: [[Int]]
+       what = [[1,2],[1,2,3]]
+