Then, for example, the rule for the mobile automaton shown on page 71 can be given as {{1, 1, 1}  {0, 1}, {1, 1, 0}  {0, 1}, {1, 0, 1}  {1, -1}, {1, 0, 0}  {0, -1}, {0, 1, 1}  {0, -1}, {0, 1, 0}  {0, 1}, {0, 0, 1}  {1, 1}, {0, 0, 0}  {1, -1}} where the left-hand side in each case gives the value of the active cell and its left and right neighbors, while the right-hand side consists of a pair containing the new value of the active cell and the displacement of its position. … With a rule given in this form, each step in the evolution of the mobile automaton corresponds to the function MAStep[rule_, {list_List, n_Integer}] /; (1 < n < Length[list]) := Apply[{ReplacePart[list, #1, n], n + #2}&, Replace[Take[list, {n - 1, n + 1}], rule]] The complete evolution for many steps can then be obtained with MAEvolveList[rule_, init_List, t_Integer] := NestList[MAStep[rule, #]&, init, t] (The program will run more efficiently if Dispatch is applied to the rule before giving it as input.) For the mobile automaton on page 73 , the rule can be given as {{1, 1, 1}  {{0, 0, 0}, -1}, {1, 1, 0}  {{1, 0, 1}, -1}, {1, 0, 1}  {{1, 1, 1}, 1}, {1, 0, 0}  {{1, 0, 0}, 1}, {0, 1, 1}  {{0, 0, 0}, 1}, {0, 1, 0}  {{0, 1, 1}, -1}, {0, 0, 1}  {{1, 0, 1}, 1}, {0, 0, 0}  {{1, 1, 1}, 1}} and MAStep must be rewritten as MAStep[rule_, {list_List, n_Integer}] /; (1 < n < Length[list]) := Apply[{Join[Take[list, {1, n - 2}], #1, Take[list, {n + 2, -1}]], n + #2}&, Replace[Take[list, {n - 1, n + 1}], rule]]

It is convenient to refer to the first number in each sequence as f[1] , the second as f[2] , and so on, so that the n th number is denoted f[n] . … In the simplest cases, f[n] depends only on the number immediately before it in the sequence, denoted f[n – 1] . … Sequence (c) is the powers of two; (d) is the so-called Fibonacci sequence, related to powers of the golden ratio (1 + √ 5)/2 ≃ 1.618 .

Fractal dimensions [of additive cellular automata] The total number of nonzero cells in the first t rows of the pattern generated by the evolution of an additive cellular automaton with k colors and weights w (see page 952 ) from a single initial 1 can be found using g[w_, k_, t_] := Apply[Plus, Sign[NestList[Mod[ ListCorrelate[w, #, {-1, 1}, 0], k] &, {1}, t - 1]], {0, 1}] The fractal dimension of this pattern is then given by the large m limit of Log[k,g[w, k,k m + 1 ]/g[w, k, k m ]] When k is prime it turns out that this can be computed as d[w_, k_:2] := Log[k,Max[Abs[Eigenvalues[With[ {s = Length[w] - 1}, Map[Function[u, Map[Count[u, #] &, #1]], Map[Flatten[Map[Partition[Take[#, k + s - 1], s, 1] &, NestList[Mod[ListConvolve[w, #], k] &, #, k - 1]], 1] &, Map[Flatten[Map[{Table[0, {k - 1}], #} &, Append[#, 0]]] &, #]]] &[Array[IntegerDigits[#, k, s] &, k s - 1]]]]]]] For rule 90 one gets d[{1, 0, 1}] = Log[2, 3] ≃ 1.58 . For rule 150 d[{1, 1, 1}] = Log[2, 1 + √ 5 ] ≃ 1.69 . … For the other rules on page 952 : d[{1, 1, 0, 1, 0}] = Log[2, Root[4 + 2 # - 2 # 2 - 3 # 3 + # 4 &, 2]] ≃ 1.72 d[{1, 1, 0, 1, 1}] = Log[2, Root[-4 + 4 # + # 2 - 4 # 3 + # 4 &, 2]] ≃ 1.80 Other cases include (see page 870 ): d[{1, 0, 1}, k] = 1 + Log[k, (k + 1)/2] d[{1, 1, 1}, 3] = Log[3, 6] ≃ 1.63 d[{1, 1, 1}, 5] = Log[5, 19] ≃ 1.83 d[{1, 1, 1}, 7] = Log[7, Root[-27136 + 23280 # - 7288 # 2 + 1008 # 3 - 59 # 4 + # 5 & , 1]] ≃ 1.85

Logic circuits [from cellular automata] The rules for the cellular automaton shown here are {{0, 1, 1 | 3}  1, {0, 3, 3}  3, {1, 0, 0 | 1 | 3}  1, {1, 1, 3}  4, {1, 3, 0}  3, {1, 3, 3}  2, {2, 1, 3}  3, {2, 3, 0}  2, {2, 0, _}  4, {3, 3, 0}  3, {4, 0, 0 | 1 | 2 | 4}  2, {4, 3, 3}  3, {4, 1, 3}  1, {4, 3, 0}  4, {_, _, _}  0} The initial conditions are given by Flatten[Block[{And, Or}, Map[{0, 2 (# + 1)} &, expr, {-1}] //. {!x_  {0, x, 0}, And[x__]  {0, 0, 1, 0, x, 1, 3, 0, 0}, Or[x__]  {0, 0, 1, 0, x, 0, 1, 3, 0}}]] and in terms of these initial conditions the cellular automaton must be run for Length[list //. {0, x__}  {x}] - 1 steps in order to find the result.

And operations on numbers then correspond to ways of updating sequences of 0's and 1's. … To begin, consider what is perhaps the simplest conceivable arithmetic process: start with the number 1 and then just progressively add 1 at each of a sequence of steps. The result of this process is to generate the successive numbers 1, 2, 3, 4, 5, 6, 7, 8, ...

To begin the first example, consider what happens if one multiplies by 3/2 , or 1.5, at each step. Starting with 1, the successive numbers that one obtains in this way are 1, 3/2 = 1.5 , 9/4 = 2.25 , 27/8 = 3.375 , 81/16 = 5.0625 , 243/32 = 7.59375 , 729/64 = 11.390625 , ... Patterns produced by starting with the number 1, and then successively multiplying by a factor of 2, and a factor of 3.

Generating functions [for nested patterns] A convenient algebraic way to describe a sequence of numbers a[n] is to give a generating function Sum[a[n] x n , {n, 0, ∞ }] . 1/(1 - x) thus corresponds to the constant sequence and 1/(1 - x - x 2 ) to the Fibonacci sequence (see page 890 ). … The array for rule 60 is then 1/(1- (1 + x) y) , for rule 90 1/(1 - (1/x + x) y) , for rule 150 1/(1 - (1/x + 1 + x) y) and for second-order reversible rule 150 (see page 439 ) 1/(1 - (1/x + 1 + x) y - y 2 ) .

Thus, for example, with the rule {{1, 0}  {1, 1, -1}, {1, 1}  {2, 1, 1}, {2, 0}  {1, 0, -1}, {2, 1}  {1,0,1}} the head moves to the right whenever the initial condition consists of odd-length blocks of 1's separated by single 0's; otherwise it stays in a fixed region.

This specification gives a list of three blocks {b 1 , b 2 , b 3 } and the final initial conditions consist of an infinite repetition of b 1 blocks, followed by b 2 , followed by an infinite repetition of b 3 blocks. … 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} . But even CTToR110[{{0, 0, 0, 0, 0, 0}, {}, {1, 1, 1, 1, 1, 1}, {}}, {1}] already yields blocks of lengths {105736, 34717, 95404} .

f[n_] := n f[n - 1]; f[1] = 1 f[n_] := Product[i, {i, n}] f[n_] := Module[{t = 1}, Do[t = t i, {i, n}]; t] f[n_] := Module[{t = 1, i}, For[i = 1, i ≤ n, i++, t ⋆ = i]; t] f[n_] := Apply[Times, Range[n]] f[n_] := Fold[Times, 1, Range[n]] f[n_] := If[n  1, 1, n f[n - 1]] f[n_] := Fold[#2[#1] &, 1, Array[Function[t, # t] &, n]] f = If[#1  1, 1, #1 #0[#1 - 1]] &