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

Each collection of such functions can be obtained from lists of vectors representing 1D Walsh functions by using Outer[Outer[Times, ##] &, b, b, 1, 1] , or equivalently Map[Transpose, Map[# b &, b, {2}]] . … The matrices for size n = 2 s can be obtained from Nest[Apply[Join, f[{Map[Flatten[Map[{#, #} &, #]] &, #], Map[Flatten[Map[{#, -#} &, #]] &, g[#]]}]] &, {{1}},s] with (a) f = Identity , g = Reverse , (b) f = Transpose , g = Identity , and (c) f = g = Identity . … Walsh functions were used by electrical engineers such as Frank Fowle in the 1890s to find transpositions of wires that minimized crosstalk; they were introduced into mathematics by Joseph Walsh in 1923.

[Generating sequences with] unequal probabilities Given a sequence a of n equally probable 0's and 1's, the following generates a single 0 or 1 with probabilities approximating {1 - p, p} to n digits: Fold[({BitAnd, BitOr} 〚 1 + First[#2] 〛 [#1, Last[#2]]) &, 0, Reverse[Transpose[{First[RealDigits[p, 2, n, -1]], a}]]] This can be generalized to allow a whole sequence to be generated with as little as an average of two input digits being used for each output digit.

Surprisingly enough, this simple procedure, which can be represented by the function s[list_] := Flatten[ Transpose[Reverse[Partition[list, Length[list]/2]]]] with or without the Reverse , is able to produce orderings which at least in some respects seem quite random.

In general, if a period m is possible then so must all periods n for which p = {m, n} satisfies OrderedQ[Transpose[If[MemberQ[p/#, 1], Map[Reverse, {p/#, #}], {#, p/#}]] &[2^IntegerExponent[p, 2]]] Extensions of this to other types of systems seem difficult to find, but it is conceivable that when viewed as continuous mappings on a Cantor set (see page 869 ) at least some cellular automata might exhibit similar properties.

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.

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

Thus, for example, rule 30 can be given as {{1, 1, 1}  0, {1, 1, 0}  0, {1, 0, 1}  0, {1, 0, 0}  1, {0, 1, 1}  1, {0, 1, 0}  1, {0, 0, 1}  1, {0, 0, 0}  0} To use rules in this form, CAStep can be rewritten as CAStep[rule_, a_List] := Transpose[{RotateRight[a], a, RotateLeft[a]}] /. rule or CAStep[rule_, a_List] := Partition[a, 3, 1, 2] /. rule The rules that are given can now contain patterns, so that rule 90, for example, can be written as {{1, _, 1}  0, {1, _, 0}  1, {0, _, 1}  1, {0, _, 0}  0} But how can one set up a program that can handle rules in several different forms? … In each case, the use of Partition could be replaced by Transpose[Table[RotateLeft[a, i], {i, -r, r}]] .

= {}, AllNet[k], q = ISets[b = Map[Table[ Position[d, NetStep[net, #, a]] 〚 1, 1 〛 , {a, 0, k - 1}]&, d]]; DeleteCases[MapIndexed[#2 〚 2 〛 - 1  #1 &, Rest[ Map[Position[q, #] 〚 1, 1 〛 &, Transpose[Map[Part[#, Map[ First, q]]&, Transpose[b]]], {2}]] - 1, {2}], _  0, {2}]]] DSets[net_, k_:2] := FixedPoint[Union[Flatten[Map[Table[NetStep[net, #, a], {a, 0, k - 1}]&, #], 1]]&, {Range[Length[net]]}] ISets[list_] := FixedPoint[Function[g, Flatten[Map[ Map[Last, Split[Sort[Part[Transpose[{Map[Position[g, #] 〚 1, 1 〛 &, list, {2}], Range[Length[list]]}], #]], First[#1]  First[#2]&], {2}]&, g], 1]], {{1}, Range[2, Length[list]]}] If net has q nodes, then in general MinNet[net] can have as many as 2 q -1 nodes.

{x_, y_}  {{x, y}, {x + 1, y}, {x, y + 1}}, 1] &, {{0, 0}}, n] • Transpose[{Re[#], Im[#]}] &[ Flatten[Nest[{2 #, 2 # + 1, 2 # +  } &, {0}, n]]] (compare page 1005 ) • Position[Map[Split, NestList[Sort[Flatten[{#, # + 1}]] &, {0}, 2 n - 1]], _?(OddQ[Length[#]] &), {2}] (see page 358 ) • Flatten[Table[Map[{t, #} &, Fold[Flatten[{#1, #1 + #2}] &, 0, Flatten[2^(Position[ Reverse[IntegerDigits[t, 2]], 1] - 1)]]], {t, 2 n - 1}], 1] (see page 870 ) • Map[Map[FromDigits[#, 2] &, Transpose[Partition[#, 2]]] &, Position[Nest[{{#, #}, {#}} &, 1, n], 1] - 1] (see page 509 ) A formatting hack giving the same visual pattern is DisplayForm[Nest[SubsuperscriptBox[#, #, #] &, "1", n]]