User:Eriksiers/Knapsack problem
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