# Euler Problem 23

‘A perfect number is a number for which the sum of its proper divisors
‘is exactly equal to the number. For example, the sum of the proper
‘divisors of 28 would be 1 + 2 + 4 + 7 + 14 = 28, which means that 28
‘is a perfect number.

‘A number whose proper divisors are less than the number is called deficient
‘and a number whose proper divisors exceed the number is called abundant.
‘As 12 is the smallest abundant number, 1 + 2 + 3 + 4 + 6 = 16, the smallest
‘number that can be written as the sum of two abundant numbers is 24.
‘By mathematical analysis, it can be shown that all integers greater than 28123
‘can be written as the sum of two abundant numbers. However, this upper limit
‘cannot be reduced any further by analysis even though it is known that the
‘greatest number that cannot be expressed as the sum of two abundant numbers
‘is less than this limit.

‘Find the sum of all the positive integers which cannot be written as the sum
‘of two abundant numbers.

The approach seems simple:

1. Determine the list of abundant numbers and add to a collection
2. Determine the list of all abundant number sums and add it to a different collection
3. Run the list of numbers past the second collection to identify those not in the collection, and sum

Usually, I’ll count the number of something, re-dim a variable to that count, and then stuff the variable. But since I have to calculate “abundantness” to determine membership, we’ll just add it to the collection in the same step, and have the collection report the count.

Unfortunately, collections only provide for add, remove, retrieve, and count. There is not a “belongs” or “ismember” function. A smart guy (Mark Nold) over in StackOverflow provided a way, using errors. Here is his code:

Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long

InCollection = False
Set var = Nothing

Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0

‘5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ‘ it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If

End Function

I use his method twice to, first, see if an abundant number sum is already in the collection of AbundantSums, and then secondly to see which of the numbers in the range to 28123 is not in the AbundantSums collection.

That’s how I did it. My problem is that, to coin a new unit of measurement, the calculations take a kilo-second, or almost 18 minutes, to arrive at the answer. The first and last steps are very fast. It’s the middle one that takes 1000 seconds. Euler won’t mind, I think, if I say there are 6965 abundant numbers in the range. To compute all possible abundant number sums is 6965*6965 cycles, or very close to 49 million loops. I don’t see the trick to get this down to one-minute Euler time, and I couldn’t pick out the shortcut in the commentary of those who already solved this problem. Here’s my code, with timing comments for each of the steps.

Sub Problem_023()
Const Limit As Long = 28123
Dim AbundantNums As New Collection
Dim AbundantSums As New Collection
Dim i As Long, j As Long
Dim n As Long, T As Single
Dim TEMP As Long, Key As String, errNum As Long, Item As Long

T = Timer
j = 1
For i = 12 To Limit
If IsAbundant(i) Then
j = j + 1
End If
Next i

n = AbundantNums.Count
Debug.Print n; Timer – T   ‘6965  0.2695313

For i = 1 To n
If AbundantNums.Item(i) + AbundantNums.Item(1) &gt; Limit Then
Exit For
End If
For j = i To n
errNum = 0
If AbundantNums.Item(i) + AbundantNums.Item(j)  LTE Limit Then
Item = AbundantNums.Item(i) + AbundantNums.Item(j)
Key = CStr(Item)
Err.Clear
On Error Resume Next
TEMP = AbundantSums.Item(Key) ‘if retrieved then no error
errNum = CLng(Err.Number)
On Error GoTo 0
End If
Else
Exit For
End If
Next j
Next i
Debug.Print AbundantSums.Count; Timer – T   ‘26667  1001.789

For i = 1 To Limit
errNum = 0
Key = CStr(i)
Err.Clear
On Error Resume Next
TEMP = AbundantSums.Item(Key)
errNum = CLng(Err.Number)
On Error GoTo 0
If errNum = 5 Then ‘ i is not in the Sums Collection
End If
Next i

Debug.Print Answer; ”  Time:”; Timer – T

End Sub   ‘xxxxxxxxxx  Time: 1001.883

Function IsAbundant(num As Long) As Boolean
Dim i       As Long
Dim sum     As Long

sum = 1
For i = 2 To Sqr(num)
If num Mod i = 0 Then
sum = sum + i
sum = sum + num / i
End If
Next i

If Sqr(num) = Int(Sqr(num)) Then ‘a perfect square
‘i = Sqr(num) = num/i and added twice above
sum = sum – Sqr(num)
End If

If sum &gt; num Then
IsAbundant = True
Else
IsAbundant = False
End If

End Function

The IsAbundant function only has to check to the square root of a number. If num mod i = 0 you have also determined that num/i is a factor at the same time, and both can be added to the sum of factors. The only rub is when num is a perfect square (when i = sqr(num) = num/i) and you have added that factor twice. Rather than put some logic inside the loop, I checked if that was the case, and subtracted one square root when required.

Only partial credit for this one. It takes too dang long. Please comment on what I’ve missed. The Prime Glossary (http://primes.utm.edu/glossary/page.php?sort=AbundantNumber) reports that the real limit is 20161. While several solvers knew that, I don’t think that’s the problemgets me down to about 400 seconds. To make the change, just change the constant at the top.

…mrt

Posted in Uncategorized

## 7 thoughts on “Euler Problem 23”

1. How much faster (if at all) does it go using a Scripting.Dictionary (which handily also has an Exists member function)? Once I’m into the thousands of items, I usually figure there’s going to be something worth having; any concern that the code may one day find itself on a machine without the scripting runtime is negligible in my experience. Also, the key of a Dictionary can be any type, which would save a lot of CStr-ing. Using a Dictionary for AbundantSums reduces the code inside the inner loop to

errNum = 0
Item = AbundantNums.Item(i) + AbundantNums.Item(j) ‘ move above if to save computing twice
If Item <= Limit Then
AbundantSums(Item) = 1 ‘ creates the item if not present, don’t actually care about what’s stored
Else
Exit For
End If

Also, you have AbundantSums.Keys as an array, so ou can do something like this:

keys = AbundantSums.Keys
For i = LBound(keys) To UBound(keys)
Next

(No code actually tested yet – I hope haven’t written anything stupid!)
This was a slow one for me too: my Ruby option took almost a minute, of which 10sec was calculating the abundant list. I’m guessing there’s a trick being missed.

2. dcardno says:

I tried creating an array of Abundant numbers and then testing each integer to see if I could find combinations of Abundant numbers that would sum to them. I also found that the process was very slow – I got the right answer, but some approaches were taking over an hour to run (the fastest was about 13 minutes).

I finally did it by creating an array of abundant numbers as before, then iterating through that array twice to find all the possible sums of two Abundant numbers and recorded that as a T/F indicator in another array – call the first array arAB() and the second an array of Booleans from 1 to 28K (the limit given in the problem – all numbers > 28,123 can be written as the sum of two Abundant numbers), called arYES() some pseudocode (apologies if I screw up the code formatting):

for i = 1 to ubound(arAB)
for j = i to ubound(arAB)
iTest = arAB(i) + arAB(j)
if iTest &lt;= ubound(arYES) then
arYES(iTest) = TRUE
else
exit for
end if
next j
next i

for i = 1 to ubound(arYES)
if arYes(i) = FALSE THEN
iSum = iSum + i
end if
Next i

the full routine runs in less than two seconds

3. dbb says:

I think I used the same approach as dcardno, but mine takes just over a minute. Nearly all of my time is spent finding the abundant numbers. I’d be interested in knowing how you get it all to run in 2 seconds in VBA.

Here is my code..

‘make 2 arrays of abundant numbers
For i = 2 To 28123
If SumDivisors(i) GREATER_THAN i Then ‘custom routine to find and sum divisors
r = r + 1
A(r) = i ‘this array stores a list of the numbers
b(i) = True ‘this array tells us if any number in the range is abundant
End If
Next i
Debug.Print Timer – t

For i = 1 To 28123  ‘for each number in range
For j = 1 To r  ‘loop through abundant numbers
‘exit inner j loop and add i to our sum n, if our abundant number exceeds the current number i
‘ie no sum found for this i
If A(j) GREATER_THAN_EQUAL i Then
n = n + i
Exit For
End If
‘exit inner j loop if (i + the abundant number) is abundant
If b(i – A(j)) Then
Exit For
End If
Next j
Next i

4. dcardno says:

I’ve cut & pasted the whole thing – which also includes my prior attempts commented out, and some timing results. I am running on a reasonably-powered laptop (Core 2 duo, T7500 IIRC, with 4Gig RAM), and it runs in just under a second. There was a substantial improvement in determining the factors by only testing to sqr(iIN) and calculating the second factor as required

Function iSumDiv(iIN As Long) As Long

‘ prior versions test up to iIn/2 to capture both factors
‘ present version tests up to sqr(iIn) and calculates second factor
‘ requires correction for the root (should only count once), but
‘ is ~20x faster (3.5 sec v .18 sec to create Abundant array)

Dim i               As Long
iSumDiv = 1
For i = 2 To Sqr(iIN)
If iIN Mod i = 0 Then
iSumDiv = iSumDiv + i + (iIN / i)
If i = Sqr(iIN) Then iSumDiv = iSumDiv – i
End If
Next i

End Function

Sub ListAbundant()

Dim i               As Long
Dim j               As Long
Dim k               As Long
Dim m               As Long
Dim iSum            As Long
Const iMax          As Long = 28123
Dim arAb()          As Boolean
Dim blFound         As Boolean
Dim arAbVal()       As Long
Dim iTest           As Long
Dim sStart          As Single
‘Dim wf              As WorksheetFunction

‘Set wf = Application.WorksheetFunction

‘ create array of T/F indicating abundant numbers

sStart = Timer
ReDim arAb(1 To iMax)
For i = 11 To iMax
If arAb(i) = False Then
If iSumDiv(i) &gt; i Then
arAb(i) = True
j = 2
Do While j * i &lt;= iMax
arAb(i * j) = True
j = j + 1
Loop
End If
End If
Next i
For i = 1 To iMax
If arAb(i) = True Then
k = k + 1
End If
Next i

Debug.Print k; Timer – sStart

‘ transform to array of abundant numbers

ReDim arAbVal(1 To k)
k = 1
For i = 1 To iMax
If arAb(i) Then
arAbVal(k) = i
k = k + 1
arAb(i) = False
End If
Next i

‘Another alternative – calculate all possible combinations of 2 Abundant numbers
‘then add all numbers that aren’t in that list.  Execution time of ~4.4 sec – of
‘which 3.7 is to create the array of abundant numbers. The clear winner!

For i = 1 To k – 1
For j = i To k – 1
iTest = arAbVal(i) + arAbVal(j)
If iTest &lt;= iMax Then
arAb(iTest) = True
Else
Exit For
End If
Next j
Next i

‘ alternative – use worksheet lookup functions – still bloody slow.
‘ Stopped manually at ~20 min, not complete

‘For i = 23 To iMax
‘    If arAb(i) = False Then
‘        For j = 1 To UBound(arAb)
‘            iTest = i – arAbVal(j)
‘            If iTest &lt;= 0 Then
‘                Exit For
‘            Else
‘                If wf.Lookup(i, arAbVal) = i Then
‘                    For k = 1 To CInt(UBound(arAb) / i – 0.5)
‘                        arAb(i * k) = True
‘                    Next k
‘                    Exit For
‘                End If
‘            End If
‘        Next j
‘    End If
‘Next i

‘ this approach (examine values arAbVal(j) &amp; (k), determine success or failure,
‘ set T/F for each coresponding arAb(i) plus multiples) took approx one hour – 3822 seconds

‘For i = 23 To iMax
‘    If arAb(i) = False Then
‘        For j = 1 To UBound(arAbVal)
‘            If arAb(i) = True Then
‘                Exit For
‘            End If
‘            If arAbVal(j) <i> i Then
‘                        Exit For
‘                    Else
‘                        If arAbVal(j) + arAbVal(k) = i Then
‘                            For m = 1 To Int(iMax / i)
‘                                arAb(i * m) = True
‘                            Next m
‘                            Exit For
‘                        End If
‘                    End If
‘                Next k
‘            Else
‘                Exit For
‘            End If
‘        Next j
‘    End If
‘Next i

For i = 1 To iMax
If arAb(i) = False Then
iSum = iSum + i
End If
Next i

‘ This approach (loop within loop to test all arAbVal(j) + arAbVal(k))
‘ takes approx 12 minutes to run (723 seconds)

‘For i = 1 To iMax
‘    blFound = False
‘    For j = 1 To UBound(arAbVal)
‘        If arAbVal(j) </i><i> 0 Then
‘                    Exit For
‘                End If
‘            Next k
‘            If blFound Then
‘                Exit For
‘            End If
‘        Else
‘            Exit For
‘        End If
‘    Next j
‘    If Not blFound Then
‘        iSum = iSum + i
‘    End If
‘Next i

Debug.Print iSum; Timer – sStart

End Sub

5. dbb says:

Ah yes, checking for divisors up to only the square root cuts the overall time to a couple of seconds. I’d used that approach for checking primes but not here. Silly me.

6. DCardno says:

I don’t think that’s the real speed-up, dbb. When checking divisors up to half the input value it takes ~3.5 seconds to create the array of abundant numbers; checking only up to the square root cuts that to about a quarter of a second – but we only do it once and then refer to the array thereafter. The real improvement comes in not trying to find Abundant(i) and Abundant(j) that sum to a particular number, but instead just calculating the possible sums of Ab(i) and Ab(j) and using the value to index the array of T/F values.

I am trying to think of [i]why[/i] that should be such an improvement – it seems that we still have to run ~7000 * 7000 (approx the number of abundant numbers below 28K) calculations. It’s actually less than that, since the inner loop is smaller: the loops are i from 1 to 7000 and j from i to 7000, and we exit the loop if Ab(i) + Ab(j) > 28K, but it still seems that we should be doing perhaps 3500 * 3500 iterations. It could be that my other attempts [i]didn’t[/i] exit the loops properly, so the difference is between one routine doing 7K*7K loops and the other doing 3.5K*3.5K – but that’s still only a 4x speedup, and what I ended up with went from ~12 minutes (723 seconds) to under 2 seconds, or a 350x improvement.

The answer just struck me as I was reviewing that last bit of code in the module I posted (which got kind of munged-up in the formatting and lost most of a loop). In trying to find Abundant(i) + Abundant(j) that sums to each value in the range 1 to 28K we are actually doing 28K * 3.5K * 3.5K loops = ~3.4×10^11 iterations. In ticking off the sums of Ab(i) + Ab(j) for all values of i and j, we are only doing 3.5K * 3.5K loops, or 1.2×10^7 iterations.

Since we cut off the first approach based on Ab(i) being greater than the target value we save some of the second loop, and also some of the third loop if Ab(i) + Ab(j) is greater than the target, but that saving doesn’t make up for running the routine for every number from 1 to 28K

7. Michael says:

D – my approach was like your discarded 12 minute one. I just put a counter right under “for j = i to n” (the inner loop). It started down the j loop 12155776 times. It started 6962 times (top check shorts by 3) down the i loop. Nowhere do I loop 28K times. It’s not 49 million, but it’s not 3*10^11 either.

I still don’t understand the differences ;-)

…mrt

Posting code? Use <pre> tags for VBA and <code> tags for inline.