a3/mart_map2/skeleton3a_wt.icl

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