a1/charlie/skeleton1.icl

   1 /* assignment 1
   2  *
   3  * Charlie Gerhardus, s3050009
   4  * Mart Lubbers, s4109503
   5  */
   6
   7 /* awnsers to questions
   8  *
   9  * 2.3, [1, 2, 3] has the full generic representation PAIR 1 (PAIR 2 3)
  10  *  the >-< operator converts the second PAIR on the fly so the initial generic representation
  11  *  returned by fromList [1, 2, 3] = PAIR 1 [2, 3].
  12  *
  13  * 2.4, Its possible to define a class for a generic conversion function:
  14  *
  15  *  class toGen a b :: a -> b
  16  *
  17  *  For every type we want to convert we need to create a instance:
  18  *
  19  *  instance toGen [a] (ListG a) where
  20  *     toGen x = fromList x
  21  *  instance toGen (Tree a) (TreeG a) where
  22  *     toGen x = fromTree x
  23  *  ....
  24  *
  25  *  Which results in the same code as can be seen later in the assignment, the difference
  26  *  is that instead of a multitude of different functions (fromList, fromTree...) we end up
  27  *  with a lot of overloaded functions.
  28  *
  29  * 3.2, yes the results are identical. This can be verified by compile and running this module.
  30  *
  31  * 3.3, when we define a new datastructure and provide a function that converts it into a generic
  32  *  representation  we can use our ordering operator on it right away. If we define more operators
  33  *  for our generic representation we dont have to provide a sepperate implementation of these operators for
  34  *  every datastructure we introduce.
  35  *
  36  * 3.4, since we are rewriting the whole datastructure before we can use the operator the programm can
  37  *  potentionally use more memory and result in more instructions that take care of the conversion.
  38  *
  39  */
  40
  41
  42 module skeleton1
  43
  44 /*
  45         Course I00032 Advanced Programming 2014
  46         Skeleton for assignment 1
  47         Pieter Koopman
  48 */
  49
  50 import StdEnv
  51 import StdFile
  52
  53 /**************** Prelude: *******************************/
  54 //      Example types
  55 :: Color        = Red | Yellow | Blue
  56 :: Tree a       = Tip | Bin a (Tree a) (Tree a)
  57 :: Rose a       = Rose a [Rose a]
  58
  59 //      Binary sums and products (in generic prelude)
  60 :: UNIT                 = UNIT
  61 :: PAIR   a b   = PAIR a b
  62 :: EITHER a b   = LEFT a | RIGHT b
  63
  64 //      Generic type representations
  65 :: RoseG a      :== PAIR a [Rose a]
  66
  67 // Conversions
  68 fromRose :: (Rose a)    -> RoseG a
  69 fromRose (Rose a l)             = PAIR a l
  70
  71 // Oerdering
  72
  73 ::      Ordering = Smaller | Equal | Bigger
  74
  75 class (><) infix 4 a :: !a !a -> Ordering
  76
  77 instance >< Int where           // Standard ordering for Int
  78         (><) x y
  79         | x < y         = Smaller
  80         | x > y         = Bigger
  81         | otherwise     = Equal
  82
  83 instance >< Char where          // Standard ordering for Char
  84         (><) x y
  85         | x < y         = Smaller
  86         | x > y         = Bigger
  87         | otherwise     = Equal
  88
  89 instance >< String where        // Standard lexicographical ordering
  90         (><) x y
  91         | x < y         = Smaller
  92         | x > y         = Bigger
  93         | otherwise     = Equal
  94
  95 instance >< Bool where          // False is smaller than True
  96         (><) False True  = Smaller
  97         (><) True  False = Bigger
  98         (><) _     _     = Equal
  99
 100 /**************** End Prelude *************************/
 101
 102 /* compare ordering */
 103 instance == Ordering where
 104         (==) Equal   Equal   = True
 105         (==) Smaller Smaller = True
 106         (==) Bigger  Bigger  = True
 107         (==) _       _       = False
 108
 109 /* color to rgb encoding
 110  *
 111  * Blue   = 0x0000FF
 112  * Red    = 0xFF0000
 113  * Yellow = 0xFFFF00
 114  */
 115 color2RGB :: Color -> Int
 116 color2RGB Blue   = 0x0000FF
 117 color2RGB Red    = 0xFF0000
 118 color2RGB Yellow = 0xFFFF00
 119
 120 /* list operator instance */
 121 instance >< [a] | >< a where
 122         (><) [] [] = Equal
 123         (><) _  [] = Bigger
 124         (><) [] _  = Smaller
 125         (><) [x:xs] [y:ys]
 126         | ( (x >< y) == Equal ) = xs >< ys
 127         | otherwise             = x >< y
 128
 129 /* tuple operator */
 130 instance >< (a, b) | >< a & >< b where
 131         (><) (x1, y1) (x2, y2)
 132         | ( (x1 >< x2) == Equal ) = y1 >< y2
 133         | otherwise               = x1 >< x2
 134
 135 /* color comparison */
 136 instance >< Color where
 137         (><) x y = color2RGB x >< color2RGB y
 138
 139 /* tree comparison */
 140 instance >< (Tree a) | >< a where
 141         (><) Tip Tip = Equal
 142         (><) _   Tip = Bigger
 143         (><) Tip _   = Smaller
 144         (><) (Bin x xl xr) (Bin y yl yr)
 145         | ( (x >< y) == Equal ) = (xl, xr) >< (yl, yr)
 146         | otherwise             = x >< y
 147
 148 /* rose comparison */
 149 instance >< (Rose a) | >< a where
 150         (><) (Rose x xs) (Rose y ys) = (x, xs) >< (y , ys)
 151
 152 /* we take >-< as the generic ordering operator */
 153 class (>-<) infix 4 a :: !a !a -> Ordering
 154
 155 /* instances for Int, Char, String and Bool
 156  *
 157  * instance >-< Int Char String Bool where
 158  *        (>-<) x y = x >< y
 159  *
 160  * not possible?
 161  */
 162 instance >-< Int where
 163         (>-<) x y =  x >< y
 164 instance >-< Char where
 165         (>-<) x y = x >< y
 166 instance >-< String where
 167         (>-<) x y = x >< y
 168 instance >-< Bool where
 169         (>-<) x y = x >< y
 170
 171 /* for unit */
 172 instance >-< UNIT where
 173         (>-<) UNIT UNIT = Equal
 174
 175 /* for pair */
 176 instance >-< (PAIR a b) | >-< a & >-< b where
 177         (>-<) (PAIR x1 x2) (PAIR y1 y2)
 178         | ( (x1 >-< y1) == Equal ) = x2 >-< y2
 179         | otherwise                = x1 >-< y1
 180
 181 /* for either */
 182 instance >-< (EITHER a b) | >-< a & >-< b where
 183         (>-<) (LEFT x)  (LEFT y)   = x >-< y
 184         (>-<) (RIGHT x) (RIGHT y)  = x >-< y
 185         (>-<) (LEFT _)  (RIGHT _)  = Bigger
 186         (>-<) (RIGHT _) (LEFT _)   = Smaller
 187
 188 /* generic representations */
 189 :: ColorG     :== EITHER (EITHER UNIT UNIT) UNIT
 190 :: ListG a    :== EITHER (PAIR a [a]) UNIT
 191 :: TupleG a b :== PAIR a b
 192 :: TreeG a    :== EITHER ( PAIR a ( TupleG (Tree a) (Tree a) ) ) UNIT
 193
 194 /* convert color to generic representation */
 195 fromColor :: Color -> ColorG
 196 fromColor Yellow = LEFT (LEFT UNIT)
 197 fromColor Red    = LEFT (RIGHT UNIT)
 198 fromColor Blue   = RIGHT UNIT
 199
 200 /* convert list to generatic representation */
 201 fromList :: [a] -> ListG a
 202 fromList []     = RIGHT UNIT
 203 fromList [x:xs] = LEFT (PAIR x xs)
 204
 205 /* convert tuple to generic representation */
 206 fromTuple :: (a, b) -> TupleG a b
 207 fromTuple (x, y) = PAIR x y
 208
 209 /* convert tree to generic representation */
 210 fromTree :: (Tree a) -> TreeG a
 211 fromTree Tip         = RIGHT UNIT
 212 fromTree (Bin x l r) = LEFT ( PAIR x ( fromTuple (l, r) ) )
 213
 214 /* generic conversion for >-< operator */
 215 instance >-< Color where
 216         (>-<) x y = fromColor x >-< fromColor y
 217
 218 instance >-< (a, b) | >-< a & >-< b where
 219         (>-<) x y = fromTuple x >-< fromTuple y
 220
 221 instance >-< [a] | >-< a where
 222         (>-<) x y = fromList x >-< fromList y
 223
 224 instance >-< (Rose a) | >-< a where
 225         (>-<) x y = fromRose x >-< fromRose y
 226
 227 instance >-< (Tree a) | >-< a where
 228         (>-<) x y = fromTree x >-< fromTree y
 229
 230 /* test trees */
 231 tree1 :: Tree Int
 232 tree1 = Bin 1 (Bin 5 Tip Tip) (Bin 6 Tip Tip)
 233 tree2 :: Tree Int
 234 tree2 = Bin 1 (Bin 5 Tip Tip) (Bin 8 Tip Tip)
 235
 236 /* test roses */
 237 rose1 :: Rose Int
 238 rose1 = Rose 2 [ Rose 1 [], Rose 2 [], Rose 5 [] ]
 239 rose2 :: Rose Int
 240 rose2 = Rose 2 [ Rose 1 [], Rose 2 [], Rose 8 [] ]
 241
 242 /* apply a ordering operator on two values */
 243 order :: (a a -> Ordering) (a, a) -> Ordering
 244 order f (x, y) = f x y
 245
 246 /* order a list */
 247 orderList :: (a a -> Ordering) [ (a, a) ] -> [Ordering]
 248 orderList f [] = []
 249 orderList f [x:xs] = [ order f x : orderList f xs ]
 250
 251 /* tests to perform */
 252 orderSetLists  = [([1..3], [1..2]), ([1..2], [1..5]), ([1..2], [1..2])]
 253 orderSetTuples = [((1,3), (1,2)), ((1,2), (1,3)), ((1,2),(1,2))]
 254 orderSetColors = [(Yellow, Blue), (Blue, Yellow), (Red, Red)]
 255 orderSetRoses  = [(rose2, rose1), (rose1, rose2), (rose1, rose1)]
 256 orderSetTrees  = [(tree2, tree1), (tree1, tree2), (tree1, tree1)]
 257
 258 /* perform orderings */
 259 test1 = orderList (><) orderSetLists
 260          ++ orderList (><) orderSetTuples
 261          ++ orderList (><) orderSetLists
 262          ++ orderList (><) orderSetRoses
 263          ++ orderList (><) orderSetTrees
 264 test2 = orderList (>-<) orderSetLists
 265          ++ orderList (>-<) orderSetTuples
 266          ++ orderList (>-<) orderSetLists
 267          ++ orderList (>-<) orderSetRoses
 268          ++ orderList (>-<) orderSetTrees
 269
 270 /* ordering file output */
 271 instance <<< Ordering where
 272         (<<<) file Equal = file <<< "Equal"
 273         (<<<) file Bigger = file <<< "Bigger"
 274         (<<<) file Smaller = file <<< "Smaller"
 275
 276 /* ordering list file output */
 277 instance <<< [Ordering] where
 278         (<<<) file []     = file
 279         (<<<) file [x:xs] = file <<< x <<< " " <<< xs
 280
 281 /* there is no file <<< Bool instance? */
 282 instance <<< Bool where
 283         (<<<) file True = file <<< "True"
 284         (<<<) file False = file <<< "False"
 285
 286 /* entry point */
 287 Start :: !*World -> *World
 288 Start world
 289         # (file, world) = stdio world
 290         # file          = file <<< "Test results for ><:\n"
 291         # file          = file <<< "[" <<< test1 <<< "]\n\n"
 292         # file          = file <<< "Test results for >-<:\n"
 293         # file          = file <<< "[" <<< test2 <<< "]\n\n"
 294         # file          = file <<< "(test1 == test2) = " <<< (test1 == test2) <<< "\n\n"
 295         # (ok, world)   = fclose file world
 296         | otherwise     = world