THE WOLFRAM 2,3 TURING MACHINE RESEARCH PRIZE

Gallery

Definitions

Color1=RGBColor[{0.977,0.952,0.}];

Color2=RGBColor[{0.965,0.401,0.18}];

TM23Graphics[data_,opts___]:=ArrayPlot[Join[{0},#,{0}]&/@Last/@data,ColorRules->{0->White,1->Color1,2->Color2},opts,Epilog->MapIndexed[Translate[Rotate[With[{r=.18},{Disk[{0,0},r],Polygon[{{r,0},{-r,0},{0,.6},{r,0}}]}],2(#[[1,1]]-1)π/2,{0,0}],{#[[1,2]]+1/2,Length[data]-First[#2]+1/2}]&,data]]

TMIcon[s_]:=Rotate[With[{r=.18},{Disk[{0,0},r],Polygon[{{r,0},{-r,0},{0,.6},{r,0}}]}],2(s-1)π/2,{0,0}]

LeftTMCompress[history_]:=Module[{min=history[[1,1,2]]+1},Pick[history,If[min>#[[1,2]],min=#[[1,2]];True,False]&/@history]]

RightTMCompress[history_]:=Module[{max=history[[1,1,2]]-1},Pick[history,If[max<#[[1,2]],max=#[[1,2]];True,False]&/@history]]

LeftRightTMCompress[history_]:=Module[{min=history[[1,1,2]]+1,max=history[[1,1,2]]-1},Pick[history,If[max≥ #[[1,2]]≥ min,False,min=Min[min,#[[1,2]]];max=Max[max,#[[1,2]]];True]&/@history]]

DirectionTMCompress[history_]:=Module[{dir=1,pos=history[[1,1,2]]},Pick[Most[history],Rest[If[
Sign[#[[1,2]]-pos]==dir,pos=#[[1,2]];False,dir=Sign[#[[1,2]]-pos];pos=#[[1,2]];True]&/@history]]]

TM23NestList[init_,t_]:=NestList[(Join[{1},Mod[Accumulate[#],2],{{1},{1,0,1}}[[1+Mod[Total[#],2]]]])&,init,t]

StepCount[hist_]:=-7 (Length[hist]-1)+2 Total[Rest[Length/@hist]]+2Count[Rest[hist],1,{2}]+Length[Last[hist]]-Length[First[hist]]

Basic Evolution

TM23Graphics[TuringMachine[{596440,2,3},{1,{{},0}},20],Mesh->True]

20 steps in evolution from a blank tape.

TM23Graphics[TuringMachine[{596440,2,3},{1,{{},0}},50],Mesh->True]

50 steps in evolution from a blank tape.

GraphicsRow[TM23Graphics/@Partition[TuringMachine[{596440,2,3},{1,{{},0}},200],50],4]

200 steps in evolution from a blank tape.

GraphicsRow[TM23Graphics[TuringMachine[{596440,2,3},{1,{#,0}},50],ImageSize->{Automatic,200}]&/@IntegerDigits[Select[Range[10],Mod[#,3]≠0&],3]]

Evolution from a sequence of initial conditions.

Head Motion

ListLinePlot[#[[1,3]]&/@TuringMachine[{596440,2,3},{1,{{},0}},250],Filling->Axis,FillingStyle->Blend[{Color1,Color2,White}],Frame->True]

Excursions of the head over the course of 250 steps, starting from a blank tape.

ListLinePlot[#[[1,3]]&/@TuringMachine[{596440,2,3},{1,{{},0}},1000],Filling->Axis,FillingStyle->Blend[{Color1,Color2,White}],Frame->True]

Excursions of the head over the course of 1000 steps, starting from a blank tape.

ListLinePlot[Function[i,#[[1,3]]&/@TuringMachine[{596440,2,3},{1,{i,0}},250]]/@IntegerDigits[Select[Range[10],Mod[#,3]≠0&],3],Filling->Axis,Frame->True]

Excursions of the head for a sequence of different initial conditions.

ListLinePlot[Function[i,#[[1,3]]&/@TuringMachine[{596440,2,3},{1,{i,0}},250]]/@IntegerDigits[Select[Range[25],Mod[#,3]≠0&],3],Frame->True]

Paths for more initial conditions.

State Sequences

ListLinePlot[Accumulate[#[[1,1]]&/@TuringMachine[{596440,2,3},{1,{{},0}},200]-3/2],Frame->True,FrameTicks->{Automatic,None}]

A representation of the states of the head for 200 steps (state 1 is an down-tick; 2 is an up-tick).

ListLinePlot[Accumulate[#[[1,1]]&/@TuringMachine[{596440,2,3},{1,{{},0}},500]-3/2],Frame->True,FrameTicks->{Automatic,None}]

A representation of the states of the head for 500 steps (state 1 is an down-tick; 2 is an up-tick).

GraphPlot[Rule@@@Partition[{#[[1,1]],#[[2,#[[1,2]]]]}&/@TuringMachine[{596440,2,3},{1,{{},0}},20],2,1],DirectedEdges->True,VertexRenderingFunction->(Translate[Scale[{{EdgeForm[Gray],{White,Color1,Color2}[[#2[[2]]+1]],Rectangle[#1,#1+{1,1}]},Translate[TMIcon[#2[[1]]],#1+{1/2,1/2}]},.2,#1],-{.1,.1}]&)]

Sequences of rule case used for 20 steps of evolution from a blank tape.

GraphPlot[Rule@@@Partition[{#[[1,1]],#[[2,#[[1,2]]]]}&/@TuringMachine[{596440,2,3},{1,{{},0}},200],2,1],VertexRenderingFunction->(Translate[Scale[{{EdgeForm[Gray],{White,Color1,Color2}[[#2[[2]]+1]],Rectangle[#1,#1+{1,1}]},Translate[TMIcon[#2[[1]]],#1+{1/2,1/2}]},.2,#1],-{.1,.1}]&)]

Sequences of rule case used for 200 steps of evolution from a blank tape.

ListLinePlot[Transpose[With[{e={#[[1,1]],#[[2,#[[1,2]]]]}&/@TuringMachine[{596440,2,3},{1,{{},0}},5000]},Table[(Count[Take[e,t],#]/t)&/@Tuples[{{1,2},{0,1,2}}],{t,5000}]]],Frame->True]

Cumulative fractions of different rule cases as a function of number of steps, starting from a blank tape.

Compressed Evolution

TM23Graphics[LeftTMCompress[TuringMachine[{596440,2,3},{1,{{},0}},StepCount[TM23NestList[{},10]]]],Mesh->All]

10 steps of left compressed evolution, corresponding to 400 steps of underlying evolution.

TM23Graphics[RightTMCompress[TuringMachine[{596440,2,3},{1,{{},0}},370]],Mesh->All]

Right compressed evolution corresponding to 400 steps of underlying evolution.

TM23Graphics[LeftRightTMCompress[TuringMachine[{596440,2,3},{1,{{},0}},StepCount[TM23NestList[{},10]]]],Mesh->All]

Left-right compressed evolution corresponding to 400 steps of underlying evolution.

TM23Graphics[DirectionTMCompress[TuringMachine[{596440,2,3},{1,{{},0}},StepCount[TM23NestList[{},10]]+1]]]

Direction-compressed evolution  corresponding to 400 steps of underlying evolution.

ArrayPlot[MapIndexed[Drop[#,First[#2]-1]&,(1+TM23NestList[{},200])],ColorRules->{0->White,1->Color1,2->Color2}]

200 steps of left compressed evolution  (corresponding to 129520 steps of underlying evolution).

ArrayPlot[MapIndexed[Drop[#,First[#2]-1]&,(1+TM23NestList[Table[0,{100}],200])],ColorRules->{0->White,1->Color1,2->Color2}]

200 steps of left compressed evolution  starting from 100 yellow cells (corresponding to 213600 steps of underlying evolution).

ListLinePlot[Differences[Flatten[Position[Differences[Length/@TM23NestList[{},1000]],4]]],PlotRange->All,Filling->Bottom,FillingStyle->LightBlue,Frame->True,Mesh->All,Axes->None,PlotRange->{Automatic,{0,All}},AspectRatio->1/2]

The spacings between successive outward jumps in 1000 steps of left compressed evolution (corresponding to 3214932 steps of underlying evolution).

ListLinePlot[Differences[Flatten[Position[Differences[Length/@TM23NestList[{},10000]],4]]],PlotRange->All,Frame->True,Mesh->All,Axes->None,PlotRange->{Automatic,{0,All}},AspectRatio->1/2]

The spacings between successive outward jumps in 10000 steps of left compressed evolution (corresponding to 323588676 steps of underlying evolution).

Causal Networks

LayeredGraphPlot[With[{rules=MapIndexed[{First[#2],#[[1,2]],#[[2,#[[1,2]]]]}&,TuringMachine[{596440,2,3},{1,{{},0}},250]]},Join[Rule@@@Partition[rules,2,1],Flatten[Rule@@@Partition[#,2,1]&/@Last@Reap[Sow[#,#[[2]]]&/@rules],1]]],DirectedEdges->True,AspectRatio->1.5]

The causal network of updating events, starting from a blank tape.

GraphPlot[With[{rules=MapIndexed[{First[#2],#[[1,2]],#[[2,#[[1,2]]]]}&,TuringMachine[{596440,2,3},{1,{{},0}},250]]},Join[Rule@@@Partition[rules,2,1],Flatten[Rule@@@Partition[#,2,1]&/@Last@Reap[Sow[#,#[[2]]]&/@rules],1]]],DirectedEdges->True]

The causal network, rearranged.

GraphPlot[With[{rules=MapIndexed[{First[#2],#[[1,2]],#[[2,#[[1,2]]]]}&,TuringMachine[{596440,2,3},{1,{{},0}},2000]]},Join[Rule@@@Partition[rules,2,1],Flatten[Rule@@@Partition[#,2,1]&/@Last@Reap[Sow[#,#[[2]]]&/@rules],1]]],VertexRenderingFunction->None]

The causal network from 2000 steps of evolution from a blank tape.

Function Computed by the Machine

ListLogPlot[FromDigits[Last[#],3]&/@TuringMachine[{596440,2,3},{1,{{},0}},100],Joined->True,Filling->Bottom,Frame->True]

The "function" computed on successive steps, starting from a blank tape.

ListLogPlot[Table[{n,FromDigits[Last[Last[TuringMachine[{596440,2,3},{1,{IntegerDigits[n,3],0}},10]]],3]},{n,0,100}],Joined->True,Filling->Bottom]

The "function" from initial conditions to final states, after 10 steps.

Random Initial Conditions

TM23Graphics[TuringMachine[{596440,2,3},{{1,25},RandomChoice[{0,1,2},50]},50],Mesh->True]

Evolution with a random initial condition.

TM23Graphics[TuringMachine[{596440,2,3},{{1,50},RandomChoice[{0,1,2},100]},200]]

More steps with a random initial condition.