Add-ins:
Excel
PowerPoint

The following iterative sequence is defined for the set of positive integers:

`n`
→ `n`/2 (`n`
is even)

`n` → 3`n`
+ 1 (`n` is odd)

Using the rule above and starting with 13, we
generate the following sequence:

13 → 40
→ 20
→ 10
→ 5
→ 16
→ 8
→ 4
→ 2
→ 1

It can be seen that this sequence (starting at 13 and finishing at 1) contains 10 terms. Although it has not been proved yet (Collatz Problem), it is thought that all starting numbers finish at 1.

Which starting number, under one million, produces the longest chain?

**NOTE:** Once the chain starts the
terms are allowed to go above one million.

I delayed tackling this problem because the brute force approach did not appeal to me. I expected it to take well over the expectation of the duration for a Project Euler problem, which happens to be 1 minute.

The solution I finally came up with was a recursive routine that populates a table with results as they become available. The benefit of this approach is that as soon as we find an existing entry in the table, we know the length of the chain from that number on out and can use it. Since each even number will be halved in the first step, if we build the data base from 1 to 999,999, we will have the answer for each even number in just 1 step! For odd numbers, we will populate the table for numbers greater than the starting number itself. Here's an example. Consider the chain in the statement of the problem. In computing the length of the chain starting with 13, we also discover that the chain starting with 40 has a length of 9 and the chain starting with 20 has a length of 8. Further, we would not even have to compute the entire chain for 20 since the next number, 10, has already been analyzed (remember, we started from 1). So, the length of the chain for 13 requires building only 3 values (40, 20, and 10). In addition, we can update our table for the chain length for starting values 20 and 40.

As it turns out the best way to implement this method is to use a recursive approach. This way we let the OS / compiler do the heavy lifting of keeping track of what counter goes with what value.

The code below ran in about 50 seconds.

Option Explicit Function CheckOneNbr(ByVal aNbr As Variant, SeqCount As Collection) As Integer Debug.Assert TypeName(aNbr) = "Decimal" On Error GoTo AddData CheckOneNbr = SeqCount(CStr(aNbr)) Exit Function AddData: On Error GoTo 0 If CDec(Right(aNbr, 1)) Mod 2 = 0 Then CheckOneNbr = CheckOneNbr(aNbr / 2, SeqCount) + 1 _ Else CheckOneNbr = CheckOneNbr(3 * aNbr + 1, SeqCount) + 1 SeqCount.Add CheckOneNbr, CStr(aNbr) End Function Sub Euler014() Dim I As Long Dim ProcTime As Single, MaxRslt As Integer, MaxStartNbr As Long Dim SeqCount As Collection ProcTime = Timer Set SeqCount = New Collection SeqCount.Add 1, CStr(1) MaxRslt = 1: MaxStartNbr = 1 For I = 2 To 1000000 - 1 CheckOneNbr CDec(I), SeqCount If MaxRslt < SeqCount(CStr(I)) Then MaxRslt = SeqCount(CStr(I)) MaxStartNbr = I End If Next I Debug.Print MaxRslt, MaxStartNbr, Timer - ProcTime End Sub

Given how long it took, I entertained the possibility that the recursive solution was not the way to go. So, I wrote and checked the performance of the "flat" routine. It ran in about 120 seconds on my laptop.

Sub Euler014s() Dim I As Long Dim ProcTime As Single, MaxRslt As Integer, MaxStartNbr As Long ProcTime = Timer MaxRslt = 1: MaxStartNbr = 1 For I = 2 To 1000000 - 1 Dim Rslt As Variant, ThisSeqLen As Integer Rslt = CDec(I): ThisSeqLen = 1 Do While Rslt <> 1 If Right(Rslt, 1) Mod 2 = 0 Then Rslt = Rslt / 2 _ Else Rslt = 3 * Rslt + 1 ThisSeqLen = ThisSeqLen + 1 Loop If MaxRslt < ThisSeqLen Then MaxRslt = ThisSeqLen: MaxStartNbr = I Next I Debug.Print MaxRslt, MaxStartNbr, Timer - ProcTime End Sub