Last active
November 14, 2017 05:53
-
-
Save vertexcite/e28fa8cc8389646b175a to your computer and use it in GitHub Desktop.
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.)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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] | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Shrinking works better for built-in generation of random list of tuples:
(This is for version d439747)