'
'  RedBlackTree.lss
'
'  Time-stamp: <2003-03-25 18:18:05 Daniel Eriksson>
'
'  Date        Author           Changes
'  ----------  ---------------  ------------------------------------
'  2003-03-25  Daniel Eriksson  Created
'

Private Const RED = 0
Private Const BLACK = 1

Public Class Comparison
' Abstract class for comparing two Variants. Comparison
' functors need to subclass Comparison.
'
  Public Function Compare(lhs As Variant, rhs As Variant) As Integer
  ' Returns a negative integer, zero, or a positive integer as lhs is less than, 
  ' equal to, or greater than rhs. 
  End Function
End Class

Public Class IntegerComparison As Comparison
' Functor for comparing integers.
'
  Public Function Compare(lhs As Variant, rhs As Variant) As Integer
    Compare = lhs - rhs
  End Function
End Class

Public Class StringComparison As Comparison
' Functor for comparing strings.
'
  Public Function Compare(lhs As Variant, rhs As Variant) As Integer
    If lhs < rhs Then
      Compare = -1
    Else
      If lhs = rhs Then
        Compare = 0
      Else
        Compare = 1
      End If
    End If
  End Function
End Class

Private Class RedBlackNode
' A red-black tree node.
'
  Public element As Variant 
  Public parent As RedBlackNode 
  Public left As RedBlackNode 
  Public right As RedBlackNode
  Public color As Integer
  
  Public Sub New(theElement As Variant, lt As RedBlackNode, _
  rt As RedBlackNode)
    
    If RequiresSet(theElement) Then
      Set element = theElement
    Else
      element = theElement
    End If
    
    SetleftChild lt
    SetrightChild rt
    color = BLACK
  End Sub
  
  Public Sub SetLeftChild(leftNode As RedBlackNode)
    If Not (Me.left Is Nothing) Then
      If (Me.left.parent Is Me) Then Set Me.left.parent = Nothing 
    End If
    Set Me.left = leftNode                                         
    If Not (Me.left Is Nothing) Then Set Me.left.parent = Me 
  End Sub
  
  Public Sub SetRightChild(rightNode As RedBlackNode)
    If Not (Me.right Is Nothing) Then
      If (Me.right.parent Is Me) Then Set Me.right.parent = Nothing 
    End If
    Set Me.right = rightNode                                      
    If Not (Me.right Is Nothing) Then Set Me.right.parent = Me
  End Sub  
End Class

Public Class RedBlackTree
' A red-black tree is data structure that provides
' an ordered collection without doubles.
' 
' It is a binary search tree with the following coloring 
' properties:
'  
' 1. Every node is colored either red or black.
' 2. The root is black.
' 3. If a node is red, its children must be black.
' 4. Every path from a node to a null refence must contain 
'    the same number of black nodes.
' 
' "A consequence of the coloring rules is that the height 
' of a red-black tree is at most 2 log(N + 1). Consequently, 
' searching is guaranteed to be a logarithmic operation."
' (Mark Allen Weiss, Data Structures and Algorithm Analysis 
' in Java)
'
' Example:
'  Dim int_functor As New IntegerComparison  
'  Dim int_tree As New RedBlackTree(int_functor)
'  
'  Print int_tree.Add(1) ' True
'  Printint_tree.Add(1) ' False
'  Print int_tree.Add(2) ' True
'  Print int_tree.Size() ' 2  
'  
  Private m_root As RedBlackNode 
  Private m_nullNode As RedBlackNode 
  Private m_comparison As Comparison
  Private m_size As Long
  
  Public Sub New(functor As Comparison)
    Set m_comparison = functor
    
    Set m_nullNode = New RedBlackNode(Nothing, Nothing, Nothing)
    m_nullNode.SetLeftChild m_nullNode 
    m_nullNode.SetRightChild m_nullNode
    
    Set m_root = m_nullNode    
    m_size = 0
  End Sub
  
  Property Get Size As Long
    Size = m_size
  End Property
  
  Public Function IsEmpty As Variant
  ' Returns true if the tree is empty; otherwise, 
  ' returns false
    Me.IsEmpty = (m_size = 0)
  End Function  
  
  Public Function Contains(element As Variant) As Variant
  ' Checks if the tree contains element.
  '
  ' Returns true if the set did not already contain 
  ' element; otherwise, returns false
  '
    Contains = Not FindNode(element) Is Nothing
  End Function
  
  Public Function Elements() As Variant
  ' Returns the elements in the tree as a sorted
  ' array.
  '
    Dim Result() As Variant   
    Redim Result(m_size - 1) As Variant
    
    CollectElements m_root, Result, 0 
    Elements = Result 
  End Function
  
  Public Function Add(e As Variant) As Variant
  ' Adds element to the tree if it is not already present.
  '
  ' Returns true if the tree did not already contain 
  ' element; otherwise, returns false.
  '
    Dim current As RedBlackNode 
    Set current = m_root
    
    If RequiresSet(e) Then
      Set m_nullNode.element = e
    Else
      m_nullNode.element = e
    End If
    
    Dim parent As RedBlackNode 
    
    ' Set parent to the leaf which should become parent.
    Do While Not (m_comparison.Compare(e, Current.element) = 0)      
      Set parent = current 
      If m_comparison.Compare(e, Current.element) < 0 Then
        Set current = current.left 
      Else
        Set current = current.right 
      End If
    Loop
    
    ' The new element was already in the tree.
    If Not (Current Is m_nullNode) Then
      Add = False
      Exit Function
    End If
    
    Set current = New RedBlackNode(e, m_nullNode, m_nullNode)
    
    If Not (parent Is Nothing) Then
      If m_comparison.Compare(e, parent.element) < 0 Then
        parent.SetLeftChild current
      Else
        parent.SetRightChild current 
      End If
    Else
      Set m_root = current
    End If
    
    HandleReorient current
    
    m_size = m_size + 1
    Add = True
  End Function
  
  Public Function Remove(element As Variant) As Variant
  ' Removes element from the tree if it is present.
  '
  ' Returns true if the tree contained element; 
  ' otherwise, returns false.
  '
    
        ' Delcare temporary nodes - there will be plenty of fixing to do
    Dim Temp As RedBlackNode
    Dim Temp2 As RedBlackNode
    Dim Temp3 As RedBlackNode
    
        ' Set Temp3 equal to the node we want to delete    
    Set Temp3 = FindNode(element)
    
    If Temp3 Is Nothing Then
      Me.Remove = False
      Exit Function
    End If
    
        ' Remove the node from the tree
    If (Temp3.left Is m_nullNode) Or (Temp3.right Is m_nullNode) Then
      Set Temp2 = Temp3                       ' We're at the end of the tree
    Else
      Set Temp2 = Temp3.right         ' Find a successor node
      Do While Not (Temp2.left Is m_nullNode)
        Set Temp2 = Temp2.left
      Loop
    End If
    
        ' Check for Temp2's child and store in Temp
    If Not (Temp2.left Is m_nullNode) Then
      Set Temp = Temp2.left
    Else
      Set Temp = Temp2.right
    End If
    
        ' Remove Temp2 from the list of parents
    Set Temp.parent = Temp2.parent
    If Not (Temp2.parent Is Nothing) Then
      If Temp2 Is Temp2.parent.left Then
        Temp2.parent.SetLeftChild Temp      ' Bring up the left child
      Else
        Temp2.parent.SetRightChild Temp     ' Bring up the right child
      End If
    Else
      Set m_root = Temp                         ' Can't forget about the root
    End If
    
        ' We removed a black node, so fix up the colours of the tree
    If Temp2.color = BLACK Then
      
            ' Syncronize our Red-Black structure
      Dim Temp4 As RedBlackNode
      
            ' Check the red-black properties
      Do While (Not Temp Is m_root)
        ' Check that everything is okay
        If Temp.color = RED Then Exit Do
        
        ' It's not, so continue to fix up the properties
        ' Each row must have opposite red-black colours. (TODO: Correct this.)
        ' Row 1 should be black, row 2 red, 3 black, etc.
        
        ' Check our sibling's properties
        If Temp Is Temp.parent.left Then
          
          Set Temp4 = Temp.parent.right 
          If Temp4.color = RED Then
            Temp4.color = BLACK
            Temp.parent.color = RED 
            Rotateleft Temp.parent
            Set Temp4 = Temp.parent.right 
          End If
          
          If (Temp4.left.color = BLACK) And (Temp4.right.color = BLACK) Then
            Temp4.color = RED  
            Set Temp = Temp.parent 
          Else
            
            If Temp4.right.color = BLACK Then
              Temp4.left.color = BLACK
              Temp4.color = RED
              Rotateright Temp4
              Set Temp4 = Temp.parent.right 
            End If
            Temp4.color = Temp.parent.color
            Temp.parent.color = BLACK
            Temp4.right.color = BLACK
            Rotateleft Temp.parent
            Set Temp = m_root
          End If
          
        Else
          
          Set Temp4 = Temp.parent.left  
          If Temp4.color = RED Then
            Temp4.color = BLACK
            Temp.parent.color = RED   
            Rotateright Temp.parent
            Set Temp4 = Temp.parent.left 
          End If
          
          If (Temp4.right.color = BLACK) And (Temp4.left.color = BLACK) Then
            Temp4.color = RED 
            Set Temp = Temp.parent 
          Else
            If Temp4.left.color = BLACK Then
              Temp4.right.color = BLACK
              Temp4.color = RED
              Rotateleft Temp4
              Set Temp4 = Temp.parent.left 
            End If
            Temp4.color = Temp.parent.color
            Temp.parent.color = BLACK
            Temp4.right.color = BLACK
            Rotateright Temp.parent
            Set Temp = m_root
          End If
          
        End If
      Loop
      
      Temp.color = BLACK
      
    End If
    
    m_size = m_size - 1
    Me.Remove = True
  End Function
  
  Private Sub RotateLeft(Node As RedBlackNode)
    
    Dim Temp As RedBlackNode
    Set Temp = Node.right ' Declare temporary node and rotate Node to the left
    
        ' Perform the rotation
    Node.SetRightChild Temp.left
    
        ' Set our parent if we aren't at the end of the tree
    If Not (Temp.left Is m_nullNode) Then Set Temp.left.parent = Node
    
        ' Fix up the parents now
    If Not (Temp Is m_nullNode) Then Set Temp.parent = Node.parent
    
    If Not (Node.parent Is Nothing) Then
      If Node Is Node.parent.left Then
        Node.parent.SetLeftChild Temp ' Rotate parent left
      Else
        Node.parent.SetRightChild Temp ' Rotate parent right
      End If
    Else
      Set m_root = Temp ' Rotation occuring about the root node
    End If
    
    ' Finish up
    Temp.SetLeftChild Node
    If Not (Node Is m_nullNode) Then Set Node.parent = Temp
  End Sub
  
  Private Sub RotateRight(Node As RedBlackNode)
    
    Dim Temp As RedBlackNode 
    Set Temp = Node.left ' Declare temporary node and rotate Node to the right
    
    ' Perform the rotation
    Node.SetLeftChild Temp.right
    
    ' Set parent if we aren't at the end of the tree
    If Not (Temp.right Is m_nullNode) Then Set Temp.right.parent = Node
    
    ' Fix parents
    If Not (Temp Is m_nullNode) Then Set Temp.parent = Node.parent 
    
    If Not (Node.parent Is Nothing) Then
      If Node Is Node.parent.right Then
        Node.parent.SetRightChild Temp ' Rotate parent right
      Else
        Node.parent.SetLeftChild Temp ' Rotate parent left
      End If
    Else
      Set m_root = Temp ' Rotation occuring about the root node
    End If
    
    ' Finish up
    Temp.SetRightChild Node
    If Not (Node Is m_nullNode) Then Set Node.parent = Temp
  End Sub
  
  Private Function FindNode(element As Variant) As RedBlackNode
    
    Dim Temp As RedBlackNode
    Set Temp = m_root
    
    Do While Not (Temp Is m_nullNode)
      If m_comparison.Compare(element, Temp.element) = 0 Then
        Set FindNode = Temp 
        Exit Function
      Else
        If m_comparison.Compare(element, Temp.element) < 0 Then
          Set Temp = Temp.left
        Else
          Set Temp = Temp.right 
        End If
      End If
    Loop
    
    Set FindNode = Nothing
  End Function
  
  Private Sub CollectElements(Current As RedBlackNode, _
  ResultList() As Variant, ndx As Long)
    If Not Current Is m_nullNode Then
      
      CollectElements Current.left, ResultList, ndx
      
      Set ResultList(ndx) = Current.element
      ndx = ndx + 1
      
      CollectElements Current.right, ResultList, ndx            
    End If
  End Sub
  
  Private Sub HandleReorient(current As RedBlackNode)
    Dim tmp As RedBlackNode
    
    ' Check the red-black properties
    Do While (Not current Is m_root)
      If current.parent.color = BLACK Then Exit Do
      
            'It's not, so continue to fix up the properties
            'Each row must have opposite red-black colours.
            'Row 1 should be black, row 2 red, 3 black, etc.
      
            ' Check our aunt's properties
      If current.parent Is current.parent.parent.left Then
        
        Set tmp = current.parent.parent.right 'Retrieve uncle and compare its properties
        If tmp.color = RED Then
          current.color = BLACK
          tmp.color = BLACK
          current.parent.parent.color = RED
          Set current = current.parent.parent 'Move to our grandparent
        Else
          If current Is current.parent.right Then
            Set current = current.parent 'Make the temp node a left child
            RotateLeft current
          End If
          
          ' Redo colours and rotate again
          current.parent.color = BLACK     
          current.parent.parent.color = RED
          RotateRight current.parent.parent
        End If
        
      Else
        ' Check uncle's properties        
        Set tmp = current.parent.parent.left 'Retrieve aunt and compare its properties
        If tmp.color = RED Then
          current.parent.color = BLACK   
          tmp.color = BLACK
          current.parent.parent.color = RED
          Set current = current.parent.parent 
        Else    
          If current Is current.parent.left Then
            Set current = current.parent  'Make the temp node a right child
            RotateRight current
          End If
          
                    ' Redo colours and rotate again
          current.parent.color = BLACK 
          current.parent.parent.color = RED
          RotateLeft current.parent.parent
        End If        
      End If      
    Loop
    
    m_root.color = BLACK 'The root is always black    
  End Sub
End Class

Function RequiresSet(v As Variant) As Variant
' Returns true if v's data type requires the
' key word "Set" in assignments; otherwise returns
' false.
'
  Dim data_type As Integer
  data_type = Datatype(v)
  If data_type = 9 Or data_type = 34 Or data_type = 35 Then
    RequiresSet = True
  Else
    RequiresSet = False
  End If
End Function