If all possible sequences of colors were allowed, then there would be k possibilities for what block could follow a given block, given by Map[Rest, Table[Append[list, i], {i, 0, k - 1}]] .

Table[0, {n}] .

(Ordinary quasigroups are defined by {a ∘ c  b, d ∘ a  b} with c , d unique for given a , b —so that their table is a Latin square; their axioms can be set up with 3 operators as {a \ a ∘ b  b, a ∘ b / b  a, a ∘ (a \ b)  b, (a / b) ∘ b  a} .)

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.

In d dimensions with k colors, 5-neighbor rules generalize to (2d + 1) -neighbor rules, with CAStep[{rule_, d_}, a_] := Map[rule 〚 -1 - # 〛 &, a + k AxesTotal[a, d], {d}] AxesTotal[a_, d_] := Apply[Plus, Map[RotateLeft[a, #] + RotateRight[a, #]&, IdentityMatrix[d]]] with rule given by IntegerDigits[code, k, k(2d(k - 1) + 1)] . 9-neighbor rules generalize to 3 d -neighbor rules, with CAStep[{rule_, d_}, a_] := Map[rule 〚 -1 - # 〛 &, a + k FullTotal[a, d], {d}] FullTotal[a_, d_] := Array[RotateLeft[a, {##}] &, Table[3, {d}], -1, Plus] - a with rule given by IntegerDigits[code, k, k((3 d - 1)(k - 1) + 1)] .

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 .

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

Sequential substitution systems [from cellular automata] Given a sequential substitution system with rules in the form used on page 893 , the rules for a cellular automaton which emulates it can be obtained from SSSToCA[rules_] := Flatten[{{v[_, _, _], u, _}  u, {_, v[rn_, x_, _], u}  r[rn + 1, x], {_, v[_, x_, _], _}  x, MapIndexed[ With[{r n = #2 〚 1 〛 , rs = #1 〚 1 〛 , rr = #1 〚 2 〛 }, {If[Length[rs]  1, {u, r[rn, First[rs]], _}  q[0, rr], {u, r[rn, First[rs]], _}  v[rn, First[rs], Take[rs, 1]]], {u, r[rn, x_], _}  v[rn, x, {}], {v[rn, _, Drop[rs, -1]], Last[rs], _}  q[Length[rs] - 1, rr], Table[{v[rn, _, Flatten[{___, Take[rs, i - 1]}]], rs 〚 i 〛 , _}  v[ rn, rs 〚 i 〛 , Take[rs, i]], {i, Length[rs] - 1, 1, -1}], {v[rn, _, _], y_, _}  v[rn, y, {}]}] & , rules /. s  List], {_, q[0, {x__, _}], _}  q[0, {x}], {_, q[0, {x_}], _}  r[1, x], {_, q[0, {}], x_}  r[1, x], {_, q[_, {___, x_}], _}  x, {_, q[_, {}], x_}  x, {_, x_, q[0, _]}  x, {_, _, q[n_, {}]}  q[n - 1, {}], {_, _, q[n_, {x___, _}]}  q[n - 1, {x}], {q[_, {}], _, _}  w, {q[0, {__, x_}], p[y_, _], _}  p[x, y], {q[0, {__, x_}], y_, _}  p[x, y], {p[_, x_], p[y_, _], _}  p[x, y], {p[_, x_], u, _}  x, {p[_, x_], y_, _}  p[x, y], {_, p[x_, _], _}  x, {w, u, _}  u, {w, x_, _}  w, {_, w, x_}  x, {_, r[rn_, x_], _}  x, {_, u, r[_, _]}  u, {_, x_, r[rn_, _]}  r[rn, x], {_, x_, _}  x}] The initial condition is obtained by applying the rule s[x_, y__]  {r[1, x], y} and then padding with u 's.

In general, bitwise optimizations require representing cellular automaton rules not by simple look-up tables but rather by Boolean expressions, which must be derived for each rule and can be quite complicated (see page 869 ).

The first one on the bottom (with 63 comparisons) has a nested structure and uses the method invented by Kenneth Batcher in 1964: Flatten[Reverse[Flatten[With[{m = Ceiling[Log[2, n]] - 1}, Table[With[{d = If[i  m, 2 t , 2 i + 1 - 2 t ]}, Map[ {0, d} + # &, Select[Range[n - d], BitAnd[# - 1, 2 t ]  If[i  m, 0, 2 t ] &]]], {t, 0, m}, {i, t, m}]], 1]], 1] The second one on the bottom also uses 63 comparisons, while the last one is the smallest known for n = 16 : it uses 60 comparisons and was invented by Milton Green in 1969.