Search NKS | Online
1 - 10 of 98 for Flatten
![](/common/images/search/spacer.gif)
Recursive subdivision [encoding]
In one dimension, encoding can be done using
Subdivide[a_] := Flatten[ If[Length[a] 2, a, If[Apply[SameQ, a], {1,First[a]}, {0, Map[Subdivide, Partition[a, Length[a]/2]]}]]]
In n dimensions, it can be done using
Subdivide[a_, n_] := With[{s = Table[1, {n}]}, Flatten[ If[Dimensions[a] 2s, a, If[Apply[SameQ, Flatten[a]], {1, First[Flatten[a]]}, {0, Map[Subdivide[#, n] &, Partition[a, 1/2Length[a] s], {n}]}]]]]
Sequence equations
Another way to set up 1D systems based on constraints is by having equations like Flatten[{x, 1, x, 0, y}] === Flatten[{0, y, 0, y, x}] , where each variable stands for a list.
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] 〛 ]}
Implementation [of 2D substitution systems]
With the rule on page 187 given for example by {1 {{1, 0}, {1, 1}}, 0 {{0, 0}, {0, 0}}} the result of t steps in the evolution of a 2D substitution system from a initial condition such as {{1}} is given by
SS2DEvolve[rule_, init_, t_] := Nest[Flatten2D[# /. rule] &, init, t]
Flatten2D[list_] := Apply[Join, Map[MapThread[Join, #] &, list]]
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# /. {x_, y_} {{x, y}, {x + 1, y}, {x, y + 1}}, 1] &, {{0, 0}}, n]
• Transpose[{Re[#], Im[#]}] &[ Flatten[Nest[{2 #, 2 # + 1, 2 # + } &, {0}, n]]]
(compare page 1005 )
• Position[Map[Split, NestList[Sort[Flatten[{#, # + 1}]] &, {0}, 2 n - 1]], _?(OddQ[Length[#]] &), {2}]
(see page 358 )
• Flatten[Table[Map[{t, #} &, Fold[Flatten[{#1, #1 + #2}] &, 0, Flatten[2^(Position[ Reverse[IntegerDigits[t, 2]], 1] - 1)]]], {t, 2 n - 1}], 1]
(see page 870 )
• Map[Map[FromDigits[#, 2] &, Transpose[Partition[#, 2]]] &, Position[Nest[{{#, #}, {#}} &, 1, n], 1] - 1]
(see page 509 )
A formatting hack giving the same visual pattern is
DisplayForm[Nest[SubsuperscriptBox[#, #, #] &, "1", n]]
Particularly dramatic are the concatenation systems discussed on page 913 , as well as successive rows in nested patterns such as Flatten[IntegerDigits[NestList[BitXor[#, 2 #] &, 1, 500], 2]] and sequences based on numbers such as Flatten[Table[If[GCD[i, j] 0, 1, 0], {i, 1000}, {j, i}]] (see page 613 ).
Cyclic tag systems which allow any value for each element can be obtained by adding the rule
CTStep[{{r_, s___}, {n_, a___}}] := {{s, r}, Flatten[{a, Table[r, {n}]}]}
The leading elements in this case can be obtained using
CTListStep[{rules_, list_}] := {RotateLeft[rules, Length[list]], With[{n = Length[rules]}, Flatten[Apply[Table[#1, {#2}] &, Map[Transpose[ {rules, #}] &, Partition[list, n, n, 1, 0]], {2}]]]}
Sequence equations
One can ask whether by replacing variables by sequences one can satisfy so-called word or string equations such as
Flatten[{x, 0, x, 0, y}] Flatten[{y, x, 0, y, 1, 0, 1, 0, 0}]
(with shortest solution x = {1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0} , y = {1, 0, 1, 0, 0, 1, 0, 1, 0, 0} ).
The tetrahedron network from page 476 is for example given in this representation by
{1 {2, 3, 4}, 2 {1, 3, 4}, 3 {1, 2, 4}, 4 {1, 2, 3}}
The list of nodes reached by following up to n connections from node i are then given by
NodeLists[g_, i_, n_] := NestList[Union[Flatten[# /. g]] &, {i}, n]
The network distance corresponding to the length of the shortest path between two nodes is given by
Distance[g_, {i_, j_}] := Length[NestWhileList[ Union[Flatten[# /. g]] &, {i}, !
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. … Transforms of 2D data are equivalent to 1D transforms of flattened data.
![](/common/images/search/spacer.gif)