Code

In[]:=
Clear[TMStep]
TMStep[rule_List,{s_,a_List,n_}]:=If[!(1≤n≤Length[a]),Throw[Null],Apply[{#1,ReplacePart[a,#2,n],n+#3}&,Replace[{s,a〚n〛},rule]]]
In[]:=
TMEvolveList[rule_,init_List,t_Integer]:=NestWhileList[TMStep[rule,#]&,init,#[[1]]!=0&,1,t]
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[]:=
InitTM[{s_,k_}]:=Catenate[Table[{si,ki}->{0,ki,0},{si,1,s},{ki,0,k-1}]]
In[]:=
TMLifetime[rule_,init_,tmax_]:=If[#===tmax,Infinity,#]&[If[#===Null,-Infinity,#]&[Catch[Length[TMEvolveList[rule,init,tmax]]-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!=-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[0,s],Range[0,k-1],{-1,1}}],s*k]
In[]:=
Clear[TuringMachineRulePlot]
In[]:=
TuringMachineRulePlot[rule_,init_,t_,stot_:2,opts___]:=Module{data},​​data={{#1,#3},#2}&@@@TMEvolveList[rule,init,t];​​Show​​ArrayPlot​​ArrayPad[data[[All,-1]],{{0},{1}}],​​ColorRules->0->White,1->
,2->Purple,​​opts​​,​​Graphics​​MapIndexed​​
[◼]
FiniteStateIndicatorIcon
Version (latest): 2.1.0
Documentation »
[{#[[1,2]]+1/2,Length[data]-First[#2]+1/2},{#[[1,1]],stot}]&,​​data​​​​​​​​;

k=2, s=2 Exhaustive

In[]:=
AllTM[2,2]
Out[]=
{{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{0,0,-1}},{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{0,0,1}},{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{0,1,-1}},{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{0,1,1}},{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{1,0,-1}},{{1,0}{0,0,-1},{1,1}{0,0,-1},{2,0}{0,0,-1},{2,1}{1,0,1}},
⋯20724⋯
,{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{1,1,-1}},{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{1,1,1}},{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{2,0,-1}},{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{2,0,1}},{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{2,1,-1}},{{1,0}{2,1,1},{1,1}{2,1,1},{2,0}{2,1,1},{2,1}{2,1,1}}}
Full expression not available
(
original memory size:
26.9 MB)
In[]:=
TMLifetime[InitTM[{2,2}],{1,ConstantArray[0,15],5},4]
Out[]=
2
In[]:=
TMEvolveList[InitTM[{2,2}],{1,ConstantArray[0,15],5},4]
Out[]=
{{1,{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},5},{0,{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},5}}
In[]:=
SeedRandom[234234];TMAdaptiveList[InitTM[{2,2}],{2,2},{1,ConstantArray[0,15],5},100,1000]
Out[]=
{{{{1,0}{0,0,0},{1,1}{0,1,0},{2,0}{0,0,0},{2,1}{0,1,0}},1},{{{1,0}{0,0,0},{1,1}{0,0,0},{2,0}{0,0,0},{2,1}{0,1,0}},1},{{{1,0}{0,0,0},{1,1}{0,0,0},{2,0}{2,0,0},{2,1}{0,1,0}},1},{{{1,0}{0,0,0},{1,1}{0,0,-1},{2,0}{2,0,0},{2,1}{0,1,0}},1},{{{1,0}{0,0,0},{1,1}{0,0,-1},{2,0}{2,0,1},{2,1}{0,1,0}},1},{{{1,0}{0,1,0},{1,1}{0,0,-1},{2,0}{2,0,1},{2,1}{0,1,0}},1},
⋯990⋯
,{{{1,0}{1,0,0},{1,1}{2,0,-1},{2,0}{1,1,0},{2,1}{1,1,0}},100},{{{1,0}{1,0,0},{1,1}{2,0,-1},{2,0}{1,1,0},{2,1}{1,1,0}},100},{{{1,0}{1,0,0},{1,1}{2,0,-1},{2,0}{1,1,0},{2,1}{1,1,0}},100},{{{1,0}{1,0,0},{1,1}{2,0,-1},{2,0}{1,1,0},{2,1}{1,1,0}},100},{{{1,0}{1,0,0},{1,1}{2,0,-1},{2,0}{1,1,0},{2,1}{1,1,0}},100}}
Full expression not available
(
original memory size:
1.2 MB)
In[]:=
First/@SplitBy[SeedRandom[234234];TMAdaptiveList[InitTM[{2,2}],{2,2},{1,ConstantArray[0,15],5},100,1000],Last]
Out[]=
{{{{1,0}{0,0,0},{1,1}{0,1,0},{2,0}{0,0,0},{2,1}{0,1,0}},1},{{{1,0}{1,1,1},{1,1}{2,0,-1},{2,0}{2,0,1},{2,1}{1,0,1}},12},{{{1,0}{2,0,0},{1,1}{1,0,0},{2,0}{2,0,1},{2,1}{2,0,0}},13},{{{1,0}{2,0,0},{1,1}{1,0,0},{2,0}{1,0,1},{2,1}{2,0,0}},23},{{{1,0}{2,0,-1},{1,1}{1,0,0},{2,0}{1,0,1},{2,1}{2,1,0}},100}}
In[]:=
RulePlot[TuringMachine[#],{1,{{},0}},#2]&@@@
429
Out[]=
RulePlot[TuringMachine[{{1,0}{0,0,0},{1,1}{0,1,0},{2,0}{0,0,0},{2,1}{0,1,0}}],{1,{{},0}},1],
,
,
,

In[]:=
DominantColors

{}
In[]:=
aaa=SparseArray[{},10]
Out[]=
SparseArray
Specified elements: 0
Dimensions: {10}

In[]:=
aaa[[2]]=3
Out[]=
3
In[]:=
aaa//Normal
Out[]=
{0,3,0,0,0,0,0,0,0,0}
In[]:=
ParallelMap[TMLifetime[#,{1,ConstantArray[0,101],51},50]&,AllTM[2,2]]
Out[]=
{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
⋯20394⋯
,50,50,50,3,3,3,3,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,4,4,4,4,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,3,3,3,3,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,3,3,3,3,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50,50}
Full expression not available
(
original memory size:
497.7 kB)
In[]:=
Counts[%]
Out[]=
16912,5010952,22304,4128,640,3384,516
In[]:=
Position[%439,6]
Out[]=
{{13919},{14063},{14207},{14351},{15636},{15780},{15924},{16068},{17396},{17420},{17540},{17564},{17684},{17708},{17828},{17852},{18661},{18662},{18663},{18664},{18949},{18950},{18951},{18952},{19111},{19135},{19255},{19279},{19399},{19423},{19543},{19567},{20233},{20234},{20235},{20236},{20521},{20522},{20523},{20524}}
In[]:=
AllTM[2,2]Flatten
441
;
In[]:=
TuringMachineRulePlot[#,{1,ConstantArray[0,11],5},20]&/@
464

Adaptive

[[[ For visualization copy the last tape, and put a red dot for the halted head state ]]]
[[ Also, we should padding around the states ]]

3,3

[[ Log , or multilog , behavior ]]

Rulial Multiway

Only works for s=2, k=2: