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

The Notion of Computation

Computations in Cellular Automata

({{Page 639 · Squaring cellular automaton,  (page 1109)}})

{{0,_,3}->0,{_,2,3}->3,{1,1,3}->4,{_,1,4}->4,{1|2,3,_}->5,{p:(0|1),4,_}->7-p,{7,2,6}->3,{7,_,_}->7,{_,7,p:(1|2)}->p,{_,p:(5|6),_}->7-p,{5|6,p:(1|2),_}->7-p,{5|6,0,0}->1,{_,p:(1|2),_}->p,{_,_,_}->0}

Append[Table[1,{n}],3]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

With[{n=2},
CAEvolveList[GeneralCARule[{{0,_,3}->0,{_,2,3}->3,{1,1,3}->4,{_,1,4}->4,{1|2,3,_}->5,{p:(0|1),4,_}->7-p,{7,2,6}->3,{7,_,_}->7,{_,7,p:(1|2)}->p,{_,p:(5|6),_}->7-p,{5|6,p:(1|2),_}->7-p,{5|6,0,0}->1,{_,p:(1|2),_}->p,{_,_,_}->0}], PadRight[Append[Table[1,{n}],3],n^2+n+2],4 n^2]]//Grid

({{Page 640 · Primes cellular automaton,  (page 1109)}})

{{13,3,13}->12,{6,_,4}->15,{10,_,3|11}->15,{13,7,_}->8,{13,8,7}->13,{15,8,_}->1,{8,_,_}->7,{15,1,_}->2,{_,1,_}->1,{1,_,_}->8,{2|4|5,_,_}->13,{15,2,_}->4,{_,4,8}->4,{_,4,_}->5,{_,5,_}->3,{15,3,_}->12,{_,x:(2|3|8),_}->x,{_,x:(11|12),_}->x-1,{11,_,_}->13,{13,_,1|2|3|5|6|10|11}->15,{13,0,8}->15,{14,_,6|10}->15,{10,0|9|13,6|10}->15,{6,_,6}->0,{_,_,10}->9,{6|10,15,9}->14,{_,6|10,9|14|15}->10,{_,6|10,_}->6,{6|10,15,_}->13,{13|14,_,9|15}->14,{13|14,_,_}->13,{_,_,15}->15,{_,_,9|14}->9,{_,_,_}->0}

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

With[{rule=GeneralCARule[{{13,3,13}->12,{6,_,4}->15,{10,_,3|11}->15,{13,7,_}->8,{13,8,7}->13,{15,8,_}->1,{8,_,_}->7,{15,1,_}->2,{_,1,_}->1,{1,_,_}->8,{2|4|5,_,_}->13,{15,2,_}->4,{_,4,8}->4,{_,4,_}->5,{_,5,_}->3,{15,3,_}->12,{_,x:(2|3|8),_}->x,{_,x:(11|12),_}->x-1,{11,_,_}->13,{13,_,1|2|3|5|6|10|11}->15,{13,0,8}->15,{14,_,6|10}->15,{10,0|9|13,6|10}->15,{6,_,6}->0,{_,_,10}->9,{6|10,15,9}->14,{_,6|10,9|14|15}->10,{_,6|10,_}->6,{6|10,15,_}->13,{13|14,_,9|15}->14,{13|14,_,_}->13,{_,_,15}->15,{_,_,9|14}->9,{_,_,_}->0}]},CAEvolveList[rule,Join[Table[0,{15}],{10,0,4,8},Table[0,{7}]],15]]//Grid

The Phenomenon of Universality

({{Universality in Mathematica,  (page 1110)}})

f[n_]:=n!

f[n_]:=n!

Table[f[n], {n,5}]

f[n_]:=n f[n-1];f[1]=1

f[n_]:=n f[n-1];f[1]=1;

Table[f[n], {n,5}]

f[n_]:=Product[i,{i,n}]

f[n_]:=Product[i,{i,n}]

Table[f[n], {n,5}]

f[n_]:=Module[{t=1},Do[t=t i,{i,n}];t]

f[n_]:=Module[{t=1},Do[t=t i,{i,n}];t]

Table[f[n], {n,5}]

f[n_]:=Module[{t=1,i},For[i=1,i≤n,i++,t*=i];t]

f[n_]:=Module[{t=1,i},For[i=1,i≤n,i++,t*=i];t]

Table[f[n], {n,5}]

f[n_]:=Apply[Times,Range[n]]

f[n_]:=Apply[Times,Range[n]]

Table[f[n], {n,5}]

f[n_]:=Fold[Times,1,Range[n]]

f[n_]:=Fold[Times,1,Range[n]]

Table[f[n], {n,5}]

f[n_]:=If[n==1,1,n f[n-1]]

f[n_]:=If[n==1,1,n f[n-1]]

Table[f[n], {n,5}]

f[n_]:=Fold[#2[#1]&,1,Array[Function[t,#1 t]&,n]]

f[n_]:=Fold[#2[#1]&,1,Array[Function[t,#1 t]&,n]]

Table[f[n], {n,5}]

f=If[#1==1,1,#1 #0[#1-1]]&

f=If[#1==1,1,#1 #0[#1-1]]&;

Table[f[n], {n,5}]

A Universal Cellular Automaton

({{Page 648 · Universal cellular automaton,  (page 1110)}})

{{_,3,7,18,_}->12,{_,5,7|8,0,_}->12,{_,3,10,18,_}->16,{_,5,10|11,0,_}->16,{_,5,8,18,_}->7,{_,5,14,0|18,_}->12,{_,_,8,5,_}->7,{_,_,14,5,_}->12,{_,5,11,18,_}->10,{_,5,17,0|18,_}->16,{_,_,x:(11|17),5,_}->x-1,{_,0|9|18,x:(7|10|16),3,_}->x+1,{_,0|9|18,12,3,_}->14,{_,_,0|9|18,7|10|12|16,x:(3|5)}->8-x,{_,_,_,8|11|14|17,x:(3|5)}->8-x,{_,13,4,_,x:(0|18)}->x,{18,_,4,_,_}->18,{_,_,18,_,4}->18,{0,_,4,_,_}->0,{_,_,0,_,4}->0,{4,_,0|18,1,_}->3,{4,_,_,_,_}->4,{_,_,4,_,_}->9,{_,4,12,_,_}->7,{_,4,16,_,_}->10,{x:(0|18),_,6,_,_}->x,{_,2,6,15,x:(0|18)}->x,{_,12|16,6,7,_}->0,{_,12|16,6,10,_}->18,{_,9,10,6,_}->16,{_,9,7,6,_}->12,{9,15,6,7,9}->0,{9,15,6,10,9}->18,{9,_,6,_,_}->9,{_,6,7,9,12|16}->12,{_,6,10,9,12|16}->16,{12|16,6,7,9,_}->12,{12|16,6,10,9,_}->16,{6,13,_,_,_}->9,{6,_,_,_,_}->6,{_,_,9,13,3}->9,{_,9,13,3,_}->15,{_,_,_,15,3}->3,{_,3,15,0|18,_}->13,{_,13,3,_,0|18}->6,{x:(0|18),15,9,_,_}->x,{_,6,13,_,_}->15,{_,4,15,_,_}->13,{_,_,_,15,6}->6,{_,_,2,6,15}->1,{_,_,1,6,_}->2,{_,1,6,_,_}->9,{_,3,2,_,_}->1,{3,2,_,_,_}->3,{_,_,3,2,_}->3,{_,1,9,1,6}->6,{_,_,9,1,6}->4,{_,4,2,_,_}->1,{_,_,_,_,x:(3|5)}->x,{_,_,3|5,_,x:(0|18)}->x,{_,_,x:(1|2|7|8|9|10|11|12|13|14|15|16|17),_,_}->x,{_,_,18,7|10,18}->18,{_,_,0,7|10,0}->0,{_,_,0|18,_,_}->9,{_,_,x_,_,_}->x}

Flatten[{Transpose[{Join[{4,18 (1-a),6},Table[9,{(2^(  2 r+1))-3}]],10-3 rtab}],Table[{9,1},{r}],9,13}]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

UCAInit[a_]=With[{r=1,rtab=IntegerDigits[90,2,8]},Flatten[{Transpose[{Join[{4,18 (1-a),6},Table[9,{(2^(  2 r+1))-3}]],10-3 rtab}],Table[{9,1},{r}],9,13}]]

Block[{init=Join[UCAInit[0],UCAInit[1],UCAInit[0]],t=10,rule=GeneralCARule[{{_,3,7,18,_}->12,{_,5,7|8,0,_}->12,{_,3,10,18,_}->16,{_,5,10|11,0,_}->16,{_,5,8,18,_}->7,{_,5,14,0|18,_}->12,{_,_,8,5,_}->7,{_,_,14,5,_}->12,{_,5,11,18,_}->10,{_,5,17,0|18,_}->16,{_,_,x:(11|17),5,_}->x-1,{_,0|9|18,x:(7|10|16),3,_}->x+1,{_,0|9|18,12,3,_}->14,{_,_,0|9|18,7|10|12|16,x:(3|5)}->8-x,{_,_,_,8|11|14|17,x:(3|5)}->8-x,{_,13,4,_,x:(0|18)}->x,{18,_,4,_,_}->18,{_,_,18,_,4}->18,{0,_,4,_,_}->0,{_,_,0,_,4}->0,{4,_,0|18,1,_}->3,{4,_,_,_,_}->4,{_,_,4,_,_}->9,{_,4,12,_,_}->7,{_,4,16,_,_}->10,{x:(0|18),_,6,_,_}->x,{_,2,6,15,x:(0|18)}->x,{_,12|16,6,7,_}->0,{_,12|16,6,10,_}->18,{_,9,10,6,_}->16,{_,9,7,6,_}->12,{9,15,6,7,9}->0,{9,15,6,10,9}->18,{9,_,6,_,_}->9,{_,6,7,9,12|16}->12,{_,6,10,9,12|16}->16,{12|16,6,7,9,_}->12,{12|16,6,10,9,_}->16,{6,13,_,_,_}->9,{6,_,_,_,_}->6,{_,_,9,13,3}->9,{_,9,13,3,_}->15,{_,_,_,15,3}->3,{_,3,15,0|18,_}->13,{_,13,3,_,0|18}->6,{x:(0|18),15,9,_,_}->x,{_,6,13,_,_}->15,{_,4,15,_,_}->13,{_,_,_,15,6}->6,{_,_,2,6,15}->1,{_,_,1,6,_}->2,{_,1,6,_,_}->9,{_,3,2,_,_}->1,{3,2,_,_,_}->3,{_,_,3,2,_}->3,{_,1,9,1,6}->6,{_,_,9,1,6}->4,{_,4,2,_,_}->1,{_,_,_,_,x:(3|5)}->x,{_,_,3|5,_,x:(0|18)}->x,{_,_,x:(1|2|7|8|9|10|11|12|13|14|15|16|17),_,_}->x,{_,_,18,7|10,18}->18,{_,_,0,7|10,0}->0,{_,_,0|18,_,_}->9,{_,_,x_,_,_}->x},2]},CAEvolveList[rule,init,t]]

({{Page 655 · More colors,  (page 1111)}})

CA3ToCA2[{a_,b_,c_}->d_]:=Union[Flatten[Table[Thread[Partition[Flatten[{l,a,b,c,r}/.coding],11,1][[{2,3,4}]]->(d/.coding)],{l,0,2},{r,0,2}],2]]

coding={0->{0,0,0},1->{0,0,1},2->{0,1,1}}

CA3ToCA2[{a_,b_,c_}->d_]:=Union[Flatten[Table[Thread[Partition[Flatten[{l,a,b,c,r}/.coding],11,1][[{2,3,4}]]->(d/.coding)],{l,0,2},{r,0,2}],2]]

Block[{coding={0->{0,0,0},1->{0,0,1},2->{0,1,1}}},
CA3ToCA2[{0,1,0}->2]]

Emulating Other Systems with Cellular Automata

({{Page 657 · Mobile automata,  (page 1111)}})

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

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
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]}

With[{rule = GeneralCARule[MAToCA[{{1,1,1}->{0,1},{1,1,0}->{0,1},{1,0,1}->{1,-1},{1,0,0}->{0,-1},{0,1,1}->{0,-1},{0,1,0}->{0,1},{0,0,1}->{1,1},{0,0,0}->{1,-1}}],2]},
CAEvolveList[rule, PadRight[PadLeft[{2},10],20], 5]]//Grid

({{Page 658 · Turing machines,  (page 1111)}})

TMToCA[rules_,k_:2]:=Flatten[{Map[g[#,k]&,rules],{_,x_,_}->x}]

g[{s_,a_}->{sp_,ap_,d_},k_]:={If[d==1,Identity,Reverse][{k s+a,x_,_}]->k sp+x,{_,k s+a,_}->ap}

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
TMToCA[rules_,k_:2]:=Flatten[{Map[g[#,k]&,rules],{_,x_,_}->x}]
g[{s_,a_}->{sp_,ap_,d_},k_]:={If[d==1,Identity,Reverse][{k s+a,x_,_}]->k sp+x,{_,k s+a,_}->ap}

CAEvolveList[GeneralCARule[TMToCA[{{1,0}->{3,1,-1},{1,1}->{2,0,1},{2,0}->{1,1,1},{2,1}->{3,1,1},{3,0}->{2,1,1},{3,1}->{1,0,-1}}]], ReplacePart[Table[0,{15}],2,5],10]//Grid

({{Page 659 · Substitution systems,  (page 1111)}})

SSToCA[rules_]:={{b,b,p[x_,_]}->s[x],{_,s[v:(0|1)],p[x_,_]}->p[v,x],{_,p[_,y_],_}->s[y],{_,s[v:(0|1)],_m}->m[v],{s[0|1],m[v:(0|1)],_}->s[v],{b,m[v:(0|1)],_}->r[v],{_,r[v:(0|1)],_}:>(Replace[v,rules]/.{{x_}->s[x],{x_,y_}->p[x,y]}),{_r,s[v:(0|1)],_}->r[v],{_r,b,_}->m[b],{s[0|1],m[b],_}->b,{_,v_,_}->v}

{b->0,s[0]->1,m[0]->2,p[0,0]->3,r[0]->4,p[0,1]->5,p[1,0]->6,r[1]->7,p[1,1]->8,m[1]->9,m[b]->10,s[1]->11}

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
SSToCA[rules_]:={{b,b,p[x_,_]}->s[x],{_,s[v:(0|1)],p[x_,_]}->p[v,x],{_,p[_,y_],_}->s[y],{_,s[v:(0|1)],_m}->m[v],{s[0|1],m[v:(0|1)],_}->s[v],{b,m[v:(0|1)],_}->r[v],{_,r[v:(0|1)],_}:>(Replace[v,rules]/.{{x_}->s[x],{x_,y_}->p[x,y]}),{_r,s[v:(0|1)],_}->r[v],{_r,b,_}->m[b],{s[0|1],m[b],_}->b,{_,v_,_}->v}

CAEvolveList[GeneralCARule[SSToCA[{1->{0}, 0->{0,1}}]], Join[Table[b,{8}],{m[0]},Table[b,{3}]], 20]/.{b->0,s[0]->1,m[0]->2,p[0,0]->3,r[0]->4,p[0,1]->5,p[1,0]->6,r[1]->7,p[1,1]->8,m[1]->9,m[b]->10,s[1]->11}//Grid

({{Page 660 · Sequential substitution systems,  (page 1111)}})

SSSToCA[rules_]:=Flatten[{{v[_,_,_],u,_}->u,{_,v[rn_,x_,_],u}->r[rn+1,x],{_,v[_,x_,_],_}->x,MapIndexed[With[{rn=#2[[1]],rs=#1[[1]],rr=#1[[2]]},{If[Length[rs]==1,{u,r[rn,First[rs]],_}->q[0,rr],{u,r[rn,First[rs]],_}->v[rn,First[rs],Take[rs,1]]],{u,r[rn,x_],_}->v[rn,x,{}],{v[rn,_,Drop[rs,-1]],Last[rs],_}->q[Length[rs]-1,rr],Table[{v[rn,_,Flatten[{___,Take[rs,i-1]}]],rs[[i]],_}->v[rn,rs[[i]],Take[rs,i]],{i,Length[rs]-1,1,-1}],{v[rn,_,_],y_,_}->v[rn,y,{}]}]&,rules/.s->List],{_,q[0,{x__,_}],_}->q[0,{x}],{_,q[0,{x_}],_}->r[1,x],{_,q[0,{}],x_}->r[1,x],{_,q[_,{___,x_}],_}->x,{_,q[_,{}],x_}->x,{_,x_,q[0,_]}->x,{_,_,q[n_,{}]}->q[n-1,{}],{_,_,q[n_,{x___,_}]}->q[n-1,{x}],{q[_,{}],_,_}->w,{q[0,{__,x_}],p[y_,_],_}->p[x,y],{q[0,{__,x_}],y_,_}->p[x,y],{p[_,x_],p[y_,_],_}->p[x,y],{p[_,x_],u,_}->x,{p[_,x_],y_,_}->p[x,y],{_,p[x_,_],_}->x,{w,u,_}->u,{w,x_,_}->w,{_,w,x_}->x,{_,r[rn_,x_],_}->x,{_,u,r[_,_]}->u,{_,x_,r[rn_,_]}->r[rn,x],{_,x_,_}->x}]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
SSSToCA[rules_]:=Flatten[{{v[_,_,_],u,_}->u,{_,v[rn_,x_,_],u}->r[rn+1,x],{_,v[_,x_,_],_}->x,MapIndexed[With[{rn=#2[[1]],rs=#1[[1]],rr=#1[[2]]},{If[Length[rs]==1,{u,r[rn,First[rs]],_}->q[0,rr],{u,r[rn,First[rs]],_}->v[rn,First[rs],Take[rs,1]]],{u,r[rn,x_],_}->v[rn,x,{}],{v[rn,_,Drop[rs,-1]],Last[rs],_}->q[Length[rs]-1,rr],Table[{v[rn,_,Flatten[{___,Take[rs,i-1]}]],rs[[i]],_}->v[rn,rs[[i]],Take[rs,i]],{i,Length[rs]-1,1,-1}],{v[rn,_,_],y_,_}->v[rn,y,{}]}]&,rules/.s->List],{_,q[0,{x__,_}],_}->q[0,{x}],{_,q[0,{x_}],_}->r[1,x],{_,q[0,{}],x_}->r[1,x],{_,q[_,{___,x_}],_}->x,{_,q[_,{}],x_}->x,{_,x_,q[0,_]}->x,{_,_,q[n_,{}]}->q[n-1,{}],{_,_,q[n_,{x___,_}]}->q[n-1,{x}],{q[_,{}],_,_}->w,{q[0,{__,x_}],p[y_,_],_}->p[x,y],{q[0,{__,x_}],y_,_}->p[x,y],{p[_,x_],p[y_,_],_}->p[x,y],{p[_,x_],u,_}->x,{p[_,x_],y_,_}->p[x,y],{_,p[x_,_],_}->x,{w,u,_}->u,{w,x_,_}->w,{_,w,x_}->x,{_,r[rn_,x_],_}->x,{_,u,r[_,_]}->u,{_,x_,r[rn_,_]}->r[rn,x],{_,x_,_}->x}]

s[1,0,0]/.s[x_,y__]->{r[1,x],y}

CAEvolveList[GeneralCARule[SSSToCA[{s[1,1,0]->s[1,1],s[1,0]->s[0,1,1]}],1],Join[{u,u},s[1,0,0]/.s[x_,y__]->{r[1,x],y},{u,u,u}],12]

({{Page 661 · Register machines,  (page 1112)}})

g[i[1],p_,m_]:={{_,p,_}->p+1,{_,0,p}->m+2,{_,_,p}->m+3}

g[i[2],p_,m_]:={{_,p,_}->p+1,{p,0,_}->m+5,{p,_,_}->m+6}

g[d[1,q_],p_,m_]:={{m+2|m+3,p,_}->q,{m+1,p,_}->p,{0,p,_}->p+1,{_,m+2|m+3,p}->m+1}

g[d[2,q_],p_,m_]:={{_,p,m+5|m+6}->q,{_,p,m+4}->p,{_,p,0}->p+1,{p,m+5|m+6,_}->m+4}

RMToCA[prog_]:=With[{m=Length[prog]},Flatten[{MapIndexed[g[#1,First[#2],m]&,prog],{{0,0|m+1,m+3}->m+2,{0,m+1,_}->0,{0,0,m+1}->0,{_,_,x:(m+1|m+3)}->x,{_,m+1|m+3,_}->m+2,{m+6,0|m+4,0}->m+5,{_,m+4,0}->0,{m+4,0,0}->0,{x:(m+4|m+6),_,_}->x,{_,m+4|m+6,_}->m+5,{_,x_,_}->x}}]]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule
g[i[1],p_,m_]:={{_,p,_}->p+1,{_,0,p}->m+2,{_,_,p}->m+3}
g[i[2],p_,m_]:={{_,p,_}->p+1,{p,0,_}->m+5,{p,_,_}->m+6}
g[d[1,q_],p_,m_]:={{m+2|m+3,p,_}->q,{m+1,p,_}->p,{0,p,_}->p+1,{_,m+2|m+3,p}->m+1}
g[d[2,q_],p_,m_]:={{_,p,m+5|m+6}->q,{_,p,m+4}->p,{_,p,0}->p+1,{p,m+5|m+6,_}->m+4}
RMToCA[prog_]:=With[{m=Length[prog]},Flatten[{MapIndexed[g[#1,First[#2],m]&,prog],{{0,0|m+1,m+3}->m+2,{0,m+1,_}->0,{0,0,m+1}->0,{_,_,x:(m+1|m+3)}->x,{_,m+1|m+3,_}->m+2,{m+6,0|m+4,0}->m+5,{_,m+4,0}->0,{m+4,0,0}->0,{x:(m+4|m+6),_,_}->x,{_,m+4|m+6,_}->m+5,{_,x_,_}->x}}]]

CAEvolveList[GeneralCARule[RMToCA[{i[1], d[2,1], i[2], d[1,3], d[2,1]}]], ReplacePart[Table[0,{15}],1,8], 30]//Grid

({{Page 661 · Multiplication systems,  (page 1112)}})

{{_,0,3|8}->5,{_,0,2|7}->8,{_,1,4|9}->9,{_,1,3|8}->4,{_,1,2|7}->8,{_,10,4|9}->3,{_,10,3|8}->7,{_,10,2|7}->2,{5|6,1,0}->9,{5|6,10,0}->3,{5|6,1,_}->6,{5|6,10,_}->5,{_,2|3|4|5,_}->10,{_,6|7|8|9,_}->1,{_,x_,_}->x}

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

CAEvolveList[GeneralCARule[{{_,0,3|8}->5,{_,0,2|7}->8,{_,1,4|9}->9,{_,1,3|8}->4,{_,1,2|7}->8,{_,10,4|9}->3,{_,10,3|8}->7,{_,10,2|7}->2,{5|6,1,0}->9,{5|6,10,0}->3,{5|6,1,_}->6,{5|6,10,_}->5,{_,2|3|4|5,_}->10,{_,6|7|8|9,_}->1,{_,x_,_}->x}],
PadLeft[{2,0},10], 20]//Grid

({{Page 662 · Logic circuits,  (page 1112)}})

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

Flatten[Block[{And,Or},Map[{0,2 (#+1)}&,expr,{-1}]//.{!x_:>{0,x,0},And[x__]:>{0,0,1,0,x,1,3,0,0},Or[x__]:>{0,0,1,0,x,0,1,3,0}}]]

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

With[{expr = And[1,0]},CAEvolveList[GeneralCARule[{{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}], Flatten[Block[{And,Or},Map[{0,2 (#+1)}&,expr,{-1}]//.{!x_:>{0,x,0},And[x__]:>{0,0,1,0,x,1,3,0,0},Or[x__]:>{0,0,1,0,x,0,1,3,0}}]], 9]]//Grid

({{Page 663 · RAM,  (page 1112)}})

{{2,4|8,2|11,_,_}->2,{11|10,4|8,2|11,_,_}->11,{2,4|8,_,_,_}->10,{11|10,4|8,_,_,_}->2,{2,0,_,_,_}->2,{11,0,_,_,_}->11,{3|7|6,_,10,_,_}->1,{x:(3|7|6),_,_,_,_}->x,{_,_,6,4,10}->5,{_,_,6,8,10}->9,{_,3,_,10,_}->4,{_,7,_,10,_}->8,{_,_,1,_,x:(5|9)}->x,{1,_,_,_,_}->1,{_,_,1,_,_}->1,{_,_,_,_,1}->1,{_,_,x:(4|8|0),_,_}->x}

CAEvolveList[rule_,init_List,t_Integer]:=NestList[CAStep[rule,#]&,init,t]
CAStep[GeneralCARule[rule_,r_Integer:1],a_List]:=Partition[a,2 r+1,1,r+1]/.rule

With[{i=7,n=4,data={1,0,1,0,0,1,0}},CAEvolveList[GeneralCARule[{{2,4|8,2|11,_,_}->2,{11|10,4|8,2|11,_,_}->11,{2,4|8,_,_,_}->10,{11|10,4|8,_,_,_}->2,{2,0,_,_,_}->2,{11,0,_,_,_}->11,{3|7|6,_,10,_,_}->1,{x:(3|7|6),_,_,_,_}->x,{_,_,6,4,10}->5,{_,_,6,8,10}->9,{_,3,_,10,_}->4,{_,7,_,10,_}->8,{_,_,1,_,x:(5|9)}->x,{1,_,_,_,_}->1,{_,_,1,_,_}->1,{_,_,_,_,1}->1,{_,_,x:(4|8|0),_,_}->x},2], Join[{0,1},Flatten[{0,i, IntegerDigits[n,2]/.{1->{0,11},0->{0,2}}}], {0,1},Flatten[data/.{1->{8,1}, 0->{4,1}}]], 15]]//Grid

Emulating Cellular Automata with Other Systems

({{Page 664 · Mobile automata,  (page 1112)}})

vals={x,p[0],q[0,0],q[0,1],q[1,0],q[1,1],p[1]}

CAToMA[rules_]:=Table[(#->Replace[#,{{q[a_,b_],p[c_],p[d_]}:>{q[c,{a,c,d}/.rules],1},{q[a_,b_],p[c_],x}:>{q[c,{a,c,0}/.rules],1},{q[_,_],x,x}->{p[0],-1},{q[_,_],q[_,a_],p[_]}->{p[a],-1},{x,q[_,a_],p[_]}->{p[a],-1},{x,x,p[_]}->{q[0,0],1},{_,_,_}->{x,0}}]&)[vals[[IntegerDigits[i,7,3]+1]]],{i,0,(7^(  3))-1}]

Flatten[{p[0], Map[p,list], p[0]}]

MAStep[rule_,{list_List,n_Integer}]/;1<n<Length[list]:=Apply[{ReplacePart[list,#1,n],n+#2}&,Replace[Take[list,{n-1,n+1}],rule]]
MAEvolveList[rule_,init_List,t_Integer]:=NestList[MAStep[rule,#]&,init,t]
vals={x,p[0],q[0,0],q[0,1],q[1,0],q[1,1],p[1]};
CAToMA[rules_]:=Table[(#->Replace[#,{{q[a_,b_],p[c_],p[d_]}:>{q[c,{a,c,d}/.rules],1},{q[a_,b_],p[c_],x}:>{q[c,{a,c,0}/.rules],1},{q[_,_],x,x}->{p[0],-1},{q[_,_],q[_,a_],p[_]}->{p[a],-1},{x,q[_,a_],p[_]}->{p[a],-1},{x,x,p[_]}->{q[0,0],1},{_,_,_}->{x,0}}]&)[vals[[IntegerDigits[i,7,3]+1]]],{i,0,(7^(  3))-1}]
ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]

MAEvolveList[CAToMA[ElementaryCARule[90]],{With[{list= {0,0,0,1,0,0,0}},Join[Table[x,{5}],Flatten[{p[0], Map[p,list], p[0]}],Table[x,{5}]]],5},5]

({{Page 665 ·  Turing machines,  (page 1113)}})

CAToTM[rules_]:={{q[a_,b_],c:(0|1)}:>{q[b,c],{a,b,c}/.rules,1},{q[_,_],x}->{p[0],0,-1},{p[a_],b:(0|1)}->{p[b],a,-1},{p[_],x}->{q[0,0],0,1}}

CAToTM[rules_]:={{q[a_,b_],c:(0|1)}:>{q[b,c],{a,b,c}/.rules,1},{q[_,_],x}->{p[0],0,-1},{p[a_],b:(0|1)}->{p[b],a,-1},{p[_],x}->{q[0,0],0,1}}
TMStep[rule_List,{s_,a_List,n_}]/;1≤n≤Length[a]:=Apply[{#1,ReplacePart[a,#2,n],n+#3}&,Replace[{s,a[[n]]},rule]]
TMEvolveList[rule_,init_List,t_Integer]:=NestList[TMStep[rule,#]&,init,t]
ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]

With[{list={0,0,1,0,0}},TMEvolveList[CAToTM[ElementaryCARule[90]], {q[0,0],Flatten[{{x,x,x},Join[{0,0},list,{0,0}],{x,x,x}}],4},10]]

({{Page 667 · Sequential substitution systems,  (page 1113)}})

CAToSSS[rules_]:=Join[rules/.({a_,b_,c_}->d_)->{1,2 a,2 b,2 c}->{2 d,1,2 b,2 c},{{1,0,0}->{0,0},{0}->{1,0,0,0}}]

CAToSSS[rules_]:=Join[rules/.({a_,b_,c_}->d_)->{1,2 a,2 b,2 c}->{2 d,1,2 b,2 c},{{1,0,0}->{0,0},{0}->{1,0,0,0}}]
ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]
SetAttributes[s,Flat];
SSSRules[list_List]:=Module[{x,y},Apply[Join[{x___},#1,{y___}]->Join[{x},#2,{y}]&,list,{1}]]
SSSEvolveList3[rules_,init_List,t_Integer]:=With[{r=SSSRules[rules]},NestList[#1/.r&,init,t]]

SSSEvolveList3[CAToSSS[ElementaryCARule[90]],{0,0,2,0,0},30]//Grid

({{Page 667 · Tag systems,  (page 1113)}})

CAToTS[rules_]:={2,{{s[x_],s[y_]}:>{d[x,y],d[x,y]},{d[w_,x_],d[y_,z_]}:>{s[{w,x,y}/.rules],s[{x,y,z}/.rules]},{s[x_],d[y_,z_]}:>{s[0],s[0],s[{0,y,z}/.rules]},{d[x_,y_],s[z_]}:>{s[{x,y,0}/.rules],s[0],s[0]}}}

CAToTS[rules_]:={2,{{s[x_],s[y_]}:>{d[x,y],d[x,y]},{d[w_,x_],d[y_,z_]}:>{s[{w,x,y}/.rules],s[{x,y,z}/.rules]},{s[x_],d[y_,z_]}:>{s[0],s[0],s[{0,y,z}/.rules]},{d[x_,y_],s[z_]}:>{s[{x,y,0}/.rules],s[0],s[0]}}}
ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]
TSEvolveList[{n_,rule_},init_,t_]:=NestList[If[Length[#]<n,{},Join[Drop[#,n],Take[#,n]/.rule]]&,init,t]

Cases[TSEvolveList[CAToTS[ElementaryCARule[90]],{s[0],s[0],s[1],s[0],s[0]},50],{__s}]//Grid

({{Page 668 · Symbolic systems,  (page 1113)}})

Flatten[{Array[p[x_][#1][#2][#3]->p[x[{##}/.rules]][#2][#3]&,{2,2,2},0]/.{0->p,1->q},{r[x_]->p[r[p][p]][x],p[x_][p][p][r]->x[p][p][r]}}]

Fold[#1[#2]&,r[p][p],init/.{0->p,1->q}][p][p][r]

ElementaryCARule[n_]:=Thread[Reverse[Table[IntegerDigits[i,2,3], {i,0,7}]]->IntegerDigits[n,2,8]]

With[{init={0,0,1,0,0}},Fold[#1[#2]&,r[p][p],init/.{0->p,1->q}][p][p][r]]

With[{rules=ElementaryCARule[90]},Flatten[{Array[p[x_][#1][#2][#3]->p[x[{##}/.rules]][#2][#3]&,{2,2,2},0]/.{0->p,1->q},{r[x_]->p[r[p][p]][x],p[x_][p][p][r]->x[p][p][r]}}]]

NestList[#/.With[{rules=ElementaryCARule[90]},Flatten[{Array[p[x_][#1][#2][#3]->p[x[{##}/.rules]][#2][#3]&,{2,2,2},0]/.{0->p,1->q},{r[x_]->p[r[p][p]][x],p[x_][p][p][r]->x[p][p][r]}}]]&, With[{init={0,0,1,0,0}},Fold[#1[#2]&,r[p][p],init/.{0->p,1->q}][p][p][r]], 10]//TableForm

({{Page 669 · Cyclic tag systems,  (page 1113)}})

TS1ToCT[{n_,subs_}]:=With[{k=Length[subs]},Join[Map[v[Last[#],k]&,subs],Table[{},{k (n-1)}]]]

u[i_,k_]:=Table[If[j==i+1,1,0],{j,k}]

v[list_,k_]:=Flatten[Map[u[#,k]&,list]]

Map[Map[Position[#,1][[1,1]]-1&,Partition[#,k]]&,Take[history,{1,-1,n k}]]

TS1ToCT[{n_,subs_}]:=With[{k=Length[subs]},Join[Map[v[Last[#],k]&,subs],Table[{},{k (n-1)}]]]
u[i_,k_]:=Table[If[j==i+1,1,0],{j,k}]
v[list_,k_]:=Flatten[Map[u[#,k]&,list]]
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,{}}

TS1ToCT[{3,{0->{0,0},1->{1,1,0,1}}}]

Note that substitutions must be given in the order 0->{..}, 1->{...}, ...

v[{0,1,0,1,1},2]

CTEvolveList[TS1ToCT[{3,{0->{0,0},1->{1,1,0,1}}}],v[{0,1,0,1,1},2],30]

With[{n=3,k=2},Map[Map[Position[#,1][[1,1]]-1&,Partition[#,k]]&,Take[%,{1,-1,n k}]]]

({{Page 669 · Multicolor Turing machines,  (page 1113)}})

TMToTM2[rule_,s_,k_]:=(#/.MapIndexed[#1->First[#2]&,Union[Map[#[[1,1]]&,#]]]&)[With[{b=Ceiling[Log[2,k]]-1},Flatten[Table[{Table[{Table[{{m,i,n,d},c}->{{m,Mod[i,(2^(  n-1))],n-1,d},Quotient[i,(2^(  n-1))],1},{n,2,b},{i,0,(2^(  n))-1}],Table[{{m,i,1,d},c}->{{m,-1,1,d},i,d},{i,0,1}],Table[{{m,-1,n,d},c}->{{m,-1,n+1,d},c,d},{n,b-1}],{{m,-1,b,d},c}->{{0,0,m},c,d}},{d,-1,1,2}],Table[{{i,n,m},c}->{{i+(2^(  n)) c,n+1,m},c,-1},{n,0,b-1},{i,0,(2^(  n))-1}],With[{r=(2^(  b))},Table[If[i+r c≥k,{},Cases[rule,({m,i+r c}->{x_,y_,z_})->{{i,b,m},c}->{{x,Mod[y,r],b,z},Quotient[y,r],1}]],{i,0,r-1}]]},{m,s},{c,0,1}]]]]

With[{b=Ceiling[Log[2,k]]},{i,Flatten[IntegerDigits[list,2,b]],b n}]

TMToTM2[rule_,s_,k_]:=(#/.MapIndexed[#1->First[#2]&,Union[Map[#[[1,1]]&,#]]]&)[With[{b=Ceiling[Log[2,k]]-1},Flatten[Table[{Table[{Table[{{m,i,n,d},c}->{{m,Mod[i,(2^(  n-1))],n-1,d},Quotient[i,(2^(  n-1))],1},{n,2,b},{i,0,(2^(  n))-1}],Table[{{m,i,1,d},c}->{{m,-1,1,d},i,d},{i,0,1}],Table[{{m,-1,n,d},c}->{{m,-1,n+1,d},c,d},{n,b-1}],{{m,-1,b,d},c}->{{0,0,m},c,d}},{d,-1,1,2}],Table[{{i,n,m},c}->{{i+(2^(  n)) c,n+1,m},c,-1},{n,0,b-1},{i,0,(2^(  n))-1}],With[{r=(2^(  b))},Table[If[i+r c≥k,{},Cases[rule,({m,i+r c}->{x_,y_,z_})->{{i,b,m},c}->{{x,Mod[y,r],b,z},Quotient[y,r],1}]],{i,0,r-1}]]},{m,s},{c,0,1}]]]]
TMEvolveList[rule_,init_List,t_Integer]:=NestList[TMStep[rule,#]&,init,t]
TMStep[rule_List,{s_,a_List,n_}]/;1≤n≤Length[a]:=Apply[{#1,ReplacePart[a,#2,n],n+#3}&,Replace[{s,a[[n]]},rule]]

TMEvolveList[TMToTM2[{{1,0}->{2,2,1},{1,1}->{1,2,1},{1,2}->{1,2,-1},{2,0}->{1,2,-1},{2,1}->{2,1,1},{2,2}->{2,1,1}},2, 3], With[{i=1, list ={0,0,0,0,0,1,0,0,0,0,0}, n =5, k=3},With[{b=Ceiling[Log[2,k]]},{i,Flatten[IntegerDigits[list,2,b]],b n}]], 10]

({{Page 670 · One-element-dependence tag systems,  (page 1114)}})

TS1EvolveList[rule_,init_,t_]:=NestList[TS1Step[rule,#]&,init,t]

TS1Step[{n_,subs_},{}]={}

TS1Step[{n_,subs_},list_]:=Drop[Join[list,First[list]/.subs],n]

TMToTS1[rules_]:={2,Union[Flatten[rules/.({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],{2 v}],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],{2 v}]}],d[i,u]->Table[d[j],{4}]}]}]]}

Cases[history,x:{a[_],___}:>Apply[{#1,Reverse[#2]}&,Map[Drop[IntegerDigits[Count[x,#],2],-1]&,{_b,_d}]]]

TS1EvolveList[rule_,init_,t_]:=NestList[TS1Step[rule,#]&,init,t]
TS1Step[{n_,subs_},{}]={};
TS1Step[{n_,subs_},list_]:=Drop[Join[list,First[list]/.subs],n]
TMToTS1[rules_]:={2,Union[
Flatten[rules/.({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],{2 v}],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],{2 v}]}],d[i,u]->Table[d[j],{4}]}]}]]}

TMToTS1[{{1,1}-> {2, 0, 1}, {1,0}->{3,1,-1}, {2, 1}->{3,1,1},{2,0}->{1,1,1},{3,1}->{1,0,-1},{3,0}->{2,1,1} }]

With[{history=TS1EvolveList[TMToTS1[{{1,1}-> {2, 0, 1}, {1,0}->{3,1,-1}, {2, 1}->{3,1,1},{2,0}->{1,1,1},{3,1}->{1,0,-1},{3,0}->{2,1,1} }],{a[1],a[1],c[1]},200]},Cases[history,x:{a[_],___}:>Apply[{#1,Reverse[#2]}&,Map[Drop[IntegerDigits[Count[x,#],2],-1]&,{_b,_d}]]]]

({{Page 672 · Register machines,  (page 1114)}})

TMToRM[rules_]:=Module[{segs,adrs},segs=Map[TMCompile,rules];adrs=Thread[Map[First,rules]->Drop[FoldList[Plus,1,Map[Length,segs]],-1]];MapIndexed[#1/.{dr[r_,n_]:>d[r,n+First[#2]],dm[r_,z_]:>d[r,z/.adrs]}&,Flatten[segs]]]

TMCompile[_->z:{_,_,1}]:=f[z,{1,2}]

TMCompile[_->z:{_,_,-1}]:=f[z,{2,1}]

f[{s_,a_,_},{ra_,rb_}]:=Flatten[{i[3],dr[ra,-1],dr[3,3],i[ra],i[ra],dr[3,-2],If[a==1,i[ra],{}],i[3],dr[rb,5],i[rb],dr[3,-1],dr[rb,1],dm[rb,{s,0}],dr[rb,-6],i[rb],dr[3,-1],dr[rb,1],dm[rb,{s,1}]}]

(Flatten[Partition[Complement[#,#-1],1,2]]&)[Position[list,{_,{_,_,0}}]]

TMToRM[rules_]:=Module[{segs,adrs},segs=Map[TMCompile,rules];adrs=Thread[Map[First,rules]->Drop[FoldList[Plus,1,Map[Length,segs]],-1]];MapIndexed[#1/.{dr[r_,n_]:>d[r,n+First[#2]],dm[r_,z_]:>d[r,z/.adrs]}&,Flatten[segs]]]
TMCompile[_->z:{_,_,1}]:=f[z,{1,2}]
TMCompile[_->z:{_,_,-1}]:=f[z,{2,1}]
f[{s_,a_,_},{ra_,rb_}]:=Flatten[{i[3],dr[ra,-1],dr[3,3],i[ra],i[ra],dr[3,-2],If[a==1,i[ra],{}],i[3],dr[rb,5],i[rb],dr[3,-1],dr[rb,1],dm[rb,{s,0}],dr[rb,-6],i[rb],dr[3,-1],dr[rb,1],dm[rb,{s,1}]}]
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]

TMToRM[{{1,1}->{1,1,1}, {1,0}->{2,1,-1}, {2,1}->{2,1,-1}, {2,0}->{1,1,1}}]

RMEvolveList[TMToRM[{{1,1}->{1,1,1}, {1,0}->{2,1,-1}, {2,1}->{2,1,-1}, {2,0}->{1,1,1}}],{1,{0,0,0}},60]

With[{list=%},(Flatten[Partition[Complement[#,#-1],1,2]]&)[Position[list,{_,{_,_,0}}]]]

({{Register machines with many registers,  (page 1114)}})

RMEncode[list_]:=Product[Prime[j]^list[[j]],{j,Length[list]}]

RMToRM2[prog_]:=Module[{segs,adrs},segs=MapIndexed[seg,prog];adrs=FoldList[Plus,1,Map[Length,segs]];MapIndexed[#1/.{ds[r_,s_]:>d[r,adrs[[s]]],dr[r_,j_]:>d[r,j+First[#2]]}&,Flatten[segs]]]

seg[i[r_],{a_}]:=With[{p=Prime[r]},Flatten[{Table[i[2],{p}],dr[1,-p],i[1],dr[2,-1],Table[dr[1,1],{p+1}]}]]

seg[d[r_,n_],{a_}]:=With[{p=Prime[r]},Flatten[{i[2],dr[1,5],i[1],dr[2,-1],dr[1,1],ds[1,n],Table[{If[m==p-1,ds[1,a],dr[1,3 p+2-m]],Table[i[1],{p}],dr[2,-p],Table[dr[1,1],{2 p-m-1}],ds[1,a+1]},{m,p-1}]}]]

RMEncode[list_]:=Product[Prime[j]^list[[j]],{j,Length[list]}]
RMToRM2[prog_]:=Module[{segs,adrs},segs=MapIndexed[seg,prog];adrs=FoldList[Plus,1,Map[Length,segs]];MapIndexed[#1/.{ds[r_,s_]:>d[r,adrs[[s]]],dr[r_,j_]:>d[r,j+First[#2]]}&,Flatten[segs]]]
seg[i[r_],{a_}]:=With[{p=Prime[r]},Flatten[{Table[i[2],{p}],dr[1,-p],i[1],dr[2,-1],Table[dr[1,1],{p+1}]}]]
seg[d[r_,n_],{a_}]:=With[{p=Prime[r]},Flatten[{i[2],dr[1,5],i[1],dr[2,-1],dr[1,1],ds[1,n],Table[{If[m==p-1,ds[1,a],dr[1,3 p+2-m]],Table[i[1],{p}],dr[2,-p],Table[dr[1,1],{2 p-m-1}],ds[1,a+1]},{m,p-1}]}]]
RMEvolveList[prog_,init:{_Integer,_List},t_Integer]:=NestList[RMStep[prog,#]&,init,t]
RMExecute[d[r_,m_],{n_,list_}]:=If[list[[r]]>0,{m,MapAt[#-1&,list,r]},{n+1,list}]
RMExecute[i[r_],{n_,list_}]:={n+1,MapAt[#+1&,list,r]}
RMStep[prog_,{n_Integer,list_List}]:=If[n>Length[prog],{n,list},RMExecute[prog[[n]],{n,list}]]

RMEvolveList[RMToRM2[{d[1,4],i[1],d[1,15],i[2],d[1,6],d[1,11],i[1],d[2,7],d[3,7],d[1,15],d[3,4],i[3],d[2,12],d[3,4]}],{1,{RMEncode[{4,0,0}],0}}, 20]

({{Computations with register machines,  (page 1114)}})

{d[1,4],i[1],d[1,15],i[2],d[1,6],d[1,11],i[1],d[2,7],d[3,7],d[1,15],d[3,4],i[3],d[2,12],d[3,4]}

RMEvolveList[prog_,init:{_Integer,_List},t_Integer]:=NestList[RMStep[prog,#]&,init,t]
RMExecute[d[r_,m_],{n_,list_}]:=If[list[[r]]>0,{m,MapAt[#-1&,list,r]},{n+1,list}]
RMExecute[i[r_],{n_,list_}]:={n+1,MapAt[#+1&,list,r]}
RMStep[prog_,{n_Integer,list_List}]:=If[n>Length[prog],{n,list},RMExecute[prog[[n]],{n,list}]]

RMEvolveList[{d[1,4],i[1],d[1,15],i[2],d[1,6],d[1,11],i[1],d[2,7],d[3,7],d[1,15],d[3,4],i[3],d[2,12],d[3,4]},{1,{4,0,0}},25]

({{Page 673 · Arithmetic systems,  (page 1114)}})

RMToAS[prog_,nr_]:=With[{p=Length[prog],g=Product[Prime[j],{j,nr}]},{p g,Sort[Flatten[MapIndexed[With[{n=First[#2]-1},#1/.{i[r_]:>Table[n+j p->(1+n+Prime[r] (-n+#)&),{j,0,g-1}],d[r_,k_]:>Table[n+j p->If[Mod[j,Prime[r]]==0,-1+k+(-n+#)/Prime[r]&,#+1&],{j,0,g-1}]}]&,prog]]]}]

ASEvolveList[{n_,rules_},init_,t_]:=NestList[(Mod[#,n]/.rules)[#]&,init,t]

{Mod[m,p]+1,Map[Last,FactorInteger[Product[Prime[i],{i,nr}] Quotient[m,p]]]-1}

RMToAS[prog_,nr_]:=With[{p=Length[prog],g=Product[Prime[j],{j,nr}]},{p g,Sort[Flatten[MapIndexed[With[{n=First[#2]-1},#1/.{i[r_]:>Table[n+j p->(1+n+Prime[r] (-n+#)&),{j,0,g-1}],d[r_,k_]:>Table[n+j p->If[Mod[j,Prime[r]]==0,-1+k+(-n+#)/Prime[r]&,#+1&],{j,0,g-1}]}]&,prog]]]}]
ASEvolveList[{n_,rules_},init_,t_]:=NestList[(Mod[#,n]/.rules)[#]&,init,t]

ASEvolveList[RMToAS[{i[1], d[2,1], i[2], d[1,3], d[2,1]},2],5,5]

Block[{nr=2,prog={i[1], d[2,1], i[2], d[1,3], d[2,1]},p},p=Length[prog];Function[m,{Mod[m,p]+1,Map[Last,FactorInteger[Product[Prime[i],{i,nr}] Quotient[m,p]]]-1}]/@ASEvolveList[RMToAS[prog,nr],5,5]]

({{History,  (page 1115)}})

FSEvolveList[fracs_,init_,t_]:=NestList[First[Select[fracs #,IntegerQ,1]]&,init,t]

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}

Rest[Log[2,Select[list,IntegerQ[Log[2,#]]&]]]

FSEvolveList[fracs_,init_,t_]:=NestList[First[Select[fracs #,IntegerQ,1]]&,init,t];
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};

FSEvolveList[fracs,2,100]

Rest[Log[2,Select[FSEvolveList[fracs,2,10000],IntegerQ[Log[2,#]]&]]]

The Rule 110 Cellular Automaton

({{Page 683 · Initial conditions,  (page 1116)}})

CTToR110[rules_/;Select[rules,Mod[Length[#],6]≠0&]=={},init_]:=Module[{g1,g2,g3,nr=0,x1,y1,sp},g1=Flatten[Map[If[#==={},{{{2}}},{{{1,3,5-First[#]}},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[rules_/;Select[rules,Mod[Length[#],6]≠0&]=={},init_]:=Module[{g1,g2,g3,nr=0,x1,y1,sp},g1=Flatten[Map[If[#==={},{{{2}}},{{{1,3,5-First[#]}},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]}]

Map[Length,CTToR110[{{1,1,0,1,0,1},{1,1,0,0,0,0}},{0,1}]]

Class 4 Behavior and Universality

({{Page 693 · 2D cellular automata,  (page 1117)}})

a/.{0->0,1->2,2->3,3:>If[0<u<3,1,3]}

The below shows how WireWorld can replicate a NAND gate.

WWstep[list_] := Table[Function[x,Which[
x==0,0,x==1,2,x==2,3,x== 3,If[0<Count[ Extract[list,
Flatten[Table[{i-a,j-b},{a,-1,1},{b,-1,1}],1]
],1]<3,1,3]]][list[[i,j]]],{i,1,Length[list]},{j,1,Length[list[[1]]]}]

Grid/@NestList[WWstep,Transpose@{{0,0,0,0,0,0,0,0,0,0,0},{0,0,0,0,3,3,3,0,0,0,0},{0,1,3,3,3,0,3,3,3,3,0},{0,0,0,0,3,3,3,0,0,0,0},{0,0,0,0,3,3,3,0,0,0,0},{0,0,0,0,0,3,0,0,0,0,0},{0,0,0,0,0,3,0,0,0,0,0},{0,0,0,0,0,3,0,0,0,0,0},{0,0,0,0,0,0,0,0,0,0,0}},5]

Universality in Turing Machines and Other Systems

({{Page 706 ·  Minsky's Turing machine,  (page 1119)}})

TagToMTM[{2,rule_},init_]:=With[{b=FoldList[Plus,1,Map[Length,rule]+1]},Drop[Flatten[{Reverse[Flatten[{1,Map[{Map[{1,0,Table[0,{b[[#+1]]}]}&,#],1}&,rule],1}]],0,0,Map[{Table[2,{b[[#+1]]}],3}&,init]}],-1]]

TagToMTM[{2,rule_},init_]:=With[{b=FoldList[Plus,1,Map[Length,rule]+1]},Drop[Flatten[{Reverse[Flatten[{1,Map[{Map[{1,0,Table[0,{b[[#+1]]}]}&,#],1}&,rule],1}]],0,0,Map[{Table[2,{b[[#+1]]}],3}&,init]}],-1]]

TagToMTM[{2,{{0,1},{0,1,1}}},{0,0,1,1}]

({{Page 707 ·  Rule 110 Turing machines,  (page 1119)}})

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

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

({{Rule 60 Turing machines,  (page 1119)}})

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

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

({{s=2, k=2 Turing machines,  (page 1120)}})

{{1,0}->{1,1,-1},{1,1}->{2,1,1},{2,0}->{1,0,-1},{2,1}->{1,0,1}}

({{Page 709 · Machine 596440,  (page 1120)}})

NestList[Join[{0},Mod[1+Rest[FoldList[Plus,0,#]],2],{{0},{1,1,0}}[[Mod[Apply[Plus,#],2]+1]]]&,init,t]

With[{t=3,init={0,0,0,0,0,0,0,1,0,0,0,0,0,0}},NestList[Join[{0},Mod[1+Rest[FoldList[Plus,0,#]],2],{{0},{1,1,0}}[[Mod[Apply[Plus,#],2]+1]]]&,init,t]]

({{Encoding sequences by integers,  (page 1120)}})

CRT[list_,p_]:=With[{m=Apply[Times,p]},Mod[Apply[Plus,MapThread[#1 (m/#2)^EulerPhi[#2]&,{list,p}]],m]]

LE[list_]:=Module[{n=Length[list],i=Max[MapIndexed[#1-#2&,PrimePi[list]]]+1},CRT[PadRight[list,n+i],Join[Array[Prime[i+#]&,n],Array[Prime,i]]]]

Mod[x,Prime[Rest[NestList[NestWhile[#+1&,#+1,Mod[x,Prime[#]]==0&]&,0,n]]]]

CRT[list_,p_]:=With[{m=Apply[Times,p]},Mod[Apply[Plus,MapThread[#1 (m/#2)^EulerPhi[#2]&,{list,p}]],m]]
LE[list_]:=Module[{n=Length[list],i=Max[MapIndexed[#1-#2&,PrimePi[list]]]+1},CRT[PadRight[list,n+i],Join[Array[Prime[i+#]&,n],Array[Prime,i]]]]

CRT[{1,3,2,3},{5,7,11,13}]

Mod[1641,{5,7,11,13}]

LE[{1,3,2,3}]

With[{n=4,x=58},Mod[x,Prime[Rest[NestList[NestWhile[#+1&,#+1,Mod[x,Prime[#]]==0&]&,0,n]]]]]

({{Register machines,  (page 1121)}})

{d[4,40],i[5],d[3,9],i[3],d[7,4],d[5,14],i[6],d[3,3],i[7],d[6,2],i[6],d[5,11],d[6,3],d[4,35],d[6,15],i[4],d[8,16],d[5,21],i[1],d[3,1],d[5,25],i[2],d[3,1],i[6],d[5,32],d[1,28],d[3,1],d[4,28],i[4],d[6,29],d[3,1],d[5,24],d[2,28],d[3,1],i[8],i[6],d[5,36],i[6],d[3,3],d[6,40],d[4,3]}

R2ToURM[prog_,init_]:=Join[init,With[{n=Length[prog]},{1+LE[Reverse[prog]/.{i[x_]->x,d[x_,y_]->4+2 n+x-2 y}],n+1,0,0,0,0}]]

RMEncode[list_]:=Product[Prime[j]^list[[j]],{j,Length[list]}]
RMToRM2[prog_]:=Module[{segs,adrs},segs=MapIndexed[seg,prog];adrs=FoldList[Plus,1,Map[Length,segs]];MapIndexed[#1/.{ds[r_,s_]:>d[r,adrs[[s]]],dr[r_,j_]:>d[r,j+First[#2]]}&,Flatten[segs]]]
seg[i[r_],{a_}]:=With[{p=Prime[r]},Flatten[{Table[i[2],{p}],dr[1,-p],i[1],dr[2,-1],Table[dr[1,1],{p+1}]}]]
seg[d[r_,n_],{a_}]:=With[{p=Prime[r]},Flatten[{i[2],dr[1,5],i[1],dr[2,-1],dr[1,1],ds[1,n],Table[{If[m==p-1,ds[1,a],dr[1,3 p+2-m]],Table[i[1],{p}],dr[2,-p],Table[dr[1,1],{2 p-m-1}],ds[1,a+1]},{m,p-1}]}]]
CRT[list_,p_]:=With[{m=Apply[Times,p]},Mod[Apply[Plus,MapThread[#1 (m/#2)^EulerPhi[#2]&,{list,p}]],m]]
LE[list_]:=Module[{n=Length[list],i=Max[MapIndexed[#1-#2&,PrimePi[list]]]+1},CRT[PadRight[list,n+i],Join[Array[Prime[i+#]&,n],Array[Prime,i]]]]
R2ToURM[prog_,init_]:=Join[init,With[{n=Length[prog]},{1+LE[Reverse[prog]/.{i[x_]->x,d[x_,y_]->4+2 n+x-2 y}],n+1,0,0,0,0}]]

R2ToURM[RMToRM2[{i[1],d[1,1]}],{0,0}]

R2ToURM[{i[1],d[1,1]},{0,0}]

({{Recursive functions,  (page 1121)}})

TSToPR[{n_,rule_}]:=Fold[Apply[c,Flatten[{#1,Array[p,#2],c[r[z,c[r[p[1],s],c[r[z,p[2]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[2]]],p[1]]],p[#2]]}]]&,c[c[r[p[1],s],p[1],c[r[p[1],r[z,c[s,c[s,s]]]],c[c[r[z,c[r[p[1],s],c[r[z,c[s,z]],c[r[p[1],r[z,c[r[p[1],s],c[r[z,p[2]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[2]]],p[1]]]],p[2],p[3]]],p[1]]],p[1],p[1]],p[1]],p[2]]],p[n+1],MapIndexed[c[r[z,c[r[p[1],p[4]],p[2],p[3],p[4]]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[Length[#2]+1]],#1[[1]],#1[[2]]]&,Nest[Partition[#,2]&,Table[Nest[c[s,#]&,z,FromDigits[Reverse[IntegerDigits[i,2,n]/.rule]+1,3]],{i,0,(2^(  n))-1}],n-1],{0,n-1}]],Range[n,1,-1]]

TSToPR[{n_,rule_}]:=Fold[Apply[c,Flatten[{#1,Array[p,#2],c[r[z,c[r[p[1],s],c[r[z,p[2]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[2]]],p[1]]],p[#2]]}]]&,c[c[r[p[1],s],p[1],c[r[p[1],r[z,c[s,c[s,s]]]],c[c[r[z,c[r[p[1],s],c[r[z,c[s,z]],c[r[p[1],r[z,c[r[p[1],s],c[r[z,p[2]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[2]]],p[1]]]],p[2],p[3]]],p[1]]],p[1],p[1]],p[1]],p[2]]],p[n+1],MapIndexed[c[r[z,c[r[p[1],p[4]],p[2],p[3],p[4]]],c[r[z,r[c[s,z],c[r[c[s,c[s,z]],z],p[2]]]],p[Length[#2]+1]],#1[[1]],#1[[2]]]&,Nest[Partition[#,2]&,Table[Nest[c[s,#]&,z,FromDigits[Reverse[IntegerDigits[i,2,n]/.rule]+1,3]],{i,0,(2^(  n))-1}],n-1],{0,n-1}]],Range[n,1,-1]]

TSToPR[{2,{{0}->{0,1},{1}->{0}}}]

2^FromDigits[Reverse[Take[list,n-1]]] 3^FromDigits[Take[list,{n+1,-1}]] 5^list[[n]] (7^(  s))

With[{s=2,list={0,0,1,0,0},n=3},2^FromDigits[Reverse[Take[list,n-1]]] 3^FromDigits[Take[list,{n+1,-1}]] 5^list[[n]] (7^(  s))]

({{Page 711 · Combinators,  (page 1121)}})

crules={𝓈[x_][y_][z_]->x[z][y[z]],𝓀[x_][y_]->x}

id=𝓈[𝓀][𝓀]

ToC[expr_,vars_]:=Fold[rm,expr,Reverse[vars]]

rm[v_,v_]=id

rm[f_[v_],v_]/;FreeQ[f,v]=f

rm[h_,v_]/;FreeQ[h,v]=𝓀[h]

rm[f_[g_],v_]:=𝓈[rm[f,v]][rm[g,v]]

id=𝓈[𝓀][𝓀];
ToC[expr_,vars_]:=Fold[rm,expr,Reverse[vars]]
rm[v_,v_]=id;
rm[f_[v_],v_]/;FreeQ[f,v]=f;
rm[h_,v_]/;FreeQ[h,v]=𝓀[h];
rm[f_[g_],v_]:=𝓈[rm[f,v]][rm[g,v]]

ToC[x[y[x][z]],{x,y,z}]

zero=𝓈[𝓀]

inc=𝓈[𝓈[𝓀[𝓈]][𝓀]]

plus=𝓈[𝓀[𝓈]][𝓈[𝓀[𝓈[𝓀[𝓈]]]][𝓈[𝓀[𝓀]]]]

times=𝓈[𝓀[𝓈]][𝓀]

power=𝓈[𝓀[𝓈[𝓈[𝓀][𝓀]]]][𝓀]

crules={𝓈[x_][y_][z_]->x[z][y[z]],𝓀[x_][y_]->x};
zero=𝓈[𝓀];
inc=𝓈[𝓈[𝓀[𝓈]][𝓀]];
plus=𝓈[𝓀[𝓈]][𝓈[𝓀[𝓈[𝓀[𝓈]]]][𝓈[𝓀[𝓀]]]];
times=𝓈[𝓀[𝓈]][𝓀];
power=𝓈[𝓀[𝓈[𝓈[𝓀][𝓀]]]][𝓀];

Nest[inc,zero,2]

Nest[inc,zero,3][a][b]//.crules

times[Nest[inc,zero,3]][Nest[inc,zero,2]][a][b]//.crules

𝓈[𝓈[𝓈[𝓈[𝓈[𝓀][𝓀]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]]][𝓈[𝓈[𝓀[𝓈]][𝓈[𝓈[𝓀[𝓈]][𝓈[𝓀[𝓈[𝓈[𝓈[𝓈[𝓈[𝓈[𝓈[𝓀][𝓀]][𝓀[𝓈]]][𝓀[𝓀]]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]]][𝓀[𝓈[𝓈[𝓈[𝓈[𝓀][𝓀]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓈[𝓀[𝓈[𝓈[𝓀][𝓀]]]][𝓈[𝓀[𝓀]][𝓈[𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]]]][𝓈[𝓈[𝓀][𝓀]][𝓀[𝓀]]]]]]][𝓈[𝓀[𝓀]][𝓈[𝓈[𝓀][𝓀]][𝓀[𝓀]]]]]]][𝓀[𝓈[𝓈[𝓈[𝓀][𝓀]][𝓀[𝓈[𝓀]]]][𝓀[𝓈[𝓀]]]]]][𝓀[𝓈[𝓀]]]]]]]][𝓈[𝓀[𝓀]][𝓈[𝓈[𝓈[𝓀][𝓀]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]][𝓀[𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓈[𝓀[𝓈]][𝓀]][𝓈[𝓀][𝓀]]]]]]]]][𝓀[𝓈[𝓀[𝓀]][𝓈[𝓈[𝓀[𝓈]][𝓀]]]]]]][𝓀[𝓈[𝓀][𝓀]]]]][𝓀[𝓈[𝓀]]]

({{Page 712 · Combinator properties,  (page 1122)}})

h[1]=h[2]=h[3]=12

h[t_]:=If[Mod[t,4]==2,2,1] (h[Ceiling[t/2]-1]+t)+{3,5,-7,-1}[[Mod[t,4]+1]]

h[1]=h[2]=h[3]=12;
h[t_]:=If[Mod[t,4]==2,2,1] (h[Ceiling[t/2]-1]+t)+{3,5,-7,-1}[[Mod[t,4]+1]]

Array[h,20]

({{Single combinators,  (page 1123)}})

{𝒿[𝒿][x_][y_][z_]->x[z][y[z]],𝒿[𝒿[𝒿]][x_][y_]->x}

NestList[#/.{𝒿[𝒿][x_][y_][z_]->x[z][y[z]],𝒿[𝒿[𝒿]][x_][y_]->x}&,𝒿[𝒿][𝒿[𝒿]][𝒿[𝒿]][𝒿[𝒿][𝒿[𝒿][𝒿]]][𝒿[𝒿][𝒿]],5]

({{Page 714 ·  Cellular automaton combinators,  (page 1123)}})

Apply[p[p[p[#1][#2]][p[#3][#4]]][p[p[#5][#6]][p[#7][#8]]]/.{0->𝓀,1->𝓈[𝓀]}&,IntegerDigits[m,2,8]]//.crules

p=ToC[z[y][x],{x,y,z}]//.crules

id=𝓈[𝓀][𝓀];
ToC[expr_,vars_]:=Fold[rm,expr,Reverse[vars]]
rm[v_,v_]=id;
rm[f_[v_],v_]/;FreeQ[f,v]=f;
rm[h_,v_]/;FreeQ[h,v]=𝓀[h];
rm[f_[g_],v_]:=𝓈[rm[f,v]][rm[g,v]]
crules={𝓈[x_][y_][z_]->x[z][y[z]],𝓀[x_][y_]->x};
p=ToC[z[y][x],{x,y,z}]//.crules;

With[{m=90},Apply[p[p[p[#1][#2]][p[#3][#4]]][p[p[#5][#6]][p[#7][#8]]]/.{0->𝓀,1->𝓈[𝓀]}&,IntegerDigits[m,2,8]]//.crules]

p[num[Length[list]]][Fold[p[Nest[𝓈,𝓀,#2]][#1]&,p[𝓀][𝓀],list]]//.crules

num[n_]:=Nest[inc,𝓈[𝓀],n]

inc=𝓈[𝓈[𝓀[𝓈]][𝓀]]

Extract[expr,Map[Reverse[IntegerDigits[#,2]]&,3+59/15 (16^Range[Depth[expr[𝓈[𝓀]][𝓈][𝓀]//.crules]-1,1,-1]-1)]]/.{𝓀->0,𝓈[𝓀]->1}

id=𝓈[𝓀][𝓀];
ToC[expr_,vars_]:=Fold[rm,expr,Reverse[vars]]
rm[v_,v_]=id;
rm[f_[v_],v_]/;FreeQ[f,v]=f;
rm[h_,v_]/;FreeQ[h,v]=𝓀[h];
rm[f_[g_],v_]:=𝓈[rm[f,v]][rm[g,v]]
crules={𝓈[x_][y_][z_]->x[z][y[z]],𝓀[x_][y_]->x};
p=ToC[z[y][x],{x,y,z}]//.crules;
num[n_]:=Nest[inc,𝓈[𝓀],n]
inc=𝓈[𝓈[𝓀[𝓈]][𝓀]];

With[{list={0,0,1,0,0}},p[num[Length[list]]][Fold[p[Nest[𝓈,𝓀,#2]][#1]&,p[𝓀][𝓀],list]]//.crules]

With[{expr=%},Extract[expr,Map[Reverse[IntegerDigits[#,2]]&,3+59/15 (16^Range[Depth[expr[𝓈[𝓀]][𝓈][𝓀]//.crules]-1,1,-1]-1)]]/.{𝓀->0,𝓈[𝓀]->1}]

w=cr[p[inc[inc[x[𝓈[𝓀]]]]][inc[x[𝓈[𝓀]]][cr[p[y[𝓈[𝓀]][𝓀]][p[y[𝓈[𝓀]][𝓈[𝓀]]][y[𝓀]]],{y}]][p[x[𝓈[𝓀]][cr[p[p[f[y[𝓀][𝓀][𝓀][𝓈[𝓀]]][y[𝓀][𝓀][𝓈[𝓀]]][y[𝓀][𝓈[𝓀]]]][y[𝓈[𝓀]]]][y[𝓀][𝓀]],{y}]][p[p[𝓀][𝓀]][p[𝓀][x[𝓀]]]][𝓈[𝓀]]][p[𝓀][p[𝓀][𝓀]]]][𝓀]],{x}]

cr[expr_,vars_]:=ToC[expr//.crules,vars]

id=𝓈[𝓀][𝓀];
ToC[expr_,vars_]:=Fold[rm,expr,Reverse[vars]]
rm[v_,v_]=id;
rm[f_[v_],v_]/;FreeQ[f,v]=f;
rm[h_,v_]/;FreeQ[h,v]=𝓀[h];
rm[f_[g_],v_]:=𝓈[rm[f,v]][rm[g,v]]
w=cr[p[inc[inc[x[𝓈[𝓀]]]]][inc[x[𝓈[𝓀]]][cr[p[y[𝓈[𝓀]][𝓀]][p[y[𝓈[𝓀]][𝓈[𝓀]]][y[𝓀]]],{y}]][p[x[𝓈[𝓀]][cr[p[p[f[y[𝓀][𝓀][𝓀][𝓈[𝓀]]][y[𝓀][𝓀][𝓈[𝓀]]][y[𝓀][𝓈[𝓀]]]][y[𝓈[𝓀]]]][y[𝓀][𝓀]],{y}]][p[p[𝓀][𝓀]][p[𝓀][x[𝓀]]]][𝓈[𝓀]]][p[𝓀][p[𝓀][𝓀]]]][𝓀]],{x}];
cr[expr_,vars_]:=ToC[expr//.crules,vars]
crules={𝓈[x_][y_][z_]->x[z][y[z]],𝓀[x_][y_]->x};
p=ToC[z[y][x],{x,y,z}]//.crules;
num[n_]:=Nest[inc,𝓈[𝓀],n]
inc=𝓈[𝓈[𝓀[𝓈]][𝓀]];

f=With[{m=90},Apply[p[p[p[#1][#2]][p[#3][#4]]][p[p[#5][#6]][p[#7][#8]]]/.{0->𝓀,1->𝓈[𝓀]}&,IntegerDigits[m,2,8]]//.crules]

Block[{list={0,0,1,0,0},init,expr},init=p[num[Length[list]]][Fold[p[Nest[𝓈,𝓀,#2]][#1]&,p[𝓀][𝓀],list]]//.crules;expr=w[init]//.crules;Extract[expr,Map[Reverse[IntegerDigits[#,2]]&,3+59/15 (16^Range[Depth[expr[𝓈[𝓀]][𝓈][𝓀]//.crules]-1,1,-1]-1)]]/.{𝓀->0,𝓈[𝓀]->1}]