a1/charlie/skeleton1.icl

   1 /* assignment 1
   2  *
   3  * Charlie Gerhardus, s3050009
   4  * Mart Lubbers s4109503
   5  */
   6
   7 module skeleton1
   8
   9 /*
  10         Course I00032 Advanced Programming 2014
  11         Skeleton for assignment 1
  12         Pieter Koopman
  13 */
  14
  15 import StdEnv
  16
  17 /**************** Prelude: *******************************/
  18 //      Example types
  19 :: Color        = Red | Yellow | Blue
  20 :: Tree a       = Tip | Bin a (Tree a) (Tree a)
  21 :: Rose a       = Rose a [Rose a]
  22
  23 //      Binary sums and products (in generic prelude)
  24 :: UNIT                 = UNIT
  25 :: PAIR   a b   = PAIR a b
  26 :: EITHER a b   = LEFT a | RIGHT b
  27
  28 //      Generic type representations
  29 :: RoseG a      :== PAIR a [Rose a]
  30
  31 // Conversions
  32 fromRose :: (Rose a)    -> RoseG a
  33 fromRose (Rose a l)             = PAIR a l
  34
  35 // Oerdering
  36
  37 ::      Ordering = Smaller | Equal | Bigger
  38
  39 class (><) infix 4 a :: !a !a -> Ordering
  40
  41 instance >< Int where           // Standard ordering for Int
  42         (><) x y
  43         | x < y         = Smaller
  44         | x > y         = Bigger
  45         | otherwise     = Equal
  46
  47 instance >< Char where          // Standard ordering for Char
  48         (><) x y
  49         | x < y         = Smaller
  50         | x > y         = Bigger
  51         | otherwise     = Equal
  52
  53 instance >< String where        // Standard lexicographical ordering
  54         (><) x y
  55         | x < y         = Smaller
  56         | x > y         = Bigger
  57         | otherwise     = Equal
  58
  59 instance >< Bool where          // False is smaller than True
  60         (><) False True  = Smaller
  61         (><) True  False = Bigger
  62         (><) _     _     = Equal
  63
  64 /**************** End Prelude *************************/
  65
  66 /* compare ordering */
  67 instance == Ordering where
  68         (==) Equal   Equal   = True
  69         (==) Smaller Smaller = True
  70         (==) Bigger  Bigger  = True
  71         (==) _       _       = False
  72
  73 /* color to rgb encoding
  74  *
  75  * Blue   = 0x0000FF
  76  * Red    = 0xFF0000
  77  * Yellow = 0xFFFF00
  78  */
  79 color2RGB :: Color -> Int
  80 color2RGB Blue   = 0x0000FF
  81 color2RGB Red    = 0xFF0000
  82 color2RGB Yellow = 0xFFFF00
  83
  84 /* list operator instance */
  85 instance >< [a] | >< a where
  86         (><) [] [] = Equal
  87         (><) _  [] = Bigger
  88         (><) [] _  = Smaller
  89         (><) [x:xs] [y:ys]
  90         | ( (x >< y) == Equal ) = xs >< ys
  91         | otherwise             = x >< y
  92
  93 /* tuple operator */
  94 instance >< (a, b) | >< a & >< b where
  95         (><) (x1, y1) (x2, y2)
  96         | ( (x1 >< x2) == Equal ) = y1 >< y2
  97         | otherwise               = x1 >< x2
  98
  99 /* color comparison */
 100 instance >< Color where
 101         (><) x y = color2RGB x >< color2RGB y
 102
 103 /* tree comparison */
 104 instance >< (Tree a) | >< a where
 105         (><) Tip Tip = Equal
 106         (><) _   Tip = Bigger
 107         (><) Tip _   = Smaller
 108         (><) (Bin x xl xr) (Bin y yl yr)
 109         | ( (x >< y) == Equal ) = (xl, xr) >< (yl, yr)
 110         | otherwise             = x >< y
 111
 112 /* rose comparison */
 113 instance >< (Rose a) | >< a where
 114         (><) (Rose x xs) (Rose y ys) = (x, xs) >< (y , ys)
 115
 116 /* we take >-< as the generic ordering operator */
 117 class (>-<) infix 4 a :: !a !a -> Ordering
 118
 119 /* instances for Int, Char, String and Bool
 120  *
 121  * instance >-< Int Char String Bool where
 122  *        (>-<) x y = x >< y
 123  *
 124  * not possible?
 125  */
 126 instance >-< Int where
 127         (>-<) x y =  x >< y
 128 instance >-< Char where
 129         (>-<) x y = x >< y
 130 instance >-< String where
 131         (>-<) x y = x >< y
 132 instance >-< Bool where
 133         (>-<) x y = x >< y
 134
 135 /* for unit */
 136 instance >-< UNIT where
 137         (>-<) UNIT UNIT = Equal
 138
 139 /* for pair */
 140 instance >-< (PAIR a b) | >-< a & >-< b where
 141         (>-<) (PAIR x1 x2) (PAIR y1 y2)
 142         | ( (x1 >-< y1) == Equal ) = x2 >-< y2
 143         | otherwise                = x1 >-< y1
 144
 145 /* for either */
 146 instance >-< (EITHER a b) | >-< a & >-< b where
 147         (>-<) (LEFT x)  (LEFT y)   = x >-< y
 148         (>-<) (RIGHT x) (RIGHT y)  = x >-< y
 149         (>-<) (LEFT _)  (RIGHT _)  = Bigger
 150         (>-<) (RIGHT _) (LEFT _)   = Smaller
 151
 152 /* generic representations */
 153 :: ColorG     :== EITHER (EITHER UNIT UNIT) UNIT
 154 :: ListG a    :== EITHER (PAIR a [a]) UNIT
 155 :: TupleG a b :== PAIR a b
 156 :: TreeG a    :== EITHER ( PAIR a ( TupleG (Tree a) (Tree a) ) ) UNIT
 157
 158 /* convert color to generic representation */
 159 fromColor :: Color -> ColorG
 160 fromColor Yellow = LEFT (LEFT UNIT)
 161 fromColor Red    = LEFT (RIGHT UNIT)
 162 fromColor Blue   = RIGHT UNIT
 163
 164 /* convert list to generatic representation */
 165 fromList :: [a] -> ListG a
 166 fromList []     = RIGHT UNIT
 167 fromList [x:xs] = LEFT (PAIR x xs)
 168
 169 /* convert tuple to generic representation */
 170 fromTuple :: (a, b) -> TupleG a b
 171 fromTuple (x, y) = PAIR x y
 172
 173 /* convert tree to generic representation */
 174 fromTree :: (Tree a) -> TreeG a
 175 fromTree Tip         = RIGHT UNIT
 176 fromTree (Bin x l r) = LEFT ( PAIR x ( fromTuple (l, r) ) )
 177
 178 /* generic conversion for >-< operator */
 179 instance >-< Color where
 180         (>-<) x y = fromColor x >-< fromColor y
 181
 182 instance >-< (a, b) | >-< a & >-< b where
 183         (>-<) x y = fromTuple x >-< fromTuple y
 184
 185 instance >-< [a] | >-< a where
 186         (>-<) x y = fromList x >-< fromList y
 187
 188 instance >-< (Rose a) | >-< a where
 189         (>-<) x y = fromRose x >-< fromRose y
 190
 191 instance >-< (Tree a) | >-< a where
 192         (>-<) x y = fromTree x >-< fromTree y
 193
 194 /* test trees */
 195 tree1 :: Tree Int
 196 tree1 = Bin 1 (Bin 5 Tip Tip) (Bin 6 Tip Tip)
 197 tree2 :: Tree Int
 198 tree2 = Bin 1 (Bin 5 Tip Tip) (Bin 8 Tip Tip)
 199
 200 /* test roses */
 201 rose1 :: Rose Int
 202 rose1 = Rose 2 [ Rose 1 [], Rose 2 [], Rose 5 [] ]
 203 rose2 :: Rose Int
 204 rose2 = Rose 2 [ Rose 1 [], Rose 2 [], Rose 8 [] ]
 205
 206 /* our two comparison lists */
 207 cmp1 :: [Ordering]
 208 cmp1 = [[1..3] >< [1..2], [1..2] >< [1..5], (1,2) >< (1,2), (1,3) >-< (1,2), Red >< Yellow, Yellow >< Blue, tree1 >< tree1, tree1 >< tree2, tree2 >< tree1, rose1 >< rose1, rose1 >< rose2, rose2 >< rose1]
 209 cmp2 :: [Ordering]
 210 cmp2 = [[1..3] >-< [1..2], [1..2] >-< [1..5], (1,2) >-< (1,2), (1,3) >-< (1,2), Red >-< Yellow, Yellow >-< Blue, tree1 >-< tree1, tree1 >-< tree2, tree2 >-< tree1, rose1 >-< rose1, rose1 >-< rose2, rose2 >-< rose1]
 211
 212 /* entry point */
 213 Start = ([cmp1, cmp2], cmp1 == cmp2)