You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
LaunchKernels[];
In[]:=
TMMutation[rule_,{s_,k_}]:=MapAt[Switch[RandomChoice[Range[3]],1,ReplacePart[#,1->RandomInteger[{1,s}]],2,ReplacePart[#,2->RandomInteger[{0,k-1}]],3,ReplacePart[#,3->RandomChoice[{-1,0,1}]]]&,rule,{RandomInteger[{1,Length[rule]}],2}]
In[]:=
TMLifetime[rule_,init_,tmax_]:=With[{tme=TuringMachine[rule,init,tmax]},If[#==0,Infinity,tmax-#]&[LengthWhile[Rest[Reverse[tme]],#===Last[tme]&]]]
In[]:=
InitTM[{s_,k_}]:=Catenate[Table[{si,ki}->{si,ki,0},{si,1,s},{ki,0,k-1}]]
In[]:=
TMAdaptiveList[initrule_,{s_,k_},init_,tmax_,smax_]:=NestList[With[{u=TMMutation[First[#],{s,k}]},With[{t=TMLifetime[u,init,tmax]},If[t!=Infinity&&t>=Last[#],{u,t},#]]]&,{initrule,TMLifetime[initrule,init,tmax]},smax]
In[]:=
AllTM[s_,k_]:=Thread[Tuples[{Range[s],Range[0,k-1]}]->#]&/@Tuples[Tuples[{Range[s],Range[0,k-1],{-1,0,1}}],s*k]
In[]:=
ParallelTable[SeedRandom[2345234+i];TMAdaptiveList[InitTM[{3,2}],{3,2},{1,{{},0}},100,1000],{i,400}];
In[]:=
First/@SplitBy[#,Last]&/@%10
Out[]=
In[]:=
Length/@%
Out[]=
{5,7,9,5,4,7,3,7,7,8,3,6,6,5,7,7,7,6,6,5,6,5,8,5,7,7,9,6,7,6,7,2,9,7,6,6,10,7,4,6,9,8,6,7,3,8,6,5,8,7,6,7,7,6,7,5,6,3,6,7,6,5,7,8,5,8,6,9,6,8,8,8,7,6,5,5,6,6,7,5,7,9,7,7,7,7,7,7,11,5,8,6,5,7,5,8,8,5,5,6,7,7,7,6,8,7,7,7,6,7,5,7,9,8,9,5,7,10,6,6,5,7,6,7,7,6,4,7,8,7,8,6,7,5,7,8,8,9,7,8,7,5,7,6,8,6,5,7,9,6,6,9,6,3,5,7,8,5,6,5,7,6,8,8,7,6,6,8,6,7,8,9,9,7,7,7,5,8,7,7,5,5,6,5,6,4,6,6,5,6,7,5,5,9,3,5,7,5,5,9,9,9,6,4,6,8,8,6,5,7,6,7,6,7,7,7,5,7,8,8,5,4,7,5,2,6,8,7,6,5,2,7,5,4,5,5,7,6,6,7,8,6,6,5,8,7,9,6,6,5,9,6,3,5,7,6,6,6,9,5,5,5,7,5,8,7,5,6,6,2,5,6,7,6,6,6,7,4,7,6,7,8,7,4,6,9,5,7,6,8,7,5,6,7,6,5,5,6,5,6,6,9,8,9,6,8,6,8,7,3,7,5,8,7,6,5,10,6,7,7,6,7,6,7,5,7,7,6,8,5,6,7,10,8,5,7,6,8,9,4,10,6,7,7,4,10,8,7,7,5,6,8,6,7,5,7,5,7,5,8,7,5,8,7,5,7,5,6,4,6,7,6,3,6,5,5,6,6,9,6,7,6,9,6,6,4,6,7,7,4,7,5,7,5,5,6,6,4,5,4}
In[]:=
#[[-1,-1]]&/@%13
Out[]=
{7,18,10,7,7,9,5,8,9,8,2,6,7,12,8,9,10,8,9,9,14,8,10,8,10,8,9,5,9,7,14,2,9,12,7,14,14,8,8,7,11,13,10,6,3,13,6,5,9,11,6,9,9,14,8,6,9,6,12,16,7,6,7,7,9,8,7,10,9,8,8,20,12,6,6,8,8,6,9,7,9,13,8,9,6,8,7,7,19,8,9,7,7,13,7,14,9,9,6,7,11,10,8,5,9,7,8,10,8,10,13,13,10,12,8,9,10,10,7,6,8,10,6,8,9,5,8,8,10,20,10,7,7,8,7,11,9,11,6,11,12,6,9,9,9,9,6,8,9,8,8,20,8,8,18,6,8,10,7,9,8,6,11,8,6,9,8,15,14,8,9,12,20,7,8,6,10,10,11,13,6,9,6,7,8,7,9,8,7,9,11,6,7,9,6,6,7,10,7,15,11,10,6,6,10,9,20,9,7,17,11,20,6,7,13,8,6,8,12,12,9,9,10,10,8,9,10,16,10,6,6,9,9,9,6,8,13,8,7,7,20,10,10,5,8,6,10,14,7,6,10,6,7,9,7,14,11,9,11,7,8,7,9,8,13,9,7,8,10,1,11,6,11,8,9,9,7,8,12,9,13,8,8,7,7,11,9,10,7,11,7,6,11,10,9,10,6,14,8,16,8,9,9,9,7,11,11,8,10,8,7,8,9,8,8,5,10,6,8,8,6,14,8,10,7,10,8,10,11,7,7,8,18,10,8,11,8,10,9,8,10,8,6,8,8,11,9,11,13,6,8,8,13,6,9,6,8,8,11,9,20,7,8,9,7,18,9,8,9,12,11,7,2,8,8,20,11,8,14,7,10,6,14,6,11,4,5,8,9,8,9,10,7,5,9,6,11,9,8,9}
In[]:=
Max[%]
Out[]=
20
In[]:=
(Labeled[RulePlot[TuringMachine[First[#]],{1,{{},0}},24,Mesh->True,ImageSize->{Automatic,150}],Last[#]+1]&/@First/@SplitBy[#,Last])&/@TakeLargestBy
,#[[-1,-1]]&,10
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
1 |
2 |
4 |
5 |
6 |
8 |
14 |
16 |
21 |
1 |
3 |
4 |
5 |
6 |
7 |
16 |
21 |
1 |
2 |
5 |
6 |
8 |
9 |
21 |
1 |
3 |
5 |
6 |
7 |
9 |
21 |
1 |
2 |
3 |
4 |
5 |
6 |
8 |
9 |
21 |
1 |
3 |
4 |
5 |
6 |
13 |
16 |
21 |
1 |
3 |
4 |
5 |
6 |
8 |
17 |
21 |
1 |
3 |
7 |
9 |
21 |
1 |
2 |
3 |
5 |
6 |
7 |
21 |
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
17 |
18 |
20 |
[[ Many of these “have the same idea” ]]
In[]:=
KeySort[Counts[#[[-1,-1]]&/@%8]]
Out[]=
11,23,31,41,59,648,756,883,969,1043,1129,1211,1313,1413,152,163,171,184,191,209
In[]:=
all23=ParallelTable[SeedRandom[2345234+i];TMAdaptiveList[InitTM[{2,3}],{2,3},{1,{{},0}},100,1000],{i,400}];
In[]:=
all23f=First/@SplitBy[#,Last]&/@all23;
In[]:=
KeySort[Counts[#[[-1,-1]]&/@all23f]]
Out[]=
01,22,31,418,592,69,725,837,949,1029,1130,1222,1315,1428,159,1617,176,184,222,251,342,371
In[]:=
(Labeled[RulePlot[TuringMachine[First[#]],{1,{{},0}},40,ImageSize->{Automatic,150}],Last[#]+1]&/@First/@SplitBy[#,Last])&/@TakeLargestBy[all23f,#[[-1,-1]]&,5]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
1 |
2 |
3 |
4 |
7 |
8 |
9 |
11 |
21 |
25 |
38 |
1 |
2 |
3 |
4 |
8 |
10 |
14 |
16 |
29 |
35 |
1 |
2 |
3 |
4 |
5 |
7 |
9 |
35 |
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
11 |
13 |
14 |
26 |
1 |
2 |
3 |
4 |
6 |
8 |
9 |
10 |
12 |
23 |
Out[]=
s | k | total machines | max. lifetime |
2 | 2 | 4.10× 3 10 | 6 |
3 | 2 | 2.99× 6 10 | 21 |
4 | 2 | 4.29× 9 10 | 107 |
5 | 2 | 1.02× 13 10 | 4.72× 7 10 |
6 | 2 | 3.65× 16 10 | 10↑15 = 10 ⋰ 10 10 |
2 | 3 | 2.99× 6 10 | 38 |
3 | 3 | 1.98× 11 10 | 1.19× 17 10 |
4 | 3 | 3.65× 16 10 | 14072 10 |
[This actually finds the standard BB]
Look at other criteria: e.g. maximum number of head reversals before halting
Look at other criteria: e.g. maximum number of head reversals before halting