Binaryworld - Ternary QuickSort - A modification of QuickSort ... [ VB -> Datastructure ]

' Ternary QuickSort. See the summary of QuickSort for background before
' reading this one. Ternary QuickSort (also called MultiKey QuickSort) differs
' from the original QuickSort by examining keys one byte at a time (like
' RadixSort), and by handling keys in three categories -- less than pivot,
' equal to pivot, and more than pivot -- instead of two. (Separate handling
' of equal keys is why this sort is stable while ordinary QuickSort is not.)
' As in QuickSort, the left and right sublists are processed recursively until
' they are short enough for InsertionSort. The equal-to-pivot sublist is also
' handled recursively, except that a pointer indicating the "depth" of the byte
' to be examined is advanced to the next position before the call. Since
' sublists handed off to InsertionSort consist of keys whose first bytes are
' identical up to DEPTH - 1, we use a special version of InsertionSort that
' compares keys only from DEPTH onward.
'
' Needs no extra arrays, but uses some stack space for recursion. In practice
' in VBA, I don't find this sort to be as fast as the original QuickSort,
' but results may differ in languages that offer faster access to bytes within
' strings. This algorithm is definitely oriented toward strings; see comments
' under MSD Radix Sort on possible adaptation to integers and longs.
'
' Reference: Jon Bentley and Robert Sedgewick, "Fast Algorithms for Sorting
' and Searching Strings", Proceedings of the 8th Annual ACM-SIAM Symposium on
' Discrete Algorithms, January 1997. See also http://www.cs.princeton.edu/~rs/
' strings/.
'
' Speed: TernaryQuickSort sorts 500,000 random strings in 39 sec; sorts 100186
' library call numbers in 14 sec; sorts 25479 dictionary words in 1.8 sec
' (random order), 1.9 sec (presorted) or 1.8 sec (reverse sorted). Timed in
' Excel 2001 on an 800 mhz PowerBook.
'
' Bottom line: a stable version of QuickSort good for strings,
' but not (at least in VBA) as fast as the original.

' Usage:

Dim S1(L To R) As Strings
Dim B1(1 To nChars) As Byte
Dim P1(L To R) As Long

For I = L To R
  S1(I) = GetRandomString()
Next I

StrsToBytes S1, L, R, B1, P1    'a routine that stores the strings in 0-
                  ' terminated byte
              'arrays with P1() holding pointers to the first
              ' byte of
              'each string

TernaryQuickSort L, R, B1, P1

' CODE:

Sub TernaryQuickSort(L As Long, R As Long, B() As Byte, P() As Long)
  TernQuick L, R, B, P, 0
End Sub

Sub TernQuick(L As Long, R As Long, B() As Byte, P() As Long, _
  ByVal DEPTH As Integer)
  Dim TMP As Long
  Dim I As Long
  Dim J As Long
  Dim pMED As Long
  Dim Pivot As Integer
  Dim OuterL As Long
  Dim InnerL As Long
  Dim InnerR As Long
  Dim OuterR As Long
  Dim DIF As Long
  Dim N As Long
  Dim SwapN As Long
  Dim NLO As Long
  Dim NHI As Long
  Dim NEQ As Long

  N = 1 + R - L
  'Short sublists will be handled by lower overhead InsertionSort.
  If N > 10 Then
  'Get a pivot value from the median of three or nine keys.
    pMED = BGetMed(B, P, L, N, DEPTH)
  'Swap the median into the leftmost position.
    TMP = P(L)
    P(L) = P(pMED)
    P(pMED) = TMP
  'Our pivot will be the byte value at DEPTH.
    Pivot = B(P(L) + DEPTH)
  'Set up two pointers on the left and two on the right.
    OuterL = L
    InnerL = OuterL
    OuterR = R
    InnerR = OuterR
    Do
    'Look for a lefthand key/pointer to swap.
      Do While InnerL <= InnerR
     'DIF is the key's byte minus the Pivot byte.
        DIF = B(P(InnerL) + DEPTH) - Pivot
     'If the key's byte is greater, we've found a pointer to swap to the
     ' right side.
        If DIF > 0 Then Exit Do
     'If our byte is equal to the Pivot byte, we swap it to the extreme
     ' left end.
        If DIF = 0 Then
          TMP = P(OuterL)
          P(OuterL) = P(InnerL)
          P(InnerL) = TMP
          OuterL = OuterL + 1
        End If
     'If our byte is less than Pivot, we just scan over it.
        InnerL = InnerL + 1
      Loop
    'Now look for a righthand key/pointer to swap.
      Do While InnerL <= InnerR
        DIF = B(P(InnerR) + DEPTH) - Pivot
     'If the key's byte is less, we've found a pointer to swap to the left
     ' side.
        If DIF < 0 Then Exit Do
     'If our byte is equal to the Pivot byte, we swap it to the extreme
     ' right end.
        If DIF = 0 Then
          TMP = P(OuterR)
          P(OuterR) = P(InnerR)
          P(InnerR) = TMP
          OuterR = OuterR - 1
        End If
        InnerR = InnerR - 1
      Loop
    'If the inner pointers have crossed, we're done.
      If InnerL > InnerR Then Exit Do
    'Otherwise, we do the left/right swap we just set up.
      TMP = P(InnerL)
      P(InnerL) = P(InnerR)
      P(InnerR) = TMP
      InnerL = InnerL + 1
      InnerR = InnerR - 1
    Loop
  'We've arranged pointers to equal bytes on the far left and right,
  ' pointers to lower bytes
  'on the inner left, and pointers to higher bytes on the inner right. Now
  ' we will swap the
  'equals to the center, between the lowers and the highers.
    NLO = InnerL - OuterL
    NHI = OuterR - InnerR
    NEQ = N - (NLO + NHI)
    If OuterL - L < NLO Then SwapN = OuterL - L Else SwapN = NLO
    I = L
    J = InnerL - SwapN
  'Move the lefthand equals to center.
    Do While SwapN > 0
      TMP = P(I)
      P(I) = P(J)
      P(J) = TMP
      I = I + 1
      J = J + 1
      SwapN = SwapN - 1
    Loop
    If R - OuterR < NHI Then SwapN = R - OuterR Else SwapN = NHI
    I = InnerL
    J = R + 1 - SwapN
  'Move the righthand equals to center.
    Do While SwapN > 0
      TMP = P(I)
      P(I) = P(J)
      P(J) = TMP
      I = I + 1
      J = J + 1
      SwapN = SwapN - 1
    Loop
  'If there are more bytes, we increment DEPTH and recurse on the equals.
    If B(P(L+NLO) + DEPTH) <> 0 Then TernQuick L+NLO, L+NLO+NEQ-1, B, P, _
      DEPTH+1
  'Now we recurse on the lowers and highers; we do the shorter sublist first
  ' to hold stack
  'depth to log N.
    If NLO < NHI Then
      TernQuick L, L + NLO - 1, B, P, DEPTH
      TernQuick L + NLO + NEQ, L + NLO + NEQ + NHI - 1, B, P, DEPTH
    Else
      TernQuick L + NLO + NEQ, L + NLO + NEQ + NHI - 1, B, P, DEPTH
      TernQuick L, L + NLO - 1, B, P, DEPTH
    End If
  Else
  'A special version of InsertionSort that compares keys starting at depth
  ' (since the
  'sublists we hand off to it will have identical prefixes.
    DeepInsertS B, P, L, N, DEPTH
  End If
End Sub

Function BGetMed(B() As Byte, P() As Long, L As Long, N As Long, _
  DEPTH As Integer) As Long
  Dim D As Long
  Dim PL As Long
  Dim PM As Long
  Dim PN As Long

    PL = L
    PN = L + N - 1
    PM = (PL + PN) \ 2
    If N > 30 Then
      D = N \ 8
      PL = BMed3(B, P, PL, PL + D, PL + 2 * D, DEPTH)
      PM = BMed3(B, P, PM - D, PM, PM + D, DEPTH)
      PL = BMed3(B, P, PN - 2 * D, PN - D, PN, DEPTH)
    End If
    BGetMed = BMed3(B, P, PL, PM, PN, DEPTH)
End Function

Function BMed3(B() As Byte, P() As Long, I As Long, J As Long, K As Long, _
  DEPTH As Integer) As Long
  Dim CI As Byte
  Dim CJ As Byte
  Dim CK As Byte

  CI = B(P(I) + DEPTH)
  CJ = B(P(J) + DEPTH)
  CK = B(P(K) + DEPTH)
  If (CI <= CJ And CJ <= CK) Or (CI >= CJ And CJ >= CK) Then
    BMed3 = J
  ElseIf (CJ <= CI And CI <= CK) Or (CJ >= CI And CI >= CK) Then
    BMed3 = I
  ElseIf (CI <= CK And CK <= CJ) Or (CI >= CK And CK >= CJ) Then
    BMed3 = K
  End If
End Function

Sub DeepInsertS(B() As Byte, P() As Long, L As Long, N As Long, D As Integer)
  Dim LP As Long
  Dim RP As Long
  Dim TMP As Long
  Dim I As Long
  Dim J As Long

  For RP = L + 1 To L + N - 1
    TMP = P(RP)
    For LP = RP To L + 1 Step -1
      I = TMP + D
      J = P(LP - 1) + D
      Do While B(I) = B(J)
        If B(I) = 0 Or B(J) = 0 Then Exit Do
        I = I + 1
        J = J + 1
      Loop
      If CInt(B(I)) - CInt(B(J)) < 0 Then P(LP) = P(LP - 1) Else Exit For
    Next LP
    P(LP) = TMP
  Next RP
End Sub

Sub Strs2Bytes(A() As String, L As Long, R As Long, B() As Byte, P() As Long)
  Dim I As Long
  Dim nPtrs As Long
  Dim nBytes As Long
  Dim DEPTH As Integer

  nBytes = 0
  nPtrs = 0
  For I = L To R
    nBytes = nBytes + Strings.Len(A(I)) + 1
    nPtrs = nPtrs + 1
  Next I
  ReDim B(1 To nBytes)
  ReDim P(1 To nPtrs)

  nPtrs = 1
  nBytes = 1
  For I = L To R
    P(nPtrs) = nBytes
    For DEPTH = 1 To Strings.Len(A(I))
      B(nBytes) = Asc(Strings.MID(A(I), DEPTH, 1))
      nBytes = nBytes + 1
    Next DEPTH
    B(nBytes) = 0
    nBytes = nBytes + 1
    nPtrs = nPtrs + 1
  Next I
End Sub