I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

User:Eriksiers/Knapsack problem

From Rosetta Code

This is my not-quite-working version of another VB solution to the unbounded knapsack problem. (The actual solution is Knapsack Problem/Visual Basic.) I didn't base this version on the one that's posted; I wanted to do it all on my lonesome. It's significantly shorter than the actual solution, but...

I didn't put it up there because there's something not quite right here; it goes over the limits by one panacea and one gold. Also, it picks the first version that works, and doesn't list all solutions (but I think I could handle that in just a few lines.) Also also, it doesn't go through all permutations of the list.

Maybe I'll fix it some day, maybe not. Probably not.

Type item
name As String
value As Long
weight As Long ' divide by 10 for actual weight
volume As Long ' divide by 1000 for actual volume
End Type
 
Private treasures(2) As item
 
Const MAX_WEIGHT = 250
Const MAX_VOLUME = 250
 
Private Sub buildTable()
With treasures(0)
.name = "panacea"
.value = 3000
.weight = 3
.volume = 25
End With
With treasures(1)
.name = "ichor"
.value = 1800
.weight = 2
.volume = 15
End With
With treasures(2)
.name = "gold"
.value = 2500
.weight = 20
.volume = 2
End With
End Sub
 
Sub BruteForceFillBackpack()
Dim L0 As Long, L1 As Long, L2 As Long
Dim volumeLeft As Long, weightLeft As Long
Dim tmpVl As Long, tmpWt As Long, tmpNum As Long
 
Dim maxTake(2) As Long
 
Dim finalChoice(2) As Long, finalValue As Long, outP As String
 
buildTable
 
tmpVl = MAX_VOLUME \ treasures(0).volume
tmpWt = MAX_WEIGHT \ treasures(0).weight
maxTake(0) = IIf(tmpVl < tmpWt, tmpVl, tmpWt) 'lower number needed

For L0 = 0 To maxTake(0)
volumeLeft = MAX_VOLUME - (treasures(0).volume * L0)
weightLeft = MAX_WEIGHT - (treasures(0).weight * L0)
 
tmpVl = volumeLeft \ treasures(1).volume
tmpWt = weightLeft \ treasures(1).weight
maxTake(1) = IIf(tmpVl < tmpWt, tmpVl, tmpWt) 'lower number again
For L1 = 0 To maxTake(1)
volumeLeft = MAX_VOLUME - (treasures(1).volume * L1)
weightLeft = MAX_WEIGHT - (treasures(1).weight * L1)
 
tmpVl = volumeLeft \ treasures(2).volume
tmpWt = weightLeft \ treasures(2).weight
maxTake(2) = IIf(tmpVl < tmpWt, tmpVl, tmpWt) 'and again

tmpNum = (treasures(0).value * L0) + (treasures(1).value * L1) + (treasures(2).value * maxTake(2))
If tmpNum > finalValue Then
finalChoice(0) = L0
finalChoice(1) = L1
finalChoice(2) = maxTake(2)
finalValue = tmpNum
End If
Next
Next
 
For L0 = 0 To 2
outP = outP & treasures(L0).name & ":" & finalChoice(L0) & vbNewLine
Next
outP = outP & "Total value:" & finalValue & vbNewLine
outP = outP & "Total weight:" & Str$(((treasures(0).weight * finalChoice(0)) + (treasures(1).weight * finalChoice(1)) + (treasures(2).weight * finalChoice(2))) / 10!) & vbNewLine
outP = outP & "Total volume:" & Str$(((treasures(0).volume * finalChoice(0)) + (treasures(1).volume * finalChoice(1)) + (treasures(2).volume * finalChoice(2))) / 1000!)
 
MsgBox outP
End Sub