C/sorting.and.searching.cormen.algo/src/var.txt

   1 VERSION 1.0 CLASS
   2 BEGIN
   3   MultiUse = -1  'True
   4   Persistable = 0  'NotPersistable
   5   DataBindingBehavior = 0  'vbNone
   6   DataSourceBehavior  = 0  'vbNone
   7   MTSTransactionMode  = 0  'NotAnMTSObject
   8 END
   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
  14 Option Explicit
  15
  16 ' red-black tree, array Method
  17
  18 Private GrowthFactor As Double
  19
  20 ' sentinel is Node(0)
  21 Private Const Sentinel As Long = 0
  22
  23 ' housekeeping for node
  24 Private Enum EColor
  25     Black
  26     Red
  27 End Enum
  28
  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
  36
  37 ' support for FindFirst and FindNext
  38 Private StackIndex As Integer
  39 Private Stack(1 To 32) As Long
  40 Private NextNode As Long
  41
  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
  45
  46 Private Function FindNode(ByVal KeyVal As Variant) As Long
  47 '   inputs:
  48 '       Key                   ' designates key to find
  49 '   returns:
  50 '       index to node
  51 '   action:
  52 '       Search tree for designated key, and return index to node.
  53 '   errors:
  54 '       errKeyNotFound
  55 '
  56     Dim current As Long
  57
  58     ' find node specified by key
  59     current = Root
  60     Do While current <> Sentinel
  61         If key(current) = KeyVal Then
  62             FindNode = current
  63             Exit Function
  64         Else
  65             If KeyVal < key(current) Then
  66                 current = Left(current)
  67             Else
  68                 current = Right(current)
  69             End If
  70         End If
  71     Loop
  72     Raise errKeyNotFound, "CRbt.FindNode"
  73 End Function
  74
  75 Private Sub RotateLeft(ByVal x As Long)
  76 '   inputs:
  77 '       x                     designates node
  78 '   action:
  79 '       perform a left tree rotation about "x"
  80 '
  81     Dim y As Long
  82
  83     ' rotate node x to left
  84
  85     y = Right(x)
  86
  87     ' establish x.Right link
  88     Right(x) = Left(y)
  89     If Left(y) <> Sentinel Then Parent(Left(y)) = x
  90
  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
  95             Left(Parent(x)) = y
  96         Else
  97             Right(Parent(x)) = y
  98         End If
  99     Else
 100         Root = y
 101     End If
 102
 103     ' link x and y
 104     Left(y) = x
 105     If x <> Sentinel Then Parent(x) = y
 106 End Sub
 107
 108 Private Sub RotateRight(ByVal x As Long)
 109 '   inputs:
 110 '       x                     designates node
 111 '   action:
 112 '       perform a right tree rotation about "x"
 113 '
 114     Dim y As Long
 115
 116     ' rotate node x to right
 117
 118     y = Left(x)
 119
 120     ' establish x.Left link
 121     Left(x) = Right(y)
 122     If Right(y) <> Sentinel Then Parent(Right(y)) = x
 123
 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
 128             Right(Parent(x)) = y
 129         Else
 130             Left(Parent(x)) = y
 131         End If
 132     Else
 133         Root = y
 134     End If
 135
 136     ' link x and y
 137     Right(y) = x
 138     If x <> Sentinel Then Parent(x) = y
 139 End Sub
 140
 141 Private Sub InsertFixup(ByRef x As Long)
 142 '   inputs:
 143 '       x                     designates node
 144 '   action:
 145 '       maintains red-black tree properties after inserting node x
 146 '
 147     Dim y As Long
 148
 149     Do While x <> Root
 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
 155
 156                 ' uncle is Red
 157                 Color(Parent(x)) = Black
 158                 Color(y) = Black
 159                 Color(Parent(Parent(x))) = Red
 160                 x = Parent(Parent(x))
 161             Else
 162
 163                 ' uncle is Black
 164                 If x = Right(Parent(x)) Then
 165                     ' make x a left child
 166                     x = Parent(x)
 167                     RotateLeft x
 168                 End If
 169
 170                 ' recolor and rotate
 171                 Color(Parent(x)) = Black
 172                 Color(Parent(Parent(x))) = Red
 173                 RotateRight Parent(Parent(x))
 174             End If
 175         Else
 176
 177             ' mirror image of above code
 178             y = Left(Parent(Parent(x)))
 179             If Color(y) = Red Then
 180
 181                 ' uncle is Red
 182                 Color(Parent(x)) = Black
 183                 Color(y) = Black
 184                 Color(Parent(Parent(x))) = Red
 185                 x = Parent(Parent(x))
 186             Else
 187
 188                 ' uncle is Black
 189                 If x = Left(Parent(x)) Then
 190                     x = Parent(x)
 191                     RotateRight x
 192                 End If
 193                 Color(Parent(x)) = Black
 194                 Color(Parent(Parent(x))) = Red
 195                 RotateLeft Parent(Parent(x))
 196             End If
 197         End If
 198     Loop
 199     Color(Root) = Black
 200 End Sub
 201
 202 Public Sub Insert(ByVal KeyVal As Variant, ByRef RecVal As Variant)
 203 '   inputs:
 204 '       KeyVal                key of node to insert
 205 '       RecVal                record associated with key
 206 '   action:
 207 '       Inserts record RecVal with key KeyVal.
 208 '   error:
 209 '       errDuplicateKey
 210 '
 211     Dim current As Long
 212     Dim p As Long
 213     Dim x As Long
 214
 215     ' allocate node for data and insert in tree
 216
 217     ' find where node belongs
 218     current = Root
 219     p = 0
 220     Do While current <> Sentinel
 221         If key(current) = KeyVal Then Raise errDuplicateKey, "CRbt.Insert"
 222         p = current
 223         If KeyVal < key(current) Then
 224             current = Left(current)
 225         Else
 226             current = Right(current)
 227         End If
 228     Loop
 229
 230     ' setup new node
 231     x = Node.Alloc()
 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)
 239     End If
 240     Parent(x) = p
 241     Left(x) = Sentinel
 242     Right(x) = Sentinel
 243     Color(x) = Red
 244
 245     ' copy fields to node
 246     key(x) = KeyVal
 247     rec(x) = RecVal
 248
 249     ' insert node in tree
 250     If p <> 0 Then
 251         If KeyVal < key(p) Then
 252             Left(p) = x
 253         Else
 254             Right(p) = x
 255         End If
 256     Else
 257         Root = x
 258     End If
 259
 260     InsertFixup x
 261     LastFind = Sentinel
 262 End Sub
 263
 264 Private Sub DeleteFixup(ByRef x As Long)
 265 '   inputs:
 266 '       x                     designates node
 267 '   action:
 268 '       maintains red-black tree properties after deleting a node
 269 '
 270     Dim w As Long
 271
 272     Do While (x <> Root)
 273         If Color(x) <> Black Then Exit Do
 274         If x = Left(Parent(x)) Then
 275             w = Right(Parent(x))
 276             If Color(w) = Red Then
 277                 Color(w) = Black
 278                 Color(Parent(x)) = Red
 279                 RotateLeft Parent(x)
 280                 w = Right(Parent(x))
 281             End If
 282             If Color(Left(w)) = Black _
 283             And Color(Right(w)) = Black Then
 284                 Color(w) = Red
 285                 x = Parent(x)
 286             Else
 287                 If Color(Right(w)) = Black Then
 288                     Color(Left(w)) = Black
 289                     Color(w) = Red
 290                     RotateRight w
 291                     w = Right(Parent(x))
 292                 End If
 293                 Color(w) = Color(Parent(x))
 294                 Color(Parent(x)) = Black
 295                 Color(Right(w)) = Black
 296                 RotateLeft Parent(x)
 297                 x = Root
 298             End If
 299         Else
 300             w = Left(Parent(x))
 301             If Color(w) = Red Then
 302                 Color(w) = Black
 303                 Color(Parent(x)) = Red
 304                 RotateRight Parent(x)
 305                 w = Left(Parent(x))
 306             End If
 307             If Color(Right(w)) = Black _
 308             And Color(Left(w)) = Black Then
 309                 Color(w) = Red
 310                 x = Parent(x)
 311             Else
 312                 If Color(Left(w)) = Black Then
 313                     Color(Right(w)) = Black
 314                     Color(w) = Red
 315                     RotateLeft w
 316                     w = Left(Parent(x))
 317                 End If
 318                 Color(w) = Color(Parent(x))
 319                 Color(Parent(x)) = Black
 320                 Color(Left(w)) = Black
 321                 RotateRight Parent(x)
 322                 x = Root
 323             End If
 324         End If
 325     Loop
 326     Color(x) = Black
 327 End Sub
 328
 329 Public Sub Delete(ByVal KeyVal As Variant)
 330 '   inputs:
 331 '       KeyVal                key of node to delete
 332 '   action:
 333 '       Deletes record with key KeyVal.
 334 '   error:
 335 '       errKeyNotFound
 336 '
 337     Dim x As Long
 338     Dim y As Long
 339     Dim z As Long
 340
 341     If LastFind <> Sentinel Then
 342         If key(LastFind) = KeyVal Then
 343             z = LastFind
 344         Else
 345             z = FindNode(KeyVal)
 346         End If
 347     Else
 348         z = FindNode(KeyVal)
 349     End If
 350
 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
 354         y = z
 355     Else
 356         ' find tree successor with a Sentinel node as a child
 357         y = Right(z)
 358         Do While Left(y) <> Sentinel
 359             y = Left(y)
 360         Loop
 361     End If
 362
 363     ' x is y's only child, and x may be a sentinel node
 364     If Left(y) <> Sentinel Then
 365         x = Left(y)
 366     Else
 367         x = Right(y)
 368     End If
 369
 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
 374             Left(Parent(y)) = x
 375         Else
 376             Right(Parent(y)) = x
 377         End If
 378     Else
 379         Root = x
 380     End If
 381
 382     ' copy data fields from y to z
 383     If y <> z Then
 384         key(z) = key(y)
 385         rec(z) = rec(y)
 386     End If
 387
 388     ' if we removed a black node, we need to do some fixup
 389     If Color(y) = Black Then DeleteFixup x
 390
 391     Set rec(y) = Nothing
 392     Node.Free y
 393
 394     LastFind = Sentinel
 395 End Sub
 396
 397 Public Function Find(ByVal KeyVal) As Variant
 398 '   inputs:
 399 '       KeyVal                key of node to delete
 400 '   returns:
 401 '       record associated with key
 402 '   action:
 403 '       Finds record with key KeyVal
 404 '   error:
 405 '       errKeyNotFound
 406 '
 407     LastFind = FindNode(KeyVal)
 408     Find = rec(LastFind)
 409 End Function
 410
 411 Private Function GetNextNode() As Long
 412 '   returns:
 413 '       index to next node, 0 if none
 414 '   action:
 415 '       Finds index to next node.
 416 '
 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)
 422         Loop
 423         GetNextNode = Stack(StackIndex)
 424         StackIndex = StackIndex - 1
 425         NextNode = Right(GetNextNode)
 426         Exit Function
 427     Loop
 428     Raise errKeyNotFound, "CRbt.GetNextNode"
 429 End Function
 430
 431 Public Function FindFirst(ByRef KeyVal As Variant) As Variant
 432 '   outputs:
 433 '       KeyVal                key of node to find
 434 '   returns:
 435 '       record associated with key
 436 '   action:
 437 '       For sequential access, finds first record.
 438 '   errors:
 439 '       errKeyNotFound
 440 '
 441     Dim n As Long
 442
 443     ' for sequential access, call FindFirst, followed by
 444     ' repeated calls to FindNext
 445
 446     StackIndex = 0
 447     NextNode = Root
 448     n = GetNextNode()
 449     LastFind = n
 450     KeyVal = key(n)
 451     FindFirst = rec(n)
 452 End Function
 453
 454 Public Function FindNext(ByRef KeyVal As Variant) As Variant
 455 '   outputs:
 456 '       KeyVal                record key
 457 '   returns:
 458 '       record associated with key
 459 '   action:
 460 '       For sequential access, finds next record.
 461 '   errors:
 462 '       errKeyNotFound
 463 '
 464     Dim n As Long
 465
 466     ' for sequential access, call FindFirst, followed by
 467     ' repeated calls to FindNext
 468
 469     n = GetNextNode()
 470     LastFind = n
 471     KeyVal = key(n)
 472     FindNext = rec(n)
 473 End Function
 474
 475 Public Sub Init( _
 476         ByVal InitialAllocVal As Long, _
 477         ByVal GrowthFactorVal As Single)
 478 '   inputs:
 479 '       InitialAllocVal         initial value for allocating nodes
 480 '       GrowthFactorVal         amount to grow node storage space
 481 '   action:
 482 '       initialize tree
 483 '
 484     GrowthFactor = GrowthFactorVal
 485
 486     ' allocate nodes
 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)
 493
 494     ' initialize root and sentinel
 495     Left(Sentinel) = Sentinel
 496     Right(Sentinel) = Sentinel
 497     Parent(Sentinel) = 0
 498     Color(Sentinel) = Black
 499     Root = Sentinel
 500     LastFind = Sentinel
 501
 502     ' startup node manager
 503     Set Node = New CNode
 504     Node.Init InitialAllocVal, GrowthFactorVal
 505
 506     StackIndex = 0
 507 End Sub
 508
 509
 510 Private Sub Class_Terminate()
 511 '   action:
 512 '       release memory
 513 '
 514     Set Node = Nothing
 515 End Sub