lang/C/sorting.and.searching.cormen.algo/src/vpr.txt

   1 Attribute VB_Name = "Rbt"
   2 Option Explicit
   3
   4 ' red-black tree algorithm, object method
   5
   6 Private Sentinel As CRbt        ' all leafs are sentinels
   7 Private Root As CRbt            ' root of red-black tree
   8 Private LastFind As CRbt        ' last node found
   9
  10
  11 Private Function FindNode(ByVal Key As Variant) As CRbt
  12 '   inputs:
  13 '       Key                   ' designates key to find
  14 '   returns:
  15 '       index to node
  16 '   action:
  17 '       Search tree for designated key, and return index to node.
  18 '   errors:
  19 '       errKeyNotFound
  20 '
  21     Dim current As CRbt
  22
  23     ' find node specified by key
  24     Set current = Root
  25     Do While Not current Is Sentinel
  26         If current.Key = Key Then
  27             Set FindNode = current
  28             Exit Function
  29         Else
  30             If Key < current.Key Then
  31                 Set current = current.Left
  32             Else
  33                 Set current = current.Right
  34             End If
  35         End If
  36     Loop
  37     Err.Raise errKeyNotFound, "Rbt.FindNode"
  38 End Function
  39
  40 Private Sub RotateLeft(ByRef x As CRbt)
  41 '   inputs:
  42 '       x                     designates node
  43 '   action:
  44 '       perform a left tree rotation about "x"
  45 '
  46     Dim y As CRbt
  47
  48     ' rotate node x to left
  49
  50     Set y = x.Right
  51
  52     ' establish x.Right link
  53     Set x.Right = y.Left
  54     If Not y.Left Is Sentinel Then Set y.Left.Parent = x
  55
  56     ' establish y.Parent link
  57     If Not y Is Sentinel Then Set y.Parent = x.Parent
  58     If Not x.Parent Is Nothing Then
  59         If x Is x.Parent.Left Then
  60             Set x.Parent.Left = y
  61         Else
  62             Set x.Parent.Right = y
  63         End If
  64     Else
  65         Set Root = y
  66     End If
  67
  68     ' link x and y
  69     Set y.Left = x
  70     If Not x Is Sentinel Then Set x.Parent = y
  71 End Sub
  72
  73 Private Sub RotateRight(ByRef x As CRbt)
  74 '   inputs:
  75 '       x                     designates node
  76 '   action:
  77 '       perform a right tree rotation about "x"
  78 '
  79     Dim y As CRbt
  80
  81     ' rotate node x to right
  82
  83     Set y = x.Left
  84
  85     ' establish x.Left link
  86     Set x.Left = y.Right
  87     If Not y.Right Is Sentinel Then Set y.Right.Parent = x
  88
  89     ' establish y.parent link
  90     If Not y Is Sentinel Then Set y.Parent = x.Parent
  91     If Not x.Parent Is Nothing Then
  92         If x Is x.Parent.Right Then
  93             Set x.Parent.Right = y
  94         Else
  95             Set x.Parent.Left = y
  96         End If
  97     Else
  98         Set Root = y
  99     End If
 100
 101     ' link x and y
 102     Set y.Right = x
 103     If Not x Is Sentinel Then Set x.Parent = y
 104 End Sub
 105
 106 Private Sub InsertFixup(ByRef x As CRbt)
 107 '   inputs:
 108 '       x                     designates node
 109 '   action:
 110 '       maintains red-black tree properties after inserting node x
 111 '
 112     Dim y As CRbt
 113
 114     ' maintain Red-Black tree balance
 115     ' after inserting node x
 116
 117     ' check Red-Black properties
 118     Do While (Not x Is Root)
 119         If x.Parent.Color <> Red Then Exit Do
 120         ' we have a violation
 121         If x.Parent Is x.Parent.Parent.Left Then
 122             Set y = x.Parent.Parent.Right
 123             If y.Color = Red Then
 124
 125                 ' uncle is Red
 126                 x.Parent.Color = Black
 127                 y.Color = Black
 128                 x.Parent.Parent.Color = Red
 129                 Set x = x.Parent.Parent
 130             Else
 131
 132                 ' uncle is Black
 133                 If x Is x.Parent.Right Then
 134                     ' make x a left child
 135                     Set x = x.Parent
 136                     RotateLeft x
 137                 End If
 138
 139                 ' recolor and rotate
 140                 x.Parent.Color = Black
 141                 x.Parent.Parent.Color = Red
 142                 RotateRight x.Parent.Parent
 143             End If
 144         Else
 145
 146             ' mirror image of above code
 147             Set y = x.Parent.Parent.Left
 148             If y.Color = Red Then
 149
 150                 ' uncle is Red
 151                 x.Parent.Color = Black
 152                 y.Color = Black
 153                 x.Parent.Parent.Color = Red
 154                 Set x = x.Parent.Parent
 155             Else
 156
 157                 ' uncle is Black
 158                 If x Is x.Parent.Left Then
 159                     Set x = x.Parent
 160                     RotateRight x
 161                 End If
 162                 x.Parent.Color = Black
 163                 x.Parent.Parent.Color = Red
 164                 RotateLeft x.Parent.Parent
 165             End If
 166         End If
 167     Loop
 168     Root.Color = Black
 169 End Sub
 170
 171 Public Sub Insert(ByVal KeyVal As Variant, ByRef RecVal As Variant)
 172 '   inputs:
 173 '       KeyVal                key of node to insert
 174 '       RecVal                record associated with key
 175 '   action:
 176 '       Inserts record RecVal with key KeyVal.
 177 '   error:
 178 '       errDuplicateKey
 179 '
 180     Dim current As CRbt
 181     Dim Parent As CRbt
 182     Dim x As CRbt
 183
 184     ' allocate node for data and insert in tree
 185
 186     ' find where node belongs
 187     Set current = Root
 188     Set Parent = Nothing
 189     Do While Not current Is Sentinel
 190         If current.Key = KeyVal Then Raise errDuplicateKey, "Rbt.Insert"
 191         Set Parent = current
 192         If KeyVal < current.Key Then
 193             Set current = current.Left
 194         Else
 195             Set current = current.Right
 196         End If
 197     Loop
 198
 199     ' setup new node
 200     Set x = New CRbt
 201     Set x.Parent = Parent
 202     Set x.Left = Sentinel
 203     Set x.Right = Sentinel
 204     x.Color = Red
 205
 206     ' copy fields to node
 207     x.Key = KeyVal
 208     x.Rec = RecVal
 209
 210     ' insert node in tree
 211     If Not Parent Is Nothing Then
 212         If KeyVal < Parent.Key Then
 213             Set Parent.Left = x
 214         Else
 215             Set Parent.Right = x
 216         End If
 217     Else
 218         Set Root = x
 219     End If
 220
 221     InsertFixup x
 222     Set LastFind = Sentinel
 223 End Sub
 224
 225 Private Sub DeleteFixup(ByRef x As CRbt)
 226 '   inputs:
 227 '       x                     designates node
 228 '   action:
 229 '       maintains red-black tree properties after deleting a node
 230 '
 231     Dim w As CRbt
 232
 233     ' maintain Red-Black tree balance
 234     ' after deleting node x
 235
 236     Do While Not x Is Root
 237         If x.Color <> Black Then Exit Do
 238         If x Is x.Parent.Left Then
 239             Set w = x.Parent.Right
 240             If w.Color = Red Then
 241                 w.Color = Black
 242                 x.Parent.Color = Red
 243                 RotateLeft x.Parent
 244                 Set w = x.Parent.Right
 245             End If
 246             If w.Left.Color = Black And w.Right.Color = Black Then
 247                 w.Color = Red
 248                 Set x = x.Parent
 249             Else
 250                 If w.Right.Color = Black Then
 251                     w.Left.Color = Black
 252                     w.Color = Red
 253                     RotateRight w
 254                     Set w = x.Parent.Right
 255                 End If
 256                 w.Color = x.Parent.Color
 257                 x.Parent.Color = Black
 258                 w.Right.Color = Black
 259                 RotateLeft x.Parent
 260                 Set x = Root
 261             End If
 262         Else
 263             Set w = x.Parent.Left
 264             If w.Color = Red Then
 265                 w.Color = Black
 266                 x.Parent.Color = Red
 267                 RotateRight x.Parent
 268                 Set w = x.Parent.Left
 269             End If
 270             If w.Right.Color = Black And w.Left.Color = Black Then
 271                 w.Color = Red
 272                 Set x = x.Parent
 273             Else
 274                 If w.Left.Color = Black Then
 275                     w.Right.Color = Black
 276                     w.Color = Red
 277                     RotateLeft w
 278                     Set w = x.Parent.Left
 279                 End If
 280                 w.Color = x.Parent.Color
 281                 x.Parent.Color = Black
 282                 w.Left.Color = Black
 283                 RotateRight x.Parent
 284                 Set x = Root
 285             End If
 286         End If
 287     Loop
 288     x.Color = Black
 289 End Sub
 290
 291 Public Sub Delete(ByVal KeyVal As Variant)
 292 '   inputs:
 293 '       KeyVal                key of node to delete
 294 '   action:
 295 '       Deletes record with key KeyVal.
 296 '   error:
 297 '       errKeyNotFound
 298 '
 299     Dim x As CRbt
 300     Dim y As CRbt
 301     Dim z As CRbt
 302
 303     If Not LastFind Is Sentinel Then
 304         If LastFind.Rec = KeyVal Then
 305             Set z = LastFind
 306         Else
 307             Set z = FindNode(KeyVal)
 308         End If
 309     Else
 310         Set z = FindNode(KeyVal)
 311     End If
 312
 313     '  delete node z from tree
 314     If z.Left Is Sentinel Or z.Right Is Sentinel Then
 315         ' y has a Sentinel node as a child
 316         Set y = z
 317     Else
 318         ' find tree successor with a Sentinel node as a child
 319         Set y = z.Right
 320         Do While Not y.Left Is Sentinel
 321             Set y = y.Left
 322         Loop
 323     End If
 324
 325     ' x is y's only child, and x may be a sentinel node
 326     If Not y.Left Is Sentinel Then
 327         Set x = y.Left
 328     Else
 329         Set x = y.Right
 330     End If
 331
 332     ' remove y from the parent chain
 333     Set x.Parent = y.Parent
 334     If Not y.Parent Is Nothing Then
 335         If y Is y.Parent.Left Then
 336             Set y.Parent.Left = x
 337         Else
 338             Set y.Parent.Right = x
 339         End If
 340     Else
 341         Set Root = x
 342     End If
 343
 344     ' copy data fields from y to z
 345     If Not y Is z Then
 346         z.Key = y.Key
 347         z.Rec = y.Rec
 348     End If
 349
 350     ' if we removed a black node, we need to do some fixup
 351     If y.Color = Black Then DeleteFixup x
 352
 353     ' y is freed automatically, as it's no longer referenced
 354
 355     Set LastFind = Sentinel
 356 End Sub
 357
 358 Public Function Find(ByVal KeyVal) As Variant
 359 '   inputs:
 360 '       KeyVal                key of node to delete
 361 '   returns:
 362 '       record associated with key
 363 '   action:
 364 '       Finds record with key KeyVal
 365 '   error:
 366 '       errKeyNotFound
 367 '
 368     Set LastFind = FindNode(KeyVal)
 369     Find = LastFind.Rec
 370 End Function
 371
 372 Public Sub Init()
 373 '   action:
 374 '       initialize tree
 375 '
 376     Set Sentinel = New CRbt
 377     Set Sentinel.Left = Sentinel
 378     Set Sentinel.Right = Sentinel
 379     Set Sentinel.Parent = Nothing
 380     Sentinel.Color = Black
 381     Set Root = Sentinel
 382     Set LastFind = Sentinel
 383 End Sub
 384
 385 Private Sub ZapNode(x As CRbt)
 386 '   inputs:
 387 '       x       node in tree
 388 '   action:
 389 '       recursively set all parent pointers to Nothing
 390 '
 391     If x Is Nothing Then Exit Sub
 392     Set x.Parent = Nothing
 393     ZapNode x.Left
 394     ZapNode x.Right
 395 End Sub
 396
 397 Public Sub Term()
 398 '   action:
 399 '       release memory
 400 '
 401     ' free sentinel
 402     Set Sentinel.Left = Nothing
 403     Set Sentinel.Right = Nothing
 404     Set Sentinel.Parent = Nothing
 405     Set Sentinel = Nothing
 406
 407     ' remove all parent pointers
 408     ZapNode Root.Left
 409     ZapNode Root.Right
 410
 411     ' now, freeing root will free whole tree
 412     Set Root = Nothing
 413 End Sub
 414