Life

Life.hs

{-# OPTIONS_GHC -Wall #-}

module Life where

import Data.Foldable (for_)
import Control.Comonad.Store (Comonad (..), Store, peek, peeks, store)
import Data.Array ((!), Array, array, bounds)
import Data.Bool (bool)
import Data.List (transpose)

type Cell = Bool

type Point = (Int, Int)

type Life = Store Point Cell

outside :: Point -> (Point, Point) -> Bool
outside (x, y) ((lowX, lowY), (highX, highY)) =
  not (x >= lowX && y >= lowY && x <= highX && y <= highY)

fromArray :: Array Point Cell -> Life
fromArray a =
  store (\s -> not (s `outside` bounds a) && (a ! s)) (0, 0)

fromGrid :: [[Cell]] -> Life
fromGrid rows =
  fromArray $ array ((0, 0), (width, height)) $ do
    (y, row) <- zip [0 ..] rows
    (x, val) <- zip [0 ..] row
    return ((x, y), val)
  where
    width = maximum (map length rows) - 1
    height = length rows - 1

neighbours :: Life -> [Cell]
neighbours life =
  fmap
    (\(dx, dy) -> peeks (\(x, y) -> (x + dx, y + dy)) life)
    [ (-1, -1), ( 0, -1), ( 1, -1),
      (-1,  0),           ( 1,  0),
      (-1,  1), ( 0,  1), ( 1,  1)
    ]

cell :: Life -> Cell
cell life
  | alive && (livingNeighbours == 2 || livingNeighbours == 3) = True
  | not alive && livingNeighbours == 3 = True
  | otherwise = False
  where
    livingNeighbours :: Int
    livingNeighbours = sum (fmap (bool 0 1) (neighbours life))
    alive :: Bool
    alive = extract life

generation :: Life -> Life
generation = extend cell

wrap :: Int -> [a] -> [[a]]
wrap _ [] = []
wrap cols as =
  let (row, rest) = splitAt cols as
   in row : wrap cols rest

toGrid :: Int -> Int -> Life -> [[Bool]]
toGrid cols rows life =
  let coords = (,) <$> [0 .. rows - 1] <*> [0 .. cols - 1]
   in transpose $ wrap rows $ fmap (`peek` life) coords

showLife :: Int -> Int -> Life -> String
showLife cols rows =
  unlines . (map . map) (bool '.' '*') . toGrid cols rows

live :: Life -> [Life]
live = iterate generation

blinker :: Life
blinker =
  fromGrid
    [ [False, False, False, False, False]
    , [False, False, False, False, False]
    , [False, True,  True,  True,  False]
    , [False, False, False, False, False]
    , [False, False, False, False, False]
    ]

main :: IO ()
main = for_ (take 10 (live blinker)) $ \gen ->
  putStrLn $ showLife 5 5 gen