--- /dev/null
+--------------------------------
+-- The Game of Life --
+--------------------------------
+
+generations x = 30
+
+data L a = N | C1 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 (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
projects / ghc-hetmet.git / blobdiff