Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question

migrated from math.stackexchange.com Oct 1 '12 at 0:11

This question came from our site for people studying math at any level and professionals in related fields.

    
Welcome to Mathematica.SE! Could you please edit your question to explain what you have tried, and how the spreadsheet outcomes linked in your question relate to the problem. –  Verbeia Oct 1 '12 at 0:56
    
Could you describe in more detail your cellular automaton? I don't understand it (yes, I looked at your Excel file, but didn't understand it either). And what do you mean with "making it fractal"? –  celtschk Oct 1 '12 at 9:09
    
Daniele, if you register an account it will be easier for you to edit and update your own questions. To edit this question you will also need to link the account with your math.stackexchange.com one. –  Mr.Wizard Oct 3 '12 at 7:48
    
If I see it correctly, there are Ifs inside other Ifs after Return (those which at the current formatting are not in the beginning of a line). Those Ifs will never be executed because of the preceding Return. I guess that's the source of your problem. Probably you wanted them to be outside the previous If. –  celtschk Oct 3 '12 at 8:12
1  
@Daniele Take a look at the CellularAutomaton function and the Cellular Automata overview in the help documentation. –  amr Oct 3 '12 at 9:30

2 Answers 2

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]]

Mathematica graphics

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]

enter image description here

share|improve this answer
1  
Nice work deducing the rule! –  Simon Woods Oct 12 '12 at 19:41
    
Good answer. Just wondering, is the CellularAutomaton function capable of this kind of action...? –  cormullion Oct 12 '12 at 21:54
    
@cormullion See my update. –  halirutan Oct 13 '12 at 1:59
    
Do you think that if I want to change color scheme, i can apply the following code? –  DRM Oct 13 '12 at 11:00
    
I mean to COUNT 0 and 1 instead of 1 and 2, and the change rule, can i write the following code? > countRedBlack[a_, i_Integer?Positive, j_Integer?Positive] := With[{nb = Flatten@a[[i - 1 ;; i + 1, j - 1 ;; j + 1]]}, Count[nb, #] & /@ {0, 1}] –  DRM Oct 13 '12 at 11:02

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]]

enter image description here

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]
share|improve this answer
    
Shouldn't something here be red? --poke-- --poke-- –  Mr.Wizard Oct 12 '12 at 20:15
    
@Mr.Wizard, are you implying that my colouring scheme, in which "Red" is black, "White" is gray, and "Black" is white, is in some way deficient? ;-) –  Simon Woods Oct 12 '12 at 21:59

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.