This program demonstrates six map coloring algorithms:

• 2-Coloring
• 3-Coloring Exhaustively
• 3-Coloring With Map Simplification
• 4-Coloring Exhaustively
• 4-Coloring With Map Simplification
• 5-Coloring

2-Coloring

2-coloring a map is relatively simple. Pick a region and assign it a color. Then recursively assign the other color to its neighbors. Eventually this will color every region. If the program ever reaches a region that has already been assigned the wrong color (i.e. you are trying to color a region green but it is already red), then the map is not 2-colorable.

If the map is disconnected, repeat this step for a region that does not yet have a color and continue until all of the regions are colored.

The following code shows the controlling algorithm.

' 2-color the map.
' Return True if the map is not 2-colorable.
Private Function AssignColors2() As Boolean
Dim rgn As MapRegion

    ' Make the adjacency lists.
    FindNeighbors

    ' Reset the regions' colors.
    ResetColors

    ' Assume we will fail.
    AssignColors2 = True

    ' Color starting from each region to ensure
    ' that all disconnected areas are colored.
    For Each rgn In Regions
        ' See if this region has a color yet.
        If rgn.Color = UNCOLORED Then
            ' Assign a color.
            If rgn.Assign2Color(0) Then Exit Function
        End If
    Next rgn

    ' We succeeded.
    AssignColors2 = False
End Function

' Assign the color to this region. Then recursively
' assign the other colors to our neighbors.
' Return True if there is an error.
Public Function Assign2Color(ByVal clr As Integer)
Dim nbr As MapRegion

    ' See if we already have the right color.
    If Color = clr Then
        ' We already have the right color.
        ' Return a success code.
        Assign2Color = False
        Exit Function
    End If

    ' See if we have the wrong color.
    If Color <> UNCOLORED Then
        ' We have the wrong color.
        ' Return an error code.
        Assign2Color = True
        Exit Function
    End If

    ' Assign the color.
    Color = clr

    ' Assign colors to our neighbors.
    clr = 1 - clr
    For Each nbr In Neighbors
        If nbr.Assign2Color(clr) Then
            ' There was an error.
            Assign2Color = True
            Exit Function
        End If
    Next nbr

    ' Return a success code.
    Assign2Color = False
End Function

3-Coloring Exhaustively

Exhaustively coloring a map is simple but can be very slow. The program tries every possible combination of colors for every region to see if it can find a valid coloring.

The ExhaustivelyColor subroutine assigns a color to the first region and then calls ExhaustivelyColorRegion to color the other regions.

' Color the map exhaustively.
' Return True if the map is not colorable with the
' given number of colors.
Public Function ExhaustivelyColor(ByVal MAX_COLOR As _
    Integer) As Boolean
    ' If the map is empty, we don't need to color it.
    If Regions.count < 1 Then
        ExhaustivelyColor = False
        Exit Function
    End If

    ' See if there are a lot of region/color combinations.
    If Regions.count ^ (MAX_COLOR + 1) > 10000 Then
        If MsgBox("Warning: Exhaustively coloring " & _
                Regions.count & " regions with " & _
                MAX_COLOR + 1 & " colors may take a long " & _
                    "time." & _
                vbCrLf & "Do you want to continue?", _
            vbYesNo Or vbQuestion, "Warning") = vbNo _
        Then
            ExhaustivelyColor = True
            Exit Function
        End If
    End If

    ' Make a traversal of the regions.
    Dim traversal As Collection
    Set traversal = MakeTraversal(Regions)

    ' Arbitrarily give the first region the first color.
    traversal(1).Color = 0

    ' Color the remaining regions exhaustively
    ' in traversal order.
    Dim count As Long
    ExhaustivelyColor = Not ExhaustivelyColorRegion(count, _
        traversal, 2, MAX_COLOR)
    Debug.Print "Recursed " & count & " times."
End Function

' For each color, give this region the color and
' recursively assign colors to the remaining regions.
' Return True if we find a valid coloring.
Private Function ExhaustivelyColorRegion(ByRef count As _
    Long, ByVal traversal As Collection, ByVal rgn_index As _
    Integer, ByVal MAX_COLOR As Integer) As Boolean
    ' Assume we have a valid coloring.
    ExhaustivelyColorRegion = True

    count = count + 1
    ' If rgn_index > Regions.Count, then we
    ' have assigned colors to all regions so this
    ' is a valid coloring.
    If rgn_index > Regions.count Then Exit Function

    ' Try all the colors for this region.
    Dim rgn As MapRegion
    Set rgn = Regions(rgn_index)

    Dim clr As Integer
    For clr = 0 To MAX_COLOR
        ' See if a neighbor already has this color.
        If Not rgn.ColorUsedByNeighbors(clr) Then
            ' A neighbor isn't using this color.
            ' Try it.
            rgn.Color = clr

            ' Recursively color the rest of the regions.
            ' If this call returns True, then we
            ' have found a valid coloring so far.
            If ExhaustivelyColorRegion( _
                count, traversal, rgn_index + 1, MAX_COLOR) _
                    _
                    Then Exit Function
        End If
    Next clr
    rgn.Color = UNCOLORED

    ' We did not find a valid coloring.
    ExhaustivelyColorRegion = False
End Function

3-Coloring With Map Simplification

3-coloring maps is an NP-complete problem so under some circumstances it can take a very long time. Sometimes you can simplify the map to make things a bit faster.

The trick is to notice that you can remove any region with two or fewer neighbors from the map. Then you can color the remaining map, restore the region, and pick its color from those that its neighbors are not using. Because the region has at most two neighbors, you know that there is a color available.

Subroutine AssignColors3 uses this technique to simplify the map. It calls subroutine ExhaustivelyColor to color the simplified map, and restores the regions it removed, coloring them appropriately.

In many cases, simplifying the map removes all of the regions so it is easy to color the map as the program restores the regions it earlier removed.

' 3-color the map.
Private Function AssignColors3() As Boolean
Dim all_regions As New Collection
Dim rgn As MapRegion
Dim stack As New Collection

    ' Make the adjacency lists.
    FindNeighbors

    ' Reset the regions' colors.
    ResetColors

    ' Make the regions copy their neighbor lists.
    For Each rgn In Regions
        rgn.SaveNeighbors
    Next rgn

    ' Save a copy of the region list.
    For Each rgn In Regions
        all_regions.Add rgn
    Next rgn

    ' Push regions onto the stack.
    Do While Regions.count > 0
        ' Look for a region with degree < 3.
        For Each rgn In Regions
            If rgn.Neighbors.count < 3 _
                Then Exit For
        Next rgn

        ' See if we found one.
        If rgn Is Nothing Then
            ' There are no more with degree < 3.
            Exit Do
        Else
            ' Push rgn onto the stack.
            stack.Add rgn

            ' Remove the node from the graph.
            rgn.RemoveFromGraph
            Regions.Remove Format$(rgn.Number)
        End If
    Loop
    Debug.Print "Map simplified from " & _
        all_regions.count & " to " & _
        Regions.count & " regions."

    ' Exhaustively color the rest of the map.
    AssignColors3 = ExhaustivelyColor(2)

    ' Pop regions off the stack and color them.
    Do While stack.count > 0
        ' Get the region.
        Set rgn = stack(stack.count)
        stack.Remove stack.count

        ' Restore the region to the map.
        Regions.Add rgn, Format$(rgn.Number)
        rgn.RestoreNeighbors

        ' Assign rgn a color different from
        ' those used by its neighbors.
        rgn.PickUnusedColor
    Loop

    ' Restore the region list to its original order.
    Set Regions = New Collection
    For Each rgn In all_regions
        Regions.Add rgn, Format$(rgn.Number)
    Next rgn
End Function

4-Coloring Exhaustively

4-coloring a map exhaustively is the same as 3-coloring it exhaustively. See the section 3-Coloring Exhaustively for details.

4-Coloring With Map Simplification

4-coloring a map with simplification is similar to 3-coloring it with simplification. See the section 3-Coloring With Map Simplification for details.

The difference is that here the program can remove regions that have three or fewer neighbors instead of two or fewer. That lets the program simplify the map more than is possible when 3-coloring.

5-Coloring

While it is always possible to 4-color a map, finding a valid 4-coloring may be time consuming. However, there is a method that always finds a 5-coloring quickly. This algorithm uses two simplifiying rules.

First, the algorithm uses a rule similar to the previous ones. If a region has four or fewer neighbors, then the program can remove it from the map, color the remaining regions, restore the removed region, and assign it a color that is not used by its neighbors.

Second, it can be shown (although not by me ;-) that: if a map contains no regions of degree <= 4, then it contains at least one region with degree 5 that has two mutually non-adjacent neighbors with degree <= 7. The program removes the region and replaces its two neighbors with a single region representing them both. When the program is rebuilding the map, it gives these two neighbors the same color (the color assigned to their merged region). It then picks a color for original region. Because that region had five neighbors and because two of them have the same color, there must be a color left over for this region. (Don't worry about it, this is pretty complicated.)

' 5-color the map.
Private Sub AssignColors5()
Dim num_low_degree As Integer
Dim num_non_adjacent As Integer
Dim all_regions As New Collection
Dim rgn As MapRegion
Dim n1 As MapRegion
Dim n2 As MapRegion
Dim stack As New Collection
Dim obj As Object
Dim color_used(0 To 4) As Boolean
Dim i As Integer

    ' Make the adjacency lists.
    FindNeighbors

    ' Reset the regions' colors.
    ResetColors

    ' Make the regions save their neighbor lists.
    For Each rgn In Regions
        rgn.SaveNeighbors
    Next rgn

    ' Save a copy of the region list.
    For Each rgn In Regions
        all_regions.Add rgn
    Next rgn

    ' Push regions onto the stack.
    num_low_degree = 0
    num_non_adjacent = 0
    Do While Regions.count > 0
        ' Look for regions with degree < 5.
        For Each rgn In Regions
            If rgn.Neighbors.count < 5 _
                Then Exit For
        Next rgn

        ' If we did not find one, look for a
        ' node with degree 5 with two mutually
        ' non-adjacent children of degree <= 7.
        If rgn Is Nothing Then
            num_non_adjacent = num_non_adjacent + 1
            For Each rgn In Regions
                If rgn.FindNonAdjacents(n1, n2) _
                    Then Exit For
            Next rgn

            ' If we still did not find one, there's
            ' something wrong.
            If rgn Is Nothing Then
                MsgBox "Error finding node to remove."
                Exit Do
            End If

            ' Push rgn and its adjacency list
            ' onto the stack.
            stack.Add rgn
            stack.Add rgn.Neighbors

            ' Remove the node from the graph.
            rgn.RemoveFromGraph
            Regions.Remove Format$(rgn.Number)

            ' Associate n1 and n2.
            n1.AssociateWith n2

            ' Push n1 and n2 onto the stack.
            stack.Add n1
            stack.Add n2

            ' Remove n1 from the graph.
            n1.RemoveFromGraph
            Regions.Remove Format$(n1.Number)
        Else
            num_low_degree = num_low_degree + 1

            ' Push rgn and its adjacency list
            ' onto the stack.
            stack.Add rgn
            stack.Add rgn.Neighbors

            ' Remove the node from the graph.
            rgn.RemoveFromGraph
            Regions.Remove Format$(rgn.Number)
        End If
    Loop

    Debug.Print "# low degree:   " & num_low_degree
    Debug.Print "# non-adjacent: " & num_non_adjacent

    ' Pop regions off the stack and color them.
    Do While stack.count > 0
        Set obj = stack(stack.count)
        stack.Remove stack.count
        Set rgn = stack(stack.count)
        stack.Remove stack.count

        If TypeOf obj Is Collection Then
            ' Restore the region to the map.
            Regions.Add rgn, Format$(rgn.Number)
            Set rgn.Neighbors = obj

            ' Assign rgn a color different from
            ' those used by its neighbors.
            rgn.PickUnusedColor
        Else
            ' Assign rgn the same color as its
            ' associated node.
            rgn.Color = obj.Color
        End If
    Loop

    ' Restore the region list to its original order.
    Set Regions = New Collection
    For Each rgn In all_regions
        Regions.Add rgn, Format$(rgn.Number)
        rgn.RestoreNeighbors
    Next rgn
End Sub