Red black tree sort: Difference between revisions
(added Phix) |
(Red black tree sort in FreeBASIC) |
||
Line 9: | Line 9: | ||
You may use an implementation at [[Algebraic data types]] as a starting point, if you find that helpful. |
You may use an implementation at [[Algebraic data types]] as a starting point, if you find that helpful. |
||
=={{header|FreeBASIC}}== |
|||
Code originally by AGS. |
|||
https://www.freebasic.net/forum/viewtopic.php?t=16113 |
|||
<lang freebasic>#define NULL Cast(Any Ptr,0) |
|||
Enum nodecolor |
|||
BLACK = 0 |
|||
RED = 1 |
|||
End Enum |
|||
Type RBNode |
|||
Dim izda As RBNode Ptr |
|||
Dim dcha As RBNode Ptr |
|||
Dim parent As RBNode Ptr |
|||
Dim kolor 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.izda = NULL |
|||
This.dcha = NULL |
|||
This.parent = NULL |
|||
This.kolor = 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->izda = sentinel |
|||
This.sentinel->dcha = 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 izda 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->izda = This.sentinel) Then |
|||
child = parent->dcha |
|||
Delete parent |
|||
parent = 0 |
|||
Else |
|||
'rotate |
|||
child = parent->izda |
|||
parent->izda = child->dcha |
|||
child->dcha = 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->dcha |
|||
'establish x->dcha link |
|||
x->dcha = y->izda |
|||
If (y->izda <> This.sentinel) Then |
|||
y->izda->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->izda) Then |
|||
x->parent->izda = y |
|||
Else |
|||
x->parent->dcha = y |
|||
End If |
|||
Else |
|||
This.root = y |
|||
End If |
|||
'link x and y |
|||
y->izda = 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->izda |
|||
' establish x->left link |
|||
x->izda = y->dcha |
|||
If (y->dcha <> This.sentinel) Then |
|||
y->dcha->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->dcha) Then |
|||
x->parent->dcha = y |
|||
Else |
|||
x->parent->izda = y |
|||
End If |
|||
Else |
|||
This.root = y |
|||
End If |
|||
'link x and y |
|||
y->dcha = 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->kolor = RED) |
|||
'we have a violation |
|||
If (x->parent = x->parent->parent->izda) Then |
|||
Var y = x->parent->parent->dcha |
|||
If (y->kolor = RED) Then |
|||
'uncle is RED |
|||
x->parent->kolor = BLACK |
|||
y->kolor = BLACK |
|||
x->parent->parent->kolor = RED |
|||
x = x->parent->parent |
|||
Else |
|||
'uncle is BLACK |
|||
If (x = x->parent->dcha) Then |
|||
'make x a izda child |
|||
x = x->parent |
|||
This.rotateLeft(x) |
|||
End If |
|||
'recolor and rotate |
|||
x->parent->kolor = BLACK |
|||
x->parent->parent->kolor = RED |
|||
This.rotateRight(x->parent->parent) |
|||
End If |
|||
Else |
|||
' mirror image of above code |
|||
Var y = x->parent->parent->izda |
|||
If (y->kolor = RED) Then |
|||
' uncle is RED |
|||
x->parent->kolor = BLACK |
|||
y->kolor = BLACK |
|||
x->parent->parent->kolor = RED |
|||
x = x->parent->parent |
|||
Else |
|||
' uncle is BLACK |
|||
If (x = x->parent->izda) Then |
|||
x = x->parent |
|||
This.rotateRight(x) |
|||
End If |
|||
x->parent->kolor = BLACK |
|||
x->parent->parent->kolor = RED |
|||
This.rotateLeft(x->parent->parent) |
|||
End If |
|||
End If |
|||
Wend |
|||
This.root->kolor = 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 |
|||
parent = current |
|||
If (rc < 0) Then |
|||
current = current->izda |
|||
Else |
|||
current = current->dcha |
|||
End If |
|||
Wend |
|||
' setup new node |
|||
Dim x As RBNode Ptr = New RBNode(key, value) |
|||
x->izda = This.sentinel |
|||
x->dcha = 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->izda = x |
|||
Else |
|||
parent->dcha = 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->kolor = BLACK) |
|||
If (x = x->parent->izda) Then |
|||
w = x->parent->dcha |
|||
If (w->kolor = RED) Then |
|||
w->kolor = BLACK |
|||
x->parent->kolor = RED |
|||
This.rotateLeft(x->parent) |
|||
w = x->parent->dcha |
|||
End If |
|||
If (w->izda->kolor = BLACK And w->dcha->kolor = BLACK) Then |
|||
w->kolor = RED |
|||
x = x->parent |
|||
Else |
|||
If (w->dcha->kolor = BLACK) Then |
|||
w->izda->kolor = BLACK |
|||
w->kolor = RED |
|||
This.rotateRight(w) |
|||
w = x->parent->dcha |
|||
End If |
|||
w->kolor = x->parent->kolor |
|||
x->parent->kolor = BLACK |
|||
w->dcha->kolor = BLACK |
|||
This.rotateLeft(x->parent) |
|||
x = This.root |
|||
End If |
|||
Else |
|||
w = x->parent->izda |
|||
If (w->kolor = RED) Then |
|||
w->kolor = BLACK |
|||
x->parent->kolor = RED |
|||
This.rotateRight(x->parent) |
|||
w = x->parent->izda |
|||
End If |
|||
If (w->dcha->kolor = BLACK And w->izda->kolor = BLACK) Then |
|||
w->kolor = RED |
|||
x = x->parent |
|||
Else |
|||
If (w->izda->kolor = BLACK) Then |
|||
w->dcha->kolor = BLACK |
|||
w->kolor = RED |
|||
This.rotateLeft(w) |
|||
w = x->parent->izda |
|||
End If |
|||
w->kolor = x->parent->kolor |
|||
x->parent->kolor = BLACK |
|||
w->izda->kolor = BLACK |
|||
This.rotateRight(x->parent) |
|||
x = This.root |
|||
End If |
|||
End If |
|||
Wend |
|||
x->kolor = 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 |
|||
If (z->izda = This.sentinel Orelse z->dcha = 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->dcha |
|||
While (y->izda <> This.sentinel) |
|||
y = y->izda |
|||
Wend |
|||
End If |
|||
'x is y's only child |
|||
If (y->izda <> This.sentinel) Then |
|||
x = y->izda |
|||
Else |
|||
x = y->dcha |
|||
End If |
|||
'remove y from the parent chain |
|||
x->parent = y->parent |
|||
If (y->parent) Then |
|||
If (y = y->parent->izda) Then |
|||
y->parent->izda = x |
|||
Else |
|||
y->parent->dcha = 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->kolor = 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->izda |
|||
Else |
|||
current = current->dcha |
|||
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 kolor |
|||
Screen 19,32 |
|||
color , Rgb(255,255,155) |
|||
Cls |
|||
WindowTitle "Red black tree sort" |
|||
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->kolor = 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 |
|||
'Start with printing the root |
|||
current->node = tree->root |
|||
current->x = x |
|||
current->y = y |
|||
current->lvl = lvl |
|||
This.PrintNode(current,x,y) |
|||
Do |
|||
'Print izda node (position it at izda side of current node) |
|||
If (current->node->izda <> 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->izda |
|||
This.PrintNode(item,x,y) |
|||
This.Enqueue(item) |
|||
End If |
|||
'Print dcha node (position it at dcha side of current node |
|||
If (current->node->dcha <> 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->dcha |
|||
This.PrintNode(item,x,y) |
|||
This.Enqueue(item) |
|||
End If |
|||
'Continue drawing from first node in the queue |
|||
'Nodes in izda 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 Do |
|||
x = current->x |
|||
y = current->y |
|||
lvl = current->lvl |
|||
Loop |
|||
End Sub |
|||
Dim x As Integer Ptr |
|||
Dim i As Integer |
|||
Var tree = New RBTree(@integer_compare) |
|||
Open Cons For Output As #1 |
|||
For i = 0 To 29 |
|||
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, !"\nStarting Deletion after keypress" |
|||
Var print_tree = New NodeQueue |
|||
print_tree->PrintTree(tree) |
|||
Sleep() |
|||
Delete print_tree |
|||
randomize timer |
|||
For i = 0 To 14 |
|||
Dim as integer j = int(rnd * 15) + int(rnd * 16) |
|||
Print #1, "Delete"; j |
|||
Var n = tree->FindNode(j) |
|||
If (n) Then tree->Deletenode(n) |
|||
Sleep() |
|||
Dim print_tree As NodeQueue Ptr |
|||
print_tree = New NodeQueue |
|||
print_tree->PrintTree(tree) |
|||
Delete print_tree |
|||
Next i |
|||
Bsave "FreeBASIC_Red-black-tree_sort.bmp", 0 |
|||
Print #1, !"\nEnding program after keypress" |
|||
Sleep() |
|||
Close #1 |
|||
Delete tree</lang> |
|||
{{out}} |
|||
[https://www.dropbox.com/s/hbrtaahsd6jmlyl/FreeBASIC_Red-black-tree_sort.bmp?dl=0 FreeBasic Red black tree sort image] |
|||
Revision as of 23:01, 16 June 2022
Implement red-black tree sorting of fixed width integers. Here, the left branch will only contain nodes with a smaller key and the right branch will only contain nodes with a larger key.
Start with an empty tree, add 30 nodes each with arbitrary (aka "random") keys, then traverse the tree, printing the values from the left node, the key value, then the values from the right node, displaying their value and their color (red or black). Since we are using a red-black tree here, this would eliminate any duplicate values.
Then delete an arbitrary 15 nodes and display the resulting tree.
You may use an implementation at Algebraic data types as a starting point, if you find that helpful.
FreeBASIC
Code originally by AGS. https://www.freebasic.net/forum/viewtopic.php?t=16113 <lang freebasic>#define NULL Cast(Any Ptr,0)
Enum nodecolor
BLACK = 0 RED = 1
End Enum
Type RBNode
Dim izda As RBNode Ptr Dim dcha As RBNode Ptr Dim parent As RBNode Ptr Dim kolor 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.izda = NULL This.dcha = NULL This.parent = NULL This.kolor = 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->izda = sentinel This.sentinel->dcha = 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 izda 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->izda = This.sentinel) Then child = parent->dcha Delete parent parent = 0 Else 'rotate child = parent->izda parent->izda = child->dcha child->dcha = 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->dcha 'establish x->dcha link x->dcha = y->izda If (y->izda <> This.sentinel) Then y->izda->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->izda) Then x->parent->izda = y Else x->parent->dcha = y End If Else This.root = y End If 'link x and y y->izda = 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->izda ' establish x->left link x->izda = y->dcha If (y->dcha <> This.sentinel) Then y->dcha->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->dcha) Then x->parent->dcha = y Else x->parent->izda = y End If Else This.root = y End If 'link x and y y->dcha = 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->kolor = RED) 'we have a violation If (x->parent = x->parent->parent->izda) Then Var y = x->parent->parent->dcha If (y->kolor = RED) Then 'uncle is RED x->parent->kolor = BLACK y->kolor = BLACK x->parent->parent->kolor = RED x = x->parent->parent Else 'uncle is BLACK If (x = x->parent->dcha) Then 'make x a izda child x = x->parent This.rotateLeft(x) End If 'recolor and rotate x->parent->kolor = BLACK x->parent->parent->kolor = RED This.rotateRight(x->parent->parent) End If Else ' mirror image of above code Var y = x->parent->parent->izda If (y->kolor = RED) Then ' uncle is RED x->parent->kolor = BLACK y->kolor = BLACK x->parent->parent->kolor = RED x = x->parent->parent Else ' uncle is BLACK If (x = x->parent->izda) Then x = x->parent This.rotateRight(x) End If x->parent->kolor = BLACK x->parent->parent->kolor = RED This.rotateLeft(x->parent->parent) End If End If Wend This.root->kolor = 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 parent = current If (rc < 0) Then current = current->izda Else current = current->dcha End If Wend ' setup new node Dim x As RBNode Ptr = New RBNode(key, value) x->izda = This.sentinel x->dcha = 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->izda = x Else parent->dcha = 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->kolor = BLACK) If (x = x->parent->izda) Then w = x->parent->dcha If (w->kolor = RED) Then w->kolor = BLACK x->parent->kolor = RED This.rotateLeft(x->parent) w = x->parent->dcha End If If (w->izda->kolor = BLACK And w->dcha->kolor = BLACK) Then w->kolor = RED x = x->parent Else If (w->dcha->kolor = BLACK) Then w->izda->kolor = BLACK w->kolor = RED This.rotateRight(w) w = x->parent->dcha End If w->kolor = x->parent->kolor x->parent->kolor = BLACK w->dcha->kolor = BLACK This.rotateLeft(x->parent) x = This.root End If Else w = x->parent->izda If (w->kolor = RED) Then w->kolor = BLACK x->parent->kolor = RED This.rotateRight(x->parent) w = x->parent->izda End If If (w->dcha->kolor = BLACK And w->izda->kolor = BLACK) Then w->kolor = RED x = x->parent Else If (w->izda->kolor = BLACK) Then w->dcha->kolor = BLACK w->kolor = RED This.rotateLeft(w) w = x->parent->izda End If w->kolor = x->parent->kolor x->parent->kolor = BLACK w->izda->kolor = BLACK This.rotateRight(x->parent) x = This.root End If End If Wend x->kolor = 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 If (z->izda = This.sentinel Orelse z->dcha = 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->dcha While (y->izda <> This.sentinel) y = y->izda Wend End If 'x is y's only child If (y->izda <> This.sentinel) Then x = y->izda Else x = y->dcha End If 'remove y from the parent chain x->parent = y->parent If (y->parent) Then If (y = y->parent->izda) Then y->parent->izda = x Else y->parent->dcha = 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->kolor = 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->izda Else current = current->dcha 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 kolor Screen 19,32 color , Rgb(255,255,155) Cls WindowTitle "Red black tree sort"
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->kolor = 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 'Start with printing the root current->node = tree->root current->x = x current->y = y current->lvl = lvl This.PrintNode(current,x,y) Do 'Print izda node (position it at izda side of current node) If (current->node->izda <> 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->izda This.PrintNode(item,x,y) This.Enqueue(item) End If 'Print dcha node (position it at dcha side of current node If (current->node->dcha <> 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->dcha This.PrintNode(item,x,y) This.Enqueue(item) End If 'Continue drawing from first node in the queue 'Nodes in izda 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 Do x = current->x y = current->y lvl = current->lvl Loop
End Sub
Dim x As Integer Ptr Dim i As Integer Var tree = New RBTree(@integer_compare)
Open Cons For Output As #1 For i = 0 To 29
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, !"\nStarting Deletion after keypress" Var print_tree = New NodeQueue print_tree->PrintTree(tree) Sleep() Delete print_tree
randomize timer For i = 0 To 14
Dim as integer j = int(rnd * 15) + int(rnd * 16) Print #1, "Delete"; j Var n = tree->FindNode(j) If (n) Then tree->Deletenode(n) Sleep() Dim print_tree As NodeQueue Ptr print_tree = New NodeQueue print_tree->PrintTree(tree) Delete print_tree
Next i
Bsave "FreeBASIC_Red-black-tree_sort.bmp", 0 Print #1, !"\nEnding program after keypress" Sleep() Close #1 Delete tree</lang>
- Output:
FreeBasic Red black tree sort image
Julia
See Red_black_tree_sort/Julia.