Conway's Game of Life and QuickCheck property based testing. Based on session with Stephen Blackheath at Global Day of Code Retreat, 15 November 2014. (Some minor tweaks since then.)

Life.hs

module Life where

import Data.Set (Set)
import qualified Data.Set as S
import Data.Foldable (foldMap)

type Cell = (Int, Int)

type World = Set Cell

candidates :: Set Cell -> Set Cell
candidates = foldMap explode

neighbourCount :: Cell -> Set Cell -> Int
neighbourCount c w = S.size $ S.filter (\x -> x `S.member` explode c) w

births :: Set Cell -> Set Cell
births w = S.filter (\c -> neighbourCount c w == 3) (candidates w)

survivors :: Set Cell -> Set Cell
survivors w = S.filter (\c -> neighbourCount c w `elem` [2,3]) w

next :: Set Cell -> Set Cell

--next = nextCorrect -- Comment out the code on either this line or the line below
next = nextBroken -- Uncomment code on this line to intentionally break things to see testing in action (though that depends on QuickCheck being lucky enough to randomly choose a case that fails)

nextCorrect :: Set Cell -> Set Cell
nextCorrect w = births w `S.union` survivors w

nextBroken :: Set Cell -> Set (Int, Int)
nextBroken w = deadpixel `S.insert` births w `S.union` survivors w where deadpixel = (15,12)

explode :: Cell -> Set Cell
explode (x,y) = S.fromList [(x+dx,y+dy) | dx <- range, dy <- range, (dx,dy) /= (0,0)]
  where range = [-1..1]

Main.hs

{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}
module Main where

import Test.QuickCheck
import Test.QuickCheck.All
import Data.Set (Set)
import qualified Data.Set as S
import Control.Monad
import Data.Maybe

import Life


prop_rules :: WorldArb -> Bool
prop_rules wa = and $ S.toList $ S.map rules allCells
  where 
    w = world wa
    w' = next w
    allCells = candidates $ blockOfCells (width wa) (height wa) `S.union` w `S.union` w'
    rules c = or [rule_overCrowding, rule_lonely, rule_survive, rule_born, rule_empty]
      where
        rule_overCrowding = alive && not alive' && n > 3
        rule_lonely       = alive  && not alive' && n < 2
        rule_survive      = alive && alive' && n `elem` [2,3]
        rule_born         = not alive && alive' && n == 3
        rule_empty        = not alive && not alive' && n /= 3
        n = neighbourCount c w
        alive  = c `S.member` w
        alive' = c `S.member` w'

prop_rules2 :: Int -> Int -> [(Int, Int)] -> Bool
prop_rules2 width' height' w = prop_rules wa
  where
    mw = massageList width' height' w
    wa = WorldArb {world = S.fromList mw, width = width', height = height'}

-- Forces random elements into the grid of dimensions width x height  
massageList :: Int -> Int -> [(Int, Int)] -> [(Int, Int)]
massageList w h = map (\(x,y) -> (if w == 0 then x else x `mod` w, if h == 0 then y else y `mod` h))


blockOfCells :: Int -> Int -> Set Cell
blockOfCells w h = S.fromList [(x,y) | x <- [0..w-1], y <- [0..h-1]]

-- Using QuickCheck's arbitrary
-- Note that prop_rules2 only tests over a fixed grid, whereas prop_rules allows QuickCheck to define the grid bounds.
-- This highlights QuickCheck's power, where it homes in on the simplest case.
-- To demonstrate this, force the implementation to have a "dead pixel" outside the usual bounds, e.g. by 
-- changing next as follows
-- next w = deadpixel `S.insert` births w `S.union` survivors w where deadpixel = (70,37)
data WorldArb = WorldArb { world :: World, width :: Int, height :: Int } deriving Show

instance Arbitrary WorldArb where
  arbitrary = do
    width' <- arbitrary
    height' <- arbitrary
    maybes <- forM (S.toList (blockOfCells width' height')) $ \c -> do
      alive <- choose (False, True)
      return $ if alive then Just c else Nothing
    return WorldArb {world = S.fromList . catMaybes $ maybes, width = width', height = height'}




--------------------------------------------------------------------------
-- main

return []
main = $quickCheckAll

--------------------------------------------------------------------------
-- the end.

Shrinking works better for built-in generation of random list of tuples:

=== prop_rules2 from Main.hs:31 ===
*** Failed! Falsifiable (after 39 tests and 5 shrinks):    
15
12
[]

(This is for version d439747)