a2/charlie/skeleton2.icl

   1 /* assignment 2
   2  *
   3  * Charlie Gerhardus, s3050009
   4  * Mart Lubbers, s4109503
   5  */
   6
   7 module skeleton2
   8
   9 /*
  10         Skeleton for Exercise 2 of Advanced Programming.
  11         Works fine with the environment Everything, but you can also use
  12         StdEnv and manually add StdMaybe from the directory {Application}\Libraries\StdLib.
  13
  14         Pieter Koopman, 2013
  15 */
  16
  17 import StdEnv, StdMaybe
  18
  19 /**************** Prelude *************************/
  20
  21 //      Binary sums and products (in generic prelude)
  22 :: UNIT                 = UNIT
  23 :: PAIR   a b   = PAIR a b
  24 :: EITHER a b   = LEFT a | RIGHT b
  25 :: CONS   a             = CONS String a
  26
  27 //      Generic type representations
  28 :: ListG a      :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
  29 :: TreeG a      :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a))))
  30 :: TupG a b     :== CONS (PAIR a b)
  31 :: TG           :== CONS UNIT
  32
  33 // Conversions
  34 fromList :: [a] -> ListG a
  35 fromList []             = LEFT (CONS "Nil" UNIT)
  36 fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as))
  37
  38 toList :: (ListG a) -> [a]
  39 toList (LEFT (CONS "Nil" UNIT)) = []
  40 toList (RIGHT (CONS "Cons" (PAIR a as))) = [a:as]
  41
  42 /**************** End Prelude *************************/
  43
  44 /**************** Part 1 *******************************/
  45
  46 :: Tree a = Tip | Bin (Tree a) a (Tree a)
  47
  48 class Container t
  49 where
  50         Cinsert   :: a (t a) -> t a      | <        a
  51         Ccontains :: a (t a) -> Bool     | <, Eq    a
  52         Cshow     ::   (t a) -> [String] | toString a
  53         Cnew      :: t a
  54
  55 // unsorted list container
  56 instance Container []
  57 where
  58         Cinsert x y = [x] ++ y
  59         Ccontains x [y:ys] | x == y = True
  60                            | otherwise = Ccontains x ys
  61         Ccontains _ [] = False
  62         Cshow [x:xs] = [toString x] ++ Cshow xs
  63         Cshow [] = []
  64         Cnew = []
  65
  66 // unbalanced binairy search tree
  67 instance Container Tree
  68 where
  69         Cinsert x Tip = Bin Tip x Tip
  70         Cinsert x (Bin l y r) | x < y = Bin (Cinsert x l) y r
  71                               | otherwise = Bin l y (Cinsert x r)
  72         Ccontains _ Tip = False
  73         Ccontains x (Bin l y r) | x == y = True
  74                                 | x < y = Ccontains x l
  75                                                         | otherwise = Ccontains x r
  76         Cshow Tip = []
  77         Cshow (Bin l x r) = Cshow l ++ [toString x] ++ Cshow r
  78         Cnew = Tip
  79
  80 //list test:
  81 list_container :: [Int]
  82 list_container = Cinsert 3 (Cinsert 12 (Cinsert 8 Cnew))
  83 list_test = (Ccontains 3 list_container,Cshow list_container)
  84
  85 //tree test:
  86 tree_container :: Tree Int
  87 tree_container = Cinsert 3 (Cinsert 12 (Cinsert 8 Cnew))
  88 tree_test = (Ccontains 3 tree_container,Cshow tree_container)
  89
  90 //Start = [list_test, tree_test]
  91
  92 /**************** Part 3 *******************************/
  93
  94 /* convert tuple to generic representation */
  95 fromTuple :: (a, b) -> TupG a b
  96 fromTuple (x, y) = CONS "Tuple" (PAIR x y)
  97
  98 toTuple :: (TupG a b) -> (a, b)
  99 toTuple (CONS "Tuple" (PAIR x y)) = (x, y)
 100
 101 /* convert tree to generic representation */
 102 fromTree :: (Tree a) -> TreeG a
 103 fromTree Tip         = LEFT (CONS "Tip" UNIT)
 104 fromTree (Bin l x r) = RIGHT ( CONS "Bin" ( PAIR x ( PAIR l r ) ) )
 105
 106 toTree :: (TreeG a) -> (Tree a)
 107 toTree (LEFT (CONS "Tip" UNIT)) = Tip
 108 toTree (RIGHT (CONS "Bin" (PAIR x (PAIR l r)))) = Bin l x r
 109
 110 //      Example types
 111 show :: a -> [String] | show_ a
 112 show a = show_ a []
 113
 114 class show_ a where show_ :: a [String] -> [String]
 115
 116 instance show_ Int  where show_ i c = ["Int"  : toString i : c]
 117 instance show_ Bool where show_ b c = ["Bool" : toString b : c]
 118
 119 instance show_ UNIT where
 120         show_ _ c = ["UNIT" : c]
 121
 122 instance show_ (PAIR a b) | show_ a & show_ b where
 123         show_ (PAIR x y) c = ["PAIR":show_ x (show_ y c)]
 124
 125 instance show_ (EITHER a b) | show_ a & show_ b where
 126         show_ (LEFT x) c = ["LEFT":show_ x c]
 127         show_ (RIGHT x) c = ["RIGHT":show_ x c]
 128
 129 instance show_ (CONS a) | show_ a where
 130         show_ (CONS n x) c = ["CONS":n:show_ x c]
 131
 132 instance show_ [a] | show_ a where
 133         show_ x c = show_ (fromList x) c
 134
 135 instance show_ (Tree a) | show_ a where
 136         show_ x c = show_ (fromTree x) c
 137
 138 instance show_ (a, b) | show_ a & show_ b where
 139         show_ x c = show_ (fromTuple x) c
 140
 141 /**************** Part 4 *******************************/
 142 :: Result a = Fail | Match a [String]
 143 class parse a :: [String] -> Result a
 144
 145 instance parse Int where
 146         parse ["Int",i : r]  = Match (toInt i) r
 147         parse _              = Fail
 148 instance parse Bool where
 149         parse ["Bool",b : r] = Match (b=="True") r
 150         parse _              = Fail
 151 instance parse UNIT where
 152         parse ["UNIT" : r]   = Match UNIT r
 153         parse _              = Fail
 154
 155 instance parse (PAIR a b) | parse a & parse b where
 156         parse ["PAIR" : r] = Match (PAIR x y) t where
 157                 (Match y t) = parse s;
 158                 (Match x s) = parse r
 159         parse _ = Fail
 160
 161 instance parse (EITHER a b) | parse a & parse b where
 162         parse ["LEFT":r] = Match (LEFT x) s where
 163                 (Match x s) = parse r
 164         parse ["RIGHT":r] = Match (RIGHT y) s where
 165                 (Match y s) = parse r
 166         parse _ = Fail
 167
 168 instance parse (CONS a) | parse a where
 169         parse ["CONS",n:r] = cons n (parse r) where
 170                 cons n (Match x s) = Match (CONS n x) s
 171
 172 instance parse [a] | parse a where
 173         parse r = list (parse r) where
 174                 list (Match x s) = Match (toList x) s
 175
 176 instance parse (a, b) | parse a & parse b where
 177         parse r = tuple (parse r) where
 178                 tuple (Match x s) = Match (toTuple x) s
 179
 180 instance parse (Tree a) | parse a where
 181         parse r = tree (parse r) where
 182                 tree (Match x s) = Match (toTree x) s
 183
 184 :: T = C
 185
 186 tuple_text = show (8, 9)
 187 tuple_parse :: (Int, Int)
 188 tuple_parse = tuple (parse tuple_text) where
 189         tuple (Match x s) = x
 190
 191 list_text = show [1, 2, 3, 112]
 192 list_parse :: [Int]
 193 list_parse = list (parse list_text) where
 194         list (Match x s) = x
 195
 196 tree_data :: Tree Int
 197 tree_data = Cinsert 8 (Cinsert 12 (Cinsert 5 (Cinsert 11 Cnew)))
 198 tree_text = show tree_data
 199 tree_parse :: (Tree Int)
 200 tree_parse = tree (parse tree_text) where
 201         tree (Match x s) = x
 202
 203 instance <<< [a] | <<< a where
 204         (<<<) file [x:xs] = (list_print (file <<< "[" <<< x) xs) <<< "]"
 205
 206 list_print :: !*File [a] -> *File | <<< a
 207 list_print file [x:xs] = list_print (file <<< ", " <<< x) xs
 208 list_print file [] = file
 209
 210 instance <<< (a, b) | <<< a & <<< b where
 211         (<<<) file (x, y) = file <<< "(" <<< x <<< ", " <<< y <<< ")"
 212
 213 instance <<< (Tree a) | <<< a where
 214         (<<<) file Tip = file <<< "Tip"
 215         (<<<) file (Bin l x r) = file <<< " {" <<< l <<< " } [" <<< x <<< "] { " <<< r <<< "} "
 216
 217 :: PTree a = PTip | PBin Int a (PTree a) (PTree a)
 218
 219 combine2d :: [[a]] [[a]] -> [[a]]
 220 combine2d [x:xs] [y:ys] = [x ++ y] ++ (combine2d xs ys)
 221 combine2d x [] = x
 222 combine2d [] y = y
 223
 224 tree_depth :: (Tree a) -> Int
 225 tree_depth (Bin l _ r) = 1+(max (tree_depth l) (tree_depth r))
 226 tree_depth Tip = 0
 227
 228 tree_width :: (Tree a) -> Int
 229 tree_width t = 2^((tree_depth t)-1)
 230
 231 tree_flatten :: Int Int (Tree a) -> [[(Int, a)]]
 232 tree_flatten pos step (Bin l x r) = [[(pos, x)]] ++ (combine2d (tree_flatten (pos-step) (step/2) l) (tree_flatten (pos+step) (step/2) r))
 233 tree_flatten _ _ Tip = []
 234
 235 tree_node :: *File Int Int a -> *File | <<< a
 236 tree_node file p np x | p < np = tree_node (file <<< " ") (p+1) np x
 237                       | otherwise = file <<< x
 238
 239 tree_line :: *File Int [(Int, a)] -> *File | <<< a
 240 tree_line file pos [(npos, x):xs] = tree_line (tree_node file pos npos x) npos xs
 241 tree_line file _ [] = file
 242
 243 tree_print :: *File [[(Int, a)]] -> *File | <<< a
 244 tree_print file [x:xs] = tree_print ((tree_line file 0 x) <<< "\n") xs
 245 tree_print file [] = file <<< "\n"
 246
 247 Start :: !*World -> *World
 248 Start world
 249         # (file, world) = stdio world
 250         # file          = file <<< "Tuple text:\n"
 251         # file          = file <<< tuple_text <<< "\n\n"
 252         # file          = file <<< "parser result: " <<< tuple_parse <<< "\n\n"
 253         # file          = file <<< "List text:\n"
 254         # file          = file <<< list_text <<< "\n\n"
 255         # file          = file <<< "parser result: " <<< list_parse <<< "\n\n"
 256         # file          = file <<< "Tree text:\n"
 257         # file          = file <<< tree_text <<< "\n\n"
 258         # file          = file <<< "parser result: " <<< tree_parse <<< "\n\n"
 259         # file          = file <<< "tree_depth = " <<< (tree_depth tree_data) <<< "\n"
 260         # file          = file <<< "tree_width = " <<< (tree_width tree_data) <<< "\n"
 261         # file          = file <<< "tree_flatten = " <<< (tree_flatten (((tree_width tree_data)*2)+4) ((tree_width tree_data)*2) tree_data) <<< "\n"
 262         # file          = tree_print file (tree_flatten (((tree_width tree_data)*2)+4) ((tree_width tree_data)*2) tree_data)
 263         # (ok, world)   = fclose file world
 264         | otherwise     = world
 265
 266 /**************** Starts *******************************/
 267
 268 //Start = ("add your own Start rule!\n", Start4)
 269
 270 // Possible tests:
 271 //Start1 :: ([String],Result T)
 272 //Start1 = (strings,parse strings) where strings = show C
 273
 274 //Start2 :: ([String],Result (Int,Bool))
 275 //Start2 = (strings,parse strings) where strings = show (1,False)
 276
 277 //Start3 :: ([String],Result [Int])
 278 //Start3 = (strings,parse strings) where strings = show l; l :: [Int]; l = [1..4]
 279
 280 //Start4 :: ([String],Result (Tree Int))
 281 //Start4 = (strings,parse strings)
 282 //where
 283 //      strings = show t
 284
 285 //      t :: Tree Int
 286 //      t = Bin (Bin Tip 2 (Bin Tip 3 Tip)) 4 (Bin (Bin Tip 5 Tip) 6 Tip)