Search NKS | Online
51 - 60 of 98 for Flatten
![](/common/images/search/spacer.gif)
With a list s of possible symbols, c[s, n] gives all possible expressions with LeafCount[expr] n :
c[s_, 1] = s; c[s_, n_] := Flatten[ Table[Outer[#1[#2] &, c[s, n - m], c[s, m]], {m, n - 1}]]
There are a total of Binomial[2n - 2, n - 1] Length[s] n /n such expressions.
Iterated run-length encoding
Starting say with {1} consider repeatedly replacing list by (see page 1070 )
Flatten[Map[{Length[#], First[#]} &, Split[list]]]
The resulting sequences contain only the numbers 1, 2 and 3, but otherwise at first appear fairly random.
Flatten[MapIndexed[ c[dlist, Reverse[#2]] #1 &, Reverse[data], {2}], 1]
Fractal dimensions [of additive cellular automata]
The total number of nonzero cells in the first t rows of the pattern generated by the evolution of an additive cellular automaton with k colors and weights w (see page 952 ) from a single initial 1 can be found using
g[w_, k_, t_] := Apply[Plus, Sign[NestList[Mod[ ListCorrelate[w, #, {-1, 1}, 0], k] &, {1}, t - 1]], {0, 1}]
The fractal dimension of this pattern is then given by the large m limit of
Log[k,g[w, k,k m + 1 ]/g[w, k, k m ]]
When k is prime it turns out that this can be computed as
d[w_, k_:2] := Log[k,Max[Abs[Eigenvalues[With[ {s = Length[w] - 1}, Map[Function[u, Map[Count[u, #] &, #1]], Map[Flatten[Map[Partition[Take[#, k + s - 1], s, 1] &, NestList[Mod[ListConvolve[w, #], k] &, #, k - 1]], 1] &, Map[Flatten[Map[{Table[0, {k - 1}], #} &, Append[#, 0]]] &, #]]] &[Array[IntegerDigits[#, k, s] &, k s - 1]]]]]]]
For rule 90 one gets d[{1, 0, 1}] = Log[2, 3] ≃ 1.58 .
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 .)
The pattern after n steps is then given by Nest[Flatten[f[#]] &, {0}, n] , where for the rule on page 189 f[z_] = 1/2 (1 - ) {z + 1/2, z - 1/2} ( f[z_] = (1 - ){z + 1, z} gives a transformed version).
The number of sequences s n of length n that can actually occur is given by
Apply[Plus, Flatten[MatrixPower[m, n]]]
where the adjacency matrix m is given by
MapAt[(1 + #) &, Table[0, {Length[net]}, {Length[net]}], Flatten[MapIndexed[{First[#2], Last[#1]} &, net, {2}], 1]]
For rule 32, for example, s n turns out to be Fibonacci[n + 3] , so that for large n it is approximately GoldenRatio n .
Logic circuits [from cellular automata]
The rules for the cellular automaton shown here are
{{0, 1, 1 | 3} 1, {0, 3, 3} 3, {1, 0, 0 | 1 | 3} 1, {1, 1, 3} 4, {1, 3, 0} 3, {1, 3, 3} 2, {2, 1, 3} 3, {2, 3, 0} 2, {2, 0, _} 4, {3, 3, 0} 3, {4, 0, 0 | 1 | 2 | 4} 2, {4, 3, 3} 3, {4, 1, 3} 1, {4, 3, 0} 4, {_, _, _} 0}
The initial conditions are given by
Flatten[Block[{And, Or}, Map[{0, 2 (# + 1)} &, expr, {-1}] //. {!
[Examples of] reducible systems
The color of a cell at step t and position x can be found by starting with initial condition
Flatten[With[{w = Max[Ceiling[Log[2, {t, x}]]]}, {2 Reverse[IntegerDigits[t, 2, w]] + 1, 5, 2 IntegerDigits[x, 2, w] + 2}]]
then for rule 188 running the cellular automaton with rule
{{a : (1 | 3), 1 | 3, _} a, {_, 2 | 4, a : (2 | 4)} a, {3, 5 | 10, 2} 6, {1, 5 | 7, 4} 0, {3, 5, 4} 7, {1, 6, 2} 10, {1, 6 | 11, 4} 8, {3, 6 | 8 | 10 | 11, 4} 9, {3, 7 | 9, 2} 11, {1, 8 | 11, 2} 9, {3, 11, 2} 8, {1, 9 | 10, 4} 11, {_, a_ /; a > 4, _} a, {_, _, _} 0}
and for rule 60 running the cellular automaton with rule
{{a : (1 | 3), 1 | 3, _} a, {_, 2 | 4, a : (2 | 4)} a, {1, 5, 4} 0, {_, 5, _} 5, {_, _, _} 0}
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}]
![](/common/images/search/spacer.gif)