From: A New Kind of Science, by Stephen Wolfram © 2002 Stephen Wolfram, LLC

Two Dimensions and Beyond

Cellular Automata

({{Implementation,  (page 927)}})

PadLeft[{{1}},{n,n},0,Floor[{n,n}/2]]

With[{n=5},PadLeft[{{1}},{n,n},0,Floor[{n,n}/2]]]

CAStep[rule_,a_]:=Map[rule[[10-#]]&,ListConvolve[{{0,2,0},{2,1,2},{0,2,0}},a,2],{2}]

CAStep[rule_,a_]:=Map[rule[[10-#]]&,ListConvolve[{{0,2,0},{2,1,2},{0,2,0}},a,2],{2}]

Grid[Nest[CAStep[IntegerDigits[942,2,10],#]&,With[{n=17},PadLeft[{{1}},{n,n},0,Floor[{n,n}/2]]],6]]

CAStep[rule_,a_]:=Map[rule[[18-#]]&,ListConvolve[{{2,2,2},{2,1,2},{2,2,2}},a,2],{2}]

CAStep[rule_,a_]:=Map[rule[[18-#]]&,ListConvolve[{{2,2,2},{2,1,2},{2,2,2}},a,2],{2}]

Grid[Nest[CAStep[IntegerDigits[175850,2,18],#]&,With[{n=17, k=7},PadLeft[PadRight[{Table[1,{k}]},{Ceiling[n/2],Floor[(k+n)/2]}],{n,n}]],7]]

CAStep[{rule_,d_},a_]:=Map[rule[[-1-#]]&,a+k AxesTotal[a,d],{d}]

AxesTotal[a_,d_]:=Apply[Plus,Map[RotateLeft[a,#]+RotateRight[a,#]&,IdentityMatrix[d]]]

IntegerDigits[code,k,k (2 d (k-1)+1)]

AxesTotal[a_,d_]:=Apply[Plus,Map[RotateLeft[a,#]+RotateRight[a,#]&,IdentityMatrix[d]]];
CAStep[{rule_,d_},a_]:=Map[rule[[-1-#]]&,a+k AxesTotal[a,d],{d}];

Grid[Block[{k=2,d=2,code=942},Nest[CAStep[{IntegerDigits[code,k,k (2 d (k-1)+1)],2},#]&,With[{n=17},PadLeft[{{1}},{n,n},0,Floor[{n,n}/2]]],6]]]

FullTotal[a_,d_]:=Array[RotateLeft[a,{##}]&,Table[3,{d}],-1,Plus]-a

CAStep[{rule_,d_},a_]:=Map[rule[[-1-#]]&,a+k FullTotal[a,d],{d}]

CAStep[{rule_,d_},a_]:=Map[rule[[-1-#]]&,a+k FullTotal[a,d],{d}]
FullTotal[a_,d_]:=Array[RotateLeft[a,{##}]&,Table[3,{d}],-1,Plus]-a

Grid[Block[{d=2,k=2,code=175850},Nest[CAStep[{IntegerDigits[code,k,k((3^d-1)(k-1)+1)],d},#]&,With[{n=17, s=7},PadLeft[PadRight[{Table[1,{s}]},{Ceiling[n/2],Floor[(s+n)/2]}],{n,n}]],7]]]

Graphics3D[Map[Cuboid[-Reverse[#]]&,Position[a,1]]]

With[{a={{{1,0,0},{1,1,0},{0,0,0}},{{0,0,0},{0,0,1},{0,0,0}},{{0,0,1},{0,0,1},{0,0,1}}}},Graphics3D[Map[Cuboid[-Reverse[#]]&,Position[a,1]]]]

({{General rules,  (page 927)}})

Reverse[Table[IntegerDigits[i-1,k,Length[os]],{i,k^Length[os]}]]

With[{k=2,os={{-1,0},{0,-1},{0,0},{0,1},{1,0}}},Reverse[Table[IntegerDigits[i-1,k,Length[os]],{i,k^Length[os]}]]]

Map[IntegerDigits[num,k,k^Length[os]][[-1-#]]&,Apply[Plus,MapIndexed[k^(Length[os]-First[#2]) RotateLeft[a,#1]&,os]],{-1}]

With[{a={{0,1,0},{1,1,1},{0,1,0}},k=2,os={{-1,0},{0,-1},{0,0},{0,1},{1,0}},num=234},Map[IntegerDigits[num,k,k^Length[os]][[-1-#]]&,Apply[Plus,MapIndexed[k^(Length[os]-First[#2]) RotateLeft[a,#1]&,os]],{-1}]]

Map[IntegerDigits[num,k,k^Length[os]][[-1-#]]&,ListCorrelate[Fold[ReplacePart[k #1,1,#2+r+1]&,Array[0&,Table[2 r+1,{d}]],os],a,r+1],{d}]

With[{d=2,r=1,a={{0,1,0},{1,1,1},{0,1,0}},k=2,os={{-1,0},{0,-1},{0,0},{0,1},{1,0}},num=234},Map[IntegerDigits[num,k,k^Length[os]][[-1 -#]]&,ListCorrelate[Fold[ReplacePart[k #1,1,#2+r+1]&,Array[0&,Table[2 r+1,{d}]],os],a,r+1],{d}]]

({{Numbers of possible rules,  (page 927)}})

Apply[Plus,2^Join[2 list,2 Range[s+1]-1]]

With[{s=8, list={3,5}},Apply[Plus,2^Join[2 list,2 Range[s+1]-1]]]

({{Symmetric 5-neighbor rules,  (page 928)}})

s={{1},{2,3,9,17},{4,10,19,25},{5},{6,7,13,21},{8,14,23,29},{11,18},{12,20,26,27},{15,22},{16,24,30,31},{28},{32}}

FromDigits[Map[Last,
Sort[Flatten[Map[Thread,Thread[{s,IntegerDigits[n,2,12]}]],1]]],2]

With[{n=12,s={{1},{2,3,9,17},{4,10,19,25},{5},{6,7,13,21},{8,14,23,29},{11,18},{12,20,26,27},{15,22},{16,24,30,31},{28},{32}}},FromDigits[Map[Last,
Sort[Flatten[Map[Thread,Thread[{s,IntegerDigits[n,2,12]}]],1]]],2]]

({{Ulam systems,  (page 928)}})

Map[First,First[Nest[UStep[p[q[r[#1],#2]]&,{{1,0},{0,1},{-1,0},{0,-1}},#]&,({#,#}&)[{{{0,0},{0,0}}}],t]]]

UStep[f_,os_,{a_,b_}]:=({Join[a,#],#}&)[f[Flatten[Outer[{#1+#2,#1}&,Map[First,b],os,1],1],a]]

r[c_]:=Map[First,Select[Split[Sort[c],First[#1]==First[#2]&],Length[#]==1&]]

q[c_,a_]:=Select[c,Apply[And,Map[Function[u,qq[#1,u,a]],a]]&]

p[c_]:=Select[c,Apply[And,Map[Function[u,pp[#1,u]],c]]&]

pp[{x_,u_},{y_,v_}]:=Max[Abs[x-y]]>1||u==v

qq[{x_,u_},{y_,v_},a_]:=x==y||Max[Abs[x-y]]>1||u==y||First[Cases[a,{u,z_}->z]]==y

UStep[f_,os_,{a_,b_}]:=({Join[a,#],#}&)[f[Flatten[Outer[{#1+#2,#1}&,Map[First,b],os,1],1],a]]
r[c_]:=Map[First,Select[Split[Sort[c],First[#1]==First[#2]&],Length[#]==1&]]
q[c_,a_]:=Select[c,Apply[And,Map[Function[u,qq[#1,u,a]],a]]&]
p[c_]:=Select[c,Apply[And,Map[Function[u,pp[#1,u]],c]]&]
pp[{x_,u_},{y_,v_}]:=Max[Abs[x-y]]>1||u==v
qq[{x_,u_},{y_,v_},a_]:=x==y||Max[Abs[x-y]]>1||u==y||First[Cases[a,{u,z_}->z]]==y

With[{t=5},Map[First,First[
Nest[UStep[p[q[r[#1],#2]]&,{{1,0},{0,1},{-1,0},{0,-1}},#]&,({#,#}&)[{{{0,0},{0,0}}}],t]]]]

Turing Machines

({{Implementation,  (page 930)}})

TM2DStep[rule_,{s_,tape_,r:{x_,y_}}]:=Apply[{#1,ReplacePart[tape,#2,{r}],r+#3}&,{s,tape[[x,y]]}/.rule]

TM2DStep[rule_,{s_,tape_,r:{x_,y_}}]:=Apply[{#1,ReplacePart[tape,#2,{r}],r+#3}&,{s,tape[[x,y]]}/.rule]

TableForm[NestList[TM2DStep[{{1,0}->{2,1,{0,1}},{1,1}->{2,0,{0,-1}},{2,0}->{4,1,{0,-1}},{2,1}->{3,0,{0,1}},{3,0}->{1,1,{-1,0}},{3,1}->{2,1,{0,1}},{4,0}->{3,1,{0,-1}},{4,1}->{2,0,{1,0}}},#]&,{1,Table[0,{5},{5}],{2,2}},3],TableSpacing->{1,1}]

({{History,  (page 930)}})

{s_,c_}:>With[{sp=s (2 c-1) i},{sp,1-c,{Re[sp],Im[sp]}}]

TM2DStep[rule_,{s_,tape_,r:{x_,y_}}]:=Apply[{#1,ReplacePart[tape,#2,{r}],r+#3}&,{s,tape[[x,y]]}/.rule]

TableForm[NestList[TM2DStep[{s_,c_}:>With[{sp=s (2 c-1) I},{sp,1-c,{Re[sp],Im[sp]}}],#]&,{1,Table[0,{7},{7}],{4,4}},6],TableSpacing->{1,1}]

Substitution Systems and Fractals

({{Implementation,  (page 931)}})

SS2DEvolve[rule_,init_,t_]:=Nest[Flatten2D[#/.rule]&,init,t]

Flatten2D[list_]:=Apply[Join,Map[MapThread[Join,#]&,list]]

SS2DEvolve[rule_,init_,t_]:=Nest[Flatten2D[#/.rule]&,init,t]
Flatten2D[list_]:=Apply[Join,Map[MapThread[Join,#]&,list]]

Grid[SS2DEvolve[{1->{{1,0},{1,1}},0->{{0,0},{0,0}}},{{1}},3]]

({{Connection with digit sequences,  (page 931)}})

Table[If[FreeQ[Transpose[IntegerDigits[{i,j},k,n]],form],1,0],{i,0,(k^(  n))-1},{j,0,(k^(  n))-1}]

Grid[With[{n=3,k=2,form={0,1}},Table[If[FreeQ[Transpose[IntegerDigits[{i,j},k,n]],form],1,0],{i,0,(k^( n))-1},{j,0,(k^( n))-1}]]]

({{Page 187 · Sierpinski pattern,  (page 931)}})

Mod[Array[Binomial,(({2,2})^n),0],2]

Grid[With[{n=4},Mod[Array[Binomial,(({2,2})^n),0],2]]]

1-Sign[Array[BitAnd,(({2,2})^n),0]]

Grid[With[{n=4},1-Sign[Array[BitAnd,(({2,2})^n),0]]]]

NestList[Mod[RotateLeft[#]+#,2]&,PadLeft[{1},(2^n)],(2^n)-1]

Grid[With[{n=4},NestList[Mod[RotateLeft[#]+#,2]&,PadLeft[{1},(2^n)],(2^n)-1]]]

NestList[Mod[ListConvolve[{1,1},#,-1],2]&,PadLeft[{1},(2^n)],(2^n)-1]

Grid[With[{n=4},NestList[Mod[ListConvolve[{1,1},#,-1],2]&,PadLeft[{1},(2^n)],(2^n)-1]]]

IntegerDigits[NestList[BitXor[2#,#]&,1,(2^n)-1],2,(2^n)]

Grid[With[{n=4},IntegerDigits[NestList[BitXor[2#,#]&,1,(2^n)-1],2,(2^n)]]]

NestList[Mod[Rest[FoldList[Plus,0,#]],2]&,Table[1,{(2^n)}],(2^n)-1]

Grid[With[{n=4},NestList[Mod[Rest[FoldList[Plus,0,#]],2]&,Table[1,{(2^n)}],(2^n)-1]]]

Table[PadRight[Mod[CoefficientList[(((1+x))^(t-1)),x],2],(2^n)],{t,(2^n)}]

Grid[With[{n=4},Table[PadRight[Mod[CoefficientList[(((1+x))^(t-1)),x],2],(2^n)],{t,(2^n)}]]]

Reverse[Mod[CoefficientList[Series[1/(1-(1+x)*y),{x,0,(2^n)-1},{y,0,(2^n)-1}],{x,y}],2]]

Grid[With[{n=4},Reverse[Mod[CoefficientList[Series[1/(1-(1+x)*y),{x,0,(2^n)-1},{y,0,(2^n)-1}],{x,y}],2]]]]

Nest[Apply[Join,MapThread[Join,{{#1,#1},{0*#1,#1}},2]]&,{{1}},n]

Grid[With[{n=4},Nest[Apply[Join,MapThread[Join,{{#1,#1},{0*#1,#1}},2]]&,{{1}},n]]]

Nest[Flatten[2#/.{x_,y_}->{{x,y},{x+1,y},{x,y+1}},1]&,{{0,0}},n]

With[{n=3},Nest[Flatten[2#/.{x_,y_}->{{x,y},{x+1,y},{x,y+1}},1]&,{{0,0}},n]]

Grid[ Table[If[MemberQ[With[{n=4},Nest[Flatten[2#/.{x_,y_}->{{x,y},{x+1,y},{x,y+1}},1]&,{{0,0}},n]],{a,b}],1,0],{a,0,15},{b,0,15}]]

(Transpose[{Re[#],Im[#]}]&)[Flatten[Nest[{2#,2#+1,2#+i}&,{0},n]]]

Grid[ Table[If[MemberQ[With[{n=4},
(Transpose[{Re[#],Im[#]}]&)[Flatten[Nest[{2#,2#+1,2#+I}&,{0},n]]]],{a,b}],1,0],{a,0,15},{b,0,15}]]

Position[Map[Split,NestList[Sort[Flatten[{#,#+1}]]&,{0},(2^n)-1]],_?(OddQ[Length[#]]&),{2}]

Grid[ Table[If[MemberQ[With[{n=4},
Position[Map[Split,NestList[Sort[Flatten[{#,#+1}]]&,{0},(2^n)-1]],_?(OddQ[Length[#]]&),{2}]],{a,b}],1,0],{a,1,16},{b,1,16}]]

Flatten[Table[Map[{t,#}&,Fold[Flatten[{#1,#1+#2}]&,{0},Flatten[2^(Position[Reverse[IntegerDigits[t,2]],1]-1)]]],{t,0,(2^n)-1}],1]

Grid[ Table[If[MemberQ[With[{n=4},
Flatten[Table[Map[{t,#}&,Fold[Flatten[{#1,#1+#2}]&,{0},Flatten[2^(Position[Reverse[IntegerDigits[t,2]],1]-1)]]],{t,0,(2^n)-1}],1]],{a,b}],1,0],{a,0,15},{b,0,15}]]

Map[Map[FromDigits[#1,2]&,Transpose[Partition[#1,2]]]&,Position[Nest[{{#1,#1},{#1}}&,1,n],1]-1]

Grid[ Table[If[MemberQ[With[{n=4},
Map[Map[FromDigits[#1,2]&,Transpose[Partition[#1,2]]]&,Position[Nest[{{#1,#1},{#1}}&,1,n],1]-1]],{a,b}],1,0],{a,0,15},{b,0,15}]]

DisplayForm[Nest[SubsuperscriptBox[#,#,#]&,"1",n]]

With[{n=5},DisplayForm[Nest[SubsuperscriptBox[#,#,#]&,"1",n]]]

({{Higher-dimensional generalizations,  (page 932)}})

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]]

{1->Array[If[LessEqual[##],0,1]&,{2,2,2}],0->Array[0&,{2,2,2}]}

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]]

SSEvolve[{1->Array[If[LessEqual[##],0,1]&,{2,2,2}],0->Array[0&,{2,2,2}]},{{{1}}},2,3]

({{Penrose tilings,  (page 932)}})

With[{ϕ=GoldenRatio},Nest[#/.a[p_,q_,r_]:>With[{s=(p+ϕ q) (2-ϕ)},{a[r,s,q],b[r,s,p]}]/.b[p_,q_,r_]:>With[{s=(p+ϕ r) (2-ϕ)},{a[p,q,s],b[r,s,q]}]&,a[{1/2,Sin[2 π/5] ϕ},{1,0},{0,0}],t]]

With[{ϕ=GoldenRatio,t=2},Nest[
#/.a[p_,q_,r_]:>With[{s=(p+ϕ q) (2-ϕ)},{a[r,s,q],b[r,s,p]}]/.b[p_,q_,r_]:>With[{s=(p+ϕ r) (2-ϕ)},{a[p,q,s],b[r,s,q]}]&,a[{1/2,Sin[2 π/5] ϕ},{1,0},{0,0}],t]]//N

Graphics[With[{ϕ=GoldenRatio,t=4},{#/.{a[p__]:>{GrayLevel[.6],Polygon[{p}]},b[p__]:>{GrayLevel[.8],Polygon[{p}]}},#/.{a[p_,q__]:>Line[{p,q,p}],b[p_,q__]:>Line[{p,q,p}]}}&[Nest[
#/.a[p_,q_,r_]:>With[{s=(p+ϕ q) (2-ϕ)},{a[r,s,q],b[r,s,p]}]/.b[p_,q_,r_]:>With[{s=(p+ϕ r) (2-ϕ)},{a[p,q,s],b[r,s,q]}]&,a[{1/2,Sin[2 π/5] ϕ},{1,0},{0,0}],t]]]]

({{Connection with digit sequences,  (page 933)}})

Table[FromDigits[IntegerDigits[s,2,t],i-1],{s,0,(2^(  t))-1}]

With[{t=5},Table[FromDigits[IntegerDigits[s,2,t],I-1],{s,0,(2^( t))-1}]]

({{Page 192 · Neighbor-dependent substitution systems,  (page 935)}})

Flatten2D[Partition[list,{2,2},1,-1]/.rule]

Flatten2D[list_]:=Apply[Join,Map[MapThread[Join,#]&,list]]

With[{rule={{_,1},{0,1}}-> {{1,0},{1,1}}, list = {{1,0},{0,1}}},Flatten2D[Partition[list,{2,2},1,-1]/.rule]]

({{Page 192 · Space-filling curves,  (page 935)}})

(1/2 (((-1))^(  #)) ({1,-1} (Abs[((#)^(  2))-t]-#)+((#)^(  2))-t-Mod[#,2])&)[Round[(Sqrt[t])]]

Table[(1/2 (((-1))^(  #)) ({1,-1} (Abs[((#)^(  2))-t]-#)+((#)^(  2))-t-Mod[#,2])&)[Round[(Sqrt[t])]],{t,0,24}]

ListLinePlot[%]

Network Systems

({{Implementation,  (page 935)}})

CyclicNet[n_]:=RotateRight[Table[Mod[{i-1,i+1},n]+1,{i,n}]]

CyclicNet[n_]:=RotateRight[Table[Mod[{i-1,i+1},n]+1,{i,n}]]

CyclicNet[5]

Follow[list_,i_,s_List]:=Fold[list[[#1]][[#2]]&,i,s]

Follow[list_,i_,s_List]:=Fold[list[[#1]][[#2]]&,i,s]
CyclicNet[n_]:=RotateRight[Table[Mod[{i-1,i+1},n]+1,{i,n}]]

Follow[CyclicNet[5], 2, {2,1,1}]

NeighborNumbers[list_,i_Integer,d_Integer]:=Map[Length,NestList[Union[Flatten[list[[#]]]]&,Union[list[[i]]],d-1]]

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]}]]

Follow[list_,i_,s_List]:=Fold[list[[#1]][[#2]]&,i,s]
CyclicNet[n_]:=RotateRight[Table[Mod[{i-1,i+1},n]+1,{i,n}]]
NeighborNumbers[list_,i_Integer,d_Integer]:=Map[Length,NestList[Union[Flatten[list[[#]]]]&,Union[list[[i]]],d-1]]
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]}]]

Nest[NetEvolveStep[{1,{{1}->{{1,1},{2}},{2}->{{1,1},{2}}}},#]&,CyclicNet[5],3]

ConnectedNodes[list_,i_]:=FixedPoint[Union[Flatten[{#,list[[#]]}]]&,{i}]

ConnectedNodes[list_,i_]:=FixedPoint[Union[Flatten[{#,list[[#]]}]]&,{i}]

ConnectedNodes[{{3,2},{4,3},{5,4},{1,5},{2,1}},1]

RenumberNodes[list_,seq_]:=Map[Position[seq,#][[1,1]]&,list[[seq]],{2}]

RenumberNodes[list_,seq_]:=Map[Position[seq,#][[1,1]]&,list[[seq]],{2}]

RenumberNodes[{{3,2},{4,3},{5,4},{1,5},{2,1}},{5,4,3,2,1}]

NetEvolveList[rule_,init_,t_Integer]:=NestList[(RenumberNodes[#,ConnectedNodes[#,1]]&)[NetEvolveStep[rule,#]]&,init,t]

Follow[list_,i_,s_List]:=Fold[list[[#1]][[#2]]&,i,s]
CyclicNet[n_]:=RotateRight[Table[Mod[{i-1,i+1},n]+1,{i,n}]]
NeighborNumbers[list_,i_Integer,d_Integer]:=Map[Length,NestList[Union[Flatten[list[[#]]]]&,Union[list[[i]]],d-1]]
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]}]]
ConnectedNodes[list_,i_]:=FixedPoint[Union[Flatten[{#,list[[#]]}]]&,{i}]
RenumberNodes[list_,seq_]:=Map[Position[seq,#][[1,1]]&,list[[seq]],{2}]
NetEvolveList[rule_,init_,t_Integer]:=NestList[(RenumberNodes[#,ConnectedNodes[#,1]]&)[NetEvolveStep[rule,#]]&,init,t]

NetEvolveList[{1,{{1}->{{1,1},{2}},{2}->{{1,1},{2}}}},CyclicNet[10],3]

({{Page 202 · Properties,  (page 936)}})

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

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;

With[{t=10},FoldList[Plus,1,Join[{1,4,12,10,-20,6,4},Map[d,IntegerDigits[Range[4,t-5],2]]]]]

({{Sequential network systems,  (page 936)}})

{{1,1}->{{{{},{1,1}},{2}},2},{1,2}->{{{2,2},{{},{2,2}}},2},{2,1}->{{{},{2,2}},2},{2,2}->{{{1,2},{{1},{2}}},1},{2,3}->{{{{1,2},{1}},{{2},{2,1}}},2},{2,4}->{{{2,2},{{2,1},{}}},1}}

({{Implementation,  (page 936)}})

NetCAStep[{rule_,net_},list_]:=Map[Replace[list[[#]],rule]&,net]

ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]
NetCAStep[{rule_,net_},list_]:=Map[Replace[list[[#]],rule]&,net]

ElementaryCARule[90]

NetCAStep[{ElementaryCARule[90],{{2,1,3},{1,2,2},{1,3,2}}},{0,1,0}]

Multiway Systems

({{Implementation,  (page 937)}})

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]

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]

MWEvolveList[{"AAB"->"BB","BA"->"ABB"},{"ABBAAB"},3]

MWStep[rule_List,slist_List]:=Union[Flatten[Map[ReplaceList[#,rule]&,slist],1]]

MWStep[rule_List,slist_List]:=Union[Flatten[Map[ReplaceList[#,rule]&,slist],1]]
MWEvolveList[rule_,init_List,t_Integer]:=NestList[MWStep[rule,#]&,init,t]

MWEvolveList[{{x___,0,0,1,y___}->{x,1,1,y},{x___,1,0,y___}->{x,0,1,1,y}},{{0,1,1,0,0,1}},3]

{"AB"->"","ABA"->"ABBAB","ABABBB"->"AAAAABA"}

({{General properties,  (page 937)}})

Select[Union[Flatten[Outer[Plus,diff,list,1],1]],Abs[#]==#&]

With[{diff={{2,-1},{-1,2}},list={{4,3}}},Select[Union[Flatten[Outer[Plus,diff,list,1],1]],Abs[#]==#&]]

({{Multiway systems based on numbers,  (page 939)}})

NestList[Union[Flatten[{#+1,2 #}]]&,{0},t]

With[{t=5},NestList[Union[Flatten[{#+1,2 #}]]&,{0},t]]

Systems Based on Constraints

({{Checking constraints,  (page 941)}})

SatisfiedQ[list_,allowed_]:=Apply[And,Map[MatchQ[#,allowed]&,Partition[list,{3,3},{1,1}],{2}],{0,1}]

SatisfiedQ[list_,allowed_]:=Apply[And,Map[MatchQ[#,allowed]&,Partition[list,{3,3},{1,1}],{2}],{0,1}]

SatisfiedQ[{{1,1,1},{0,0,1},{0,0,0}},{{_,1,_},{0,0,1},{_,0,_}}]

({{Representing repetitive patterns,  (page 941)}})

c[{d1_,d2_,d3_,d4_},{x_,y_}]:=With[{d=d1 d2+d1 d4+d3 d4},Mod[{{d2 x+d4 x+d3 y,d4 x-d1 y}}/d,1]]

Fill[{dlist_,data_},{nx_,ny_}]:=Array[c[dlist,{##}]&,{nx,ny}]/.Flatten[MapIndexed[c[dlist,Reverse[#2]]->#1&,Reverse[data],{2}],1]

c[{d1_,d2_,d3_,d4_},{x_,y_}]:=With[{d=d1 d2+d1 d4+d3 d4},Mod[{{d2 x+d4 x+d3 y,d4 x-d1 y}}/d,1]]
Fill[{dlist_,data_},{nx_,ny_}]:=Array[c[dlist,{##}]&,{nx,ny}]/.Flatten[MapIndexed[c[dlist,Reverse[#2]]->#1&,Reverse[data],{2}],1]

Grid[Fill[{{3,-1,2,3},{{0,0,1,1,0},{0,0,0,1,1},{1,1,0,0,1}}},{10,10}]]

({{Page 219 · Non-periodic pattern,  (page 942)}})

a[x_,y_]:=Mod[y+1,2]/;x+y>0

a[x_,y_]:=0/;Mod[x+y,2]==1

a[x_,y_]:=Mod[Floor[(x-y)(2^(  (x+y-6)/4))],2]/;Mod[x+y,4]==2

a[x_,y_]:=1-Sign[Mod[x-y+2,(2^(  (-x-y+8)/4))]]

a[x_,y_]:=Mod[y+1,2]/;x+y>0
a[x_,y_]:=0/;Mod[x+y,2]==1
a[x_,y_]:=Mod[Floor[(x-y)(2^(  (x+y-6)/4))],2]/;Mod[x+y,4]==2
a[x_,y_]:=1-Sign[Mod[x-y+2,(2^(  (-x-y+8)/4))]]

Grid[Reverse/@Table[a[x,y],{y,-5,5},{x,-5,5}]]

({{Forcing nested patterns,  (page 942)}})

{1->{{3}},2->{{13,1},{4,10}},3->{{15,1},{4,12}},4->{{14,1},{2,9}},5->{{13,1},{4,12}},6->{{13,1},{8,9}},7->{{15,1},{4,10}},8->{{14,1},{6,10}},9->{{14},{2}},10->{{16},{7}},11->{{13},{8}},12->{{16},{3}},13->{{5,11}},14->{{2,9}},15->{{3,11}},16->{{6,10}}}

Join2[arrays_]:=Join@@Join21/@arrays
Join21[arrays_]:=Transpose[Join@@Transpose/@arrays]
Nest[Join2[#1/.{1->{{3}},2->{{13,1},{4,10}},3->{{15,1},{4,12}},4->{{14,1},{2,9}},5->{{13,1},{4,12}},6->{{13,1},{8,9}},7->{{15,1},{4,10}},8->{{14,1},{6,10}},9->{{14},{2}},10->{{16},{7}},11->{{13},{8}},12->{{16},{3}},13->{{5,11}},14->{{2,9}},15->{{3,11}},16->{{6,10}}}]&,{{3}},3]

({{Pattern-avoiding sequences,  (page 944)}})

Nest[DeleteCases[Flatten[Map[Table[Append[#,i-1],{i,k}]&,#],1],{___,x__,x__,___}]&,{{}},n]

With[{n=5,k=3},Nest[DeleteCases[Flatten[Map[Table[Append[#,i-1],{i,k}]&,#],1],{___,x__,x__,___}]&,{{}},n]]

({{Diophantine equations,  (page 944)}})

Numerator[FromContinuedFraction[ContinuedFraction[(Sqrt[a]),(If[EvenQ[#],#,2 #]&)[Length[Last[ContinuedFraction[(Sqrt[a])]]]]]]]

Function[{a},{a,Numerator[FromContinuedFraction[ContinuedFraction[(Sqrt[a]),(If[EvenQ[#],#,2 #]&)[Length[Last[ContinuedFraction[(Sqrt[a])]]]]]]]}]/@DeleteCases[Range[20],x_/;IntegerQ[(Sqrt[x])]]