VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsNapSack"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Event Error(Description As String)
Event Solved(selection() As Byte, value As Double)

Private m_weights() As Double
Private m_values() As Double
Private m_best() As Byte
Private m_bestvalue As Double
Private m_maxweight As Double
Private m_items As Double

Private Sub ShellSort(itemindex() As Long, descending As Boolean)
    
    'modified shell sort to sort 3 arrays by array1/array2
    
    Dim index As Long, index2 As Long
    Dim firstItem As Long, itemcount As Long
    Dim inverseOrder As Boolean
    Dim distance As Long, tmpstore As Double
    Dim value1 As Double, value2 As Double, value3 As Byte
    
    firstItem = LBound(m_weights())
    itemcount = UBound(m_weights())
    ' find the best value for distance
    Do
        distance = distance * 3 + 1
    Loop Until distance > itemcount
    ' sort the array
    Do
        distance = distance \ 3
        For index = distance + 1 To itemcount
            value1 = m_values(index)
            value2 = m_weights(index)
            value3 = itemindex(index)
            index2 = index
            Do While (m_values(index2 - distance) / m_weights(index2 - distance)) > (value1 / value2) Xor descending
                tmpstore = index2 - distance
                m_values(index2) = m_values(tmpstore)
                m_weights(index2) = m_weights(tmpstore)
                itemindex(index2) = itemindex(tmpstore)
                index2 = tmpstore
                If index2 <= distance Then Exit Do
            Loop
            m_values(index2) = value1
            m_weights(index2) = value2
            itemindex(index2) = value3
        Next
    Loop Until distance = 1
    
End Sub

Private Sub Kolesar(capacity As Double)
    
    'Solves the 0-1 knapsack problem
    'using Kolesar's method
    
    'items must be sorted by value/weight
    'in descending order
    'value(i) corresponds to weight(i) for item i
    
    'items = no. of items
    'values() = item values
    'weights() = item weight
    'capacity = max. weight to be carried by napsack
    
    'initialise
    Dim stored() As Byte
    
    ReDim m_best(m_items)
    ReDim stored(m_items)
    
    m_maxweight = capacity
    m_bestweight = -1
    
    'begin
    EvalNode stored(), 0, 0, 0

End Sub

Private Sub EvalNode(tmpstore() As Byte, ByVal last As Long, ByVal weight As Long, ByVal value As Long)
    
    Dim i As Long
    
    Dim stored() As Byte
    ReDim stored(m_items)
    
    CopyMemory stored(0), tmpstore(0), m_items
    
    Do While last < m_items
        If weight + m_weights(last) > m_maxweight Then
            last = last + 1 'try the next item as this one doesn't fit
            EvalNode stored(), last, weight, value
        Else
            value = value + m_values(last)
            If m_maxweight = weight + m_weights(last) Then
                stored(last) = 1 'possible solution
                Exit Do
            Else
                weight = weight + m_weights(last)
                last = last + 1
                If value + m_values(last) * m_weights(last) / (m_maxweight - weight) <= bestvalue Then
                    Exit Do 'this branch has been fathomed
                            'no possible improvements on our best result
                Else
                    stored(last) = 1
                    EvalNode stored(), last, weight, value 'continue with evaluation of this path
                End If
            End If
            If value > m_bestvalue Then 'best solution so far
                m_bestvalue = value
                For i = 0 To m_items
                    m_best(i) = stored(i)
                Next
            End If
        End If
    Loop
    
End Sub

Public Sub NapSack(values() As Double, weights() As Double, capacity As Double)

    Dim i As Long
    Dim result() As Byte
    Dim itemcount As Double
    Dim itemindex() As Long
    
    itemcount = UBound(weights())
    
    ReDim result(itemcount)
    ReDim itemindex(itemcount)
    ReDim m_weights(itemcount)
    ReDim m_values(itemcount)
    
    'remember original order of items
    For i = 0 To itemcount
        itemindex(i) = i
    Next
    
    'check arrays have same no. of elements
    m_items = itemcount
    If UBound(values()) - 1 <> itemcount Then
        RaiseEvent Error("Each value must have a corresponding weight")
    End If
        
    'copy entire arrays
    CopyMemory m_values(0), values(0), (itemcount + 1) * 8
    CopyMemory m_weights(0), weights(0), (itemcount + 1) * 8
    
    ShellSort itemindex(), True
    Kolesar capacity
    
    'revert to original order
    For i = 0 To itemcount
        result(i) = m_best(itemindex(i))
    Next
    
    RaiseEvent Solved(result(), m_bestvalue)
    
End Sub