Makes a pretty nice cellular automaton :D

Automaton.elm

@@ -0,0 +1,48 @@
+module Automaton exposing (..)
+
+import Random
+
+-- MODEL
+
+type alias Automaton s i = List ((s, i), s)
+
+zip : List a -> List b -> List (a, b)
+zip = List.map2 (,)
+
+cart : List a -> List b -> List (a, b)
+cart l1 l2 = List.concat <| List.map (\x -> List.map (\y -> (x, y)) l2) l1
+
+genAut : Int -> Int -> Random.Generator (Automaton Int Int)
+genAut n k = let
+    allSI = cart [1..n] [1..k]
+  in Random.map (zip allSI) (Random.list (n*k) <| Random.int 1 n)
+
+step : Automaton s i -> Maybe s -> i -> Maybe s
+step ls s0 i = case s0 of
+  Nothing -> Nothing
+  Just s -> List.filter (\((t, j), b) -> t == s && i == j) ls |> List.head |> Maybe.map snd
+
+--(=>) = (,)
+
+--state2Color : State -> Color
+--state2Color s = case s of
+--  Nothing -> Color.black
+--  Just n -> hsl (degrees (toFloat n)*77) 1.0 (0.8 - 0.6 * (toFloat n)/size)
+
+--color2String : Color -> String
+--color2String c = let rgb = toRgb c in "rgb(" ++ toString rgb.red ++ ", " ++ toString rgb.green ++ ", " ++ toString rgb.blue ++ ")"
+
+--block : Color -> Html msg
+--block c = div [style ["background-color" => color2String c, "width" => "100px", "height" => "100px", "display" => "inline-block"]] []
+
+--view : Model -> Html Msg
+--view model =
+--  div []
+--    (  button [ onClick Regen ] [ text "Regenerate" ]
+--    :: button [ onClick Sort ] [ text "Sort" ]
+--    :: br [] []
+--    :: List.map (block << state2Color) model.states
+--    )
+
+
+

Grid.elm

@@ -60,3 +60,11 @@ transpose grid = let
     nf = newFocus grid
     na = List.map newFocus <| RingList.iterate1N (List.length grid.focus.after) shiftLeft grid
   in RingList nb nf na
+
+getNeighbours : Grid a -> List a
+getNeighbours grid =
+    [ grid |> shiftLeft |> extract
+    , grid |> shiftUp |> extract
+    , grid |> shiftRight |> extract
+    , grid |> shiftDown |> extract
+    ]

Main.elm

@@ -1,5 +1,6 @@
 import Grid exposing (..)
 import RingList exposing (..)
+import Automaton exposing (..)
 
 import Html exposing (..)
 import Html.Attributes exposing (..)
@@ -18,50 +19,93 @@ main =
     , subscriptions = subscriptions
     }
 
-width = 21
-height = 16
+width = 62
+height = 33
+states = 3
+inputs = 2
+outputs = 3
+visSize = "20px"
+freq = 0.3 * second
 
 -- MODEL
 
-type alias World = Grid (Int, Float)
+type alias World = Grid (Maybe Int)
+type alias AutomatonT = Automaton Int Int
 type alias Model =
     { grid : World
-    , history : List (Int, Float)
+    , system : AutomatonT
+    , neighbours : List (Maybe Int)
     }
 
 init : (Model, Cmd Msg)
-init = (Model (Grid.generate width height (\x y -> (x, toFloat y))) [], Cmd.none)
+init =
+  ( { grid = Grid.generate width height initCell
+    , system = []
+    , neighbours = []
+    }, Random.generate NewRandomAut (genAut states inputs) )
 
 
+initCell x y = case (x > 5, y > 5) of
+    (True, _) -> Just 1
+    (_, True) -> Just 1
+    _         -> Just (1 + (x + y * width) % states)
+
 -- UPDATE
 
 type Msg
   = Update World
+  | NewRandomAut AutomatonT
+  | Regen
+  | BigStep
 
-succ (n, m) = (n + 1, m * 2)
+output m = case m of
+    Nothing -> 1
+    Just s -> 1 + s % outputs
+
+getNBOutputs grid = let
+    ret = grid |> Grid.getNeighbours |> List.map output |> List.sum
+  in 1 + ret % inputs
+
+cellStep : AutomatonT -> World -> Maybe Int
+cellStep aut grid = let
+    i = getNBOutputs grid
+    s = grid |> Grid.extract
+    t = Automaton.step aut s i
+  in t
 
 update : Msg -> Model -> (Model, Cmd Msg)
 update msg model =
   case msg of
-    Update grid -> (Model grid (Grid.extract grid :: model.history), Cmd.none)
+    Update grid -> ({ model | grid = grid }, Cmd.none)
+    NewRandomAut aut -> ({ model | system = aut }, Cmd.none)
+    Regen -> (model, Random.generate NewRandomAut (genAut states inputs))
+    BigStep -> ({ model | grid = Grid.extend (cellStep model.system) model.grid }, Cmd.none)
 
 
 -- SUBSCRIPTIONS
 
 subscriptions : Model -> Sub Msg
-subscriptions model = Sub.none
+subscriptions model = Time.every freq (\a -> BigStep)
 
 
 -- VIEW
 
-butt : World -> Html Msg
---butt rl = button [ onClick (Update (RingList.edit succ rl)) ] [ RingList.extract rl |> toString |> text ]
-butt grid = button [ onClick (Update (Grid.edit succ grid)) ] [ Grid.extract grid |> toString |> text ]
+(=>) = (,)
+
+output2Color : Int -> Color
+output2Color n = hsl (degrees (toFloat n)*77) 1.0 (0.8 - 0.6 * (toFloat n + 0.5)/outputs)
+
+color2String : Color -> String
+color2String c = let rgb = toRgb c in "rgb(" ++ toString rgb.red ++ ", " ++ toString rgb.green ++ ", " ++ toString rgb.blue ++ ")"
+
+block aut grid = let
+    col = output2Color <| output <| Grid.extract grid
+    but = text "" -- button [ onClick (Update (Grid.edit (\_ -> cellStep aut grid) grid)) ] [ text "." ]
+  in div [style ["background-color" => color2String col, "width" => visSize, "height" => visSize, "display" => "inline-block"]] [ but ]
 
-view : Model -> Html Msg
 view model = let
     dupmodel = Grid.duplicate model.grid
-    butts = Grid.map butt dupmodel
+    butts = Grid.map (block model.system) dupmodel
     listm = Grid.toList butts
-    viewm = List.map (\row -> div [] (br [] [] :: row)) listm
-  in div [] <| viewm ++ [div [] [model.history |> toString |> text]]
+    viewm = List.map (\row -> div [style ["height" => visSize]] row) listm
+  in div [] <| viewm ++ [button [onClick BigStep] [text "big step"], button [onClick Regen] [text "regenerate"]]