What's New
Q & A
Tip Jar
C# Helper...
Follow VBHelper on Twitter
MSDN Visual Basic Community
TitleMake stable appointment assignments based on customer preferences in Visual Basic .NET
DescriptionThis example shows how to make stable appointment assignments based on customer preferences in Visual Basic .NET.
Keywordsstable, appointment, assignment, preference, Stable Marriage, VB.NET
This example assumes you have people who must sign up for a limited number of appointment slots. Each person is allowed to select first, second, and third choices. The program assigns people to appointments in a "stable" way where "stable" means no two people would be willing to trade appointments.

The Person class represents a person and his or her preferences.

The following code performs the assignment. It reads preference information from a text box and builds the Person objects.

Next the code makes initial assignments. For each preference level (in this example, people rank three choices 0, 1, or 2), the code examines the Person objects. If a Person is not yet assigned and that Person's preference for this level has not been assigned, the program makes that assignment.

For example, suppose the program is looking at preference 1 (the second choice). Sally has not been assigned an appointment yet and her choice number 1 is appointment slot 6. If that slot is not already taken by another Person, the program assigns it to Sally.

After it has made these preferential assignments, the program assigns any unassigned Person to any available appointment.

Next the program enters a loop looking for improvements. For each pair of Persons, the program determines whether those persons should trade appointments. For example, suppose Bill was assigned his first choice appointment number 3 and Cindy was assigned appointment number 7, which she did not list as one of her choices. Suppose Bill listed appointment 7 as his third choice and Cindy listed appointment 3 as her second choice. In this case, the program swaps Bill's and Cindy's appointments. It prefers the third/second choices over the first/none choices.

' Get the Persons' preferences.
Dim txt As String = txtPreferences.Text
Do While txt.EndsWith(vbCrLf)
    txt = txt.Substring(0, txt.Length - vbCrLf.Length)
Dim lines() As String = Split(txt, vbCrLf)
Dim num_people As Integer = UBound(lines) - LBound(lines) + _

Dim people(num_people - 1) As Person
For i As Integer = 0 To num_people - 1
    people(i) = New Person(lines(i))
Next i

' Clear assignments.
Dim assigned_to(NUM_CHOICES - 1) As Person
For i As Integer = 0 To NUM_CHOICES - 1
    assigned_to(i) = Nothing
Next i

' Make initial choice assignments.
For pref As Integer = 0 To NUM_PREFERENCES - 1
    ' Try to assign this choice for Persons.
    For Each per As Person In people
        ' See if this Person has an assignment yet.
        If per.Assignment < 0 Then
            ' This Person is unassigned.
            ' See if this choice is available.
            Dim desired_choice As Integer = _
            If assigned_to(desired_choice) Is Nothing Then
                ' Assign this Person.
                assigned_to(desired_choice) = per
                per.Assignment = desired_choice
            End If
        End If
    Next per
Next pref

' Assign anyone without an assignment.
For Each per As Person In people
    ' See if this Person has an assignment yet.
    If per.Assignment < 0 Then
        ' This Person is unassigned.
        ' Find an available choice.
        For i As Integer = 0 To NUM_CHOICES - 1
            If assigned_to(i) Is Nothing Then
                ' Assign this Person.
                assigned_to(i) = per
                per.Assignment = i
                Exit For
            End If
        Next i
    End If
Next per

' Try to improve the assignments.
Dim had_improvement As Boolean
    had_improvement = False

    ' Look for profitable swaps.
    For Each per As Person In people
        For Each per2 As Person In people
            Dim per2_assignment As Integer = per2.Assignment
            Dim per_assignment As Integer = per.Assignment

            ' See if per and per2 should swap.
            Dim old_cost As Integer = per.Value + per2.Value
            Dim new_cost As Integer = _
                per.ValueOf(per2_assignment) + _
            If new_cost < old_cost Then
                ' Make the swap.
                per.Assignment = per2_assignment
                per2.Assignment = per_assignment
                assigned_to(per_assignment) = per2
                assigned_to(per2_assignment) = per
                had_improvement = True
            End If
        Next per2
    Next per
Loop While had_improvement

' Display the results.
txtAssignments.Text = AssignmentSummary(assigned_to, people)
Note that this example does not guarantee any sort of optimality. There may be more complicated trades involving more than two people that lead to a better final solution. I may work on another program to look at this more closely.

Note also that in real life you cannot compare the values of peoples' choices directly. For example, suppose you are available for any of the appointments but I have work during all but one. Then in some sense my first choice is more important than all of your choices. If I don't get my first choice, I need to take extra measures such as getting time off of work.

Copyright © 1997-2006 Rocky Mountain Computer Consulting, Inc.   All rights reserved.