[ with Christopher ]
[ with Christopher ]
Revised Code
Revised Code
In[]:=
getTuringMachineStateEvolutionFunction[state_String,rules_List]:=ToString/@(Last[TuringMachine[#,ToExpression[state],1]]&/@rules)
In[]:=
getTuringMachineStateEventFunction[state_String,rules_List]:=Module[{evolution=ToString/@(Last[TuringMachine[#,ToExpression[state],1]]&/@rules)},Module[{length=StringLength[Last[Last[System`Dump`showStringDiff[state,#]]]]},{StringDrop[state,-length]StringDrop[#,-length],StringDrop[state,-length],{"",StringTake[state,-length]}}]&/@evolution]
In[]:=
getTuringMachineStateEventFunction[states_List,rules_List]:=Catenate[getTuringMachineStateEventFunction[#,rules]&/@states]
In[]:=
getTuringMachineEventApplicationFunction[{(input_String|input_Symbol)output_String,(input_String|input_Symbol),{prefix_String,suffix_String}}]:=StringJoin[prefix,output,suffix]
In[]:=
getTuringMachineElementShifts[shiftedFragment_String,{input:{inputPrefix_String,inputSuffix_String},output:{outputPrefix_String,outputSuffix_String}}]:=Table[Rule@@({StringPart[shiftedFragment,position],{StringJoin[#1,StringTake[shiftedFragment,;;position-1]],StringJoin[StringTake[shiftedFragment,position+1;;],#2]}}&@@@{input,output}),{position,StringLength[shiftedFragment]}]
In[]:=
getTuringMachineElementShifts[{(input_String|input_Symbol)output_String,(input_String|input_Symbol),{prefix_String,suffix_String}}]:=Join[getTuringMachineElementShifts[prefix,{{"",StringJoin[input,suffix]},{"",StringJoin[output,suffix]}}],getTuringMachineElementShifts[suffix,{{StringJoin[prefix,input],""},{StringJoin[prefix,output],""}}]]
In[]:=
getTuringMachineElements[{substring_String,{prefix_String,suffix_String}}]:={StringPart[substring,#],{StringJoin[prefix,StringTake[substring,;;#-1]],StringJoin[StringTake[substring,#+1;;],suffix]}}&/@Range[StringLength[substring]]
In[]:=
getTuringMachineEventDecompositionFunction[event:{(input_String|input_Symbol)output_String,(input_String|input_Symbol),{prefix_String,suffix_String}}]:=Join[{getTuringMachineElementShifts[event]},getTuringMachineElements[{#,{prefix,suffix}}]&/@{input,output}]
In[]:=
turingMachineStateRenderingFunction:=(Inset[Framed[Style[RulePlot[TuringMachine[2506(*needsasampleofruletype*)],ToExpression[#2],0,MeshAll,FrameFalse],Hue[0.62,1,0.48]],BackgroundDirective[Opacity[0.2],Hue[0.62,0.45,0.87]],FrameMargins{{2,2},{0,0}},RoundingRadius0,FrameStyleDirective[Opacity[0.5],Hue[0.62,0.52,0.82]]],#1,Center,#3]&)
In[]:=
getTuringMachineEventRenderingForm[function_,{(input_String|input_Symbol)output_String,(input_String|input_Symbol),{prefix_String,suffix_String}}]:=Row[{Column[{function[ArrayPlot[{Last[ToExpression[StringJoin[prefix,input,suffix]]]}]],function[ArrayPlot[{Last[ToExpression[StringJoin[prefix,output,suffix]]]}]]},Center,0]}]
In[]:=
turingMachineEventRenderingFunction:=(If[First[First[#2]]===Null,Inset[Framed[Style[getTuringMachineEventRenderingForm[Identity,#2],Hue[0.09,1,0.32]],BackgroundDirective[Opacity[0.7],RGBColor[0.259,0.576,1]],FrameMargins{{2,2},{0,0}},RoundingRadius0,FrameStyleDirective[Opacity[0.4],Hue[0.09,1,0.91]]],#1,Center,#3],Inset[Framed[Style[getTuringMachineEventRenderingForm[Identity,#2],Hue[0.09,1,0.32]],BackgroundDirective[Opacity[0.7],Hue[0.14,0.34,1]],FrameMargins{{2,2},{0,0}},RoundingRadius0,FrameStyleDirective[Opacity[0.4],Hue[0.09,1,0.91]]],#1,Center,#3]]&)
In[]:=
MultiwayTuringMachine[rules_List,initialCondition_,stepCount_Integer,rest___]:=ResourceFunction["MultiwaySystem"][<|"StateEvolutionFunction"(getTuringMachineStateEvolutionFunction[#,rules]&),"StateEquivalenceFunction"SameQ,"StateEventFunction"(getTuringMachineStateEventFunction[#,rules]&),"EventDecompositionFunction"getTuringMachineEventDecompositionFunction,"EventApplicationFunction"getTuringMachineEventApplicationFunction,"SystemType""TuringMachine","EventSelectionFunction"Identity|>,{ToString[initialCondition]},stepCount,rest,"StateRenderingFunction"turingMachineStateRenderingFunction,"EventRenderingFunction"turingMachineEventRenderingFunction]
In[]:=
IdentityTuringMachine[{s_,k_}]:=Flatten[Table[{si,ki}{si,ki,0},{si,s},{ki,0,k-1}]]
In[]:=
DeltaTMRule[{s0_,k0_},{s_,k_}]:=Flatten[Table[{s0,k0}{si,ki,off},{si,s},{ki,0,k-1},{off,{-1,1}}]]
In[]:=
AllDeltaTMRules[{s_,k_}]:=With[{id=IdentityTuringMachine[{s,k}]},DeleteDuplicatesBy[Prepend[id,#],First]&/@Flatten[Table[DeltaTMRule[{si,ki},{s,k}],{si,s},{ki,0,k-1}]]]
In[]:=
MultiwayTuringMachine[AllDeltaTMRules[{2,2}],{{1,4,0},Table[0,7]},2,"StatesGraph",VertexSize8]
Out[]=
In[]:=
With[{t=3},MultiwayTuringMachine[AllDeltaTMRules[{2,1}],{{1,t,0},Table[0,2t+1]},t,"StatesGraphStructure"]]
Out[]=
In[]:=
With[{t=4},MultiwayTuringMachine[AllDeltaTMRules[{2,1}],{{1,t,0},Table[0,2t+1]},t,"StatesGraphStructure"]]
Out[]=
In[]:=
With[{t=4},MultiwayTuringMachine[AllDeltaTMRules[{1,2}],{{1,t,0},Table[0,2t+1]},t,"StatesGraphStructure"]]
Out[]=
In[]:=
{{1,1,0},Table[0,2*1+1]}
Out[]=
{{1,1,0},{0,0,0}}
[[[ Should be t+1 ]]]
[[[ Should be t+1 ]]]
In[]:=
With[{t=1},MultiwayTuringMachine[AllDeltaTMRules[{1,2}],{{1,t+1,0},Table[0,2t+1]},t,"StatesGraph",VertexSize1]]
Out[]=
In[]:=
With[{t=2},MultiwayTuringMachine[AllDeltaTMRules[{1,2}],{{1,t+1,0},Table[0,2t+1]},t,"StatesGraph",VertexSize2]]
This is the subgraph looking at length-5 regions of the tape... (when the head is in that region)
If we allowed the head to stay in one place, then we’d get the pure n-hypercube....
Stationary tape
Stationary tape
Trivial adjacency for s=1
Trivial adjacency for s=1
Vertex transitivity of the infinite graph:
Vertex transitivity of the infinite graph:
Move the head to a different position
Xor the tape with a fixed tape [[[ local gauge transformation of the tape ]]]
Is it a Cayley graph?
Is it a Cayley graph?
Elements of the group are {1, pos, tape}
It is a group because there is always an inverse; there is an identity if the head can stay in one place.