Compare https://community.wolfram.com/groups/-/m/t/2030103

[[NOTE: early non-MW-graph results are WRONG]]

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

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[]:=

ResourceFunction["InteractiveListSelector"][{With[{t=5},ResourceFunction["MultiwayTuringMachine"][#,{{1,t+1,0},Table[0,2t+1]},t,"StatesGraphStructure",PerformanceGoal"Speed"]],Show[MultiwayTuringGraphics[Map[ToExpression,With[{t=5},ResourceFunction["MultiwayTuringMachine"][#,{{1,t+1,0},Table[0,2t+1]},t]],{2}]],ImageSizeTiny]}#&/@Table[List/@RandomSample[rulecases,5],20]]

Out[]=

