Сортировка бинарным деревом - VBA

Формулировка задачи:

Подсмотрел я тут методы и подумал - а почему бы не написать на VBA сорировку методом бинарного дерева? Общий алгоритм сортировки был на википедии, так что оставалось всего лишь написать код. В ходе кровь из носу потребовалось ознакомиться с такой штукой как классы, о которой я ранее не имел ни малейшего представления. По итогам длительных мучений: сортировать этот зверь, конечно, сортирует, но уже на 100k чисел типа Double у него уходит немалое время (порядка нескольких секунд на моем не самом резвом рабочем компьютере). К тому же в коде есть ряд шероховатостей - 1) метод Retrieve, получающий значения из уже сформированного дерева, как я с ним не бился, оставляет пустую строчку в начале или в конце массива. Работать со счетчиками он при этом решительно отказывается, так что пришлось плюнуть и просто после его отработки делать еще один Redim Preserve 2) тот же многострадальный метод Retrieve работает с внешней переменной, получаемой ByRef. В нее он записывает значения, что, насколько я знаю, не очень хорошо. Возможно, есть еще какие-то ошибки, которые я не заметил. Просьба к уважаемым форумчанам покритиковать решение. Здесь привожу код самого класса и процедур, с ним работающих.

Option Explicit
 
Private oLeft As cTree
Private oRight As cTree
Private dKey As Double
 
'---------------
'Г‘ГўГ®Г©Г±ГІГўГ® Left
'---------------
Public Property Get LeftTree() As cTree
   Set LeftTree = oLeft
End Property
 
Public Property Let LeftTree(Value As cTree)
   Set oLeft = Value
End Property
 
'---------------
'Г‘ГўГ®Г©Г±ГІГўГ® Right
'---------------
Public Property Get RightTree() As cTree
   Set RightTree = oRight
End Property
 
Public Property Let RightTree(Value As cTree)
   Set oRight = Value
End Property
 
'---------------
'Г‘ГўГ®Г©Г±ГІГўГ® Key
'---------------
Public Property Get Key() As Double
   Key = dKey
End Property
 
Public Property Let Key(Value As Double)
   dKey = Value
End Property
 
'---------------
'ГЊГҐГІГ®Г¤ ГўГ±ГІГ*ГўГЄГЁ Г*Г®ГўГ®Г© ГўГҐГІГЄГЁ Г¤ГҐГ°ГҐГўГ*
'---------------
Public Sub Insert(Tree As cTree)
   Dim oBranch As cTree
   
   'ГЏГ°Г®ГўГҐГ°ГїГҐГ¬ ГЄГіГ¤Г* Г*Г*Г¤Г® ГўГ±ГІГ*ГўГЁГІГј ГўГҐГІГЄГі - ГҐГ±Г«ГЁ ГЄГ«ГѕГ· ГІГҐГЄГіГ№ГҐГ© ГЎГ®Г«ГјГёГҐ ГЄГ«ГѕГ·Г* Г*Г®ГўГ®Г©, ГІГ® ГўГ±ГІГ*ГўГ«ГїГҐГ¬ Г±Г«ГҐГўГ*,
   'ГЁГ*Г*Г·ГҐ - Г±ГЇГ°Г*ГўГ*
   If Me.Key > Tree.Key Then
      'Г…Г±Г«ГЁ ГўГҐГІГЄГ* Г±Г«ГҐГўГ* Г±ГўГ®ГЎГ®Г¤Г*, ГІГ® ГўГ±ГІГ*ГўГ«ГїГҐГ¬ Г±Г°Г*Г§Гі, ГҐГ±Г«ГЁ Г§Г*Г*ГїГІГ* - Г± ГЇГ®Г¬Г®Г№ГјГѕ Г°ГҐГЄГіГ°Г±ГЁГЁ Г¤ГўГЁГЈГ*ГҐГ¬Г±Гї Г*Г* ГіГ°Г®ГўГҐГ*Гј Г*ГЁГ¦ГҐ,
      'ГЇГ®ГЄГ* Г*ГҐ Г*Г*Г©Г¤ГҐГ¬ Г±ГўГ®ГЎГ®Г¤Г*ГіГѕ
      If Me.LeftTree Is Nothing Then
         Me.LeftTree = Tree
      Else
         Me.LeftTree.Insert Tree
      End If
   Else
      'Г…Г±Г«ГЁ ГўГҐГІГЄГ* Г±ГЇГ°Г*ГўГ* Г±ГўГ®ГЎГ®Г¤Г*, ГІГ® ГўГ±ГІГ*ГўГ«ГїГҐГ¬ Г±Г°Г*Г§Гі, ГҐГ±Г«ГЁ Г§Г*Г*ГїГІГ* - Г± ГЇГ®Г¬Г®Г№ГјГѕ Г°ГҐГЄГіГ°Г±ГЁГЁ Г¤ГўГЁГЈГ*ГҐГ¬Г±Гї Г*Г* ГіГ°Г®ГўГҐГ*Гј Г*ГЁГ¦ГҐ,
      'ГЇГ®ГЄГ* Г*ГҐ Г*Г*Г©Г¤ГҐГ¬ Г±ГўГ®ГЎГ®Г¤Г*ГіГѕ
      If Me.RightTree Is Nothing Then
         Me.RightTree = Tree
      Else
         Me.RightTree.Insert Tree
      End If
   End If
End Sub
 
'---------------
'ГЊГҐГІГ®Г¤ ГЇГ®Г«ГіГ·ГҐГ*ГЁГї Г®ГІГ±Г®Г°ГІГЁГ°Г®ГўГ*Г*Г*Г®ГЈГ® Г¬Г*Г±Г±ГЁГўГ*
'---------------
Public Sub Retrieve(Arr() As Double)
   Dim oBranch As cTree
   
   'ГЇГҐГ°ГҐГµГ®Г¤ГЁГ¬ Г*Г* ГіГ°Г®ГўГҐГ*Гј Г*ГЁГ¦ГҐ ГЇГ® Г«ГҐГўГ®Г© ГўГҐГІГЄГҐ
   If Not Me.LeftTree Is Nothing Then
      Me.LeftTree.Retrieve Arr
   End If
   'ГЉГ®ГЈГ¤Г* Г*Г*Г«ГҐГўГ® Г¤ГўГЁГЈГ*ГІГјГ±Гї Г*ГҐГЄГіГ¤Г* - Г§Г*ГЇГЁГ±Г»ГўГ*ГҐГ¬ Г§Г*Г*Г·ГҐГ*ГЁГҐ Гў Г¬Г*Г±Г±ГЁГў Г±Г®Г°ГІГЁГ°Г®ГўГЄГЁ
   Arr(UBound(Arr)) = Me.Key
   ReDim Preserve Arr(UBound(Arr) + 1)
   'ГЏГҐГ°ГҐГµГ®Г¤ГЁГ¬ Г*Г* ГіГ°Г®ГўГҐГ*Гј Г*ГЁГ¦ГҐ ГЇГ® ГЇГ°Г*ГўГ®Г© ГўГҐГІГЄГҐ
   If Not Me.RightTree Is Nothing Then
      Me.RightTree.Retrieve Arr
   End If
End Sub

Option Explicit
 
'ГЏГ°Г®Г¶ГҐГ¤ГіГ°Г* Г±Г®Г§Г¤Г*Г*ГЁГї Г¤ГҐГ°ГҐГўГ* ГЁ Г±Г®Г°ГІГЁГ°Г®ГўГЄГЁ ГЇГ® Г*ГҐГ¬Гі
Function SortAsTree(Arr() As Double)
    Dim MainTree As cTree        'ГЉГ«Г*Г±Г± Г¶ГҐГ«Г®ГЈГ® Г¤ГҐГ°ГҐГўГ*
    Dim SubTree As cTree         'ГЉГ«Г*Г±Г± ГўГҐГІГЄГЁ Г¤ГҐГ°ГҐГўГ*
    Dim i As Long                'Г‘Г·ГҐГІГ·ГЁГЄ
    Dim dSorted() As Double      'ГЋГІГ±Г®Г°ГІГЁГ°Г®ГўГ*Г*Г*Г»Г© Г¬Г*Г±Г±ГЁГў
    
    Set MainTree = New cTree
    
    MainTree.Key = Arr(LBound(Arr))      'Г‡Г*Г¤Г*ГҐГ¬ ГЄГ«ГѕГ· "ГЄГ®Г°Г*Гї" Г¤ГҐГ°ГўГ*
    
    'ГђГ*Г±ГІГ*ГўГ«ГїГҐГ¬ "ГўГҐГІГўГЁ" Г¤ГҐГ°ГҐГўГ* ГЇГ® Г±ГІГ®Г°Г®Г*Г*Г¬ Г®ГІ "ГЄГ®Г°Г*Гї"
    For i = LBound(Arr) + 1 To UBound(Arr)
        Set SubTree = New cTree
        SubTree.Key = Arr(i)
        MainTree.Insert SubTree
    Next i
    
    'ГЏГ® ГЇГ®Г±ГІГ°Г®ГҐГ*Г*Г®Г¬Гі Г¤ГҐГ°ГҐГўГі Г®Г±ГіГ№ГҐГ±ГІГ«ГїГҐГ¬ Г±Г®Г°ГІГЁГ°Г®ГўГЄГі
    ReDim dSorted(0)
    MainTree.Retrieve dSorted
    'Г“ГЎГЁГ°Г*ГҐГ¬ ГЇГ®Г±Г«ГҐГ¤Г*ГѕГѕ Г±ГІГ°Г®ГЄГі Г®ГІГ±Г®Г°ГІГЁГ°Г®ГўГ*Г*Г*Г®ГЈГ® Г¬Г*Г±Г±ГЁГўГ*
    ReDim Preserve dSorted(UBound(dSorted) - 1)
    SortAsTree = dSorted
End Function
 
Sub test()
    Dim dStartArr() As Double
    Dim dEndArr() As Double
    Dim i As Long
    
    ReDim dStartArr(1 To 100000)
    
    'Г‡Г*ГЇГ®Г«Г*ГїГҐГ¬ Г¬Г*Г±Г±ГЁГў
    For i = 1 To 100000
        dStartArr(i) = Rnd
    Next
    
    'Г‘Г®Г°ГІГЁГ°ГіГҐГ¬ Г¬Г*Г±Г±ГЁГў
    dEndArr = SortAsTree(dStartArr())
End Sub

Решение задачи: «Сортировка бинарным деревом»

textual
                            Листинг программы 
                        

                             '::: Пирамидальная сортировка (Главная процедура)
 
Sub HeapSort(X() As Double)
Dim Heap() As Double
Dim N&
Dim HeapSize&
Dim I&
    N& = UBound(X, 1)
    
    ReDim Heap(1 To N) As Double
    
    '::: Занесение в пирамиду
    
    HeapSize& = 1
    Heap(1) = X(1)
    
    For ii& = 2 To N
        HeapSize& = HeapSize& + 1
        Heap(HeapSize&) = X(ii&)
        ptr& = HeapSize&
        pUp Heap(), ptr&
    Next ii&
    
    '::: Вывод отсортированного
    
    o& = N
    
    Do
       If HeapSize& = 0 Then Exit Do
       X(o&) = Heap(1)
       o& = o& - 1
       Swap Heap(1), Heap(HeapSize&)
       HeapSize& = HeapSize& - 1
       pDown Heap(), 1, HeapSize&
    Loop
 
End Sub
 
':::: Просеивание вверх
 
Sub pUp(Heap() As Double, p As Long)
    If p = 1 Then Exit Sub
    Par& = p \ 2
    If Heap(p) <= Heap(Par&) Then Exit Sub
    Swap Heap(p), Heap(Par&)
    pUp Heap(), Par&
End Sub
 
':::: Просеивание вниз
 
Sub pDown(Heap() As Double, p As Long, HeapSize As Long)
    If (2 * p) >= HeapSize Then Exit Sub
    ZL# = Heap(2 * p)
    ZR# = Heap(2 * p + 1)
    If (Heap(p) >= ZL#) And (Heap(p) >= ZR#) Then Exit Sub
    If (ZL# >= ZR#) Then
       Swap Heap(p), Heap(2 * p)
       pDown Heap(), 2 * p, HeapSize
    Else
       Swap Heap(p), Heap(2 * p + 1)
       pDown Heap(), 2 * p + 1, HeapSize
    End If
End Sub
 
':::: Обменять два элемента
 
Sub Swap(a As Double, B As Double)
    tmp# = a
    a = B
    B = tmp#
End Sub
 
':::: Стартовая процедура
 
Sub Test()
Dim I&, t!
Dim H(1 To 800000) As Double, Q(1 To 800000) As Double
 
For I = 1 To UBound(H)
  H(I) = Rnd
  Q(I) = H(I)
Next I
t = Timer
HeapSort H()
Debug.Print "HeapSort t="; Timer - t
 
t = Timer
QuickSort Q(), LBound(Q), UBound(Q)
Debug.Print "QuickSort t="; Timer - t
 
'и проверить решил на всякий случай
For I = 1 To UBound(H)
 If H(I) <> Q(I) Then Stop
Next I
 
End Sub
 
Sub QuickSort(a() As Double, ByVal L As Long, ByVal U As Long)
Dim I As Long, J As Long, X As Double, Y As Double
I = L: J = U: X = a((L + U) \ 2)
Do
  While a(I) < X: I = I + 1: Wend: While X < a(J): J = J - 1: Wend 'по возрастанию
'  While A(I) > X: I = I + 1: Wend: While X > A(J): J = J - 1: Wend 'по убыванию
  If I <= J Then
    Y = a(I): a(I) = a(J): a(J) = Y:    I = I + 1: J = J - 1
  End If
Loop Until I > J
If L < J Then QuickSort a, L, J
If I < U Then QuickSort a, I, U
End Sub
                        