0
\$\begingroup\$

I've written a sort of library in Haskell to help create cellular automata by specifying the rules and the data-type of each cell. The problem is, it runs extremely slowly on larger "boards". A 64x64 board will run at maybe 10-20 steps per second, but a 256x256 board will at more like 0.3 steps per second.

This is the case when I compile the program with the -O2 flag to optimize the executable further, and without that it's even slower.

My first thoughts on what is slowing down my program were:

  • Making a new 256x256 [[Bool]] each step, or
  • Accessing the cells, since Haskell lists are linked lists.

But of course, it may well be something else slowing it down. Any ideas on what this might be, and how I could speed it up?

This is the library code:

module Automaton (
    Rule,
    Pos,
    Board,
    Palette,
    newBoard,
    showBoard,
    width,
    height,
    at,
    set,
    step,
    neighbours,
    countNeighbours,
    gol,
    checkerboard,
    option,
    renderBoard,
    nthStep,
    steps,
    random,
    randomWith
) where

import Data.Maybe
import Data.List
import Control.Monad
import Control.Monad.State
import Graphics.GD
import System.Random (randomRIO, Random)

type Rule a = Pos -> Board a -> a -> a
type Pos = (Int, Int)
type Palette a = a -> Color

newtype Board a = Board { getBoard :: [[a]] }

instance Functor Board where
    fmap f b = Board [[f v | v <- r] | r <- getBoard b]

newBoard :: Int -> Int -> (Pos -> a) -> Board a
newBoard width height gen = Board [[gen (x, y) | x <- [0..width-1]] | y <- [0..height-1]]

showBoard :: (a -> String) -> Board a -> String
showBoard fn = unlines . map (concatMap fn) . getBoard

width :: Board a -> Int
width = length . head . getBoard

height :: Board a -> Int
height = length . getBoard

size :: Board a -> (Int, Int)
size = (,) <$> width <*> height

set :: Pos -> a -> State (Board a) ()
set pos to = state $ \b -> ((), newBoard (width b) (height b) $ \c ->
    if pos == c then
        to
    else
        b `at` c)

wrap :: Pos -> Board a -> Pos
wrap (x, y) board = (x', y')
    where (w, h) = size board
          x' = if x < 0 then x + w else if x >= w then x - w else x
          y' = if y < 0 then y + h else if y >= h then y - h else y

at :: Board a -> Pos -> a
board `at` pos = let cells = getBoard board in (cells !! y) !! x
    where (x, y) = wrap pos board

step :: Rule a -> Board a -> Board a
step rule board = Board [[rule (x, y) board (board `at` (x, y)) | x <- [0..(width board)-1]] | y <- [0..(height board)-1]]

neighbours :: Board a -> Pos -> [a]
neighbours board (x, y) = map (board `at`)
    [(x-1, y-1), (x, y-1), (x+1, y-1), (x-1, y), (x+1, y), (x-1, y+1), (x, y+1), (x+1, y+1)]

countNeighbours :: (Eq a) => (a -> Bool) -> Board a -> Pos -> Int
countNeighbours pred board pos = count pred $ neighbours board pos

count :: (Eq a, Foldable t) => (a -> Bool) -> t a -> Int
count pred = foldl foldingFunction 0
    where foldingFunction total val = if pred val then total + 1 else total

gol :: Rule Bool
gol pos board True = let n = countNeighbours id board pos in n == 2 || n == 3
gol pos board False = let n = countNeighbours id board pos in n == 3

checkerboard :: Int -> Int -> a -> a -> Board a
checkerboard width height a b = newBoard width height $ \(x, y) ->
    if even $ x + y then a else b

random :: (Random a) => Int -> Int -> (a, a) -> IO (Board a)
random width height range = do
    contents <- replicateM height $ replicateM width $ randomRIO range
    return (Board contents)

randomWith :: Int -> Int -> Int -> (Int -> a) -> IO (Board a)
randomWith width height states fn = do
    codedContents <- random width height (1, states) :: IO (Board Int)
    let contents = map (map fn) $ getBoard codedContents
    return (Board contents)

option :: a -> a -> (Bool -> a)
option t f True = t
option t f False = f

steps :: Rule a -> Board a -> [Board a]
steps = iterate . step

nthStep :: Int -> Rule a -> Board a -> Board a
nthStep n rule = last . take n . iterate (step rule)

renderBoard :: Palette a -> Board a -> IO Image
renderBoard palette board = do
    let boardSize@(w, h) = size board
    img <- newImage boardSize
    sequence [setPixel (x, y) (palette v) img | (y, r) <- zip [0..] (getBoard board), (x, v) <- zip [0..] r]
    return img

And this is some code which I wrote to use the library:

import Automaton
import Graphics.GD
import Control.Monad
import Control.Monad.State
import Data.List

coolThing :: Rule Bool
coolThing pos board True = let n = countNeighbours id board pos in n == 2 || n == 4 || n == 6
coolThing pos board False = let n = countNeighbours id board pos in n == 3 || n == 5 || n == 7

main = do
    myBoard <- random 256 256 (False, True)

    forM_ (zip [1..] $ take 256 $ steps coolThing myBoard) $ \(i, b) -> do
        img <- renderBoard (option (rgb 30 30 30) (rgb 100 100 100)) b
        savePngFile ("out/" ++ show i ++ ".png") img
        putStrLn $ "finished " ++ show i
\$\endgroup\$
  • 1
    \$\begingroup\$ Sure looks like the accessing to me. Try Data.Map or zipping with a shifted board. \$\endgroup\$ – Gurkenglas Feb 26 at 21:59
  • \$\begingroup\$ @Gurkenglas Data.Map is an interesting idea, I never considered that but it seems that it should work perfectly. I'll give it a go now. \$\endgroup\$ – Zac Feb 26 at 22:10

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.