a1/mart/skeleton1.icl

   1 module skeleton1
   2 //Charlie Gerhardus (s000000)
   3 //Mart Lubbers (s4109503)
   4
   5 import StdEnv
   6
   7 /**************** Prelude: *******************************/
   8 //      Example types
   9 :: Color        = Red | Yellow | Blue
  10 :: Tree a       = Tip | Bin a (Tree a) (Tree a)
  11 :: Rose a       = Rose a [Rose a]
  12
  13 //      Binary sums and products (in generic prelude)
  14 :: UNIT         = UNIT
  15 :: PAIR   a b   = PAIR a b
  16 :: EITHER a b   = LEFT a | RIGHT b
  17
  18 //      Generic type representations
  19 :: RoseG a      :== PAIR a [Rose a]
  20
  21 // Conversions
  22 fromRose :: (Rose a) -> RoseG a
  23 fromRose (Rose a l)= PAIR a l
  24
  25 // Ordering
  26 :: Ordering = Smaller | Equal | Bigger
  27
  28 class (><) infix 4 a :: !a !a -> Ordering
  29
  30 instance >< Int where           // Standard ordering for Int
  31         (><) x y
  32         | x < y         = Smaller
  33         | x > y         = Bigger
  34         | otherwise     = Equal
  35
  36 instance >< Char where          // Standard ordering for Char
  37         (><) x y
  38         | x < y         = Smaller
  39         | x > y         = Bigger
  40         | otherwise     = Equal
  41
  42 instance >< String where        // Standard lexicographical ordering
  43         (><) x y
  44         | x < y         = Smaller
  45         | x > y         = Bigger
  46         | otherwise     = Equal
  47
  48 instance >< Bool where          // False is smaller than True
  49         (><) False True  = Smaller
  50         (><) True  False = Bigger
  51         (><) _     _     = Equal
  52
  53 /**************** End Prelude *************************/
  54 isEqual :: Ordering -> Bool
  55 isEqual Equal = True
  56 isEqual _ = False
  57
  58 // 1. Ordering by overloading
  59 //instance >< Color where
  60 //      (><) x y = (toInt x) >< (toInt y)
  61 //              where
  62 //                      toInt Red = 3
  63 //                      toInt Yellow = 2
  64 //                      toInt Blue = 1
  65
  66 //instance >< (Tree a) | >< a where
  67 //      (><) Tip Tip = Equal
  68 //      (><) (Bin _ _ _) Tip = Bigger
  69 //      (><) Tip (Bin _ _ _) = Smaller
  70 //      (><) (Bin x ltx rtx) (Bin y lty rty)
  71 //      | isEqual (x >< y)
  72 //              | isEqual (ltx >< lty) = rtx >< rty
  73 //              | otherwise = ltx >< lty
  74 //      | otherwise = x >< y
  75
  76 instance >< [a] | >< a where
  77         (><) [] [] = Equal
  78         (><) [] _ = Smaller
  79         (><) _ [] = Bigger
  80         (><) [x:xs] [y:ys]
  81         | isEqual (x >< y) = xs >< ys
  82         | otherwise = x >< y
  83
  84 instance >< (Rose a) | >< a where
  85         (><) (Rose x xs) (Rose y ys)
  86         | isEqual (x >< y) = xs >< ys
  87         | otherwise = x >< y
  88
  89 //instance >< (a, b) | >< a & >< b where
  90 //      (><) (xa, xb) (ya, yb)
  91 //      | isEqual (xa >< ya) = xb >< yb
  92 //      | otherwise = xa >< ya
  93
  94 //2. Generic representation
  95 //2.1
  96 :: ColorG       :== EITHER UNIT (EITHER UNIT UNIT)
  97 :: ListG a      :== EITHER UNIT (PAIR a [a])
  98 :: TupleG a b   :== PAIR a b
  99 :: TreeG a      :== EITHER UNIT (PAIR a (PAIR (Tree a) (Tree a)))
 100
 101 //2.2
 102 listToGen :: [a] -> ListG a
 103 listToGen [] = LEFT UNIT
 104 listToGen [x:xs] = RIGHT (PAIR x xs)
 105
 106 //2.3.  EITHER (PAIR 1 (PAIR 2 3)) UNIT
 107 //      Nope, it will leave the xs to be so it will be: EITHER (PAIR 1 [2,3])
 108 //2.4.  Yes, for Int and Char it works fine but for list and tuples you'll run
 109 //      into problems.
 110 //class toGen a :: a -> GenG a
 111 //
 112 //:: IntG :== EITHER UNIT (PAIR UNIT Int)
 113 //:: CharG :== EITHER UNIT (PAIR UNIT Char)
 114 //:: ListG a :== EITHER UNIT (PAIR a [a])
 115 //:: GenG a :== EITHER IntG (EITHER CharG (ListG a))
 116 //
 117 //instance toGen Int where
 118 //      toGen 0 = LEFT (LEFT UNIT)
 119 //      toGen x = LEFT (RIGHT (PAIR UNIT (x-1)))
 120 //
 121 //instance toGen Char where
 122 //      toGen x
 123 //      | fromChar x == 0 = RIGHT (LEFT (LEFT UNIT))
 124 //      | otherwise = RIGHT (LEFT (RIGHT (PAIR UNIT (x-(toChar 1)))))
 125 //
 126 //instance toGen [] where
 127 //      toGen [] = RIGHT (RIGHT (LEFT UNIT))
 128 //      toGen [x:xs] = RIGHT (RIGHT (RIGHT (PAIR (x xs))))
 129
 130 //3. Ordering via generic representation
 131 //3.1
 132 instance >< UNIT where
 133         (><) _ _ = Equal
 134
 135 instance >< (PAIR a b) | >< a & >< b where
 136         (><) (PAIR x1 y1) (PAIR x2 y2)
 137         | isEqual (x1 >< x2) = y1 >< y2
 138         | otherwise = x1 >< x2
 139
 140 instance >< (EITHER a b) | >< a & >< b where
 141         (><) (LEFT _) (RIGHT _) = Smaller
 142         (><) (RIGHT _) (LEFT _) = Bigger
 143         (><) (RIGHT x) (RIGHT y) = x >< y
 144         (><) (LEFT x) (LEFT y) = x >< y
 145
 146 instance >< Color where
 147         (><) a b = colorToGen a >< colorToGen b
 148
 149 instance >< (a, b) | >< a & >< b where
 150         (><) a b = tupleToGen a >< tupleToGen b
 151
 152 instance >< (Tree a) | >< a where
 153         (><) a b = treeToGen a >< treeToGen b
 154
 155 colorToGen :: Color -> ColorG
 156 colorToGen Blue = LEFT UNIT
 157 colorToGen Yellow = RIGHT (LEFT UNIT)
 158 colorToGen Red = RIGHT (RIGHT UNIT)
 159
 160 tupleToGen :: (a, b) -> TupleG a b
 161 tupleToGen (x, y) = PAIR x y
 162
 163 treeToGen :: (Tree a) -> TreeG a
 164 treeToGen Tip = LEFT UNIT
 165 treeToGen (Bin x xr xl) = RIGHT (PAIR x (PAIR xr xl))
 166
 167 //3.2.  Yes
 168 //3.3.  Less defining and easier overloading
 169 //3.4.  Overhead, the compiler has to translate on and on
 170
 171 Start = [Red >< Yellow, Blue >< Yellow, Blue >< Blue,
 172         (Bin 1 Tip Tip) >< Tip,
 173         [1, 2] >< [2, 3],
 174         [1, 2] >< [1, 2],
 175         [1, 3] >< [1, 2],
 176 //      [] >< [],
 177 //      Tip >< Tip,
 178         (Bin 1 Tip Tip) >< (Bin 1 Tip Tip),
 179         Tip >< (Bin 1 Tip Tip) ]