v2_optimized

Option Explicit

' ============================================================
' CORELDRAW BANNER AUTO NESTING V3
'
' MODEL A - REAL OBJECT NESTING
'
' OPTIMIZATION:
'   1. All objects must be placed
'   2. Right waste target <= 10 cm
'   3. Left edge alignment
'   4. Top edge alignment
'   5. Minimum material
'
' MULTI START:
'   6 sorting strategies
'   x
'   4 MaxRects fitness strategies (BSSF, BAF, BLSF, Contact Point)
'
' V3 CHANGES FROM V2:
'   - Alignment penalty is now blended directly into the
'     placement score (not just an EPS tie-break).
'   - New "Contact Point" fitness strategy (fitMode = 4):
'     maximizes touching edge length with the roll wall
'     and already-placed objects.
'   - Small height bias added to placement scoring, nudging
'     the packer toward a shorter overall bounding box.
'   - Free rectangle list is merged (adjacent free rects
'     combined) in addition to being pruned, reducing
'     fragmentation of the search space.
'   - Post-processing local search (RebalanceRolls): tries to
'     drain the last roll into earlier rolls to cut roll count
'     and material further after the multi-start search.
'   - Removed dead/overwritten assignment in
'     ApplyNestingToObjects.
'
' NO:
'   - dummy rectangles
'   - labels
'   - layout shapes
'
' YES:
'   - real CorelDRAW objects
'   - 90 degree rotation
'   - multiple roll widths
' ============================================================


' ============================================================
' CONSTANTS
' ============================================================

Private Const EPS As Double = 0.000001

Private Const ROLL_GAP As Double = 5#

Private Const MAX_ROLLS As Long = 100

' Target maximum unused width at right side.
Private Const MAX_RIGHT_WASTE As Double = 10#

' Objects whose edges differ by <= this value
' are considered aligned.
Private Const ALIGN_TOLERANCE As Double = 0.5

' Weight applied to the alignment penalty when it is blended
' directly into the per-placement score. Alignment penalty is
' measured in cm, same scale as BSSF/BLSF leftover distances,
' so this acts as a meaningful nudge for those modes. For BAF
' (area-based, cm^2) the alignment contribution is relatively
' smaller by nature of the scale difference -- this is
' intentional: BAF still optimizes area first, alignment only
' breaks near-ties.
Private Const W_ALIGN As Double = 2#

' Small weight biasing placement toward a lower resulting top
' edge (y + h), which nudges the packer to keep the overall
' bounding box shorter. Kept small so it only matters when
' fitness/alignment are close.
Private Const W_HEIGHT As Double = 0.001

' ============================================================
' DATA TYPES
' ============================================================

Private Type TBanner

    Label As String

    OrigW As Double
    OrigH As Double

    margin As Double

End Type


Private Type TFreeRect

    x As Double
    y As Double

    w As Double
    h As Double

End Type


Private Type TPlaced

    rid As Long

    x As Double
    y As Double

    w As Double
    h As Double

    Rotated As Boolean

End Type


Private Type TRoll

    placed() As TPlaced

    placedCount As Long

    UsedHeight As Double

End Type


' ============================================================
' BASIC MATH
' ============================================================

Private Function MinD(ByVal a As Double, ByVal b As Double) As Double

    If a < b Then
        MinD = a
    Else
        MinD = b
    End If

End Function


Private Function MaxD(ByVal a As Double, ByVal b As Double) As Double

    If a > b Then
        MaxD = a
    Else
        MaxD = b
    End If

End Function


Private Function AbsD(ByVal a As Double) As Double

    If a < 0# Then
        AbsD = -a
    Else
        AbsD = a
    End If

End Function


Private Function AreaOf(ByRef item As TBanner) As Double

    AreaOf = _
        (item.OrigW + 2# * item.margin) * _
        (item.OrigH + 2# * item.margin)

End Function


' ============================================================
' SORT VALUE
'
' 1 = Area descending
' 2 = Width descending
' 3 = Height descending
' 4 = Short side descending
' 5 = Long side descending
' 6 = Aspect ratio descending
' ============================================================

Private Function SortValue(ByRef item As TBanner, ByVal sortMode As Long) As Double

    Dim w As Double
    Dim h As Double

    Dim shortSide As Double
    Dim longSide As Double

    w = item.OrigW + 2# * item.margin
    h = item.OrigH + 2# * item.margin

    shortSide = MinD(w, h)
    longSide = MaxD(w, h)

    Select Case sortMode

        Case 1

            SortValue = w * h

        Case 2

            SortValue = w

        Case 3

            SortValue = h

        Case 4

            SortValue = shortSide

        Case 5

            SortValue = longSide

        Case 6

            If shortSide > EPS Then
                SortValue = longSide / shortSide
            Else
                SortValue = 0#
            End If

        Case Else

            SortValue = w * h

    End Select

End Function


' ============================================================
' SORT INDEX
' ============================================================

Private Sub SortIndex(ByRef items() As TBanner, ByRef sourceIdx() As Long, ByVal n As Long, ByVal sortMode As Long, ByRef sortedIdx() As Long)

    Dim i As Long
    Dim j As Long

    Dim tmp As Long

    ReDim sortedIdx(1 To n)

    For i = 1 To n

        sortedIdx(i) = sourceIdx(i)

    Next i


    For i = 1 To n - 1

        For j = i + 1 To n

            If SortValue(items(sortedIdx(j)), sortMode) > SortValue(items(sortedIdx(i)), sortMode) Then

                tmp = sortedIdx(i)

                sortedIdx(i) = sortedIdx(j)
                sortedIdx(j) = tmp

            End If

        Next j

    Next i

End Sub


' ============================================================
' RECTANGLE INTERSECTION
' ============================================================

Private Function RectsIntersect(ByRef a As TFreeRect, ByRef b As TFreeRect) As Boolean

    If a.x >= b.x + b.w - EPS Then

        RectsIntersect = False

        Exit Function

    End If


    If b.x >= a.x + a.w - EPS Then

        RectsIntersect = False

        Exit Function

    End If


    If a.y >= b.y + b.h - EPS Then

        RectsIntersect = False

        Exit Function

    End If


    If b.y >= a.y + a.h - EPS Then

        RectsIntersect = False

        Exit Function

    End If


    RectsIntersect = True

End Function


' ============================================================
' RECTANGLE CONTAINMENT
' ============================================================

Private Function IsContained(ByRef a As TFreeRect, ByRef b As TFreeRect) As Boolean

    If a.x + EPS < b.x Then

        IsContained = False

        Exit Function

    End If


    If a.y + EPS < b.y Then

        IsContained = False

        Exit Function

    End If


    If a.x + a.w > b.x + b.w + EPS Then

        IsContained = False

        Exit Function

    End If


    If a.y + a.h > b.y + b.h + EPS Then

        IsContained = False

        Exit Function

    End If


    IsContained = True

End Function


' ============================================================
' PRUNE FREE RECTANGLES
' ============================================================

Private Sub PruneFree(ByRef freeRects() As TFreeRect, ByRef freeCount As Long)

    Dim i As Long
    Dim j As Long
    Dim k As Long

    Dim contained As Boolean


    If freeCount <= 1 Then Exit Sub


    i = 1


    Do While i <= freeCount

        contained = False


        For j = 1 To freeCount

            If i <> j Then

                If IsContained(freeRects(i), freeRects(j)) Then

                    contained = True

                    Exit For

                End If

            End If

        Next j


        If contained Then

            For k = i To freeCount - 1

                freeRects(k) = freeRects(k + 1)

            Next k


            freeCount = freeCount - 1


        Else

            i = i + 1

        End If

    Loop


    If freeCount <= 0 Then

        ReDim freeRects(1 To 1)

    Else

        ReDim Preserve freeRects(1 To freeCount)

    End If

End Sub


' ============================================================
' MERGE ADJACENT FREE RECTANGLES
'
' Combines free rectangles that share a full edge (same
' opposite dimension and touching side) into one larger
' rectangle. Reduces fragmentation left behind by PruneFree,
' giving later placements more/larger candidate free rects
' to choose from.
' ============================================================

Private Sub MergeFreeRects(ByRef freeRects() As TFreeRect, ByRef freeCount As Long)

    Dim i As Long
    Dim j As Long
    Dim k As Long

    Dim merged As Boolean

    Dim a As TFreeRect
    Dim b As TFreeRect


    If freeCount <= 1 Then Exit Sub


    Do

        merged = False


        i = 1

        Do While i <= freeCount And Not merged

            j = i + 1

            Do While j <= freeCount And Not merged

                a = freeRects(i)
                b = freeRects(j)


                ' Horizontal merge: same y and h, touching left/right edge
                If AbsD(a.y - b.y) <= EPS And AbsD(a.h - b.h) <= EPS Then

                    If AbsD((a.x + a.w) - b.x) <= EPS Then

                        freeRects(i).w = a.w + b.w

                        For k = j To freeCount - 1
                            freeRects(k) = freeRects(k + 1)
                        Next k

                        freeCount = freeCount - 1

                        merged = True

                    ElseIf AbsD((b.x + b.w) - a.x) <= EPS Then

                        freeRects(i).x = b.x
                        freeRects(i).w = a.w + b.w

                        For k = j To freeCount - 1
                            freeRects(k) = freeRects(k + 1)
                        Next k

                        freeCount = freeCount - 1

                        merged = True

                    End If

                End If


                ' Vertical merge: same x and w, touching top/bottom edge
                If Not merged Then

                    If AbsD(a.x - b.x) <= EPS And AbsD(a.w - b.w) <= EPS Then

                        If AbsD((a.y + a.h) - b.y) <= EPS Then

                            freeRects(i).h = a.h + b.h

                            For k = j To freeCount - 1
                                freeRects(k) = freeRects(k + 1)
                            Next k

                            freeCount = freeCount - 1

                            merged = True

                        ElseIf AbsD((b.y + b.h) - a.y) <= EPS Then

                            freeRects(i).y = b.y
                            freeRects(i).h = a.h + b.h

                            For k = j To freeCount - 1
                                freeRects(k) = freeRects(k + 1)
                            Next k

                            freeCount = freeCount - 1

                            merged = True

                        End If

                    End If

                End If


                j = j + 1

            Loop

            i = i + 1

        Loop

    Loop While merged


    If freeCount <= 0 Then

        ReDim freeRects(1 To 1)

    Else

        ReDim Preserve freeRects(1 To freeCount)

    End If

End Sub


' ============================================================
' ADD VALID FREE RECTANGLE
' ============================================================

Private Sub AddIfValid(ByRef arr() As TFreeRect, ByRef count As Long, ByVal x As Double, ByVal y As Double, ByVal w As Double, ByVal h As Double)

    If w <= EPS Then Exit Sub

    If h <= EPS Then Exit Sub


    count = count + 1


    arr(count).x = x
    arr(count).y = y

    arr(count).w = w
    arr(count).h = h

End Sub


' ============================================================
' SPLIT FREE RECTANGLES
' ============================================================

Private Sub PlaceAndSplit(ByRef freeRects() As TFreeRect, ByRef freeCount As Long, ByVal placedX As Double, ByVal placedY As Double, ByVal placedW As Double, ByVal placedH As Double)

    Dim oldCount As Long
    Dim newCount As Long

    Dim maxNew As Long

    Dim i As Long

    Dim fr As TFreeRect
    Dim placed As TFreeRect

    Dim tmp() As TFreeRect


    oldCount = freeCount


    If oldCount <= 0 Then Exit Sub


    maxNew = oldCount * 4 + 10


    ReDim tmp(1 To maxNew)


    placed.x = placedX
    placed.y = placedY

    placed.w = placedW
    placed.h = placedH


    For i = 1 To oldCount

        fr = freeRects(i)


        If Not RectsIntersect(fr, placed) Then

            AddIfValid tmp, newCount, fr.x, fr.y, fr.w, fr.h


        Else

            ' LEFT

            AddIfValid tmp, newCount, _
                       fr.x, _
                       fr.y, _
                       placed.x - fr.x, _
                       fr.h


            ' RIGHT

            AddIfValid tmp, newCount, _
                       placed.x + placed.w, _
                       fr.y, _
                       (fr.x + fr.w) - (placed.x + placed.w), _
                       fr.h


            ' BOTTOM

            AddIfValid tmp, newCount, _
                       fr.x, _
                       fr.y, _
                       fr.w, _
                       placed.y - fr.y


            ' TOP

            AddIfValid tmp, newCount, _
                       fr.x, _
                       placed.y + placed.h, _
                       fr.w, _
                       (fr.y + fr.h) - (placed.y + placed.h)

        End If

    Next i


    If newCount <= 0 Then

        ReDim freeRects(1 To 1)

        freeCount = 0

        Exit Sub

    End If


    ReDim freeRects(1 To newCount)


    For i = 1 To newCount

        freeRects(i) = tmp(i)

    Next i


    freeCount = newCount


    PruneFree freeRects, freeCount

    MergeFreeRects freeRects, freeCount

End Sub


' ============================================================
' CONTACT LENGTH (for Contact Point fitness)
'
' Total length of edges of the candidate rectangle that
' touch the roll's left/bottom wall or an already-placed
' rectangle. Higher = tighter fit against neighbors.
' ============================================================

Private Function ContactLength(ByVal candX As Double, ByVal candY As Double, ByVal rw As Double, ByVal rh As Double, ByRef placed() As TPlaced, ByVal placedCount As Long) As Double

    Dim i As Long

    Dim total As Double
    Dim overlapLen As Double

    Dim px As Double
    Dim py As Double
    Dim pw As Double
    Dim ph As Double


    total = 0#


    ' Contact with roll's left wall
    If AbsD(candX - 0#) <= EPS Then
        total = total + rh
    End If

    ' Contact with roll's bottom edge
    If AbsD(candY - 0#) <= EPS Then
        total = total + rw
    End If


    For i = 1 To placedCount

        px = placed(i).x
        py = placed(i).y
        pw = placed(i).w
        ph = placed(i).h


        ' Shared vertical edge (left-right touching)
        If AbsD(candX - (px + pw)) <= EPS Or AbsD((candX + rw) - px) <= EPS Then

            overlapLen = MinD(candY + rh, py + ph) - MaxD(candY, py)

            If overlapLen > 0# Then
                total = total + overlapLen
            End If

        End If


        ' Shared horizontal edge (bottom-top touching)
        If AbsD(candY - (py + ph)) <= EPS Or AbsD((candY + rh) - py) <= EPS Then

            overlapLen = MinD(candX + rw, px + pw) - MaxD(candX, px)

            If overlapLen > 0# Then
                total = total + overlapLen
            End If

        End If

    Next i


    ContactLength = total

End Function


' ============================================================
' PLACEMENT SCORE
'
' 1 = BSSF
' 2 = BAF
' 3 = BLSF
' 4 = Contact Point (maximize touching perimeter)
'
' Lower returned value = better, consistently across modes
' (mode 4 returns a negated contact length so that more
' contact still means "lower/better").
' ============================================================

Private Function PlacementScore(ByRef fr As TFreeRect, ByVal rw As Double, ByVal rh As Double, ByVal fitMode As Long, ByVal candX As Double, ByVal candY As Double, ByRef placed() As TPlaced, ByVal placedCount As Long) As Double

    Dim leftoverW As Double
    Dim leftoverH As Double

    Dim areaWaste As Double

    Dim contact As Double


    Select Case fitMode

        Case 1

            leftoverW = fr.w - rw
            leftoverH = fr.h - rh

            PlacementScore = MinD(leftoverW, leftoverH)


        Case 2

            areaWaste = (fr.w * fr.h) - (rw * rh)

            PlacementScore = areaWaste


        Case 3

            leftoverW = fr.w - rw
            leftoverH = fr.h - rh

            PlacementScore = MaxD(leftoverW, leftoverH)


        Case 4

            contact = ContactLength(candX, candY, rw, rh, placed, placedCount)

            PlacementScore = -contact


        Case Else

            leftoverW = fr.w - rw
            leftoverH = fr.h - rh

            PlacementScore = MinD(leftoverW, leftoverH)

    End Select

End Function


' ============================================================
' FIND MINIMUM ALIGNMENT DISTANCE
'
' Checks candidate left edge against existing left edges.
'
' Checks candidate top edge against existing top edges.
' ============================================================

Private Function AlignmentPenalty(ByRef placed() As TPlaced, ByVal placedCount As Long, ByVal x As Double, ByVal y As Double, ByVal w As Double, ByVal h As Double) As Double

    Dim i As Long

    Dim leftDist As Double
    Dim topDist As Double

    Dim candidateTop As Double

    Dim existingTop As Double

    Dim bestLeft As Double
    Dim bestTop As Double

    Dim alignedLeft As Boolean
    Dim alignedTop As Boolean


    If placedCount <= 0 Then

        AlignmentPenalty = 0#

        Exit Function

    End If


    bestLeft = 1E+30
    bestTop = 1E+30


    candidateTop = y + h


    For i = 1 To placedCount

        leftDist = AbsD(x - placed(i).x)

        existingTop = placed(i).y + placed(i).h

        topDist = AbsD(candidateTop - existingTop)


        If leftDist < bestLeft Then

            bestLeft = leftDist

        End If


        If topDist < bestTop Then

            bestTop = topDist

        End If

    Next i


    alignedLeft = (bestLeft <= ALIGN_TOLERANCE)

    alignedTop = (bestTop <= ALIGN_TOLERANCE)


    If alignedLeft Then

        bestLeft = 0#

    End If


    If alignedTop Then

        bestTop = 0#

    End If


    ' The smaller the value, the better.
    '
    ' Strong preference for straight cut lines.
    AlignmentPenalty = bestLeft + bestTop

End Function


' ============================================================
' CHECK WHETHER POSITION IS BETTER
'
' V3: alignment is already folded into "score" by the caller,
' so this only needs score, then y, then x as tie-breakers.
' ============================================================

Private Function IsBetterPlacement(ByVal score As Double, ByVal tieY As Double, ByVal tieX As Double, ByVal bestScore As Double, ByVal bestY As Double, ByVal bestX As Double) As Boolean

    If score < bestScore - EPS Then

        IsBetterPlacement = True

        Exit Function

    End If


    If AbsD(score - bestScore) <= EPS Then

        If tieY < bestY - EPS Then

            IsBetterPlacement = True

            Exit Function

        End If


        If AbsD(tieY - bestY) <= EPS Then

            If tieX < bestX - EPS Then

                IsBetterPlacement = True

                Exit Function

            End If

        End If

    End If


    IsBetterPlacement = False

End Function


' ============================================================
' FIND BEST PLACEMENT
'
' V3: combines base fitness score, alignment penalty (W_ALIGN)
' and a height bias (W_HEIGHT) into one combined score before
' comparing candidates, so alignment now genuinely influences
' which free rectangle gets chosen, not just a rare EPS tie.
' ============================================================

Private Function FindBestPlacement(ByRef freeRects() As TFreeRect, ByVal freeCount As Long, ByVal reqW As Double, ByVal reqH As Double, ByVal allowRotation As Boolean, ByVal fitMode As Long, ByRef placed() As TPlaced, ByVal placedCount As Long, ByRef bestX As Double, ByRef bestY As Double, ByRef bestW As Double, ByRef bestH As Double, ByRef bestRot As Boolean) As Boolean

    Dim i As Long

    Dim rw As Double
    Dim rh As Double

    Dim baseScore As Double
    Dim alignScore As Double
    Dim heightBias As Double

    Dim combinedScore As Double

    Dim bestScore As Double

    Dim tieY As Double
    Dim tieX As Double

    Dim bestTieY As Double
    Dim bestTieX As Double

    Dim found As Boolean


    bestScore = 1E+30

    bestTieY = 1E+30
    bestTieX = 1E+30

    found = False


    For i = 1 To freeCount

        ' ====================================================
        ' NORMAL
        ' ====================================================

        rw = reqW
        rh = reqH


        If rw <= freeRects(i).w + EPS And rh <= freeRects(i).h + EPS Then

            baseScore = PlacementScore(freeRects(i), rw, rh, fitMode, freeRects(i).x, freeRects(i).y, placed, placedCount)

            alignScore = AlignmentPenalty(placed, placedCount, freeRects(i).x, freeRects(i).y, rw, rh)

            heightBias = freeRects(i).y + rh

            combinedScore = baseScore + alignScore * W_ALIGN + heightBias * W_HEIGHT

            tieY = freeRects(i).y
            tieX = freeRects(i).x


            If IsBetterPlacement(combinedScore, tieY, tieX, bestScore, bestTieY, bestTieX) Then

                bestScore = combinedScore

                bestTieY = tieY
                bestTieX = tieX

                bestX = freeRects(i).x
                bestY = freeRects(i).y

                bestW = rw
                bestH = rh

                bestRot = False

                found = True

            End If

        End If


        ' ====================================================
        ' ROTATED
        ' ====================================================

        If allowRotation Then

            rw = reqH
            rh = reqW


            If rw <= freeRects(i).w + EPS And rh <= freeRects(i).h + EPS Then

                baseScore = PlacementScore(freeRects(i), rw, rh, fitMode, freeRects(i).x, freeRects(i).y, placed, placedCount)

                alignScore = AlignmentPenalty(placed, placedCount, freeRects(i).x, freeRects(i).y, rw, rh)

                heightBias = freeRects(i).y + rh

                combinedScore = baseScore + alignScore * W_ALIGN + heightBias * W_HEIGHT

                tieY = freeRects(i).y
                tieX = freeRects(i).x


                If IsBetterPlacement(combinedScore, tieY, tieX, bestScore, bestTieY, bestTieX) Then

                    bestScore = combinedScore

                    bestTieY = tieY
                    bestTieX = tieX

                    bestX = freeRects(i).x
                    bestY = freeRects(i).y

                    bestW = rw
                    bestH = rh

                    bestRot = True

                    found = True

                End If

            End If

        End If

    Next i


    FindBestPlacement = found

End Function


' ============================================================
' PACK ONE ROLL
' ============================================================

Private Sub PackOneBin(ByRef items() As TBanner, ByRef sourceIdx() As Long, ByVal n As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal sortMode As Long, ByVal fitMode As Long, ByRef placed() As TPlaced, ByRef placedCount As Long, ByRef outIdx() As Long, ByRef outCount As Long)

    Dim freeRects() As TFreeRect
    Dim sortedIdx() As Long

    Dim freeCount As Long

    Dim k As Long
    Dim rid As Long

    Dim reqW As Double
    Dim reqH As Double

    Dim bestX As Double
    Dim bestY As Double

    Dim bestW As Double
    Dim bestH As Double

    Dim bestRot As Boolean


    ReDim placed(1 To n)

    ReDim outIdx(1 To n)


    placedCount = 0
    outCount = 0


    ReDim freeRects(1 To 1)

    freeCount = 1


    freeRects(1).x = 0#
    freeRects(1).y = 0#

    freeRects(1).w = rollWidth
    freeRects(1).h = maxHeight


    SortIndex items, sourceIdx, n, sortMode, sortedIdx


    For k = 1 To n

        rid = sortedIdx(k)


        reqW = items(rid).OrigW + 2# * items(rid).margin

        reqH = items(rid).OrigH + 2# * items(rid).margin


        If FindBestPlacement(freeRects, freeCount, reqW, reqH, allowRotation, fitMode, placed, placedCount, bestX, bestY, bestW, bestH, bestRot) Then

            placedCount = placedCount + 1


            placed(placedCount).rid = rid

            placed(placedCount).x = bestX
            placed(placedCount).y = bestY

            placed(placedCount).w = bestW
            placed(placedCount).h = bestH

            placed(placedCount).Rotated = bestRot


            PlaceAndSplit freeRects, freeCount, bestX, bestY, bestW, bestH


        Else

            outCount = outCount + 1

            outIdx(outCount) = rid

        End If

    Next k

End Sub


' ============================================================
' PACK MULTIPLE ROLLS
' ============================================================

Private Sub PackMultiRoll(ByRef items() As TBanner, ByVal n As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal sortMode As Long, ByVal fitMode As Long, ByRef rolls() As TRoll, ByRef rollCount As Long, ByRef notPlaced As Long)

    Dim remaining() As Long
    Dim nextRemaining() As Long

    Dim placed() As TPlaced
    Dim outIdx() As Long

    Dim remainingCount As Long
    Dim outCount As Long
    Dim placedCount As Long

    Dim i As Long
    Dim safety As Long


    rollCount = 0
    notPlaced = 0


    If n <= 0 Then Exit Sub


    ReDim rolls(1 To MAX_ROLLS)

    ReDim remaining(1 To n)


    For i = 1 To n

        remaining(i) = i

    Next i


    remainingCount = n


    Do While remainingCount > 0

        safety = safety + 1


        If safety > MAX_ROLLS Then

            notPlaced = remainingCount

            Exit Do

        End If


        PackOneBin items, remaining, remainingCount, rollWidth, maxHeight, allowRotation, sortMode, fitMode, placed, placedCount, outIdx, outCount


        If placedCount <= 0 Then

            notPlaced = remainingCount

            Exit Do

        End If


        rollCount = rollCount + 1


        rolls(rollCount).placedCount = placedCount


        ReDim rolls(rollCount).placed(1 To placedCount)


        For i = 1 To placedCount

            rolls(rollCount).placed(i) = placed(i)

        Next i


        rolls(rollCount).UsedHeight = CalcPlacedHeight(placed, placedCount)


        If outCount <= 0 Then

            remainingCount = 0

            Exit Do

        End If


        ReDim nextRemaining(1 To outCount)


        For i = 1 To outCount

            nextRemaining(i) = outIdx(i)

        Next i


        ReDim remaining(1 To outCount)


        For i = 1 To outCount

            remaining(i) = nextRemaining(i)

        Next i


        remainingCount = outCount

    Loop

End Sub


' ============================================================
' BUILD FREE RECTS FROM AN EXISTING PLACED LIST
'
' Reconstructs the free-rectangle map for a roll from its
' current placed items, so the rebalancing local search can
' test whether an extra item fits into that roll.
' ============================================================

Private Sub BuildFreeRects(ByRef placed() As TPlaced, ByVal placedCount As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByRef freeRects() As TFreeRect, ByRef freeCount As Long)

    Dim i As Long


    ReDim freeRects(1 To 1)

    freeCount = 1


    freeRects(1).x = 0#
    freeRects(1).y = 0#

    freeRects(1).w = rollWidth
    freeRects(1).h = maxHeight


    For i = 1 To placedCount

        PlaceAndSplit freeRects, freeCount, placed(i).x, placed(i).y, placed(i).w, placed(i).h

    Next i

End Sub


' ============================================================
' REBALANCE ROLLS (POST-PROCESS LOCAL SEARCH)
'
' After the multi-start search picks a winning configuration,
' try to drain the last roll's items into earlier rolls'
' remaining free space. If a roll becomes fully empty, it is
' removed, reducing roll count and material. This is a light
' local search, not a full optimum, but often reduces waste
' further versus the pure greedy multi-start result.
' ============================================================

Private Sub RebalanceRolls(ByRef items() As TBanner, ByRef rolls() As TRoll, ByRef rollCount As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal fitMode As Long)

    Dim moved As Boolean
    Dim found As Boolean

    Dim safety As Long

    Dim srcRoll As Long
    Dim dstRoll As Long

    Dim i As Long
    Dim k As Long
    Dim r As Long

    Dim rid As Long

    Dim reqW As Double
    Dim reqH As Double

    Dim freeRects() As TFreeRect
    Dim freeCount As Long

    Dim bestX As Double
    Dim bestY As Double
    Dim bestW As Double
    Dim bestH As Double
    Dim bestRot As Boolean

    Dim newPlaced() As TPlaced
    Dim newCount As Long


    safety = 0


    Do

        moved = False

        safety = safety + 1

        If safety > 500 Then Exit Do

        If rollCount <= 1 Then Exit Do


        srcRoll = rollCount


        i = 1

        Do While i <= rolls(srcRoll).placedCount

            rid = rolls(srcRoll).placed(i).rid

            reqW = items(rid).OrigW + 2# * items(rid).margin
            reqH = items(rid).OrigH + 2# * items(rid).margin

            found = False


            For dstRoll = 1 To rollCount - 1

                BuildFreeRects rolls(dstRoll).placed, rolls(dstRoll).placedCount, rollWidth, maxHeight, freeRects, freeCount


                If FindBestPlacement(freeRects, freeCount, reqW, reqH, allowRotation, fitMode, rolls(dstRoll).placed, rolls(dstRoll).placedCount, bestX, bestY, bestW, bestH, bestRot) Then

                    ' --- place into destination roll ---

                    rolls(dstRoll).placedCount = rolls(dstRoll).placedCount + 1

                    ReDim Preserve rolls(dstRoll).placed(1 To rolls(dstRoll).placedCount)

                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).rid = rid
                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).x = bestX
                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).y = bestY
                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).w = bestW
                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).h = bestH
                    rolls(dstRoll).placed(rolls(dstRoll).placedCount).Rotated = bestRot

                    rolls(dstRoll).UsedHeight = CalcPlacedHeight(rolls(dstRoll).placed, rolls(dstRoll).placedCount)


                    ' --- remove from source roll ---

                    newCount = 0

                    ReDim newPlaced(1 To rolls(srcRoll).placedCount)


                    For k = 1 To rolls(srcRoll).placedCount

                        If k <> i Then

                            newCount = newCount + 1

                            newPlaced(newCount) = rolls(srcRoll).placed(k)

                        End If

                    Next k


                    rolls(srcRoll).placedCount = newCount


                    If newCount > 0 Then

                        ReDim rolls(srcRoll).placed(1 To newCount)


                        For k = 1 To newCount

                            rolls(srcRoll).placed(k) = newPlaced(k)

                        Next k


                        rolls(srcRoll).UsedHeight = CalcPlacedHeight(rolls(srcRoll).placed, newCount)

                    Else

                        rolls(srcRoll).UsedHeight = 0#

                    End If


                    found = True

                    moved = True


                    Exit For

                End If

            Next dstRoll


            If Not found Then

                i = i + 1

            End If

        Loop


        If rolls(srcRoll).placedCount = 0 Then

            For r = srcRoll To rollCount - 1

                rolls(r) = rolls(r + 1)

            Next r


            rollCount = rollCount - 1

        End If


    Loop While moved

End Sub


' ============================================================
' CALCULATE USED HEIGHT
' ============================================================

Private Function CalcPlacedHeight(ByRef placed() As TPlaced, ByVal placedCount As Long) As Double

    Dim i As Long

    Dim h As Double


    h = 0#


    For i = 1 To placedCount

        h = MaxD(h, placed(i).y + placed(i).h)

    Next i


    CalcPlacedHeight = h

End Function


' ============================================================
' MATERIAL USED
' ============================================================

Private Function CalcMaterialUsed(ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double

    Dim r As Long

    Dim total As Double


    total = 0#


    For r = 1 To rollCount

        total = total + rollWidth * rolls(r).UsedHeight

    Next r


    CalcMaterialUsed = total

End Function


' ============================================================
' TRUE DESIGN AREA
' ============================================================

Private Function CalcTrueArea(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long) As Double

    Dim r As Long
    Dim i As Long
    Dim rid As Long

    Dim total As Double


    total = 0#


    For r = 1 To rollCount

        For i = 1 To rolls(r).placedCount

            rid = rolls(r).placed(i).rid

            total = total + items(rid).OrigW * items(rid).OrigH

        Next i

    Next r


    CalcTrueArea = total

End Function


' ============================================================
' WASTE
' ============================================================

Private Function CalcWaste(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double

    Dim material As Double
    Dim trueArea As Double


    material = CalcMaterialUsed(rolls, rollCount, rollWidth)

    trueArea = CalcTrueArea(items, rolls, rollCount)


    If material <= EPS Then

        CalcWaste = 1#

    Else

        CalcWaste = (material - trueArea) / material

    End If

End Function


' ============================================================
' RIGHT WASTE
'
' Maximum unused horizontal width on the right
' of any roll.
' ============================================================

Private Function CalcRightWaste(ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double

    Dim r As Long
    Dim i As Long

    Dim rightEdge As Double
    Dim maxRightEdge As Double

    Dim waste As Double
    Dim worstWaste As Double


    worstWaste = 0#


    For r = 1 To rollCount

        maxRightEdge = 0#


        For i = 1 To rolls(r).placedCount

            rightEdge = rolls(r).placed(i).x + rolls(r).placed(i).w

            maxRightEdge = MaxD(maxRightEdge, rightEdge)

        Next i


        waste = rollWidth - maxRightEdge

        If waste < 0# Then
            waste = 0#
        End If


        worstWaste = MaxD(worstWaste, waste)

    Next r


    CalcRightWaste = worstWaste

End Function


' ============================================================
' TOTAL ALIGNMENT SCORE
'
' Lower = better.
'
' Measures:
'   - left edge alignment
'   - top edge alignment
'
' A perfectly aligned edge contributes zero.
' ============================================================

Private Function CalcAlignmentScore(ByRef rolls() As TRoll, ByVal rollCount As Long) As Double

    Dim r As Long
    Dim i As Long
    Dim j As Long

    Dim score As Double

    Dim leftDist As Double
    Dim topDist As Double

    Dim candidateTop As Double
    Dim otherTop As Double

    Dim bestLeft As Double
    Dim bestTop As Double

    Dim alignedLeft As Boolean
    Dim alignedTop As Boolean


    score = 0#


    For r = 1 To rollCount

        For i = 1 To rolls(r).placedCount

            bestLeft = 1E+30
            bestTop = 1E+30


            candidateTop = rolls(r).placed(i).y + rolls(r).placed(i).h


            For j = 1 To rolls(r).placedCount

                If i <> j Then

                    leftDist = AbsD(rolls(r).placed(i).x - rolls(r).placed(j).x)

                    otherTop = rolls(r).placed(j).y + rolls(r).placed(j).h

                    topDist = AbsD(candidateTop - otherTop)


                    bestLeft = MinD(bestLeft, leftDist)

                    bestTop = MinD(bestTop, topDist)

                End If

            Next j


            alignedLeft = (bestLeft <= ALIGN_TOLERANCE)

            alignedTop = (bestTop <= ALIGN_TOLERANCE)


            If alignedLeft Then
                bestLeft = 0#
            End If


            If alignedTop Then
                bestTop = 0#
            End If


            If bestLeft < 1E+20 Then
                score = score + bestLeft
            End If


            If bestTop < 1E+20 Then
                score = score + bestTop
            End If

        Next i

    Next r


    CalcAlignmentScore = score

End Function


' ============================================================
' PACK SCORE
'
' HARD PRIORITY:
'
'   1. Not placed
'   2. Right waste > 10 cm
'
' SOFT PRIORITY:
'
'   3. Material
'   4. Alignment
'   5. Roll count
'
' Important:
' A solution with right waste <= 10 cm
' is always preferred over a solution
' with right waste > 10 cm.
' ============================================================

Private Function PackScore(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal notPlaced As Long, ByVal rollWidth As Double, ByRef rightWaste As Double, ByRef alignmentScore As Double, ByRef materialUsed As Double) As Double

    Dim excessRight As Double
    Dim alignmentNormalized As Double


    rightWaste = CalcRightWaste(rolls, rollCount, rollWidth)

    alignmentScore = CalcAlignmentScore(rolls, rollCount)

    materialUsed = CalcMaterialUsed(rolls, rollCount, rollWidth)


    ' --------------------------------------------------------
    ' HARD FAILURE:
    ' not all objects placed
    ' --------------------------------------------------------

    If notPlaced > 0 Then

        PackScore = 1E+30 + CDbl(notPlaced) * 1E+25

        Exit Function

    End If


    ' --------------------------------------------------------
    ' RIGHT WASTE
    ' --------------------------------------------------------

    excessRight = rightWaste - MAX_RIGHT_WASTE


    If excessRight < 0# Then

        excessRight = 0#

    End If


    ' --------------------------------------------------------
    ' ALIGNMENT NORMALIZATION
    ' --------------------------------------------------------

    alignmentNormalized = alignmentScore


    ' --------------------------------------------------------
    ' FINAL SCORE
    '
    ' Right waste excess is deliberately very expensive.
    ' Material is still the main objective after satisfying
    ' the 10 cm right-edge target.
    ' --------------------------------------------------------

    PackScore = _
        excessRight * 100000000# + _
        materialUsed + _
        alignmentNormalized * 0.01 + _
        CDbl(rollCount) * 0.0001

End Function


' ============================================================
' MOVE SHAPE TO BOTTOM LEFT
' ============================================================

Private Sub MoveShapeToBottomLeft(ByVal sh As Shape, ByVal targetX As Double, ByVal targetY As Double)

    Dim bx As Double
    Dim by As Double

    Dim bw As Double
    Dim bh As Double


    sh.GetBoundingBox bx, by, bw, bh, False


    sh.Move targetX - bx, targetY - by

End Sub


' ============================================================
' APPLY NESTING TO REAL OBJECTS
' ============================================================

Private Sub ApplyNestingToObjects(ByRef items() As TBanner, ByRef sourceShapes() As Shape, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double)

    Dim totalHeight As Double

    Dim rollOffsetY As Double

    Dim r As Long
    Dim i As Long

    Dim rid As Long

    Dim margin As Double

    Dim targetX As Double
    Dim targetY As Double

    Dim pageLeft As Double
    Dim pageBottom As Double

    Dim sh As Shape


    totalHeight = 0#


    For r = 1 To rollCount

        totalHeight = totalHeight + rolls(r).UsedHeight


        If r < rollCount Then

            totalHeight = totalHeight + ROLL_GAP

        End If

    Next r


    If totalHeight <= EPS Then

        totalHeight = 10#

    End If


    ActivePage.SizeWidth = rollWidth

    ActivePage.SizeHeight = totalHeight


    pageLeft = ActivePage.LeftX

    pageBottom = ActivePage.BottomY


    rollOffsetY = 0#


    For r = 1 To rollCount

        For i = 1 To rolls(r).placedCount

            rid = rolls(r).placed(i).rid


            Set sh = sourceShapes(rid)


            margin = items(rid).margin


            If rolls(r).placed(i).Rotated Then

                sh.Rotate 90#

            End If


            targetX = pageLeft + rolls(r).placed(i).x + margin

            targetY = pageBottom + rollOffsetY + rolls(r).UsedHeight - rolls(r).placed(i).y - rolls(r).placed(i).h + margin


            MoveShapeToBottomLeft sh, targetX, targetY

        Next i


        rollOffsetY = _
            rollOffsetY + _
            rolls(r).UsedHeight + _
            ROLL_GAP

    Next r


    ActiveDocument.ClearSelection


    For r = 1 To rollCount

        For i = 1 To rolls(r).placedCount

            rid = rolls(r).placed(i).rid

            sourceShapes(rid).CreateSelection

        Next i

    Next r

End Sub


' ============================================================
' PARSE ROLL WIDTH LIST
' ============================================================

Private Sub ParseWidthList(ByVal txt As String, ByRef widths() As Double, ByRef widthCount As Long)

    Dim parts() As String

    Dim i As Long

    Dim v As Double


    widthCount = 0


    parts = Split(txt, ",")


    ReDim widths(1 To UBound(parts) + 1)


    For i = LBound(parts) To UBound(parts)

        If Len(Trim$(parts(i))) > 0 Then

            v = Val(Trim$(parts(i)))


            If v > 0# Then

                widthCount = widthCount + 1

                widths(widthCount) = v

            End If

        End If

    Next i


    If widthCount <= 0 Then

        ReDim widths(1 To 1)

    Else

        ReDim Preserve widths(1 To widthCount)

    End If

End Sub


' ============================================================
' SORT MODE NAME
' ============================================================

Private Function SortModeName(ByVal mode As Long) As String

    Select Case mode

        Case 1

            SortModeName = "Area Descending"

        Case 2

            SortModeName = "Width Descending"

        Case 3

            SortModeName = "Height Descending"

        Case 4

            SortModeName = "Short Side Descending"

        Case 5

            SortModeName = "Long Side Descending"

        Case 6

            SortModeName = "Aspect Ratio Descending"

        Case Else

            SortModeName = "Unknown"

    End Select

End Function


' ============================================================
' FIT MODE NAME
' ============================================================

Private Function FitModeName(ByVal mode As Long) As String

    Select Case mode

        Case 1

            FitModeName = "BSSF"

        Case 2

            FitModeName = "BAF"

        Case 3

            FitModeName = "BLSF"

        Case 4

            FitModeName = "Contact Point"

        Case Else

            FitModeName = "Unknown"

    End Select

End Function


' ============================================================
' MAIN
' ============================================================

Public Sub RunNesting_BannerCorelDRAW()

    Dim doc As Document

    Dim sr As ShapeRange

    Dim sh As Shape


    Dim items() As TBanner

    Dim sourceShapes() As Shape


    Dim rolls() As TRoll

    Dim candidateRolls() As TRoll


    Dim n As Long

    Dim i As Long
    Dim j As Long


    Dim oldUnit As Long


    Dim margin As Double

    Dim rollText As String


    Dim widths() As Double

    Dim widthCount As Long


    Dim rotateAnswer As VbMsgBoxResult

    Dim allowRotation As Boolean


    Dim maxHeight As Double

    Dim minNeeded As Double


    Dim candidateWidth As Double

    Dim bestWidth As Double


    Dim candidateSortMode As Long

    Dim candidateFitMode As Long


    Dim bestSortMode As Long

    Dim bestFitMode As Long


    Dim candidateRollCount As Long

    Dim candidateNotPlaced As Long


    Dim bestRollCount As Long

    Dim bestNotPlaced As Long


    Dim candidateScore As Double

    Dim bestScore As Double


    Dim candidateMaterial As Double

    Dim bestMaterial As Double


    Dim candidateWaste As Double

    Dim bestWaste As Double


    Dim candidateRightWaste As Double

    Dim bestRightWaste As Double


    Dim candidateAlignment As Double

    Dim bestAlignment As Double


    Dim bx As Double
    Dim by As Double

    Dim bw As Double
    Dim bh As Double


    Dim sumSide As Double

    Dim maxMargin As Double


    Dim msg As String


    ' ========================================================
    ' DOCUMENT CHECK
    ' ========================================================

    If ActiveDocument Is Nothing Then

        MsgBox "Tidak ada document CorelDRAW aktif.", vbExclamation, "Auto Nesting"

        Exit Sub

    End If


    Set doc = ActiveDocument


    ' ========================================================
    ' SELECTION CHECK
    ' ========================================================

    Set sr = ActiveSelectionRange


    If sr Is Nothing Then

        MsgBox "Pilih object/banner terlebih dahulu.", vbExclamation, "Auto Nesting"

        Exit Sub

    End If


    If sr.count <= 0 Then

        MsgBox "Pilih minimal 1 object/banner terlebih dahulu.", vbExclamation, "Auto Nesting"

        Exit Sub

    End If


    n = sr.count


    ' ========================================================
    ' UNIT
    ' ========================================================

    oldUnit = doc.Unit

    doc.Unit = cdrCentimeter


    ' ========================================================
    ' READ OBJECTS
    ' ========================================================

    ReDim items(1 To n)

    ReDim sourceShapes(1 To n)


    i = 0


    For Each sh In sr

        i = i + 1


        Set sourceShapes(i) = sh


        sh.GetBoundingBox bx, by, bw, bh, False


        If bw <= EPS Or bh <= EPS Then

            doc.Unit = oldUnit


            MsgBox "Object nomor " & CStr(i) & " memiliki bounding box tidak valid.", vbCritical, "Auto Nesting"


            Exit Sub

        End If


        items(i).Label = "Object " & CStr(i)

        items(i).OrigW = bw
        items(i).OrigH = bh

        items(i).margin = 0#

    Next sh


    ' ========================================================
    ' MARGIN
    ' ========================================================

    margin = Val(InputBox("Margin / clearance per sisi (cm):", "Auto Nesting - Margin", "0"))


    If margin < 0# Then

        margin = 0#

    End If


    For i = 1 To n

        items(i).margin = margin

    Next i


    ' ========================================================
    ' ROLL WIDTH
    ' ========================================================

    rollText = InputBox("Masukkan daftar lebar roll dalam cm." & vbCrLf & "Contoh: 150,200,250,300", "Auto Nesting - Roll Width", "109, 159, 219, 259, 319")


    If Len(Trim$(rollText)) = 0 Then

        doc.Unit = oldUnit


        MsgBox "Lebar roll tidak diberikan.", vbExclamation, "Auto Nesting"


        Exit Sub

    End If


    ParseWidthList rollText, widths, widthCount


    If widthCount <= 0 Then

        doc.Unit = oldUnit


        MsgBox "Daftar lebar roll tidak valid.", vbCritical, "Auto Nesting"


        Exit Sub

    End If


    ' ========================================================
    ' ROTATION
    ' ========================================================

    rotateAnswer = MsgBox("Izinkan object diputar 90°?", vbYesNo + vbQuestion, "Auto Nesting - Rotation")


    allowRotation = (rotateAnswer = vbYes)


    ' ========================================================
    ' MAX HEIGHT
    ' ========================================================

    sumSide = 0#

    maxMargin = 0#


    For i = 1 To n

        sumSide = sumSide + MaxD(items(i).OrigW, items(i).OrigH)

        maxMargin = MaxD(maxMargin, items(i).margin)

    Next i


    maxHeight = sumSide + maxMargin * (n + 2) + 100#


    ' ========================================================
    ' MINIMUM ROLL WIDTH
    ' ========================================================

    minNeeded = 0#


    For i = 1 To n

        If allowRotation Then

            minNeeded = MaxD(minNeeded, MinD(items(i).OrigW, items(i).OrigH) + 2# * items(i).margin)

        Else

            minNeeded = MaxD(minNeeded, items(i).OrigW + 2# * items(i).margin)

        End If

    Next i


    ' ========================================================
    ' INITIAL BEST
    ' ========================================================

    bestScore = 1E+30

    bestMaterial = 1E+30

    bestWaste = 1#

    bestRightWaste = 1E+30

    bestAlignment = 1E+30


    bestWidth = 0#

    bestRollCount = 0

    bestNotPlaced = n


    bestSortMode = 1

    bestFitMode = 1


    ' ========================================================
    ' MULTI-START
    '
    ' Each roll width:
    '
    '   6 sorting methods
    '   x
    '   4 fitness methods (BSSF, BAF, BLSF, Contact Point)
    '
    ' = 24 configurations per roll width
    ' ========================================================

    For j = 1 To widthCount

        candidateWidth = widths(j)


        If candidateWidth + EPS >= minNeeded Then


            For candidateSortMode = 1 To 6


                For candidateFitMode = 1 To 4


                    PackMultiRoll items, n, candidateWidth, maxHeight, allowRotation, candidateSortMode, candidateFitMode, candidateRolls, candidateRollCount, candidateNotPlaced


                    candidateScore = PackScore(items, candidateRolls, candidateRollCount, candidateNotPlaced, candidateWidth, candidateRightWaste, candidateAlignment, candidateMaterial)


                    If candidateNotPlaced = 0 Then

                        candidateWaste = CalcWaste(items, candidateRolls, candidateRollCount, candidateWidth)

                    Else

                        candidateWaste = 1#

                    End If


                    If candidateScore < bestScore Then

                        bestScore = candidateScore

                        bestWidth = candidateWidth


                        bestRollCount = candidateRollCount

                        bestNotPlaced = candidateNotPlaced


                        bestSortMode = candidateSortMode

                        bestFitMode = candidateFitMode


                        bestMaterial = candidateMaterial

                        bestWaste = candidateWaste

                        bestRightWaste = candidateRightWaste

                        bestAlignment = candidateAlignment

                    End If


                Next candidateFitMode


            Next candidateSortMode


        End If

    Next j


    ' ========================================================
    ' NO RESULT
    ' ========================================================

    If bestWidth <= EPS Or bestRollCount <= 0 Then

        doc.Unit = oldUnit


        msg = "Tidak ditemukan konfigurasi roll yang feasible."

        msg = msg & vbCrLf & vbCrLf

        msg = msg & "Minimum roll width: "

        msg = msg & Format$(minNeeded, "0.00")

        msg = msg & " cm"


        MsgBox msg, vbCritical, "Auto Nesting"


        Exit Sub

    End If


    ' ========================================================
    ' REPACK WINNING CONFIGURATION
    ' ========================================================

    PackMultiRoll items, n, bestWidth, maxHeight, allowRotation, bestSortMode, bestFitMode, rolls, bestRollCount, bestNotPlaced


    ' ========================================================
    ' LOCAL SEARCH: REBALANCE BETWEEN ROLLS
    '
    ' Tries to drain the last roll into earlier rolls' spare
    ' space, reducing roll count / material further when
    ' possible. Only runs when the winning configuration
    ' already placed everything.
    ' ========================================================

    If bestNotPlaced = 0 Then

        RebalanceRolls items, rolls, bestRollCount, bestWidth, maxHeight, allowRotation, bestFitMode

    End If


    ' ========================================================
    ' FINAL METRICS
    ' ========================================================

    bestMaterial = CalcMaterialUsed(rolls, bestRollCount, bestWidth)

    bestWaste = CalcWaste(items, rolls, bestRollCount, bestWidth)

    bestRightWaste = CalcRightWaste(rolls, bestRollCount, bestWidth)

    bestAlignment = CalcAlignmentScore(rolls, bestRollCount)


    ' ========================================================
    ' APPLY REAL OBJECTS
    ' ========================================================

    ApplyNestingToObjects items, sourceShapes, rolls, bestRollCount, bestWidth


    ' ========================================================
    ' RESTORE UNIT
    ' ========================================================

    doc.Unit = oldUnit


    ' ========================================================
    ' RESULT
    ' ========================================================

    msg = "AUTO NESTING V3 SELESAI"

    msg = msg & vbCrLf & vbCrLf

    msg = msg & "Object: "
    msg = msg & CStr(n)

    msg = msg & vbCrLf

    msg = msg & "Roll width: "
    msg = msg & Format$(bestWidth, "0.00")
    msg = msg & " cm"

    msg = msg & vbCrLf

    msg = msg & "Jumlah roll: "
    msg = msg & CStr(bestRollCount)

    msg = msg & vbCrLf

    msg = msg & "Tidak ditempatkan: "
    msg = msg & CStr(bestNotPlaced)

    msg = msg & vbCrLf

    msg = msg & "Material digunakan: "
    msg = msg & Format$(bestMaterial, "0.00")
    msg = msg & " cm2"

    msg = msg & vbCrLf

    msg = msg & "Waste estimasi: "
    msg = msg & Format$(bestWaste * 100#, "0.00")
    msg = msg & "%"

    msg = msg & vbCrLf

    msg = msg & "Waste kanan maksimum: "
    msg = msg & Format$(bestRightWaste, "0.00")
    msg = msg & " cm"

    msg = msg & vbCrLf

    If bestRightWaste <= MAX_RIGHT_WASTE + EPS Then

        msg = msg & "Right waste status: OK"

    Else

        msg = msg & "Right waste status: > 10 cm"

    End If

    msg = msg & vbCrLf

    msg = msg & "Alignment score: "
    msg = msg & Format$(bestAlignment, "0.00")

    msg = msg & vbCrLf

    msg = msg & "Sort: "
    msg = msg & SortModeName(bestSortMode)

    msg = msg & vbCrLf

    msg = msg & "Fitness: "
    msg = msg & FitModeName(bestFitMode)


    MsgBox msg, vbInformation, "Auto Nesting V3"

End Sub