Red-black tree (self-balancing binary search tree)

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
AGS
Posts: 1284
Joined: Sep 25, 2007 0:26
Location: the Netherlands

Red-black tree (self-balancing binary search tree)

Post by AGS »

RED-BLACK TREE

A red-black tree is an implementation of a self balancing binary search tree. Wiki can tell you about the technical background of the red-black tree
http://en.wikipedia.org/wiki/Red-black_tree

The nodes in this particular red-black tree contain a key (Integer) and a value (String). You can change the type of both key and value to something else. If you want to do so you'll have to change the source code here and their (important: if you change the type of the key you'll have to supply your own compare function. It is used to determine whether two keys are equal and if not which of the two keys is the bigger one).

Four operations can be performed on the tree:
-->add a node to the tree (key,value);
-->delete a node from the tree;
-->find a node in the tree (key);
-->delete the entire tree;
-->draw the entire tree (graphically).

Insertion and deletion of a node both start out as if these operations are performed on a 'regular' binary search tree. This means walking the tree up to the insertion/deletion point and performing the insert/delete operation.

After insertion/deletion the tree gets rebalanced. This rebalancing assures the tree meets the requirements of a red-black tree.

There requirements are
- A node is either red or black.
- The root is black.
- All leaves are black.
- Both children of every red node are black.
- Every simple path from a given node to any of its
descendant leaves contains the same number of black nodes.

As an example of a red-black tree here is a picture of a red-black tree after inserting the keys 0 To 20 (picture: output of NodeQueue.PrintTree routine)
Image

At the end of the code you'll find an example of using the tree.

The example starts out by inserting values inserted into a tree. Before each insertion the program outputs the key about to be inserted to the console and waits for a key-press. After the key-press it adds a (key,value) pair to the tree and draws the resulting tree.

After adding values to the tree the program continues by deleting all the values from the tree (one by one). Again the program first prints the key that is about to be deleted from the tree, it waits for a key press and after the key-press
it deletes a node from the tree and draws the resulting tree.

The routine that does the printing of the tree (NodeQueue.PrintTree) is a bit of a hack. Drawing a binary tree in a way that makes the tree look good is something
better done using some sophisticated layout algorithm (like the graphviz library uses). I've just tried to get a useful result (visually) for smaller trees with small keys/values so you can see the tree balancing 'in action'.

When used to draw bigger trees you'll find the layout degrades and (many) nodes will not show up on the screen as nodes drop of at the bottom of the screen.

Two more things.
You can find the smallest key in the tree by going left at the
root and continuing to go left until a node is found that has the sentinel as it´s left child.
You can find the largest key in the tree by going right at the root and continuing to go right until a node is found that has the sentinel as it´s right child.

Code: Select all

#define NULL Cast(Any Ptr,0)

Enum nodecolor
  BLACK = 0
  RED = 1
End Enum

Type RBNode

    Dim left As RBNode Ptr
    Dim right As RBNode Ptr
    Dim parent As RBNode Ptr
    Dim color As nodecolor
    Dim key As Integer
    Dim value As String
    Dim nonzero As Integer
    Declare Constructor(ByVal key As Integer = 0,value As String = "",ByVal clr As nodecolor = RED)
    Declare Destructor()

End Type

Constructor RBNode(ByVal key As Integer,value As String,ByVal clr As nodecolor = RED)

  This.key = key
  This.value = value
  This.left = NULL
  This.right = NULL
  This.parent = NULL
  This.color = clr
  This.nonzero = 1
  
  
End Constructor    

Destructor RBNode()
  
End Destructor

Function integer_compare(ByVal key1 As Integer, ByVal key2 As Integer) As Integer

  If (key1 = key2) Then
    Return 0
  ElseIf (key1 < key2) Then
    Return -1
  ElseIf (key1 > key2) Then
    Return 1
  End If

End Function

Type RBTree

  Dim sentinel As RBNode Ptr
  Dim root As RBNode Ptr
  Dim count As Integer 
  Dim Compare As Function(ByVal key1 As Integer, ByVal key2 As Integer) As Integer
  Declare Constructor(ByVal cmp As Function(ByVal key1 As Integer,ByVal key2 As Integer) As Integer)
  Declare Sub rotateLeft(ByVal x As RBNode Ptr)
  Declare Sub rotateRight(ByVal x As RBNode Ptr)
  Declare Sub insertFixup(ByVal x As RBNode Ptr) 
  Declare Function insertNode(ByVal key As Integer,value As String) As RBNode Ptr
  Declare Sub deleteFixup(ByVal x As RBNode Ptr)  
  Declare Sub deleteNode(ByVal z As RBNode Ptr)
  Declare Function findNode(ByVal key As Integer) As RBNode Ptr
  Declare Destructor() 

End Type

Constructor RBTree(ByVal cmp As Function(ByVal key1 As Integer,ByVal key2 As Integer) As Integer)

  This.sentinel = New RBNode(0,"",BLACK)
  This.sentinel->left = sentinel
  This.sentinel->right = sentinel
  This.root = This.sentinel
  This.count = 0
  This.Compare = cmp

End Constructor



Destructor RBTree()

  'The tree is transformed into a tree in which 
  'left children are always leaves. This is done by rotation. 
  'After rotating any left child is a leaf (not a tree)
  'so a left child can simply be deleted.  
  'Usually a stack is used to keep track of what nodes have
  'been removed. By using rotation there is no need for a stack.


  Dim parent As RBNode Ptr
  Dim child As RBNode Ptr

  If (This.root <> This.sentinel AndAlso This.root <> NULL) Then
    parent = This.root
    While (parent <> This.sentinel)    
      If (parent->left = This.sentinel) Then        
        child = parent->right
        Delete parent
        parent = 0
      Else        
        'rotate
        child = parent->left
        parent->left = child->right
        child->right = parent
      End If
    parent = child
    Wend  
  Else
    If (This.sentinel <> 0) Then
      Delete This.sentinel
      This.sentinel = 0
    End If        
  End If

End Destructor  

    
Sub RBTree.rotateLeft(ByVal x As RBNode Ptr)
  
  'rotate node x to right
  
  Var y = x->right

  'establish x->right link
  x->right = y->left
  If (y->left <> This.sentinel) Then
      y->left->parent = x
  End If

  'establish y->parent link
  If (y <> This.sentinel) Then
      y->parent = x->parent
  End If
  If (x->parent) Then
    If (x = x->parent->left) Then
       x->parent->left = y
    Else
       x->parent->right = y
    End If
  Else
    This.root = y
  End If

  'link x and y
  y->left = x
  If (x <> This.sentinel) Then
    x->parent = y
  End If
    
End Sub
    
Sub RBTree.rotateRight(ByVal x As RBNode Ptr)

    'rotate node x to right
    
    Var y = x->left

    ' establish x->left link
    x->left = y->right
    If (y->right <> This.sentinel) Then
      y->right->parent = x
    End If

    ' establish y->parent link
    If (y <> This.sentinel) Then
        y->parent = x->parent
    End If
    If (x->parent) Then
      If (x = x->parent->right) Then
        x->parent->right = y
      Else
        x->parent->left = y
      End If
    Else
      This.root = y
    End If

    'link x and y
    y->right = x
    If (x <> This.sentinel) Then
      x->parent = y
    End If

End Sub
    
Sub RBTree.insertFixup(ByVal x As RBNode Ptr)
  'maintain tree balance after inserting node x

  'check Red-Black properties
  While (x <> This.Root AndAlso x->parent->color = RED)
    'we have a violation
    If ( x->parent = x->parent->parent->left) Then
      Var y = x->parent->parent->right
      If ( y->color = RED) Then
        'uncle is RED
        x->parent->color = BLACK
        y->color = BLACK
        x->parent->parent->color = RED
        x = x->parent->parent
      Else
        'uncle is BLACK
        If ( x = x->parent->right) Then
          'make x a left child
          x = x->parent
          This.rotateLeft(x)
        End If
        'recolor and rotate
        x->parent->color = BLACK
        x->parent->parent->color = RED
        This.rotateRight(x->parent->parent)
      End If
    Else
      ' mirror image of above code
      Var y = x->parent->parent->left
      If ( y->color = RED) Then
        ' uncle is RED
        x->parent->color = BLACK
        y->color = BLACK
        x->parent->parent->color = RED
        x = x->parent->parent
      Else
        ' uncle is BLACK
        If ( x = x->parent->left) Then
          x = x->parent
          This.rotateRight(x)
        End If
        x->parent->color = BLACK
        x->parent->parent->color = RED
        This.rotateLeft(x->parent->parent)
      End If
    End If
  Wend
  This.root->color = BLACK

End Sub

Function RBTree.insertNode(ByVal key As Integer,value As String) As RBNode Ptr
  'Insert a node in the RBTree

  'find where node belongs
  Dim current As RBNode Ptr = This.root
  Dim parent As RBNode Ptr
  While (current <> This.sentinel)
    Var rc = This.Compare(key, current->key)
    If (rc = 0) Then
        Return current
    End If
    parent = current
    If (rc < 0) Then
      current = current->left
    Else
      current = current->right
    End If
  Wend
  ' setup new node
  Dim x As RBNode Ptr = New RBNode(key, value)
  x->left  = This.sentinel
  x->right = This.sentinel
  x->parent = parent

  This.count = This.count + 1

  ' insert node in tree
  If (parent) Then
    If (This.Compare(key, parent->key) < 0) Then
      parent->left = x
    Else
      parent->right = x
    End If
  Else
    This.root = x
  End If

  This.insertFixup(x)
  Return x
  
End Function

Sub RBTree.deleteFixup(ByVal x As RBNode Ptr)
  'maintain tree balance after deleting node x
  
  Dim w As RBNode Ptr
  While (x <> This.root AndAlso x->color = BLACK)
    If ( x = x->parent->left) Then
      w = x->parent->right
      If (w->color = RED) Then
        w->color = BLACK
        x->parent->color = RED
        This.rotateLeft(x->parent)
        w = x->parent->right
      End If

      If ( w->left->color = BLACK and w->right->color = BLACK) Then
        w->color = RED
        x = x->parent
      Else
        If ( w->right->color = BLACK) Then
          w->left->color = BLACK
          w->color = RED
          This.rotateRight(w)
          w = x->parent->right
        End If

        w->color = x->parent->color
        x->parent->color = BLACK
        w->right->color = BLACK
        This.rotateLeft(x->parent)
        x = This.root
      End If
    Else
      w = x->parent->left
      If ( w->color = RED) Then
        w->color = BLACK
        x->parent->color = RED
        This.rotateRight(x->parent)
        w = x->parent->left
      End If

      If ( w->right->color = BLACK and w->left->color = BLACK) Then
        w->color = RED
        x = x->parent
      Else
        If ( w->left->color = BLACK) Then
          w->right->color = BLACK
          w->color = RED
          This.rotateLeft(w)
          w = x->parent->left
        End If

        w->color = x->parent->color
        x->parent->color = BLACK
        w->left->color = BLACK
        This.rotateRight(x->parent)
        x = This.root
      End If
    End If
  Wend
  x->color = BLACK

End Sub

Sub RBTree.deleteNode(ByVal z As RBNode Ptr)
  'delete node z from tree

  Dim y As RBNode Ptr
  Dim x As RBNode Ptr
  
  If ( 0 =  z OrElse z = This.sentinel) Then
    Return
  End If

  If (z->left = This.sentinel OrElse z->right = This.sentinel) Then
    'y has a This.sentinel node as a child
    y = z
  Else
    'find tree successor with a This.sentinel node as a child
    y = z->right
    While (y->left <> This.sentinel)
      y = y->left
    Wend
  End If

  'x is y's only child
  If ( y->left <> This.sentinel) Then
    x = y->left
  Else
    x = y->right
  End If

  'remove y from the parent chain
  x->parent = y->parent
  If ( y->parent) Then
    If ( y = y->parent->left) Then
      y->parent->left = x
    Else
      y->parent->right = x
    End If
  Else
    This.root = x
  End If

  If (y <> z) Then  
    z->key = y->key
    z->value = y->value
  End If

  If ( y->color = BLACK) Then
    This.deleteFixup(x)
  End If

  Delete y
  
  This.count = This.count - 1

End Sub

Function RBtree.findNode(ByVal key As Integer) As RBNode Ptr
  'find node with key equal to key
  Var current = This.root

  While (current <> This.sentinel)
    Var rc = This.Compare(key, current->key)
    If ( rc = 0) Then
      Return current
    Else
      If ( rc < 0) Then
        current = current->left
      Else
        current = current->right
      End If
    End If
  Wend
  Return 0

End Function


Type GraphicsNode

  Dim node As RBNode Ptr  
  Dim lvl As UByte
  Dim nxt As GraphicsNode Ptr
  Dim prev As GraphicsNode Ptr
  Dim x As UInteger
  Dim y As UInteger
  
End Type

Type NodeQueue

  Dim startx As Integer
  Dim starty As Integer
  Dim first As GraphicsNode Ptr
  Dim last  As GraphicsNode Ptr
  Dim levels(2 To 11) As Integer => {100,50,25,12,10,10,10,10,10}
  Dim count As Integer
  Declare Constructor
  Declare Destructor
  Declare Function Enqueue(ByRef item As GraphicsNode Ptr) As Integer
  Declare Function Dequeue(ByRef item As GraphicsNode Ptr) As GraphicsNode Ptr
  Declare Sub PrintNode(ByVal item As GraphicsNode Ptr,ByVal x As Integer,ByVal y As Integer)
  Declare Sub PrintTree(ByVal tree As RBTree Ptr)

End Type

Constructor NodeQueue()

  ''Draw first node in the middle of the screen
  '(just below the top of the screen)
  This.startx = 350
  This.starty = 100
  This.first = NULL
  This.last = NULL  
  This.count = 1
  '800x600, 32 bits color
  Screen 19,32
  Color ,RGB(255,255,155)
  CLS
End Constructor

Destructor NodeQueue()
 
End Destructor

Function NodeQueue.Enqueue(ByRef item As GraphicsNode Ptr) As Integer

  'Insertion into an empty que
  If (This.first = NULL) Then
    This.first = item
    This.last = item
    This.Count += 1
    Return 0
  Else
    Var tmp = This.last
    This.last = item
    This.last->prev = tmp
    tmp->nxt = This.last
    This.last->nxt = NULL
    This.Count += 1
    Return 0
  End If
  
  Return -1

End Function

Function NodeQueue.Dequeue(ByRef item As GraphicsNode Ptr) As GraphicsNode Ptr

  'Dequeueing from an empty queue or a queue with one node
  If (This.last = This.first) Then
    'Dequeueing from an empty queue
    If (This.last = NULL) Then
      This.Count -= 1
      Return NULL
    Else      
      'Dequeueing from a queue with one node
      item->node = This.First->node
      item->x = This.First->x
      item->y = This.First->y
      item->lvl = This.first->lvl      
      Delete This.first
      This.first = NULL
      This.last = NULL
      This.Count -= 1
      Return item
    End If
  Else  
    'Dequeueing from a queue with more than one node
    Var tmp = This.Last
    item->node = This.Last->node
    item->x = This.Last->x
    item->y = This.Last->y
    item->lvl = This.Last->lvl      
    This.last = This.last->prev
    This.last->nxt = NULL
    Delete tmp
    Return item
  End If
  Return NULL

End Function
    
Sub NodeQueue.PrintNode(ByVal item As GraphicsNode Ptr,ByVal x As Integer,ByVal y As Integer)

  'Draw a black line from parent node to child node
  Line (x,y)-(item->x,item->y),RGB(0,0,0)
  'Draw node (either red or black)
  If (item->node->color = RED) Then
    Circle (item->x,item->y),5,RGB(255,0,0),,,,F
  Else
    Circle (item->x,item->y),5,RGB(0,0,0),,,,F
  End If
  Draw String (item->x,item->y - 40),Str(item->node->key),RGB(0,0,0)
  Draw String (item->x-8,item->y - 25),"""" & item->node->value & """",RGB(0,0,0)
  
End Sub

Sub NodeQueue.PrintTree(ByVal tree As RBTree Ptr)

  Dim item As GraphicsNode Ptr

  Dim current As GraphicsNode Ptr = New GraphicsNode  
  Dim tmp As GraphicsNode Ptr
  Dim lvl As Integer = 1
  Dim x As Integer = This.startx
  Dim y As Integer = This.starty
  
  'check for empty tree
  If (tree->root = tree->sentinel) Then
    Return
  End If
  
  'Start with printing the root
  current->node = tree->root
  current->x = x
  current->y = y
  current->lvl = lvl  
  This.PrintNode(current,x,y)
  While(1)
    'Print left node (position it at left side of current node)
    If (current->node->left <> tree->sentinel) Then
      item = New GraphicsNode
      item->lvl = lvl + 1      
      If (item->lvl <= 9) Then
        item->x = x - This.levels(lvl+1)
      Else
        item->x = x - 10
      End If
      item->y = y + 50
      item->node = current->node->left
      This.PrintNode(item,x,y)
      This.Enqueue(item)
    End If
    'Print right node (position it at right side of current node
    If (current->node->right <> tree->sentinel) Then
      item = New GraphicsNode
      item->lvl = lvl + 1
      If (item->lvl <= 9) Then
        item->x = x + This.levels(lvl+1)
      Else
        item->x = x + 10
      End If
      item->y = y + 50
      item->node = current->node->right
      This.PrintNode(item,x,y)
      This.Enqueue(item)
    End If
    'Continue drawing from first node in the queue
    'Nodes in left tree will be drawn first as these are put in
    'the queue first
    Var tmp = This.Dequeue(current)
    'If count smaller then entire tree has been drawn
    If (This.count < 1) Then
      Exit While
    End If
    x = current->x
    y = current->y
    lvl = current->lvl
  Wend  
    
End Sub      

Dim x As Integer Ptr

Var tree = New RBTree(@integer_compare)

Open Cons For Output As #1
For i As Integer = 0 To 20
  Print #1,"Insert ";i  
  tree->Insertnode(i,Str(i))
  Sleep()
  Dim print_tree As NodeQueue Ptr
  print_tree = New NodeQueue
  print_tree->PrintTree(tree)
  Delete print_tree  
Next i
Print #1,"Starting Deletion after keypress"
Var print_tree = New NodeQueue
print_tree->PrintTree(tree)
Sleep()
Delete print_tree

For i As Integer = 0 To 20
  Print #1,"Delete";i  
  Var n = tree->FindNode(i)
  If (n) Then
    tree->Deletenode(n)
  End If
  Sleep()
  Dim print_tree As NodeQueue Ptr
  print_tree = New NodeQueue
  print_tree->PrintTree(tree)
  Delete print_tree  
Next i

Print #1,"Ending program after keypress"
Sleep()
Close #1
Delete tree
Edit: fixed RBTree constructor (changing sentinel colour to BLACK)
Last edited by AGS on Jul 29, 2010 16:25, edited 2 times in total.
anonymous1337
Posts: 5494
Joined: Sep 12, 2005 20:06
Location: California

Post by anonymous1337 »

This is definitely cool. A high quality post with well-thought classes. Makes me wish we had interfaces so I could implement my own PrintTree function.
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

Thanks; this is going to be very useful! I think I will use this in my program when I get the stomach for it...

btw... its left child, etc. ;)
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Post by kiyotewolf »

Facinating.

I've been learning binary trees & such, from really really OLD.. BASIC programming books.

Srsly.. 20+ years old.. or so.

Also, figuring out AI has made learning binary trees a bit more of a priority.

* goes to study the wikipedia entry for awhile & absorb more data.. *



~Kiyote!
AGS
Posts: 1284
Joined: Sep 25, 2007 0:26
Location: the Netherlands

Post by AGS »

There was a small error in the program. The balance of the tree wasn't right due to the program colouring the sentinel RED instead of BLACK. I fixed that in the RBTree constructor and as you can see in the picture the tree looks a bit more balanced now.

The problem: when adding the key two (after zero and one had already been added) a rotation and a recolouring of nodes should have taken place. The program, however, recoloured nodes only.
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

AGS,

Can you make an example that will add an arbitrary number of UDTs based on their "name" variable (a string) to the tree? I would also like to be able to search it based on the name variable.
AGS
Posts: 1284
Joined: Sep 25, 2007 0:26
Location: the Netherlands

Post by AGS »

agamemnus wrote:AGS,

Can you make an example that will add an arbitrary number of UDTs based on their "name" variable (a string) to the tree? I would also like to be able to search it based on the name variable.
I'm not 100% sure what you mean with 'arbitrary number of UDTs'. I can change the code so the value field of RBNode contains a pointer to an UDT with a name field. For example

Code: Select all

Type UDT
  Dim name As String
  Dim field1 As Integer
  Dim field2 As Integer  
  Declare Constructor()
  Declare Destructor()
End Type
Parameterlist of InsertNode would change to
(key As String,value As UDT Ptr) and the parameterlist of DeleteNode would not change.

If you want to be able to put different UDTs (different in terms of number/type of fields/methods/properties/etc...) into one and the same RBTree (something like

Code: Select all

Type UDT1
   Dim name As String
   Dim _field_1 As Double
   Dim _field_2 As UByte Ptr
   Declare Constructor()
   Declare Destructor()
End Type
) then I would not know how to do it as InsertNode and DeleteNode expect value to be of a certain type. You cannot insert values of type UDT1 Ptr and values of type UDT Ptr into one and the same RBTree.
Last edited by AGS on Aug 08, 2010 6:46, edited 1 time in total.
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

Ok, thanks.

By arbitrary, I simply meant "x" number of (the same) UDT.
AGS
Posts: 1284
Joined: Sep 25, 2007 0:26
Location: the Netherlands

Post by AGS »

The following example of the RBtree stores UDTs of a certain type in an RBTree. Changes from the first version are:
- added the type UDT;
- the UDT has a method called Clone. This is needed because in the DeleteNode routine both key and value are copied from one RBNode to some other RBNode. Since value points to an UDT it is up to the user of the RBTree to make sure the content of that UDT gets copied correctly;
- the destructor of a RBNode calls Delete on an UDT Ptr in order to delete an UDT from an RBNode when it is removed from the RBTree;
- function integer_compare has been replaced with function string_compare.

Code: Select all

#define NULL Cast(Any Ptr,0)

Type UDT

  Dim name As String
  Dim data As Integer
  Declare Constructor
  Declare Destructor
  Declare Function Clone() As UDT Ptr

End Type

Constructor UDT

End Constructor

Destructor UDT

  This.name = ""
  This.data = 0
  
End Destructor

Function UDT.Clone() As UDT Ptr

  Dim tmp As UDT Ptr = New UDT
  tmp->name = This.name
  tmp->data = This.data
  Return tmp
  
End Function
  


Enum nodecolor
  BLACK = 0
  RED = 1
End Enum

Type RBNode

    Dim Left As RBNode Ptr
    Dim Right As RBNode Ptr
    Dim parent As RBNode Ptr
    Dim Color As nodecolor
    Dim Key As String
    Dim value As UDT Ptr
    Dim nonzero As Integer
    Declare Constructor(Key As String,value As UDT Ptr,ByVal clr As nodecolor = RED)
    Declare Destructor()

End Type

Constructor RBNode(Key As String,value As UDT Ptr,ByVal clr As nodecolor = RED)

  This.key = Key
  This.value = value
  This.left = NULL
  This.right = NULL
  This.parent = NULL
  This.color = clr
  This.nonzero = 1
 
 
End Constructor   

Destructor RBNode()
 

  If (This.value <> NULL) Then
    Delete This.value
    This.value = NULL
  End If
 
End Destructor

Function string_compare(key1 As String,key2 As String) As Integer

  If (key1 = key2) Then
    Return 0
  Elseif (key1 < key2) Then
    Return -1
  Elseif (key1 > key2) Then
    Return 1
  End If

End Function

Type RBTree

  Dim sentinel As RBNode Ptr
  Dim root As RBNode Ptr
  Dim count As Integer
  Dim Compare As Function(key1 As String,key2 As String) As Integer
  Declare Constructor(Byval cmp As Function(key1 As String,key2 As String) As Integer)
  Declare Sub rotateLeft(Byval x As RBNode Ptr)
  Declare Sub rotateRight(Byval x As RBNode Ptr)
  Declare Sub insertFixup(Byval x As RBNode Ptr)
  Declare Function insertNode(Key As String,Byval value As UDT Ptr) As RBNode Ptr
  Declare Sub deleteFixup(Byval x As RBNode Ptr) 
  Declare Sub deleteNode(Byval z As RBNode Ptr)
  Declare Function findNode(Key As String) As RBNode Ptr
  Declare Destructor()

End Type

Constructor RBTree(Byval cmp As Function(key1 As String,key2 As String) As Integer)

  This.sentinel = New RBNode("",NULL,BLACK)
  This.sentinel->left = sentinel
  This.sentinel->right = sentinel
  This.root = This.sentinel
  This.count = 0
  This.Compare = cmp

End Constructor



Destructor RBTree()

  'The tree is transformed into a tree in which
  'left children are always leaves. This is done by rotation.
  'After rotating any left child is a leaf (not a tree)
  'so a left child can simply be deleted. 
  'Usually a stack is used to keep track of what nodes have
  'been removed. By using rotation there is no need for a stack.


  Dim parent As RBNode Ptr
  Dim child As RBNode Ptr

  If (This.root <> This.sentinel AndAlso This.root <> NULL) Then
    parent = This.root
    While (parent <> This.sentinel)   
      If (parent->left = This.sentinel) Then       
        child = parent->right
        Delete parent
        parent = 0
      Else       
        'rotate
        child = parent->left
        parent->left = child->right
        child->right = parent
      End If
    parent = child
    Wend 
  Else
    If (This.sentinel <> 0) Then
      Delete This.sentinel
      This.sentinel = 0
    End If       
  End If

End Destructor 

   
Sub RBTree.rotateLeft(Byval x As RBNode Ptr)
 
  'rotate node x to right
 
  Var y = x->right

  'establish x->right link
  x->right = y->left
  If (y->left <> This.sentinel) Then
      y->left->parent = x
  End If

  'establish y->parent link
  If (y <> This.sentinel) Then
      y->parent = x->parent
  End If
  If (x->parent) Then
    If (x = x->parent->left) Then
       x->parent->left = y
    Else
       x->parent->right = y
    End If
  Else
    This.root = y
  End If

  'link x and y
  y->left = x
  If (x <> This.sentinel) Then
    x->parent = y
  End If
   
End Sub
   
Sub RBTree.rotateRight(Byval x As RBNode Ptr)

    'rotate node x to right
   
    Var y = x->left

    ' establish x->left link
    x->left = y->right
    If (y->right <> This.sentinel) Then
      y->right->parent = x
    End If

    ' establish y->parent link
    If (y <> This.sentinel) Then
        y->parent = x->parent
    End If
    If (x->parent) Then
      If (x = x->parent->right) Then
        x->parent->right = y
      Else
        x->parent->left = y
      End If
    Else
      This.root = y
    End If

    'link x and y
    y->right = x
    If (x <> This.sentinel) Then
      x->parent = y
    End If

End Sub
   
Sub RBTree.insertFixup(Byval x As RBNode Ptr)
  'maintain tree balance after inserting node x

  'check Red-Black properties
  While (x <> This.Root AndAlso x->parent->color = RED)
    'we have a violation
    If ( x->parent = x->parent->parent->left) Then
      Var y = x->parent->parent->right
      If ( y->color = RED) Then
        'uncle is RED
        x->parent->color = BLACK
        y->color = BLACK
        x->parent->parent->color = RED
        x = x->parent->parent
      Else
        'uncle is BLACK
        If ( x = x->parent->right) Then
          'make x a left child
          x = x->parent
          This.rotateLeft(x)
        End If
        'recolor and rotate
        x->parent->color = BLACK
        x->parent->parent->color = RED
        This.rotateRight(x->parent->parent)
      End If
    Else
      ' mirror image of above code
      Var y = x->parent->parent->left
      If ( y->color = RED) Then
        ' uncle is RED
        x->parent->color = BLACK
        y->color = BLACK
        x->parent->parent->color = RED
        x = x->parent->parent
      Else
        ' uncle is BLACK
        If ( x = x->parent->left) Then
          x = x->parent
          This.rotateRight(x)
        End If
        x->parent->color = BLACK
        x->parent->parent->color = RED
        This.rotateLeft(x->parent->parent)
      End If
    End If
  Wend
  This.root->color = BLACK

End Sub

Function RBTree.insertNode(Key As String,Byval value As UDT Ptr) As RBNode Ptr
  'Insert a node in the RBTree

  'find where node belongs
  Dim current As RBNode Ptr = This.root
  Dim parent As RBNode Ptr
  While (current <> This.sentinel)
    Var rc = This.Compare(Key, current->key)
    If (rc = 0) Then
        Return current
    End If
    parent = current
    If (rc < 0) Then
      current = current->left
    Else
      current = current->right
    End If
  Wend
  ' setup new node
  Dim x As RBNode Ptr = New RBNode(Key, value)
  x->left  = This.sentinel
  x->right = This.sentinel
  x->parent = parent

  This.count = This.count + 1

  ' insert node in tree
  If (parent) Then
    If (This.Compare(Key, parent->key) < 0) Then
      parent->left = x
    Else
      parent->right = x
    End If
  Else
    This.root = x
  End If

  This.insertFixup(x)
  Return x
 
End Function

Sub RBTree.deleteFixup(Byval x As RBNode Ptr)
  'maintain tree balance after deleting node x
 
  Dim w As RBNode Ptr
  While (x <> This.root AndAlso x->color = BLACK)
    If (x = x->parent->left) Then
      w = x->parent->right
      If (w->color = RED) Then
        w->color = BLACK
        x->parent->color = RED
        This.rotateLeft(x->parent)
        w = x->parent->right
      End If

      If ( w->left->color = BLACK And w->right->color = BLACK) Then
        w->color = RED
        x = x->parent
      Else
        If ( w->right->color = BLACK) Then
          w->left->color = BLACK
          w->color = RED
          This.rotateRight(w)
          w = x->parent->right
        End If

        w->color = x->parent->color
        x->parent->color = BLACK
        w->right->color = BLACK
        This.rotateLeft(x->parent)
        x = This.root
      End If
    Else
      w = x->parent->left
      If ( w->color = RED) Then
        w->color = BLACK
        x->parent->color = RED
        This.rotateRight(x->parent)
        w = x->parent->left
      End If

      If ( w->right->color = BLACK And w->left->color = BLACK) Then
        w->color = RED
        x = x->parent
      Else
        If ( w->left->color = BLACK) Then
          w->right->color = BLACK
          w->color = RED
          This.rotateLeft(w)
          w = x->parent->left
        End If

        w->color = x->parent->color
        x->parent->color = BLACK
        w->left->color = BLACK
        This.rotateRight(x->parent)
        x = This.root
      End If
    End If
  Wend
  x->color = BLACK

End Sub

Sub RBTree.deleteNode(Byval z As RBNode Ptr)
  'delete node z from tree

  Dim y As RBNode Ptr
  Dim x As RBNode Ptr
 
  If ( 0 =  z OrElse z = This.sentinel) Then
    Return
  End If

  If (z->left = This.sentinel OrElse z->right = This.sentinel) Then
    'y has a This.sentinel node as a child
    y = z
  Else
    'find tree successor with a This.sentinel node as a child
    y = z->right
    While (y->left <> This.sentinel)
      y = y->left
    Wend
  End If

  'x is y's only child
  If ( y->left <> This.sentinel) Then
    x = y->left
  Else
    x = y->right
  End If

  'remove y from the parent chain
  x->parent = y->parent
  If ( y->parent) Then
    If ( y = y->parent->left) Then
      y->parent->left = x
    Else
      y->parent->right = x
    End If
  Else
    This.root = x
  End If

  'need to clone y otherwise Delete y will
  'destroy the data y points to
  If (y <> z) Then 
    z->key = y->key
    Delete z->value
    z->value = y->value->Clone()
    z->value->name = z->key
  End If

  If ( y->color = BLACK) Then
    This.deleteFixup(x)
  End If

  Delete y:y = NULL
 
  This.count = This.count - 1

End Sub

Function RBtree.findNode(Key As String) As RBNode Ptr
  'find node with key equal to key
  Var current = This.root

  While (current <> This.sentinel)
    Var rc = This.Compare(Key, current->key)
    If ( rc = 0) Then
      Return current
    Else
      If ( rc < 0) Then
        current = current->left
      Else
        current = current->right
      End If
    End If
  Wend
  Return 0

End Function


Type GraphicsNode

  Dim node As RBNode Ptr 
  Dim lvl As Ubyte
  Dim nxt As GraphicsNode Ptr
  Dim prev As GraphicsNode Ptr
  Dim x As Uinteger
  Dim y As Uinteger
 
End Type

Type NodeQueue

  Dim startx As Integer
  Dim starty As Integer
  Dim first As GraphicsNode Ptr
  Dim last  As GraphicsNode Ptr
  Dim levels(2 To 11) As Integer => {100,50,25,12,10,10,10,10,10}
  Dim count As Integer
  Declare Constructor
  Declare Destructor
  Declare Function Enqueue(Byref item As GraphicsNode Ptr) As Integer
  Declare Function Dequeue(Byref item As GraphicsNode Ptr) As GraphicsNode Ptr
  Declare Sub PrintNode(Byval item As GraphicsNode Ptr,Byval x As Integer,Byval y As Integer)
  Declare Sub PrintTree(Byval tree As RBTree Ptr)

End Type

Constructor NodeQueue()

  ''Draw first node in the middle of the screen
  '(just below the top of the screen)
  This.startx = 350
  This.starty = 100
  This.first = NULL
  This.last = NULL 
  This.count = 1
  '800x600, 32 bits color
  Screen 19,32
  Color ,RGB(255,255,155)
  Cls
End Constructor

Destructor NodeQueue()
 
End Destructor

Function NodeQueue.Enqueue(Byref item As GraphicsNode Ptr) As Integer

  'Insertion into an empty que
  If (This.first = NULL) Then
    This.first = item
    This.last = item
    This.Count += 1
    Return 0
  Else
    Var tmp = This.last
    This.last = item
    This.last->prev = tmp
    tmp->nxt = This.last
    This.last->nxt = NULL
    This.Count += 1
    Return 0
  End If
 
  Return -1

End Function

Function NodeQueue.Dequeue(Byref item As GraphicsNode Ptr) As GraphicsNode Ptr

  'Dequeueing from an empty queue or a queue with one node
  If (This.last = This.first) Then
    'Dequeueing from an empty queue
    If (This.last = NULL) Then
      This.Count -= 1
      Return NULL
    Else     
      'Dequeueing from a queue with one node
      item->node = This.First->node
      item->x = This.First->x
      item->y = This.First->y
      item->lvl = This.first->lvl     
      Delete This.first
      This.first = NULL
      This.last = NULL
      This.Count -= 1
      Return item
    End If
  Else 
    'Dequeueing from a queue with more than one node
    Var tmp = This.Last
    item->node = This.Last->node
    item->x = This.Last->x
    item->y = This.Last->y
    item->lvl = This.Last->lvl     
    This.last = This.last->prev
    This.last->nxt = NULL
    Delete tmp
    Return item
  End If
  Return NULL

End Function
   
Sub NodeQueue.PrintNode(Byval item As GraphicsNode Ptr,Byval x As Integer,Byval y As Integer)

  'Draw a black line from parent node to child node
  Line (x,y)-(item->x,item->y),RGB(0,0,0)
  'Draw node (either red or black)
  If (item->node->color = RED) Then
    Circle (item->x,item->y),5,RGB(255,0,0),,,,F
  Else
    Circle (item->x,item->y),5,RGB(0,0,0),,,,F
  End If
  Draw String (item->x,item->y - 25),Str(item->node->key),RGB(0,0,0)  
  'Draw String (item->x-8,item->y - 25),"""" & item->node->value & """",RGB(0,0,0)
 
End Sub

Sub NodeQueue.PrintTree(Byval tree As RBTree Ptr)

  Dim item As GraphicsNode Ptr

  Dim current As GraphicsNode Ptr = New GraphicsNode 
  Dim tmp As GraphicsNode Ptr
  Dim lvl As Integer = 1
  Dim x As Integer = This.startx
  Dim y As Integer = This.starty
 
  'check for empty tree
  If (tree->root = tree->sentinel) Then
    Return
  End If
 
  'Start with printing the root
  current->node = tree->root
  current->x = x
  current->y = y
  current->lvl = lvl 
  This.PrintNode(current,x,y)
  While(1)
    'Print left node (position it at left side of current node)
    If (current->node->left <> tree->sentinel) Then
      item = New GraphicsNode
      item->lvl = lvl + 1     
      If (item->lvl <= 9) Then
        item->x = x - This.levels(lvl+1)
      Else
        item->x = x - 10
      End If
      item->y = y + 50
      item->node = current->node->left
      This.PrintNode(item,x,y)
      This.Enqueue(item)
    End If
    'Print right node (position it at right side of current node
    If (current->node->right <> tree->sentinel) Then
      item = New GraphicsNode
      item->lvl = lvl + 1
      If (item->lvl <= 9) Then
        item->x = x + This.levels(lvl+1)
      Else
        item->x = x + 10
      End If
      item->y = y + 50
      item->node = current->node->right
      This.PrintNode(item,x,y)
      This.Enqueue(item)
    End If
    'Continue drawing from first node in the queue
    'Nodes in left tree will be drawn first as these are put in
    'the queue first
    Var tmp = This.Dequeue(current)
    'If count smaller then entire tree has been drawn
    If (This.count < 1) Then
      Exit While
    End If
    x = current->x
    y = current->y
    lvl = current->lvl
  Wend 
   
End Sub     

Dim item As UDT Ptr

Var tree = New RBTree(@string_compare)

Open Cons For Output As #1
For i As Integer = 0 To 20
  Print #1,"Insert ";i 
  item = New UDT
  item->name = Str(i)
  item->data = i
  tree->Insertnode(Str(i),item)
  Sleep()
  Dim print_tree As NodeQueue Ptr
  print_tree = New NodeQueue
  print_tree->PrintTree(tree)
  Delete print_tree 
Next i
Print #1,"Starting Deletion after keypress"
Var print_tree = New NodeQueue
print_tree->PrintTree(tree)
Sleep()
Delete print_tree

For i As Integer = 0 To 20
  Print #1,"Delete";i 
  Var n = tree->FindNode(Str(i))
  If (n) Then
    tree->Deletenode(n)
  End If
  Sleep()
  Dim print_tree As NodeQueue Ptr
  print_tree = New NodeQueue
  print_tree->PrintTree(tree)
  Delete print_tree 
Next i

Print #1,"Ending program after keypress"
Sleep()
Close #1
Delete tree
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

I have some questions about some of the code and some optimizations...

This is from .rotateLeft. I changed "y" to xRight.

Code: Select all

 ' Rotate node x to the right.
 var xRight = x->right

 ' Establish x->right link.
 x->right = xRight->left
 if xRight->left <> sentinel then xRight->left->parent = x

 ' Establish xRight->parent link.
 if xRight <> sentinel then xRight->parent = x->parent
* Can you explain what "sentinel" represents?

* Is it correct that xRight is not set to equal "x->right->left"? Or is it intended that xRight be the "old" "x->right" value?


------------------
* In .insertFixup, define y at the start ("dim y as rbNode ptr"). That way it's only allocated once instead of multiple times. Same for rc in .insertNode and .findNode.

* In .insertFixup, define a "temporary" xParent at the start along with a y. xParent isn't changed itself, so I think it's safe to do this. I replaced the while with a do loop because xParent needs to be in between the two exit conditions.

Code: Select all

 do
  if x = root then exit do
  xParent = x->parent
  if xParent->color <> RED then exit do
  ....
Last edited by agamemnus on Aug 19, 2010 18:32, edited 2 times in total.
sir_mud
Posts: 1401
Joined: Jul 29, 2006 3:00
Location: US
Contact:

Post by sir_mud »

The sentinel is equivalent to testing for null, just a way to know the end of the tree.
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

sir_mud: why not just test for null, then? What's the difference...?

OK, another optimization: you don't even need rc-- (this one is for .insertNode)

Code: Select all

 ' Find where the node belongs.
 dim as rbNode ptr current = root, parent
 do
  if current = sentinel then exit do
  select case compare (key, current->key)
  case 0: return current
  case is < 0: parent = current: current = current->left
  case else: parent = current: current = current->right
  end select
 loop
 ...
Edit: looks like "parent = current" needs to come before "current = ..."
Last edited by agamemnus on Aug 19, 2010 19:22, edited 2 times in total.
anonymous1337
Posts: 5494
Joined: Sep 12, 2005 20:06
Location: California

Post by anonymous1337 »

If leaves are explicitly nodes, some algorithms are simplified if there is no null. Read the wiki page.

Discrete graphs, combinatorics and algorithms pertaining to them are no five minute topics. They're very serious, in-depth subjects of mathematics. It's a shame that most people only deal with very basic analysis (calculus).
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Post by agamemnus »

anonymous1337 wrote:If leaves are explicitly nodes, some algorithms are simplified if there is no null. Read the wiki page.
I don't even understand your first sentence... I asked "what is the difference between null and sentinel" and you said something totally different than what I expected the answer to be... I mean... what does leaves being explicitly nodes have to do with this? ?????? AAARGH logic fail I45b64d56vdqaw3eaqq..
anonymous1337
Posts: 5494
Joined: Sep 12, 2005 20:06
Location: California

Post by anonymous1337 »

sir_mud: why not just test for null, then?
I was answering that one. Not even the one immediately after it.

If leaves are nothing but nodes - not even nulls - some algorithms are simplified.
Post Reply