a2/mart/skeleton2.icl

   1 module skeleton2
   2
   3 /*
   4         Skeleton for Exercise 2 of Advanced Programming.
   5         Works fine with the environment Everything, but you can also use
   6         StdEnv and manually add StdMaybe from the directory {Application}\Libraries\StdLib.
   7
   8         Pieter Koopman, 2013
   9 */
  10
  11 import StdEnv
  12 //import StdMaybe
  13
  14 /**************** Prelude *************************/
  15
  16 //      Binary sums and products (in generic prelude)
  17 :: UNIT         = UNIT
  18 :: PAIR   a b   = PAIR a b
  19 :: EITHER a b   = LEFT a | RIGHT b
  20 :: CONS   a     = CONS String a
  21
  22 //      Generic type representations
  23 :: ListG a      :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
  24 :: TreeG a      :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a))))
  25 :: TupG a b     :== CONS (PAIR a b)
  26 :: TG           :== CONS UNIT
  27
  28 // Conversions
  29 fromList :: [a] -> ListG a
  30 fromList []             = LEFT (CONS "Nil" UNIT)
  31 fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as))
  32
  33 toList :: (ListG a) -> [a]
  34 toList (LEFT (CONS "Nil" UNIT)) = []
  35 toList (RIGHT (CONS "Cons" (PAIR a as))) = [a:as]
  36
  37
  38 /**************** End Prelude *************************/
  39
  40 /**************** Part 1 *******************************/
  41
  42 :: Tree a = Tip | Bin (Tree a) a (Tree a)
  43
  44 class Container t
  45 where
  46         Cinsert   :: a (t a) -> t a      | <        a
  47         Ccontains :: a (t a) -> Bool     | <, Eq    a
  48         Cshow     ::   (t a) -> [String] | toString a
  49         Cnew      :: t a
  50
  51 instance Container [] where
  52         Cinsert e x = [e:x]
  53
  54         Ccontains e x = isMember e x
  55
  56         Cshow x = map toString x
  57
  58         Cnew = []
  59
  60 instance Container Tree where
  61         Cinsert e Tip = Bin Tip e Tip
  62         Cinsert e (Bin l x r)
  63         | e < x = Cinsert e l
  64         | otherwise = Cinsert e r
  65
  66         Ccontains e Tip = False
  67         Ccontains e (Bin l x r)
  68         | e == x = True
  69         | e < x = Ccontains e l
  70         | otherwise = Ccontains e r
  71
  72         Cshow Tip = []
  73         Cshow (Bin l x r) = Cshow l ++ [toString x] ++ Cshow r
  74
  75         Cnew = Tip
  76
  77
  78 /**************** Part 2 ******************************/
  79 /*
  80 Intlist : *
  81 List    : *→*
  82 Tree    : *→*→*
  83 T1      : (*→*)→*
  84 T2      : (((*→*)→*)→*)→*
  85 T3      : (*→*→*)→*
  86 T4      : ((*→*)→*)→*
  87 */
  88 /***************** Part 3 *******************************/
  89 show :: a -> [String] | show_ a
  90 show a = show_ a []
  91
  92 class show_ a where show_ :: a [String] -> [String]
  93
  94 instance show_ Int  where show_ i c = ["Int"  : toString i : c]
  95 instance show_ Bool where show_ b c = ["Bool" : toString b : c]
  96
  97 instance show_ UNIT where show_ _ c = ["UNIT" : c]
  98
  99 instance show_ (PAIR a b) | show_ a & show_ b where
 100         show_ (PAIR x y) c = ["PAIR":show_ x (show_ y c)]
 101
 102 instance show_ (EITHER a b) | show_ a & show_ b where
 103         show_ (LEFT x) c = ["LEFT":show_ x c]
 104         show_ (RIGHT x) c = ["RIGHT":show_ x c]
 105
 106 instance show_ (CONS a) | show_ a where
 107         show_ (CONS s x) c = ["CONS", s:show_ x c]
 108
 109 instance show_ [a] | show_ a where
 110         show_ x c = show_ (fromList x) c
 111
 112 fromTree :: (Tree a) -> TreeG a
 113 fromTree Tip = LEFT (CONS "Tip" UNIT)
 114 fromTree (Bin l x r) = RIGHT (CONS "Bin" (PAIR x (PAIR l r)))
 115
 116 instance show_ (Tree a) | show_ a where
 117         show_ x c = show_ (fromTree x) c
 118
 119 fromTuple :: (a, b) -> TupG a b
 120 fromTuple (x, y) = CONS "Tuple" (PAIR x y)
 121
 122 instance show_ (a, b) | show_ a & show_ b where
 123         show_ x c = show_ (fromTuple x) c
 124
 125 Start = [
 126         show [1, 2, 3],
 127         show (Bin Tip 5 Tip),
 128         show ([1, 2], 5) ]
 129
 130 ///**************** Part 4 *******************************/
 131 :: Result a = Fail | Match a [String]
 132 class parse a :: [String] -> Result a
 133
 134 instance parse Int where
 135         parse ["Int",i : r]  = Match (toInt i) r
 136         parse _              = Fail
 137 instance parse Bool where
 138         parse ["Bool",b : r] = Match (b=="True") r
 139         parse _              = Fail
 140 instance parse UNIT where
 141         parse ["UNIT" : r]   = Match UNIT r
 142         parse _              = Fail
 143 instance parse (PAIR a b) where
 144 //      parse ["PAIR":r] = Match r
 145         parse _ = Fail
 146 instance parse (EITHER a b) where
 147 //      parse ["EITHER":r] = Match r
 148         parse _ = Fail
 149 instance parse (CONS a) where
 150 //      parse ["CONS",s:r]
 151         parse_ = Fail
 152
 153 instance parse (Tree a) | parse a where parse list = Fail // should be improved
 154
 155 :: T = C
 156
 157 ///**************** Starts *******************************/
 158 //
 159 //Start = ("add your own Start rule!\n", Start4)
 160 //
 161 //// Possible tests:
 162 ////Start1 :: ([String],Result T)
 163 ////Start1 = (strings,parse strings) where strings = show C
 164 //
 165 ////Start2 :: ([String],Result (Int,Bool))
 166 ////Start2 = (strings,parse strings) where strings = show (1,False)
 167 //
 168 ////Start3 :: ([String],Result [Int])
 169 ////Start3 = (strings,parse strings) where strings = show l; l :: [Int]; l = [1..4]
 170 //
 171 //Start4 :: ([String],Result (Tree Int))
 172 //Start4 = (strings,parse strings)
 173 //where
 174 //      strings = show t
 175 //
 176 //      t :: Tree Int
 177 //      t = Bin (Bin Tip 2 (Bin Tip 3 Tip)) 4 (Bin (Bin Tip 5 Tip) 6 Tip)