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.  Nope, not possible since they are basic types and they can't be
 109 //      converted to UNIT, EITHER or PAIR.
 110
 111 //3. Ordering via generic representation
 112 //3.1
 113 instance >< UNIT where
 114         (><) _ _ = Equal
 115
 116 instance >< (PAIR a b) | >< a & >< b where
 117         (><) (PAIR x1 y1) (PAIR x2 y2)
 118         | isEqual (x1 >< x2) = y1 >< y2
 119         | otherwise = x1 >< x2
 120
 121 instance >< (EITHER a b) | >< a & >< b where
 122         (><) (LEFT _) (RIGHT _) = Smaller
 123         (><) (RIGHT _) (LEFT _) = Bigger
 124         (><) (RIGHT x) (RIGHT y) = x >< y
 125         (><) (LEFT x) (LEFT y) = x >< y
 126
 127 instance >< Color where
 128         (><) a b = colorToGen a >< colorToGen b
 129
 130 instance >< (a, b) | >< a & >< b where
 131         (><) a b = tupleToGen a >< tupleToGen b
 132
 133 instance >< (Tree a) | >< a where
 134         (><) a b = treeToGen a >< treeToGen b
 135
 136 colorToGen :: Color -> ColorG
 137 colorToGen Blue = LEFT UNIT
 138 colorToGen Yellow = RIGHT (LEFT UNIT)
 139 colorToGen Red = RIGHT (RIGHT UNIT)
 140
 141 tupleToGen :: (a, b) -> TupleG a b
 142 tupleToGen (x, y) = PAIR x y
 143
 144 treeToGen :: (Tree a) -> TreeG a
 145 treeToGen Tip = LEFT UNIT
 146 treeToGen (Bin x xr xl) = RIGHT (PAIR x (PAIR xr xl))
 147
 148 //3.2.  Yes
 149 //3.3.  Less defining and easier overloading
 150 //3.4.  Overhead, the compiler has to translate on and on
 151
 152 Start = [Red >< Yellow, Blue >< Yellow, Blue >< Blue,
 153         (Bin 1 Tip Tip) >< Tip,
 154         (Bin 1 Tip Tip) >< (Bin 1 Tip Tip),
 155         Tip >< (Bin 1 Tip Tip) ]