VB 6.0 Knapsack

Option Explicit On
Public Class Form1

Type TreasureType
    Dim Name As String
    Dim Value As Double
    Dim Ratio As Double
    Dim Volume As Double
End Type

Type SolutionType
    Dim Desc As String
    Dim Value As Double
End Type

Type KnapsackType
    Dim Contents() As Double
    Dim CapacityWeight As Double
    Dim CapacityVolume As Double
End Type

    Dim Treasures() As TreasureType

    Public Sub Main()

        SetupTreasureShangriLa()
        'call knapsack
        'Debug.Print(CalcKnapsack(25, 0.25))

    End Sub

    Public Sub SetupTreasureShangriLa()
        'add data in array
    ReDim Treasures(11) As TreasureType
        With Treasures(1)
            .Name = "Bed"
            .Value = 1200
            .Ratio = 2.67
            .Volume = 450
        End With
        With Treasures(2)
            .Name = "Dining Room Set"
            .Value = 1800
            .Ratio = 2.81
            .Volume = 640
        End With
        With Treasures(3)
            .Name = "Sofa Set"
            .Value = 5000
            .Ratio = 5.1
            .Volume = 980
        End With
        With Treasures(4)
            .Name = "TV set"
            .Value = 1900
            .Ratio = 9.5
            .Volume = 200
        End With
        With Treasures(5)
            .Name = "Hi Fi set"
            .Value = 2600
            .Ratio = 9.63
            .Volume = 270
        End With
        With Treasures(6)
            .Name = "Sofa bed"
            .Value = 1300
            .Ratio = 3.71
            .Volume = 350
        End With
        With Treasures(7)
            .Name = "Recliner"
            .Value = 900
            .Ratio = 3.0
            .Volume = 300
        End With
        With Treasures(8)
            .Name = "Refrigerator"
            .Value = 1300
            .Ratio = 2.89
            .Volume = 450
        End With
        With Treasures(9)
            .Name = "Washer & drier"
            .Value = 1600
            .Ratio = 2.0
            .Volume = 800
        End With
        With Treasures(10)
            .Name = "Wall Cabinet"
            .Value = 1800
            .Ratio = 3.0
            .Volume = 600
        End With
        With Treasures(11)
            .Name = "Chest"
            .Value = 1400
            .Ratio = 2.8
            .Volume = 500
        End With
    End Sub

    Public Function CalcKnapsack(ByVal sCapacityRatio As Double, ByVal sCapacityVolume As Double) As String
        Dim Knapsack As KnapsackType
        Dim Solution As SolutionType

        Knapsack.CapacityVolume = sCapacityVolume
        Knapsack.CapacityRatio = sCapacityRatio
    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

    [i]Private Sub Stuff(ByRef Knapsack As KnapsackType, ByRef Solution As SolutionType, ByVal nDepth As Integer)[/i]
        Dim nI As Integer
        Dim curVal As Double
        Dim sWeightRemaining As Single
        Dim sVolumeRemaining As Single
        Dim nJ As Integer

        sWeightRemaining = CalcRatioRemaining(Knapsack)
        sVolumeRemaining = CalcvolumeRemaining(Knapsack)
        ' insert algorithm knapsack
        ' call calculate ratio
        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 Double
        Dim curTmp As Double
        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 Object, ByVal vB As Object) As Object

        If vA < vB Then
            Min = vA
        Else
            Min = vB
        End If

    End Function

    Private Function CalcRatioRemaining(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

        CalcRatioRemaining = 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
End Class