# Search NKS | Online

21 - 30 of 61 for Join

The matrices for size n = 2 s can be obtained from
Nest[Apply[Join, f[{Map[Flatten[Map[{#, #} &, #]] &, #], Map[Flatten[Map[{#, -#} &, #]] &, g[#]]}]] &, {{1}},s]
with (a) f = Identity , g = Reverse , (b) f = Transpose , g = Identity , and (c) f = g = Identity . … It exhibits a nested structure, and can be obtained as in the pictures below from the evolution of a 2D substitution system, or equivalently from a Kronecker product as in
Nest[Flatten2D[Map[# {{1, 1}, {1, -1}} &, #, {2}]] &, {{1}}, s]
with
Flatten2D[a_] := Apply[Join, Apply[Join, Map[Transpose,a], {2}]]
(c) is known as dyadic or Paley order.

One can also consider building up lists of non-identical elements, say by successively using Join .

The evolution of the system for t steps can be obtained from
SSEvolve[rule_, init_, t_, d_Integer] := Nest[FlattenArray[# /. rule, d] &, init, t]
FlattenArray[list_, d_] := Fold[Function[{a, n}, Map[MapThread[Join, #, n] &, a, -{d + 2}]], list, Reverse[Range[d] - 1]]
The analog in 3D of the 2D rule on page 187 is
{1 Array[If[LessEqual[##], 0, 1] &, {2, 2, 2}], 0 Array[0 &, {2, 2, 2}]}
Note that in d dimensions, each black cell must be replaced by at least d + 1 black cells at each step in order to obtain an object that is not restricted to a dimension d - 1 hyperplane.

In case (c), the following gives a list of the numbers of nodes generated up to step t :
FoldList[Plus, 1, Join[{1, 4, 12, 10, -20, 6, 4}, Map[d, IntegerDigits[Range[4, t - 5], 2]]]]
d[{___, 1}] = 1
d[{1, p : 0 .., 0}] := -Apply[Plus, 4 Range[Length[{p}]] - 1] + 6
d[{__, 1, p : 0 .., 0}] := d[{1, p, 0}] - 7
d[{___, p : 1 .., q : 0 ..., 1, 0}] := 4 Length[{p}] + 3 Length[{q}] + 2
d[{___, p : 1 .., 1, 0}] := 4 Length[{p}] + 2

Cyclic tag systems [emulating tag systems]
From a tag system which depends only on its first element, with rules given as in the note below, the following constructs a cyclic tag system emulating it:
TS1ToCT[{n_, subs_}] := With[{k = Length[subs]}, Join[Map[v[Last[#], k] &, subs], Table[{}, {k(n - 1)}]]]
u[i_, k_] := Table[If[j i + 1, 1, 0], {j, k}]
v[list_, k_] := Flatten[Map[u[#, k] &, list]]
The initial condition for the tag system can be converted using v[list, k] .

Implementation [of tag systems]
With the rules for case (a) on page 94 given for example by
{2, {{0, 0} {1, 1}, {1, 0} {}, {0, 1} {1, 0}, {1, 1} {0, 0, 0}}}
the evolution of a tag system can be obtained from
TSEvolveList[{n_, rule_}, init_, t_] := NestList[If[Length[#] < n, {}, Join[Drop[#, n], Take[#, n] /. rule]]&, init, t]
An alternative implementation is based on applying to the list at each step rules such as
{{0, 0, s___} {s, 1, 1}, {1, 0, s___} {s}, {0, 1, s___} {s, 1, 0}, {1, 1, s___} {s, 0, 0, 0}}
There are a total of ((k r + 1 - 1)/(k - 1)) k n possible rules if blocks up to length r can be added at each step and k colors are allowed.

Implementation [of cyclic tag systems]
With the rules for the cyclic tag system on page 95 given as {{1, 1}, {1, 0}} , the evolution can be obtained from
CTEvolveList[rules_, init_, t_] := Map[Last, NestList[CTStep, {rules, init}, t]]
CTStep[{{r_, s___}, {0, a___}}] := {{s, r}, {a}}
CTStep[{{r_, s___}, {1, a___}}] := {{s, r}, Join[{a}, r]}
CTStep[{u_, {}}] := {u, {}}
The leading elements on many more than t successive steps can be obtained directly from
CTList[rules_, init_, t_] := Flatten[Map[Last, NestList[CTListStep, {rules, init}, t]]]
CTListStep[{rules_, list_}] := {RotateLeft[rules, Length[list]],Flatten[rules 〚 Mod[Flatten[Position[list, 1]], Length[rules], 1] 〛 ]}

In such a rule, given a list of how many neighbors around a given cell (out of s possible) make the cell turn black the outer totalistic code for the rule can be obtained from
Apply[Plus, 2^Join[2 list, 2 Range[s + 1] - 1]]

Sierpiński pattern
Other ways to generate step n of the pattern shown here in various orientations include:
• Mod[Array[Binomial, {2, 2} n , 0], 2]
(see pages 611 and 870 )
• 1 - Sign[Array[BitAnd, {2, 2} n , 0]]
(see pages 608 and 871 )
• NestList[Mod[RotateLeft[#] + #, 2] &, PadLeft[{1}, 2 n ], 2 n - 1]
(see page 870 )
• NestList[Mod[ListConvolve[{1, 1}, #, -1], 2] &, PadLeft[{1}, 2 n ], 2 n - 1]
(see page 870 )
• IntegerDigits[NestList[BitXor[2#, #] &, 1, 2 n - 1], 2, 2 n ]
(see page 906 )
• NestList[Mod[Rest[FoldList[Plus, 0, #]], 2] &, Table[1, {2 n }], 2 n - 1]
(see page 1034 )
• Table[PadRight[ Mod[CoefficientList[(1 + x) t - 1 , x], 2], 2 n - 1], {t, 2 n }]
(see pages 870 and 951 )
• Reverse[Mod[CoefficientList[Series[1/(1 - (1 + x)y), {x, 0, 2 n - 1}, {y, 0, 2 n - 1}], {x, y}], 2]]
(see page 1091 )
• Nest[Apply[Join, MapThread[ Join, {{#, #}, {0 #, #}}, 2]] &, {{1}}, n]
(compare page 1073 )
The positions of black squares can be found from:
• Nest[Flatten[2# /.

[Turing] machine 596440
For any list of initial colors init , it turns out that successive rows in the first t steps of the compressed evolution pattern turn out to be given by
NestList[Join[{0}, Mod[1 + Rest[FoldList[Plus, 0, #]], 2], {{0}, {1, 1, 0}} 〚 Mod[Apply[Plus, #], 2] + 1] 〛 &, init, t]
Inside the right-hand part of this pattern the cell values can then be obtained from an upside-down version of the rule 60 additive cellular automaton, and starting from a sequence of 1 's the picture below shows that a typical rule 60 nested pattern can be produced, at least in a limited region.