Message Boards Message Boards

GROUPS:
Staff Picks Wolfram Science Mathematics Computational Systems Wolfram Language
Ed Pegg

Diagonal Cellular Automata

Ed Pegg, Wolfram Research
Posted 4 months ago
1393 Views
|
8 Replies
|
25 Total Likes
|

I was amused by the post 1-D Cellular Automata With a Twist, so I thought I'd take a look.

enter image description here

Here's rule 420.

Clear[a];
tab=Table[{a[0,k]=0, a[k,0]=0},{k,0,800}]; 
a[0,0]=1;
rule=IntegerDigits[420,3,7];
a[n_,k_] := a[n,k]= rule[[1+ a[n-1,k -1]+a[n -1,k]+a[n ,k-1]]];
tab=Table[a[m,d-m],{d,2,729},{m,1,d-1}];
ArrayPlot[Table[a[x,y],{x,1,729},{y,1,729}], Frame-> False, PixelConstrained->1]

rule 420

Here are some other nice rules:

nice = {381, 382, 383, 384, 385, 386, 414, 415, 416, 417, 418, 419, 
  420, 421, 422, 424, 478, 613, 622, 623, 624, 625, 626, 657, 658, 
  663, 694, 717, 721, 864, 865, 866, 867, 868, 869, 870, 871, 872, 
  883, 903, 904, 906, 936, 937, 960, 1110, 1111, 1112, 1113, 1114, 
  1115, 1143, 1144, 1145, 1146, 1147, 1148, 1149, 1150, 1230, 1231, 
  1232, 1233, 1234, 1235, 1236, 1237, 1238, 1239, 1240, 1242, 1243, 
  1244, 1245, 1246, 1247, 1254, 1255, 1256, 1257, 1258, 1259, 1260, 
  1261, 1262, 1263, 1265, 1266, 1272, 1274, 1278, 1279, 1280, 1284, 
  1287, 1288, 1342, 1351, 1352, 1354, 1355, 1386, 1387, 1392, 1504, 
  1527, 1531, 1539, 1547, 1548, 1549, 1556, 1557, 1558, 1559, 1560, 
  1561, 1562, 1563, 1564, 1585, 1593, 1594, 1595, 1596, 1597, 1598, 
  1599, 1600, 1601, 1608, 1612, 1632, 1633, 1634, 1635, 1666, 1774, 
  1839, 1840, 1841, 1842, 1843, 1844, 1872, 1874, 1875, 1876, 1877, 
  1878, 1879, 1882, 2071, 2080, 2081, 2082, 2083, 2084, 2121, 2175}

Here's 1504

rule 1504

Here's 1240

rule 1240

Here's 1263 rule 1263
POSTED BY: Ed Pegg
Answer
8 Replies
Sort By:

Very interesting! I wonder if CellularAutomaton function can be harnessed somehow to implement this system for an arbitrary rule. Also rule 420 for how many colors? For elementary binary case of 2 colors should not be there also 256 rules like for Elementary Cellular Automata because the neighborhood is 3 cells? Also, it is interesting to get the analog of Wolfram table for all possible rules of elementary case for simplest non-trivial initial conditions: https://www.wolframscience.com/nks/p55--more-cellular-automata
POSTED BY: Vitaliy Kaurov
Answer
Ed Pegg
Ed Pegg, Wolfram Research
Posted 4 months ago

420 -- 3 colors
POSTED BY: Ed Pegg
Answer

enter image description here -- you have earned Featured Contributor Badge enter image description here

Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you, keep it coming, and consider contributing to the The Notebook Archive!
POSTED BY: Moderation Team
Answer

As an answer to Vitaliy's question, you can use the CellularAutomaton function, but there is subtle issue with the boundary conditions. In the Diagonal CA, you start with a single gray cell (value 1 out of 1,2, or 0) and when you need a new boundary cell it is always white (or 0). In the CellularAutomaton function, if the rule sends white cells to white (or quiescent) then it is the same, but otherwise the boundary cells are not necessarily going to be white (or 0). Because of this the evolutions are not the same in general.

But when the rule is quiescent then they are the same. One other difference should be mentioned, that Ed's rule numbering is backwards from the usual conventions. So Ed's rule 420 = 0 1 2 0 1 2 0 = CellularAutomaton 588 = 0 2 1 0 2 1 0, which is quiescent. The rule type is a second order CA because it depends on the previous diagonal and the diagonal before that. Here is an implementation as a radius 1/2 rule.

    hist=CellularAutomaton[{588, {3, {{1, 0}, {1, 1}}}, 1/2, 2},  
PadLeft[{{1}}, {2, 32}, 0, {0, 31}], 30];
    Graphics[MapIndexed[If[#2[[1]] < #2[[2]], Nothing, 
{GrayLevel[1 - #/2], Rectangle[{#2[[2]], 30 - #2[[1]] + #2[[2]]}]}] &, hist, {2}]]

(I'd post an image, but something strange happened with the interface.)
POSTED BY: Todd Rowland
Answer
Ed Pegg
Ed Pegg, Wolfram Research
Posted 3 months ago

Todd, how would the 3D diagonal CA be set up? It seems obvious that we should find out if a "1D" cellular automaton can build a menger sponge.
POSTED BY: Ed Pegg
Answer
Ed Pegg
Ed Pegg, Wolfram Research
Posted 3 months ago

Nice! 

n=10;
array=Transpose[CellularAutomaton[{588,{3,{{1,0},{1,1}}},1/2,2},PadLeft[{{1}},{2,2^n},0,{0,2^n-1}],2^n-2]];
new=Table[RotateLeft[array[[n]],n-1],{n,1,Length[array]}];
ArrayPlot[Transpose[new], PixelConstrained->1, Frame-> False]
POSTED BY: Ed Pegg
Answer

Ed, let me first try amending my earlier post, before thinking about the 3D case.

The best reference for the search for simple rules with interesting behavior is Stephen Wolfram's A New Kind of Science.

The choice of display for the diagonal CA is connected to whether the neighborhood weights are {{1,0},{1,1}} or {{0,1},{1,1}}.

The display I had last time was more simple with

ArrayPlot[ CellularAutomaton[{588, {3, {{1, 0}, {1, 1}}}, 1/2, 2}, {{{1}, {0}},  0}, 30]]

Note that you can take advantage of CellularAutomaton's initial condition syntax for infinite backgrounds.

Many ordinary ECA can be realized as diagonal CA (but not totalistic like these are) including rule 30, and their evolutions can be evaluated in even more bizarre ways.
POSTED BY: Todd Rowland
Answer

The 3D case is more complicated to render, and the choice of rendering determines where the offsets go with the weighting. Please forgive me for posting a guess.

    ArrayPlot[CellularAutomaton[{114, {2, 
{{{1, 0}, {0, 0}}, {{1, 0}, {1, 1}}, {{1,1}, {0, 1}}}}, 
{1/2, 1/2}, 3}, {{{{1}}, {{0}}, {{0}}}, 0}, {{{30}}}]]

enter image description here

Not a completely random guess. Look at this graphic, showing the diagonal sheets. It is clearly an order 3 rule. Each sheet is a square lattice (but at a funny angle), and the first and second step back each have three cells, being the closest 3 in the parallelogram. Some combination with one 1 and 3 1's and 3 1's for weights will be correct.

Graphics[MapIndexed[{Hue[Mod[#2[[1]]/5, 1]], Point[#]} &, 
  Select[Union[#.{{1, 1}, {-1, 0}, {0, -1}}] & /@ 
    SortBy[MaximalBy[GatherBy[Tuples[Range[5], 3], #.{1, 1, 1} &], 
      Length, 3], #[[1]].{1, 1, 1} &]
POSTED BY: Todd Rowland
Answer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract