Project Euler - Problem 31

More about Project Euler.

Problem description

In England the currency is made up of pound, £, and pence, p, and there are eight coins in general circulation:

1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p).

It is possible to make £2 in the following way:

1x£1 + 1x50p + 2x20p + 1x5p + 1x2p + 3x1p

How many different ways can £2 be made using any number of coins?

Solution

These kind of problems are ideally suited to solving by recursion. The VBA code at ../../excel/templates/match_values/index.html solves a very similar problem. In that scenario, the requirement was that each element be used only once. Now, in Euler 31, we relax that restriction. Luckily, enhancing the existing code is not very difficult. We add an array InArrCounts of the same size as InArr. Then, we add a loop where we count the number of times we use a particular element. Make the necessary changes to correctly support this new array and we are done. Well, almost. It turns out the number of solutions we get exceed the capability of the Excel Transpose function. Luckily, we don't need to list each solution, just the number. So, that statement gets commented out. Also, the original code does a lot more than the Euler 31 problem requires. We could clean up the code to remove the extra code -- at the very least remove the debug statements? -- but is it worth the effort given that we can find the required answer in 3 or 4 seconds?

Once the code is in place, in 10 contiguous cells in an Excel worksheet enter the numbers 0, 200, 200, 100, 50, 20, 10, 5, 2, and 1. The first 0 means we want all solutions. The first 200 is the target amount (in pence). The rest of the numbers are the denominations of the coins, all in pence. Select this range and run the Euler31 subroutine.

To learn more about recursion, see an introductory Computer Science textbook on programming techniques, search Google, or visit
Recursion
http://www.tushar-mehta.com/publish_train/book_vba/07_recursion.htm

Option Explicit
Option Base 0

Function RealEqual(A, B, Epsilon As Double)
    RealEqual = Abs(A - B) <= Epsilon
    End Function
Function ExtendRslt(CurrRslt, NewVal, NewValCount, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal & "(" & NewValCount & ")" _
    Else ExtendRslt = CurrRslt & Separator & NewVal & "(" & NewValCount & ")"
    End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, _
        InArr(), InArrCounts() As Integer, _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    Dim I As Integer
    For I = CurrIdx To UBound(InArr)
        Dim InArrCountsIdx As Integer
        InArrCountsIdx = I - LBound(InArr) + LBound(InArrCounts)
        For InArrCounts(InArrCountsIdx) = (TargetVal - CurrTotal) \ InArr(I) To 1 Step -1
            If RealEqual(CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx), TargetVal, Epsilon) Then
                Rslt(UBound(Rslt)) = (CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx)) _
                    & Separator & Format(Now(), "hh:mm:ss") _
                    & Separator & ExtendRslt(CurrRslt, I, InArrCounts(InArrCountsIdx), Separator)
                If MaxSoln = 0 Then
                    If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
                Else
                    If UBound(Rslt) >= MaxSoln Then Exit Sub
                    End If
                ReDim Preserve Rslt(UBound(Rslt) + 1)
            ElseIf CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx) > TargetVal + Epsilon Then
            ElseIf CurrIdx < UBound(InArr) Then
                recursiveMatch MaxSoln, TargetVal, InArr(), InArrCounts(), I + 1, _
                    CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx), Epsilon, Rslt(), _
                    ExtendRslt(CurrRslt, I, InArrCounts(InArrCountsIdx), Separator), _
                    Separator
                If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
            Else
                'we've run out of possible elements and we _
                 still don't have a match
                End If
            Next InArrCounts(I)
        Next I
    End Sub
Function ArrLen(Arr(), Optional ByVal ArrDim As Integer = 1) As Long
    On Error Resume Next
    ArrLen = UBound(Arr, ArrDim) - LBound(Arr, ArrDim) + 1
    End Function
Sub Euler31()
    'The selection should be a single contiguous range in a single column. _
     The first cell indicates the number of solutions wanted.  Specify zero for all. _
      The 2nd cell is the target value. _
      The rest of the cells are the values available for matching. _
      The output is in the column adjacent to the one containing the input data.
    Dim TargetVal, Rslt(), InArr(), InArrCounts() As Integer, StartTime As Date, MaxSoln As Integer
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    ReDim InArrCounts(ArrLen(InArr) - 1)
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, InArrCounts, LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
    Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
    ReDim Preserve Rslt(UBound(Rslt) + 1)
    Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
    Debug.Print ArrLen(Rslt) - 2
    'Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
        Application.WorksheetFunction.Transpose(Rslt)
        'Since there are >65536 solutions, the Transpose function fails.  Luckily, the problem requires _
         finding just the number of solutions.
    End Sub