Implementation [of causal networks] Given a list of successive positions of the active cell, as from Map[Last, MAEvolveList[rule, init, t]] (see page 887 ), the network can be generated using MAToNet[list_] := Module[{u, j, k}, u[_] = ∞ ; Reverse[ Table[j = list 〚 i 〛 ; k = {u[j - 1], u[j], u[j + 1]}; u[j - 1] = u[j] = u[j + 1] = i; i  k, {i, Length[list], 1, -1}]]] where nodes not yet found by explicit evolution are indicated by ∞ .

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} .

3D class 4 [cellular automaton] rules With a cubic lattice of the type shown on page 183 , and with updating rules of the form LifeStep3D[{p_, q_, r_}, a_List] := MapThread[If[ #1  1 && p ≤ #2 ≤ q || #2  r, 1, 0]&, {a, Sum[RotateLeft[ a, {i, j, k}], {i, -1, 1}, {j, -1, 1}, {k, -1, 1}] - a}, 3] Carter Bays discovered between 1986 and 1990 the three examples {5, 7, 6} , {4, 5, 5} , and {5, 6, 5} .

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.

({i_, u_}  {j_, v_, r_})  {Map[#[i]  {#[i, 1], #[i, 0]} &, {a, b, c, d}], If[r  1, {a[i, u]  {a[j], a[j]}, b[i, u]  Table[b[j], {4}], c[i, u]  Flatten[{Table[b[j], {2v}], Table[c[j], {2 - u}]}], d[i, u]  {d[j]}}, {a[i, u]  Table[a[j], {2 - u}], b[i, u]  {b[j]}, c[i, u]  Flatten[{c[j], c[j], Table[d[j], {2v}]}], d[i, u]  Table[d[j], {4}]}]}]]} A Turing machine in state i with a blank tape corresponds to initial condition {a[i], a[i], c[i]} for the tag system. The configuration of the tape on each side of the head in the Turing machine evolution can be obtained from the tag system evolution using Cases[history, x : {a[_], ___}  Apply[{#1, Reverse[#2]} &, Map[ Drop[IntegerDigits[Count[x, #], 2], -1] &, {_b, _d}]]]

But ever since the mid-1800s synoptic weather maps of large areas have been available that summarize conditions in terms of features like fronts and cyclones. … But it seems that over most of a typical weather map there is no such sensitivity—so that in the end the difficulties of weather prediction are probably much more a result of computational irreducibility and of the sophisticated kinds of computations that the Principle of Computational Equivalence implies should often occur even in simple fluids.

Mobile automata [from cellular automata] Given a mobile automaton with rules in the form used on page 887 , a cellular automaton which emulates it can be constructed using MAToCA[rules_] := Append[Flatten[Map[g, rules]], {_, _, x_, _, _}  x] g[{a_, b_, c_}  {d_, e_}] := {{_, a, b + 2, c, _}  d, If[e  1, {a, b + 2, c, _, _}  c + 2, {_, _, a, b + 2, c}  a + 2]} This specific definition assumes that the mobile automaton has two possible colors for each cell; it yields a cellular automaton with four possible colors for each cell.

(Standard evaluation in Mathematica is equivalent to expr //. rules and uses the same ordering, while Map uses a different order.)

With this setup successive steps in the evolution of the system can be obtained from GMAStep[rules_, {list_, nlist_}] := Module[{a, na}, {a, na} = Transpose[Map[Replace[Take[list, {# - 1, # + 1}], rules]&, nlist]]; {Fold[ReplacePart[#, Last[#2], First[#2]]&, list, Transpose[{nlist, a}]], Union[Flatten[nlist + na]]}]

Cyclic tag systems which allow any value for each element can be obtained by adding the rule CTStep[{{r_, s___}, {n_, a___}}] := {{s, r}, Flatten[{a, Table[r, {n}]}]} The leading elements in this case can be obtained using CTListStep[{rules_, list_}] := {RotateLeft[rules, Length[list]], With[{n = Length[rules]}, Flatten[Apply[Table[#1, {#2}] &, Map[Transpose[ {rules, #}] &, Partition[list, n, n, 1, 0]], {2}]]]}