With the state of a 2-color tag system encoded as an integer according to FromDigits[Reverse[list] + 1, 3] the following takes the rule for any such tag system (in the first form from page 894 ) and yields a primitive recursive function that emulates a single step in its evolution: TSToPR[{n_, rule_}] := Fold[Apply[c, Flatten[{#1, Array[p, # 2], c[r[z, c[r[p[1], s], c[r[z, p[2]], c[r[z, r[c[s, z], c[r[c[s, c[s, z]], z], p[2]]]], p[2]]], p[1]]], p[#2]]}]] & , c[c[r[p[1], s], p[1], c[r[p[1], r[z, c[s, c[s, s]]]], c[c[r[z, c[r[p[1], s], c[r[z, c[s, z]], c[r[p[1], r[z, c[r[p[1], s], c[r[z, p[2]], c[ r[z, r[c[s, z], c[r[c[s, c[s, z]], z], p[2]]]], p[2]]], p[1]]]], p[2], p[3]]], p[1]]], p[1], p[1]], p[1]], p[2]]], p[n + 1], MapIndexed[c[r[z, c[r[p[1], p[4]], p[2], p[3], p[4]]], c[r[z, r[c[s, z], c[r[c[s, c[s, z]], z], p[2]]]], p[Length[#2] + 1]], # 1 〚 1 〛 , #1 〚 2 〛 ] & , Nest[Partition[#1, 2] & , Table[Nest[c[s, #] & z, FromDigits[Reverse[IntegerDigits[i, 2, n] /. rule] + 1, 3]], {i, 0, 2 n - 1}], n - 1], {0, n - 1}]], Range[n, 1, -1]] (For tag system (a) from page 94 this yields a primitive recursive function of size 325.) … Note that the same basic approach can be used to emulate Turing machines with recursive functions; the Turing machine configuration {s, list, n} can be encoded by an integer such as 2^FromDigits[Reverse[Take[list, n - 1]]] 3^FromDigits[Take[list, {n + 1, -1}]] 5^list 〚 n 〛 7 s

Random walks In one dimension, a random walk with t steps of length 1 starting at position 0 can be generated from NestList[(# + (-1)^Random[Integer])&, 0, t] or equivalently FoldList[Plus, 0, Table[(-1)^Random[Integer], {t}]] A generalization to d dimensions is then FoldList[Plus, Table[0, {d}], Table[RotateLeft[PadLeft[ {(-1)^Random[Integer]}, d], Random[Integer, d - 1]], {t}]] A fundamental property of random walks is that after t steps the root mean square displacement from the starting position is proportional to √ t . … As mentioned on page 1082 , the frequency spectrum Abs[Fourier[list]] 2 for a 1D random walk goes like 1/ ω 2 . … To make a random walk on a lattice with k directions in two dimensions, one can set up e = Table[{Cos[2 π s/k], Sin[2 π s/k]}, {s, 0, k - 1}] then use FoldList[Plus, {0, 0}, Table[e 〚 Random[Integer, {1, k}] 〛 , {t}]] It turns out that on any regular lattice, in any number of dimensions, the average behavior of a random walk is always isotropic.

Turing machines [emulating cellular automata] Given the rules for an elementary cellular automaton in the form used on page 867 , the following will construct a Turing machine which emulates it: CAToTM[rules_] := {{q[a_, b_], c : (0 | 1)}  {q[b, c], {a, b, c} /. rules, 1}, {q[_, _], x}  {p[0], 0, -1}, {p[a_], b : (0 | 1)}  {p[b], a, -1}, {p[_], x}  {q[0, 0], 0, 1}} Given a list of initial cell colors for the cellular automaton, the initial tape for the Turing machine consists of Join[{0, 0}, list, {0, 0}] surrounded by x 's, with the head of the Turing machine on the first 0 in state q[0, 0] .

For equations of the form ∂ tt u[t, x]  ∂ xx u[t, x] + f[u[t, x]] one can set up a simple finite difference method by taking f in the form of pure function and creating from it a kernel with space step dx and time step dt : PDEKernel[f_, {dx_, dt_}] := Compile[{a,b,c,d}, Evaluate[(2 b - d) + ((a + c - 2 b)/dx 2 + f[b]) dt 2 ]] Iteration for n steps is then performed by PDEEvolveList[ker_, {u0_, u1_}, n_] := Map[First, NestList[PDEStep[ker, #]&, {u0, u1}, n]] PDEStep[ker_, {u1_, u2_}] := {u2, Apply[ker, Transpose[ {RotateLeft[u2], u2, RotateRight[u2], u1}], {1}]} With this approach an approximation to the top example on page 165 can be obtained from PDEEvolveList[PDEKernel[ (1 - # 2 )(1 + #)&, {.1, .05}], Transpose[ Table[{1, 1} N[Exp[-x 2 ]], {x, -20, 20, .1}]], 400] For both this example and the middle one the results converge rapidly as dx decreases.

A string of balanced parentheses is analogous to a nested Mathematica list such as {{{}, {{}}}, {}} . The Mathematica expression tree for this list then has a structure analogous to the nested pattern in the picture.

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

In general, each successive element in a list from NeighborNumbers cannot be more than twice the previous element.

Common framework [for cellular automaton rules] The Mathematica built-in function CellularAutomaton discussed on page 867 handles general and totalistic rules in the same framework by using ListConvolve[w, a, r + 1] and taking the weights w to be respectively k^Table[i - 1, {i, 2r + 1}] and Table[1, {2r + 1}] .

Paperfolding sequences The sequence of up and down creases in a strip of paper that is successively folded in half is given by a substitution system; after t steps the sequence turns out to be NestList[Join[#, {0}, Reverse[1 - #]] &, {0}, t] .

But if one uses instead s = {1, 2} then starts with {1} and {2} one gets any of {{}, {1}, {2}, {1, 2}} and in general with s = Range[n] one gets any of the 2 n elements in the powerset Distribute[Map[{{}, {#}} &, s], List, List, List, Join] But applying Complement[s, Intersection[a, b]] to these elements still always produces the same equivalences as with a ⊼ b .