Структуры данных (стеки, очереди, деревья...)

На этой странице размещены исходные коды различных структур данных. Написаны они различными авторами , в том числе и мной. Я благодарю авторов тех исходников, которые попали в эту копилку и по возможности буду указывать ссылку на их страницу.

Стек
Очередь
Битовые множества
Связанный список (однонаправленный)
Хеш-таблица
Бинарное дерево (рекурсивная реализация)
Бинарное дерево (итерационная реализация)
AVL дерево
Красно-черное дерево

Реализация стека с помощью динамического массива.

Описание: частный случай однонаправленного списка, где добавление и выборка значений происходит из одного конца. Принцип действия: "Последним вошел - первым вышел"

Type mType As Integer 

Type TStack
    iIndex As Integer
    iAll As Integer
    Dim IndexStack(Any) As mType
    Declare Sub init()
    Declare Sub free()
    Declare Sub push(As mType)
    Declare Function pop() As mType 
End Type

Sub TStack.init()
    Redim IndexStack(100) As mType
    iIndex = -1 : iAll = 100
End Sub

Sub TStack.free()
    Redim IndexStack(0) As mType
End Sub

Sub TStack.push( iValue As mType)
    
    If iIndex >= iAll Then
        iAll+=100
        Redim Preserve IndexStack(iAll) As mType
    Endif
    
    iIndex+=1
    IndexStack(iIndex) = iValue
    
End Sub

Function TStack.pop() As mType
    If iIndex > 0 Then
        Function = IndexStack(iIndex)
        iIndex -= 1
    Elseif iIndex = 0 Then  
        Function = IndexStack(iIndex)
        IndexStack(iIndex) = 0
        iIndex -= 1
        Redim IndexStack(100) As mType  
    Else
        Print "Stack empty!!!"
    Endif
End Function


'''''''''Test''''''''
Dim Shared stack As TStack

Stack.init()

For i As Integer  = 0 To 120
    Stack.push(i)
Next

For i As Integer  = 0 To 120
    ? Stack.pop
Next

Stack.free()
Sleep

Реализация очереди из 10 элементов

Описание для данной реализации: частный случай однонаправленного списка, где добавление значений происходит с конца, а выборка значений сначала. Принцип действия: "Первым вошел - первым вышел"

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
' Очередь из 10 элементов
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

' класс queue
Type queue
  v As Integer ' значение
  pNext As queue Ptr ' указатель на следующий элемент
  Declare Sub AddQueue( v As Integer) ' метод добавления
  Declare Sub DelQueue() ' метод полного удаления
  Declare Sub PrintQueue() ' вывод на консоль всех элементов
End Type

Dim Shared As queue Ptr pFirst, pEnd  ' указатели на начало и конец очереди
Dim Shared As Integer iIndex ' кол-во элементов в очереди

' метод добавления элемента в очередь
Sub queue.AddQueue( v As Integer)

  Dim pTemp As queue Ptr = New queue ' создаем новый элемент очереди
  pTemp->v = v ' присваиваем значение

  If iIndex<10 Then ' если очередь содержит меньше 10 элементов

   If iIndex = 0 Then ' если в очереди еще нет элементов
    pFirst = pTemp ' данный элемент становится первым в очереди
    pEnd = pTemp ' так же данный элемент является последним в очереди
    pEnd->pNext = 0 ' указатель на следующий элемент обнуляем
   Else
    pEnd->pNext = pTemp ' данный элемент ставим в очередь после последнего элемента
    pEnd = pTemp ' теперь этот элемент стал последним
    pTemp->pNext = 0 ' указатель на следующий элемент обнуляем
   Endif

   iIndex+=1 ' увеличиваем счетчик элементов

  Else

   Dim As queue Ptr pDel = pFirst ' запоминаем первый указатель для удаления
   pFirst = pFirst->pNext ' теперь второй элемент станет первым в очереди
   Delete pDel : pDel = 0 ' удаляем запомненный элемент и обнуляем

   pEnd->pNext = pTemp ' данный элемент ставим в очередь после последнего элемента
   pEnd = pTemp ' теперь этот элемент стал последним
   pTemp->pNext = 0 ' указатель на следующий элемент обнуляем
  Endif

End Sub

' метод удалениея всех элементов из очереди
Sub queue.DelQueue()

  ' временные указатели на элементы очереди,
  ' одному из них присваиваем первый элемент очереди
  Dim As queue Ptr pDel, pTemp =  pFirst

  While pTemp <> 0 ' пока указатель на элемент очереди существует

   pDel = pTemp ' присваиваем указатель на удаление
   pTemp = pTemp->pNext ' присваиваем указатель на следующий элемент
   Delete pDel ' удаляем элемент

  Wend

End Sub

' метод вывода на консоль всех элементов очереди
Sub queue.PrintQueue()
   
  ' временный указатель на элемент очереди,
  ' присваиваем ему указатель на первый элемент
  Dim As queue Ptr pTemp =  pFirst  
   
  While pTemp <> 0 ' пока указатель на элемент очереди существует

   Print pTemp->v & " "; ' выводим значение элемента очереди на консоль
   pTemp = pTemp->pNext ' присваиваем указатель на следующий элемент

  Wend  
  Print  
End Sub

'\\\\\\\\\\\\\\\\\\\\\\\\
' Тест работы класса
'\\\\\\\\\\\\\\\\\\\\\\\\

Dim pInitQueue As queue Ptr  = New queue ' инициализируем класс

' Цикл на 20 итераций (в очередь поступит 20 значений)
For i As Integer = 1 To 20  
  pInitQueue->AddQueue(i) ' добавляем элемент
  pInitQueue->PrintQueue() ' печатаем все элементы очереди
  Print ' пустая строка (разделитель)
  Print "Press any key!!!"
  Sleep
Next

pInitQueue->DelQueue() ' удаляем все элементы
Delete pInitQueue ' удаляем указатель инициализации класса
Print "End program, press any key"
Sleep

Битовые множества

Описание: позволяет экономно хранить ограниченный набор значений и отвечать на вопрос о принадлежности некоторого значения данному набору. Допустимое значение может входить во множество не более одного раза.

'тип - множество
Union TSet

    As Byte Data(32)
    As Long data_(8)

End Union

Dim Set As  TSet

' очищает множество
#MACRO ClearSet(set)
   Erase set.data_
#EndMacro

' включает элемент во множество
#MACRO IncludeSet(set,n)
    set.data( n Shr 3) Or= (1 Shl (n And 7))
#EndMacro

' возвращает не 0, если элемент есть во множестве
#MACRO InSet(set,n)
    set.data( n Shr 3 ) And (1 Shl ( n And 7))
#EndMacro

' Исключает элемент из множества
#MACRO UnSet(set,n)
    If InSet(set,n) Then
        set.data( n Shr 3) xor= (1 Shl (n And 7))
    Endif   
#EndMacro


'''''''''''''' Test '''''''''''''''''''

IncludeSet(set,11)
IncludeSet(set,12)
IncludeSet(set,13)

For i As Integer = 0 To 40
    ? i,InSet(Set,i)
Next

Print "Delete 12"
UnSet(Set,12)

For i As Integer = 0 To 40
    ? i,InSet(Set,i)
Next

ClearSet(set)

Sleep

Связанный список (однонаправленный)

Описание: чаще всего используется для больших , заранее неизвестных объемов входных данных. В отличие от массивов , элементы легко поддаются удалению, а список расширению\вставке. С другой стороны, доступ к элементам имеет линейную зависимость. Так же реализация сортировки заметно сложнее чем у массивов. Данный список является однонаправленным (односвязным), то есть содержит указатель только на следующий элемент и по нему связан. Для двухсвязного списка необходимо, чтобы в каждом узле списка содержался дополнительно указатель на предыдущий элемент и были организованы для него связи для каждого узла.

' Связанный список

Type myType As Integer

Type TList
    As myType Data
    As Integer iKey ' ключ для удаления и доступа к определенному элементу
    As TList Ptr p
End Type


Dim Shared As TList Ptr pFirst = 0 , pEnd = 0

' добавление в конец списка
Function addLast ( myData As myType) As Integer

    Dim As TList Ptr nw = Allocate(Sizeof(TList))

    If nw = 0 Then Return 0

    nw->Data = myData
    nw->p = 0

    If pFirst = 0 Then
        pFirst = nw
        pFirst->iKey = 1
        pEnd = pFirst
    Else
        nw->iKey = pEnd->iKey+1
        pEnd->p = nw
        pEnd = nw
    Endif

    Return 1

End Function

' добавление в начало списка
Function addBegin ( myData As myType) As Integer

    Dim As TList Ptr nw = Allocate(Sizeof(TList))

    If nw = 0 Then Return 0

    nw->Data = myData

    If pFirst = 0 Then
        pFirst = nw
        pFirst->iKey = 1
        pEnd = pFirst
    Else
        nw->p = pFirst
        pFirst = nw
        Dim As TList Ptr pTemp = pFirst
        Dim iKey As Integer = 1
        While pTemp
            pTemp->iKey = iKey
            pTemp = pTemp->p
            iKey += 1
        Wend
    Endif

    Return 1

End Function

' вставка элемента в любое место списка по индексу
Function insert ( iKey As Integer, myData As myType) As Integer
    
    Dim As TList Ptr nw = Allocate(Sizeof(TList))

    If nw = 0 Then Return 0
    
    nw->Data = myData   

    If pFirst = 0 Then
      Return addLast(myData)
    Elseif iKey = 1 Then
        Return addBegin(myData)     
    Elseif pEnd->iKey+1 <= iKey Then
        Return addLast(myData)
    Else
        Dim As TList Ptr pTemp = pFirst
        For i As Integer = 1 To iKey - 2
            pTemp = pTemp->p
        Next
        nw->p = pTemp->p
        pTemp->p = nw
        pTemp = pFirst
        Dim iKey As Integer = 1
        While pTemp
            pTemp->iKey = iKey
            pTemp = pTemp->p
            iKey += 1
        Wend    
        Return 1
    Endif
    
End Function

' удаление элемента из списка по заданному индексу
Function delElement ( iKey As Integer) As Integer

    Dim As TList Ptr pTemp = pFirst, pTempOld

    pTempOld = pTemp

    While pTemp

        If pTemp->iKey = iKey Then
            If pTemp->p <> 0 Then
                If pTemp = pFirst Then
                    pFirst = pTemp->p
                Else
                    pTempOld->p = pTemp->p
                Endif
            Else
                If pTemp = pFirst Then
                    pFirst = 0
                    pEnd = 0
                Else
                    pTempOld->p = 0
                    pEnd = pTempOld
                Endif
            Endif
            Deallocate(pTemp)
            pTemp = pFirst
            Dim iKey As Integer = 1
            While pTemp
                pTemp->iKey = iKey
                pTemp = pTemp->p
                iKey += 1
            Wend
            Return 1
        Endif

        pTempOld = pTemp
        pTemp = pTemp->p
    Wend

End Function

' получение значения элемента из списка по заданному индексу
Function getElement ( iKey As Integer) As myType
    Dim As TList Ptr pTemp = pFirst
    While pTemp
        If pTemp->iKey = iKey Then
            Return pTemp->Data
        Endif
        pTemp = pTemp->p
    Wend
End Function

' изменение значения для имеющегося элемента из списка по заданному индексу
Function setElement ( iKey As Integer, iData As myType ) As Integer
    Dim As TList Ptr pTemp = pFirst
    While pTemp
        If pTemp->iKey = iKey Then
            pTemp->Data = iData
            Return 1
        Endif
        pTemp = pTemp->p
    Wend
End Function

' печать всего списка
Sub PrintAll()
    Dim As TList Ptr pTemp = pFirst
    While pTemp
        Print "index = "; pTemp->iKey,"Value = ";pTemp->Data
        pTemp = pTemp->p
    Wend
End Sub

' удаление всего списка
Sub ClearList() 
    Dim As TList Ptr pTemp = pFirst, pDel
    While pTemp
        pDel = pTemp
        pTemp = pTemp->p
        Deallocate(pDel)
    Wend    
    pFirst = 0 : pEnd = 0
End Sub

''''''''''''' Тест ''''''''''''''''''''''

Randomize Timer

Print "---------Add Last-----------"
For i As Integer = 0 To 9
    addLast(Rnd*100)
Next
PrintAll()

Print "-----------Delete 10 element---------"
delElement(10)
PrintAll()

Print "----------Add Begin 3 elements----------"
For i As Integer = 0 To 2
    addBegin(i)
Next
PrintAll()

Print "---------Insert 2 element-----------"
insert(2,777)
PrintAll()

Print "--------get and set------------"
Print "Value for index 2 = "; getElement(2)
Print "Change Value for index 2" : setElement(2,999)
Print "Value for index 2 = "; getElement(2)
ClearList()
Sleep

Хеш-таблица

Описание: представляет из себя структуру данных, реализующую интерфейс ассоциативного массива. Если проще, то это некая структура (чаще всего массив) , каждая ячейка которого\й содержит указатель на отдельный список. Понятно, что если перебирать большой целый связанный список, то времени может уходить немало. Но hash функция обрабатывает значение перед вставкой в список\ки и определяет свою ячейку для своего связанного списка. При поиске значения , оно опять обрабатывается hash функцией и таким образом определяет в каком списке какой ячейки искать это значение. Скорость поиска значений с использованием hash таблиц в среднем значительно быстрее поиска в связанном списке. Ссылка на страницу автора исходного кода

'  This HashFunction basically converts the first several bytes
'  of a string into a machine dependent integer which is then
'  wrapped into the hash table. The string length cannot be smaller
'  than the sizeof(int).  

#INCLUDE "crt.bi"

#DEFINE  HTABLESIZE     10

Type Node
    As Node Ptr Next
    As Zstring Ptr Data 
End Type

Dim Shared As Node Ptr HashTable(HTABLESIZE)

Declare Sub HashTableCreate()
Declare Sub HashTableDestroy()
Declare Function HashTableInsert(data_ As Zstring Ptr) As Integer ' =-1 on failure, =0 if ok
Declare Function HashTableFind(data_ As Zstring Ptr) As node Ptr ' search return data node
Declare Function HashTableDelete(data_ As Zstring Ptr) As Integer ' =0 on ok, =-1 on fail
Declare Function  HashFunction(data_ As Zstring Ptr) As Integer
Declare Sub HashTablePrint()  ' Print all elements in table



''''''''''''''''''''''''''''
    Dim As Integer i
    HashTableCreate()

    For i = 1 To 99  ' Insert Keys "1key"-"99key"
        Dim As ZString*100 buf
        sprintf(buf,!"%dkey",i)
        HashTableInsert(buf)
    Next

    HashTablePrint()    ' Print out all of the Hash Table

    For i = 50 To 90  '  Remove keys "50key"-"90key"
        Dim As ZString*100 buf
        sprintf(buf,!"%dkey",i)
        HashTableDelete(buf)
    Next

    HashTablePrint()    ' Print out Hash table

    HashTableDestroy()  ' Destroy the Hash Table
Sleep

''''''''''''''''''''''''''''
Sub HashTableCreate()
    Dim As Integer i
    For i = 0 To HTABLESIZE - 1
        HashTable(i)=0
    Next    
End Sub

    


''''''''''''''''''''''''''''
Sub HashTableDestroy()
    Dim As Integer i
    For i = 0 To HTABLESIZE - 1
        Dim As Node Ptr p
        p = HashTable(i)
        While p <> 0
            Dim As Node Ptr tmp
            tmp = p
            p = p->Next
            free(tmp->Data)
            free(tmp)
        Wend
    Next    
End Sub

    


''''''''''''''''''''''''''''
Function HashTableInsert(data_ As Zstring Ptr) As Integer ' =-1 on failure, =0 if ok
    Dim As Integer ind
    Dim As Node Ptr nw
    nw = malloc(Sizeof(Node))
    If nw =0 Then Return -1
    nw->Data = malloc(1+Len(data_))
    If nw->Data = 0 Then
        free(nw)
        Return -1
    Endif
    strcpy(nw->Data,Data_)
    ind = HashFunction(data_)
    nw->Next = HashTable(ind)  
    HashTable(ind) = nw
    Return 0
End Function


''''''''''''''''''''''''''''
Function HashTableFind(data_ As Zstring Ptr) As node Ptr ' search return data node
    Dim As  Node Ptr p
    p = HashTable(HashFunction(data_))
    While p <> 0    
        If StrCmp(p->Data,data_) = 0  Then Return p
        p = p->Next
    Wend

    Return 0
End Function


''''''''''''''''''''''''''''
Function HashTableDelete(data_ As Zstring Ptr) As Integer ' =0 ok, =-1 on fail
    Dim As Integer ind
    Dim As Node Ptr p
    ind = HashFunction(data_)
    p = HashTable(ind)
    If p = 0 Then Return -1
    If StrCmp(p->Data,data_) = 0  Then
        HashTable(ind) = p->Next
        free(p->Data)
        free(p)
        Return 0
    Endif

    While p->Next <> 0 
        
        If StrCmp(p->Next->Data,data_) = 0 Then
            Dim As Node Ptr tmp
            tmp = p->Next
            p->Next = tmp->Next 
            free(tmp->Data)
            free(tmp)
            Return 0
        Endif   
        p = p->Next
    Wend

    Return -1
End Function


'''''''''''''''''''''''''''''''''
Function HashFunction(data_ As Zstring Ptr) As Integer ' convert the first several bytes into int
    Return *Cast(Integer Ptr,data_) Mod HTABLESIZE  
End Function




''''''''''''''''''''''''''''''
Sub HashTablePrint()  ' Print all elements in table
    Dim As Integer i
    For i = 0 To HTABLESIZE - 1
        Dim As Node Ptr p
        printf(!"Slot %d:",i)

        p = HashTable(i)

        While p <> 0
            printf(!" %s",p->Data)
            p = p->Next             
        Wend

        printf(!"\n")
    Next
    printf(!"\n")
End Sub

Бинарное дерево (рекурсивная реализация)

Описание: преимущества бинарного дерева по сравнению с другими структурами данных - это простая реализация и возможная эффективность при поиске значений, а так же сортировка значений. Это простейшая реализация , главной целю которой, было показать начинающим основы построения дерева. Реализация имела только методы добавления и обхода дерева. Я решил добавить функцию поиска. Само по себе бинарное дерево в данной реализации является несбалансированным, то есть при определенных условиях , поиск значения может показать не самые завидные результаты. Лучшим решением конечно являются самосбалансированные деревья (AVL или Красно-черное) , но они заметно сложнее в реализации. На данной странице (ниже) представлены примеры самосбалансированных деревьев. Ссылка на страницу автора исходного кода и описания.

Type Node 'Звено дерева
    As Integer x 'То, что записываем в дерево
    As Node Ptr l,r 'Это указатели на новые звенья
End Type

Sub show(Byref Tree As Node Ptr ) 'Функция обхода
    If (Tree<>0) Then 'Пока не встретится пустое звено
        show(Tree->l) 'Рекурсивная функция для вывода левого поддерева
        Print Tree->x 'Отображаем корень дерева
        show(Tree->r) 'Рекурсивная функци для вывода правого поддерева
    Endif
End Sub

Sub add_node(x As Integer, Byref MyTree As Node Ptr) 'Фукция добавления звена в дерево

    If (MyTree = 0) Then  'То, о чем я в самом начале писал. Если дерева нет, то ложим семечко
        MyTree=new Node 'Выделяем память под звено дерева
        MyTree->x=x 'Записываем данные в звено
        MyTree->l=0 'Подзвенья инициализируем пустотой во избежание ошибок
        MyTree->r=0 'Подзвенья инициализируем пустотой во избежание ошибок
    Endif

    If (x<MyTree->x) Then   'Если нововведенный элемент x меньше чем элемент x из семечка дерева, уходим влево
        If (MyTree->l<>0) Then
            add_node(x,MyTree->l) 'При помощи рекурсии заталкиваем элемент на свободный участок
        Else 'Если элемент получил свой участок, то
            MyTree->l=new Node  'Выделяем память левому подзвену. Именно подзвену, а не просто звену
            MyTree->l->l=0 : MyTree->l->r=0 'У левого подзвена будут свои левое и правое подзвенья, инициализируем их пустотой
            MyTree->l->x=x 'Записываем в левое подзвено записываемый элемент
        Endif
    Endif

    If (x>MyTree->x) Then  'Если нововведенный элемент x больше чем элемент x из семечка дерева, уходим вправо
        If (MyTree->r<>0)Then
            add_node(x,MyTree->r) 'При помощи рекурсии заталкиваем элемент на свободный участок
        Else 'Если элемент получил свой участок, то
            MyTree->r=new Node  'Выделяем память правому подзвену. Именно подзвену, а не просто звену
            MyTree->r->l=0:MyTree->r->r=0 'У правого подзвена будут свои левое и правое подзвенья, инициализируем их пустотой
            MyTree->r->x=x 'Записываем в правое подзвено записываемый элемент
        Endif
    Endif

End Sub

' функция поиска значения
Function find_node(ikey As Integer, MyTree As Node Ptr) As Node Ptr
    
    ' если такого звена нет ИЛИ ключ найден, возвращаем указатель на него
    If MyTree = 0 OrElse MyTree->x = ikey Then Return MyTree

   If MyTree->x < ikey Then ' если ключ больше чем значение в данном звене
            Return find_node(iKey,MyTree->r) ' поехали искать по правому краю
   Else ' иначе
            Return find_node(iKey,MyTree->l)    ' поехали искать по левому краю
   Endif
   
End Function


Dim As Node Ptr Tree=0  'Создаю указатель, тип которого = звено дерева и инициализирую его пустотой

For  i As integer=5 To 1 Step -1
    add_node(i,Tree) 'Это я забивал 5-4-3-2-1, а вывод сами увидите
Next

show(Tree) 'Вывод на экран дерева. или просто обход дерева

Dim As Node Ptr fNode = find_node(3,Tree) 'ищем звено дерева для значения 3

If fNode <> 0 Then ' если звено найдено
    ? "Find:"; fNode->x ' печатаем что там находится
Else
    ? "not found" ' не найдено значение в дереве
Endif

Sleep

Бинарное дерево (итерационная реализация)

Описание: нерекурсивная реализация бинарного дерева может пригодится для программ обильно использующих стек, чтобы оградить себя от возможного переполнения стека. Ссылка на страницу автора исходного кода.

' BOX #1:  Right Threaded Tree.

Enum Direction
    UP
    DOWN
End Enum

Type Node
    As Integer Data_
    As Node Ptr Left_,Right_
    RightDirection As Direction  ' Should be a single bit
End Type

''''''''''''''''''''
Dim Shared As Node Ptr Root = 0
'''''''''''''''''''/

Declare Function InsertItem(data_ As Integer) As Integer '=0 on OK, =-1 on fail
Declare Function SearchItem(data_ As Integer) As Node Ptr '=0 on fail
Declare Sub DestroyTree(tree As node Ptr)  ' destroy tree
Declare Sub PrintTree()  ' Print the tree



Dim i As Integer
For i=0 To 10000  ' Insert Some Items into tree
    InsertItem(i)
Next

PrintTree()  ' Print Tree In-Order Traversal

DestroyTree(Root)
Sleep
''''''''''''''''''''
Sub DestroyTree(tree As node Ptr)
    If tree = 0 Then
        Exit Sub
    Endif
    DestroyTree(tree->Left_)
    If tree->RightDirection = DOWN  Then
        DestroyTree(tree->Right_)
    Endif
    Deallocate(tree)
End Sub

''''''''''''''''''''/
Function InsertItem(data_ As Integer) As Integer
    Dim As Node Ptr nw,p
    nw = Callocate(Sizeof(Node))
    If nw = 0 Then Return -1
    nw->Data_ = data_
    If Root = 0 Then
        nw->RightDirection = DOWN
        Root = nw
        Return 0
    Endif
    p = Root
    Do
        If data_<=p->Data_ Then
            If p->Left_ = 0 Then
                p->Left_ = nw
                nw->Right_ = p
                nw->RightDirection = UP
                Return 0
            Endif
            p=p->Left_
        Else
            If p->Right_ = 0 Or p->RightDirection = UP Then
                nw->Right_ = p->Right_
                p->Right_ = nw
                p->RightDirection = DOWN
                Return 0
            Endif
            p = p->Right_
        Endif
    Loop
End Function


''''''''''''''''''''
Sub PrintTree() ' Use Threading to print the whole tree
    Dim As  Node Ptr p
    Dim Dir_ As Direction
    p = Root
    Dir_ = DOWN
    While p<>0
        If dir_ = DOWN Then
            If p->Left_ <> 0 Then
                p = p->Left_
                Continue While
            Elseif p->Left_ = 0 Then
                dir_ = UP
                Continue While
            Endif
            Dir_ = p->RightDirection
            p = p->Right_
        Else
            ? p->Data_,
            dir_ = p->RightDirection
            p = p->Right_           
        Endif
    Wend
End Sub

AVL дерево

Описание: данное дерево является разновидностью бинарного дерева. В реализацию алгоритма заложено самосбалансирование узлов дерева, то есть для каждой его вершины высота её двух поддеревьев различается не более чем на единицу. Такое дерево дает очень эффективный поиск значений, а так же вставку значений. Ссылка на страницу автора исходного кода.

'   AVL Tree 
'   Insertion Time :  Best:Theta(n*lg(n))  Worst:Theta(n*lg(n))  Avg:Theta(n*lg(n))
'   Search Time    :  Best:Theta(1)        Worst:Theta(n*lg(n))  Avg:Theta(n*lg(n))
'   Deletion Time  :  Best:Theta(n*lg(n))  Worst:Theta(n*lg(n))  Avg:Theta(n*lg(n))

#INCLUDE "crt.bi"


'''''''''''''''''''''''
Type Node 
    
    As Integer Data  
    
    As Integer HeightDiff           ' Height Between Left and Right Subtree
    
    As Node Ptr Left,Right      
    
End Type

''''''''''''''''''''''''''''''
Function maxmin( i1 As Integer , i2 As Integer) As Integer
    
    Return Iif(i1 > i2, i1,i2)
    
End Function


'''''''''''''''''''
' Rotates around the current node 
Function LeftRotate(node As Node Ptr) As Integer  ' =1 if rotate works,=0 otherwise 
    
    Dim As Node Ptr nd
    Dim As Integer data_  , midheight , leftheight
    
    If node = 0 ORELSE node->Right = 0 Then Return 0    ' No Right Node!!

    nd = node->Right

    midheight = nd->HeightDiff
    
    leftheight = maxmin(nd->HeightDiff,0)+1+node->HeightDiff

    node->Right = nd->Right  ' Move Node
    
    nd->Right = nd->Left
    
    nd->Left = node->Left
    
    node->Left = nd

    data_ = node->Data
    
    node->Data = nd->Data
    
    nd->Data = Data_

    node->Left->HeightDiff = leftheight-midheight
    
    node->HeightDiff = 1 + maxmin(leftheight,midheight)

    Return 1
    
End Function


''''''''''''''''''/
' Rotate around current node
Function RightRotate(node As Node Ptr) As Integer ' =1 if rotate works, =0 otherwise
    
    Dim As Node Ptr nd
    Dim As Integer data_ , leftheight,rightheight
    
    If node = 0 ORELSE node->Left = 0 Then Return 0 

    nd = node->Left

    leftheight = nd->HeightDiff
    
    rightheight = maxmin(leftheight,0)+1-node->HeightDiff

    node->Left = nd->Left
    
    nd->Left = nd->Right
    
     nd->Right = node->Right
     
    node->Right = nd

    data_ = node->Data
    
     node->Data = nd->Data
     
      nd->Data = Data_

    node->Right->HeightDiff = 0 - rightheight
    
    node->HeightDiff = leftheight-(1 + maxmin(0,rightheight))
    
    Return 1
    
End Function



''''''''''''''''''/
Enum avlenum
    
    DONTADJUST
    
    ADJUST 
    
End Enum

Function InsertValue( root As Node Ptr Ptr , value As Integer) As avlenum ' =1 on success, =0 on fail

    If (*root) = 0 Then 
            
            Dim As Node Ptr nw
            
            nw = malloc(Sizeof( Node ))
            
            If nw = 0 Then Return DONTADJUST
            
            nw->Left = 0
            
            nw->Right = 0
            
            nw->Data = value
            
            nw->HeightDiff = 0
            
            (*root) = nw
            
            Return ADJUST
    
    Endif

    If value < (*root)->Data Then
        
        If InsertValue(@(*root)->Left,value) = DONTADJUST Then Return DONTADJUST

        '''''/ Increase Balance '''''''''/
        (*root)->HeightDiff += 1

        '''''' Tree has become Balanced ''''''''
        If (*root)->HeightDiff = 0 Then Return DONTADJUST

        '''''' Check For Rotation ''''''''''/
        If (*root)->HeightDiff = +2 Then ' Rotate + Stop

            ' Check if in Homogenous Config.
            If (*root)->Left->HeightDiff = +1 Then ' Homogenous. Conf.
                
                RightRotate(*root)
                
                Return DONTADJUST
                
            Endif
            '  Hetrogenous Conf
            LeftRotate((*root)->Left)
            
            RightRotate(*root)
            
            Return DONTADJUST
            
        Endif

        '''''/ Keep Going up the tree '''''''/
        Return ADJUST
        
    Elseif value > ((*root)->Data)  Then
        
        If InsertValue(@(*root)->Right,value) = DONTADJUST Then Return DONTADJUST

        '''''/ Decrease Balance '''''''''/
        (*root)->HeightDiff -= 1

        '''''' Tree has become Balanced ''''''''
        If (*root)->HeightDiff = 0 Then Return DONTADJUST

        '''''' Check For Rotation ''''''''''/
        If (*root)->HeightDiff = -2 Then ' Rotate + Stop
            
            ' Check if in Homogenous Config.
            If (*root)->Right->HeightDiff = -1 Then ' Homogenous. Conf.
            
                LeftRotate(*root)
                
                Return DONTADJUST
                
            Endif
            '  Hetrogenous Conf
            RightRotate((*root)->Right)
            
            LeftRotate(*root)
            
            Return DONTADJUST
        Endif

        '''''/ Keep Going up the tree '''''''/
        Return ADJUST
        
    Else
    
        printf(!"Item (%d) already exists in tree\n",value)
        
        Return DONTADJUST
        
    Endif
End Function


''''''''''''''''''''
Sub PrintTree(root As Node Ptr)
 
 ' Perform Inorder Traversal of tree
    If root = 0 Then Exit Sub
    
    PrintTree(root->Left)
    
    printf(!" %d(%d) ",root->Data,root->HeightDiff)
    
    PrintTree(root->Right)
    
End Sub


''''''''''''''''''''
Sub DeleteTree(root As Node Ptr)
    
    If root = 0 Then Exit Sub
    
    DeleteTree(root->Left)
    
    DeleteTree(root->Right)
    
    free(root)
    
End Sub


''''''''''''''''''''
Function Height(root As Node Ptr) As Integer

    If root = 0 Then Return 0
    
    Return 1 + maxmin(Height(root->Left),Height(root->Right))
    
End Function


''''''''' Check if Tree is an AVL Tree''''''''''/
Function DoubleCheck(root As Node Ptr) As Integer ' =0 if Check Fails,=1 if OK
    
    If root = 0 Then Return 1

    If DoubleCheck(root->Left) = 0 orelse DoubleCheck(root->Right) = 0 Then Return 0

    ' Check if Tree Is OK
    If Height(root->Left)-Height(root->Right) <> root->HeightDiff Then Return 0

    If root->HeightDiff < -1 orelse root->HeightDiff > +1 Then Return 0

    Return 1

End Function


''''''''''''''''''''''''''''''''
Function Count(root As Node Ptr) As Integer ' = return total count of nodes in tree

    If root = 0 Then Return 0
    
    Return 1+Count(root->Left)+Count(root->Right)

End Function


'''''''''''''''''''''''''''''''/
Function PrintStatus(root As Node Ptr) As Integer  ' =1 if Ok,=0 if not AVL tree
    
    printf(!"Status: Count: %d  ",Count(root))

    If DoubleCheck(root) = 0 Then
        
        printf(!"Tree is not an AVL Tree\n")
        
        Return 0
        
    Else
    
        printf(!"Tree is an AVL Tree\n")
        
        Return 1
        
    Endif

End Function

'''''''''''''''''''
Dim As Node Ptr root = 0

Dim As Integer i

    Randomize Timer 
    
    '''''/ Insert Some Values Into Tree ''''''''
    For i = 0 To 1000
        
        InsertValue(@root,Rnd*200) 
        
        If PrintStatus(root) = 0 Then Beep : End
        
    Next
    
    printf(!"Tree: ")
    
    PrintTree(root)
    
    printf(!"\n")

    DeleteTree(root)
    
    Sleep

Еще один пример (взят отсюда), но в нем реализовано больше методов (поиск, удаление и др.):

#INCLUDE "crt.bi"

Type node
      As Integer element
      As node Ptr Left
      As node Ptr Right
      As Integer height
End Type

Type bstree extends Object
      Declare Sub insert(As Integer,Byref As node Ptr)
      Declare Sub del(As Integer, Byref As node Ptr)
      Declare Function deletemin(Byref As node Ptr)As Integer
      Declare Sub find(As Integer,Byref As node Ptr)
      Declare Function findmin(Byref As node Ptr)As node Ptr
      Declare Function findmax(Byref As node Ptr)As node Ptr
      Declare Sub makeempty(Byref As node Ptr)
      Declare Sub copy(Byref As node Ptr,Byref As node Ptr)
      Declare Function nodecopy(Byref As node Ptr)As node Ptr
      Declare Sub preorder(As node Ptr)
      Declare Sub inorder(As node Ptr)
      Declare Sub postorder(As node Ptr)
      Declare Function bsheight(As node Ptr)As Integer
      Declare Function srl(Byref As node Ptr)As node Ptr
      Declare Function drl(Byref As node Ptr)As node Ptr
      Declare Function srr(Byref As node Ptr)As node Ptr
      Declare Function drr(Byref As node Ptr)As node Ptr
      Declare Function max(As Integer,As Integer)As Integer
      Declare Function nonodes(As node Ptr)As Integer
End Type

' Inserting a node
Sub bstree.insert(x As Integer,Byref p As node Ptr)
      If (p = NULL) Then
          p = New node
          p->element = x
          p->left=NULL
          p->Right = NULL
          p->height=0
          If (p=NULL) Then
              printf (!"Out of Space\n")
          Endif
      Else
          If (x<p->element) Then
              insert(x,p->Left)
              If ((bsheight(p->Left) - bsheight(p->Right))=2) Then
                  If (x < p->left->element) Then
                      p=srl(p)
                  Else
                      p = drl(p)
                  Endif
              Endif
          Elseif (x>p->element) Then
              insert(x,p->Right)
              If ((bsheight(p->Right) - bsheight(p->Left))=2) Then
                  If (x > p->right->element) Then
                      p=srr(p)
                  Else
                      p = drr(p)
                  Endif
              Endif
          Else
              printf(!"Элемет существует\n")
          Endif
      Endif
      Dim As Integer m,n,d
      m=bsheight(p->Left)
      n=bsheight(p->Right)
      d=max(m,n)
      p->height = d + 1
End Sub

' Finding the Smallest
Function bstree.findmin(Byref p As node Ptr) As node Ptr
      If (p=NULL) Then
          printf(!"В дереве нет элементов\n")
          Return p
      Else
          Dim pp As  node Ptr = p
          While (pp->Left<>NULL)
              pp=pp->Left
              'return p;
          Wend
          Return pp
      Endif
End Function

' Finding the Largest node
Function bstree.findmax(Byref  p As node Ptr) As node Ptr
      If (p=NULL) Then
          printf(!"В дереве нет элементов\n")
          Return p
      Else
          Dim pp As  node Ptr = p
          While(pp->Right <>NULL)
              pp=pp->Right
              'return p;
          Wend
          Return pp
      Endif
End Function

' Finding an element
Sub bstree.find(x As Integer,Byref p As node Ptr )
      If (p=NULL) Then
          printf(!"Простите, но такого элемента нет\n")
      Else
          If (x < p->element) Then
              find(x,p->Left)
          Else
              If (x>p->element) Then
                  find(x,p->Right)
              Else
                  printf(!"Элемент, который вы искали есть в дереве!\n")
              Endif
          Endif
      Endif
End Sub

' Copy a tree
Sub bstree.copy(Byref p As node Ptr,Byref p1 As node Ptr)
      makeempty(p1)
      p1 = nodecopy(p)
End Sub

' Make a tree empty
Sub bstree.makeempty(Byref p As node Ptr)
      If (p <> NULL) Then
          makeempty(p->Left)
          makeempty(p->Right)
          Delete p
          p=NULL
      Endif
End Sub

' Copy the nodes
Function bstree.nodecopy(Byref p As node Ptr) As node Ptr
      Dim As node Ptr temp
      If (p=NULL) Then
          Return p
      Else
          temp = New node
          temp->element = p->element
          temp->Left = nodecopy(p->Left)
          temp->Right = nodecopy(p->Right)
          Return temp
      Endif
End Function

' Deleting a node
Sub bstree.del(x As Integer ,Byref p As node Ptr)
      If (p=NULL) Then
          printf(!"Простите, но такого элемента нет\n")
      Elseif ( x < p->element) Then
          del(x,p->Left)
      Elseif (x > p->element) Then
          del(x,p->Right)
      Elseif ((p->Left = NULL) And (p->Right = NULL)) Then
          Delete p
          p=NULL
          printf(!"Элемент удален\n")
      Elseif (p->Left = NULL) Then
          p=p->Right
          Delete p
          p=NULL
          printf(!"Элемент удален\n")
      Elseif (p->Right = NULL) Then
          p=p->Left
          Delete p
          p=NULL
          printf(!"Элемент удален\n")
      Else
          p->element = deletemin(p->Right)
      Endif
End Sub

Function bstree.deletemin(Byref p As node Ptr)As Integer
      Dim As Integer c
      printf(!"Выбрано удаление минимального значения\n")
      If (p->Left = NULL) Then
          c=p->element
          p=p->Right
          Return c
      Else
          c=deletemin(p->Left)
          Return c
      Endif
End Function

Sub bstree.preorder(p As node Ptr)
      If (p<>NULL) Then
          Printf(p->element & !"\t")
          preorder(p->Left)
          preorder(p->Right)
      Endif
End Sub

' Inorder Printing
Sub bstree.inorder(p As node Ptr)
      If (p<>NULL) Then
          inorder(p->Left)
          Printf(p->element & !"\t")
          inorder(p->Right)
      Endif
End Sub

'PostOrder Printing
Sub bstree.postorder(p As node Ptr)
      If (p<>NULL) Then
          postorder(p->Left)
          postorder(p->Right)
          Printf(p->element & !"\t")
      Endif
End Sub

Function bstree.max(value1 As Integer, value2 As Integer) As Integer
      Return Iif(value1 > value2 , value1 , value2)
End Function

Function bstree.bsheight(p As node Ptr) As Integer
      Dim As Integer t
      If (p = NULL) Then
          Return -1
      Else
          t = p->height
          Return t
      Endif
End Function

Function bstree.srl(Byref p1 As node Ptr ) As node Ptr
      Dim As node Ptr p2
      p2 = p1->Left
      p1->Left = p2->Right
      p2->Right = p1
      p1->height = max(bsheight(p1->Left),bsheight(p1->Right)) + 1
      p2->height = max(bsheight(p2->Left),p1->height) + 1
      Return p2
End Function

Function  bstree.srr(Byref p1 As node Ptr) As node Ptr
      Dim As node Ptr p2
      p2 = p1->Right
      p1->Right = p2->Left
      p2->Left = p1
      p1->height = max(bsheight(p1->Left),bsheight(p1->Right)) + 1
      p2->height = max(p1->height,bsheight(p2->Right)) + 1
      Return p2
End Function

Function bstree.drl(Byref p1 As node Ptr) As node Ptr
      p1->left=srr(p1->Left)
      Return srl(p1)
End Function

Function bstree.drr(Byref p1 As node Ptr)As node Ptr
      p1->Right = srl(p1->Right)
      Return srr(p1)
End Function

Function bstree.nonodes(p As node Ptr) As Integer
      Dim As Integer count
      If (p<>NULL) Then
          nonodes(p->Left)
          nonodes(p->Right)
          count+=1
      Endif
      Return count
End Function

'clrscr();
Dim As node Ptr root,root1,min,max ',flag;
Dim As Integer a,choice,findele,delele_
Dim As bstree bst
'system("clear");
root = NULL
root1=NULL
Printf(!"\n\t\t\t\tАВЛ Дерево\n")
Printf(!"\t\t\t\t:::::::::::::::::::\n")

Do
      Printf(!"\t\t::::::::::::::::::::::::::::::::::::::::::::::::\n")
      Printf(!"\t\t::::1 Вставить новый узел::::::::::::::::\n")
      Printf(!"\t\t::::2 Найти минимальный элемент:::::::::::\n")
      Printf(!"\t\t::::3 Найти максимальный элемент:::::::::::::::\n")
      Printf(!"\t\t::::4 Поиск по значению:::::::::::::::::::\n")
      Printf(!"\t\t::::5 Удалить элемент:::::::::::::::::::\n")
      Printf(!"\t\t::::6 Вариант обхода1:::::::::::::::::\n")
      Printf(!"\t\t::::7 Вариант обхода2::::::::::::::::::\n")
      Printf(!"\t\t::::8 Вариант обхода3::::::::::::::::\n")
      Printf(!"\t\t::::9 Показать высоту дерева:::\n")
      Printf(!"\t\t::::10 Выход:::::::::::::::::::::::::::::\n")
      Printf(!"\t\t::::::::::::::::::::::::::::::::::::::::::::::::\n")

      Printf(!"\nВыберите нужное действие и нажмите Enter: ")
      Input "",choice

      Select Case choice
          Case 1
              Printf(!"\n\t\tДобавление нового узла")
              Printf(!"\t\t:::::::::::::\n")
              Printf(!"Введите элемент: ")
              Input "" ,a
              bst.insert(a,root)
              Printf(!"\nНовый элемент добавлен успешно\n")
          Case 2
              If (root <>NULL) Then
                  min=bst.findmin(root)
                  Printf(!"\nМинимальный элемент в дереве: " & min->element)
              Endif
          Case 3
              If (root <>NULL) Then
                  max=bst.findmax(root)
                  Printf(!"\nМаксимальный элемент в дереве: " & max->element)
              Endif
          Case 4
              Printf(!"\nВведите искомый элемент: ")
              Input "",findele
              If (root <> NULL) Then
                  bst.find(findele,root)
              Endif
          Case 5
              Printf(!"\nКакой узел удалять? : ")
              Input "", delele_
              bst.del(delele_,root)
              bst.inorder(root)
              Print
          Case 6
              Printf(!"\n\t\tВариант обхода1\n")
              bst.preorder(root)
              Print
          Case 7
              Printf(!"\n\t\tВариант обхода2\n")
              bst.inorder(root)
              Print
          Case 8
              Printf(!"\n\t\tВарант обхода3\n")
              bst.postorder(root)
              Print
          Case 9
              Printf(!"\n\t\tВЫСОТА\n")
              Printf(!"Дерево имеет высоту: " & bst.bsheight(root))
          Case 10
              Printf(!"\n\tБлагодарим вас за использование програмы\n")
          Case Else
              Printf(!"Sorry! wrong input\n")
      End Select
      Sleep
      Cls
Loop While(choice <> 10)

Красно - черное дерево

Описание: это дерево как и AVL является разновидностью бинарного. Для многих программистов данный алгоритм является более предпочтительным при хранении данных , для которых нужна сортировка и быстрый поиск. Стандартная библиотека С++ STL (map , set и пр.) построена именно на основе красно-черных деревьев. По большому счету, пример ниже уже можно использовать как словарь или множество. Я тестировал на больших объемах данных, скорость вставки и поиска очень высока. Ссылка на страницу автора исходного кода

'/* red-black tree */

#INCLUDE "crt.bi"


Type T As Integer                 ' /* type of item to be stored */


'/* Red-Black tree description */
Enum nodeColor
    BLACK
    RED
End Enum

Type Node_
    As Node_  Ptr Left         '/* left child */
    As Node_  Ptr Right        '/* right child */
    As Node_ Ptr parent       '/* parent */
    As nodeColor Color            '/* node color (BLACK, RED) */
    As T Data                    '/* data stored in node */
End Type

Type  Node As Node_

#DEFINE NIL @sentinel           '/* all leafs are sentinels */
Dim Shared As Node sentinel = Type( NIL, NIL, 0, BLACK, 0)

Dim Shared As Node Ptr root = NIL               '/* root of Red-Black tree */

Sub rotateLeft(x As Node Ptr)

    '/**************************
    ' *  rotate node x to left *
    ' **************************/

    Dim As Node Ptr y = x->Right

    '/* establish x->right link */
    x->Right = y->Left
    If (y->Left <> NIL) Then y->Left->parent = x

    '/* establish y->parent link */
    If (y <> NIL) Then y->parent = x->parent

    If (x->parent) Then
        If (x = x->parent->Left) Then
            x->parent->Left = y
        Else
            x->parent->Right = y
        Endif
    Else
        root = y
    Endif

    '/* link x and y */
    y->Left = x
    If (x <> NIL) Then x->parent = y
End Sub

Sub rotateRight(x As Node Ptr)

    '/****************************
    ' *  rotate node x to right  *
    ' ****************************/

    Dim As Node Ptr y = x->Left

    '/* establish x->left link */
    x->Left = y->Right
    If (y->Right <> NIL) Then y->Right->parent = x

    '/* establish y->parent link */
    If (y <> NIL) Then y->parent = x->parent

    If (x->parent) Then

        If (x = x->parent->Right) Then

            x->parent->Right = y

        Else

            x->parent->Left = y

        Endif

    Else
        root = y
    Endif

    '/* link x and y */
    y->Right = x
    If (x <> NIL) Then x->parent = y
End Sub

Sub insertFixup(x As Node Ptr)

    '/*************************************
    ' *  maintain Red-Black tree balance  *
    ' *  after inserting node x           *
    ' *************************************/

    '/* check Red-Black properties */


    While x <> root AndAlso x->parent->Color = RED
        '/* we have a violation */

        If (x->parent = x->parent->parent->Left) Then
            Dim As Node Ptr 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
                    rotateLeft(x)
                Endif

                '/* recolor and rotate */
                x->parent->Color = BLACK
                x->parent->parent->Color = RED
                rotateRight(x->parent->parent)
            Endif
        Else

            '/* mirror image of above code */
            Dim As Node Ptr 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
                    rotateRight(x)
                Endif
                x->parent->Color = BLACK
                x->parent->parent->Color = RED
                rotateLeft(x->parent->parent)
            Endif
        Endif
    Wend

    root->Color = BLACK
End Sub

Function insertNode(data_ As T) As Node Ptr
    Dim As Node Ptr current, parent, x

    '/***********************************************
    ' *  allocate node for data and insert in tree  *
    ' ***********************************************/

    ' /* find where node belongs */
    current = root

    parent = 0

    While (current <> NIL)
        If data_ = current->Data  Then Return current
        parent = current
        current = Iif (data_ < current->Data , current->Left , current->Right)
    Wend

    '/* setup new node */
    x = malloc (Sizeof(Node))
    If x = 0 Then
        printf (!"insufficient memory (insertNode)\n")
        Sleep
        End
    Endif

    x->Data = data_
    x->parent = parent
    x->Left = NIL
    x->Right = NIL
    x->Color = RED

    '/* insert node in tree */
    If(parent) Then
        If data_ < parent->Data  Then
            parent->Left = x
        Else
            parent->Right = x
        Endif
    Else
        root = x
    Endif

    insertFixup(x)

    Return x
End Function

Sub deleteFixup( x As Node Ptr)

    '/*************************************
    ' *  maintain Red-Black tree balance  *
    ' *  after deleting node x            *
    ' *************************************/

    While x <> root AndAlso x->Color = BLACK
        If x = x->parent->Left Then
            Dim As Node Ptr w = x->parent->Right
            If (w->Color = RED) Then
                w->Color = BLACK
                x->parent->Color = RED
                rotateLeft (x->parent)
                w = x->parent->Right
            Endif
            If (w->Left->Color = BLACK AndAlso 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
                    rotateRight (w)
                    w = x->parent->Right
                Endif
                w->Color = x->parent->Color
                x->parent->Color = BLACK
                w->Right->Color = BLACK
                rotateLeft (x->parent)
                x = root
            Endif
        Else
            Dim As Node Ptr w = x->parent->Left
            If (w->Color = RED) Then
                w->Color = BLACK
                x->parent->Color = RED
                rotateRight (x->parent)
                w = x->parent->Left
            Endif
            If (w->Right->Color = BLACK Andalso 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
                    rotateLeft (w)
                    w = x->parent->Left
                Endif
                w->Color = x->parent->Color
                x->parent->Color = BLACK
                w->Left->Color = BLACK
                rotateRight (x->parent)
                x = root
            Endif
        Endif
    Wend
    x->Color = BLACK
End Sub

Sub deleteNode(z As Node Ptr)
    Dim As Node Ptr x, y

    '/*****************************
    ' *  delete node z from tree  *
    ' *****************************/

    If (z = 0 Or z = NIL) Then Exit Sub


    If (z->Left = NIL OrElse z->Right = NIL) Then
        '/* y has a NIL node as a child */
        y = z
    Else
        '/* find tree successor with a NIL node as a child */
        y = z->Right
        While (y->Left <> NIL)
            y = y->Left
        Wend
    Endif

    '/* x is y's only child */
    If (y->Left <> NIL) Then
        x = y->Left
    Else
        x = y->Right
    Endif

    '/* 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
        Endif
    Else
        root = x
    Endif

    If (y <> z) Then z->Data = y->Data


    If (y->Color = BLACK) Then deleteFixup (x)

    free (y)
End Sub

Function findNode(data_ As T) As Node Ptr

    '/*******************************
    ' *  find node containing data  *
    ' *******************************/

    Dim As Node Ptr current = root
    While(current <> NIL)
        If data_ = current->Data Then
            Return (current)
        Else
            current = Iif (data_ < current->Data , current->Left , current->Right)
        Endif
    Wend
    Return 0
End Function


Sub PrintTree(Tree As Node Ptr )
    '/*******************************
    ' *  Print all Tree                   *
    ' *******************************/

    If Tree <> NIL Then


        PrintTree(Tree->Left)
        Print Tree->Data,
        PrintTree(Tree->Right)


    Endif
End Sub

Sub DeleteTree(Tree As Node Ptr)
    '/*******************************
    ' *  Delete all Tree              *
    ' *******************************/
    If tree <> NIL Then
        DeleteTree(Tree->Left)
        DeleteTree(Tree->Right)
        free(Tree)
    Endif
End Sub

Dim As Integer a, maxnum, ct
Dim As  Node Ptr t_

maxnum = 100

For ct = 1 To maxnum
    a = ct
    t_ = findNode(a)

    If t_ <> NULL Then
        'deleteNode(t_)
    Else
        insertNode(a)
    Endif
Next

Var t = Timer
Dim As Node Ptr nP =  findNode(9)
? nP
If nP <> 0 Then ? nP->Data

? Timer -t

PrintTree(root)
DeleteTree(root)

Sleep

FreeBasic

Структуры данных (стеки, очереди, деревья...)