Euler Problem 23

Euler Problem 23 asks:

‘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
   Dim Answer  As Long
 
   T = Timer
   j = 1
   For i = 12 To Limit
      If IsAbundant(i) Then
         AbundantNums.Add (i)
         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) > 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
            If errNum = 5 Then   ‘this means Not Retrieved from Collection
              AbundantSums.Add Item:=Item, Key:=Key ‘so add it
           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
        Answer = Answer + i
      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 > 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)
    Answer = Answer + keys(i)
    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. 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. 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. 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. 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. 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. 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.

Leave a Reply

Your email address will not be published.