Collatz Tool Box — any speed ups possible?

I have created a tool box for experimenting with the Collatz conjecture. Info here: Wolfram MathWorld and here: Wikipedia The patterns I have found allow us to make the conjecture jump through some hoops.

Final Edit countOrbit has been re-cast as a Do Until loop because the logic behaves similar to a one-directional linked list and I don't think it can be improved.

Note: the number of sub orbits $\leq$ (total steps) / 6

Edit for the down-voters: the current maximum that collatz projects have reached is around $10^{18}$. The example below has two numbers $10^{301030}$ and $10^{477119}$ that my functions can use quickly and accurately. That is many magnitudes greater that what is currently being done. So, why the down-votes?

This is one example: m is the count of numbers in an ascending sequence. uniqueRank[1,m] returns the first number of the first unique sub orbit of that length. omegaSubOrbit[x,m] returns the last number of that sub orbit. We display the digit counts of these numbers. Then we count the complete orbit down to 1. This takes a bit over 12 minutes on my AMD 1100T. The left-hand number is the count of multiplies (we don't count divisions by two) and the right-hand count is the number of sub orbits used to get the counts.

m = 1000000; x = uniqueRank[1, m];
y = omegaSubOrbit[x, m];
{IntegerLength[x], IntegerLength[y]}
countOrbit[1, x]


{301030, 477119}
{4805005, 1903828}
{13420758, 1903828} 7.8 minutes to count all multiplies and divides

My question: Since I'm using For and While in a few places, is there a way to speed up those functions? Especially, the countOrbit function?

ascendingQ[x_] := 3 == Mod[x, 4]
uniqueQ[x_] := 0 != Mod[2 x - 1, 3]
subOrbit[x_] :=
Block[{y = x},
Flatten[Join[
Table[y \[DirectedEdge] (y = 1/2 (3 y + 1)), {n, 1,
IntegerExponent[x + 1, 2] - 1}], {y \[DirectedEdge] (3 y + 1)/
2^IntegerExponent[3 y + 1, 2]}]]]
createSubOrbitGraph[n_] :=
Block[{j, v = {}},
For[j = 1, j <= n, j++,
If[uniqueQ[2 j + 1], AppendTo[v, subOrbit[2 j + 1]]];
];
Flatten[v]
]
uniqueRank[n_, m_] := Block[{a = If[1 != n && OddQ[n], n - 1, n]},
(n + IntegerExponent[a, 2]) 2^m - 1]
nonUniqueRank[n_, m_] := (2 n - 1)   2^m - 1
createOrbit[w_, x_] := Block[{u = subOrbit[x]},
While[w < u[[-1, 2]],
u = Flatten[AppendTo[u, subOrbit[u[[-1, 2]]]]]];
u]
createOrbitGraph[n_] :=
Block[{j, u = {}},
For[j = 1, j <= n, j++,
If[uniqueQ[2 j + 1], u = Union[u, createOrbit[2 j + 1, 2 j + 1]]];
];
Flatten[u]
]
omegaSubOrbit[x_, m_] :=
Block[{z = (-1 + (3/2)^m (1 + x))}, 2^(1 - IntegerExponent[2 z, 2]) z]
omegaSubOrbit[x_] :=
Block[{m = IntegerExponent[x + 1, 2], z = (-1 + (3/2)^m (1 + x))},
2^(1 - IntegerExponent[2 z, 2]) z]
countOrbit[w_, x_] :=
Block[{h = x, t, c, d = 0, s = 0, l = 0, m, n, a},
While[True,
m = IntegerExponent[h + 1, 2];
t = -1 + (3/2)^m (1 + h);
n = IntegerExponent[t, 2];
l += m;
d += n;
s += 1;
h = t/2^n;
If[h <= w, Break[]];
];
c = 2 l + d;
a = If[1 == w, "Full ", "Extended Sub "];
Print["---Counts ", a, "Orbit---",
"\nNumber of Sub Orbits: ", s,
"\nMultiplications by 3: ", l,
"\nDivisions by 2:       ", l,
"\nExtra Divisions by 2: ", d,
"\nTotal for Orbit:      ", c]
]


Some brief documentation:
ascendingQ[x] Returns True if odd x is ascending, False if descending
uniqueQ[x] Returns True if odd x is not embedded in any longer sequence
subOrbit[x] Returns graph data in the form {Head[DirectedEdge]Tail}
createSubOrbitGraph[n] Returns graph data of sub orbits up through n
uniqueRank[n, m] Returns the first number of the n-th unique occurance of a sub orbit of size m
nonUniqueRank[n, m] Returns the first number of the n-th occurance of a sub orbit of size m, which may not be unique.
createOrbit[w, x] Returns graph data for w=1 complete orbit or w=x extended sub orbit
Note: for a graph, both are equivalent. w=x produces fewer duplicates.
createOrbitGraph[n] Returns graph data of extended sub orbits up through n
omegaSubOrbit[x] Returns the last odd number of a sub orbit. (The one that required multiple divides.)
omegaSubOrbit[x, m] Same as above, but uses m to speed up the first step
countOrbit[w, x] Returns the count of multiply and division steps and the count of sub orbits processed, for w=1 complete orbit or w=x extended sub orbit

Edit Replaced countOrbit[w,x] with refined version that counts divisions and multiplication. Reduced the time from 15 minutes to 7.8 minutes for the above example.

• I didn't downvote this, but it may be that some "speed up my code" questions aren't always well-received by everyone. relevant Meta question... – cormullion Jul 31 '13 at 11:41
• I posted this link recently. Might be of interest... – cormullion Jul 31 '13 at 12:22
• The reason for my downvoting this is: on the one hand the "speed up my code" reason that cormuillion mentioned, and that you give too many functions without explaining what they do to someone who doesn't know about the Collatz problem. I am happy to retract the vote if you make this into a more minimal question with an explanation for what the conjecture is, why subOrbit[n] skips the even steps and some indication this is done correctly and so on.. – gpap Jul 31 '13 at 14:58
• Take a look at Leonid's great answer in this question, it will give you an idea how to improve your code. – sebhofer Aug 3 '13 at 8:26
• many more basic collatz ideas here & hope to hear from others in Mathematica Chat – vzn Jun 12 '15 at 17:22

As stated in the OP, this is a "linked-list" type of algorithm that I don't feel can be speeded up using the usual methods. So, I figured that compiling the functions to use Integers Of Unusual Size would be the only way to speed up things. As noted in an answer on that thread, Mathematica compiles are limited to machine-precision so, I'm debating with myself about crafting a C program using GMP to test some timings. I will accept this answer to clear this thread from the unanswered queue.