language-agnosticdiscrete-mathematicsoperations-research

What Discrete Optimization family is this?


Bin-Assignment Problem I am given N lists of M items that will be physically realized (someone actually has to put items (names abbreviated here,) in physical bins.) Then the bins are emptied, if necessary, and re-used, working left-to-right. There is a real cost to putting a different item in a bin than what was in it before. I rearrange the lists to minimize changes, manually. Software can do it faster, and more reliably in an optimum way. The whole thing happens in Excel (then paper, then in a factory.) I wrote some VBA, a brute-force affair, that did really well with some examples. But not all. If I knew the family of optimization that this is, I could code it, even if I just pass something to a DLL. But multiple searches online have not succeeded. I tried several phrasings. It's not a traveling S.., knapsack, etc. It seems similar to the Sequence Alignment problem from Bioinformatics. Someone recognize it? Let's hear it, Operations Research people.


Solution

  • enter image description here As it turns out, the naive solution just needed tweaking. Look at a cell. Try to find the same letter in the column to it's right. If you find one, swap it with whatever it to the right of that cell now. Work your way down. The ColumnsPer parameter accounts for the real-world use, where each column has an associated list of numbers and the grid columns alternate labels, numbers, labels, ...

    Option Explicit
    Public Const Row1 As Long = 4
    Public Const ColumnsPer As Long = 1  '2, when RM, % 
    Public Const BinCount As Long = 6  
    Public Const ColCount As Long = 6
    
    Private Sub reorder_items_max_left_to_right_repeats(wksht As Worksheet, _
        col1 As Long, maxBins As Long, maxRecipes As Long, ByVal direction As Integer)
    
        Dim here As Range
        Set here = wksht.Cells(Row1, col1)
            here.Activate
            
        Dim cond
        For cond = 1 To maxRecipes - 1
            Do While WithinTheBox(here, col1, direction)
                If Not Adjacent(here, ColumnsPer).Value = here.Value Then
                       Dim there As Range
                       Set there = Matching_R_ange(here, direction)
                    If Not there Is Nothing Then swapThem Adjacent(here, ColumnsPer), there
                End If
    NextItemDown:
                Set here = here.Offset(direction, 0)
                    here.Activate
                    'Debug.Assert here.Address <> "$AZ$6"
              DoEvents
            Loop
    NextCond:
            Select Case direction
                Case 1
                    Set here = Cells(Row1, here.Column + ColumnsPer)
                Case -1
                    Set here = Cells(Row1 + maxBins - 1, here.Column + ColumnsPer)
            End Select
            here.Activate
        Next cond
    End Sub
    
    Function Adjacent(fromHereOnLeft As Range, colsRight As Long) As Range
        Set Adjacent = fromHereOnLeft.Offset(0, colsRight)
    End Function
    
    Function Matching_R_ange(fromHereOnLeft As Range, _
                             ByVal direction As Integer) As Range
        
        Dim rowStart As Long
            rowStart = Row1
            
        Dim colLook As Long
            colLook = fromHereOnLeft.Offset(0, ColumnsPer).Column
            
        Dim c As Range
        Set c = Cells(rowStart, colLook)
        
        Dim col1 As Long
        col1 = c.Column
        
        Do While WithinTheBox(c, col1, direction)
            Debug.Print "C " & c.Address
        
            If c.Value = fromHereOnLeft.Value _
            And c.Row <> fromHereOnLeft.Row Then
                Set Matching_R_ange = c
                Exit Function
            Else
                    Set c = c.Offset(1 * direction, 0)
            End If
          DoEvents
        Loop
        'returning NOTHING is expected, often
    End Function
    
    Function WithinTheBox(ByVal c As Range, ByVal col1 As Long, ByVal direction As Integer)
        Select Case direction
            Case 1
                WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row >= Row1
            Case -1
                WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row > Row1
        End Select
        WithinTheBox = WithinTheBox And _
                   c.Column >= col1 And c.Column < col1 + ColCount - 1
    End Function
    
    Private Sub swapThem(range10 As Range, range20 As Range)
        'Unlike with SUB 'Matching_R_ange', we have to swap the %s as well as the items
        'So set temporary range vars to hold %s, to avoid confusion due to referencing items/r_anges
        If ColumnsPer = 2 Then
            Dim range11 As Range
            Set range11 = range10.Offset(0, 1)
            
            Dim range21 As Range
            Set range21 = range20.Offset(0, 1)
            'sit on them for now
        End If
        
        Dim Stak As Object
        Set Stak = CreateObject("System.Collections.Stack")
            Stak.push (range10.Value)           'A
            Stak.push (range20.Value)           'BA
                       range10.Value = Stak.pop 'A
                       range20.Value = Stak.pop '_  Stak is empty now, can re-use
                       
        If ColumnsPer = 2 Then
            Stak.push (range11.Value)
            Stak.push (range21.Value)
                       range11.Value = Stak.pop
                       range21.Value = Stak.pop
        End If
    End Sub