(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.1' Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 46184, 1422]*) (*NotebookOutlinePosition[ 48143, 1492]*) (* CellTagsIndexPosition[ 47973, 1482]*) (*WindowFrame->Normal*) Notebook[{ Cell["\[Copyright] 2005 K. Sutner ", "SmallText"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Collatz Problem", FontFamily->"Charter"]], "Title", CellTags->"c:1"], Cell[CellGroupData[{ Cell["The Collatz Problem", "Section", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:14"], Cell[CellGroupData[{ Cell[" The Collatz Function", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:15"], Cell[TextData[{ "The following problem remains open, despite considerable efforts by a \ large number of people, and endless amounts of CPU time dedicated to it. In \ fact, someone suggested at some point that the problem was invented to \ disable all mathematics departments in the US. The question is annoyingly \ simple to state, which makes it so particularly attractive \[LongDash] \ somewhat like Fermat's last theorem, though that was recently solved. The \ problem also appears under different names, in particular the ", Cell[BoxData[ \(TraditionalForm\`3 x + 1\)]], " Problem, Kakutani's problem, Syracuse problem, Ulam's problem and \ Thwaites Conjecture. Pal Erd\[ODoubleAcute]s once commented that Mathematics \ is not ready for this type of problem. \n\nConsider the following function on \ the positive integers, named after Lothar Collatz, who studied similar \ functions in the 1930's.\n\n\t", Cell[BoxData[ \(TraditionalForm\`C(1)\ = \ 1\)]], "\n\t", Cell[BoxData[ \(TraditionalForm\`C(n)\ = \ n/2\)]], "\t\tif ", Cell[BoxData[ \(TraditionalForm\`n\)]], " is even,\n\t", Cell[BoxData[ \(TraditionalForm\`C(n)\ = \ \((3 n + 1)\)/2\)]], "\tif ", Cell[BoxData[ \(TraditionalForm\`n\)]], " is odd.\n\t\nThis is actually a variant of the traditional Collatz \ function, you will find slightly different definitions in the literature. \ By definition, this version of ", Cell[BoxData[ \(TraditionalForm\`C\)]], " has a fixed point at ", Cell[BoxData[ \(TraditionalForm\`1\)]], ", which makes it somewhat easier to deal with. The classical version has \ a 2-cycle ", Cell[BoxData[ \(TraditionalForm\`1 \[Rule] \ \(\(2\)\(\[Rule]\)\(\ \)\(1\)\(\ \ \)\)\)]], ". Here are the first few values of ", Cell[BoxData[ \(TraditionalForm\`C\)]], ":" }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(Map[\ C, \ Range[20]]\)], "Input", AspectRatioFixed->True], Cell[TextData[{ "It is more interesting to iterate ", Cell[BoxData[ \(TraditionalForm\`C\)]], " on a single number, say, 18. " }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(NestList[C, 18, 20]\)], "Input", AspectRatioFixed->True], Cell["\<\ As one can see, after a few steps we reach the fixed point 1. The \ same happens for all the following examples.\ \>", "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(FixedPointList[C, 18]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(FixedPointList[C, 100]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(FixedPointList[C, 1000]\)], "Input", AspectRatioFixed->True], Cell["\<\ Here is a somewhat larger starting value, correspondingly the orbit \ becomes a bit longer.\ \>", "Text"], Cell[BoxData[ \(FixedPointList[C, \(30!\)]\)], "Input", AspectRatioFixed->True], Cell[TextData[{ "You can try out many other starting values, you will always get back to ", Cell[BoxData[ \(TraditionalForm\`1\)]], " \[LongDash] as far as one knows. This assertion is known as the Collatz \ Conjecture:" }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[{ StyleBox["\nCollatz Conjecture", FontWeight->"Bold"], "\nFor any ", Cell[BoxData[ \(TraditionalForm\`n\ > \ 0\)]], ", the iteration of ", Cell[BoxData[ \(TraditionalForm\`C\)]], " on ", Cell[BoxData[ \(TraditionalForm\`n\)]], " ultimately leads to ", Cell[BoxData[ \(TraditionalForm\`1\)]], ".\n" }], "Text", Evaluatable->False, AspectRatioFixed->True, Background->RGBColor[1, 1, 0]], Cell[TextData[{ "So far, the conjecture has been verified computationally to about ", Cell[BoxData[ \(TraditionalForm\`2\^\(\(\ \)\(52\)\)\)]], ". Note that the conjecture is trivially false if we allow non-positive \ inputs, there are periodic orbits that do not end in ", Cell[BoxData[ \(TraditionalForm\`1\)]], ", or ", Cell[BoxData[ \(TraditionalForm\`\(-1\)\)]], " for that matter. The conjecture are is false if we modify the definition \ of the function to, say, ", Cell[BoxData[ \(TraditionalForm\`C(n)\ = \ \((3 n - 1)\)/2\)]], ". " }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(NestList[C, \(-5\), 10]\)], "Input", AspectRatioFixed->True], Cell[TextData[{ "We will indicate below how one can show that the conjecture is true for \ some classes of numbers (other than the obvious ", Cell[BoxData[ \(TraditionalForm\`2\^\(\(\ \)\(k\)\)\)]], ") and that indeed it is true almost everywhere. " }], "Text", Evaluatable->False, AspectRatioFixed->True] }, Closed]], Cell[CellGroupData[{ Cell["Orbits", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:16"], Cell[TextData[{ "We need to take a closer look at some of the properties of the Collatz \ function. To this end we define several functions that calculate the orbit of \ a given number and the number of steps till the fixed point 1 is reached.It \ is clear that the Collatz Conjecture holds if, and only if, for all ", Cell[BoxData[ \(TraditionalForm\`n\)]], " there is a ", Cell[BoxData[ \(TraditionalForm\`t\)]], " such that ", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(t\)\)\)(n)\ < \ n\)]], ". The least such ", Cell[BoxData[ \(TraditionalForm\`t\)]], " is the stopping time of ", Cell[BoxData[ \(TraditionalForm\`n\)]], ". By contrast, the number of steps needed to reach the fixed point is the \ total stopping time. To obtain slightly more information on can also count \ the down-steps ", Cell[BoxData[ \(TraditionalForm\`x\ \[RightTeeArrow] \ x/2\)]], " and the up-steps ", Cell[BoxData[ \(TraditionalForm\`x\ \[RightTeeArrow] \ \((3 x + 1)\)/2\)]], " separately. Of course, we tacitly assume that the conjecture is true \ here; otherwise, the functions below would never terminate on some inputs. \ For efficiency, the functions are memoized. \n\n\t", Cell[BoxData[ \(TraditionalForm\`C\)]], "\t\tthe Collatz function\n\t", StyleBox["orbit", "MR"], "\t\tcomputes the forward orbit\n\t", Cell[BoxData[ \(TraditionalForm\`\[Sigma]\_t\)]], "\t\tthe total stopping time (number of steps till fixed point 1 is \ reached)\n\t", Cell[BoxData[ \(TraditionalForm\`\[Sigma]\_u\)]], "\t\tup-count, the number of steps when the argument is odd\n\t", Cell[BoxData[ \(TraditionalForm\`\[Sigma]\_d\)]], "\t\tdonw-count, the number of steps when the argument is even.\n\t\nThus \ ", Cell[BoxData[ \(TraditionalForm\`\(\[Sigma]\_t\)( n)\ = \ \(\[Sigma]\_u\)(n)\ + \ \(\[Sigma]\_d\)(n)\)]], " is the total stopping time for the iteration on ", Cell[BoxData[ \(TraditionalForm\`n\)]], ". " }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell["\<\ Here are some examples, make sure to experiment with these \ functions.\ \>", "Text"], Cell[BoxData[ \(orbit[100]\)], "Input", AspectRatioFixed->True], Cell["\<\ Long orbits are best represented graphically. Here is a simple \ direct plot.\ \>", "Text"], Cell[BoxData[ \(orb\ = \ orbit[2\^11 - 1]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(\(ListPlot[\ orb, PlotStyle \[Rule] {Blue, PointSize[0.015]}, PlotRange \[Rule] All];\)\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(\(ListPlot[orbit[2^33 - 1], PlotStyle \[Rule] {Blue, PointSize[0.012]}, PlotRange \[Rule] All];\)\)], "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell["Stopping Times", "Subsubsection"], Cell["Stopping times associated with a specific input. ", "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(\(\(With[\ {n\ = \ 2^33 - 1}, \ \[IndentingNewLine]{\ \[Sigma][ n], \[Sigma][n, Full \[Rule] 1], \[Sigma][n, Full \[Rule] 2]}\ ]\)\(\ \ \)\)\)], "Input"], Cell["\<\ Thus it takes 123 steps before we reach a value smaller than the \ input and after 336 steps we reach 1. Using the up- and down-counts we can \ give a quick numerical estimate if the whole iteration is correct.\ \>", \ "Text"], Cell[BoxData[ \(With[\ {n\ = \ 2^33 - 1}, \ \[IndentingNewLine]Times @@ \((\ n\ {3/2, 1/2}^\[Sigma][n, Full \[Rule] 2])\)\ ]\ // \ N\)], "Input"], Cell[TextData[{ "Looks good, since we underestimate the up-steps to ", Cell[BoxData[ \(TraditionalForm\`x\ \[RightTeeArrow] \ 3 x/2\)]], ". Here are all the various stopping times for the first ", Cell[BoxData[ \(TraditionalForm\`2\^\(\(\ \)\(9\)\)\)]], " numbers." }], "Text"], Cell["\<\ ListPlot[\[Sigma][Range[512]],PlotStyle\[Rule]Blue];\ \>", "Input", AspectRatioFixed->True], Cell["\<\ Most stopping times seem fairly small \[LongDash] about the \ logarithm of the input. But note that some outliers are not rendered in the \ last picture. \ \>", "Text"], Cell["\<\ ListPlot[\[Sigma][Range[512]],PlotRange\[Rule]All,PlotStyle\[Rule]\ Blue];\ \>", "Input", AspectRatioFixed->True], Cell["\<\ The total stopping time shows some regularity, but it is not \ entirely clear how to pinpoint the structure that shows up in the picture. \ \ \>", "Text"], Cell[BoxData[ \(ListPlot[\[Sigma][Range[1023], Full \[Rule] 1], PlotRange \[Rule] All, PlotStyle \[Rule] Blue]; \)], "Input", AspectRatioFixed->True], Cell["\<\ Here are up-counts (red) and down-counts (blue) together. Their \ distribution is clearly similar and also similar to their sum, the total \ stopping time.\ \>", "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[{ \(\(cnt = \ \[Sigma][Range[1024], Full \[Rule] 2];\)\), "\n", \(\(ListPlot[\ First /@ cnt, PlotStyle \[Rule] {Red, PointSize[0.012]}, \[IndentingNewLine]PlotRange \[Rule] All, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(ListPlot[\ Last /@ cnt, PlotStyle \[Rule] {Blue, PointSize[0.012]}, \[IndentingNewLine]PlotRange \[Rule] All, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(DoShow[{%, %%}];\)\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Near Powers of 2", "Subsubsection"], Cell[TextData[{ "As far as individual orbits are concerned, it is interesting to consider \ the binary expansions of the numbers in the orbit. After all, the operations \ of ", Cell[BoxData[ \(TraditionalForm\`C\)]], " are easily described in terms of bit operations. Starting at points ", Cell[BoxData[ \(TraditionalForm\`x = 2\^\(\(\ \)\(k\)\) - 1\)]], ", these orbits look somewhat similar. " }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(\(binaryCollatz[2^8 - 1]\ // \ PlotMatrix;\)\)], "Input"], Cell[BoxData[ \(\(binaryCollatz[2^9 - 1]\ // \ PlotMatrix;\)\)], "Input"], Cell[BoxData[ \(\(binaryCollatz[2^10 - 1]\ // \ PlotMatrix;\)\)], "Input"], Cell[TextData[{ "It seems that for ", Cell[BoxData[ \(TraditionalForm\`x\ = \ 2\^\(\(\ \)\(k\)\) - 1\)]], " the orbit alway starts with a number of up-steps vaguely proportional to \ ", Cell[BoxData[ \(TraditionalForm\`k\)]], ". Somewhat surprisingly, there are exactly ", Cell[BoxData[ \(TraditionalForm\`k\)]], " up-steps before the first down-step. Moreover, ", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(k\)\)\)(\ 2\^\(\(\ \)\(k\)\) - 1)\ = \ 3\^\(\(\ \)\(k\)\) - \ 1\)]], ". Let's verify this computationally." }], "Text"], Cell[BoxData[ \(Table[{\ OrderedQ[\ orbit[k, 2^k - 1]], OrderedQ[\ orbit[k + 1, 2^k - 1]]}, {k, 2, 20}]\ // \ Union\)], "Input"], Cell[BoxData[ \(Table[\ Nest[C, 2^k - 1, k], \ {k, 2, 20}] + \ 1\ \ // \ FactorInteger\)], "Input"], Cell["Here is a close-up of the initial segment of up-steps only. ", "Text"], Cell[BoxData[ \(\(Take[\ binaryCollatz[2^30 - 1], 31]\ // \ PlotMatrix;\)\)], "Input"], Cell[TextData[{ "It is tempting to look at integers whose binary expansion has a special \ form such as ", Cell[BoxData[ \(TraditionalForm\`x = 2\^\(\(\ \)\(k\)\) - 1\)]], ". Note that the stopping times come in linearly increasing segments." }], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[ \(\(ListPlot[\ \ \[Sigma][2^Range[100] - 1], \ PlotStyle \[Rule] {Blue, PointSize[0.012]}];\)\)], "Input"], Cell["\<\ More precisely, there are segments where the up-count remains \ stationary, but the down-counts increase at a rate of one. If there are \ gaps, the down-counts resume in the proper place.\ \>", "Text"], Cell[BoxData[ \(\(With[\ {stop\ = \ \[Sigma][\ 2^Range[100] - 1, \ Full \[Rule] 2\ \ ]}, \ \[IndentingNewLine]gr1\ = \ ListPlot[\ First\ /@ \ stop, \ \[IndentingNewLine]\t PlotStyle \[Rule] {Blue, PointSize[0.01]}, DisplayFunction \[Rule] Identity]; \[IndentingNewLine]gr2\ = \ ListPlot[\ Last\ /@ \ stop, \ \[IndentingNewLine]\t PlotStyle \[Rule] {Red, PointSize[0.01]}, DisplayFunction \[Rule] Identity]; \[IndentingNewLine]DoShow[{gr1, gr2}]];\)\)], "Input"], Cell["Here is this memory effect in action:", "Text"], Cell[BoxData[ \(TableForm[\ \[Sigma][\ 2^Range[82, 94] - 1, \ Full \[Rule] 2\ \ ], TableHeadings \[Rule] {Range[82, 94], {"\", "\"}}]\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Powers of 3", "Subsubsection"], Cell["\<\ Some orbits starting at powers of 3. This time there is no trace \ of initial monotonicity. \ \>", "Text"], Cell[BoxData[{ \(\(Table[\ PlotMatrix[\ binaryCollatz[\ 3^k\ ], \ DisplayFunction \[Rule] Identity], \ {k, 2, 10, 2}];\)\), "\[IndentingNewLine]", \(\(ShowArray[%, 5];\)\)}], "Input"], Cell[BoxData[{ \(\(Table[\ PlotMatrix[\ binaryCollatz[\ 3^k\ ], \ DisplayFunction \[Rule] Identity], \ {k, 3, 11, 2}];\)\), "\[IndentingNewLine]", \(\(ShowArray[%, 5];\)\)}], "Input"], Cell["Some stopping times and total stopping times for power of 3.", "Text"], Cell[BoxData[ \(\(ListPlot[\ Table[\ \[Sigma][\ 3^k\ ], \ {k, 100}], \ PlotStyle \[Rule] {Blue, PointSize[0.015]}];\)\)], "Input"], Cell[BoxData[ \(\(ListPlot[\ Table[\ \[Sigma][\ 3^k\ , Full \[Rule] 1], \ {k, 100}], \ PlotStyle \[Rule] {Blue, PointSize[0.015]}];\)\)], "Input"], Cell["\<\ And the up- and down-counts. The opposite slopes \"explain\" the \ constant segments in the total stopping time plot. \ \>", "Text", Evaluatable->False, AspectRatioFixed->True], Cell[BoxData[{ \(\(cnt\ = \ \[Sigma][\ 3^Range[100], \ Full \[Rule] 2];\)\), "\[IndentingNewLine]", \(\(ListPlot[\ \ First\ /@ \ cnt, \ PlotStyle \[Rule] {Blue, PointSize[0.01]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(ListPlot[\ Last\ /@ \ cnt, \ PlotStyle \[Rule] {Red, PointSize[0.01]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(DoShow[{%, %%}];\)\)}], "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Profiling Orbits", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:17"], Cell[TextData[{ "We can classify orbits, or rather, initial segments thereof by the parity \ of the elements. Since the Collatz function depends only on the parity of \ the argument, this provides another way of distinguishing between up- and \ down-steps. Unfortunately, for this to work out properly one has to use the \ classical version of the function defined by\n\n\t", Cell[BoxData[ \(TraditionalForm\`D(n)\ = \ n/2\)]], "\t\tif ", Cell[BoxData[ \(TraditionalForm\`n\)]], " is even,\n\t", Cell[BoxData[ \(TraditionalForm\`D(n)\ = \ \((3 n + 1)\)/2\)]], "\tif ", Cell[BoxData[ \(TraditionalForm\`n\)]], " is odd.\n\t\nWe refer to the binary vector \n\t", Cell[BoxData[ \(TraditionalForm\`\(\[Pi]\_k\)( x)\ = \ \((\ x, \ D(x), \ \[Ellipsis], \ \(D\^\(\(\ \)\(k - 1\)\)\)( x)\ )\)\ \ mod\ 2\)]], "\nas the ", Cell[BoxData[ \(TraditionalForm\`k\)]], "-profile of ", Cell[BoxData[ \(TraditionalForm\`x\)]], ". Likewise, the profile is obtained by taking the whole orbit modulo 2. \ The trailing block 1, 0, 1, 0, \[Ellipsis] below indicates that the fixed \ point has been reached. " }], "Text"], Cell[BoxData[{ \(\[Pi][20, 10]\), "\[IndentingNewLine]", \(\[Pi][20, 20]\), "\[IndentingNewLine]", \(\[Pi][20, 17]\)}], "Input"], Cell[TextData[{ "The profile map has strong periodicity properties as can be seen from the \ next table. More precisely, ", Cell[BoxData[ \(TraditionalForm\`\(\[Pi]\_k\)( x\ + \ 2\^\(\(\ \)\(k\)\))\ = \ \(\[Pi]\_k\)(x)\ + \ 1\ \ \((mod\ 2)\)\)]], ". " }], "Text"], Cell[BoxData[ \(TableForm[\ \ Table[\[Pi][4, x], \ {x, 0, 15}], \ TableHeadings \[Rule] {Range[0, 15], Range[0, 3]}, \ TableSpacing \[Rule] {0, 1}]\)], "Input"], Cell[TextData[{ "The periodic blocks in each column are such that all profile vectors of \ length ", Cell[BoxData[ \(TraditionalForm\`4\)]], " appear already in first ", Cell[BoxData[ \(TraditionalForm\`2\^\(\(\ \)\(4\)\)\)]], " inputs." }], "Text"], Cell[BoxData[ \(\(Table[\ \ \[Pi][4, n], \ {n, 2^4}\ ]\ // \ Union\)\ // \ Length\)], "Input"], Cell[TextData[{ "One can show that this is no coincidence: every binary vector of lenght \ ", Cell[BoxData[ \(TraditionalForm\`k\)]], " appears as the profile vector of some number ", Cell[BoxData[ \(TraditionalForm\`x\ \[LessEqual] \ 2\^k\)]], ". Note that only the last ", Cell[BoxData[ \(TraditionalForm\`k\)]], " bits of ", Cell[BoxData[ \(TraditionalForm\`x\)]], " determine the first ", Cell[BoxData[ \(TraditionalForm\`k\)]], " bits of the profile vector. In fact, the following theorem holds.\n\n", StyleBox["Theorem", FontWeight->"Bold"], ": ", Cell[BoxData[ \(TraditionalForm\`x\ = \ y\ \((mod\ 2\^\(\(\ \)\(k\)\))\)\)]], " if, and only if, ", Cell[BoxData[ \(TraditionalForm\`\(\[Pi]\_\(\(\ \)\(k\)\)\)( x)\ = \ \(\[Pi]\_\(\(\ \)\(k\)\)\)(y)\)]], ". \n\nThe proof is by induction on ", Cell[BoxData[ \(TraditionalForm\`k\)]], " \n\nWe verify this result computationally by determining the equivalence \ classes induced by profile vectors of lenth 5 on numbers up to 500. It turns \ out that the same classes are obtained by taking remainders modulo ", Cell[BoxData[ \(TraditionalForm\`2\^5\)]], ". " }], "Text"], Cell[BoxData[{ \(\(class\ = \ ToClasses[\ Range[0, 500], \ \[Pi][5, #] &, \ Type \[Rule] Function\ ];\)\), "\n", \(Union /@ \ Mod[class, 32]\)}], "Input"], Cell[TextData[{ "The profile function ", Cell[BoxData[ \(TraditionalForm\`\[Pi]\_k\)]], " induces a permutation of ", Cell[BoxData[ \(TraditionalForm\`\[DoubleStruckCapitalZ]\_\(2\^\(\(\ \)\(k\)\)\)\)]], " if we identify numbers ", Cell[BoxData[ \(TraditionalForm\`0\ \[LessEqual] \ x\ < \ 2\^\(\(\ \)\(k\)\)\)]], " with there ", Cell[BoxData[ \(TraditionalForm\`k\)]], "-bit binary expansion. Here is the permution of ", Cell[BoxData[ \(TraditionalForm\`\([1024]\)\)]], " induced by profile vectors of length 10. " }], "Text"], Cell[BoxData[{ \(\(perm\ = \ \(FromDigits[Reverse[#], 2] &\)\ /@ \ \ \ \((\ \(\[Pi][10, #] &\) /@ \ Range[0, 1023])\);\)\), "\[IndentingNewLine]", \(\(perm\ // \ Union\)\ // \ Length\), "\[IndentingNewLine]", \(\(ListPlot[\ perm, PlotStyle \[Rule] {Blue, PointSize[0.015]}, AspectRatio \[Rule] 1];\)\)}], "Input"], Cell["\<\ The order and the cycle lengths of this permutation \[LongDash] for \ whatever it's worth. \ \>", "Text"], Cell[BoxData[{ \(OrderT[T @@ \((perm + 1)\)]\), "\n", \(Length\ /@ \ CycleDecompositionT[T @@ \((perm + 1)\)]\)}], "Input"], Cell[TextData[{ "As we have already verified above, for inputs of the form ", Cell[BoxData[ \(TraditionalForm\`x\ = \ 2\^\(\(\ \)\(k\)\) - 1\)]], " the initial segments of the profile vectors consists of exactly ", Cell[BoxData[ \(TraditionalForm\`k\)]], " many 1's." }], "Text"], Cell[BoxData[ \(\[Pi][31, 2^30 - 1]\)], "Input"], Cell[TextData[{ "Every binary vector appears as the profile of some input and, in fact, of \ infinitely many inputs. One might wonder how the initial segment of an orbit \ with a given profile depends on the starting point. We would like a \ reasonably simple description of the function ", Cell[BoxData[ \(TraditionalForm\`\(\(\ \)\(\(C\^p\)(x)\)\)\)]], " that determines the ", Cell[BoxData[ \(TraditionalForm\`k\)]], "th element in the orbit of ", Cell[BoxData[ \(TraditionalForm\`x\)]], ", assuming the profile of said orbit is ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". So\n\n\t", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(\[Epsilon]\)\)\)(x)\ = \ x\)]], ", \n\t", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(p0\)\)\)(x)\ = \ \(\(C\^p\)(x)\)/ 2\)]], ",\n\t", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(p1\)\)\)( x)\ = \ \((3 \(\( C\^p\)(x)\) + 1)\)/2\)]], ". \n\t\nHere is an implementation of this operation. " }], "Text"], Cell[BoxData[{ \(Clear[CC]\), "\[IndentingNewLine]", \(\(CC[{}, x_]\ := \ x;\)\), "\[IndentingNewLine]", \(\(CC[{p___, 0}, x_]\ := \ CC[{p}, x]/2;\)\), "\[IndentingNewLine]", \(\(CC[{p___, 1}, x_]\ := \ \((3 CC[{p}, x] + 1)\)/2;\)\)}], "Input"], Cell["And some examples.", "Text"], Cell[BoxData[{ \(CC[{0, 0, 0, 0, 1}, X]\), "\[IndentingNewLine]", \(%\ // \ Expand\)}], "Input"], Cell[BoxData[{ \(CC[{1, 0, 0, 0, 0}, X]\), "\[IndentingNewLine]", \(%\ // \ Expand\)}], "Input"], Cell[BoxData[{ \(CC[{1, 0, 1, 0, 1}, X]\), "\[IndentingNewLine]", \(%\ // \ Expand\)}], "Input"], Cell[BoxData[{ \(CC[{1, 1, 1, 1, 1}, X]\), "\[IndentingNewLine]", \(%\ // \ Expand\)}], "Input"], Cell[TextData[{ "The examples suggest that it is best to split this function into two parts \ so that \n\n\t", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(p\)\)\)( x)\ = \ \(\[Lambda](p)\)\ x\ + \ \[Rho](p)\)]], ". \n\nWriting ", Cell[BoxData[ \(TraditionalForm\`\(\(\[LeftDoubleBracket]\)\(v\)\(\ \[RightDoubleBracket]\)\)\)]], " for the number of 1's in a binary vector ", Cell[BoxData[ \(TraditionalForm\`v\)]], " and ", Cell[BoxData[ \(TraditionalForm\`v : i\ = \ \((v\_\(i + 1\), v\_\(i + 2\), \[Ellipsis], v\_\(k - 1\))\)\)]], " for the suffix of ", Cell[BoxData[ \(TraditionalForm\`v\)]], " obtained by trunkating the first ", Cell[BoxData[ \(TraditionalForm\`i + 1\)]], " elements one has \n\n\t", Cell[BoxData[ \(TraditionalForm\`\[Lambda](p)\ = \ 3\^\(\(\[LeftDoubleBracket]\)\(p\)\(\[RightDoubleBracket]\)\)\/2\^k\)]\ ], "\n\t\n\t", Cell[BoxData[ \(TraditionalForm\`\[Rho]( p)\ = \ \[Sum]\_\(i < k\)\ \ \(p\_i\) 3\^\(\(\[LeftDoubleBracket]\)\(p : i\)\(\[RightDoubleBracket]\)\)\ \/2\^\(k - i\)\)]], "\n\t\nHere ", Cell[BoxData[ \(TraditionalForm\`k\)]], " as always denotes the length of ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". The functions \[Lambda] and \[Rho] below return their results in held \ form so one can see the structure of the algebraic expression. Here are some \ examples." }], "Text"], Cell[BoxData[{ \(Clear[X]\), "\[IndentingNewLine]", \(With[\ {\ p\ = \ {0, 0, 0, 0, 0, 0, 0, 1}}, \[Lambda][p]\ X\ + \ \[Rho][ p]]\), "\[IndentingNewLine]", \(%\ // \ ReleaseHold\)}], "Input"], Cell[BoxData[{ \(With[\ {\ p\ = \ {1, 0, 0, 0, 0, 0, 0, 0}}, \[Lambda][p]\ X\ + \ \[Rho][ p]]\), "\[IndentingNewLine]", \(%\ // \ ReleaseHold\)}], "Input"], Cell[BoxData[{ \(With[\ {\ p\ = \ {1, 0, 0, 1, 0, 0, 0, 1}}, \[Lambda][p]\ X\ + \ \[Rho][ p]]\), "\[IndentingNewLine]", \(%\ // \ ReleaseHold\)}], "Input"], Cell["A minor test that the functions work as claimed.", "Text"], Cell[BoxData[ \(\(\(With[\ {x\ = \ Random[\ Integer, {1, 10^6}]}, \[IndentingNewLine]\t{\ Nest[C, x, 20], \[Lambda][\ 20, \ x\ ]\ x\ + \ \[Rho][\ 20, \ x\ ]}]\[IndentingNewLine] Equal @@ ReleaseHold[%]\)\(\ \)\)\)], "Input"], Cell[TextData[{ "We can even imitate the proof of the key identity. We pick a profile and \ apply the RHS of the identity to some unspecified number ", Cell[BoxData[ \(TraditionalForm\`x\)]], ", obtaining an expression ", Cell[BoxData[ \(TraditionalForm\`y\)]], ". " }], "Text"], Cell[BoxData[{ \(A\ = \ Array[\ a\_# &, \ {6}]\), "\[IndentingNewLine]", \(y\ = \ \[Lambda][A] X\ + \ \[Rho][\ A]\)}], "Input"], Cell[TextData[{ "If ", Cell[BoxData[ \(TraditionalForm\`x\)]], " is even the next bit in the profile would be a 0. Using the new profile, \ we get a new RHS which promptly simplifies to ", Cell[BoxData[ \(TraditionalForm\`y/2\)]], ". The situation is analogous when the next bit is a 1. " }], "Text"], Cell[BoxData[{ \(\[Lambda][\ Append[A, 0]]\ X\ + \ \[Rho][\ Append[A, 0]]\), "\n", \(\(%\ == \ y/2\ // \ ReleaseHold\)\ // \ Simplify\), "\n", \(\[Lambda][\ Append[A, 1]]\ X\ + \ \[Rho][\ Append[A, 1]]\), "\n", \(\(%\ == \ \((3\ y\ + \ 1)\)/2\ // \ ReleaseHold\)\ // \ Simplify\)}], "Input"], Cell[TextData[{ "We can solve a modular equation to obtain a witness ", Cell[BoxData[ \(TraditionalForm\`x\)]], " for a given profile ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". Here is an example." }], "Text"], Cell[BoxData[{ \(\[Lambda][{1, 0, 0, 1, 1, 0, 1, 1}]\ X\ + \ \[Rho][{1, 0, 0, 1, 1, 0, 1, 1}]\), "\[IndentingNewLine]", \(eq\ = \ %\ // \ ReleaseHold\)}], "Input"], Cell[BoxData[{ \(sol\ = \ Solve[\ {256\ eq\ \[Equal] \ 0, \ Modulus \[Equal] 256}, X, \ Mode \[Rule] \ Modular\ ]\), "\[IndentingNewLine]", \(\[Pi][8, First[\ X /. sol]]\)}], "Input"], Cell[TextData[{ "It is straightforward to automate this computation. Hence we can compute \ a witness ", Cell[BoxData[ \(TraditionalForm\`x\_p\)]], " for each profile vector ", Cell[BoxData[ \(TraditionalForm\`p\)]], " such that the profile of ", Cell[BoxData[ \(TraditionalForm\`x\_p\)]], " starts with ", Cell[BoxData[ \(TraditionalForm\`p\)]], " and ", Cell[BoxData[ \(TraditionalForm\`x\_p\)]], " is minimal such. Thus ", Cell[BoxData[ \(TraditionalForm\`0\ \[LessEqual] \ x\_p\ < \ 2\^\(\(\ \)\(k\)\)\)]], " where ", Cell[BoxData[ \(TraditionalForm\`k\)]], " is the length of ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". " }], "Text"], Cell[BoxData[ \(\(witness[ A_List]\ := \ \[IndentingNewLine]With[\ {kk\ = \ 2^Length[A]}, X\ /. \ Solve[{\ kk\ ReleaseHold[\[Lambda][A]\ X\ + \ \[Rho][A]] \[Equal] \ 0, \ Modulus \[Equal] kk}, X, \ Mode \[Rule] \ Modular\ ]\ \ // \ First\ ];\)\)], "Input"], Cell[" Some modest testing.", "Text"], Cell[BoxData[{ \(witness[\ {1, 0, 0, 1, 1, 0}]\), "\[IndentingNewLine]", \(\[Pi][6, %]\)}], "Input"], Cell[BoxData[{ \(\(witness\ /@ \ Tuples[{0, 1}, 6];\)\), "\[IndentingNewLine]", \(\(ListPlot[\ %, PlotStyle \[Rule] {Blue, PointSize[0.02]}, AspectRatio \[Rule] 1];\)\), "\[IndentingNewLine]", \(\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Terras' Theorem", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:17"], Cell[TextData[{ "As already pointed out, the Collatz Conjecture holds if, and only if, for \ all ", Cell[BoxData[ \(TraditionalForm\`n\)]], " there is a ", Cell[BoxData[ \(TraditionalForm\`t\)]], " such that ", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(t\)\)\)(n)\ < \ n\)]], ", i.e., if every number has a finite stopping time. The most interesting \ theorem proven at this point is due to R. Terras.\n\n", StyleBox["Theorem", FontWeight->"Bold"], ": The set ", Cell[BoxData[ \(TraditionalForm\`S\_\(\(\ \)\(k, \ n\)\)\ = \ {\ x\ \[LessEqual] \ n\ | \ \ \[Sigma](x)\ \[LessEqual] \ k\ }\)]], " has asymptotic density 1 in the limit.\n\nMore precisely, writing ", Cell[BoxData[ \(TraditionalForm\`D\_\(k, n\) = \ \(\(|\)\(\ \)\(S\_\(k, n\)\)\(|\)\(\(/\)\(n\)\)\)\)]], " for the density up to ", Cell[BoxData[ \(TraditionalForm\`n\)]], " the limit ", Cell[BoxData[ \(TraditionalForm\`D\_k = lim\_\(n \[Rule] \[Infinity]\)D\_\(k, n\)\)]], " exists for all ", Cell[BoxData[ \(TraditionalForm\`k\)]], " and ", Cell[BoxData[ \(TraditionalForm\`D\_k = \ 1\)]], ". So, for most inputs the Collatz conjecture is true. \n\nHere is a \ sketch of the proof. \n\nRecall from above that ", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(k\)\)\)( x)\ = \ \(\(\[Lambda]\_k\)(x)\)\ x\ + \ \[Rho](x)\)]], ". Hence ", Cell[BoxData[ \(TraditionalForm\`\(C\^\(\(\ \)\(k\)\)\)(x)\ < x\)]], " certainly requires ", Cell[BoxData[ \(TraditionalForm\`\(\[Lambda]\_k\)(x)\ < \ 1\)]], ". Define the coefficient stopping time ", Cell[BoxData[ \(TraditionalForm\`\[Omega](x)\)]], " to be the least such ", Cell[BoxData[ \(TraditionalForm\`k\)]], " (or ", Cell[BoxData[ \(TraditionalForm\`\[Infinity]\)]], " if there is none), so by necessity ", Cell[BoxData[ \(TraditionalForm\`\[Omega](x)\ \[LessEqual] \ \[Sigma]( x)\ \[LessEqual] \ \(\[Sigma]\_\(\(t\)\(\ \)\)\)(x)\)]], ". Given a profile vector ", Cell[BoxData[ \(TraditionalForm\`p\)]], " of length ", Cell[BoxData[ \(TraditionalForm\`\(\(k\)\(\ \)\)\)]], "let ", Cell[BoxData[ \(TraditionalForm\`T\_p\ = \ \({\ x\ | \ \(\[Pi]\_k\)(x)\ = \ p\ }\ = \ x\_p + \ \(2\^\(\(\ \)\(k\)\)\) \[DoubleStruckCapitalN]\)\)]], " be the set of all inputs whose profiles start with ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". \n\nReturning to the notion of coefficent stopping time, call a profile \ ", Cell[BoxData[ \(TraditionalForm\`p\)]], " of length ", Cell[BoxData[ \(TraditionalForm\`k\)]], " critical if ", Cell[BoxData[ FormBox[ RowBox[{\(\(\(\[LeftDoubleBracket]\)\(p\)\(\[RightDoubleBracket]\)\)\ \ ln\ 3\), " ", "<", " ", RowBox[{"k", " ", "ln", " ", "2", Cell[""]}]}], TraditionalForm]]], " but this relation holds for no proper prefix of ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". Here ", Cell[BoxData[ \(TraditionalForm\`\(\(\[LeftDoubleBracket]\)\(p\)\(\ \[RightDoubleBracket]\)\)\)]], " denotes the number of 1's in ", Cell[BoxData[ \(TraditionalForm\`p\)]], ". Note that by definition, for any critical vector we must have ", Cell[BoxData[ \(TraditionalForm\`\(\(\[LeftDoubleBracket]\)\(p\)\(\ \[RightDoubleBracket]\)\)\ = \ \[LeftFloor]k\ r\ \[RightFloor]\)]], " where ", Cell[BoxData[ \(TraditionalForm\`r\ = \ ln\ 2/ln\ 3\ \[TildeTilde] \ 0.6309\)]], ". Then the integers with coefficient stopping time ", Cell[BoxData[ \(TraditionalForm\`k\)]], " are precisely ", Cell[BoxData[ \(TraditionalForm\`T\_p\)]], " where ", Cell[BoxData[ \(TraditionalForm\`p\)]], " is any critical profile vector of length ", Cell[BoxData[ \(TraditionalForm\`k\)]], ". Moreover, except for finitely many, these numbers also have stopping \ time ", Cell[BoxData[ \(TraditionalForm\`k\)]], ". On the other hand, if ", Cell[BoxData[ \(TraditionalForm\`p\)]], " fails to be critical, only finitely many numbers in ", Cell[BoxData[ \(TraditionalForm\`T\_p\)]], " will have stopping time ", Cell[BoxData[ \(TraditionalForm\`k\)]], ". \n\nSince the set of inputs with stopping time ", Cell[BoxData[ \(TraditionalForm\`k\)]], " is therefore a union of arithmetic progression it must have limiting \ density. To show that this density is in fact equal to 1 requires a bit more \ effort. \n\n" }], "Text", Evaluatable->False, AspectRatioFixed->True] }, Closed]], Cell[CellGroupData[{ Cell["Some Explicit Stopping Times", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:17"], Cell[TextData[{ "For some restricted values of ", Cell[BoxData[ \(TraditionalForm\`x\)]], " one can one can compute the (total) stopping times directly. Here is an \ example of a 3-parameter class of such inputs:\n\t", Cell[BoxData[ \(TraditionalForm\`\(\(\ \)\(x(n, m, t)\ = \ \ \(\(\((2\/3)\)\^\(\(\ \)\(t\)\)\ \((\ 2\^\(\(\ \)\(n\ 3\^\(\(\ \)\(m\)\)\)\) + 1)\)\)\(-\)\(1\)\(\ \)\)\)\)\)]], "\nsubject to the constraints \n\t", Cell[BoxData[ \(TraditionalForm\`0\ \[LessEqual] t\ \[LessEqual] \ m + 1\)]], " and ", Cell[BoxData[ \(TraditionalForm\`n\ = \ 1, 5\ \((mod\ 6)\)\)]], ".\nSome examples." }], "Text"], Cell[BoxData[{ \(Clear[xx, st]\), "\n", \(\(xx[n_, m_, t_]\ := \ \((2/3)\)^t \((2^\((n\ 3^m)\) + 1)\)\ - \ 1\ \ \ \ \ /; \ \ 0\ \[LessEqual] \ t\ \[LessEqual] \ m + 1\ && \ MemberQ[{1, 5}, Mod[n, 6]];\)\), "\n", \(\(st[n_, m_, t_]\ := \ \((n\ 3^m)\) + \ t;\)\)}], "Input"], Cell[TextData[{ "The stopping times and the total stopping times are very simple for these \ inputs. The boundary case ", Cell[BoxData[ \(TraditionalForm\`n = \(t = 1\)\)]], ", ", Cell[BoxData[ \(TraditionalForm\`m = 0\)]], " produces ", Cell[BoxData[ \(TraditionalForm\`x(1, 0, 1) = \ 1\)]], " and should be excluded from the discussion. " }], "Text"], Cell[BoxData[{ \(Table[\ \ \ \[Sigma][xx[1, m, t]], \ {m, 0, 7}, {t, 0, m + 1}]\ // \ TableForm\), "\[IndentingNewLine]", \(Table[\ \ \ \[Sigma][xx[1, m, t], Full \[Rule] 1], \ {m, 0, 6}, {t, 0, m + 1}]\ // \ TableForm\)}], "Input"], Cell[BoxData[ \(Table[\ \ \ \[Sigma][xx[5, m, t], Full \[Rule] 1], \ {m, 0, 6}, {t, 0, m + 1}]\ // \ TableForm\)], "Input"], Cell[BoxData[ \(Table[\ \ \ \[Sigma][xx[7, m, t], Full \[Rule] 1], \ {m, 0, 6}, {t, 0, m + 1}]\ // \ TableForm\)], "Input"], Cell[TextData[{ "This suggests that on inputs ", Cell[BoxData[ \(TraditionalForm\`x\ = \ \(x(n, m, t)\ = \ \ \((2\/3)\)\^\(\(\ \)\(t\)\)\ \((\ 2\^\(\(\ \)\(n\ 3\^\(\(\ \)\(m\)\)\)\) + 1)\) - 1\)\)]], " the total stopping time is\n\t ", Cell[BoxData[ \(TraditionalForm\`\[Sigma](x)\ = \ n\ 3\^m\ + \ t\)]], " \nexcept for the boundary case ", Cell[BoxData[ \(TraditionalForm\`n = \(t = 1\)\)]], ", ", Cell[BoxData[ \(TraditionalForm\`m = 0\)]], ". Here is an example that shows that this claim is not as bizarre as it \ may seem. After a few up-steps a power of 2 is reached from which point on \ the orbit is trivial. " }], "Text"], Cell[BoxData[ \(\[Pi][\ xx[1, 4, 5]]\)], "Input"], Cell[BoxData[ \(\(binaryCollatz[\ xx[1, 4, 5]\ ]\ // \ PlotMatrix;\)\)], "Input"], Cell[TextData[{ "The ", Cell[BoxData[ \(TraditionalForm\`t\)]], " parameter controls the length of the transitional period." }], "Text"], Cell[BoxData[{ \(\(Table[\ PlotMatrix[\ binaryCollatz[\ xx[1, 3, t]\ ], \ DisplayFunction \[Rule] Identity], \ {t, 0, 3}];\)\), "\[IndentingNewLine]", \(\(ShowArray[%];\)\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Going Backwards", "Subsection", Evaluatable->False, AspectRatioFixed->True, CellTags->"c:17"], Cell[TextData[{ "The functional digraph of the Collatz function is locally very simple: the \ predecessors of a node ", Cell[BoxData[ \(TraditionalForm\`x\)]], " are determined as follows: \n\n\t\t", Cell[BoxData[ \(TraditionalForm\`2 x\)]], "\t\t\tif ", Cell[BoxData[ \(TraditionalForm\`x\ \[NotEqual] \ 2\ \((mod\ 3)\)\)]], "\n\t\t", Cell[BoxData[ \(TraditionalForm\`2 x\)]], ", ", Cell[BoxData[ \(TraditionalForm\`\((2 x - 1)\)/3\)]], " \t\tif ", Cell[BoxData[ \(TraditionalForm\`x\ = \ 2\ \((mod\ 3)\)\)]], "\n\t\t\n(except for node 1 which has indegree 2). Think of the graph as \ a tree rooted at 1. Since ", Cell[BoxData[ \(TraditionalForm\`x\ = \ 0\ \((mod\ 3)\)\)]], " implies ", Cell[BoxData[ \(TraditionalForm\`2\^\(\(\ \)\(k\)\)\ x\ = \ 0\ \((mod\ 3)\)\)]], " for all ", Cell[BoxData[ \(TraditionalForm\`k\)]], " the subtree at ", Cell[BoxData[ \(TraditionalForm\`x\)]], " is a single branch which one may as well truncate. Since ", Cell[BoxData[ \(TraditionalForm\`2\ = \ \(-1\)\ \((mod\ 3)\)\)]], " for any ", Cell[BoxData[ \(TraditionalForm\`x\ \[NotEqual] \ 0\ \((mod\ 3)\)\)]], " the subtree rooted ", Cell[BoxData[ \(TraditionalForm\`x\)]], " has an infinite branch ", Cell[BoxData[ \(TraditionalForm\`\((\(2\^\(\(\ \)\(k\)\)\) x)\)\_\(\(\ \)\(k\)\)\)]], " where indegree 1 and indegree 2 nodes alternate. \n\nThe following \ function traces back only one branch and prefers the ", Cell[BoxData[ \(TraditionalForm\`\((2 x - 1)\)/3\)]], " step over ", Cell[BoxData[ \(TraditionalForm\`2 x\)]], ". It truncates when a node ", Cell[BoxData[ \(TraditionalForm\`0\ \((mod\ 3)\)\)]], " is reached. Note that the function induces a loop at ", Cell[BoxData[ \(TraditionalForm\`1\ \[Rule] \(2\ \[Rule] \ 1\)\)]], ". " }], "Text"], Cell[BoxData[{ \(Clear[back]\), "\[IndentingNewLine]", \(\(back[x_Integer]\ := \ \[IndentingNewLine]Switch[\ Mod[x, 3], \[IndentingNewLine]\t0, \ x, \ \[IndentingNewLine]\t1, \ 2 x, \[IndentingNewLine]\t 2, \((2 x - 1)\)/3\[IndentingNewLine]];\)\)}], "Input"], Cell["The function seems to reach a fixed point.", "Text"], Cell[BoxData[ \(bk\ = \ Table[\ FixedPoint[\ back, \ x\ ], \ {x, 3, 200}]\)], "Input"], Cell[BoxData[ \(\(ListPlot[\ bk, PlotStyle \[Rule] {Blue, PointSize[0.012]}, PlotRange \[Rule] All];\)\)], "Input"], Cell["\<\ Here are the number of steps required for the backtracking function \ to reach a fixed point when the inputs are powers of 2.\ \>", "Text"], Cell[BoxData[{ \(\(bk\ = \ \(Length@FixedPointList[\ back, #] &\)\ /@ \ \((2^ Range[2, 1000])\);\)\), "\[IndentingNewLine]", \(\(ListPlot[\ bk, PlotStyle \[Rule] {Blue, PointSize[0.01]}, PlotRange \[Rule] All];\)\)}], "Input"], Cell[BoxData[ \(bk\ // \ Union\)], "Input"], Cell[BoxData[ \(Position[bk, 26]\)], "Input"], Cell[BoxData[{ \(\(L\ \ = \ IntegerDigits[NestList[\ back, \ \ 2^366\ , \ 40\ ], 2]\ // \ Rest;\)\), "\[IndentingNewLine]", \(\(\(L\ // \ padLeft\)\ // \ PlotMatrix;\)\)}], "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Code", "Section"], Cell[BoxData[ \(\(\(\(binaryCollatz[\ L_List\ ]\ := \ binaryCollatz[FromDigits[L, 2]];\)\ \n \(\(binaryCollatz[\ n_Integer\ ]\ := \ \[IndentingNewLine]Module[\ {orb\ = \ IntegerDigits[orbit[n], 2], \ k}, \[IndentingNewLine]\t k\ = \ Max[ Length /@ orb]; \[IndentingNewLine]\t\(PadLeft[#, k] &\)\ /@ \ orb\[IndentingNewLine]];\)\(\n\) \)\[IndentingNewLine] Clear[padLeft]\n \(\(padLeft[ L_List]\ := \ \[IndentingNewLine]With[\ {n\ = \ Max[Length /@ L]}, \ \(PadLeft[#, n] &\)\ /@ \ Most[L]\ ];\)\(\n\) \)\n Clear[periodicQ]\n \(\(periodicQ[ L_List]\ := \ \[IndentingNewLine]Module[\ {n, nn = Quotient[Length[L], 3]}, \[IndentingNewLine]\t Catch[\ \[IndentingNewLine]\t\t\tScan[\ If[Length[Union[Partition[L, #]]] \[Equal] 1, Throw[True]] &, \ Range[nn]]; \[IndentingNewLine]\t\t\tThrow[ False]\ ]\[IndentingNewLine]];\)\(\n\) \)\n Clear[back]\n \(back[n_Integer]\ := \ back[IntegerDigits[n, 2]];\)\n \(\(back[ L_List]\ := \ \[IndentingNewLine]Module[{y = FromDigits[L, 2]}, \[IndentingNewLine]Switch[\ Mod[y, 3], \[IndentingNewLine]\t0, \ L, \ \[IndentingNewLine]\t 1, \ Append[L, 0], \[IndentingNewLine]\t2, IntegerDigits[\((2 y - 1)\)/3, 2]\[IndentingNewLine]]\[IndentingNewLine]];\)\(\n\) \)\n \(Unprotect[C];\)\n Clear[C, orbit]\n \(Attributes[C] = {Listable};\)\n \(C[1] = 1;\)\n \(C[n_Integer] := \((C[n]\ = \ n/2)\) /; EvenQ[n];\)\n \(C[n_Integer] := \ \((C[n]\ = \ \((3\ n + 1)\)/2)\);\)\ \n (*\ \ \(C[ n_Integer] := \ \((C[n]\ = \ 3\ n + 1)\);\)\ *) \n \(Attributes[orbit] = {Listable};\)\n \(orbit[n_Integer] := \(orbit[n]\ = \ Most[FixedPointList[C, n]]\);\)\n \(\(orbit[k_Integer, n_Integer] := NestList[C, n, k];\)\(\n\) \)\n Clear[\[Sigma]]\n \(Attributes[\[Sigma]] = {Listable};\)\n \(Options[\[Sigma]] = {Full \[Rule] 0};\)\n \(\[Sigma][1]\ = \ 0;\)\n \(\(\[Sigma][n_Integer, opts___?OptionQ] := \[IndentingNewLine]Module[{orb}, \ \[IndentingNewLine]Switch[\ \((\(Full\ /. \ {opts}\)\ /. \ Options[\[Sigma]])\), \[IndentingNewLine]\t 0, \ \ \ Length@ NestWhileList[\ C, \ n, \ # \[GreaterEqual] \ n &\ ] - 1, \[IndentingNewLine]\t 1, \ \ Length[orbit[n]] - 1, \[IndentingNewLine]\t2, \ orb\ = \ orbit[n]; \[IndentingNewLine]\t With[\ {up = \ Length[Select[Partition[orb, 2, 1], OrderedQ]]}, \[IndentingNewLine]\t\t{Length[orb] - up - 1, up}\ ]\[IndentingNewLine]\t]\[IndentingNewLine]];\)\(\n\ \) \)\n \(Unprotect[\[Pi]];\)\n Clear[Cclassic, \[Pi]]\n \(Attributes[Cclassic] = {Listable};\)\n \(Cclassic[n_Integer] := \((Cclassic[n]\ = \ n/2)\) /; EvenQ[n];\)\n \(Cclassic[ n_Integer] := \ \((Cclassic[n]\ = \ \((3\ n + 1)\)/2)\);\)\ \n \(\[Pi][k_Integer, n_Integer]\ := \ \ Mod[\ \ NestList[Cclassic, n, k - 1\ ], \ 2\ ];\)\n \(\(\[Pi][ n_Integer]\ := \ \ Mod[\ \ NestList[Cclassic, n, \[Sigma][n, Full \[Rule] 1]\ ], \ 2\ ];\)\(\n\) \)\[IndentingNewLine] Clear[\[Rho], \[Lambda]]\n \(\[Rho][k_Integer, n_Integer]\ := \ \[Rho][\ \[Pi][k, n]];\)\n \(\[Lambda][k_Integer, n_Integer]\ := \ \[Lambda][\ \[Pi][k, n]];\)\ \n \(\[Rho][ pv_List]\ := \ \ \[IndentingNewLine]With[{k\ = \ Length[pv]}, \[IndentingNewLine]\t Table[\ \ HoldForm[2]^\((i - k)\)\ HoldForm[3]^ Total[\ Drop[pv, i + 1]], \ {i, 0, k - 1}\ ]\ . \ pv\[IndentingNewLine]];\)\n \(\[Lambda][pv_List]\ := \ With[{k\ = \ Length[pv]}, HoldForm[2]^\((\(-k\))\) HoldForm[3]^Total[\ pv]\ ];\)\)\(\ \)\)\)], "Input", InitializationCell->True] }, Closed]] }, Open ]] }, FrontEndVersion->"5.1 for X", ScreenRectangle->{{0, 1280}, {0, 1024}}, AutoGeneratedPackage->None, ScreenStyleEnvironment->"Working", ShowPageBreaks->False, WindowToolbars->{}, WindowSize->{1016, 996}, WindowMargins->{{Automatic, 1}, {Automatic, 0}}, PrintingStartingPageNumber->285, PrivateNotebookOptions->{"ColorPalette"->{RGBColor, 256}}, ShowCellLabel->True, ShowCellTags->False, RenderingOptions->{"ObjectDithering"->True, "RasterDithering"->False}, CharacterEncoding->Automatic, Magnification->1.5, StyleDefinitions -> "Classic.nb" ] (******************************************************************* Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. *******************************************************************) (*CellTagsOutline CellTagsIndex->{ "c:1"->{ Cell[1828, 55, 96, 2, 125, "Title", CellTags->"c:1"]}, "c:14"->{ Cell[1949, 61, 106, 3, 88, "Section", Evaluatable->False, CellTags->"c:14"]}, "c:15"->{ Cell[2080, 68, 111, 3, 42, "Subsection", Evaluatable->False, CellTags->"c:15"]}, "c:16"->{ Cell[6981, 236, 96, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:16"]}, "c:17"->{ Cell[17525, 563, 106, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[30364, 965, 105, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[35207, 1112, 118, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[38582, 1216, 105, 3, 42, "Subsection", Evaluatable->False, CellTags->"c:17"]} } *) (*CellTagsIndex CellTagsIndex->{ {"c:1", 47152, 1450}, {"c:14", 47229, 1453}, {"c:15", 47335, 1457}, {"c:16", 47444, 1461}, {"c:17", 47553, 1465} } *) (*NotebookFileOutline Notebook[{ Cell[1754, 51, 49, 0, 44, "SmallText"], Cell[CellGroupData[{ Cell[1828, 55, 96, 2, 125, "Title", CellTags->"c:1"], Cell[CellGroupData[{ Cell[1949, 61, 106, 3, 88, "Section", Evaluatable->False, CellTags->"c:14"], Cell[CellGroupData[{ Cell[2080, 68, 111, 3, 42, "Subsection", Evaluatable->False, CellTags->"c:15"], Cell[2194, 73, 1924, 48, 468, "Text", Evaluatable->False], Cell[4121, 123, 80, 2, 73, "Input"], Cell[4204, 127, 198, 7, 43, "Text", Evaluatable->False], Cell[4405, 136, 78, 2, 73, "Input"], Cell[4486, 140, 185, 5, 43, "Text", Evaluatable->False], Cell[4674, 147, 80, 2, 73, "Input"], Cell[4757, 151, 81, 2, 73, "Input"], Cell[4841, 155, 82, 2, 73, "Input"], Cell[4926, 159, 115, 3, 43, "Text"], Cell[5044, 164, 85, 2, 73, "Input"], Cell[5132, 168, 293, 8, 68, "Text", Evaluatable->False], Cell[5428, 178, 457, 19, 127, "Text", Evaluatable->False], Cell[5888, 199, 647, 18, 93, "Text", Evaluatable->False], Cell[6538, 219, 82, 2, 73, "Input"], Cell[6623, 223, 321, 8, 68, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[6981, 236, 96, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:16"], Cell[7080, 241, 2110, 55, 393, "Text", Evaluatable->False], Cell[9193, 298, 95, 3, 43, "Text"], Cell[9291, 303, 69, 2, 51, "Input"], Cell[9363, 307, 102, 3, 43, "Text"], Cell[9468, 312, 85, 2, 59, "Input"], Cell[9556, 316, 155, 3, 51, "Input"], Cell[9714, 321, 165, 3, 74, "Input"], Cell[CellGroupData[{ Cell[9904, 328, 39, 0, 28, "Subsubsection"], Cell[9946, 330, 113, 2, 43, "Text", Evaluatable->False], Cell[10062, 334, 195, 3, 74, "Input"], Cell[10260, 339, 237, 5, 68, "Text"], Cell[10500, 346, 171, 3, 74, "Input"], Cell[10674, 351, 302, 8, 68, "Text"], Cell[10979, 361, 103, 3, 50, "Input"], Cell[11085, 366, 179, 4, 68, "Text"], Cell[11267, 372, 125, 4, 50, "Input"], Cell[11395, 378, 164, 4, 68, "Text"], Cell[11562, 384, 162, 3, 51, "Input"], Cell[11727, 389, 228, 6, 68, "Text", Evaluatable->False], Cell[11958, 397, 514, 10, 166, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[12509, 412, 41, 0, 42, "Subsubsection"], Cell[12553, 414, 480, 12, 93, "Text", Evaluatable->False], Cell[13036, 428, 78, 1, 51, "Input"], Cell[13117, 431, 78, 1, 51, "Input"], Cell[13198, 434, 79, 1, 51, "Input"], Cell[13280, 437, 589, 16, 93, "Text"], Cell[13872, 455, 151, 3, 74, "Input"], Cell[14026, 460, 111, 2, 51, "Input"], Cell[14140, 464, 76, 0, 43, "Text"], Cell[14219, 466, 91, 1, 51, "Input"], Cell[14313, 469, 317, 8, 68, "Text", Evaluatable->False], Cell[14633, 479, 133, 2, 51, "Input"], Cell[14769, 483, 212, 4, 68, "Text"], Cell[14984, 489, 572, 9, 166, "Input"], Cell[15559, 500, 53, 0, 43, "Text"], Cell[15615, 502, 182, 3, 74, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[15834, 510, 36, 0, 42, "Subsubsection"], Cell[15873, 512, 117, 3, 43, "Text"], Cell[15993, 517, 223, 5, 97, "Input"], Cell[16219, 524, 223, 5, 97, "Input"], Cell[16445, 531, 76, 0, 43, "Text"], Cell[16524, 533, 143, 2, 51, "Input"], Cell[16670, 537, 159, 2, 74, "Input"], Cell[16832, 541, 190, 5, 68, "Text", Evaluatable->False], Cell[17025, 548, 451, 9, 166, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[17525, 563, 106, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[17634, 568, 1214, 32, 318, "Text"], Cell[18851, 602, 142, 3, 97, "Input"], Cell[18996, 607, 302, 8, 68, "Text"], Cell[19301, 617, 178, 3, 74, "Input"], Cell[19482, 622, 271, 9, 43, "Text"], Cell[19756, 633, 107, 2, 51, "Input"], Cell[19866, 637, 1242, 36, 268, "Text"], Cell[21111, 675, 184, 4, 74, "Input"], Cell[21298, 681, 584, 17, 70, "Text"], Cell[21885, 700, 370, 6, 97, "Input"], Cell[22258, 708, 115, 3, 43, "Text"], Cell[22376, 713, 133, 2, 74, "Input"], Cell[22512, 717, 304, 8, 68, "Text"], Cell[22819, 727, 52, 1, 51, "Input"], Cell[22874, 730, 1047, 28, 268, "Text"], Cell[23924, 760, 267, 4, 120, "Input"], Cell[24194, 766, 34, 0, 43, "Text"], Cell[24231, 768, 106, 2, 74, "Input"], Cell[24340, 772, 106, 2, 74, "Input"], Cell[24449, 776, 106, 2, 74, "Input"], Cell[24558, 780, 106, 2, 74, "Input"], Cell[24667, 784, 1488, 43, 365, "Text"], Cell[26158, 829, 228, 5, 97, "Input"], Cell[26389, 836, 186, 4, 74, "Input"], Cell[26578, 842, 186, 4, 74, "Input"], Cell[26767, 848, 64, 0, 43, "Text"], Cell[26834, 850, 278, 6, 97, "Input"], Cell[27115, 858, 301, 9, 68, "Text"], Cell[27419, 869, 139, 2, 74, "Input"], Cell[27561, 873, 323, 9, 68, "Text"], Cell[27887, 884, 326, 5, 120, "Input"], Cell[28216, 891, 235, 8, 43, "Text"], Cell[28454, 901, 186, 3, 74, "Input"], Cell[28643, 906, 210, 4, 74, "Input"], Cell[28856, 912, 737, 28, 68, "Text"], Cell[29596, 942, 343, 6, 120, "Input"], Cell[29942, 950, 37, 0, 43, "Text"], Cell[29982, 952, 109, 2, 74, "Input"], Cell[30094, 956, 233, 4, 97, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[30364, 965, 105, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[30472, 970, 4698, 137, 668, "Text", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[35207, 1112, 118, 3, 28, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[35328, 1117, 705, 18, 175, "Text"], Cell[36036, 1137, 332, 6, 120, "Input"], Cell[36371, 1145, 385, 12, 68, "Text"], Cell[36759, 1159, 261, 4, 97, "Input"], Cell[37023, 1165, 139, 2, 51, "Input"], Cell[37165, 1169, 139, 2, 51, "Input"], Cell[37307, 1173, 715, 18, 125, "Text"], Cell[38025, 1193, 53, 1, 51, "Input"], Cell[38081, 1196, 86, 1, 51, "Input"], Cell[38170, 1199, 148, 5, 43, "Text"], Cell[38321, 1206, 224, 5, 97, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[38582, 1216, 105, 3, 42, "Subsection", Evaluatable->False, CellTags->"c:17"], Cell[38690, 1221, 1953, 59, 343, "Text"], Cell[40646, 1282, 303, 5, 189, "Input"], Cell[40952, 1289, 58, 0, 43, "Text"], Cell[41013, 1291, 91, 1, 51, "Input"], Cell[41107, 1294, 128, 2, 51, "Input"], Cell[41238, 1298, 149, 3, 68, "Text"], Cell[41390, 1303, 260, 4, 74, "Input"], Cell[41653, 1309, 48, 1, 51, "Input"], Cell[41704, 1312, 49, 1, 51, "Input"], Cell[41756, 1315, 214, 4, 74, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[42019, 1325, 23, 0, 47, "Section"], Cell[42045, 1327, 4111, 91, 1753, "Input", InitializationCell->True] }, Closed]] }, Open ]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)