HeapSort - A compact routine that sorts data in place

' HeapSort.  A compact routine that sorts data in place (no extra memory needed)
'  and is guaranteed to run in O(N log N) time no matter how the input data is 
' arranged.  On the down side, it's slower than other N log N sorts (Quick and 
' Merge) and not stable (does not preserve the original order of records with 
' equal keys)  Works by organizing records into a "heap" data structure where 
' each node is larger than its two leaves, and then repeatedly selecting the 
' largest key from the root of the heap.  Two versions are given.  pHeapSortS 
' is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' HeapSortL is a direct version for longs, which can be adapted to integers.
'
' Speed:  pHeapSortS sorts 500,000 random strings in 88 sec; sorts 100186 
' library call numbers in 16.2 sec; sorts 25479 dictionary words in 3.3 sec 
' (random order), 3.4 sec (presorted) or 3.2 sec (reverse sorted).  HeapSortL 
' sorts 500,000 random longs in 92 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  compact, adapts to any date type and guarantees N log N sorting 
' times, but not the fastest and not stable.

' Usage:  

Dim S1(L To R) As String
Dim P1(L To R) As Long
Dim L1(L To R) As Long
 
For I = L To R
    S1(I) = GetRandomString()
    P1(I) = I
    L1(I) = GetRandomLong()
Next I

pHeapSortS L, R, S1, P1
HeapSortL L, R, L1

' CODE:

Sub pHeapSortS(L As Long, R As Long, A() As String, P() As Long)
    Dim Node As Long
    Dim Last As Long
    Dim TMP As Long
    
    'build heap
    For Node = (R + L) \ 2 To L Step -1
        pHeapS Node, L, R, A, P
    Next Node

    'repeatedly select item at root of heap
    For Last = R To L + 1 Step -1
        'swap root item to final position
        TMP = P(L)
        P(L) = P(Last)
        P(Last) = TMP
        'get swapped item into right place in heap
        pHeapS L, L, Last - 1, A, P
    Next Last
End Sub

Sub pHeapS(ByVal Node As Long, L As Long, R As Long, A() As String, P() As Long)
    Dim LEAF As Long
    Dim TMP As Long

    Do
        LEAF = Node + Node - (L - 1)
        If LEAF > R Then Exit Sub
        'pick the larger leaf
        If LEAF < R Then If A(P(LEAF + 1)) > A(P(LEAF)) Then LEAF = LEAF + 1
        'if node > leaves, we're done
        If A(P(Node)) > A(P(LEAF)) Then Exit Sub
        'if not, swap larger leaf with node
        TMP = P(Node)
        P(Node) = P(LEAF)
        P(LEAF) = TMP
        'and move further into the heap
        Node = LEAF
    Loop
End Sub

Sub HeapSortL(L As Long, R As Long, A() As Long)
    Dim Node As Long
    Dim Last As Long
    Dim TMP AS Long
    
    For Node = (R + L) \ 2 To L Step -1
        HeapL Node, L, R, A
    Next Node
    For Last = R To L + 1 Step -1
    TMP = A(L)
    A(L) = A(Last)
    A(Last) = TMP
        HeapL L, L, Last - 1, A
    Next Last
End Sub

Sub HeapL(ByVal Node As Long, L As Long, R As Long, A() As Long)
    Dim LEAF As Long
    Dim TMP AS Long

    Do
        LEAF = Node + Node - (L - 1)
        If LEAF > R Then Exit Sub
        If LEAF < R Then If A(LEAF + 1) > A(LEAF) Then LEAF = LEAF + 1
        If A(Node) > A(LEAF) Then Exit Sub
        TMP = A(Node)
    A(Node) = A(LEAF)
    A(LEAF) = TMP
        Node = LEAF
    Loop
End Sub