Implementation [of operators from axioms] Given an axiom system in the form {f[a, f[a, a]]  a, f[a, b]  f[b, a]} one can find rule numbers for the operators f[x, y] with k values for each variable that are consistent with the axiom system by using Module[{c, v}, c = Apply[Function, {v = Union[Level[axioms, {-1}]], Apply[And, axioms]}]; Select[Range[0, k k 2 - 1], With[{u = IntegerDigits[#, k, k 2 ]}, Block[{f}, f[x_, y_] := u 〚 -1 - k x - y 〛 ; Array[c, Table[k, {Length[v]}], 0, And]]] &]] For k = 4 this involves checking nearly 16 4 or 4 billion cases, though many of these can often be avoided, for example by using analogs of the so-called Davis–Putnam rules.

[Universality of] set theory Any integer n can be encoded as a set using for example Nest[Union[#, {#}] &, {}, n] .

Given a sequence of length n , an approximation to h can be reconstructed using Max[MapIndexed[#1/First[#2] &, FoldList[Plus, First[list], Rest[list]]]] The fractional part of the result obtained is always an element of the Farey sequence Union[Flatten[Table[a/b, {b, n}, {a, 0, b}]]] (See also pages 892 , 932 and 1084 .)

Starting with a list of nodes, the nodes reached by following arcs with value a for one step are given by NetStep[net_, i_, a_] := Union[ReplaceList[a, Flatten[net 〚 i 〛 ]]] A list of values then corresponds to a path in the network starting from any node if Fold[NetStep[net, #1, #2]&, Range[Length[net]], list] =!… = {}, 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. … To obtain such trimmed networks one can apply the function TrimNet[net_] := With[{m = Apply[Intersection, Map[FixedPoint[ Union[#, Flatten[Map[Last, net 〚 # 〛 , {2}]]]&, #]&, Map[List, Range[Length[net]]]]]}, net 〚 m 〛 /.

Implementation [of TM cellular automaton] Given a non-deterministic Turing machine with rules in the form above, the rules for a cellular automaton which emulates it can be obtained from NDTMToCA[tm_] := Flatten[{{_, h, _}  h, {s, _c, _}  e, {s, _, _}  s, {_, s, c[i_]}  s[i], {_, s, x_}  x, {a[_, _], _s, _}  s, {_, a[x_, y_], s[i_]}  a[x, y, i], {x_, _s, _}  x, {_, _, s[i_]}  s[i], Map[Table[With[{b = (# 〚 Min[Length[#], z] 〛 &)[ {x, #} /. tm]}, If[Last[b]  -1, {{a[_], a[x, #, z], e}  h, {a[ _], a[x, #, z], s}  a[x, #, z], {a[_], a[x, #, z], _}  a[b 〚 2 〛 ], {a[x, #, z], a[w_], _}  a[b 〚 1 〛 , w], {_, a[w_], a[x, #, z]}  a[w]}, {{a[_], a[x, #, z], _}  a[b 〚 2 〛 ], {a[x, #, z], a[w_], _}  a[w], {_, a[w_], a[x, #, z]}  a[b 〚 1 〛 , w]}]], {x, Max[Map[# 〚 1, 1 〛 &, tm]]}, {z, Max[Map[Length[# 〚 2 〛 ] &, tm]]}] &, Union[Map[# 〚 1, 2 〛 &, tm]]], {_, x_, _}  x}]

With this setup, each step then corresponds to LifeStep[list_] := With[{p=Flatten[Array[List, {3, 3}, -1], 1]}, With[{u = Split[Sort[Flatten[Outer[Plus, list, p, 1], 1]]]}, Union[Cases[u, {x_, _, _}  x], Intersection[Cases[u, {x_, _, _, _}  x], list]]]] (A still more efficient implementation is based on finding runs of length 3 and 4 in Sort[u] .)

For any sequence s this can be done using Module[{c, m = 0}, Map[c[#] = {m, m += Count[s, #]/Length[s]} &, Union[s]]; Function[x, (First[RealDigits[2 # Ceiling[2 -# Min[x]], 2, -#, -1]] &)[Floor[Log[2, Max[x] - Min[x]]]]][ Fold[(Max[#1] - Min[#1]) c[#2] + Min[#1] &, {0, 1}, s]]] Huffman coding of a sequence containing a single 0 block together with n 1 blocks will yield output of length about n ; arithmetic coding will yield length about Log[n] .

[Converting from CAs with] more colors Given a rule that involves three colors and nearest neighbors, the following converts each case of the rule to a collection of cases for a rule with two colors: CA3ToCA2[{a_, b_, c_}  d_] := Union[Flatten[Table[Thread[ Partition[Flatten[{l, a, b, c, r} /. coding], 11, 1] 〚 {2, 3, 4} 〛  (d /. coding)], {l, 0, 2}, {r, 0, 2}], 2]] coding = {0  {0, 0, 0}, 1  {0, 0, 1}, 2  {0, 1, 1}} The problem of encoding cells with several colors by blocks of black and white cells is related to standard problems in coding theory (see page 560 ).

In general the density for an arrangement of white squares with offsets v is given in s dimensions by (no simple closed formula seems to exist except for the 1 × 1 case) Product[With[{p = Prime[n]}, 1 - Length[Union[Mod[v, p]]]/p s ], {n, ∞ }] White squares correspond to lattice points that are directly visible from the origin at the top left of the picture, so that lines to them do not pass through any other integer points.

This can be done for blocks up to length n in a 1D cellular automaton with k colors using ReversibleQ[rule_, k_, n_] := Catch[Do[ If[Length[Union[Table[CAStep[rule, IntegerDigits[i, k, m]], {i, 0, k m - 1}]]] ≠ k m , Throw[False]], {m, n}]; True] For k = 2 , r = 1 it turns out that it suffices to test only up to n = 4 (128 out of the 256 rules fail at n = 1 , 64 at n = 2 , 44 at n = 3 and 14 at n = 4 ); for k = 2 , r = 2 it suffices to test up to n = 15 , and for k = 3 , r = 1 , up to n = 9 .