取最佳数集求和的算法

Question

我正在努力寻找算法，将表/列表中的少量资金相加为相等的，或者可能是最接近(但不大于) ceratin数的。

让我以身作则。我有一份有数字的名单：

{ 1.23 ; 3.45 ; 20.11 ; 100.13 ; 200.08 }

我想得到的号码是123.69

所以它应该采取{ 3.45 ; 20.11 ; 100.13 } = 123.69

如果这个数字是122，它不应该是相同的，而是{ 20.11 ; 100.13 ; 1.23 } = 121.47

你知道怎么写那样的东西吗？

Answer 1

这是子集和问题的一个变体，对于只涉及整数的经典问题，使用DP非常容易，并且可以在StackOverflow周围的许多线程中找到答案，比如这一个。

，但是，，您的问题中有一个小的调整，使得它与经典的整数子集和问题略有不同--您所处理的值不一定是整数，它们也有一个十进制值。

在您的例子中，十进制值最多可达2位数“后面的点”。这意味着，您可以轻松地将问题转化为经典整数子集和问题，只需将数组中的所有值乘以100，然后搜索100*x而不是x。

在您的示例中，您需要在整数值{123, 345, 2011, 10013, 20008}的数组中查找12,369个。

附件1:解决整数的SubsetSum问题：

这是使用动态规划完成的，其中DP的递归公式是：

f(x,0) = FALSE if x<0
f(0,0) = TRUE
f(x,i) = f(x,i-1) OR f(x-arr[i], i-1)

通过计算上面的自下而上，您可以得到一个大小为(W*100+1) x (n+1)的矩阵(其中W是所请求的和，n是数组中的元素数)。

通过在最后一行中搜索包含值true的列，您可以找到“最佳”的和数。

附件2：查找数字的实际子集。

到目前为止，你已经找到了你能得到的最好的金额，但还没有找到最好的数字。要做到这一点，您将需要使用您的矩阵(您之前计算的)，并重播您所做的步骤，以生成这个总和。对于这条线中的类似问题，本文对此进行了解释，简单地说，它是通过以下方法实现的：

line <- BEST //best solution found
i <- n
while (i> 0):
  if table[line-array[i]][i-1] == TRUE:
      the element 'i' is in the set
      i <- i-1
      line <- line-array[i]
  else:
      i <- i-1 

Note：如果这太复杂了，而且数组的大小相当小，或者“点后的2小数”限制不是真的--你几乎必须使用指数解--蛮力，它创建所有可能的子集，并从中选择最佳的子集。在这种情况下没有(已知的)有效的解决方案，因为这个问题已知为NP-硬。

tl;dr:将所有值乘以100，然后使用现有的整数子集和问题算法来寻找最佳拟合。

Answer 2

我编写了以下代码，这些代码在VB.NET中工作得很好，但在VBA中有问题。你能帮我找个错误吗？

Dim L() As Integer
bestAll = 0

K = 35.3903

ReDim list(0 To 17) As Integer
ReDim L(0 To 17) As Integer
Dim W As Integer
Dim bool As Boolean

   Dim B(16) As Double
   B(0) = 0.042
   B(1) = 0.1286
   B(2) = 0.1472
   B(3) = 0.1534
   B(4) = 0.2008
   B(5) = 1.4679
   B(6) = 1.5954
   B(7) = 2.6748
   B(8) = 12.1078
   B(9) = 12.1272
   B(10) = 12.4154
   B(11) = 12.4978
   B(12) = 15.4142
   B(13) = 28.3464
   B(14) = 34.8652
   B(15) = 38.1519
   B(16) = 42.8154
For W = 0 To 16
           bool = Proc(0, W, L, 0, B)
        Next W

在这里，函数Proc：

Public Function Proc(best As Double, I As Integer, L() As Integer, count As Integer, A() As Double) As Boolean
        Dim newbest As Double
        newbest = 0
        If ((best + A(I)) <= K) Then
            newbest = best + A(I)
            L(count) = I
            count = count + 1
            If (newbest > bestAll) Then
                bestAll = newbest
                listcount = count
                Dim j1 As Integer
                For j1 = 0 To count - 1
                    list(j1) = L(j1)
                Next j1
            End If
        Else
            Proc = False
        End If
        Dim j2 As Integer
        
        For j2 = I + 1 To wielkosctabeli - 1
            Dim promissin As Boolean
            promissin = Proc(newbest, j2, L, count, A)
            If Not promissin Then
                Exit For
            End If
        Next j2
        Proc = True
    End Function