Symbolic systems [emulating cellular automata] Given the rules for an elementary cellular automaton in the form used on page 867 (with {0, 0, 0}  0 ), the following will construct a symbolic system which emulates it: Flatten[{Array[(p[x_][#1][#2][#3]  p[x[{##} /. rules]][#2][#3]) &, {2, 2, 2}, 0] /. {0  p, 1  q}, {r[x_]  p[r[p][p]][x], p[x_][p][p][r]  x[p][p][r]}}] The initial condition for the symbolic system is given by Fold[#1[#2] &, r[p][p], init /. {0  p, 1  q}][p][p][r] Step t in the cellular automaton corresponds to step t (t + Length[init] + 3) in the symbolic system.

One can reproduce the original data using PDecode[a_] := Module[{d = Flatten[ a /. p[j_, r_]  Table[p[j], {r}]]}, Flatten[MapIndexed[ If[Head[#1] === p, d 〚 #2 〛 = d 〚 #2 - First[#1] 〛 ,#1] &, d]]] To get a representation purely in terms of 0 and 1, one can use a self-delimiting representation for each integer that appears.

.}] = 0 g[{1, s__}] := 1 + g[IntegerDigits[FromDigits[{s}, 2] + 1, 2]] The list of elements in the sequence up to value m is given by Flatten[Table[Table[n, {IntegerExponent[n, 2] + 1}], {n, m}]] The differences between the first 2 (2 k -1) of these elements is Nest[Replace[#, {x___}  {x, 1, x, 0}]&, {}, k] The largest n for which f[n]  m is given by 2m + 1 - DigitCount[m, 2, 1] or IntegerExponent[(2m)!… Hump m in the picture of sequence (c) shown is given by FoldList[Plus, 0, Flatten[Nest[Delete[NestList[Rest, #, Length[#] - 1], 2]&, Append[Table[1, {m}], 0], m]] - 1/2] The first 2 m elements in the sequence can also be generated in terms of reordered base 2 digit sequences by FoldList[Plus, 1, Map[Last[Last[#]]&, Sort[Table[{Length[#], Apply[Plus, #], 1 - #}& [ IntegerDigits[i, 2]], {i, 2 m }]]]] Note that the positive and negative fluctuations in sequence (f) are not completely random: although the probability for individual fluctuations in each direction seems to be the same, the probability for two positive fluctuations in a row is smaller than for two negative fluctuations in a row.

Given a list of initial cell colors for the cellular automaton, the initial conditions for the mobile automaton are given by Flatten[{p[0], Map[p, list], p[0]}] surrounded by x 's, with the active cell being placed initially just before the first p[0] .

With this setup, a network consisting of just one node is {{1, 1}} and a 1D array of n nodes can be obtained with CyclicNet[n_] := RotateRight[ Table[Mod[{i - 1, i + 1}, n] + 1, {i, n}]] With above connections represented as 1 and the below connections as 2 , the node reached by following a succession s of connections from node i is given by Follow[list_, i_, s_List] := Fold[list 〚 #1 〛 〚 #2 〛 &, i, s] The total number of distinct nodes reached by following all possible succession of connections up to length d is given by NeighborNumbers[list_, i_Integer, d_Integer] := Map[Length, NestList[Union[Flatten[list 〚 # 〛 ]] &, Union[list 〚 i 〛 ], d - 1]] For each such list the rules for the network system then specify how the connections from node i should be rerouted. … With rules set up in this way, each step in the evolution of a network system is given by NetEvolveStep[{depth_Integer, rule_List}, list_List] := Block[ {new = {}}, Join[Table[Map[NetEvolveStep1[#, list, i] &, Replace[NeighborNumbers[list, i, depth], rule]], {i, Length[list]}], new]] NetEvolveStep1[s : {___Integer}, list_, i_] := Follow[list, i, s] NetEvolveStep1[{s1 : {___Integer}, s2 : {___Integer}}, list_, i_] := Length[list] + Length[ AppendTo[new, {Follow[list, i, s1], Follow[list, i, s2]}]] The set of nodes that can be reached from node i is given by ConnectedNodes[list_, i_] := FixedPoint[Union[Flatten[{#, list 〚 # 〛 }]] &, {i}] and disconnected nodes can be removed using RenumberNodes[list_, seq_] := Map[Position[seq, #] 〚 1, 1 〛 &, list 〚 seq 〛 , {2}] The sequence of networks obtained on successive steps by applying the rules and then removing all nodes not connected to node number 1 is given by NetEvolveList[rule_, init_, t_Integer] := NestList[(RenumberNodes[#, ConnectedNodes[#, 1]] &)[ NetEvolveStep[rule, #]] &, init, t] Note that the nodes in each network are not necessarily numbered in the order that they appear on successive lines in the pictures in the main text.

For any input x one can test whether the machine will ever halt using u[{Reverse[IntegerDigits[x, 2]], 0}] u[list_] := v[Split[Flatten[list]]] v[{a_, b_: {}, c_: {}, d_: {}, e_: {}, f_: {}, g___}] := Which[a == {1} || First[a]  0, True, c  {}, False, EvenQ[Length[b]], u[{a, 1 - b, c, d, e, f, g}], EvenQ[Length[c]], u[{a, 1 - b, c, 1, Rest[d], e, f, g, 0}], e  {} || Length[d] ≥ Length[b] + Length[a] - 2, True, EvenQ[Length[e]], u[{a, b , c, d, f, g}], True, u[{a, 1 - b, c, 1 - d, e, 1, Rest[f], g, 0}]] This test takes at most n/3 recursive steps, even though the original machine can take of order n 2 steps to halt.

Starting with a list of the initial conditions for s steps, the configurations for the next s steps are given by Append[Rest[list], Map[Mod[Apply[Plus, Flatten[c #]], 2]&, Transpose[ Table[RotateLeft[list, {0, i}], {i, -r, r}], {3, 2, 1}]]] where r = (Length[First[c]] - 1)/2 .

Finding layouts [for networks] One way to lay out a network g so that network distances in it come as close as possible to ordinary distances in d -dimensional space, is just to search for values of the x[i, k] which minimize a quantity such as With[{n = Length[g]}, Apply[Plus, Flatten[(Table[Distance[g, {i, j}], {i, n}, {j, n}] 2 - Table[ Sum[(x[i, k] - x[j, k]) 2 , {k, d}], {i, n}, {j, n}]) 2 ]]] using for example FindMinimum starting say with x[1, _]  0 and all the other x[_, _]  Random[] .

CTToR110[rules_ /; Select[rules, Mod[Length[#], 6] ≠ 0 &]  {}, init_] := Module[{g1, g2, g3, nr = 0, x1, y1, sp}, g1 = Flatten[ Map[If[#1 === {}, {{{2}}}, {{{1, 3, 5 - First[#1]}}, Table[ {4, 5 - # 〚 n 〛 }, {n, 2, Length[#]}]}] &, rules] /. a_Integer  Map[({d[# 〚 1 〛 , # 〚 2 〛 ], s[# 〚 3 〛 ]}) &, Partition[c[a], 3]], 4]; g2 = g1 = MapThread[If[#1 === #2 === {d[22, 11], s3}, {d[ 20, 8], s3}, #1] &, {g1, RotateRight[g1, 6]}]; While[Mod[ Apply[Plus, Map[# 〚 1, 2 〛 &, g2, 30] ≠ 0, nr++; g2 = Join[ g2, g1]]; y1 = g2 〚 1, 1, 2 〛 - 11; If[y1 < 0, y1 += 30]; Cases[ Last[g2] 〚 2 〛 , s[d[x_, y1], _, _, a_]  (x1 = x + Length[a])]; g3 = Fold[sadd, {d[x1, y1], {}}, g2]; sp = Ceiling[5 Length[ g3 〚 2 〛 ]/(28 nr) + 2]; {Join[Fold[sadd, {d[17, 1], {}}, Flatten[Table[{{d[sp 28 + 6, 1], s[5]}, {d[398, 1], s[5]}, { d[342, 1], s[5]}, {d[370, 1], s[5]}}, {3}], 1]] 〚 2 〛 , bg[ 4, 11]], Flatten[Join[Table[bgi, {sp 2 + 1 + 24 Length[init]}], init /. {0  init0, 1  init1}, bg[1, 9], bg[6, 60 - g2 〚 1, 1, 1 〛 + g3 〚 1, 1 〛 + If[g2 〚 1, 1, 2 〛 < g3 〚 1, 2 〛 , 8, 0]]]], g3 〚 2 〛 }] s[1] = struct[{3, 0, 1, 10, 4, 8}, 2]; s[2] = struct[{3, 0, 1, 1, 619, 15}, 2]; s[3] = struct[{3, 0, 1, 10, 4956, 18}, 2]; s[4] = struct[{0, 0, 9, 10, 4, 8}]; s[5] = struct[{5, 0, 9, 14, 1, 1}]; {c[1], c[2]} = Map[Join[{22, 11, 3, 39, 3, 1}, #] &, {{63, 12, 2, 48, 5, 4, 29, 26, 4, 43, 26, 4, 23, 3, 4, 47, 4, 4}, {87, 6, 2, 32, 2, 4, 13, 23, 4, 27, 16, 4}}]; {c[3], c[4], c[5]} = Map[Join[#, {4, 17, 22, 4, 39, 27, 4, 47, 4, 4}] &, {{17, 22, 4, 23, 24, 4, 31, 29}, {17, 22, 4, 47, 18, 4, 15, 19}, {41, 16, 4, 47, 18, 4, 15, 19}}] {init0, init1} = Map[IntegerDigits[216 (# + 432 10 49 ), 2] &, {246005560154658471735510051750569922628065067661, 1043746165489466852897089830441756550889834709645}] bgi = IntegerDigits[9976, 2] bg[s_, n_] := Array[bgi 〚 1 + Mod[# - 1, 14] 〛 &, n, s] ev[s[d[x_, y_], pl_, pr_, b_]] := Module[{r, pl1, pr1}, r = Sign[BitAnd[2^ListConvolve[{1, 2, 4}, Join[bg[pl - 2, 2], b, bg[pr, 2]]], 110]]; pl1 = (Position[r - bg[pl + 3, Length[r]], 1 | -1] /. {}  {{Length[r]}}) 〚 1, 1 〛 ; pr1 = Max[pl1, (Position[r - bg[pr + 5 - Length[r], Length[r]], 1 | -1] /. {}  {{1}}) 〚 -1, 1 〛 ]; s[d[x + pl1 - 2, y + 1], pl1 + Mod[pl + 2, 14], 1 + Mod[pr + 4, 14] + pr1 - Length[r], Take[r, {pl1, pr1}]]] struct[{x_, y_, pl_, pr_, b_, bl_}, p_Integer : 1] := Module[ {gr = s[d[x, y], pl, pr, IntegerDigits[b, 2, bl]], p2 = p + 1}, Drop[NestWhile[Append[#, ev[Last[#]]] &, {gr}, If[Rest[Last[#]] === Rest[gr], p2--]; p2 > 0 &], -1]] sadd[{d[x_, y_], b_}, {d[dx_, dy_], st_}] := Module[{x1 = dx - x, y1 = dy - y, b2, x2, y2}, While[y1 > 0, {x1, y1} += If[Length[st]  30, {8, -30}, {-2, -3}]]; b2 = First[Cases[st, s[d[x3_, -y1], pl_, _, sb_]  Join[bg[pl - x1 - x3, x1 + x3], x2 = x3 + Length[sb]; y2 = -y1; sb]]]; {d[x2, y2], Join[b, b2]}] CTToR110[{{}}, {1}] yields blocks of lengths {7204, 1873, 7088} . … The core of the right-hand block grows approximately like 500 (Length[Flatten[rules]] + Length[rules]) , but to make a block that can just be repeated without shifts, between 1 and 30 repeats of this core can be needed.

The first m rules (which yield far more than m elements of the original sequence) are obtained for any h that is not a rational number from the continued fraction form (see page 914 ) of h by Map[(({0  Join[#, {1}], 1  Join[#, {1, 0}]} &)[Table[0, {# - 1}]]) &, Reverse[Rest[ContinuedFraction[h, m]]]] Given these rules, the original sequence is given by Floor[h] + Fold[Flatten[#1 /. #2] &, {0}, rules] If h is the solution to a quadratic equation, then the continued fraction form is repetitive, and so there are a limited number of different substitution rules.