Search NKS | Online
11 - 20 of 93 for NestList
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. The rule {2, 3} {{2, 1}, {1}} specifies that when NeighborNumbers gives {2, 3} for a node i , the connections from that node should become {Follow[list, i, {2, 1}], Follow[list, i, {1}]} . … 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.
Implementation [of symbolic systems]
The evolution for t steps of the first symbolic system shown can be implemented simply by
NestList[#/. ℯ [x_][y_] x[x[y]]&, init, t]
Implementation [of 3/2 system]
The evolution for t steps of the system at the top of the page can be computed simply by
NestList[If[EvenQ[#], 3#/2, 3(# + 1)/2] &, 1, t]
Implementation [of continuous cellular automata]
The state of a continuous cellular automaton at a particular step can be represented by a list of numbers, each lying between 0 and 1. This list can then be updated using
CCAEvolveStep[f_, list_List] := Map[f, (RotateLeft[list] + list + RotateRight[list])/3]
CCAEvolveList[f_, init_List, t_Integer] := NestList[CCAEvolveStep[f, #] &, init, t]
where for the rule on page 157 f is FractionalPart[3#/2] & while for the rule on page 158 it is FractionalPart[# + 1/4] & .
Note that in the definitions above, the elements of list can be either exact rational numbers, or approximate numbers obtained using N .
Implementation [of register machines]
The state of a register machine at a particular step can be represented by the pair {n, list} , where n gives the position in the program of current instruction being executed (the "program counter") and list gives the values of the registers. … With this setup, the evolution of any register machine can be implemented using the functions (a typical initial condition is {1, {0, 0}} )
RMStep[prog_, {n_Integer, list_List}] := If[n > Length[prog], {n, list}, RMExecute[prog 〚 n 〛 , {n, list}]]
RMExecute[i[r_], {n_, list_}] := {n + 1, MapAt[(# + 1)&, list, r]}
RMExecute[d[r_, m_], {n_, list_}] := If[list 〚 r 〛 > 0, {m, MapAt[(# - 1)&, list, r]}, {n + 1, list}]
RMEvolveList[prog_, init:{_Integer, _List}, t_Integer] := NestList[RMStep[prog, #]&, init, t]
The total number of possible programs of length n using k registers is (k (1 + n)) n .
Multiway tag systems
As an extension of ordinary multiway systems one can generalize tag systems from page 93 to allow a list of strings at each step. Representing the strings by lists, one can write rules in the form
{{1, 1, s___} {s, 1, 0}, {1, s___} {s, 1, 0, 1}}
so that the evolution is given by
MWTSEvolve[rule_, list_, t_] := Nest[Flatten[Map[ReplaceList[#, rule] &, #], 1] &, list, t]
Higher-dimensional generalizations [of substitution systems]
The state of a d -dimensional substitution system can be represented by a nested list of depth d . 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.
Digit count sequences
Starting say with {1} repeatedly replace list by
Join[list, IntegerDigits[Apply[Plus, list], 2]]
The resulting sequences grow in length roughly like n Log[n] . … A definite nested structure similar to picture (c) on page 130 is evident.
Implementation [of multiway systems]
It is convenient to represent the state of a multiway system at each step by a list of strings, where an individual string is for example "ABBAAB" . The rules for the multiway system can then be given for example as
{"AAB" "BB", "BA" "ABB"}
The evolution of the system is given by the functions
MWStep[rule_List, slist_List] := Union[Flatten[ Map[Function[s, Map[MWStep1[#, s] &, rule]], slist]]]
MWStep1[p_String q_String, s_String] := Map[StringReplacePart[s, q, #] &, StringPosition[s, p]]
MWEvolveList[rule_, init_List, t_Integer] := NestList[MWStep[rule, #] &, init, t]
An alternative approach uses lists instead of strings, and in effect works by tracing the internal steps that Mathematica goes through in trying out possible matchings. With the rule from above written as
{{x___, 0, 0, 1, y___} {x, 1, 1, y}, {x___, 1, 0, y___} {x, 0, 1, 1, y}}
MWStep can be rewritten as
MWStep[rule_List, slist_List] := Union[Flatten[Map[ReplaceList[#, rule] &, slist], 1]]
The case shown on page 206 is
{"AB" "", "ABA" "ABBAB", "ABABBB" "AAAAABA"}
starting with {"ABABAB"} .
Conway considered fraction systems based on rules of the form
FSEvolveList[fracs_, init_, t_] := NestList[First[Select[fracs #, IntegerQ, 1]] &, init, t]
With the choice
fracs = {17/91, 78/85, 19/51, 23/38, 29/33, 77/29, 95/ 23, 77/19, 1/17, 11/13, 13/11, 15/14, 15/2, 55/1}
starting at 2 the result for Log[2, list] is as shown below, where Rest[Log[2, Select[list, IntegerQ[Log[2, #]] &]]] gives exactly the primes.