Binaryworld - HeapSort - A compact routine that sorts data in place ... [ VB -> Datastructure ]

' 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