Search NKS | Online
91 - 100 of 210 for Listable
![](/common/images/search/spacer.gif)
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 .
![](/common/images/search/spacer.gif)