lifegame.hs

import System.Random (RandomGen, getStdGen, randoms)
import Control.Concurrent (threadDelay)
import System.Process (callCommand)
import Data.List.Split (chunksOf)
import Data.Maybe (fromMaybe)

type Cell = Bool
type CellTable = [[Cell]]
type Score = Int
type Pos = (Int, Int)
type Size = (Int, Int)
type Game = (CellTable, Size)

main :: IO ()
main = do
  gen <- getStdGen
  let interval = 50 * 1000
  let size = (20, 10)
  let initialCellTable = randomCellTable gen size
  foreverWithInterval interval (initialCellTable, size) printCellsAndNext

printCellsAndNext :: Game -> IO Game
printCellsAndNext game@(cellTable, size) = do
  clearScreen
  cellTable |> showCellTable |> putStr
  return (nextCellTable game, size)
  where
    clearScreen = callCommand "clear"

randomCellTable :: (RandomGen g) => g -> Size -> CellTable
randomCellTable gen (w, h) = gen |> randoms |> take (w * h) |> chunksOf w

getCell :: Game -> Pos -> Maybe Cell
getCell (cellTable, (w, h)) (x, y) =
  if x < 0 || x == w || y < 0 || y == h
    then Nothing
    else Just (cellTable !! y !! x)

showCellTable :: CellTable -> String
showCellTable cellTable = cellTable $> (concatMap showCell) |> unlines
  where
    showCell True = "■"
    showCell False = "□"

nextCellTable :: Game -> CellTable
nextCellTable game@(cellTable, _) = cellTable |> zipIndex2 $>> \(pos, cell) -> nextCell (cellScore game pos) cell

nextCell :: Score -> Cell -> Cell
nextCell score False = score == 3
nextCell 0     True  = False
nextCell 1     True  = False
nextCell 2     True  = True
nextCell 3     True  = True
nextCell _     True  = False

cellScore :: Game -> Pos -> Score
cellScore game pos = aroundCells game pos $> fromMaybe False |> filter id |> length

aroundCells :: Game -> Pos -> [Maybe Cell]
aroundCells game (x, y) =
  [(x - 1, y - 1),
   (x    , y - 1),
   (x + 1, y - 1),
   (x - 1, y    ),
   (x + 1, y    ),
   (x - 1, y + 1),
   (x    , y + 1),
   (x + 1, y + 1)] $> getCell game

-- Utilities

(|>) :: a -> (a -> b) -> b
x |> f = f x

x $> f = f <$> x
($>) :: Functor f => f a -> (a -> b) -> f b

($>>) :: Functor f => f (f a) -> (a -> b) -> f (f b)
x $>> f = ((<$>).(<$>)) f x

map2 :: (a -> b) -> [[a]] -> [[b]]
map2 = map . map

zipIndex :: [a] -> [(Int, a)]
zipIndex = zip [0..]

zipIndex2 :: [[a]] -> [[((Int, Int), a)]]
zipIndex2 xss = xss |> zipIndex $> \(i, xs) -> i |> repeat |> zipIndex |> \ys -> zip ys xs

foreverWithInterval :: Int -> a -> (a -> IO a) -> IO ()
foreverWithInterval interval x action = do
  threadDelay interval
  x' <- action x
  foreverWithInterval interval x' action
  return ()