How to Optimize Solution? (Project Euler #14) [duplicate]

Link to Question: https://projecteuler.net/problem=14

I began by defining the following functions below.

collatz := If[EvenQ[#], #/2, 3 # + 1] &
NotOneQ := collatz[#] != 1 &
collatzlength := Plus[NestWhileList[collatz, #, NotOneQ] // Length, 1] &


To find the actual answer, I inputted

Min[
Flatten[
Position[
Table[collatzlength[i], {i, 1, 999999}],
Max[Table[collatzlength[i], {i, 1, 999999}]]]]]

837799


Basically, it computes collatzlength for i = 1 to i = 999999, Tabled the results into a list, found the Position(s) of the maximum value in the list, and (in case there were multiple numbers with the same Collatz sequence length) took the minimum entry from a Flattened list.

Though this solution is simple and conceptually intuitive, it is fairly primitive and took a whopping 16 minutes for Mathematica to evaluate. How can I optimize this solution to make it compute faster? I saw other posts on StackExchange asking the same thing for Problem #14, but I was unable to understand any of the concepts discussed in those posts.

-A

Edit: I tried the suggestion below about memorization. Here is the setup. Please let me know if it is incorrect and what needs to be changed. Please refer to the top of the post for the original function definitions.

f[x__] := collatz[x] = If[EvenQ[x], x/2, 3 x + 1]
g[x__] := f[x] != 1
h[x__] := collatzlength[x] = Plus[NestWhileList[f, x, g] // Length, 1]


The adjusted input was then

Min[Flatten[
Position[Table[h[i], {i, 1, 999999}],
Max[Table[h[i], {i, 1, 999999}]]]]]


I tested both methods using {i,1,10000} and AbsoluteTiming, and the computation time more than doubled after the memorizations were applied. Here are the results.

Original:

{21.303, 6171}


Memorizations applied:

{42.7376, 6171}

• Maybe memoize the functions? The usual syntax is something like this: f[x_] := f[x] = rhs The first time you call f[3], it will evaluate the rhs and assign that to f[3]. Next time you call f[3], it merely fetches the value from memory and skips evaluating the rhs a second time. If your program makes many redundant calls, this should save a lot of time. – phosgene Jun 30 '15 at 3:37
• I tried this, and the computation time nearly doubled, unfortunately. I will post what I changed. It doesn't make sense that computation time would increase, so I most likely set it up incorrectly. – A is for Ambition Jun 30 '15 at 4:12
• search for "collatz" in this site. There are several related questions. – Dr. belisarius Jun 30 '15 at 4:33
• No. Just change, e.g., first line to collatz[x_] := collatz[x] = If[EvenQ[x], x/2, 3 x + 1], see what happens. Figure out if any other memoization might apply. And note belisarius's comment - there are smart ways to do this. – ciao Jun 30 '15 at 4:44
• Related (with some beautiful visualizations): (85718) – shrx Jun 30 '15 at 7:21

The performance can be further increased by just calculating and memoizing the sequence length and using ParallelMap instead of Map.

seqLength[1] = 1

seqLength[n_?EvenQ] := seqLength[n] = 1 + seqLength[n/2]
seqLength[n_?OddQ] := seqLength[n] = 1 + seqLength[3 n + 1]

lengthList = Flatten@ParallelMap[seqLength, Range[10^6], Method -> Automatic];
Position[lengthList, Max@lengthList]

• Nice approach to save memory, +1 – LLlAMnYP Jun 30 '15 at 11:25

I figured, that the performance increase of memoizing the result of a_?OddQ -> 3 a + 1 or a_?EvenQ -> a / 2 would hardly help. However, it would be very helpful to memoize the sequence from applying the rule all the way until the result goes down to 1.

Like so:

ClearAll[f]

f[1] = {1};
f[a_?EvenQ] := f[a] = Join[{a}, f[a/2]]
f[a_?OddQ] := f[a] = Join[{a}, f[3 a + 1]]

AbsoluteTiming[f /@ Range[999 999]] // First

16.3734


Looks like those 16 minutes turned into 16 seconds.

Length /@ (f /@ Range[999 999]);
Max@%

525

Position[%%, 525]

{{837 799}}

f[837 799] // Short

{837799,2513398,1256699,3770098,1885049,5655148,2827574,<<511>>,10,5,16,8,4,2,1}