compiler/ilxGen/tests/life.hs

   1 --------------------------------
   2 --      The Game of Life      --
   3 --------------------------------
   4
   5 generations x = 30
   6
   7 data L a = N | C1 a (L a)
   8
   9 data Tuple2 a b = T2 a b
  10
  11 data Tuple3 a b c = T3 a b c
  12
  13
  14 main = putStr (listChar_string
  15                     (append1 (C1 '\FF' N)
  16                              (life1 (generations ()) (start ()))))
  17
  18 listChar_string :: L Char -> String
  19 listChar_string N = []
  20 listChar_string (C1 x xs) = x : listChar_string xs
  21
  22 start :: a -> L (L Int)
  23 start x = (C1 N
  24           (C1 N
  25           (C1 N
  26           (C1 N
  27           (C1 N
  28           (C1 N
  29           (C1 N
  30           (C1 N
  31           (C1 N
  32           (C1 N
  33           (C1 N
  34           (C1 N
  35           (C1 N
  36           (C1 N
  37           (C1
  38            (C1 0
  39            (C1 0
  40            (C1 0
  41            (C1 1
  42            (C1 1
  43            (C1 1
  44            (C1 1
  45            (C1 1
  46            (C1 0
  47            (C1 1
  48            (C1 1
  49            (C1 1
  50            (C1 1
  51            (C1 1
  52            (C1 0
  53            (C1 1
  54            (C1 1
  55            (C1 1
  56            (C1 1
  57            (C1 1
  58            (C1 0
  59            (C1 1
  60            (C1 1
  61            (C1 1
  62            (C1 1
  63            (C1 1
  64            (C1 0 N))))))))))))))))))))))))))) N)))))))))))))))
  65
  66 -- Calculating the next generation
  67
  68 gen1 :: Int -> L (L Int) -> L (L Int)
  69 gen1 n board = map1 row1 (shift1 (copy1 n 0) board)
  70
  71 row1 :: Tuple3 (L Int) (L Int) (L Int) -> L Int
  72 row1 (T3 last this next)
  73   = zipWith31 elt1 (shift2 0 last)
  74                    (shift2 0 this)
  75                    (shift2 0 next)
  76
  77
  78 elt1 :: Tuple3 Int Int Int
  79         -> (Tuple3 Int Int Int)
  80         -> (Tuple3 Int Int Int) -> Int
  81 elt1 (T3 a b c) (T3 d e f) (T3 g h i)
  82  = if (not (eq tot 2))
  83           && (not (eq tot 3))
  84       then 0
  85       else if (eq tot 3) then 1 else e
  86    where tot = a `plus` b `plus` c `plus` d
  87                `plus` f `plus` g `plus` h `plus` i
  88
  89 eq :: Int -> Int -> Bool
  90 eq x y = x == y
  91
  92 plus :: Int -> Int -> Int
  93 plus x y = x + y
  94
  95 shiftr1 :: L Int -> L (L Int) -> L (L Int)
  96 shiftr1 x xs = append2 (C1 x N)  (init1 xs)
  97
  98 shiftl1 :: L Int -> L (L Int) -> L (L Int)
  99 shiftl1 x xs = append2 (tail1 xs) (C1 x N)
 100
 101 shift1 :: L Int -> L (L Int)
 102             -> L (Tuple3 (L Int) (L Int) (L Int))
 103 shift1 x xs = zip31 (shiftr1 x xs) xs (shiftl1 x xs)
 104
 105 shiftr2 :: Int -> L Int -> L Int
 106 shiftr2 x xs = append3 (C1 x N) (init2 xs)
 107
 108 shiftl2 :: Int -> L Int -> L Int
 109 shiftl2 x xs = append3 (tail2 xs) (C1 x N)
 110
 111 shift2 :: Int -> L Int -> L (Tuple3 Int Int Int)
 112 shift2 x xs = zip32 (shiftr2 x xs) xs (shiftl2 x xs)
 113
 114 -- copy
 115
 116 copy1 :: Int -> Int -> L Int
 117 copy1 0 x = N
 118 copy1 n x = C1 x (copy1 (n-1) x)
 119
 120 copy2 :: Int -> L Int -> L (L Int)
 121 copy2 0 x = N
 122 copy2 n x = C1 x (copy2 (n-1) x)
 123
 124 copy3 :: Int -> Char -> L Char
 125 copy3 0 x = N
 126 copy3 n x = C1 x (copy3 (n-1) x)
 127
 128 -- Displaying one generation
 129
 130 disp1 :: (Tuple2 (L Char) (L (L Int))) -> L Char
 131 disp1 (T2 gen xss)
 132  = append1 gen
 133     (append1 (C1 '\n' (C1 '\n' N))
 134              (foldr_1 (glue1 (C1 '\n' N)) N
 135                        (map4 (compose2 concat1 (map2 star1)) xss)))
 136
 137 star1 :: Int -> L Char
 138 star1 i = case i of
 139            0 -> C1 ' ' (C1 ' ' N)
 140            1 -> C1 ' ' (C1 'o' N)
 141
 142 glue1 :: L Char -> L Char -> L Char -> L Char
 143 glue1 s xs ys = append1 xs (append1 s ys)
 144
 145 -- Generating and displaying a sequence of generations
 146
 147 life1 :: Int -> L (L Int) -> L Char
 148 life1 n xss
 149   = foldr_1 (glue1 (copy3 (n+2) '\VT')) N
 150             (map5 disp1
 151               (zip1_ (map6 (string_ListChar.show) (ints 0))
 152                     gens))
 153     where
 154     gens = take3 (740::Int) (iterate1 (gen1 n) (initial1 n xss))
 155
 156 ints :: Int -> L Int
 157 ints x = C1 x (ints (x+1))
 158
 159 string_ListChar :: String -> L Char
 160 string_ListChar [] = N
 161 string_ListChar (x:xs) = C1 x (string_ListChar xs)
 162
 163 initial1 :: Int -> L (L Int) -> L (L Int)
 164 initial1 n xss = take1 n (append2 (map3 (compose1 (take2 n)
 165                            (`append3` (copy1 n 0))) xss)
 166                                 (copy2 n (copy1 n 0)))
 167
 168 iterate1 :: (L (L Int) -> L (L Int))
 169                -> L (L Int) -> L (L (L Int))
 170 iterate1 f x = C1 x (iterate1 f (f x))
 171
 172 -- versions of built in functions
 173
 174 -- take
 175 take1 :: Int -> L (L Int) -> L (L Int)
 176 take1 0 _ = N
 177 take1 _ N = N
 178 --should be:take1 (n+1) (C1 x xs) = C1 x (take1 n xs)
 179 take1 n (C1 x xs) | n < 0     = error "Main.take1"
 180                   | otherwise = C1 x (take1 (n-1) xs)
 181
 182 take2 :: Int -> L Int -> L Int
 183 take2 0 _ = N
 184 take2 _ N = N
 185 --should be:take2 (n+1) (C1 x xs) = C1 x (take2 n xs)
 186 take2 n (C1 x xs) | n < 0     = error "Main.take2"
 187                   | otherwise = C1 x (take2 (n-1) xs)
 188
 189 take3 :: Int -> L (L (L Int))
 190              -> L (L (L Int))
 191 take3 0 _ = N
 192 take3 _ N = N
 193 take3 n (C1 x xs) = C1 x (take3 (n-1) xs)
 194
 195 -- init
 196
 197 init1 :: L (L Int) -> L (L Int)
 198 init1 (C1 x N) = N
 199 init1 (C1 x xs) = C1 x (init1 xs)
 200 init1 N = error "init1 got a bad list"
 201
 202 init2 :: L Int -> L Int
 203 init2 (C1 x N) = N
 204 init2 (C1 x xs) = C1 x (init2 xs)
 205 init2 N = error "init1 got a bad list"
 206
 207 -- tail
 208
 209 tail1 :: L (L Int) -> L (L Int)
 210 tail1 (C1 _ xs) = xs
 211 tail1 N = error "tail1 got a bad list"
 212
 213 tail2 :: L Int -> L Int
 214 tail2 (C1 _ xs) = xs
 215 tail2 N = error "tail2 got a bad list"
 216
 217 -- maps
 218
 219 map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) ->
 220                 L (Tuple3 (L Int) (L Int) (L Int))
 221              -> L (L Int)
 222 map1 f N = N
 223 map1 f (C1 x xs) = C1 (f x) (map1 f xs)
 224
 225 map2 :: (Int -> L Char) -> L Int -> L (L Char)
 226 map2 f N = N
 227 map2 f (C1 x xs) = C1 (f x) (map2 f xs)
 228
 229 map3 :: (L Int -> L Int) -> L (L Int) -> L (L Int)
 230 map3 f N = N
 231 map3 f (C1 x xs) = C1 (f x) (map3 f xs)
 232
 233 map4 :: (L Int -> L Char)
 234          -> L (L Int) -> L (L Char)
 235 map4 f N = N
 236 map4 f (C1 x xs) = C1 (f x) (map4 f xs)
 237
 238 map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char)
 239           -> L (Tuple2 (L Char) (L (L Int)))
 240           -> L (L Char)
 241 map5 f N = N
 242 map5 f (C1 x xs) = C1 (f x) (map5 f xs)
 243
 244 map6 :: (Int -> L Char) -> L Int -> L (L Char)
 245 map6 f N = N
 246 map6 f (C1 x xs) = C1 (f x) (map6 f xs)
 247
 248 -- compose
 249
 250 compose2 :: (L (L Char) -> L Char)
 251             -> (L Int -> L (L Char))
 252             -> L Int -> L Char
 253 compose2 f g xs = f (g xs)
 254
 255 compose1 :: (L Int -> L Int)
 256              -> (L Int -> L Int) -> L Int -> L Int
 257 compose1 f g xs = f (g xs)
 258
 259 -- concat
 260
 261 concat1 :: L (L Char) -> L Char
 262 concat1 = foldr_1 append1 N
 263
 264 -- foldr
 265
 266 foldr_1 :: (L Char -> L Char -> L Char)
 267             -> L Char -> L (L Char) -> L Char
 268 foldr_1 f a N = a
 269 foldr_1 f a (C1 x xs) = f x (foldr_1 f a xs)
 270
 271 -- appends
 272
 273 append1 :: L Char -> L Char -> L Char
 274 append1 N ys = ys
 275 append1 (C1 x xs) ys = C1 x (append1 xs ys)
 276
 277 append2 :: L (L Int) -> L (L Int) -> L (L Int)
 278 append2 N ys = ys
 279 append2 (C1 x xs) ys = C1 x (append2 xs ys)
 280
 281 append3 :: L Int -> L Int -> L Int
 282 append3 N ys = ys
 283 append3 (C1 x xs) ys = C1 x (append3 xs ys)
 284
 285 -- zips
 286
 287 pzip f (C1 x1 xs) (C1 y1 ys)
 288  = C1 (f x1 y1) (pzip f xs ys)
 289 pzip f _ _ = N
 290
 291
 292 zip1_ :: L (L Char)
 293          -> L (L (L Int))
 294          -> L (Tuple2 (L Char) (L (L Int)))
 295 zip1_ = pzip T2
 296
 297 zip2_ :: L (L Int)
 298          -> L (L Int)
 299          -> L (Tuple2 (L Int) (L Int))
 300 zip2_ = pzip T2
 301
 302 zip3d :: L Int -> (Tuple2 (L Int) (L Int))
 303             -> (Tuple3 (L Int) (L Int) (L Int))
 304 zip3d x (T2 y z) = T3 x y z
 305
 306 zip3_ :: L (L Int)
 307          -> L (Tuple2 (L Int) (L Int))
 308          -> L (Tuple3 (L Int) (L Int) (L Int))
 309 zip3_ = pzip zip3d
 310
 311 zip4_ :: L Int
 312          -> L Int
 313          -> L (Tuple2 Int Int)
 314 zip4_ = pzip T2
 315
 316 zip5d :: Int -> (Tuple2 Int Int) -> (Tuple3 Int Int Int)
 317 zip5d x (T2 y z) = T3 x y z
 318
 319 zip5_ :: L Int
 320          -> L (Tuple2 Int Int)
 321          -> L (Tuple3 Int Int Int)
 322 zip5_ = pzip zip5d
 323
 324 zip6_ :: L (Tuple3 Int Int Int)
 325          -> L (Tuple3 Int Int Int)
 326          -> L (Tuple2 (Tuple3 Int Int Int)
 327                       (Tuple3 Int Int Int))
 328 zip6_ = pzip T2
 329
 330 zip31 :: L (L Int) -> L (L Int)
 331          -> L (L Int)
 332          -> L (Tuple3 (L Int) (L Int) (L Int))
 333 zip31 as bs cs
 334   = zip3_ as (zip2_ bs cs)
 335
 336 zip32 :: L Int -> L Int -> L Int
 337           -> L (Tuple3 Int Int Int)
 338 zip32 as bs cs
 339   = zip5_ as (zip4_ bs cs)
 340
 341 -- zipWith
 342
 343 zipWith21 :: ((Tuple3 Int Int Int)
 344               -> (Tuple2 (Tuple3 Int Int Int)
 345                          (Tuple3 Int Int Int)) -> Int)
 346               -> L (Tuple3 Int Int Int)
 347               -> L (Tuple2 (Tuple3 Int Int Int)
 348                            (Tuple3 Int Int Int))
 349               -> L Int
 350 zipWith21 = pzip
 351
 352 zipWith31 :: ((Tuple3 Int Int Int)
 353               -> (Tuple3 Int Int Int)
 354               -> (Tuple3 Int Int Int) -> Int)
 355                -> L (Tuple3 Int Int Int)
 356                -> L (Tuple3 Int Int Int)
 357                -> L (Tuple3 Int Int Int) -> L Int
 358 zipWith31 z as bs cs
 359  = zipWith21 z' as (zip6_ bs cs)
 360    where z' a (T2 b c) = z a b c