a3/mart/skeleton3a_wt.icl

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