Executable Programs from Alex Smith's 
solution to the Wolfram 2,3 Turing Machine Prize

Definitions

MyTimeConstraint=10000;

Code for evaluating cyclic tag systems, from the notes of A New Kind of Science. (A cyclic tag system is represented as a list of strings to be added (themselves represented as lists), followed by the initial value of the working string, bundled together in a list.)

CTStep[{{r_,s___},{0,a___}}]:={{s,r},{a}}

CTStep[{{r_,s___},{1,a___}}]:={{s,r},Join[{a},r]}

CTStep[{u_,{}}]:={u,{}}

CTEvolveList[rules_,init_,t_]:=Last/@NestList[CTStep,{rules,init},t]

ConcatBits[list_]:=StringJoin[(ToString[#1]&)/@list]

Output to match that of the Perl cyclic-tag program.

CTCompress[hist_]:=ConcatBits[(#1[[1]]&)/@Select[hist,MatchQ[#1,{__}]&]]

CTCompressY[hist_]:=ConcatBits[Flatten[(#1/.x_->{x,x}&)/@(#1[[1]]&)/@Select[hist,MatchQ[#1,{__}]&]]]

Converting a cyclic-tag system to system 5. This is quite simple, but long, because the constraints of what values the integers corresponding to various parts of the cyclic tag system can take as compared to other integers generated have to be enforced; this is done using i, which is stored as a parameter to start with and later using iKnown[] and iPlaceholder[], and holds the lowest legal value a newly-added integer can take. (A system 5 initial condition is represented as a list containing the bag followed by each rule in order; the bag and rules themselves are represented as lists.)

CTToSystem5[rules_,init_,steps_]:=CTToSystem5Main[CTInitToSystem5Init[{},init,1],rules,steps]

CTInitToSystem5Init[sofar_,{0,reminit___},i_]:=CTInitToSystem5Init[Flatten[{sofar,i,i+1,i+2,i+3}],{reminit},i+4]

CTInitToSystem5Init[sofar_,{1,reminit___},i_]:=CTInitToSystem5Init[Flatten[{sofar,i,i+2,i+3,i+5}],{reminit},i+6]

CTToSystem5Main[CTInitToSystem5Init[sofar_,{},i_],rules_,steps_]:=Flatten[{{sofar},CTRulesToSystem5Rules[{},rules,steps,iKnown[i+2]]},1]

CTRulesToSystem5Rules[sofar_,_,0,iKnown[_Integer]]:=sofar

CTRulesToSystem5Rules[sofar_,{firstrule_,otherrules___},steps_,iKnown[i_Integer]]:=CTRulesToSystem5Rules[Flatten[{sofar,CTRuleToSystem5Rule[{},firstrule,i]},1],{otherrules,firstrule},steps-1,iPlaceholder[]]

CTRulesToSystem5Rules[{sofar___,iPlaceholder[i_]},rules_,steps_,iPlaceholder[]]:=CTRulesToSystem5Rules[{sofar},rules,steps,iKnown[i]]

CTRuleToSystem5Rule[sofar_,{0,remrule___},i_]:=CTRuleToSystem5Rule[Flatten[{sofar,i,i+1}],{remrule},i+4]

CTRuleToSystem5Rule[sofar_,{1,remrule___},i_]:=CTRuleToSystem5Rule[Flatten[{sofar,i,i+3}],{remrule},i+6]

CTRuleToSystem5Rule[sofar_,{},i_]:={(#1+2&)/@sofar,sofar,{},{},iPlaceholder[i]}

Emulating system 5 is a lot easier than constructing a system 5 program:

RemoveEvenDuplicates[l_List]:=First/@Select[Tally[l],MatchQ[#1,{_,_?OddQ}]&]

System5Step[initial_List]:=Join[{Sort[(#1-1&)/@RemoveEvenDuplicates[initial[[1]]]]},((#1+1&)/@(#1&))/@Drop[initial,1]]/.{{0,x___},{y___},z___}->{{x,y},z}

MemoryEfficientCompress[step_,compress_,init_,steps_] and MemoryEfficientCompressNoJoin[step_,compress_,init_,steps_] are both capable of being equivalent to compress[NestList[step,init,steps]] in some cases used below (which, if either, is correct depends on the details of the compress function used, and sometimes neither can be used). They both also show ProgressIndicators when doing long computations.

MemoryEfficientCompress[step_,compress_,init_,steps_]:=Monitor[{sc=0,StringJoin[Reap[Nest[{step[#1],Sow[compress[{#1}]],sc=sc+1}[[1]]&,init,steps]][[2]]]}[[2]],{ProgressIndicator[sc,{1,steps}],sc}]

SowIfNotNull[{}]:=0

SowIfNotNull[{l__}]:=Sow[{l}]

MemoryEfficientCompressNoJoin[step_,compress_,init_,steps_]:={sc=0,Monitor[Flatten[Reap[Nest[{step[#1],sc=sc+1,SowIfNotNull[compress[{#1}]]}[[1]]&,init,steps]][[2]],2],{ProgressIndicator[sc,{1,steps}],sc}]}[[2]]

Matching the output of the Perl cyclic-tag program.

System5CompressC[hist_List]:=ConcatBits[Flatten[(If[MatchQ[#1,{{1,___},__}],{0,0},{1,1}]&)/@hist]]

System5CompressY[hist_List]:=ConcatBits[(#1[[2]]&)/@Partition[((1/2) (Length[#1]-1)&)/@Split[Flatten[(If[MatchQ[#1,{{1,___},__}],{0,1},{1,1}]&)/@hist]],4]]

Compiling system 5 to system 4. (A system 4 initial condition is represented as a list; each element of that list is either another list (a set in system 4), S (a star) or ActiveState[A], ActiveState[B], or ActiveState[C] (which indicate that the next element is active in that state).)

System5ToSystem4[initial_List,f_Integer]:=Flatten[{ActiveState[A],{{{{RemoveEvenDuplicates[(2 #1-2&)/@initial[[1]]]}}}},{{Table[{S,{}},{f}]}},({S,{{RemoveEvenDuplicates[Join[Range[0,f 3],(2 #1+f+3&)/@#1]]}},Table[{S,{}},{2 f}],S,{{RemoveEvenDuplicates[Range[0,3 f]]}},Table[{S,{}},{2 f-2}]}&)/@Drop[initial,1]},4]

Emulating system 4. System 4 has several rules that don't follow an obvious pattern; each of these rules is therefore given a separate definition below (or sometimes more than one definition).

ContainsA0[l_List]:=MatchQ[l,{___,0,___}]

ListDecrement[l_List]:=(#1-1&)/@Select[l,#1>0&]

Rule 1

System4Step[{before___,elem_,ActiveState[A],{list___},after___}]:={before,ActiveState[A],elem,{list},after}

System4Step[{ActiveState[A],{list___},after___}]:={ActiveState[B],{list},after}

Rule 2

System4Step[{before___,ActiveState[A],S,after___}]:={before,ActiveState[B],after}

Rule 3

System4Step[{before___,ActiveState[B],{list___},after___}]:=If[ContainsA0[{list}],{before,ListDecrement[{list}],ActiveState[C],after},{before,ListDecrement[{list}],ActiveState[B],after}]

System4Step[{before___,ActiveState[C],{list___},after___}]:=If[ContainsA0[{list}],{before,ListDecrement[{list}],ActiveState[B],after},{before,ListDecrement[{list}],ActiveState[C],after}]

Rule 4

System4Step[{before___,elem_,ActiveState[B],S,after___}]:={before,ActiveState[A],elem,after}

Rule 5

System4Step[{before___,ActiveState[C],S,{list___},after___}]:={before,S,ActiveState[C],RemoveEvenDuplicates[Join[{list},{1}]],after}

The length of useful system 4 programs means that far too much output (either to read or to fit into memory) is produced when trying to run a useful system 4 program using NestList. Here are the definitions used to reproduce or approximate the M, R, C, and Y output formats of the Perl program. (Most of the compression functions take a history from NestList as their argument, although the Y format takes the C format's output as its argument; as this would be too large to fit into my computer's memory, MemoryEfficientCompressList or the NoJoin version have to be used in practice when compressing the output of a large system 4 program.)

ListAsRangesHelper[c_,i_]:=If[c>0,i-2,If[c<0,i-1,""]]

ListAsRangesHelper2[{x_,y_}]:=If[x≠y,ToString[x]<>"-"<>ToString[y],ToString[x]]

ListAsRanges[l_List]:=StringJoin[Riffle[ListAsRangesHelper2/@Partition[Select[Table[ListAsRangesHelper[ListConvolve[{-1,1},(If[MatchQ[l,{___,#1,___}],1,0]&)/@Range[-1,Max[l]+1]][[i]],i],{i,Max[l]+2}],!MatchQ[#1,""]&],2],","]]/;MatchQ[l,{__}]

ListAsRanges[{}]:=""

System4Combine[{before___,{list1___},{list2___},after___}]:=System4Combine[{before,RemoveEvenDuplicates[Join[{list1},{list2}]],after}]

System4Combine[l_List]:=l/;!MatchQ[l,{___,{___},{___},___}]

System4CombineMore[{before___,S,{},S,{},after___}]:=System4CombineMore[{before,RunLength[{S,{}},2],after}]

System4CombineMore[{before___,S,{0},S,{0},after___}]:=System4CombineMore[{before,RunLength[{S,{0}},2],after}]

System4CombineMore[{before___,S,x_,RunLength[{S,x_},c_],after___}]:=System4CombineMore[{before,RunLength[{S,x},c+1],after}]

System4CombineMore[{before___,RunLength[{S,x_},c_],S,x_,after___}]:=System4CombineMore[{before,RunLength[{S,x},c+1],after}]

System4CombineMore[{before___,RunLength[x_,c1_],RunLength[x_,c2_],after___}]:=System4CombineMore[{before,RunLength[x,c1+c2],after}]

System4CombineMore[l_List]:=l/;!MatchQ[l,{___,S,{},S,{},___}|{___,S,{0},S,{0},___}|{___,S,x_,RunLength[{S,x_},_],___}|{___,RunLength[{S,x_},_],S,x_,___}|{___,RunLength[x_,_],RunLength[x_,_],___}]

System4CompressMHelper[S]:="_"

System4CompressMHelper[{l___}]:=ListAsRanges[{l}]

System4CompressMHelper[ActiveState[s_]]:=ToString[s]

System4CompressMHelper[RunLength[{S,{}},c_]]:="(_x"<>ToString[c]<>")"

System4CompressMHelper[RunLength[{S,{0}},c_]]:="(_0x"<>ToString[c]<>")"

System4CompressM[hist_]:=(StringJoin[System4CompressMHelper/@System4Combine[#1]]&)/@Select[hist,MatchQ[#1,{___,ActiveState[_],S,___}]&]

System4CompressR[hist_]:=(StringJoin[System4CompressMHelper/@System4CombineMore[System4Combine[#1]]]&)/@Select[hist,MatchQ[#1,{___,ActiveState[_],S,___}]&]

System4CompressC[hist_]:=ConcatBits[(System4Combine[#1]/.{{_?Positive...}..,ActiveState[B],___}->1/.{___,ActiveState[C],___}->0/.{___}->""&)/@Select[hist,MatchQ[#1,{{___}..,ActiveState[B|C],S,___}]&]]

System4CompressY[compressC_]:=StringJoin[(((StringLength[#1])/2)&)/@StringSplit[compressC,"00"]]

The cellular automaton that simplifies the construction of a system 3 initial condition from a system 4 initial condition, written here as a recursive function using ListConvolve.

System3Set[0,length_]:=Join[{2},Table[1,{length-1}]]

System3Set[row_?Positive,length_]:=(Mod[#1,2]+1&)/@ListConvolve[{1,1},Join[{1},System3Set[row-1,length]]]

Converting system 4 to systems 3, 2, and 0. (The system 1 program corresponding to a system 4 program is the same as the system 0 program corresponding to that system 4 program.) The system 3, 2, 1, and 0 initial conditions are written as lists, with ActiveState[A] (or B or C) immediately before the active element. This is implemented by marking all the elements in the system 4 program as LeftOfActive or RightOfActive, translating all the system 4 sets into lists of system 3 elements and all the system 4 stars into placeholders including ReplaceLeft or ReplaceRight (indicating that the neighbouring element should be replaced by a 0, or possibly by an active 0), doing those replacements, and then converting the resulting system 3 program into a system 2 or system 0 form if desired.

System4ToSystem3Helper[{before___,ActiveState[s_],elem_,after___}]:=Flatten[{(LeftOfActive[#1]&)/@{before},ActiveState[s,elem],(RightOfActive[#1]&)/@{after}}]

StartsAndEndsWith2[{2,l___,2}]:={2,l,2}

StartsAndEndsWith2[{1,l___}]:=StartsAndEndsWith2[(3-#1&)/@{1,l}]

StartsAndEndsWith2[{2,l___,1}]:=StartsAndEndsWith2[Flatten[(#1/.{a_,b_}->{a,3-b}&)/@Partition[{2,l,1},2]]]

System4ElemToSystem3[(LeftOfActive|RightOfActive)[{set___}],w_]:=StartsAndEndsWith2[(Mod[Total[(#1-1&)/@#1],2]+1&)/@Transpose[Join[{Table[1,{(2^w)}]},(System3Set[#1,(2^w)]&)/@{set}]]]

System4ElemToSystem3[LeftOfActive[S],_]:=ReplaceLeft[0]

System4ElemToSystem3[RightOfActive[S],_]:=ReplaceRight[0]

System4ElemToSystem3[ActiveState[s_,{set___}],w_]:={ActiveState[s],System4ElemToSystem3[LeftOfActive[{set}],w]}

System4ElemToSystem3[ActiveState[A,S],_]:=ReplaceLeft[{ActiveState[A],0}]

System4ElemToSystem3[ActiveState[B,S],_]:={ActiveState[B],ReplaceRight[0]}

System4ElemToSystem3[ActiveState[C,S],_]:={ReplaceLeft[0],ActiveState[A],ReplaceRight[0]}

DoSystem4Replacements[{before___,elem_,ReplaceLeft[i_],after___}]:=DoSystem4Replacements[{before,i,after}]

DoSystem4Replacements[{before___,ReplaceRight[i_],elem_,after___}]:=DoSystem4Replacements[{before,i,after}]

DoSystem4Replacements[l_List]:=l/;!MatchQ[l,{___,_,ReplaceLeft[_],___}|{___,ReplaceRight[_],_,___}]

System4ToSystem3[init_,w_]:=Flatten[DoSystem4Replacements[Flatten[{Table[0,{(2^w)}],2,2,1,(System4ElemToSystem3[#1,w]&)/@System4ToSystem3Helper[init]}]]]

System3ToSystem2[{before___,ActiveState[A],elem_,after___}]:=Flatten[{(Mod[3-#1,3]&)/@{before},ActiveState[A],Mod[3-elem,3],after}]

System3ToSystem2[{before___,ActiveState[B],after___}]:=Flatten[{(Mod[3-#1,3]&)/@{before},ActiveState[B],after}]

System2ToSystem0[{before___,ActiveState[C],2,after___}]:={before,ActiveState[B],1,after}

System2ToSystem0[{before___,ActiveState[C],1,after___}]:={before,ActiveState[B],2,after}

System2ToSystem0[{before___,ActiveState[C],0,after___}]:={before,ActiveState[B],0,after}

System2ToSystem0[{before___,ActiveState[B],after___}]:={before,ActiveState[B],after}

System2ToSystem0[{before___,ActiveState[A],after___}]:={before,ActiveState[A],after}

System4ToSystem2[l_,w_]:=System3ToSystem2[System4ToSystem3[l,w]]

System4ToSystem0[l_,w_]:=System2ToSystem0[System4ToSystem2[l,w]]

System3ToSystem0[x__]:=System2ToSystem0[System3ToSystem2[x]]

Executing a system 3, 2, 1, or 0 program. A general SystemStep is used, which is given a function as input that specifies how to change the active cell and the cells before and after.

SystemStep[rules_,{before___,elem1_,ActiveState[s_],elem2_,elem3_,after___}]:=Flatten[{before,rules[elem1,s,elem2,elem3],after}]

System0Rules[a_,A,0,b_]:={a,1,ActiveState[B],b}

System0Rules[a_,B,0,b_]:={ActiveState[A],a,2,b}

System0Rules[a_,A,1,b_]:={ActiveState[A],a,2,b}

System0Rules[a_,B,1,b_]:={a,2,ActiveState[B],b}

System0Rules[a_,A,2,b_]:={ActiveState[A],a,1,b}

System0Rules[a_,B,2,b_]:={a,0,ActiveState[A],b}

System1Rules[a_,A,0,b_]:={a,1,ActiveState[B],b}

System1Rules[a_,B,0,b_]:={ActiveState[A],a,2,b}

System1Rules[a_,A,1,b_]:={ActiveState[A],a,2,b}

System1Rules[a_,B,1,b_]:={a,2,ActiveState[B],b}

System1Rules[a_,A,2,b_]:={ActiveState[A],a,1,b}

System1Rules[a_,B,2,0]:={a,0,ActiveState[A],0}

System1Rules[a_,B,2,1]:={a,1,ActiveState[B],2}

System1Rules[a_,B,2,2]:={a,1,ActiveState[B],1}

System2Rules[a_,A,0,b_]:={a,1,ActiveState[B],b}

System2Rules[a_,B,0,b_]:={ActiveState[A],a,2,b}

System2Rules[a_,C,0,b_]:={ActiveState[A],a,2,b}

System2Rules[a_,A,1,b_]:={ActiveState[A],a,2,b}

System2Rules[a_,B,1,b_]:={a,2,ActiveState[B],b}

System2Rules[a_,C,1,0]:={a,0,ActiveState[A],0}

System2Rules[a_,C,1,1]:={a,1,ActiveState[C],1}

System2Rules[a_,C,1,2]:={a,1,ActiveState[C],2}

System2Rules[a_,A,2,b_]:={ActiveState[A],a,1,b}

System2Rules[a_,B,2,0]:={a,0,ActiveState[A],0}

System2Rules[a_,B,2,1]:={a,1,ActiveState[C],1}

System2Rules[a_,B,2,2]:={a,1,ActiveState[C],2}

System2Rules[a_,C,2,b_]:={a,2,ActiveState[B],b}

System3Rules[a_,A,0,b_]:={a,2,ActiveState[B],b}

System3Rules[a_,B,0,b_]:={ActiveState[A],a,2,b}

System3Rules[a_,C,0,b_]:={ActiveState[A],a,2,b}

System3Rules[a_,A,1,b_]:={ActiveState[A],a,1,b}

System3Rules[a_,B,1,b_]:={a,1,ActiveState[B],b}

System3Rules[a_,C,1,0]:={a,0,ActiveState[A],0}

System3Rules[a_,C,1,1]:={a,2,ActiveState[C],1}

System3Rules[a_,C,1,2]:={a,2,ActiveState[C],2}

System3Rules[a_,A,2,b_]:={ActiveState[A],a,2,b}

System3Rules[a_,B,2,0]:={a,0,ActiveState[A],0}

System3Rules[a_,B,2,1]:={a,2,ActiveState[C],1}

System3Rules[a_,B,2,2]:={a,2,ActiveState[C],2}

System3Rules[a_,C,2,b_]:={a,1,ActiveState[B],b}

Emulating or approximating the output formats of the Perl programs. (The active state is shown before the active element, rather than on the next line; the P output format is somewhat different but still gives much the same visual appearance, due to the embedding of literal newlines in the output list.)

System0To3CompressN[_,hist_]:=(ConcatBits[Select[#1,IntegerQ]]&)/@hist

SelectRelevantZeros[_?Positive,hist_]:=Select[hist,MatchQ[#1,{___,ActiveState[_],0,___}]&]

SelectRelevantZeros[0,hist_]:=(#1[[3]]&)/@Select[Partition[hist,3,1],MatchQ[#1[[3]],{___,ActiveState[_],0,___}]&&!MatchQ[#1,{{___,ActiveState[B],___},{___,ActiveState[A],___},{___,ActiveState[A],___}}]&]

CellOrStateToString[i_Integer]:=ToString[i]

CellOrStateToString[ActiveState[s_]]:=ToString[s]

System0To3CompressZ[s_,hist_]:=(StringJoin[CellOrStateToString/@#1]&)/@SelectRelevantZeros[s,hist]

System0To3CompressPHelper[{before___,a_?Positive,morebefore___,ActiveState[s_],___}]:={{Length[{before,a,morebefore}],s}}

System0To3CompressPHelper[{before___,ActiveState[s_],___}]:={"\n",{Length[{before}],s}}/;MatchQ[{before},{(0)...}]

System0To3CompressP[s_,hist_]:=Flatten[System0To3CompressPHelper/@SelectRelevantZeros[s,hist],1]

System0To3CompressC[pcompressed_]:=ConcatBits[(If[Length[#1]==3,1,0]&)/@Split[pcompressed,#2=!="\n"&]]

CyclicTagToSystem5InitialCondition[rules_,init_,t_]:=Flatten[FoldList[{#+2,#,{},{}}&[Accumulate[Prepend[Riffle[2#2+1,3],3]]+#1[[1,-1]]]&,{Accumulate[Riffle[Flatten[Transpose[{init,init}+1]],1,{1,-2,2}]]},PadRight[#,t,#]&[rules]],1]/.{_Integer}->{}

System5InitialConditionToSystem4InitialCondition[s5init_]:=With[{f=Max[2*3^(Length[s5init]-2)*(1+Max[s5init]),3]},Riffle[Flatten[{{{2#1-2},Table[{},{f}]},{Complement[Range[0,3f],2#+f+3],Table[{},{2f}],Range[0,3f],Table[{},{2f-2}]}&/@{##2}},2],Star]&@@s5init]

TuringMarker[coord_List,{s_Integer,stot_Integer}]:=With[{rot=({{Cos[#1],Sin[#1]},{-Sin[#1],Cos[#1]}}&)[N[(2(s-1)π)/stot]],r=0.18},{GrayLevel[0],Disk[coord,r],If[s>0,Polygon[(coord+rot.#1&)/@{{r,0},{-r,0},{0,.6},{r,0}}],{}]}]

TuringGraphicsA[history_,stot_Integer,colrls_,opts___]:=Module[{xmax,ymax,x,y,list},list=(#1[[2]]&)/@history;{ymax,xmax}=Dimensions[list];
Graphics[{Raster[Reverse[list/.colrls/.GrayLevel[x_]:>{1,1,1}x/.RGBColor->List]],GrayLevel[0],Table[TuringMarker[{history[[y,1,2]]-.5,ymax-y+.5},{history[[y,1,1]],stot}],{y,1,ymax}]},PlotRange->{{0,xmax},{0,ymax}},opts]]

TM23ColorRules={0->White,1->ColorData[3,2],2->ColorData[3,6]};

SystemHistoryToTuringHistory[hist_]:=With[{p=Position[First[hist],_ActiveState,1][[1,1]]},Map[Function[s,{{Replace[s[[#,1]],{A->1,B->2,C->3}],#,#-p},Delete[s,#]}&[Position[s,_ActiveState,1][[1,1]]]],hist]]

Cyclic Tag Systems

With these definitions, it's now possible to show what Mathematica does with the examples used to demonstrate the Perl programs.

The cyclic tag examples, based on 11011 101 01 0 "" 010: the native Mathematica output, the Perl program's default output, and the Y-format output.

CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]

CTCompress[CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]]

CTCompressY[CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]]

ArrayPlot[CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]+1]

Emulating a two-colour cyclic tag system with system 5

Converting cyclic tag systems (a long example to show typical output, and a short example for use in examples later) to system 5.

CTToSystem5[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]

CTToSystem5[{{1},{1,0}},{0,1},3]

The annotated example from the original proof. Note that Mathematica shows its output at a different stage in the system 5 rules from the Perl output; the Perl output is taken just after the rules are incremented and the bag is decremented, whereas the Mathematica output is taken just before duplicates are removed from the bag. The output shows the same features, though.

NestList[System5Step,CTToSystem5[{{1},{1,0}},{0,1},3],36]

The C and Y output formats, and a comparison to the cyclic tag system. The iteration count for the NestList (calculated automatically by the Perl programs) is entered manually here; likewise, the Perl program detects that there will be an infinite number of 1s in the C-compressed example, whilst the Mathematica program just continues until the entered number of iterations have finished. The equivalent cyclic tag system output is given as a comparison. (TimeConstrained is used on all the more time-consuming cells.)

System5CompressC[NestList[System5Step,CTToSystem5[{{1},{1,0}},{0,1},3],37]]

TimeConstrained[System5CompressY[NestList[System5Step,CTToSystem5[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50],6000]],MyTimeConstraint]

CTCompressY[CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]]

Visualizing System 5 and its bags:

Grid[Map[If[#==={},".",ArrayPlot[IntegerDigits[#,2,10],ImageSize->{30,30}]]&,NestList[System5Step,CTToSystem5[{{1},{1,0}},{0,1},3],37],{2}]]

Emulating system 5 with system 4

Compiling system 5 to system 4; this gives the same output as the corresponding Perl program, allowing for the differences in notation.

System5ToSystem4[{{2},{1,4},{1,6},{},{}},16]

Some system 4 examples, in various output formats, and comparisons to system 5 and cyclic-tag systems. In the last example here, note that System4CompressC sometimes misses off an initial 1 in the output (the C output format, which I described in the proof as 'when the leftmost star is active', should have been described as 'when a star becomes active for the first time after the system has changed from state A to state B at the left-hand end of the program'; I approximated this in Mathematica as 'when the leftmost star is active in state C, or in state B with no zeros in any of the sets to its left after the sets have been merged', which gives the same output except that it sometimes leaves off an initial 1). Note also that I accidentally typoed the input to one of the Perl programs; I wrote "0,1 1 1,0" when there were no commas allowed in the input format; the Perl program interpreted the commas as 1s, so here I've used the Mathematica version of "011 1 110", i.e Sequence[{{1}, {1, 1, 0}}, {0, 1, 1}] (written as two separate arguments to CTToSystem5 rather than using Sequence directly).

NestList[System4Step,{{0,6,8},{},S,ActiveState[B],{3,4},S,{8},{11,20}},7]

TimeConstrained[System4CompressM[NestList[System4Step,System5ToSystem4[{{2},{1,4},{1,6}},8],1400]],MyTimeConstraint]

TimeConstrained[System4CompressR[NestList[System4Step,System5ToSystem4[{{2},{1,4},{1,6}},8],1400]],MyTimeConstraint]

CTToSystem5[{{1},{1,1,0}},{0,1,1},3]

System5CompressC[NestList[System5Step,CTToSystem5[{{1},{1,1,0}},{0,1,1},3],37]]

TimeConstrained[MemoryEfficientCompress[System4Step,System4CompressC,System5ToSystem4[CTToSystem5[{{1},{1,1,0}},{0,1,1},3],40],300000],MyTimeConstraint]

System5CompressC[NestList[System5Step,{{2},{1,4},{1,6},{},{}},50]]

TimeConstrained[System4CompressC[NestList[System4Step,System5ToSystem4[{{2},{1,4},{1,6},{},{}},16],10000]],MyTimeConstraint]

CTCompressY[CTEvolveList[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50]]

TimeConstrained[System5CompressY[NestList[System5Step,CTToSystem5[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50],6000]],MyTimeConstraint]

Hold[TimeConstrained[System4CompressY[MemoryEfficientCompress[System4Step,System4CompressC,System5ToSystem4[CTToSystem5[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50],300],Unknown]],MyTimeConstraint]];

Hold[TimeConstrained[System4CompressY[MemoryEfficientCompress[System4Step,System4CompressC,System5ToSystem4[CTToSystem5[{{1,0,1},{0,1},{0},{},{0,1,0}},{1,1,0,1,1},50],1000],Unknown]],MyTimeConstraint]];

Emulating system 4 with system 3, 2, 1, or 0

The table of strings used as an example in the proof that demonstrates that the method used for simplifying the system 4 to system 3 translation is correct.

Table[System3Set[i,16],{i,0,15}]

Graphics[Raster[Reverse[((2-#1&)/@#1&)/@%]],ImageSize->{128,128}]

Simple examples of system 4 to system 3 or system 0 translation. The output is the same as in the Perl program.

System4ToSystem0[{{1,2},{3},S,{},ActiveState[A],S,{}},4]

System4ToSystem3[{{1,2},{3},S,{},ActiveState[A],S,{}},4]

Uncompressed, and N-, Z-, P-, and C-compressed output (normally system 3 or system 0 is used for the demonstration, but the final example is correct for all four systems). (The lower values for f and w mean that the output goes wrong faster, leaving 10 at the end rather than 111111111111111110, when the output from the system 5 system would leave an infinite number of 1s (and increasing f and w would give an arbitrary number of 1s)). (The extra coding in the final input cell is due to the fact that three steps of context, not one, need to be held in memory to find relevant zeros in system 0.)

NestList[SystemStep[System0Rules,#1]&,{0,0,0,ActiveState[A],0,0,0,0,0,0},27]

NestList[SystemStep[System2Rules,#1]&,{0,0,0,ActiveState[A],0,0,0,0,0,0},21]

System0To3CompressN[0,NestList[SystemStep[System0Rules,#1]&,{0,0,0,ActiveState[A],0,0,0,0,0,0},27]]

System0To3CompressZ[0,NestList[SystemStep[System0Rules,#1]&,System4ToSystem0[{{1,2},ActiveState[B],{3},S,{},S,{}},4],300]]

TimeConstrained[MemoryEfficientCompressNoJoin[SystemStep[System3Rules,#1]&,System0To3CompressP[3,#1]&,System4ToSystem3[System5ToSystem4[{{1,2},{4,5},{2,4},{},{},{}},16],6],1000000],MyTimeConstraint]

System0To3CompressC[%]

Timing[System0To3CompressC[TimeConstrained[MemoryEfficientCompressNoJoin[SystemStep[System2Rules,#1]&,System0To3CompressP[2,#1]&,System4ToSystem2[System5ToSystem4[{{1,2},{4,5},{2,4},{},{},{}},16],6],1000000],MyTimeConstraint]]]

System0To3CompressC[TimeConstrained[MemoryEfficientCompressNoJoin[SystemStep[System1Rules,#1]&,System0To3CompressP[1,#1]&,System4ToSystem0[System5ToSystem4[{{1,2},{4,5},{2,4},{},{},{}},16],6],1000000],MyTimeConstraint]]

System0To3CompressC[TimeConstrained[MemoryEfficientCompressNoJoin[{lastbut2=lastbut1,lastbut1=last,last=SystemStep[System0Rules,#1],last}[[4]]&,System0To3CompressP[0,{lastbut2,lastbut1,last}]&,System4ToSystem0[System5ToSystem4[{{1,2},{4,5},{2,4},{},{},{}},16],6],1000000],MyTimeConstraint]]

As a comparison, here's the equivalent system 4 system (there are an arbitrarily high number of 1s at the end instead of the 0 if arbitrarily high values of f are used; the system 4 version with f capped at 16 is only very slightly better than systems 0-3 emulating this system, and they're going wrong slightly sooner due to the value of w not being high enough to quite accommodate the whole of the system 4 system).

TimeConstrained[MemoryEfficientCompress[System4Step,System4CompressC,System5ToSystem4[{{1,2},{4,5},{2,4},{},{},{}},16],100000],MyTimeConstraint]

Comparing system 3 with the original system 0 on random initial conditions, using the translation function to create the system 0 initial conditions.

Join[RandomChoice[{0,1,2},20],{ActiveState[B]},RandomChoice[{0,1,2},20]]

MapIndexed[Overscript[#,#2[[1]]/.{1->Style[Text["System 3"],20],2->Style[Text["TM 596440"],20]}]&,ArrayPlot[#,ColorRules->{0->White,1->Purple,2->Brown,ActiveState[A]->Blue,ActiveState[B]->Green,ActiveState[C]->Red}]&/@{NestList[SystemStep[System3Rules,#]&,#,45],NestList[SystemStep[System0Rules,#]&,System3ToSystem0[#],63]}&[{2,2,0,1,1,1,2,2,0,0,0,0,0,1,0,0,2,0,0,2,ActiveState[B],1,1,1,0,1,2,2,1,2,1,1,2,1,2,2,0,0,2,0,0}]]

MapIndexed[Overscript[TuringGraphicsA[SystemHistoryToTuringHistory[#],#2[[1]]/.{1->3,2->2},TM23ColorRules],#2[[1]]/.{1->Style[Text["System 3"],20],2->Style[Text["TM 596440"],20]}]&,{NestList[SystemStep[System3Rules,#]&,#,45],NestList[SystemStep[System0Rules,#]&,System3ToSystem0[#],63]}&[{2,2,0,1,1,1,2,2,0,0,0,0,0,1,0,0,2,0,0,2,ActiveState[B],1,1,1,0,1,2,2,1,2,1,1,2,1,2,2,0,0,2,0,0}]]