VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CRbt" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit ' red-black tree, array Method Private GrowthFactor As Double ' sentinel is Node(0) Private Const Sentinel As Long = 0 ' housekeeping for node Private Enum EColor Black Red End Enum ' fields associated with each node Private Left() As Long ' left child Private Right() As Long ' right child Private Parent() As Long ' parent Private Color() As EColor ' red or black Private key() As Variant ' user's key Private rec() As Variant ' user's data associated with key ' support for FindFirst and FindNext Private StackIndex As Integer Private Stack(1 To 32) As Long Private NextNode As Long Private Root As Long ' root of binary tree Private Node As CNode ' class for allocating nodes Private LastFind As Long ' last node found Private Function FindNode(ByVal KeyVal As Variant) As Long ' 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 Long ' find node specified by key current = Root Do While current <> Sentinel If key(current) = KeyVal Then FindNode = current Exit Function Else If KeyVal < key(current) Then current = Left(current) Else current = Right(current) End If End If Loop Raise errKeyNotFound, "CRbt.FindNode" End Function Private Sub RotateLeft(ByVal x As Long) ' inputs: ' x designates node ' action: ' perform a left tree rotation about "x" ' Dim y As Long ' rotate node x to left y = Right(x) ' establish x.Right link Right(x) = Left(y) If Left(y) <> Sentinel Then Parent(Left(y)) = x ' establish y.Parent link If y <> Sentinel Then Parent(y) = Parent(x) If Parent(x) <> 0 Then If x = Left(Parent(x)) Then Left(Parent(x)) = y Else Right(Parent(x)) = y End If Else Root = y End If ' link x and y Left(y) = x If x <> Sentinel Then Parent(x) = y End Sub Private Sub RotateRight(ByVal x As Long) ' inputs: ' x designates node ' action: ' perform a right tree rotation about "x" ' Dim y As Long ' rotate node x to right y = Left(x) ' establish x.Left link Left(x) = Right(y) If Right(y) <> Sentinel Then Parent(Right(y)) = x ' establish y.parent link If y <> Sentinel Then Parent(y) = Parent(x) If Parent(x) <> 0 Then If x = Right(Parent(x)) Then Right(Parent(x)) = y Else Left(Parent(x)) = y End If Else Root = y End If ' link x and y Right(y) = x If x <> Sentinel Then Parent(x) = y End Sub Private Sub InsertFixup(ByRef x As Long) ' inputs: ' x designates node ' action: ' maintains red-black tree properties after inserting node x ' Dim y As Long Do While x <> Root If Color(Parent(x)) <> Red Then Exit Do ' we have a violation If Parent(x) = Left(Parent(Parent(x))) Then y = Right(Parent(Parent(x))) If Color(y) = Red Then ' uncle is Red Color(Parent(x)) = Black Color(y) = Black Color(Parent(Parent(x))) = Red x = Parent(Parent(x)) Else ' uncle is Black If x = Right(Parent(x)) Then ' make x a left child x = Parent(x) RotateLeft x End If ' recolor and rotate Color(Parent(x)) = Black Color(Parent(Parent(x))) = Red RotateRight Parent(Parent(x)) End If Else ' mirror image of above code y = Left(Parent(Parent(x))) If Color(y) = Red Then ' uncle is Red Color(Parent(x)) = Black Color(y) = Black Color(Parent(Parent(x))) = Red x = Parent(Parent(x)) Else ' uncle is Black If x = Left(Parent(x)) Then x = Parent(x) RotateRight x End If Color(Parent(x)) = Black Color(Parent(Parent(x))) = Red RotateLeft Parent(Parent(x)) End If End If Loop Color(Root) = 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 Long Dim p As Long Dim x As Long ' allocate node for data and insert in tree ' find where node belongs current = Root p = 0 Do While current <> Sentinel If key(current) = KeyVal Then Raise errDuplicateKey, "CRbt.Insert" p = current If KeyVal < key(current) Then current = Left(current) Else current = Right(current) End If Loop ' setup new node x = Node.Alloc() If x > UBound(key) Then ReDim Preserve Left(0 To UBound(Left) * GrowthFactor) ReDim Preserve Right(0 To UBound(Right) * GrowthFactor) ReDim Preserve Parent(0 To UBound(Parent) * GrowthFactor) ReDim Preserve Color(0 To UBound(Color) * GrowthFactor) ReDim Preserve key(0 To UBound(key) * GrowthFactor) ReDim Preserve rec(0 To UBound(key) * GrowthFactor) End If Parent(x) = p Left(x) = Sentinel Right(x) = Sentinel Color(x) = Red ' copy fields to node key(x) = KeyVal rec(x) = RecVal ' insert node in tree If p <> 0 Then If KeyVal < key(p) Then Left(p) = x Else Right(p) = x End If Else Root = x End If InsertFixup x LastFind = Sentinel End Sub Private Sub DeleteFixup(ByRef x As Long) ' inputs: ' x designates node ' action: ' maintains red-black tree properties after deleting a node ' Dim w As Long Do While (x <> Root) If Color(x) <> Black Then Exit Do If x = Left(Parent(x)) Then w = Right(Parent(x)) If Color(w) = Red Then Color(w) = Black Color(Parent(x)) = Red RotateLeft Parent(x) w = Right(Parent(x)) End If If Color(Left(w)) = Black _ And Color(Right(w)) = Black Then Color(w) = Red x = Parent(x) Else If Color(Right(w)) = Black Then Color(Left(w)) = Black Color(w) = Red RotateRight w w = Right(Parent(x)) End If Color(w) = Color(Parent(x)) Color(Parent(x)) = Black Color(Right(w)) = Black RotateLeft Parent(x) x = Root End If Else w = Left(Parent(x)) If Color(w) = Red Then Color(w) = Black Color(Parent(x)) = Red RotateRight Parent(x) w = Left(Parent(x)) End If If Color(Right(w)) = Black _ And Color(Left(w)) = Black Then Color(w) = Red x = Parent(x) Else If Color(Left(w)) = Black Then Color(Right(w)) = Black Color(w) = Red RotateLeft w w = Left(Parent(x)) End If Color(w) = Color(Parent(x)) Color(Parent(x)) = Black Color(Left(w)) = Black RotateRight Parent(x) x = Root End If End If Loop Color(x) = 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 Long Dim y As Long Dim z As Long If LastFind <> Sentinel Then If key(LastFind) = KeyVal Then z = LastFind Else z = FindNode(KeyVal) End If Else z = FindNode(KeyVal) End If ' delete node z from tree If Left(z) = Sentinel Or Right(z) = Sentinel Then ' y has a Sentinel node as a child y = z Else ' find tree successor with a Sentinel node as a child y = Right(z) Do While Left(y) <> Sentinel y = Left(y) Loop End If ' x is y's only child, and x may be a sentinel node If Left(y) <> Sentinel Then x = Left(y) Else x = Right(y) End If ' remove y from the parent chain Parent(x) = Parent(y) If Parent(y) <> 0 Then If y = Left(Parent(y)) Then Left(Parent(y)) = x Else Right(Parent(y)) = x End If Else Root = x End If ' copy data fields from y to z If y <> z Then key(z) = key(y) rec(z) = rec(y) End If ' if we removed a black node, we need to do some fixup If Color(y) = Black Then DeleteFixup x Set rec(y) = Nothing Node.Free y 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 ' LastFind = FindNode(KeyVal) Find = rec(LastFind) End Function Private Function GetNextNode() As Long ' returns: ' index to next node, 0 if none ' action: ' Finds index to next node. ' Do While (NextNode <> 0 Or StackIndex <> 0) Do While NextNode <> 0 StackIndex = StackIndex + 1 Stack(StackIndex) = NextNode NextNode = Left(NextNode) Loop GetNextNode = Stack(StackIndex) StackIndex = StackIndex - 1 NextNode = Right(GetNextNode) Exit Function Loop Raise errKeyNotFound, "CRbt.GetNextNode" End Function Public Function FindFirst(ByRef KeyVal As Variant) As Variant ' outputs: ' KeyVal key of node to find ' returns: ' record associated with key ' action: ' For sequential access, finds first record. ' errors: ' errKeyNotFound ' Dim n As Long ' for sequential access, call FindFirst, followed by ' repeated calls to FindNext StackIndex = 0 NextNode = Root n = GetNextNode() LastFind = n KeyVal = key(n) FindFirst = rec(n) End Function Public Function FindNext(ByRef KeyVal As Variant) As Variant ' outputs: ' KeyVal record key ' returns: ' record associated with key ' action: ' For sequential access, finds next record. ' errors: ' errKeyNotFound ' Dim n As Long ' for sequential access, call FindFirst, followed by ' repeated calls to FindNext n = GetNextNode() LastFind = n KeyVal = key(n) FindNext = rec(n) End Function Public Sub Init( _ ByVal InitialAllocVal As Long, _ ByVal GrowthFactorVal As Single) ' inputs: ' InitialAllocVal initial value for allocating nodes ' GrowthFactorVal amount to grow node storage space ' action: ' initialize tree ' GrowthFactor = GrowthFactorVal ' allocate nodes ReDim Left(0 To InitialAllocVal) ReDim Right(0 To InitialAllocVal) ReDim Parent(0 To InitialAllocVal) ReDim Color(0 To InitialAllocVal) ReDim key(0 To InitialAllocVal) ReDim rec(0 To InitialAllocVal) ' initialize root and sentinel Left(Sentinel) = Sentinel Right(Sentinel) = Sentinel Parent(Sentinel) = 0 Color(Sentinel) = Black Root = Sentinel LastFind = Sentinel ' startup node manager Set Node = New CNode Node.Init InitialAllocVal, GrowthFactorVal StackIndex = 0 End Sub Private Sub Class_Terminate() ' action: ' release memory ' Set Node = Nothing End Sub