Collatz Problem

Author

Eric W. Weisstein
December 3, 2010

This notebook downloaded from http://mathworld.wolfram.com/notebooks/IntegerSequences/CollatzProblem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/CollatzProblem.html.

©2010 Wolfram Research, Inc. except for portions noted otherwise

Code

Collatz[a0_Integer,maxits_:1000]:=NestWhileList[If[EvenQ[#],#/2,3#+1]&,a0,Unequal[#,1,-1,-10,-34]&,1,maxits]

Terras[a0_Integer,maxits_:1000]:=NestWhileList[If[EvenQ[#],#/2,(3#+1)/2]&,a0,Unequal[#,1,-1,-10,-34]&,1,maxits]

Examples

Table[Collatz[n],{n,10}]//ColumnForm

Collatz/@{4,-2,-5,-17}

Terras/@{4,-2,-5,-17}

Steps

A006577 (Formerly M4323)

Length[#]-1&/@Table[Collatz[n],{n,20}]

<<Graphics`Colors`

counts=Table[Length[Collatz[n]],{n,10^4}]-1;//Timing

Show[GraphicsArray[
Block[{$DisplayFunction=Identity},
ListPlot[Take[counts,#],PlotStyle->{Red,PointSize[.005]},
AxesLabel->TraditionalForm/@{n,StyleForm["steps to reach 1",FontSlant->Italic]}]&/@{10^3,10^4}
]]]

Tripling/halving steps

steps=Divide@@@Partition[#,2,1]&/@Table[Collatz[n],{n,20}]

A006666 (Formerly M3733)

h=Count[#,_Integer]&/@steps

t=Count[#,_Rational]&/@steps

t+h

Terras Modification

Collatz[7]

Terras[7]

Table[Terras[n],{n,10}]//ColumnForm

Terras Constant

H[x_]:=-x Log[2,x]-(1-x)Log[2,1-x]
θ=1/Log[2,3];

N[1-H[θ],20]

Register Machine

Using 8 registers

Wolfram 2002, p. 100

Tag System

De Mol  (2008)

CollatzTagIt[s_]:=If[StringLength[s]<2,"HALT",StringDrop[s,2]<>Switch[StringTake[s,1],"a","bc","b","a","c","aaa"]]

CollatzTagSystem[n_]:=NestWhileList[CollatzTag,StringJoin@@Table["a",{n}],StringLength[#]>1&]

NestList[CollatzTagIt,"aaa",25]

3

Terras[3]

c3=CollatzTagSystem[3]

StringLength/@Select[c3,StringMatchQ[#,"a"..]&]

7

Terras[7]

c7=CollatzTagSystem[7]

StringLength/@Select[c7,StringMatchQ[#,"a"..]&]

Enrique Zeleny base-6 2-D CA

Note that this CA considers wraparound rules that effectively make it nonlocal

http://demonstrations.wolfram.com/CollatzProblemAsACellularAutomaton/

Zeleny[n_]:=Transpose[DeleteCases[Transpose[
 (NestWhileList[Partition[#1,3,1,2]/.
{a_,b_,c_}->If[b==6,If[EvenQ[a],6,4],3 Mod[a,2]+Quotient[b,2]/. 0:>6/;a==6]&,Flatten[{IntegerDigits[n,6],Table[6,{50}]}],
!MatchQ[#1,{(6)..,1,(6)..}]&]/. Thread[Range[6]->Range[6,1,-1]])],{1..}]]

rules={0->Red,1->Yellow,2->Green,3->Hue[.5],4->Blue,5->Purple,6->White};

3

Zeleny[3]

ArrayPlot[Mod[-Zeleny[3],7],ColorRules->rules]

ArrayPlot[Transpose@{Range[0,6]},ColorRules->rules,Mesh->True]

Mod[-DeleteCases[Zeleny[3],1,{2}],7]

FromDigits[#,6]&/@%

Collatz[3]

7

Zeleny[7]

ArrayPlot[Mod[-Zeleny[7],7],rules]

Mod[-DeleteCases[Zeleny[7],1,{2}],7]

FromDigits[#,6]&/@%

Collatz[7]

Bruschi Quasi-CA

Base-2

RuleIA[d_]:={0,-1}+StringPosition[d,"01"~~Shortest[___]~~"00",1][[1]]

RuleIBC[d_]:=Module[{i=RuleIA[d],p},
p=StringPosition[StringDrop[d,i[[2]]],"11"~~Shortest[___]~~"00",Overlaps->False];
If[p==={},{i},Join[{i},i[[-1]]+{1,-1}+#&/@p]]
]

CAStep[d_]:=Module[{t=Flatten[Range@@@RuleIBC[d]],u=ToExpression[Characters[d]]},
(StringJoin@@(ToString/@Mod[Table[u[[n+1]]+u[[n+2]]+Boole[MemberQ[t,n+1]],{n,Length[u]-2}],2]
)<>"00")
]

AnnotateStep[d_]:=Row[MapAt[OverDot,Characters[d],List/@Flatten[Range@@@RuleIBC[d]]]]

DecodeCAStrings[l_]:=FromDigits[#,2]&/@((Reverse/@ToExpression[Characters[l]])/.List[x___,0..]:>{x})

EncodeCAString[d_,n_:10]:=StringJoin@@Table["0",{n}]<>StringJoin@@(ToString/@Reverse@IntegerDigits[d,2])<>"00"

Initial Example

AnnotateStep/@(l=Most[FixedPointList[CAStep,"00000011010000111010001011001000"]])//Column

CAStep["00011010000111010001011001000"]

CAStep[%]

DecodeCAStrings[l]

Collatz[First[%]]

Cases[%,_?OddQ]

25

EncodeCAString[25]

(l=Most[FixedPointList[CAStep,EncodeCAString[25]]])//Column

DecodeCAStrings[l]

Collatz[25]

Cases[%,_?OddQ]

163

EncodeCAString[163]

(l=Most[FixedPointList[CAStep,EncodeCAString[163]]])//Column

DecodeCAStrings[l]

Collatz[163]

Cases[%,_?OddQ]

Check Odd

Collatz[2]

Grid[Table[{DecodeCAStrings[Most[FixedPointList[CAStep,EncodeCAString[n]]]],Cases[Collatz[n],_?OddQ]},{n,15}],Dividers->All,Alignment->Left]//TraditionalForm

tf=Equal@@@Table[{DecodeCAStrings[Most[FixedPointList[CAStep,EncodeCAString[n,20]]]],Cases[Collatz[n],_?OddQ]},{n,200}];

Position[tf,False]//Flatten

AnnotateStep/@Most[FixedPointList[CAStep,EncodeCAString[27,21]]]

AnnotateStep/@Most[FixedPointList[CAStep,EncodeCAString[7]]]

x+(2^300)

Length[l=Most[FixedPointList[CAStep,EncodeCAString[2^300+7,30]]]]//Timing

Length[l2=Collatz[2^300+7,10^4]]//Timing

DecodeCAStrings[l]==Cases[l2,_?OddQ]

ArrayPlot[Transpose[ToExpression[Characters[l]]],PixelConstrained->1]

Base-3

To do...