Search NKS | Online
11 - 20 of 25 for Union
![](/common/images/search/spacer.gif)
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 .
![](/common/images/search/spacer.gif)