Here is an optimized Object-Oriented version of the exact integer solution to the Subset Sums problem(Horowitz, Sahni 1974). On my laptop (which is nothing special) this vb.net Class solves 1900 subset sums a second (for 20 items):
Option Explicit On
Public Class SubsetSum
'Class to solve exact integer Subset Sum problems'
''
' 06-sep-09 RBarryYoung Created.'
Dim Power2() As Integer = {1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32764}
Public ForceMatch As Boolean
Public watch As New Stopwatch
Public w0 As Integer, w1 As Integer, w1a As Integer, w2 As Integer, w3 As Integer, w4 As Integer
Public Function SolveMany(ByVal ItemCount As Integer, ByVal Range As Integer, ByVal Iterations As Integer) As Integer
' Solve many subset sum problems in sequence.'
''
' 06-sep-09 RBarryYoung Created.'
Dim TotalFound As Integer
Dim Items() As Integer
ReDim Items(ItemCount - 1)
'First create our list of selectable items:'
Randomize()
For item As Integer = 0 To Items.GetUpperBound(0)
Items(item) = Rnd() * Range
Next
For iteration As Integer = 1 To Iterations
Dim TargetSum As Integer
If ForceMatch Then
'Use a random value but make sure that it can be matched:'
' First, make a random bitmask to use:'
Dim bits As Integer = Rnd() * (2 ^ (Items.GetUpperBound(0) + 1) - 1)
' Now enumerate the bits and match them to the Items:'
Dim sum As Integer = 0
For b As Integer = 0 To Items.GetUpperBound(0)
'build the sum from the corresponding items:'
If b < 16 Then
If Power2(b) = (bits And Power2(b)) Then
sum = sum + Items(b)
End If
Else
If Power2(b - 15) * Power2(15) = (bits And (Power2(b - 15) * Power2(15))) Then
sum = sum + Items(b)
End If
End If
Next
TargetSum = sum
Else
'Use a completely random Target Sum (low chance of matching): (Range / 2^ItemCount)'
TargetSum = ((Rnd() * Range / 4) + Range * (3.0 / 8.0)) * ItemCount
End If
'Now see if there is a match'
If SolveOne(TargetSum, ItemCount, Range, Items) Then TotalFound += 1
Next
Return TotalFound
End Function
Public Function SolveOne(ByVal TargetSum As Integer, ByVal ItemCount As Integer _
, ByVal Range As Integer, ByRef Items() As Integer) As Boolean
' Solve a single Subset Sum problem: determine if the TargetSum can be made from'
'the integer items.'
'first split the items into two half-lists: [O(n)]'
Dim H1() As Integer, H2() As Integer
Dim hu1 As Integer, hu2 As Integer
If ItemCount Mod 2 = 0 Then
'even is easy:'
hu1 = (ItemCount / 2) - 1 : hu2 = (ItemCount / 2) - 1
ReDim H1((ItemCount / 2) - 1), H2((ItemCount / 2) - 1)
Else
'odd is a little harder, give the first half the extra item:'
hu1 = ((ItemCount + 1) / 2) - 1 : hu2 = ((ItemCount - 1) / 2) - 1
ReDim H1(hu1), H2(hu2)
End If
For i As Integer = 0 To ItemCount - 1 Step 2
H1(i / 2) = Items(i)
'make sure that H2 doesnt run over on the last item of an odd-numbered list:'
If (i + 1) <= ItemCount - 1 Then
H2(i / 2) = Items(i + 1)
End If
Next
'Now generate all of the sums for each half-list: [O( 2^(n/2) * n )] **(this is the slowest step)'
Dim S1() As Integer, S2() As Integer
Dim sum1 As Integer, sum2 As Integer
Dim su1 As Integer = 2 ^ (hu1 + 1) - 1, su2 As Integer = 2 ^ (hu2 + 1) - 1
ReDim S1(su1), S2(su2)
For i As Integer = 0 To su1
' Use the binary bitmask of our enumerator(i) to select items to use in our candidate sums:'
sum1 = 0 : sum2 = 0
For b As Integer = 0 To hu1
If 0 < (i And Power2(b)) Then
sum1 += H1(b)
If i <= su2 Then sum2 += H2(b)
End If
Next
S1(i) = sum1
If i <= su2 Then S2(i) = sum2
Next
'Sort both lists: [O( 2^(n/2) * n )] **(this is the 2nd slowest step)'
Array.Sort(S1)
Array.Sort(S2)
' Start the first half-sums from lowest to highest,'
'and the second half sums from highest to lowest.'
Dim i1 As Integer = 0, i2 As Integer = su2
' Now do a merge-match on the lists (but reversing S2) and looking to '
'match their sum to the target sum: [O( 2^(n/2) )]'
Dim sum As Integer
Do While i1 <= su1 And i2 >= 0
sum = S1(i1) + S2(i2)
If sum < TargetSum Then
'if the Sum is too low, then we need to increase the ascending side (S1):'
i1 += 1
ElseIf sum > TargetSum Then
'if the Sum is too high, then we need to decrease the descending side (S2):'
i2 -= 1
Else
'Sums match:'
Return True
End If
Loop
'if we got here, then there are no matches to the TargetSum'
Return False
End Function
End Class
Here is the Forms code to go along with it:
Public Class frmSubsetSum
Dim ssm As New SubsetSum
Private Sub btnGo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnGo.Click
Dim Total As Integer
Dim datStart As Date, datEnd As Date
Dim Iterations As Integer, Range As Integer, NumberCount As Integer
Iterations = CInt(txtIterations.Text)
Range = CInt(txtRange.Text)
NumberCount = CInt(txtNumberCount.Text)
ssm.ForceMatch = chkForceMatch.Checked
datStart = Now
Total = ssm.SolveMany(NumberCount, Range, Iterations)
datEnd = Now()
lblStart.Text = datStart.TimeOfDay.ToString
lblEnd.Text = datEnd.TimeOfDay.ToString
lblRate.Text = Format(Iterations / (datEnd - datStart).TotalMilliseconds * 1000, "####0.0")
ListBox1.Items.Insert(0, "Found " & Total.ToString & " Matches out of " & Iterations.ToString & " tries.")
ListBox1.Items.Insert(1, "Tics 0:" & ssm.w0 _
& " 1:" & Format(ssm.w1 - ssm.w0, "###,###,##0") _
& " 1a:" & Format(ssm.w1a - ssm.w1, "###,###,##0") _
& " 2:" & Format(ssm.w2 - ssm.w1a, "###,###,##0") _
& " 3:" & Format(ssm.w3 - ssm.w2, "###,###,##0") _
& " 4:" & Format(ssm.w4 - ssm.w3, "###,###,##0") _
& ", tics/sec = " & Stopwatch.Frequency)
End Sub
End Class
Let me know if you have any questions.