4 Persistable = 0 'NotPersistable
5 DataBindingBehavior = 0 'vbNone
6 DataSourceBehavior = 0 'vbNone
7 MTSTransactionMode = 0 'NotAnMTSObject
9 Attribute VB_Name = "CRbt"
10 Attribute VB_GlobalNameSpace = False
11 Attribute VB_Creatable = True
12 Attribute VB_PredeclaredId = False
13 Attribute VB_Exposed = False
16 ' red-black tree, array Method
18 Private GrowthFactor As Double
21 Private Const Sentinel As Long = 0
23 ' housekeeping for node
29 ' fields associated with each node
30 Private Left() As Long ' left child
31 Private Right() As Long ' right child
32 Private Parent() As Long ' parent
33 Private Color() As EColor ' red or black
34 Private key() As Variant ' user's key
35 Private rec() As Variant ' user's data associated with key
37 ' support for FindFirst and FindNext
38 Private StackIndex As Integer
39 Private Stack(1 To 32) As Long
40 Private NextNode As Long
42 Private Root As Long ' root of binary tree
43 Private Node As CNode ' class for allocating nodes
44 Private LastFind As Long ' last node found
46 Private Function FindNode(ByVal KeyVal As Variant) As Long
48 ' Key ' designates key to find
52 ' Search tree for designated key, and return index to node.
58 ' find node specified by key
60 Do While current <> Sentinel
61 If key(current) = KeyVal Then
65 If KeyVal < key(current) Then
66 current = Left(current)
68 current = Right(current)
72 Raise errKeyNotFound, "CRbt.FindNode"
75 Private Sub RotateLeft(ByVal x As Long)
79 ' perform a left tree rotation about "x"
83 ' rotate node x to left
87 ' establish x.Right link
89 If Left(y) <> Sentinel Then Parent(Left(y)) = x
91 ' establish y.Parent link
92 If y <> Sentinel Then Parent(y) = Parent(x)
93 If Parent(x) <> 0 Then
94 If x = Left(Parent(x)) Then
105 If x <> Sentinel Then Parent(x) = y
108 Private Sub RotateRight(ByVal x As Long)
112 ' perform a right tree rotation about "x"
116 ' rotate node x to right
120 ' establish x.Left link
122 If Right(y) <> Sentinel Then Parent(Right(y)) = x
124 ' establish y.parent link
125 If y <> Sentinel Then Parent(y) = Parent(x)
126 If Parent(x) <> 0 Then
127 If x = Right(Parent(x)) Then
138 If x <> Sentinel Then Parent(x) = y
141 Private Sub InsertFixup(ByRef x As Long)
145 ' maintains red-black tree properties after inserting node x
150 If Color(Parent(x)) <> Red Then Exit Do
151 ' we have a violation
152 If Parent(x) = Left(Parent(Parent(x))) Then
153 y = Right(Parent(Parent(x)))
154 If Color(y) = Red Then
157 Color(Parent(x)) = Black
159 Color(Parent(Parent(x))) = Red
160 x = Parent(Parent(x))
164 If x = Right(Parent(x)) Then
165 ' make x a left child
171 Color(Parent(x)) = Black
172 Color(Parent(Parent(x))) = Red
173 RotateRight Parent(Parent(x))
177 ' mirror image of above code
178 y = Left(Parent(Parent(x)))
179 If Color(y) = Red Then
182 Color(Parent(x)) = Black
184 Color(Parent(Parent(x))) = Red
185 x = Parent(Parent(x))
189 If x = Left(Parent(x)) Then
193 Color(Parent(x)) = Black
194 Color(Parent(Parent(x))) = Red
195 RotateLeft Parent(Parent(x))
202 Public Sub Insert(ByVal KeyVal As Variant, ByRef RecVal As Variant)
204 ' KeyVal key of node to insert
205 ' RecVal record associated with key
207 ' Inserts record RecVal with key KeyVal.
215 ' allocate node for data and insert in tree
217 ' find where node belongs
220 Do While current <> Sentinel
221 If key(current) = KeyVal Then Raise errDuplicateKey, "CRbt.Insert"
223 If KeyVal < key(current) Then
224 current = Left(current)
226 current = Right(current)
232 If x > UBound(key) Then
233 ReDim Preserve Left(0 To UBound(Left) * GrowthFactor)
234 ReDim Preserve Right(0 To UBound(Right) * GrowthFactor)
235 ReDim Preserve Parent(0 To UBound(Parent) * GrowthFactor)
236 ReDim Preserve Color(0 To UBound(Color) * GrowthFactor)
237 ReDim Preserve key(0 To UBound(key) * GrowthFactor)
238 ReDim Preserve rec(0 To UBound(key) * GrowthFactor)
245 ' copy fields to node
249 ' insert node in tree
251 If KeyVal < key(p) Then
264 Private Sub DeleteFixup(ByRef x As Long)
268 ' maintains red-black tree properties after deleting a node
273 If Color(x) <> Black Then Exit Do
274 If x = Left(Parent(x)) Then
276 If Color(w) = Red Then
278 Color(Parent(x)) = Red
282 If Color(Left(w)) = Black _
283 And Color(Right(w)) = Black Then
287 If Color(Right(w)) = Black Then
288 Color(Left(w)) = Black
293 Color(w) = Color(Parent(x))
294 Color(Parent(x)) = Black
295 Color(Right(w)) = Black
301 If Color(w) = Red Then
303 Color(Parent(x)) = Red
304 RotateRight Parent(x)
307 If Color(Right(w)) = Black _
308 And Color(Left(w)) = Black Then
312 If Color(Left(w)) = Black Then
313 Color(Right(w)) = Black
318 Color(w) = Color(Parent(x))
319 Color(Parent(x)) = Black
320 Color(Left(w)) = Black
321 RotateRight Parent(x)
329 Public Sub Delete(ByVal KeyVal As Variant)
331 ' KeyVal key of node to delete
333 ' Deletes record with key KeyVal.
341 If LastFind <> Sentinel Then
342 If key(LastFind) = KeyVal Then
351 ' delete node z from tree
352 If Left(z) = Sentinel Or Right(z) = Sentinel Then
353 ' y has a Sentinel node as a child
356 ' find tree successor with a Sentinel node as a child
358 Do While Left(y) <> Sentinel
363 ' x is y's only child, and x may be a sentinel node
364 If Left(y) <> Sentinel Then
370 ' remove y from the parent chain
371 Parent(x) = Parent(y)
372 If Parent(y) <> 0 Then
373 If y = Left(Parent(y)) Then
382 ' copy data fields from y to z
388 ' if we removed a black node, we need to do some fixup
389 If Color(y) = Black Then DeleteFixup x
397 Public Function Find(ByVal KeyVal) As Variant
399 ' KeyVal key of node to delete
401 ' record associated with key
403 ' Finds record with key KeyVal
407 LastFind = FindNode(KeyVal)
411 Private Function GetNextNode() As Long
413 ' index to next node, 0 if none
415 ' Finds index to next node.
417 Do While (NextNode <> 0 Or StackIndex <> 0)
418 Do While NextNode <> 0
419 StackIndex = StackIndex + 1
420 Stack(StackIndex) = NextNode
421 NextNode = Left(NextNode)
423 GetNextNode = Stack(StackIndex)
424 StackIndex = StackIndex - 1
425 NextNode = Right(GetNextNode)
428 Raise errKeyNotFound, "CRbt.GetNextNode"
431 Public Function FindFirst(ByRef KeyVal As Variant) As Variant
433 ' KeyVal key of node to find
435 ' record associated with key
437 ' For sequential access, finds first record.
443 ' for sequential access, call FindFirst, followed by
444 ' repeated calls to FindNext
454 Public Function FindNext(ByRef KeyVal As Variant) As Variant
458 ' record associated with key
460 ' For sequential access, finds next record.
466 ' for sequential access, call FindFirst, followed by
467 ' repeated calls to FindNext
476 ByVal InitialAllocVal As Long, _
477 ByVal GrowthFactorVal As Single)
479 ' InitialAllocVal initial value for allocating nodes
480 ' GrowthFactorVal amount to grow node storage space
484 GrowthFactor = GrowthFactorVal
487 ReDim Left(0 To InitialAllocVal)
488 ReDim Right(0 To InitialAllocVal)
489 ReDim Parent(0 To InitialAllocVal)
490 ReDim Color(0 To InitialAllocVal)
491 ReDim key(0 To InitialAllocVal)
492 ReDim rec(0 To InitialAllocVal)
494 ' initialize root and sentinel
495 Left(Sentinel) = Sentinel
496 Right(Sentinel) = Sentinel
498 Color(Sentinel) = Black
502 ' startup node manager
504 Node.Init InitialAllocVal, GrowthFactorVal
510 Private Sub Class_Terminate()