+module skeleton3a\r
+\r
+/*\r
+ Advanced Programming.\r
+ Skeleton for exercise 3.1 and 3.2.\r
+ To be used in a project with the environment Everything, \r
+ or StdEnv with an import of StdMaybe from StdLib\r
+\r
+ Pieter Koopman, pieter@cs.ru.nl\r
+*/\r
+\r
+import StdEnv, StdMaybe\r
+\r
+/************* showing *******************/\r
+\r
+class show_0 t where show_0 :: t [String] -> [String]\r
+class show_1 t where show_1 :: (a [String] -> [String]) (t a) [String] -> [String]\r
+class show_2 t where show_2 :: (a [String] -> [String]) (b [String] -> [String]) (t a b) [String] -> [String]\r
+\r
+instance show_0 Int where show_0 i c = [IntTag :toString i:c]\r
+instance show_0 Bool where show_0 b c = [BoolTag:toString b:c]\r
+\r
+instance show_0 UNIT where show_0 unit c = [UNITTag:c]\r
+instance show_1 CONS where\r
+ show_1 f (CONS s x) c = [CONSTag,s:f x c]\r
+instance show_2 PAIR where\r
+ show_2 f1 f2 (PAIR x1 x2) c = [PAIRTag:f1 x1 (f2 x2 c)]\r
+instance show_2 EITHER where\r
+ show_2 f1 f2 (LEFT x1) c = [LEFTTag:f1 x1 c]\r
+ show_2 f1 f2 (RIGHT x2) c = [RIGHTTag:f2 x2 c]\r
+\r
+instance show_0 Color where\r
+ show_0 x c = show_2 (show_2 (show_1 show_0) (show_1 show_0)) (show_1 show_0) (fromColor x) c\r
+\r
+instance show_1 Tree where\r
+ show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_2 (show_1 f) (show_1 f)))) (fromTree x) c\r
+instance show_0 (Tree a) | show_0 a where\r
+ show_0 x c = show_1 show_0 x c\r
+\r
+instance show_1 [] where\r
+ show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_1 f))) (fromList x) c\r
+instance show_0 [a] | show_0 a where\r
+ show_0 x c = show_1 show_0 x c\r
+\r
+instance show_0 (a, b) | show_0 a & show_0 b where\r
+ show_0 x c = show_1 (show_2 show_0 show_0) (fromTup x) c\r
+\r
+instance show_0 T where\r
+ show_0 x c = show_1 show_0 (fromT x) c\r
+\r
+IntTag :== "Int"\r
+BoolTag :== "Bool"\r
+UNITTag :== "UNIT"\r
+PAIRTag :== "PAIR"\r
+LEFTTag :== "LEFT"\r
+RIGHTTag :== "RIGHT"\r
+CONSTag :== "CONS"\r
+\r
+show :: a -> [String] | show_0 a\r
+show a = show_0 a []\r
+\r
+/**************** parsing *************************/\r
+\r
+:: Result a :== Maybe (a,[String])\r
+\r
+class parse0 t :: [String] -> Result t\r
+class parse1 t :: ([String] -> Result a) [String] -> Result (t a)\r
+class parse2 t :: ([String] -> Result a) ([String] -> Result b) [String] -> Result (t a b)\r
+\r
+instance parse0 Int where\r
+ parse0 [IntTag,i:r] = Just (toInt i, r)\r
+ parse0 r = Nothing\r
+\r
+instance parse0 Bool where\r
+ parse0 [BoolTag,b:r] = Just (b == "True", r)\r
+ parse0 r = Nothing\r
+\r
+instance parse0 UNIT where\r
+ parse0 [UNITTag:r] = Just (UNIT, r)\r
+ parse0 r = Nothing\r
+\r
+instance parse1 CONS where\r
+ parse1 f [CONSTag,s:r] = case f r of\r
+ Just (x, r) = Just (CONS s x, r)\r
+ _ = Nothing\r
+ parse1 _ _ = Nothing\r
+\r
+instance parse2 PAIR where\r
+ parse2 f1 f2 [PAIRTag:r] = case f1 r of\r
+ Just (x1, r) = case f2 r of\r
+ Just (x2, r) = Just (PAIR x1 x2, r)\r
+ _ = Nothing\r
+ _ = Nothing\r
+ parse2 _ _ _ = Nothing \r
+\r
+instance parse2 EITHER where\r
+ parse2 f1 f2 [LEFTTag:r] = case f1 r of\r
+ Just (x, r) = Just (LEFT x, r)\r
+ _ = Nothing\r
+ parse2 f1 f2 [RIGHTTag:r] = case f2 r of\r
+ Just (x, r) = Just (RIGHT x, r)\r
+ _ = Nothing\r
+\r
+instance parse0 Color where\r
+ parse0 r = case parse2 (parse2 (parse1 parse0) (parse1 parse0)) (parse1 parse0) r of\r
+ Just (x, r) = Just (toColor x, r)\r
+ _ = Nothing\r
+\r
+instance parse1 Tree where\r
+ parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse2 (parse1 f) (parse1 f)))) r of\r
+ Just (x, r) = Just (toTree x, r)\r
+ _ = Nothing\r
+instance parse0 (Tree a) | parse0 a where\r
+ parse0 r = parse1 parse0 r\r
+\r
+instance parse1 [] where\r
+ parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse1 f))) r of\r
+ Just (x, r) = Just (toList x, r)\r
+ _ = Nothing\r
+instance parse0 [a] | parse0 a where\r
+ parse0 r = parse1 parse0 r\r
+\r
+instance parse0 (a, b) | parse0 a & parse0 b where\r
+ parse0 r = case parse1 (parse2 parse0 parse0) r of\r
+ Just (x, r) = Just (toTup x, r)\r
+ _ = Nothing\r
+\r
+instance parse0 T where\r
+ parse0 r = case parse1 parse0 r of\r
+ Just (x, r) = Just (toT x, r)\r
+ _ = Nothing\r
+\r
+/**************** Example Types and conversions *************************/\r
+\r
+:: T = C\r
+:: Color = Red | Yellow | Blue\r
+:: Tree a = Tip | Bin a (Tree a) (Tree a)\r
+\r
+// Binary sums and products (in generic prelude)\r
+:: UNIT = UNIT\r
+:: PAIR a b = PAIR a b\r
+:: EITHER a b = LEFT a | RIGHT b\r
+:: CONS a = CONS String a\r
+\r
+// Generic type representations\r
+:: TG :== CONS UNIT\r
+:: ColorG :== EITHER (EITHER (CONS UNIT) (CONS UNIT)) (CONS UNIT)\r
+:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))\r
+:: TreeG a :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a))))\r
+:: TupG a b :== CONS (PAIR a b)\r
+\r
+// Conversions\r
+\r
+fromT :: T -> TG\r
+fromT c = CONS "C" UNIT\r
+\r
+fromColor :: Color -> ColorG\r
+fromColor Red = LEFT (LEFT (CONS "Red" UNIT))\r
+fromColor Yellow = LEFT (RIGHT (CONS "Yellow" UNIT))\r
+fromColor Blue = RIGHT (CONS "Blue" UNIT)\r
+\r
+fromList :: [a] -> ListG a\r
+fromList [] = LEFT(CONS "Nil" UNIT)\r
+fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as))\r
+\r
+fromTree :: (Tree a) -> TreeG a\r
+fromTree Tip = LEFT(CONS "Tip" UNIT)\r
+fromTree (Bin a l r) = RIGHT (CONS "Bin" (PAIR a (PAIR l r)))\r
+\r
+fromTup :: (a,b) -> TupG a b\r
+fromTup (a,b) = CONS "Tuple2" (PAIR a b)\r
+\r
+toT :: TG -> T\r
+toT (CONS _ UNIT) = C\r
+\r
+toColor :: ColorG -> Color\r
+toColor (LEFT (LEFT(CONS _ UNIT))) = Red\r
+toColor (LEFT (RIGHT (CONS _ UNIT))) = Yellow\r
+toColor (RIGHT (CONS _ UNIT)) = Blue\r
+\r
+toList :: (ListG a) -> [a]\r
+toList (LEFT (CONS s UNIT)) = []\r
+toList (RIGHT (CONS s (PAIR a as))) = [a:as]\r
+\r
+toTree :: (TreeG a) -> Tree a\r
+toTree (LEFT (CONS s UNIT))= Tip\r
+toTree (RIGHT (CONS s (PAIR a (PAIR l r)))) = Bin a l r\r
+\r
+toTup :: (TupG a b) -> (a,b)\r
+toTup (CONS s (PAIR a b)) = (a,b)\r
+\r
+/**************** to test if parse and show work properly *************************/\r
+\r
+test :: t -> Bool | eq0, show_0, parse0 t\r
+test x = case parse0 (show x) of\r
+ Just (y,[]) = eq0 x y\r
+ _ = False\r
+\r
+/**************** equality with a class for each kind *************************/\r
+\r
+class eq0 t ::t t-> Bool\r
+class eq1 t :: (a a -> Bool) (t a) (t a) -> Bool\r
+class eq2 t :: (a a -> Bool) (b b -> Bool) (t a b) (t a b) -> Bool\r
+\r
+instance eq0 UNIT where eq0 _ _ = True\r
+instance eq0 Int where eq0 n m = n == m\r
+\r
+instance eq1 CONS where eq1 f (CONS s x) (CONS t y) = s == t && f x y\r
+\r
+instance eq2 PAIR where eq2 f g (PAIR a b) (PAIR x y) = f a x && g b y\r
+instance eq2 EITHER where\r
+ eq2 f g (LEFT x) (LEFT y)= f x y\r
+ eq2 f g (RIGHT x) (RIGHT y)= g x y\r
+ eq2 f g _ _ = False\r
+\r
+instance eq0 [a] | eq0 a where eq0 l m = eq1 eq0 l m\r
+instance eq1 [] where eq1 f l m = eq2 (eq1 eq0) (eq1 (eq2 f (eq1 f))) (fromList l) (fromList m)\r