--------------------------------
--      The Game of Life      --
--------------------------------

generations x = 30

data L a = N | C1 a (L a) | C2 a a (L a)

data Tuple2 a b = T2 a b

data Tuple3 a b c = T3 a b c


main = putStr (listChar_string
                    (append1 (C1 '\FF' N)
                             (life1 (generations ()) (start ()))))

listChar_string :: L Char -> String
listChar_string N = []
listChar_string (C1 x xs) = x : listChar_string xs

start :: a -> L (L Int)
start x = (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1 N
          (C1
           (C1 0
           (C1 0
           (C1 0
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 0
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 0
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 0
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 1
           (C1 0 N))))))))))))))))))))))))))) N)))))))))))))))

-- Calculating the next generation

gen1 :: Int -> L (L Int) -> L (L Int)
gen1 n board = map1 row1 (shift1 (copy1 n 0) board)

row1 :: Tuple3 (L Int) (L Int) (L Int) -> L Int
row1 (T3 last this next)
  = zipWith31 elt1 (shift2 0 last)
                   (shift2 0 this)
                   (shift2 0 next)


elt1 :: Tuple3 Int Int Int
        -> (Tuple3 Int Int Int)
        -> (Tuple3 Int Int Int) -> Int
elt1 (T3 a b c) (T3 d e f) (T3 g h i)
 = if (not (eq tot 2))
          && (not (eq tot 3))
      then 0
      else if (eq tot 3) then 1 else e
   where tot = a `plus` b `plus` c `plus` d
               `plus` f `plus` g `plus` h `plus` i

eq :: Int -> Int -> Bool
eq x y = x == y

plus :: Int -> Int -> Int
plus x y = x + y

shiftr1 :: L Int -> L (L Int) -> L (L Int)
shiftr1 x xs = append2 (C1 x N)  (init1 xs)

shiftl1 :: L Int -> L (L Int) -> L (L Int)
shiftl1 x xs = append2 (tail1 xs) (C1 x N)

shift1 :: L Int -> L (L Int)
            -> L (Tuple3 (L Int) (L Int) (L Int))
shift1 x xs = zip31 (shiftr1 x xs) xs (shiftl1 x xs)

shiftr2 :: Int -> L Int -> L Int
shiftr2 x xs = append3 (C1 x N) (init2 xs)

shiftl2 :: Int -> L Int -> L Int
shiftl2 x xs = append3 (tail2 xs) (C1 x N)

shift2 :: Int -> L Int -> L (Tuple3 Int Int Int)
shift2 x xs = zip32 (shiftr2 x xs) xs (shiftl2 x xs)

-- copy

copy1 :: Int -> Int -> L Int
copy1 0 x = N
copy1 n x = C1 x (copy1 (n-1) x)

copy2 :: Int -> L Int -> L (L Int)
copy2 0 x = N
copy2 n x = C1 x (copy2 (n-1) x)

copy3 :: Int -> Char -> L Char
copy3 0 x = N
copy3 n x = C1 x (copy3 (n-1) x)

-- Displaying one generation

disp1 :: (Tuple2 (L Char) (L (L Int))) -> L Char
disp1 (T2 gen xss)
 = append1 gen
    (append1 (C1 '\n' (C1 '\n' N))
             (foldr_1 (glue1 (C1 '\n' N)) N
                       (map4 (compose2 concat1 (map2 star1)) xss)))

star1 :: Int -> L Char
star1 i = case i of
           0 -> C1 ' ' (C1 ' ' N)
           1 -> C1 ' ' (C1 'o' N)

glue1 :: L Char -> L Char -> L Char -> L Char
glue1 s xs ys = append1 xs (append1 s ys)

-- Generating and displaying a sequence of generations

life1 :: Int -> L (L Int) -> L Char
life1 n xss
  = foldr_1 (glue1 (copy3 (n+2) '\VT')) N
            (map5 disp1
              (zip1_ (map6 (string_ListChar.show) (ints 0))
                    gens))
    where
    gens = take3 (100 {-740-}::Int) (iterate1 (gen1 n) (initial1 n xss))

ints :: Int -> L Int
ints x = C1 x (ints (x+1))

string_ListChar :: String -> L Char
string_ListChar [] = N
string_ListChar (x:xs) = C1 x (string_ListChar xs)

initial1 :: Int -> L (L Int) -> L (L Int)
initial1 n xss = take1 n (append2 (map3 (compose1 (take2 n)
                           (`append3` (copy1 n 0))) xss)
                                (copy2 n (copy1 n 0)))

iterate1 :: (L (L Int) -> L (L Int))
               -> L (L Int) -> L (L (L Int))
iterate1 f x = C1 x (iterate1 f (f x))

-- versions of built in functions

-- take
take1 :: Int -> L (L Int) -> L (L Int)
take1 0 _ = N
take1 _ N = N
--should be:take1 (n+1) (C1 x xs) = C1 x (take1 n xs)
take1 n (C1 x xs) | n < 0     = error "Main.take1"
                  | otherwise = C1 x (take1 (n-1) xs)

take2 :: Int -> L Int -> L Int
take2 0 _ = N
take2 _ N = N
--should be:take2 (n+1) (C1 x xs) = C1 x (take2 n xs)
take2 n (C1 x xs) | n < 0     = error "Main.take2"
                  | otherwise = C1 x (take2 (n-1) xs)

take3 :: Int -> L (L (L Int))
             -> L (L (L Int))
take3 0 _ = N
take3 _ N = N
take3 n (C1 x xs) = C1 x (take3 (n-1) xs)

-- init

init1 :: L (L Int) -> L (L Int)
init1 (C1 x N) = N
init1 (C1 x xs) = C1 x (init1 xs)
init1 N = error "init1 got a bad list"

init2 :: L Int -> L Int
init2 (C1 x N) = N
init2 (C1 x xs) = C1 x (init2 xs)
init2 N = error "init1 got a bad list"

-- tail

tail1 :: L (L Int) -> L (L Int)
tail1 (C1 _ xs) = xs
tail1 N = error "tail1 got a bad list"

tail2 :: L Int -> L Int
tail2 (C1 _ xs) = xs
tail2 N = error "tail2 got a bad list"

-- maps

map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) ->
                L (Tuple3 (L Int) (L Int) (L Int))
             -> L (L Int)
map1 f N = N
map1 f (C1 x xs) = C1 (f x) (map1 f xs)

map2 :: (Int -> L Char) -> L Int -> L (L Char)
map2 f N = N
map2 f (C1 x xs) = C1 (f x) (map2 f xs)

map3 :: (L Int -> L Int) -> L (L Int) -> L (L Int)
map3 f N = N
map3 f (C1 x xs) = C1 (f x) (map3 f xs)

map4 :: (L Int -> L Char)
         -> L (L Int) -> L (L Char)
map4 f N = N
map4 f (C1 x xs) = C1 (f x) (map4 f xs)

map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char)
          -> L (Tuple2 (L Char) (L (L Int)))
          -> L (L Char)
map5 f N = N
map5 f (C1 x xs) = C1 (f x) (map5 f xs)

map6 :: (Int -> L Char) -> L Int -> L (L Char)
map6 f N = N
map6 f (C1 x xs) = C1 (f x) (map6 f xs)

-- compose

compose2 :: (L (L Char) -> L Char)
            -> (L Int -> L (L Char))
            -> L Int -> L Char
compose2 f g xs = f (g xs)

compose1 :: (L Int -> L Int)
             -> (L Int -> L Int) -> L Int -> L Int
compose1 f g xs = f (g xs)

-- concat

concat1 :: L (L Char) -> L Char
concat1 = foldr_1 append1 N

-- foldr

foldr_1 :: (L Char -> L Char -> L Char)
            -> L Char -> L (L Char) -> L Char
foldr_1 f a N = a
foldr_1 f a (C1 x xs) = f x (foldr_1 f a xs)

-- appends

append1 :: L Char -> L Char -> L Char
append1 N ys = ys
append1 (C1 x xs) ys = C1 x (append1 xs ys)

append2 :: L (L Int) -> L (L Int) -> L (L Int)
append2 N ys = ys
append2 (C1 x xs) ys = C1 x (append2 xs ys)

append3 :: L Int -> L Int -> L Int
append3 N ys = ys
append3 (C1 x xs) ys = C1 x (append3 xs ys)

-- zips

pzip f (C1 x1 xs) (C1 y1 ys)
 = C1 (f x1 y1) (pzip f xs ys)
pzip f _ _ = N


zip1_ :: L (L Char)
         -> L (L (L Int))
         -> L (Tuple2 (L Char) (L (L Int)))
zip1_ = pzip T2

zip2_ :: L (L Int)
         -> L (L Int)
         -> L (Tuple2 (L Int) (L Int))
zip2_ = pzip T2

zip3d :: L Int -> (Tuple2 (L Int) (L Int))
            -> (Tuple3 (L Int) (L Int) (L Int))
zip3d x (T2 y z) = T3 x y z

zip3_ :: L (L Int)
         -> L (Tuple2 (L Int) (L Int))
         -> L (Tuple3 (L Int) (L Int) (L Int))
zip3_ = pzip zip3d

zip4_ :: L Int
         -> L Int
         -> L (Tuple2 Int Int)
zip4_ = pzip T2

zip5d :: Int -> (Tuple2 Int Int) -> (Tuple3 Int Int Int)
zip5d x (T2 y z) = T3 x y z

zip5_ :: L Int
         -> L (Tuple2 Int Int)
         -> L (Tuple3 Int Int Int)
zip5_ = pzip zip5d

zip6_ :: L (Tuple3 Int Int Int)
         -> L (Tuple3 Int Int Int)
         -> L (Tuple2 (Tuple3 Int Int Int)
                      (Tuple3 Int Int Int))
zip6_ = pzip T2

zip31 :: L (L Int) -> L (L Int)
         -> L (L Int)
         -> L (Tuple3 (L Int) (L Int) (L Int))
zip31 as bs cs
  = zip3_ as (zip2_ bs cs)

zip32 :: L Int -> L Int -> L Int
          -> L (Tuple3 Int Int Int)
zip32 as bs cs
  = zip5_ as (zip4_ bs cs)

-- zipWith

zipWith21 :: ((Tuple3 Int Int Int)
              -> (Tuple2 (Tuple3 Int Int Int)
                         (Tuple3 Int Int Int)) -> Int)
              -> L (Tuple3 Int Int Int)
              -> L (Tuple2 (Tuple3 Int Int Int)
                           (Tuple3 Int Int Int))
              -> L Int
zipWith21 = pzip

zipWith31 :: ((Tuple3 Int Int Int)
              -> (Tuple3 Int Int Int)
              -> (Tuple3 Int Int Int) -> Int)
               -> L (Tuple3 Int Int Int)
               -> L (Tuple3 Int Int Int)
               -> L (Tuple3 Int Int Int) -> L Int
zipWith31 z as bs cs
 = zipWith21 z' as (zip6_ bs cs)
   where z' a (T2 b c) = z a b c