GameOfLife.hs

GameOfLife.hs

{-
adapted frm https://github.com/psfblair/ConwayLife/blob/master/LifeCore/Life.fs
-}
module GameOfLife where

import Data.Set
import qualified Data.Set as Set
import Test.Hspec
import Test.HUnit

type Cell              = (Int,Int)
type Generation        = Set Cell
type LiveCells         = Set Cell
type IsAlive           = Bool
type LiveNeighborCount = Int
type CellState         = (Cell, IsAlive, LiveNeighborCount)


survives :: CellState -> Bool
survives (c,i,n)
  | n == 3      = True
  | i && n == 2 = True
  | otherwise   = False

neighborhood :: Cell -> Set Cell
neighborhood (cx,cy) = Set.fromList [(x,y) | x <- [cx-1..cx+1], y <- [cy-1..cy+1]]

neighbors :: Cell -> Set Cell
neighbors c = Set.delete c (neighborhood c)

cellState :: LiveCells -> Cell -> CellState
cellState ls c = 
  let n = Set.size $ Set.intersection (neighbors c) ls 
      a = Set.member c ls
  in (c,a,n)

nextGen :: Generation -> Generation
nextGen g = 
  let allCells =  Set.foldl (\acc s -> Set.union acc s) Set.empty $ Set.map neighborhood g
      cellStates = Set.map (cellState g) allCells
      survivors = Set.toList $ Set.filter survives cellStates
  in Set.fromList $ [c | (c,_,_) <- survivors]


{-
Still lifes
-}
block   = Set.fromList [(1,1),(1,2),(2,1),(2,2)] :: Generation
beehive = Set.fromList [(1,2),(2,1),(3,1),(2,3),(3,3),(4,2)] :: Generation
loaf    = Set.fromList [(1,3),(2,2),(3,1),(4,2),(4,3),(3,4),(2,4)] :: Generation
boat    = Set.fromList [(1,2),(1,3),(2,1),(2,3),(3,2)] :: Generation
{-
Blinkers
-}
blinker  = Set.fromList[(1,2),(2,2),(3,2)] :: Generation
blinker' = Set.fromList[(2,1),(2,2),(2,3)] :: Generation
beacon   = Set.fromList[(1,1),(1,2),(2,1),(2,2),(3,3),(3,4),(4,3),(4,4)] :: Generation
beacon'  = Set.fromList[(1,1),(1,2),(2,1),(3,4),(4,3),(4,4)] :: Generation
toad     = Set.fromList[(1,2),(2,2),(3,2),(2,3),(3,3),(4,3)] :: Generation
toad'    = Set.fromList[(2,1),(1,2),(1,3),(3,4),(4,2),(4,3)] :: Generation
{- 
Gliders
-}
glider   = Set.fromList[(1,1),(2,1),(3,1),(3,2),(2,3)] :: Generation

shiftX :: Int -> Generation -> Generation
shiftX n g = Set.map (\(x,y) -> (x+n, y)) g

shiftY :: Int -> Generation -> Generation
shiftY n g = Set.map (\(x,y) -> (x, y+n)) g

xGens :: Int -> Generation -> Generation
xGens 0 g = g
xGens x g = xGens (x - 1) (nextGen g)


main :: IO ()
main = hspec spec

spec :: Spec
spec = do

  describe "Game Of Life" $ do  

    context "still lifes" $ do
      it "block is a still life" $ do
        nextGen block `shouldBe` block
      it "beehive is a still life" $ do
        nextGen beehive `shouldBe` beehive
      it "loaf is a still life" $ do
        nextGen loaf `shouldBe` loaf
      it "boat is a still life" $ do
        nextGen boat `shouldBe` boat

    context "blinkers" $ do
      it "blinker oscillates with period 2" $ do
        nextGen blinker `shouldBe` blinker'
      it "beacon oscillates with period 2" $ do
        nextGen beacon `shouldBe` beacon'
      it "toad oscillates with period 2" $ do
        nextGen toad `shouldBe` toad'

    context "gliders" $ do
      it "classic glider has period 4 and travels diagonally" $ do
        let glider' = shiftY (-1) $ shiftX 1 glider
        xGens 4 glider `shouldBe` glider'