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
+ 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
+ Pieter Koopman, pieter@cs.ru.nl\r
*/\r
\r
import StdEnv, StdMaybe\r
\r
/************* showing *******************/\r
\r
-class show_0 a where show_0 :: a [String] -> [String]\r
+class show_0 t where show_0 :: t [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
-instance show_0 UNIT where show_0 unit c = [UNITTag:c]\r
+instance show_0 Int where show_0 i c = [toString i:c]\r
+instance show_0 Bool where show_0 b c = [toString b:c]\r
\r
-IntTag :== "Int"\r
-BoolTag :== "Bool"\r
-UNITTag :== "UNIT"\r
-PAIRTag :== "PAIR"\r
+instance show_0 UNIT where show_0 _ c = c\r
\r
show :: a -> [String] | show_0 a\r
show a = show_0 a []\r
\r
:: Result a :== Maybe (a,[String])\r
\r
-class parse0 a :: [String] -> Result a\r
+class parse0 t :: [String] -> Result t\r
\r
-instance parse0 Int\r
-where\r
- parse0 [IntTag,i:r] = Just (toInt i, r)\r
+instance parse0 Int where\r
+ parse0 [i:r] = Just (toInt i, r)\r
parse0 r = Nothing\r
-instance parse0 Bool\r
-where\r
- parse0 [BoolTag,b:r] = Just (b=="True", r)\r
- parse0 r = Nothing\r
-instance parse0 UNIT\r
-where\r
- parse0 [UNITTag:r] = Just (UNIT, r)\r
+\r
+instance parse0 Bool where\r
+ parse0 [b:r] = Just (b == "True", r)\r
parse0 r = Nothing\r
\r
+instance parse0 UNIT where\r
+ parse0 r = Just (UNIT, r)\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
+:: 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
+// 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
+// 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
+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
+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
+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
+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
+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
+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
+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
+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 :: (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
+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\r
- = case parse0 (show x) of\r
- Just (y,[]) = eq0 x y\r
- _ = False\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 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
+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
+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 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
+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
+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
\r
/**************** map *************************/\r
\r
-class map0 t :: t -> t\r
-class map1 t :: (a -> b) (t a) -> t b\r
+class map0 t :: t -> t\r
+class map1 t :: (a -> b) (t a) -> t b\r
class map2 t :: (a -> b) (c -> d) (t a c) -> t b d \r
\r
-instance map0 Int where map0 i = i\r
-instance map0 UNIT where map0 UNIT = UNIT\r
+instance map0 Int where map0 i = i\r
+instance map0 UNIT where map0 UNIT = UNIT\r
\r
-instance map1 CONS where map1 f (CONS n x) = CONS n (f x)\r
+instance map1 CONS where map1 f (CONS n x) = CONS n (f x)\r
\r
-instance map2 PAIR where map2 f g (PAIR x y) = PAIR (f x) (g y)\r
-instance map2 EITHER where map2 f g (LEFT x) = LEFT (f x)\r
- map2 f g (RIGHT y) = RIGHT (g y)\r
+instance map2 PAIR where map2 f g (PAIR x y) = PAIR (f x) (g y)\r
+instance map2 EITHER where\r
+ map2 f g (LEFT x) = LEFT (f x)\r
+ map2 f g (RIGHT y)= RIGHT (g y)\r
\r
/**************** End Prelude *************************/\r
\r
/**************** please add all new code below this line *************************/\r
-\r
-instance eq0 Color where eq0 c1 c2 = False // TO BE IMPROVED\r
-instance == Color where (==) c1 c2 = eq0 c1 c2 // just to use the well-known notation...\r
-instance show_0 Color where show_0 _ c = c // TO BE IMPROVED\r
-instance parse0 Color where parse0 _ = Nothing // TO BE IMPROVED\r
-\r
-instance map1 [] where map1 f l = map f l // TO BE IMPROVED, use generic version\r
-\r
-// some initial tests, please extend\r
-Start\r
- = [ and [ test i \\ i <- [-25 .. 25]]\r
- , and [ c == toColor (fromColor c) \\ c <- [Red, Yellow, Blue]]\r
- , and [ test c \\ c <- [Red,Yellow,Blue]]\r
-// , test [1 .. 3]\r
-// , test [(a,b) \\ a <- [1 .. 2], b <- [5 .. 7]]\r
-// etc.\r
- // maps\r
- , map1 ((+) 1) [0 .. 5] == [1 .. 6]\r
- ]\r
-\r
-aTree = Bin 2 Tip (Bin 4 Tip Tip)\r
+//Show stuff\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_1 CONS where\r
+ show_1 f (CONS s x) c = [s:f x c]\r
+instance show_2 PAIR where\r
+ show_2 f1 f2 (PAIR x1 x2) c = f1 x1 (f2 x2 c)\r
+instance show_2 EITHER where\r
+ show_2 f1 f2 (LEFT x1) c = f1 x1 c\r
+ show_2 f1 f2 (RIGHT x2) c = 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
+//Parsing stuff\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 parse1 CONS where\r
+ parse1 f [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 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
+\r
+instance parse2 EITHER where\r
+ parse2 f1 f2 r = case f2 r of\r
+ Just (x, r) = Just (RIGHT x, r)\r
+ _ = case f1 r of\r
+ Just (x, r) = Just (LEFT 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
+instance eq0 Color where \r
+ eq0 c1 c2 = eq2 (eq2 (eq1 eq0) (eq1 eq0)) (eq1 eq0) (fromColor c1) (fromColor c2)\r
+instance == Color where \r
+ (==) c1 c2 = eq0 c1 c2\r
+\r
+instance map1 [] where\r
+ map1 f l = toList (map2 (map1 map0) (map1 (map2 f (map1 f))) (fromList l))\r
+\r
+instance map1 Tree where\r
+ map1 f t = toTree (map2 (map1 map0) (map1 (map2 f (map2 (map1 f) (map1 f)))) (fromTree t))\r
+\r
+//instance map2 (a, b) | map1 a & map1 a where\r
+// map2 f1 f2 t = toTup (map1 (map2 f1 f2) (fromTup t))\r
+\r
+Start = (\r
+ map1 fac aTree,\r
+ map1 fac aList,\r
+ //map2 fac fac (aList, aTree),\r
+ map1 (\x.(x, fac x)) aList\r
+ )\r
+ where\r
+ fac 1 = 1\r
+ fac n = n * (fac (n-1))\r
+ aTree = Bin 2 Tip (Bin 4 Tip Tip)\r
+ aList = [1..10]\r
--- /dev/null
+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
repositories / ap2015.git / commitdiff