Attribute VB_Name = "Rbt"
Option Explicit

' red-black tree algorithm, object method

Private Sentinel As CRbt        ' all leafs are sentinels
Private Root As CRbt            ' root of red-black tree
Private LastFind As CRbt        ' last node found


Private Function FindNode(ByVal Key As Variant) As CRbt
'   inputs:
'       Key                   ' designates key to find
'   returns:
'       index to node
'   action:
'       Search tree for designated key, and return index to node.
'   errors:
'       errKeyNotFound
'
    Dim current As CRbt

    ' find node specified by key
    Set current = Root
    Do While Not current Is Sentinel
        If current.Key = Key Then
            Set FindNode = current
            Exit Function
        Else
            If Key < current.Key Then
                Set current = current.Left
            Else
                Set current = current.Right
            End If
        End If
    Loop
    Err.Raise errKeyNotFound, "Rbt.FindNode"
End Function

Private Sub RotateLeft(ByRef x As CRbt)
'   inputs:
'       x                     designates node
'   action:
'       perform a left tree rotation about "x"
'
    Dim y As CRbt

    ' rotate node x to left

    Set y = x.Right

    ' establish x.Right link
    Set x.Right = y.Left
    If Not y.Left Is Sentinel Then Set y.Left.Parent = x

    ' establish y.Parent link
    If Not y Is Sentinel Then Set y.Parent = x.Parent
    If Not x.Parent Is Nothing Then
        If x Is x.Parent.Left Then
            Set x.Parent.Left = y
        Else
            Set x.Parent.Right = y
        End If
    Else
        Set Root = y
    End If

    ' link x and y
    Set y.Left = x
    If Not x Is Sentinel Then Set x.Parent = y
End Sub

Private Sub RotateRight(ByRef x As CRbt)
'   inputs:
'       x                     designates node
'   action:
'       perform a right tree rotation about "x"
'
    Dim y As CRbt

    ' rotate node x to right

    Set y = x.Left

    ' establish x.Left link
    Set x.Left = y.Right
    If Not y.Right Is Sentinel Then Set y.Right.Parent = x

    ' establish y.parent link
    If Not y Is Sentinel Then Set y.Parent = x.Parent
    If Not x.Parent Is Nothing Then
        If x Is x.Parent.Right Then
            Set x.Parent.Right = y
        Else
            Set x.Parent.Left = y
        End If
    Else
        Set Root = y
    End If

    ' link x and y
    Set y.Right = x
    If Not x Is Sentinel Then Set x.Parent = y
End Sub

Private Sub InsertFixup(ByRef x As CRbt)
'   inputs:
'       x                     designates node
'   action:
'       maintains red-black tree properties after inserting node x
'
    Dim y As CRbt

    ' maintain Red-Black tree balance
    ' after inserting node x

    ' check Red-Black properties
    Do While (Not x Is Root)
        If x.Parent.Color <> Red Then Exit Do
        ' we have a violation
        If x.Parent Is x.Parent.Parent.Left Then
            Set y = x.Parent.Parent.Right
            If y.Color = Red Then

                ' uncle is Red
                x.Parent.Color = Black
                y.Color = Black
                x.Parent.Parent.Color = Red
                Set x = x.Parent.Parent
            Else

                ' uncle is Black
                If x Is x.Parent.Right Then
                    ' make x a left child
                    Set x = x.Parent
                    RotateLeft x
                End If

                ' recolor and rotate
                x.Parent.Color = Black
                x.Parent.Parent.Color = Red
                RotateRight x.Parent.Parent
            End If
        Else

            ' mirror image of above code
            Set y = x.Parent.Parent.Left
            If y.Color = Red Then

                ' uncle is Red
                x.Parent.Color = Black
                y.Color = Black
                x.Parent.Parent.Color = Red
                Set x = x.Parent.Parent
            Else

                ' uncle is Black
                If x Is x.Parent.Left Then
                    Set x = x.Parent
                    RotateRight x
                End If
                x.Parent.Color = Black
                x.Parent.Parent.Color = Red
                RotateLeft x.Parent.Parent
            End If
        End If
    Loop
    Root.Color = Black
End Sub

Public Sub Insert(ByVal KeyVal As Variant, ByRef RecVal As Variant)
'   inputs:
'       KeyVal                key of node to insert
'       RecVal                record associated with key
'   action:
'       Inserts record RecVal with key KeyVal.
'   error:
'       errDuplicateKey
'
    Dim current As CRbt
    Dim Parent As CRbt
    Dim x As CRbt

    ' allocate node for data and insert in tree

    ' find where node belongs
    Set current = Root
    Set Parent = Nothing
    Do While Not current Is Sentinel
        If current.Key = KeyVal Then Raise errDuplicateKey, "Rbt.Insert"
        Set Parent = current
        If KeyVal < current.Key Then
            Set current = current.Left
        Else
            Set current = current.Right
        End If
    Loop

    ' setup new node
    Set x = New CRbt
    Set x.Parent = Parent
    Set x.Left = Sentinel
    Set x.Right = Sentinel
    x.Color = Red
    
    ' copy fields to node
    x.Key = KeyVal
    x.Rec = RecVal

    ' insert node in tree
    If Not Parent Is Nothing Then
        If KeyVal < Parent.Key Then
            Set Parent.Left = x
        Else
            Set Parent.Right = x
        End If
    Else
        Set Root = x
    End If

    InsertFixup x
    Set LastFind = Sentinel
End Sub

Private Sub DeleteFixup(ByRef x As CRbt)
'   inputs:
'       x                     designates node
'   action:
'       maintains red-black tree properties after deleting a node
'
    Dim w As CRbt

    ' maintain Red-Black tree balance
    ' after deleting node x

    Do While Not x Is Root
        If x.Color <> Black Then Exit Do
        If x Is x.Parent.Left Then
            Set w = x.Parent.Right
            If w.Color = Red Then
                w.Color = Black
                x.Parent.Color = Red
                RotateLeft x.Parent
                Set w = x.Parent.Right
            End If
            If w.Left.Color = Black And w.Right.Color = Black Then
                w.Color = Red
                Set x = x.Parent
            Else
                If w.Right.Color = Black Then
                    w.Left.Color = Black
                    w.Color = Red
                    RotateRight w
                    Set w = x.Parent.Right
                End If
                w.Color = x.Parent.Color
                x.Parent.Color = Black
                w.Right.Color = Black
                RotateLeft x.Parent
                Set x = Root
            End If
        Else
            Set w = x.Parent.Left
            If w.Color = Red Then
                w.Color = Black
                x.Parent.Color = Red
                RotateRight x.Parent
                Set w = x.Parent.Left
            End If
            If w.Right.Color = Black And w.Left.Color = Black Then
                w.Color = Red
                Set x = x.Parent
            Else
                If w.Left.Color = Black Then
                    w.Right.Color = Black
                    w.Color = Red
                    RotateLeft w
                    Set w = x.Parent.Left
                End If
                w.Color = x.Parent.Color
                x.Parent.Color = Black
                w.Left.Color = Black
                RotateRight x.Parent
                Set x = Root
            End If
        End If
    Loop
    x.Color = Black
End Sub

Public Sub Delete(ByVal KeyVal As Variant)
'   inputs:
'       KeyVal                key of node to delete
'   action:
'       Deletes record with key KeyVal.
'   error:
'       errKeyNotFound
'
    Dim x As CRbt
    Dim y As CRbt
    Dim z As CRbt
    
    If Not LastFind Is Sentinel Then
        If LastFind.Rec = KeyVal Then
            Set z = LastFind
        Else
            Set z = FindNode(KeyVal)
        End If
    Else
        Set z = FindNode(KeyVal)
    End If
    
    '  delete node z from tree
    If z.Left Is Sentinel Or z.Right Is Sentinel Then
        ' y has a Sentinel node as a child
        Set y = z
    Else
        ' find tree successor with a Sentinel node as a child
        Set y = z.Right
        Do While Not y.Left Is Sentinel
            Set y = y.Left
        Loop
    End If

    ' x is y's only child, and x may be a sentinel node
    If Not y.Left Is Sentinel Then
        Set x = y.Left
    Else
        Set x = y.Right
    End If

    ' remove y from the parent chain
    Set x.Parent = y.Parent
    If Not y.Parent Is Nothing Then
        If y Is y.Parent.Left Then
            Set y.Parent.Left = x
        Else
            Set y.Parent.Right = x
        End If
    Else
        Set Root = x
    End If

    ' copy data fields from y to z
    If Not y Is z Then
        z.Key = y.Key
        z.Rec = y.Rec
    End If
    
    ' if we removed a black node, we need to do some fixup
    If y.Color = Black Then DeleteFixup x

    ' y is freed automatically, as it's no longer referenced

    Set LastFind = Sentinel
End Sub

Public Function Find(ByVal KeyVal) As Variant
'   inputs:
'       KeyVal                key of node to delete
'   returns:
'       record associated with key
'   action:
'       Finds record with key KeyVal
'   error:
'       errKeyNotFound
'
    Set LastFind = FindNode(KeyVal)
    Find = LastFind.Rec
End Function

Public Sub Init()
'   action:
'       initialize tree
'
    Set Sentinel = New CRbt
    Set Sentinel.Left = Sentinel
    Set Sentinel.Right = Sentinel
    Set Sentinel.Parent = Nothing
    Sentinel.Color = Black
    Set Root = Sentinel
    Set LastFind = Sentinel
End Sub

Private Sub ZapNode(x As CRbt)
'   inputs:
'       x       node in tree
'   action:
'       recursively set all parent pointers to Nothing
'
    If x Is Nothing Then Exit Sub
    Set x.Parent = Nothing
    ZapNode x.Left
    ZapNode x.Right
End Sub

Public Sub Term()
'   action:
'       release memory
'
    ' free sentinel
    Set Sentinel.Left = Nothing
    Set Sentinel.Right = Nothing
    Set Sentinel.Parent = Nothing
    Set Sentinel = Nothing
    
    ' remove all parent pointers
    ZapNode Root.Left
    ZapNode Root.Right
    
    ' now, freeing root will free whole tree
    Set Root = Nothing
End Sub