Wolfram Cloud Document

Code:

In[]:=

singleRow[list_]:=Mean[Last/@list]

In[]:=

singleHeads[list_,t_]:=KeyValueMap[Style[Disk[{#1-.5,t},.3],Opacity[#2]]&,(Counts[#]/Length[#])&[#[[1,2]]&/@list]]

In[]:=

MultiwayTuringGraphics[evol_]:=Show[ArrayPlot[singleRow/@evol,ColorFunction(Blend[{White,Orange},#]&)],Graphics[MapIndexed[singleHeads[#,.5+Length[evol]-First[#2]]&,evol]]]

In[]:=

HackedMWTM[rule_,init_,t_]:=ReverseApplied[Complement]@@@Partition[With[{a=Map[ToExpression,ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t,"AllStatesList"],{2}]},FoldList[Union,a]],2,1]

In[]:=

TestDeterministic[rulelist_]:=(Length[#]===Length[Union[#]])&[First/@Flatten[rulelist]]

In[]:=

TMRuleCases[s_Integer,k_Integer]:=TMRuleCases[s,k]=Flatten[Table[{s0,c0}{s1,c1,d},{s0,1,s},{s1,1,s},{c0,0,k-1},{c1,0,k-1},{d,{-1,1}}],4]

In[]:=

TMAppliesQ[rule_,{{s_,i_,___},array_}]:=MemberQ[First/@Flatten[rule],{s,array[[i]]}]

In[]:=

TMAppliesGraph[rule_,t_]:=With[{ggx=ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t,"StatesGraphStructure",AspectRatio1,GraphLayout"LayeredDigraphEmbedding",PerformanceGoal"Speed"]},HighlightGraph[ggx,Select[VertexList[ggx],!TMAppliesQ[rule,ToExpression[#]]&],VertexSizeLarge]]

Not including head state

Running:

In[]:=

MultiwayTuringGraphics[Map[ToExpression,With[{t=10},ResourceFunction["MultiwayTuringMachine"][{{{2,1}{1,0,1}},{{1,0}{2,0,-1}},{{1,0}{2,0,1}},{{1,0}{1,0,1}},{{2,0}{2,1,-1}}},{{1,t+1,0},Table[0,2t+1]},t]],{2}]]

Out[]=

In[]:=

rulecases=Flatten[Table[{s0,c0}{s1,c1,d},{s0,1,2},{s1,1,2},{c0,0,1},{c1,0,1},{d,{-1,1}}],4]

Out[]=

{{1,0}{1,0,-1},{1,0}{1,0,1},{1,0}{1,1,-1},{1,0}{1,1,1},{1,1}{1,0,-1},{1,1}{1,0,1},{1,1}{1,1,-1},{1,1}{1,1,1},{1,0}{2,0,-1},{1,0}{2,0,1},{1,0}{2,1,-1},{1,0}{2,1,1},{1,1}{2,0,-1},{1,1}{2,0,1},{1,1}{2,1,-1},{1,1}{2,1,1},{2,0}{1,0,-1},{2,0}{1,0,1},{2,0}{1,1,-1},{2,0}{1,1,1},{2,1}{1,0,-1},{2,1}{1,0,1},{2,1}{1,1,-1},{2,1}{1,1,1},{2,0}{2,0,-1},{2,0}{2,0,1},{2,0}{2,1,-1},{2,0}{2,1,1},{2,1}{2,0,-1},{2,1}{2,0,1},{2,1}{2,1,-1},{2,1}{2,1,1}}

In[]:=

TMRuleCases[2,2]

Out[]=

[ From rulial post ... ]

In[]:=

allrules=With[{s=2,k=2},Table[Flatten[MapIndexed[{1,-1}#2+{0,k}{1,1,2}Mod[Quotient[#1,{2k,2,1}],{s,k,2}]+{1,0,-1}&,Partition[IntegerDigits[n,2sk,sk],k],{2}]],{n,0,4095}]];o0[{s1_,k1_}{s2_,k2_,o_}]:={s1,k1}{s2,k2,-o};minrule[r_]:=First[Sort[Sort/@{r,o0/@r}]];Keys[ReverseSort[Counts[RulePlot[TuringMachine[#],{1,{{},0}},9,ImageSize{Automatic,45},FrameStyleLightGray]&/@Union[minrule/@allrules]]]]

Out[]=





In[]:=

Length[%]

Out[]=

In[]:=

ResourceFunction["TuringMachineFromNumber"][2506]

Out[]=

{{1,1}{2,0,-1},{1,0}{2,1,1},{2,1}{1,0,1},{2,0}{1,1,-1}}

In[]:=

NDCases[rn_]:=With[{base=ResourceFunction["TuringMachineFromNumber"][rn]},Map[List,Select[Append[base,#]&/@TMRuleCases[2,2],Length[#]Length[DeleteDuplicates[#]]&],{2}]]

In[]:=

TuringMachinePlot[Flatten[#],2,2,"RulePlot"]&/@NDCases[2506]

Out[]=





In[]:=

Length[%]

Out[]=

In[]:=

284096

Out[]=

114688

In[]:=

TMSummary[rule_,t_]:=With[{g=ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t,"StatesGraphStructure",PerformanceGoal"Speed",GraphLayout"LayeredDigraphEmbedding",AspectRatio1,ImageSizeTiny]},{Graph[TimeConstrained[CanonicalGraph[g],2,g],ImageSizeTiny],Show[MultiwayTuringGraphics[DeleteCases[HackedMWTM[rule,{{1,t+1,0},Table[0,2t+1]},t],{}]],ImageSizeTiny]}]

In[]:=

TMCSummary[rule_,t_]:=With[{g=ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t,"StatesGraphStructure",PerformanceGoal"Speed",ImageSizeTiny,GraphLayout"LayeredDigraphEmbedding",AspectRatio1]},{Graph[TimeConstrained[CanonicalGraph[g],2,g],ImageSizeTiny],ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t,"CausalGraphStructure",PerformanceGoal"Speed",ImageSizeTiny,GraphLayout"LayeredDigraphEmbedding",AspectRatio1],Show[MultiwayTuringGraphics[DeleteCases[HackedMWTM[rule,{{1,t+1,0},Table[0,2t+1]},t],{}]],ImageSizeTiny]}]

In[]:=

TMStates[rule_,t_]:=ResourceFunction["MultiwayTuringMachine"][rule,{{1,t+1,0},Table[0,2t+1]},t]

Deterministic 2,2 + 1

In[]:=

ResourceFunction["InteractiveListSelector"][{#[[1,1]],Length[#]}->#[[1,2]]&/@GatherBy[ResourceFunction["ParallelMapMonitored"][TMSummary[#,5]#&,NDCases[2506]],#[[1,1]]&]]

Out[]=



