Binaryworld - ShuttleMergeSort - An improved MergeSort ... [ VB -> Datastructure ]

' 2/4/03. The previous version of ShuttleMergeSort failed on very short lists.
' The code below corrects the problem and eliminates a couple of unnecessary
' variables. Sorting times for one million random longs,
' double or strings are 67, 90 and 95 seconds (Excel 2001 / 800 mhz PowerBook /
' MacOS 10.2.3).

' 1/7/03. Here is a 20-25% faster version of MergeSort. The old version
' merged into an auxiliary array, and copied the result back to the primary
' array at the end of each pass. This version plans ahead for an even number
' of passes, and alternates direction each time, first merging to the auxiliary
' array and then back to the primary array. It also replaces recursive calls
' with an explicit stack, and calls to a separate InsertionSort with in-line
' code. Because of the back and forth merging,
' I call this version "ShuttleMergeSort".

' Another frequently proposed optimization for MergeSort is to set runs up in
' alternating directions (low to high, then high to low). This allows
' replacing separate boundary tests for LP and RP with a single test for LP
' crossing RP. I tried this, and it wasn't faster in practice. Probably the
' gain from fewer loop tests was offset by time spent in extra comparisons; in
' the simpler version, when one run is used up, the rest of the other run is
' copied to the output array with no further comparisons. Also,
' the run-alternating version was significantly slower on presorted inputs,
' which often occur in practice.

' QuickSort is still faster for strings (64 sec vs. 95),
' but MergeSort is faster for doubles (90 sec vs. 162) and longs (67 sec vs.
' 116). Given that MergeSort is stable and guaranteed NlogN,
' while QuickSort is unstable and always has an N^2 worst case,
' MergeSort is my choice for a single all-purpose sort.

' The first example below is a pointerized version for strings. It can be
' adapted to doubles by changing the declaration of A() and T. The second
' example is a direct version for longs that can be adapted to integers.

Sub pShuttleMergeSortS(LO As Long, HI As Long, A() As String, P() As Long, _
  Q() As Long)
  'LO and HI point to first and last keys; A() is the buffer of string keys.
  'P() and Q() are buffers of pointers to the keys in A()
  Dim Length As Double  'length of initial runs to be made by InsertionSort
  Dim nRuns As Long    'the number of runs at each stage
  Dim Stack() As Long    'bookkeeping stack for merge passes
  Dim I As Long
  Dim L As Long      'left limit
  Dim R As Long      'right limit
  Dim LP As Long      'left pointer
  Dim RP As Long      'right pointer
  Dim OP As Long      'other pointer
  Dim TMP As String
  Dim Forward As Boolean  'toggle for direction of alternate merge passes

  'Calculate how many merge passes will be needed.
  'Each back & forth pair of merges will convert 4N sublists into N.
  Length = 1 + HI - LO
  nRuns = 1
  While Length > 20
    Length = Length / 4
    nRuns = nRuns * 4
  Wend

  'Set up stack to keep track of sublists being merged.
  ReDim Stack(1 To nRuns)
  For I = 1 To nRuns - 1
    Stack(I) = LO + (Length * CDbl(I))
  Next I
  Stack(nRuns) = HI

  'Build short runs using low overhead InsertionSort.
  L = LO
  For I = 1 To nRuns
    R = Stack(I)
    For RP = L + 1 To R
      OP = P(RP)
      TMP = A(OP)
      For LP = RP To L + 1 Step -1
        If TMP < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
      Next LP
      P(LP) = OP
    Next RP
    L = R + 1
  Next I

  'Make back & forth passes of MergeSort until all runs are merged.
  Forward = True
  While nRuns > 1
    R = LO - 1
    If Forward Then
      'Half the passes are forward, merging from P() into Q().
      For I = 2 To nRuns Step 2
        LP = R + 1
        OP = LP
        L = Stack(I - 1)
        RP = L + 1
        R = Stack(I)
        Do
          If A(P(LP)) <= A(P(RP)) Then
            Q(OP) = P(LP)
            OP = OP + 1
            LP = LP + 1
            If LP > L Then
              Do
                Q(OP) = P(RP)
                OP = OP + 1
                RP = RP + 1
              Loop Until RP > R
              Exit Do
            End If
          Else
            Q(OP) = P(RP)
            OP = OP + 1
            RP = RP + 1
            If RP > R Then
              Do
                Q(OP) = P(LP)
                OP = OP + 1
                LP = LP + 1
              Loop Until LP > L
              Exit Do
            End If
          End If
        Loop
        Stack(I \ 2) = R
      Next I
    Else
    'Half the passes are backward, merging from Q() into P().
      For I = 2 To nRuns Step 2
        LP = R + 1
        OP = LP
        L = Stack(I - 1)
        RP = L + 1
        R = Stack(I)
        Do
          If A(Q(LP)) <= A(Q(RP)) Then
            P(OP) = Q(LP)
            OP = OP + 1
            LP = LP + 1
            If LP > L Then
              Do
                P(OP) = Q(RP)
                OP = OP + 1
                RP = RP + 1
              Loop Until RP > R
              Exit Do
            End If
          Else
            P(OP) = Q(RP)
            OP = OP + 1
            RP = RP + 1
            If RP > R Then
              Do
                P(OP) = Q(LP)
                OP = OP + 1
                LP = LP + 1
              Loop Until LP > L
              Exit Do
            End If
          End If
        Loop
        Stack(I \ 2) = R
      Next I
    End If
    'After each merge, we have half as many runs and we switch direction.
    nRuns = nRuns \ 2
    Forward = Not Forward
  Wend
End Sub

Sub ShuttleMergeSortL(LO As Long, HI As Long, A() As Long, B() As Long)
  'LO and HI point to the first and last keys.
  'A() and B() are the primary and auxiliary buffers of keys
  Dim Length As Double  'length of initial runs to be made by InsertionSort
  Dim nRuns As Long    'the number of runs at each stage
  Dim Stack() As Long    'bookkeeping stack for merge passes
  Dim I As Long
  Dim L As Long      'left limit
  Dim R As Long      'right limit
  Dim LP As Long      'left pointer
  Dim RP As Long      'right pointer
  Dim OP As Long      'other pointer
  Dim TMP As String
  Dim Forward As Boolean  'toggle for direction of alternate merge passes

  'Calculate how many merge passes will be needed.
  'Each back & forth pair of merges will convert 4N sublists into N.
  Length = 1 + HI - LO
  nRuns = 1
  While Length > 20
    Length = Length / 4
    nRuns = nRuns * 4
  Wend

  'Set up stack to keep track of sublists being merged.
  ReDim Stack(1 To nRuns)
  For I = 1 To nRuns - 1
    Stack(I) = LO + (Length * CDbl(I))
  Next I
  Stack(nRuns) = HI

  'Build short runs using low overhead InsertionSort.
  L = LO
  For I = 1 To nRuns
    R = Stack(I)
    For RP = L + 1 To R
      TMP = A(RP)
      For LP = RP To L + 1 Step -1
        If TMP < A(LP - 1) Then A(LP) = A(LP - 1) Else Exit For
      Next LP
      A(LP) = TMP
    Next RP
    L = R + 1
  Next I

  'Make back & forth passes of MergeSort until all runs are merged.
  Forward = True
  While nRuns > 1
    R = LO - 1
    If Forward Then
      'Half the passes are forward, merging from P() into Q().
      For I = 2 To nRuns Step 2
        LP = R + 1
        OP = LP
        L = Stack(I - 1)
        RP = L + 1
        R = Stack(I)
        Do
          If A(LP) <= A(RP) Then
            B(OP) = A(LP)
            OP = OP + 1
            LP = LP + 1
            If LP > L Then
              Do
                B(OP) = A(RP)
                OP = OP + 1
                RP = RP + 1
              Loop Until RP > R
              Exit Do
            End If
          Else
            B(OP) = A(RP)
            OP = OP + 1
            RP = RP + 1
            If RP > R Then
              Do
                B(OP) = A(LP)
                OP = OP + 1
                LP = LP + 1
              Loop Until LP > L
              Exit Do
            End If
          End If
        Loop
        Stack(I \ 2) = R
      Next I
    Else
     'Half the passes are backward, merging from Q() into P().
      For I = 2 To nRuns Step 2
        LP = R + 1
        OP = LP
        L = Stack(I - 1)
        RP = L + 1
        R = Stack(I)
        Do
          If B(LP) <= B(RP) Then
            A(OP) = B(LP)
            OP = OP + 1
            LP = LP + 1
            If LP > L Then
              Do
                A(OP) = B(RP)
                OP = OP + 1
                RP = RP + 1
              Loop Until RP > R
              Exit Do
            End If
          Else
            A(OP) = B(RP)
            OP = OP + 1
            RP = RP + 1
            If RP > R Then
              Do
                A(OP) = B(LP)
                OP = OP + 1
                LP = LP + 1
              Loop Until LP > L
              Exit Do
            End If
          End If
        Loop
        Stack(I \ 2) = R
      Next I
    End If
    'After each merge, we have half as many runs and we switch direction.
    nRuns = nRuns \ 2
    Forward = Not Forward
  Wend
End Sub