2
$\begingroup$

This question already has an answer here:

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.

Thanks for reading,

-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}
|improve this question
$\endgroup$

marked as duplicate by shrx, Sjoerd C. de Vries, Artes, dr.blochwave, MarcoB Jun 30 '15 at 12:51

This question has been asked before and already has an answer. If those answers do not fully address your question, please ask a new question.

  • 2
    $\begingroup$ 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. $\endgroup$ – phosgene Jun 30 '15 at 3:37
  • $\begingroup$ 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. $\endgroup$ – A is for Ambition Jun 30 '15 at 4:12
  • 1
    $\begingroup$ search for "collatz" in this site. There are several related questions. $\endgroup$ – Dr. belisarius Jun 30 '15 at 4:33
  • $\begingroup$ 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. $\endgroup$ – ciao Jun 30 '15 at 4:44
  • 1
    $\begingroup$ Related (with some beautiful visualizations): (85718) $\endgroup$ – shrx Jun 30 '15 at 7:21
2
$\begingroup$

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]
|improve this answer
$\endgroup$
  • $\begingroup$ Nice approach to save memory, +1 $\endgroup$ – LLlAMnYP Jun 30 '15 at 11:25
1
$\begingroup$

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}
|improve this answer
$\endgroup$

Not the answer you're looking for? Browse other questions tagged or ask your own question.