Knapsack Problem/Visual Basic
<lang vb>Option Explicit
Type TreasureType
Name As String Units As String Value As Currency weight As Single Volume As Single
End Type
Type SolutionType
Desc As String Value As Currency
End Type
Type KnapsackType
Contents() As Integer CapacityWeight As Single CapacityVolume As Single
End Type
Dim Treasures() As TreasureType
Public Sub Main()
SetupTreasureShangriLa Debug.Print CalcKnapsack(25, 0.25)
End Sub
Public Sub SetupTreasureShangriLa()
ReDim Treasures(3) As TreasureType
With Treasures(1)
.Name = "panacea"
.Units = "vials"
.Value = 3000
.weight = 0.3
.Volume = 0.025
End With
With Treasures(2)
.Name = "ichor"
.Units = "ampules"
.Value = 1800
.weight = 0.2
.Volume = 0.015
End With
With Treasures(3)
.Name = "gold"
.Units = "bars"
.Value = 2500
.weight = 2
.Volume = 0.002
End With
End Sub
Public Function CalcKnapsack(ByVal sCapacityWeight As Single, ByVal sCapacityVolume As Single) As String Dim Knapsack As KnapsackType Dim Solution As SolutionType
Knapsack.CapacityVolume = sCapacityVolume Knapsack.CapacityWeight = sCapacityWeight ReDim Knapsack.Contents(UBound(Treasures)) As Integer Call Stuff(Knapsack, Solution, 1) Debug.Print "Maximum value: " & Solution.Value Debug.Print "Ideal Packing(s): " & vbCrLf & Solution.Desc
End Function
Private Sub Stuff(ByRef Knapsack As KnapsackType, ByRef Solution As SolutionType, ByVal nDepth As Integer) Dim nI As Integer Dim curVal As Currency Dim sWeightRemaining As Single Dim sVolumeRemaining As Single Dim nJ As Integer
sWeightRemaining = CalcWeightRemaining(Knapsack) sVolumeRemaining = CalcvolumeRemaining(Knapsack)
With Treasures(nDepth)
If nDepth = UBound(Treasures) Then
Knapsack.Contents(nDepth) = Min(Fix(sWeightRemaining / .weight), Fix(sVolumeRemaining / .Volume))
curVal = CalcValue(Knapsack)
If curVal > Solution.Value Then
Solution.Value = curVal
Solution.Desc = BuildDesc(Knapsack)
ElseIf curVal = Solution.Value Then
Solution.Desc = Solution.Desc & vbCrLf & "or" & vbCrLf & vbCrLf & BuildDesc(Knapsack)
End If
Else
For nI = 0 To Min(Fix(sWeightRemaining / .weight), Fix(sVolumeRemaining / .Volume))
Knapsack.Contents(nDepth) = nI
For nJ = nDepth + 1 To UBound(Treasures)
Knapsack.Contents(nJ) = 0
Next nJ
Call Stuff(Knapsack, Solution, nDepth + 1)
Next nI
End If
End With
End Sub
Private Function CalcValue(ByRef Knapsack As KnapsackType) As Currency Dim curTmp As Currency Dim nI As Integer
For nI = 1 To UBound(Treasures)
curTmp = curTmp + (Treasures(nI).Value * Knapsack.Contents(nI))
Next nI
CalcValue = curTmp
End Function
Private Function Min(ByVal vA As Variant, ByVal vB As Variant) As Variant
If vA < vB Then
Min = vA
Else
Min = vB
End If
End Function
Private Function CalcWeightRemaining(ByRef Knapsack As KnapsackType) As Single Dim sTmp As Single Dim nI As Integer
For nI = 1 To UBound(Treasures)
sTmp = sTmp + (Treasures(nI).weight * Knapsack.Contents(nI))
Next nI
CalcWeightRemaining = Knapsack.CapacityWeight - sTmp
End Function
Private Function CalcvolumeRemaining(ByRef Knapsack As KnapsackType) As Single Dim sTmp As Single Dim nI As Integer
For nI = 1 To UBound(Treasures)
sTmp = sTmp + (Treasures(nI).Volume * Knapsack.Contents(nI))
Next nI
CalcvolumeRemaining = Knapsack.CapacityVolume - sTmp
End Function
Private Function BuildDesc(ByRef Knapsack As KnapsackType) As String Dim cTmp As String Dim nI As Integer
For nI = 1 To UBound(Treasures)
cTmp = cTmp & Knapsack.Contents(nI) & " " & Treasures(nI).Units & " of " & Treasures(nI).Name & vbCrLf
Next nI
BuildDesc = cTmp
End Function</lang>
Output:
Maximum value: 54500 Ideal Packing(s): 0 vials of panacea 15 ampules of ichor 11 bars of gold or 3 vials of panacea 10 ampules of ichor 11 bars of gold or 6 vials of panacea 5 ampules of ichor 11 bars of gold or 9 vials of panacea 0 ampules of ichor 11 bars of gold