Select[PM[s], Count[#, 1] > 1 &], 2]] while blocks of length n (and at most one error) can be decoded with Drop[(If[#  0, data, MapAt[1 - # &, data, #]] &)[ FromDigits[Mod[data .

Mechanical and thermal data are often mapped onto an array of nerve cells in the brain, from which features are extracted similar to those in visual perception.

The method can be implemented using Module[{a = Flatten[data], r, s}, {r, s} = Dimensions[data]; Partition[Do[ a 〚 i + {1, s - 1, s, s + 1} 〛 += m (a 〚 i 〛 - If[a 〚 i 〛 < 1/2, 0, 1]), {i, r s - s - 1}]; Map[If[# < 1/2, 0, 1] &, a], s]] In its original version m = {7, 3, 5, 1}/16 , as in the first row of pictures below.

Register machines [from cellular automata] Given the program for a register machine in the form used on page 896 , the rules for a cellular automaton that emulates it can be obtained from g[i[1], p_, m_] := {{_, p, _}  p + 1, {_, 0, p}  m + 2, {_, _, p}  m + 3} g[i[2], p_, m_] := {{_, p, _}  p + 1, {p, 0, _}  m + 5, {p, _, _}  m + 6} g[d[1, q_], p_, m_] := {{m + 2 | m + 3, p, _}  q, {m + 1, p, _}  p, {0, p, _}  p + 1, {_, m + 2 | m + 3, p}  m + 1} g[d[2, q_], p_, m_] := {{_, p, m + 5 | m + 6}  q, {_, p, m + 4}  p, {_, p, 0}  p + 1, {p, m + 5 | m + 6, _}  m + 4} RMToCA[prog_] := With[{m = Length[prog]}, Flatten[ {MapIndexed[g[#1, First[#2], m] &, prog], {{0, 0 | m + 1, m + 3}  m + 2, {0, m + 1, _}  0, {0, 0, m + 1}  0, {_, _, x : (m + 1 | m + 3)}  x, {_, m + 1 | m + 3, _}  m + 2, {m + 6, 0 | m + 4, 0}  m + 5, {_, m + 4, 0}  0, {m + 4, 0, 0}  0, {x : (m + 4 | m + 6), _, _}  x, {_, m + 4 | m + 6, _}  m + 5, {_, x_ , _}  x}}]] If m is the length of the register machine program, then the resulting cellular automaton has m + 7 possible colors for each cell.

Probably the simplest is a statement shown to be unprovable in Peano arithmetic by Laurence Kirby and Jeff Paris in 1982: that certain sequences g[n] defined by Reuben Goodstein in 1944 are of limited length for all n , where g[n_] := Map[First, NestWhileList[ {f[#] - 1, Last[#] + 1} &, {n, 3}, First[#] > 0 &]] f[{0, _}] = 0; f[{n_, k_}] := Apply[Plus, MapIndexed[#1 k^f[{#2 〚 1 〛 - 1, k}] &, Reverse[IntegerDigits[n, k - 1]]]] As in the pictures below, g[1] is {1, 0} , g[2] is {2, 2, 1, 0} and g[3] is {3, 3, 3, 2, 1, 0} . g[4] increases quadratically for a long time, with only element 3 × 2 402653211 - 2 finally being 0.

(The case shown corresponds to iteration of the map z  z - (z 3 - 1)/(3z 2 ) corresponding to Newton's method for finding the complex roots of z 3  1 .)

Examples include the Four-Color Theorem (coloring of maps), the optimality of the Kepler packing (see page 986 ), the completeness of the Robbins axiom system (see page 1151 ) and the universality of rule 110 (see page 678 ).

With a rule given in this form, a single step in the evolution of the Turing machine can be implemented with the function TMStep[rule_List, {s_, a_List, n_}] /; (1 ≤ n ≤ Length[a]) := Apply[{#1, ReplacePart[a, #2, n], n + #3}&, Replace[{s, a 〚 n 〛 }, rule]] The evolution for many steps can then be obtained using TMEvolveList[rule_, init_List, t_Integer] := NestList[TMStep[rule, #]&, init, t] An alternative approach is to represent the complete state of the Turing machine by MapAt[{s, #}&, list, n] , and then to use TMStep[rule_, c_] := Replace[c, {a___, x_, h_List, y_, b___}  Apply[{{a, x, #2, {#1, y}, b}, {a, {#1, x}, #2, y, b}} 〚 #3 〛 &, h /. rule]] The result of t steps of evolution from a blank tape can also be obtained from (see also page 1143 ) s = 1; a[_] = 0; n = 0; Do[{s, a[n], d} = {s, a[n]} /. rule; n += d, {t}]

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.

One can find the sequences of length n that work by using Nest[DeleteCases[Flatten[Map[Table[Append[#, i - 1], {i, k}] &, #], 1], {___, x__, x__, ___}] &, {{}}, n] and the number of these grows roughly like 3 n/4 .