Cellular automata playground made in 2.5 days. For use in http://elm-lang.org/try and a good starting off point for making your own automatons with unique rules. Obviously could use some refactoring into separate modules for outside the browser...

GameOfLife.elm

import Array exposing (Array(..), append, get, set, length)
import Color exposing (black, white, darkGrey)
import Graphics.Element exposing (..)
import Html exposing (..)
import Html.Attributes as Attr exposing (..)
import Html.Events exposing (..)
import Maybe exposing (withDefault, andThen)
import Mouse
import Random exposing (generate)
import Result
import Signal
import String
import Task exposing (Task)
import Time exposing (Time, fps)


main : Signal Element
main = 
  Signal.map3 view 
    (Signal.map (withDefault defaultGrid << List.head << fst) history)
    animationPlaying.signal
    animationSpeed.signal


-- UPDATE

update : Input -> Model -> Model
update ({action, position, time} as input) model =
  let
    action' =
      if action == Toggle && not (inGrid model position)
        then None
        else action
  in case action' of
    None -> identity model
    Undo -> undo model
    Redo -> redo model
    otherwise -> 
      model >>= handle { input | action = action' }


handle : Input -> Grid -> Model
handle {action, position, time} =
  return <<
    case action of
      Toggle -> maybeToggle `ap` overCell position
      Step   -> evolve
      Unstep -> unevolve
      IncRow -> alterGrid Row Push
      IncCol -> alterGrid Col Push
      DecRow -> alterGrid Row Pop
      DecCol -> alterGrid Col Pop
      Clear  -> clear
      Generate -> randomizeGrid <| Random.initialSeed <| round time
      otherwise -> identity


undo : Model -> Model
undo model =
  case model of
    ([], hs)    -> ([], hs)
    ([g], hs)   -> ([g], hs)
    (g::gs, hs) -> (gs, g::hs)


redo : Model -> Model
redo model =
  case model of
    (gs, [])    -> (gs, [])
    (gs, h::hs) -> (h::gs, hs)


type Dim = Row | Col
type Op = Push | Pop

alterGrid : Dim -> Op -> Grid -> Grid
alterGrid dim op =
  \((Grid rows) as g) ->
    let
      (ncol, nrow) = dims g
    in
      case (dim, op) of
        (Row, Push) ->
          Grid <| Array.push (Array.repeat ncol False) rows
          
        (Row, Pop) ->
          Grid <| Array.slice 0 (nrow - 1) rows
        
        (Col, Push) ->
          Grid <| Array.map (Array.push False) rows
          
        (Col, Pop) ->
          Grid <| Array.map (Array.slice 0 (ncol - 1)) rows


clear : Grid -> Grid
clear (Grid rows) =
  Grid <| mapArray2 (always False) rows


-- VIEW

(=>) = (,)


view : Grid -> AnimationState -> AnimationSpeed -> Element
view ((Grid rows) as g) state speed =
  let
    (width, height) = dims g
    
    gridElem =
      flow down <|
        spacer 2 2 ::
        rowLine width ::
        (Array.toList <| Array.map drawRow rows)
        
    buttonStyle extras =
      style <|
        [ "width" => "calc(100% * (1/2) - 4px)"
        , "margin" => "2px"
        , "font-size" => "85%"
        ] ++ extras
    
    btn attr action txt =
      [ button
        ([ class "pure-button"
         , buttonStyle []
         , onClick formInput.address action
         ] ++ attr
        )[ text txt ]
      ]
    
    tog attr txt1 txt2 =
      [ label
        ([ for "state"
         , class "pure-button pure-button-primary"
         , buttonStyle []
         ] ++ attr
        ) [ text <| if state then txt1 else txt2 ]
      , input
        [ type' "checkbox"
        , id "state"
        , hidden True
        , onClick animationPlaying.address <| toggleAnimation state
        ] []
      ]
        
    slider name =
      [ label
        [ for name
        , style
          [ "width" => "calc(100% * (3/7) - 4px)"
          , "margin" => "2px"
          , "font-size" => "95%"
          ]
        ] [ text (name ++ ": " ++ toString speed) ]
      , input
        [ type' "range"
        , id name
        , Attr.min "1"
        , Attr.max <| toString maxSpeed
        , value <| toString speed
        , on "input" targetValue setSpeed
        , style
          [ "width" => "calc(100% * (4/7) - 4px)"
          , "margin" => "2px"
          ]
        ] []
      ]

    d = disabled True
    
    formElem =
      toElement 160 77 <|
        div 
          [ style
            [ "display" => "flex"
            , "flex-wrap" => "wrap"
            ]
          ] <| List.concat
          [ tog []            "Stop" "Play"
        --, btn [d]  Unstep   "<<"
          , btn []   Step     ">>"
          , slider            "Speed"
          , btn []   Clear    "Clear"
          , btn []   Generate "Random"
          , btn []   Undo     "Undo"
          , btn []   Redo     "Redo"
          , btn []   IncRow   "+ Row"
          , btn []   IncCol   "+ Col"
          , btn []   DecRow   "- Row"
          , btn []   DecCol   "- Col"
          ]
  in
    flow right
      [ toElement 0 0 <| 
          node "link" 
            [ rel "stylesheet"
            , href "http://yui.yahooapis.com/pure/0.6.0/pure-min.css"
            ] []
      , formElem
      , gridElem
      ]


rowLine : Int -> Element
rowLine cols =
  let
    x = toWidth cols
    y = gridLine
  in
    spacer x y
      |> color darkGrey


colLine : Element
colLine =
  spacer gridLine cellSize
    |> color darkGrey


drawCell : Bool -> Element
drawCell pred =
  spacer cellSize cellSize
    |> color (if pred then black else white)


drawRow : Array Bool -> Element
drawRow row =
  flow down
    [ row
        |> Array.map drawCell
        |> Array.toList
        |> surround colLine
        |> flow right
    , rowLine <| 
        Array.length row
    ]


-- MODEL

type alias Model = (List Grid, List Grid)

history : Signal Model
history = 
  Signal.foldp update (return defaultGrid) inputSignal


-- Model monad
return : Grid -> Model
return grid =
  ([grid], [])
  
(>>=) : Model -> (Grid -> Model) -> Model
(>>=) m f =
  case m of
    ([], hs) -> Debug.crash "Error: lost the grid!"
    (g::gs, _) ->
      let
        (g',_) = f g
      in
        (g' ++ g::gs, [])


-- Grid

type Grid = Grid (Array (Array Bool))

type alias Cell = 
  { row : Int
  , col : Int
  }

topLeft = (161, 2)

cellSize = 25
gridLine = 1


defaultGrid : Grid
defaultGrid =
  let t = [True]
      f = [False]
      do = List.repeat
      from = Array.fromList << List.concat
  in  Grid << Array.fromList << List.map from <|
    [ [do 15 False]
    , [do 3 False, do 3 True, do 3 False, do 3 True, do 3 False]
    , [do 15 False]
    , [f, t, do 4 False, t, f, t, do 4 False, t, f]
    , [f, t, do 4 False, t, f, t, do 4 False, t, f]
    , [f, t, do 4 False, t, f, t, do 4 False, t, f]
    , [do 3 False, do 3 True, do 3 False, do 3 True, do 3 False]
    ]
  
  
dims : Grid -> (Int, Int)
dims (Grid g) =
  let
    y = length g
    x = g |> get 0 |> Maybe.map length |> withDefault 0
  in
    (x, y)


inGrid : Model -> (Int, Int) -> Bool
inGrid model pos =
  let
    grid = withDefault (Grid Array.empty) <| List.head <| fst model
  in
    overCell pos grid /= Nothing


overCell : (Int, Int) -> Grid -> Maybe Cell
overCell (x, y) g =
  let
    relX = x - fst topLeft
    relY = y - snd topLeft
    row = relY // (cellSize + gridLine)
    col = relX // (cellSize + gridLine)
    (cols, rows) = dims g
  in
    if row < rows && col < cols && Basics.min relX relY >= 0
      then Just <| Cell row col
      else Nothing


maybeToggle : Maybe Cell -> Grid -> Grid
maybeToggle maybe =
  case maybe of
    Nothing -> identity
    Just {row, col} ->
      \(Grid rows) -> Grid <|
        arrUpdate row (arrUpdate col not) rows


arrUpdate : Int -> (a -> a) -> Array a -> Array a
arrUpdate index update arr =
  case Array.get index arr of
    Just val ->
      Array.set index (update val) arr
    Nothing ->
      Debug.crash <| 
        "Cannot access index " ++ 
        toString index ++ " of " ++ 
        toString arr


-- INPUT

type alias Input =
  { action : Action
  , position : (Int, Int)
  , time : Time
  }


clickAction : Signal Action
clickAction =
  Signal.merge
    (Signal.map (always Toggle) Mouse.clicks)
    formInput.signal


inputSignal : Signal Input
inputSignal =
  Signal.sampleOn clickAction <|
    Signal.map3 Input
      clickAction
      Mouse.position
      time


type Action 
  = None   | Toggle
  | Step   | Unstep
  | Clear  | Generate
  | Undo   | Redo
  | IncRow | IncCol 
  | DecRow | DecCol


formInput : Signal.Mailbox Action
formInput =
  Signal.mailbox None


-- Animation

type alias AnimationState = Bool
type alias AnimationSpeed = Int

animationPlaying : Signal.Mailbox AnimationState
animationPlaying =
  Signal.mailbox False

toggleAnimation state =
  not state

animationSpeed : Signal.Mailbox AnimationSpeed
animationSpeed =
  Signal.mailbox 1

maxSpeed = 15

setSpeed str =
  let speed = String.toInt str |> Result.toMaybe |> withDefault 1
  in  Signal.message animationSpeed.address speed

sendWithCounter frames address message =
  let
    maybeStep playing t =
      if playing
        then Just <| Signal.send address message
        else Nothing
    
    framesPerSecond n =
      Signal.filterMap identity (Task.succeed ()) <|
        Signal.map2 maybeStep
          animationPlaying.signal
          (fps n)
  in
    Signal.foldp 
      (\task (acc, _) -> (acc+1, task))
      (0, Task.succeed ())
      (framesPerSecond frames)


port animate : Signal (Task x ())
port animate =
  let   
    scalePlayback (count, task) speed playing =
      if playing && count % (maxSpeed - speed + 1) == 0 
        then (count // (maxSpeed - speed + 1), task)
        else (0, Task.succeed ())
        
    dedupCounter (t1, task) (t2, _) =
      if t1 /= t2
        then (t1, task)
        else (t1, Task.succeed ())
  in
    Signal.map snd <|
    Signal.foldp dedupCounter (-1, Task.succeed()) <|
    Signal.map3 scalePlayback
      (sendWithCounter maxSpeed formInput.address Step)
      animationSpeed.signal
      animationPlaying.signal


-- GAME OF LIFE

type alias Dist = Int
type alias Alive = Bool
type alias Neighborhood = List (Dist, Alive)
type alias Rule = (Alive, Neighborhood) -> Alive
type alias Array2 a = Array (Array a)
type alias NeighborhoodGrid = Array2 (Alive, Neighborhood)

evolve : Grid -> Grid
evolve grid =
  Grid <| mapArray2 (applyRules rules) (neighborhood grid)


neighborhood : Grid -> NeighborhoodGrid
neighborhood (Grid rows) =
  let
    locs = List.map (,) [0, 1, -1] `andMap` [0, 1, -1] |> List.drop 1
    
    getByRel (c, r) (x, y) =
      Array.get (r - y) rows `andThen` Array.get (c - x)
    
    neighbors from alive =
      \rows ->
        List.map (getByRel from) locs
          |> filterMaybe
          |> List.map ((,) 1)
          |> (,) alive
  in
    rows
      |> indexedMapArray2 neighbors
      |> mapArray2 (\f -> f rows)


rules : List Rule
rules =
  let living = List.foldl (\(d,p) acc -> if p then acc + 1 else acc) 0
  in  [ (\(p, nbs) -> p && living nbs == 2)
      , (\(p, nbs) -> p && living nbs == 3)
--      , (\(p, nbs) -> p && living nbs == 2)
      , (\(p, nbs) -> not p && living nbs == 3)
      ]


applyRules : List Rule -> (Alive, Neighborhood) -> Alive
applyRules rules x =
  let any = List.member True
  in  any <| List.map (\f -> f x) rules


unevolve : Grid -> Grid
unevolve grid =
  Grid <| mapArray2 
    (applyRules <| List.map ((<<) not) rules)
    (neighborhood grid)


-- HELPERS

surround : a -> List a -> List a
surround sep xs =
  case xs of
    [] -> []
    [x] -> sep :: x :: sep :: []
    x :: xs -> sep :: x :: (surround sep xs)

toWidth =
  (+) gridLine << (*) (cellSize + gridLine)

filterMaybe : List (Maybe a) -> List a
filterMaybe ms =
  List.foldr 
    (\m acc -> 
      case m of
        Nothing -> acc
        Just val -> val :: acc) [] ms


-- Applicative functors

ap : (b -> a -> c) -> (a -> b) -> a -> c
ap f g =
  \x -> (f (g x) x)

andMap : List (a -> b) -> List a -> List b
andMap funcs xs = 
  List.concatMap (\f -> List.map f xs) funcs


-- 2D Array type

mapArray2 : (a -> b) -> Array (Array a) -> Array (Array b)
mapArray2 f = indexedMapArray2 (always f)

indexedMapArray2 : ((Int, Int) -> a -> b) -> Array2 a -> Array2 b
indexedMapArray2 f rows =
  let
    withIndex row acc =
      let y = Array.length acc
      in  Array.push (Array.indexedMap (\x v -> f (x, y) v) row) acc
  in
    Array.foldl withIndex Array.empty rows


-- Random

time =
  Time.every <| 100 * Time.millisecond

randomizeGrid : Random.Seed -> Grid -> Grid
randomizeGrid init (Grid grid) =
  let
    accumRand p (acc, seed) =
      let
        (p', seed') = generate Random.bool seed
        acc' = Array.push p' acc
      in
        (acc', seed')
    
    randomize row seed =
      Array.foldl accumRand (Array.empty, seed) row
    
    accumRandArrays row (acc, seed) =
      let
        (row', seed') = randomize row seed
        acc' = Array.push row' acc
      in
        (acc', seed')
  in
    Grid << fst <|
      Array.foldl accumRandArrays (Array.empty, init) grid