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