4
$\begingroup$

Can I use the CellularAutomation[] function where the neighborhood is defined by the connections between nodes?

For example, if 1 -> 2, 1 -> 3, 1 -> 8, 1 ->1, then the neighborhood of node 1 is the nodes 2,3,8,1.

Here is what I have to start with:

Manipulate[
nodes = Sort@Flatten@Table[Range@n, {k}];
rand = RandomInteger[{1, n}, n*k];
rules = MapThread[Rule, {nodes, rand}];
colors = RandomInteger[{0, 1}, n] /. {0 -> Black, 1 -> Red};
GraphPlot3D[rules,
 VertexRenderingFunction -> ({colors[[#2]], EdgeForm[Black], 
 Sphere[#, .1], If[colors[[#2]] === Black, Yellow, White], 
 Style[Text[#2, #1], FontWeight -> Bold, FontSize -> 12]} &)],
 {n, 1, 20, 1}, {k, 1, 8, 1}, {step, 0, 100, 1}]
$\endgroup$
4
$\begingroup$

No, the CelluluarAutomaton command works is specifically designed to model cellular automata on grids. It's certainly feasible to roll your own, though.

Your example using GraphPlot3D

I generated the following graph using your code.

rules = {1 -> 5, 1 -> 1, 1 -> 8, 1 -> 6, 1 -> 2, 2 -> 5, 2 -> 2, 
  2 -> 7, 2 -> 7, 2 -> 5, 3 -> 7, 3 -> 8, 3 -> 2, 3 -> 1, 3 -> 4, 
  4 -> 3, 4 -> 5, 4 -> 3, 4 -> 2, 4 -> 8, 5 -> 4, 5 -> 2, 5 -> 3, 
  5 -> 4, 5 -> 1, 6 -> 5, 6 -> 1, 6 -> 8, 6 -> 3, 6 -> 7, 7 -> 7, 
  7 -> 6, 7 -> 8, 7 -> 2, 7 -> 3, 8 -> 2, 8 -> 5, 8 -> 2, 8 -> 2, 
  8 -> 5};
GraphPlot3D[rules, VertexRenderingFunction -> ({Sphere[#, .1],
  Style[Text[#2, #1], FontWeight -> Bold, FontSize -> 12]} &)]

enter image description here

Now, let's set up an initial state from which to evolve. Note that I store the state (either 1 or 2) of vertex v at time 0 in value[0,v].

Clear[value];
SeedRandom[1];
n = Max[Sequence @@@ rules];
Do[value[0, v] = RandomChoice[Range[2]], {v, 1, n}];
color[1] = Yellow;
color[2] = Lighter@Red;
GraphPlot3D[rules,
  VertexRenderingFunction -> ({{color[value[0, #2]], Sphere[#, .1]},
  Style[Text[#2, #1], FontWeight -> Bold, FontSize -> 12]} &)]

enter image description here

Now, I'll write a function step that accepts a vertex u, computes the new value, and stores that value in value[gen,u], where gen is global variable indicating our generation number. Specifically, we simply sum the values of all the adjacent vertices and set the new value to 1, if the sum is even, and set the new value to 2, if the sum is odd.

Clear[adjacentVertices]
adjacentVertices[v_] := adjacentVertices[v] = Last /@ Select[rules, First[#] == v &]
adjacentVertices /@ Range[n];
step[u_] := value[gen, u] = 
   Mod[Total[Table[value[gen - 1, v], {v, adjacentVertices[u]}]], 2, 1];

Note that adjacentVertices[v] takes direction and multiplicity into account and allows for self-loops. For example, adjacentVertices[2] contains 7 twice, as well as 2 itself, while adjacentVertices[7] contains 2 only once.

Let's do it!

gen = 0;
Do[
  gen = gen + 1;
  step /@ Range[n],
 {100}]

And visualize:

ListAnimate[Table[
  GraphPlot3D[rules,
    VertexRenderingFunction -> ({{color[value[k, #2]], Sphere[#, .1]},
      Style[Text[#2, #1], FontWeight -> Bold, FontSize -> 12]} &)],
  {k, 0, 100}]]

enter image description here

Another example

I'm honestly not sure how neat that example is, so here's another one that I rather like. Note that there is nothing about running a CA on a graph that is intrinsically three dimensional, apart from the visualization. For this example, I'll use the newer Graph object, rather than the GraphPlot3D function. So, here's a pretty fun graph:

allEdges = UndirectedEdge @@@ {
      {1, 2}, {1, 15}, {1, 30}, {1, 33}, {1, 43}, {2, 37}, {2, 30}, 
      {3, 18}, {3, 13}, {3, 41}, {3, 35}, {3, 40}, {4, 20}, {4, 22}, 
      {4, 26}, {4, 6}, {5, 19}, {5, 36}, {5, 12}, {5, 48}, {6, 38}, 
      {6, 46}, {6, 22}, {6, 26}, {7, 22}, {7, 25}, {7, 35}, {7, 41}, 
      {7, 46}, {8, 15}, {8, 29}, {8, 10}, {8, 11}, {9, 16}, {9, 31}, 
      {9, 34}, {9, 39}, {9, 44}, {10, 15}, {10, 21}, {10, 29}, {10, 12}, 
      {10, 48}, {11, 14}, {11, 15}, {11, 29}, {11, 33}, {11, 42}, 
      {12, 21}, {12, 27}, {12, 36}, {12, 48}, {13, 18}, {13, 28}, 
      {13, 41}, {14, 23}, {14, 28}, {14, 29}, {14, 41}, {14, 42}, 
      {15, 33}, {15, 43}, {15, 48}, {16, 34}, {16, 39}, {17, 25}, 
      {17, 32}, {17, 38}, {19, 30}, {19, 37}, {19, 43}, {19, 45}, 
      {19, 48}, {20, 22}, {20, 29}, {20, 21}, {20, 47}, {21, 27}, 
      {21, 29}, {21, 47}, {22, 29}, {22, 41}, {22, 46}, {23, 28}, 
      {23, 42}, {24, 31}, {25, 38}, {25, 46}, {26, 47}, {26, 27}, 
      {27, 36}, {27, 47}, {28, 41}, {29, 41}, {30, 37}, {30, 43}, 
      {31, 44}, {32, 34}, {32, 38}, {33, 42}, {33, 43}, {34, 44}, 
      {34, 38}, {34, 39}, {35, 40}, {35, 41}, {37, 45}, {38, 46}, 
      {43, 48}
  };
coords = {
  {-111.67, 34.33}, {-119.65, 37.28}, {-83.46, 32.66}, {-86.29, 39.91}, 
  {-109.65, 47.04}, {-82.79, 40.28}, {-78.92, 37.51}, {-98.37, 38.49}, 
  {-71.79, 42.25}, {-99.81, 41.53}, {-97.51, 35.59}, {-100.23, 44.43}, 
  {-86.83, 32.78}, {-92.44, 34.90}, {-105.55, 39.00}, {-72.70, 41.60}, 
  {-75.50, 38.96}, {-82.52, 28.66}, {-114.66, 44.40}, {-89.20, 40.07}, 
  {-93.49, 42.08}, {-85.28, 37.53}, {-92.00, 31.05}, {-69.26, 45.36}, 
  {-76.77, 39.02}, {-84.62, 43.46}, {-94.29, 46.32}, {-89.67, 32.74}, 
  {-92.47, 38.37}, {-116.66, 39.34}, {-71.59, 43.67}, {-74.68, 40.19}, 
  {-106.10, 34.43}, {-75.53, 42.96}, {-79.38, 35.53}, {-100.47, 47.44}, 
  {-120.57, 43.93}, {-77.80, 40.88}, {-71.59, 41.67}, {-80.90, 33.91}, 
  {-86.35, 35.85}, {-99.37, 31.48}, {-111.68, 39.32}, {-72.67, 44.07}, 
  {-120.42, 47.38}, {-80.60, 38.63}, {-90.02, 44.63}, {-107.55, 43.00}
};
G = Graph[Range[48], allEdges, VertexCoordinates -> coords, 
  VertexSize -> 1]

enter image description here

This happens to be a fairly well known planar graph, although this particular embedding does have some edge crossings. It should nonetheless be four-colorable, i.e. we can color the vertices in such a way that no two adjacent vertices share the same color. Let's see if we can color it with a stochastic cellular automaton. We'll start with a random coloring.

Clear[value];
SeedRandom[3];
Do[value[0, i] = RandomChoice[Range[4]], {i, 1, 48}];
color[1] = Red;
color[2] = Blue;
color[3] = Yellow;
color[4] = Green;
SetProperty[G, 
 VertexStyle -> Table[i -> color[value[0, i]], {i, 1, 48}]]

enter image description here

The following step function implements the CA rules, which essentially say that, if the color of a vertex is different from all of it's neighbors, then leave it the same, otherwise change it with some randomness thrown in. As a result, a four-coloring is a fixed point. The hope is that this fixed state might be attractive.

step[v_] := 
  Module[{neighbors, done, vxCoord, rightNeighbors, rightValues,leftValues},
   neighbors = AdjacencyList[G, v];
   Which[
    (* Case 1: all adjacent vertices are different colors - stay fixed *)    
    Intersection[{value[gen - 1, v]}, 
      value[gen - 1, #] & /@ neighbors] == {},
    done = True;
    value[gen, v] = value[gen - 1, v],
    done = False;
    (* Case 2: There's a conflict to the right - try to avoid *)    
    vxCoord = coords[[v, 1]];
    rightNeighbors = Select[neighbors, coords[[#, 1]] > vxCoord &];
    rightValues = value[gen - 1, #] & /@ rightNeighbors;
    Intersection[{value[gen - 1, v]}, rightValues] =!= {},
    If[RandomReal[] < 0.9,
     value[gen, v] = RandomChoice[{1, 2, 3, 4}],
     value[gen, v] = value[gen - 1, v]
     ],
    (* Case 3: There's a conflict to the left - try to avoid *)
    leftValues = value[gen - 1, #] & /@ 
      Complement[neighbors, rightNeighbors];
    Intersection[{value[gen - 1, v]}, leftValues] =!= {},
    If[RandomReal[] < 0.1,
     value[gen, v] = RandomChoice[{1, 2, 3, 4}],
     value[gen, v] = value[gen - 1, v]
     ]
    ];
   done
   ];

Now, let's run it and animate:

cnt = 0;
gen = 1;
While[cnt++ < 2500 && Count[step /@ Range[48], True] < 48, 
  gen = gen + 1]
pics = Table[SetProperty[G, 
  VertexStyle -> Table[i -> color[value[k, i]], {i, 1, 48}]],
 {k, 0, cnt}];
ListAnimate[pics]

enter image description here

$\endgroup$
  • $\begingroup$ Neat Answer. When you say 'Step' computes the new value, what is this new values based on? In other words, What are the "rules" for the value at the next generation? $\endgroup$ – Schwarz Jul 23 '14 at 20:30
  • $\begingroup$ @Schwarz The Mod[Total[Table[value[gen - 1, v], {v, adjacentVertices[u]}]], 2, 1] business sets the new value to either 1 or 2, depending on whether the sum of the adjacent nodes is even or odd. $\endgroup$ – Mark McClure Jul 23 '14 at 20:42

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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