Functional Game of Life part 3

This is the third part of a series investigating a functional solution to Conway’s Game of Life. Part 1 introduced the problem and implemented the HTML rendering of a Game of Life world using a functional style in C#. Part 2 ported the C# code from part 1 to Haskell. The job now is to implement the core of a functional Game of Life, that is a function to convert one generation of cells to the next generation of cells.

Implementing Game of Life

The type declaration for the Game of Life generation function is:

liveGeneration :: [Cell] -> [Cell]

That is, it is a function that converts a list of living cells to another list of living cells. And here is the implementation:

liveGeneration cs = [ Cell x y | x <- [0..(largestX cs) + 1], y <- [0..(largestY cs) + 1], aliveNextGeneration cs x y]

  where aliveNextGeneration cs xv yv = (isOn cs xv yv && (livingNeighbours cs xv yv) `elem` [2,3])
          || (not (isOn cs xv yv) && (livingNeighbours cs xv yv) == 3)

        livingNeighbours cs xv yv = length $ filter isNeighbour cs

          where isNeighbour (Cell xa ya)  = (xa == xv -1 && ya == yv -1)    -- top left
                                  || (xa == xv && ya == yv - 1)     -- above
                                  || (xa == xv + 1 && ya == yv -1)  -- top right 
                                  || (xa == xv - 1 && ya == yv)     -- left
                                  || (xa == xv + 1 && ya == yv)     -- right
                                  || (xa == xv - 1 && ya == yv + 1) -- bottom left
                                  || (xa == xv && ya == yv + 1)     -- below
                                  || (xa == xv + 1 && ya == yv + 1) -- bottom right

Note that the liveGeneration function depends on two other functions: aliveNextGeneration and livingNeighbours. aliveNextGeneration is a predicate that indicates if a given point (xv, yv) will be alive in the next generation. To determine if a cell will be alive in the next generation we need to know how many living neighbours it has - that is what livingNeighbours is for. livingNeighbours has its own local function isNeighbour which is a predicate that tests if a cell is a neighbour.

The following system is a classic Game of Life state known as the R-pentomino:

The following Haskell program runs the R-pentomino through 1 generation of the game of life: import Gol

rpentomino = [Cell 2 1, Cell 3 1, Cell 1 2, Cell 2 2, Cell 2 3]

main = do
  putStrLn $ render rpentomino

Producing the following output:

Ten generations:

Fifty generations:

Two hundred generations:

At this scale the inefficiency of my algorithm is exposed. Evaluating 200 generations takes a long time.

Here is the full source for my Haskell Game of Life:

module Gol 
(
  Cell(Cell),
  render,
  liveGeneration
) where

import Text.Printf
import Data.List

-- the definition of a living cell
data Cell = Cell {
    x       :: Int,
    y       :: Int
  } deriving (Show,Eq,Ord)

-- convert the state of the system to a html string
render :: [Cell] -> String
render cs = concat [renderLocation x y (isOn cs x y) | x <- [0..xBound], y <- [0..yBound]]
  where xBound = largestX cs
        yBound = largestY cs
        renderLocation xv yv on = printf 
          "<div class=\"cell %s\" style=\"left: %dpx; top: %dpx;\">&nbsp;</div>\n" 
          (if on then "on" else "") (20 * (xv+1)) (20 * (yv+1))

-- transition the system through one generation
liveGeneration :: [Cell] -> [Cell]
liveGeneration cs = [ Cell x y | x <- [0..(largestX cs) + 1], y <- [0..(largestY cs) + 1], aliveNextGeneration cs x y]

  where aliveNextGeneration cs xv yv = (isOn cs xv yv && (livingNeighbours cs xv yv) `elem` [2,3])
          || (not (isOn cs xv yv) && (livingNeighbours cs xv yv) == 3)

        livingNeighbours cs xv yv = length $ filter isNeighbour cs

          where isNeighbour (Cell xa ya)  = (xa == xv -1 && ya == yv -1)    -- top left
                                  || (xa == xv && ya == yv - 1)     -- above
                                  || (xa == xv + 1 && ya == yv -1)  -- top right 
                                  || (xa == xv - 1 && ya == yv)     -- left
                                  || (xa == xv + 1 && ya == yv)     -- right
                                  || (xa == xv - 1 && ya == yv + 1) -- bottom left
                                  || (xa == xv && ya == yv + 1)     -- below
                                  || (xa == xv + 1 && ya == yv + 1) -- bottom right

isOn :: [Cell] -> Int -> Int -> Bool
isOn cs xv yv = any cellMatch cs
  where cellMatch c = x c == xv && y c == yv

largestX :: [Cell] -> Int
largestX cs = maximum $ map x cs

largestY :: [Cell] -> Int
largestY cs = maximum $ map y cs