a3/mart/skeleton3a.icl

   1 module skeleton3a
   2
   3 /*
   4  Advanced Programming.
   5  Skeleton for exercise 3.1 and 3.2.
   6  To be used in a project with the environment Everything,
   7  or StdEnv with an import of StdMaybe from StdLib
   8
   9  Pieter Koopman, pieter@cs.ru.nl
  10 */
  11
  12 import StdEnv, StdMaybe
  13
  14 /************* showing *******************/
  15
  16 class show_0 t where show_0 :: t [String] -> [String]
  17
  18 instance show_0 Int where show_0 i c = [toString i:c]
  19 instance show_0 Bool where show_0 b c = [toString b:c]
  20
  21 instance show_0 UNIT where show_0 _ c = c
  22
  23 show :: a -> [String] | show_0 a
  24 show a = show_0 a []
  25
  26 /**************** parsing *************************/
  27
  28 :: Result a :== Maybe (a,[String])
  29
  30 class parse0 t :: [String] -> Result t
  31
  32 instance parse0 Int where
  33         parse0 [i:r] = Just (toInt i, r)
  34         parse0 r = Nothing
  35
  36 instance parse0 Bool where
  37         parse0 [b:r] = Just (b == "True", r)
  38         parse0 r = Nothing
  39
  40 instance parse0 UNIT where
  41         parse0 r = Just (UNIT, r)
  42
  43 /**************** Example Types and conversions *************************/
  44
  45 :: T = C
  46 :: Color = Red | Yellow | Blue
  47 :: Tree a = Tip | Bin a (Tree a) (Tree a)
  48
  49 // Binary sums and products (in generic prelude)
  50 :: UNIT = UNIT
  51 :: PAIR a b = PAIR a b
  52 :: EITHER a b = LEFT a | RIGHT b
  53 :: CONS a = CONS String a
  54
  55 // Generic type representations
  56 :: TG :== CONS UNIT
  57 :: ColorG :== EITHER (EITHER (CONS UNIT) (CONS UNIT)) (CONS UNIT)
  58 :: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
  59 :: TreeG a :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a))))
  60 :: TupG a b :== CONS (PAIR a b)
  61
  62 // Conversions
  63
  64 fromT :: T -> TG
  65 fromT c = CONS "C" UNIT
  66
  67 fromColor :: Color  -> ColorG
  68 fromColor Red = LEFT (LEFT (CONS "Red" UNIT))
  69 fromColor Yellow = LEFT (RIGHT (CONS "Yellow" UNIT))
  70 fromColor Blue = RIGHT (CONS "Blue" UNIT)
  71
  72 fromList :: [a] -> ListG a
  73 fromList [] = LEFT(CONS "Nil" UNIT)
  74 fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as))
  75
  76 fromTree :: (Tree a) -> TreeG a
  77 fromTree Tip = LEFT(CONS "Tip" UNIT)
  78 fromTree (Bin a l r) = RIGHT (CONS "Bin" (PAIR a (PAIR l r)))
  79
  80 fromTup :: (a,b) -> TupG a b
  81 fromTup (a,b) = CONS "Tuple2" (PAIR a b)
  82
  83 toT :: TG -> T
  84 toT (CONS _ UNIT) = C
  85
  86 toColor :: ColorG -> Color
  87 toColor (LEFT (LEFT(CONS _ UNIT))) = Red
  88 toColor (LEFT (RIGHT (CONS _ UNIT))) = Yellow
  89 toColor (RIGHT (CONS _ UNIT)) = Blue
  90
  91 toList :: (ListG a) -> [a]
  92 toList (LEFT (CONS s UNIT)) = []
  93 toList (RIGHT (CONS s (PAIR a as))) = [a:as]
  94
  95 toTree :: (TreeG a) -> Tree a
  96 toTree (LEFT (CONS s UNIT))= Tip
  97 toTree (RIGHT (CONS s (PAIR a (PAIR l r)))) = Bin a l r
  98
  99 toTup :: (TupG a b) -> (a,b)
 100 toTup (CONS s (PAIR a b)) = (a,b)
 101
 102 /**************** to test if parse and show work properly *************************/
 103
 104 test :: t -> Bool | eq0, show_0, parse0 t
 105 test x = case parse0 (show x) of
 106         Just (y,[]) = eq0 x y
 107         _ = False
 108
 109 /**************** equality with a class for each kind *************************/
 110
 111 class eq0 t ::t t-> Bool
 112 class eq1 t :: (a a -> Bool) (t a) (t a) -> Bool
 113 class eq2 t :: (a a -> Bool) (b b -> Bool) (t a b) (t a b) -> Bool
 114
 115 instance eq0 UNIT where eq0 _ _ = True
 116 instance eq0 Int where eq0 n m = n == m
 117
 118 instance eq1 CONS where eq1 f (CONS s x) (CONS t y) = s == t && f x y
 119
 120 instance eq2 PAIR where eq2 f g (PAIR a b) (PAIR x y) = f a x && g b y
 121 instance eq2 EITHER where
 122         eq2 f g (LEFT x) (LEFT y)= f x y
 123         eq2 f g (RIGHT x) (RIGHT y)= g x y
 124         eq2 f g _ _ = False
 125
 126 instance eq0 [a] | eq0 a where eq0 l m = eq1 eq0 l m
 127 instance eq1 [] where eq1 f l m = eq2 (eq1 eq0) (eq1 (eq2 f (eq1 f))) (fromList l) (fromList m)
 128
 129 /**************** map *************************/
 130
 131 class map0 t :: t -> t
 132 class map1 t :: (a -> b) (t a) -> t b
 133 class map2 t :: (a -> b) (c -> d) (t a c) -> t b d
 134
 135 instance map0 Int where map0 i = i
 136 instance map0 UNIT where map0 UNIT = UNIT
 137
 138 instance map1 CONS where map1 f (CONS n x) = CONS n (f x)
 139
 140 instance map2 PAIR where map2 f g (PAIR x y) = PAIR (f x) (g y)
 141 instance map2 EITHER where
 142         map2 f g (LEFT x) = LEFT (f x)
 143         map2 f g (RIGHT y)= RIGHT (g y)
 144
 145 /**************** End Prelude *************************/
 146
 147 /**************** please add all new code below this line *************************/
 148 //Show stuff
 149 class show_1 t where show_1 :: (a [String] -> [String]) (t a) [String] -> [String]
 150 class show_2 t where show_2 :: (a [String] -> [String]) (b [String] -> [String]) (t a b) [String] -> [String]
 151
 152 instance show_1 CONS where
 153         show_1 f (CONS s x) c = [s:f x c]
 154 instance show_2 PAIR where
 155         show_2 f1 f2 (PAIR x1 x2) c = f1 x1 (f2 x2 c)
 156 instance show_2 EITHER where
 157         show_2 f1 f2 (LEFT x1) c = f1 x1 c
 158         show_2 f1 f2 (RIGHT x2) c = f2 x2 c
 159
 160 instance show_0 Color where
 161         show_0 x c = show_2 (show_2 (show_1 show_0) (show_1 show_0)) (show_1 show_0) (fromColor x) c
 162
 163 instance show_1 Tree where
 164         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
 165 instance show_0 (Tree a) | show_0 a where
 166         show_0 x c = show_1 show_0 x c
 167
 168 instance show_1 [] where
 169         show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_1 f))) (fromList x) c
 170 instance show_0 [a] | show_0 a where
 171         show_0 x c = show_1 show_0 x c
 172
 173 instance show_0 (a, b) | show_0 a & show_0 b where
 174         show_0 x c = show_1 (show_2 show_0 show_0) (fromTup x) c
 175
 176 instance show_0 T where
 177         show_0 x c = show_1 show_0 (fromT x) c
 178
 179 //Parsing stuff
 180 class parse1 t :: ([String] -> Result a) [String] -> Result (t a)
 181 class parse2 t :: ([String] -> Result a) ([String] -> Result b) [String] -> Result (t a b)
 182
 183 instance parse1 CONS where
 184         parse1 f [s:r] = case f r of
 185                 Just (x, r) = Just (CONS s x, r)
 186                 _ = Nothing
 187         parse1 _ _ = Nothing
 188
 189 instance parse2 PAIR where
 190         parse2 f1 f2 r = case f1 r of
 191                 Just (x1, r) = case f2 r of
 192                         Just (x2, r) = Just (PAIR x1 x2, r)
 193                         _ = Nothing
 194                 _ = Nothing
 195
 196 instance parse2 EITHER where
 197         parse2 f1 f2 r = case f2 r of
 198                 Just (x, r) = Just (RIGHT x, r)
 199                 _ = case f1 r of
 200                         Just (x, r) = Just (LEFT x, r)
 201                         _ = Nothing
 202
 203 instance parse0 Color where
 204         parse0 r = case parse2 (parse2 (parse1 parse0) (parse1 parse0)) (parse1 parse0) r of
 205                 Just (x, r) = Just (toColor x, r)
 206                 _ = Nothing
 207
 208 instance parse1 Tree where
 209         parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse2 (parse1 f) (parse1 f)))) r of
 210                 Just (x, r) = Just (toTree x, r)
 211                 _ = Nothing
 212 instance parse0 (Tree a) | parse0 a where
 213         parse0 r = parse1 parse0 r
 214
 215 instance parse1 [] where
 216         parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse1 f))) r of
 217                 Just (x, r) = Just (toList x, r)
 218                 _ = Nothing
 219 instance parse0 [a] | parse0 a where
 220         parse0 r = parse1 parse0 r
 221
 222 instance parse0 (a, b) | parse0 a & parse0 b where
 223         parse0 r = case parse1 (parse2 parse0 parse0) r of
 224                 Just (x, r) = Just (toTup x, r)
 225                 _ = Nothing
 226
 227 instance parse0 T where
 228         parse0 r = case parse1 parse0 r of
 229                 Just (x, r) = Just (toT x, r)
 230                 _ = Nothing
 231
 232 instance eq0 Color where
 233         eq0 c1 c2 = eq2 (eq2 (eq1 eq0) (eq1 eq0)) (eq1 eq0) (fromColor c1) (fromColor c2)
 234 instance == Color where
 235         (==) c1 c2 = eq0 c1 c2
 236
 237 instance map1 [] where
 238         map1 f l = toList (map2 (map1 map0) (map1 (map2 f (map1 f))) (fromList l))
 239
 240 instance map1 Tree where
 241         map1 f t = toTree (map2 (map1 map0) (map1 (map2 f (map2 (map1 f) (map1 f)))) (fromTree t))
 242
 243 //instance map2 (a, b) | map1 a & map1 a where
 244 //      map2 f1 f2 t = toTup (map1 (map2 f1 f2) (fromTup t))
 245
 246 Start = (
 247         map1 fac aTree,
 248         map1 fac aList,
 249         //map2 fac fac (aList, aTree),
 250         map1 (\x.(x, fac x)) aList
 251         )
 252         where
 253                 fac 1 = 1
 254                 fac n = n * (fac (n-1))
 255                 aTree = Bin 2 Tip (Bin 4 Tip Tip)
 256                 aList = [1..10]