The maximum halting times for the first few sizes n are {5, 159, 161, 1021, 5419, 315391, 1978213883, 1978213885, 3018415453261} These occur for inputs {1, 2, 5, 10, 26, 34, 106, 213, 426} and correspond to outputs (each themselves maximal for given n ) 2^{3, 23, 24, 63, 148, 1148, 91148, 91149, 3560523} - 1 Such maxima often seem to occur when the input x has the form (20 4 s - 2)/3 (and so has digits {1, 1, 0, 1, 0, … , 1, 0} ).

And for it to all have been even remotely possible has required a series of particular personal circumstances. … And indeed, within my company I have been able to build up a remarkable group of people—who have supported my efforts in all sorts of ways. … Part of what has allowed me to do this is reading an immense number of books, articles and websites.

The top plot is exactly for case (b); the bottom one is for a system three times larger in size.

In rules like the ones at the top of page 500 where each replacement involves just a single element this is inevitably how things must work.

In each case the input data is shown on top, and the output is shown below.

Make the person in the middle of the top row of seats hold up a black card, and make everyone else in that row hold up a white card.

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

Implementation [of my PDEs] All the numerical solutions shown were found using the NDSolve function built into Mathematica. … 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 slight complication is that the patterns have to include all nodes whose connections go to nodes whose labels are changed by the update. The rule at the top of page 509 must therefore be written out as and this corresponds to the Mathematica rule u[i1_  v[i2_, i3_, i4_], i3_  v[i1_, i5_, i6_], i4_  v[i1_, i7_, i8_]]  u[i1  v[i2, new[1], new[2]], new[1]  v[i1, new[2], i3], new[2]  v[i1, new[1], i4], i3  v[new[1], i5, i6], i4  v[new[2], i7, i8]] (Strictly there also need to be additional rules to cover where for example nodes 3 and 4 are actually the same.)

Andrei Markov gave a specific example of this for a semigroup with 13 generators and 33 relations, and by 1966 Gennadií Makanin had found the simpler example {"CCBB" ↔ "BBCC", "BCCCBB" ↔ "CBBBCC", "ACCBB" ↔ "BBA", "ABCCCBB" ↔ "CBBA", "BBCCBBBBCC" ↔ "BBCCBBBBCCA"} Using these relations as rules for a multiway system most initial strings yield behavior that either dies out or becomes repetitive.