Knapsack Problem/Visual Basic

From Rosetta Code
Knapsack Problem/Visual Basic is part of Knapsack Problem. You may find other members of Knapsack Problem at Category:Knapsack Problem.
Works with: Visual Basic version 6.0
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

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