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