Search NKS | Online
71 - 80 of 160 for Map
![](/common/images/search/spacer.gif)
Implementation [of causal networks]
Given a list of successive positions of the active cell, as from Map[Last, MAEvolveList[rule, init, t]] (see page 887 ), the network can be generated using
MAToNet[list_] := Module[{u, j, k}, u[_] = ∞ ; Reverse[ Table[j = list 〚 i 〛 ; k = {u[j - 1], u[j], u[j + 1]}; u[j - 1] = u[j] = u[j + 1] = i; i k, {i, Length[list], 1, -1}]]]
where nodes not yet found by explicit evolution are indicated by ∞ .
CTToR110[rules_ /; Select[rules, Mod[Length[#], 6] ≠ 0 &] {}, init_] := Module[{g1, g2, g3, nr = 0, x1, y1, sp}, g1 = Flatten[ Map[If[#1 === {}, {{{2}}}, {{{1, 3, 5 - First[#1]}}, Table[ {4, 5 - # 〚 n 〛 }, {n, 2, Length[#]}]}] &, rules] /. a_Integer Map[({d[# 〚 1 〛 , # 〚 2 〛 ], s[# 〚 3 〛 ]}) &, Partition[c[a], 3]], 4]; g2 = g1 = MapThread[If[#1 === #2 === {d[22, 11], s3}, {d[ 20, 8], s3}, #1] &, {g1, RotateRight[g1, 6]}]; While[Mod[ Apply[Plus, Map[# 〚 1, 2 〛 &, g2, 30] ≠ 0, nr++; g2 = Join[ g2, g1]]; y1 = g2 〚 1, 1, 2 〛 - 11; If[y1 < 0, y1 += 30]; Cases[ Last[g2] 〚 2 〛 , s[d[x_, y1], _, _, a_] (x1 = x + Length[a])]; g3 = Fold[sadd, {d[x1, y1], {}}, g2]; sp = Ceiling[5 Length[ g3 〚 2 〛 ]/(28 nr) + 2]; {Join[Fold[sadd, {d[17, 1], {}}, Flatten[Table[{{d[sp 28 + 6, 1], s[5]}, {d[398, 1], s[5]}, { d[342, 1], s[5]}, {d[370, 1], s[5]}}, {3}], 1]] 〚 2 〛 , bg[ 4, 11]], Flatten[Join[Table[bgi, {sp 2 + 1 + 24 Length[init]}], init /. {0 init0, 1 init1}, bg[1, 9], bg[6, 60 - g2 〚 1, 1, 1 〛 + g3 〚 1, 1 〛 + If[g2 〚 1, 1, 2 〛 < g3 〚 1, 2 〛 , 8, 0]]]], g3 〚 2 〛 }]
s[1] = struct[{3, 0, 1, 10, 4, 8}, 2];
s[2] = struct[{3, 0, 1, 1, 619, 15}, 2];
s[3] = struct[{3, 0, 1, 10, 4956, 18}, 2];
s[4] = struct[{0, 0, 9, 10, 4, 8}];
s[5] = struct[{5, 0, 9, 14, 1, 1}];
{c[1], c[2]} = Map[Join[{22, 11, 3, 39, 3, 1}, #] &, {{63, 12, 2, 48, 5, 4, 29, 26, 4, 43, 26, 4, 23, 3, 4, 47, 4, 4}, {87, 6, 2, 32, 2, 4, 13, 23, 4, 27, 16, 4}}];
{c[3], c[4], c[5]} = Map[Join[#, {4, 17, 22, 4, 39, 27, 4, 47, 4, 4}] &, {{17, 22, 4, 23, 24, 4, 31, 29}, {17, 22, 4, 47, 18, 4, 15, 19}, {41, 16, 4, 47, 18, 4, 15, 19}}]
{init0, init1} = Map[IntegerDigits[216 (# + 432 10 49 ), 2] &, {246005560154658471735510051750569922628065067661, 1043746165489466852897089830441756550889834709645}]
bgi = IntegerDigits[9976, 2]
bg[s_, n_] := Array[bgi 〚 1 + Mod[# - 1, 14] 〛 &, n, s]
ev[s[d[x_, y_], pl_, pr_, b_]] := Module[{r, pl1, pr1}, r = Sign[BitAnd[2^ListConvolve[{1, 2, 4}, Join[bg[pl - 2, 2], b, bg[pr, 2]]], 110]]; pl1 = (Position[r - bg[pl + 3, Length[r]], 1 | -1] /. {} {{Length[r]}}) 〚 1, 1 〛 ; pr1 = Max[pl1, (Position[r - bg[pr + 5 - Length[r], Length[r]], 1 | -1] /. {} {{1}}) 〚 -1, 1 〛 ]; s[d[x + pl1 - 2, y + 1], pl1 + Mod[pl + 2, 14], 1 + Mod[pr + 4, 14] + pr1 - Length[r], Take[r, {pl1, pr1}]]]
struct[{x_, y_, pl_, pr_, b_, bl_}, p_Integer : 1] := Module[ {gr = s[d[x, y], pl, pr, IntegerDigits[b, 2, bl]], p2 = p + 1}, Drop[NestWhile[Append[#, ev[Last[#]]] &, {gr}, If[Rest[Last[#]] === Rest[gr], p2--]; p2 > 0 &], -1]]
sadd[{d[x_, y_], b_}, {d[dx_, dy_], st_}] := Module[{x1 = dx - x, y1 = dy - y, b2, x2, y2}, While[y1 > 0, {x1, y1} += If[Length[st] 30, {8, -30}, {-2, -3}]]; b2 = First[Cases[st, s[d[x3_, -y1], pl_, _, sb_] Join[bg[pl - x1 - x3, x1 + x3], x2 = x3 + Length[sb]; y2 = -y1; sb]]]; {d[x2, y2], Join[b, b2]}]
CTToR110[{{}}, {1}] yields blocks of lengths {7204, 1873, 7088} .
3D class 4 [cellular automaton] rules
With a cubic lattice of the type shown on page 183 , and with updating rules of the form
LifeStep3D[{p_, q_, r_}, a_List] := MapThread[If[ #1 1 && p ≤ #2 ≤ q || #2 r, 1, 0]&, {a, Sum[RotateLeft[ a, {i, j, k}], {i, -1, 1}, {j, -1, 1}, {k, -1, 1}] - a}, 3]
Carter Bays discovered between 1986 and 1990 the three examples {5, 7, 6} , {4, 5, 5} , and {5, 6, 5} .
With this setup, a network consisting of just one node is {{1, 1}} and a 1D array of n nodes can be obtained with
CyclicNet[n_] := RotateRight[ Table[Mod[{i - 1, i + 1}, n] + 1, {i, n}]]
With above connections represented as 1 and the below connections as 2 , the node reached by following a succession s of connections from node i is given by
Follow[list_, i_, s_List] := Fold[list 〚 #1 〛 〚 #2 〛 &, i, s]
The total number of distinct nodes reached by following all possible succession of connections up to length d is given by
NeighborNumbers[list_, i_Integer, d_Integer] := Map[Length, NestList[Union[Flatten[list 〚 # 〛 ]] &, Union[list 〚 i 〛 ], d - 1]]
For each such list the rules for the network system then specify how the connections from node i should be rerouted. … With rules set up in this way, each step in the evolution of a network system is given by
NetEvolveStep[{depth_Integer, rule_List}, list_List] := Block[ {new = {}}, Join[Table[Map[NetEvolveStep1[#, list, i] &, Replace[NeighborNumbers[list, i, depth], rule]], {i, Length[list]}], new]]
NetEvolveStep1[s : {___Integer}, list_, i_] := Follow[list, i, s]
NetEvolveStep1[{s1 : {___Integer}, s2 : {___Integer}}, list_, i_] := Length[list] + Length[ AppendTo[new, {Follow[list, i, s1], Follow[list, i, s2]}]]
The set of nodes that can be reached from node i is given by
ConnectedNodes[list_, i_] := FixedPoint[Union[Flatten[{#, list 〚 # 〛 }]] &, {i}]
and disconnected nodes can be removed using
RenumberNodes[list_, seq_] := Map[Position[seq, #] 〚 1, 1 〛 &, list 〚 seq 〛 , {2}]
The sequence of networks obtained on successive steps by applying the rules and then removing all nodes not connected to node number 1 is given by
NetEvolveList[rule_, init_, t_Integer] := NestList[(RenumberNodes[#, ConnectedNodes[#, 1]] &)[ NetEvolveStep[rule, #]] &, init, t]
Note that the nodes in each network are not necessarily numbered in the order that they appear on successive lines in the pictures in the main text.
({i_, u_} {j_, v_, r_}) {Map[#[i] {#[i, 1], #[i, 0]} &, {a, b, c, d}], If[r 1, {a[i, u] {a[j], a[j]}, b[i, u] Table[b[j], {4}], c[i, u] Flatten[{Table[b[j], {2v}], Table[c[j], {2 - u}]}], d[i, u] {d[j]}}, {a[i, u] Table[a[j], {2 - u}], b[i, u] {b[j]}, c[i, u] Flatten[{c[j], c[j], Table[d[j], {2v}]}], d[i, u] Table[d[j], {4}]}]}]]}
A Turing machine in state i with a blank tape corresponds to initial condition {a[i], a[i], c[i]} for the tag system. The configuration of the tape on each side of the head in the Turing machine evolution can be obtained from the tag system evolution using
Cases[history, x : {a[_], ___} Apply[{#1, Reverse[#2]} &, Map[ Drop[IntegerDigits[Count[x, #], 2], -1] &, {_b, _d}]]]
But ever since the mid-1800s synoptic weather maps of large areas have been available that summarize conditions in terms of features like fronts and cyclones. … But it seems that over most of a typical weather map there is no such sensitivity—so that in the end the difficulties of weather prediction are probably much more a result of computational irreducibility and of the sophisticated kinds of computations that the Principle of Computational Equivalence implies should often occur even in simple fluids.
Mobile automata [from cellular automata]
Given a mobile automaton with rules in the form used on page 887 , a cellular automaton which emulates it can be constructed using
MAToCA[rules_] := Append[Flatten[Map[g, rules]], {_, _, x_, _, _} x]
g[{a_, b_, c_} {d_, e_}] := {{_, a, b + 2, c, _} d, If[e 1, {a, b + 2, c, _, _} c + 2, {_, _, a, b + 2, c} a + 2]}
This specific definition assumes that the mobile automaton has two possible colors for each cell; it yields a cellular automaton with four possible colors for each cell.
(Standard evaluation in Mathematica is equivalent to expr //. rules and uses the same ordering, while Map uses a different order.)
With this setup successive steps in the evolution of the system can be obtained from
GMAStep[rules_, {list_, nlist_}] := Module[{a, na}, {a, na} = Transpose[Map[Replace[Take[list, {# - 1, # + 1}], rules]&, nlist]]; {Fold[ReplacePart[#, Last[#2], First[#2]]&, list, Transpose[{nlist, a}]], Union[Flatten[nlist + na]]}]
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}]]]}
![](/common/images/search/spacer.gif)