Implementation of a new Game of Life Rule

Question

I need to implement a new "game of life" in Mathematica: I have three states — black, red and white. Black means go forward, red go back and white take no action.

I would like to implement the outcomes in this Excel file: http://cl.ly/0s2B2M3h3M2N

The code I have used is the following:

input13 = {{1, 1, 0, 0, 0}, {2, 0, 1, 2, 0}, {1, 1, 2, 1, 0}, {0, 1, 
    2, 1, 2}, {2, 1, 0, 1, 1}};

getNbhd[A_, i_Integer?Positive, j_Integer?Positive] :=    A[[i - 1 ;; i + 1, j - 1 ;; j + 1]];

evaluateCell[A_, i_, j_] :=   Module[{nbhd, cell = A[[i, j]], numNeighbors},

  If[i == 1 || j == 1 || i == Length[A] || j == Length[A[[1]]],     Return[0]];

  nbhd = getNbhd[A, i, j];   numNeighbors = Apply[Plus, Flatten[nbhd]];

  If[cell == 2 && numNeighbors - 2 >= 4 || 
    numNeighbors - 2 == 3 && numNeighbors - 1 <= 3 || 
    numNeighbors - 2 == 2 && numNeighbors - 1 <= 2 || 
    numNeighbors - 2 == 1 && numNeighbors - 1 <= 1 || 
    numNeighbors - 2 == 0 && numNeighbors - 0 == 8, Return[2];     If[cell == 2 && numNeighbors - 2 == numNeighbors - 1, Return[0], 
    Return[1]]];

  If[cell == 1 && numNeighbors - 1 >= 4 || 
    numNeighbors - 1 == 3 && numNeighbors - 2 <= 3 || 
    numNeighbors - 1 == 2 && numNeighbors - 2 <= 2 || 
    numNeighbors - 1 == 1 && numNeighbors - 2 <= 1 || 
    numNeighbors - 1 == 0 && numNeighbors - 0 == 8, Return[1];     If[cell == 1 && numNeighbors - 1 == numNeighbors - 2, Return[0], 
    Return[2]]];

  If[cell == 0 && numNeighbors - 1 == numNeighbors - 2, Return[0];     If[cell == 0 && numNeighbors - 1 > numNeighbors - 2, Return[1], 
    Return[2]]];]

evaluateAll[A_] :=      
    Table[evaluateCell[A, i, j], {i, 1, Length[A]}, {j, 1, Length[A[[1]]]}];
makeFrames[A_, n_] :=    Map[ArrayPlot[#, Mesh -> True] &,   
    NestList[evaluateAll, A, n]]; animate[frames_] := ListAnimate[frames, 1,    
        ControlPlacement -> Top];

But running this code I don't have anything special (the colors should be black, grey and white, but after 2 steps I have a red cell, that maybe means that no rule is set for that cell with those neighbors).

Can you help me?

My purpose is also to show that the rule I have made is fractal.

---

I have tried to delete the IFs from the brackets, and now I don't have any red cells, but after 2 step the figures don't change (always the same cell in the same place, they don't interact). Where is the problem??

If[ cell == 2 && numNeighbors - 2 >= 4 || 
    numNeighbors - 2 == 3 && numNeighbors - 1 <= 3 || 
    numNeighbors - 2 == 2 && numNeighbors - 1 <= 2 || 
    numNeighbors - 2 == 1 && numNeighbors - 1 <= 1 || 
    numNeighbors - 2 == 0 && numNeighbors - 0 == 8,   Return[2]]; 

If[ cell == 2 && numNeighbors - 2 == numNeighbors - 1, Return[0], Return[1]];

If[ cell == 1 && numNeighbors - 1 >= 4 || 
    numNeighbors - 1 == 3 && numNeighbors - 2 <= 3 || 
    numNeighbors - 1 == 2 && numNeighbors - 2 <= 2 || 
    numNeighbors - 1 == 1 && numNeighbors - 2 <= 1 || 
    numNeighbors - 1 == 0 && numNeighbors - 0 == 8,    Return[1]];

If[ cell == 1 && numNeighbors - 1 == numNeighbors - 2, Return[0],  Return[2]];

If[ cell == 0 && numNeighbors - 1 == numNeighbors - 2, Return[0]];

If[ cell == 0 && numNeighbors - 1 > numNeighbors - 2, Return[1],   Return[2]]];

@amr: I had a look to the documentation, but there are only rule already done, I want to have my rule (the one that you can see in the excel file).

Few questions: 1)Should the center cell to be count in the number of neighbors? 2)Is there another way to specify a new rule? 3)Is there a way to discover if the rule that I have created is already implemented in Mathematica with an internal code? 4)May I use a BooleanFunction to do it faster?

Many Thanks

Answer 1

Unfortunately, the approach of using Apply[Plus, Flatten[nbhd]] is fatal to your algorithm because summing up the cell-values introduces ambiguities. As an example take these rules from your excel file (White (0), Red (1) and Black (2)). This is in the Excel-file at A43:

{{2,2,2},{2,2,0},{0,0,0}} -> 2

And this is in A179:

{{1,1,1},{1,2,1},{1,1,1}} -> 1

For these two rules the center is in both cases Black(2). You could now go through your algorithm and calculate the numNeighbors which can be reduced to

Plus @@ Flatten@{{2, 2, 2}, {2, 2, 0}, {0, 0, 0}}
Plus @@ Flatten@{{1, 1, 1}, {1, 2, 1}, {1, 1, 1}}

(*
Out[33]= 10

Out[34]= 10
*)

In the following If statements in your code, you only use cell and numNeighbors to distinguish the cases. Since these values are equal for both cases but the result is different, no matter what you do your algorithm will never work correctly.

If you look at your Excel-file closer, than you see that you don't need to specify all the different cases. Your algorithm can be reduced to

If the number of Red cells is equal to the number of Black cells, then the center cell gets White. Otherwise the center gets the color Red, if we have more Red cells and Black if we have more Black cells.

This can be expressed very easily. First, we make a function which really counts the number of red and black cells. Note, that we count the center cell too:

countRedBlack[a_, i_, j_] := 
 With[{nb = Flatten@a[[i - 1 ;; i + 1, j - 1 ;; j + 1]]}, 
  Count[nb, #] & /@ {1, 2}]

The evaluateCell function can then be written down exactly as we said it above

evaluateCell[a_, i_, j_] := Module[{numRed, numBlack},
  {numRed, numBlack} = countRedBlack[a, i, j];
  Which[numRed == numBlack, 0, numRed > numBlack, 1, True, 2]
]

That's it. Let's fix your evaluatedAll function by padding the input with 0 so that evaluateCell can be called for all inner cells

evaluateAll[A_] := With[{paddedA = ArrayPad[A, 1]},
  Table[evaluateCell[paddedA, i, j], 
  {i, 2, Length[A] + 1}, {j, 2,Length[A[[1]]] + 1}]
]

And the rest is like you had it

makeFrames[A_, n_] := 
 Map[ArrayPlot[#, Mesh -> True, ColorFunction -> "RedBlueTones"] &, 
  NestList[evaluateAll, A, n]]; 
animate[frames_] := ListAnimate[frames, 1, ControlPlacement -> Top];

data = RandomInteger[2, {100, 100}];
animate[makeFrames[data, 20]]

Using CellularAutomaton

I didn't consider giving the CellularAutomaton solution because I had the feeling that the OP wanted to implement the automaton by himself. Using the included CellularAutomaton makes the whole solution a one-liner.

With @Simon Woods idea consisting of Sign and Total we define a function which makes the transition for one cell. Neighborhood range is 1 in both directions, therefore {1,1} and we want to calculate 10 steps of a random array of size 300x300:

a=CellularAutomaton[{Sign[Total[Flatten[#]]]&,{},{1,1}},RandomInteger[{-1,1},{300,300}],10];

Creating an image sequence from a gives

ListAnimate[ImageApply[Which[# == 0, {0.94, 0., 0.01}, 
 # == 1, {0.15, 0.11,0.16},True, {0.16, 0.42, 0.12}] &, Image[#]] & /@ a]

Answer 2

Given the rule as explained by Halirutan...

If the number of Red cells is equal to the number of Black cells, then the center cell gets White. Otherwise the center gets the color Red, if we have more Red cells and Black if we have more Black cells.

...it's interesting to note how things work if we use the following mapping of colours to numbers:

Red = -1 , White = 0 , Black = +1

The rule can then be expressed as:

The centre cell gets the value Sign[total of all cell values in the neighbourhood]

The evolution step can thus be expressed as a convolution with a 3x3 BoxMatrix followed by taking the Sign:

data = RandomInteger[{-1, 1}, {300, 300}];
frames = NestList[Sign@ListConvolve[BoxMatrix[1], #, {2, 2}] &, data, 20];
ListAnimate[Image /@ Rescale[frames]]

If you want to colour Red cells red, White cells white and Black cells black, use:

ListAnimate[ArrayPlot[#, ColorRules -> {-1 -> Red, 0 -> White, 1 -> Black}] & /@ frames]