MergeSort - A stable sort

' MergeSort.  A stable sort (preserves original order of records with equal 
' keys).  Like HeapSort, easily adapted to any data type and guaranteed to run 
' in O(N log N) time, but almost twice as fast.  On the down side,
'  needs an extra array of N items, but these can be pointers if the keys 
' themselves are larger than pointers.  Works by repeatedly merging short 
' sorted sequences (created by InsertionSort) into longer ones.  Two versions 
' are given.  pMergeSortS is an indirect (pointerized) version for strings,
'  which can be adapted to doubles by changing the declaration of A().  
' MergeSortL is a direct version for longs, which can be adapted to integers.
'
' Speed:  pMergeSortS sorts 500,000 random strings in 55.3 sec; sorts 100186 
' library call numbers in 9.8 sec; sorts 25479 dictionary words in 3.3 sec 
' (random order), 2.9 sec (presorted) or 3.6 sec (reverse sorted).  MergeSortL 
' sorts 500,000 random longs in 42 seconds.  Timed in Excel 2001 on an 800 mhz 
' PowerBook.
'
' Bottom line:  fast stable sort that easily handles all data types,
'  but a heavy memory user.

' Usage:  

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

pMergeSortS L, R, S1, P1, P2
MergeSortL L, R, L1, L2

' CODE:

Sub pMergeSortS(L As Long, R As Long, A() As String, P() As Long, Q() As Long)
    Dim LP As Long        'left pointer
    Dim RP As Long        'right pointer
    Dim OP As Long        'output pointer
    Dim MID As Long
    
    'This version is for strings; for other data types,
    '  change declaration of A().
    'MergeSort recursively calls itself until we have lists short enough for 
    ' InsertionSort.
    If R - L < 10 Then
       'call an indirect (pointerized) version of InsertionSort
        pInsertS L, R, A, P
    Else
       'if too long for InsertionSort, split list and recurse
        MID = (L + R) \ 2
        pMergeSortS L, MID, A, P, Q
        pMergeSortS MID + 1, R, A, P, Q
        
       'Each half of the array is sorted; now we'll merge them into the extra 
       ' array.
       'We'll work via pointers, to keep the extra array smaller.
        LP = L
        RP = MID + 1
        OP = L
        Do
        'Copy the pointer to the smaller string.
            If A(P(LP)) <= A(P(RP)) Then
                Q(OP) = P(LP)
                OP = OP + 1
                LP = LP + 1
                If LP > MID Then
             'We ran out of the left half, so transfer the rest of the right 
             ' half.
                    Do
                        Q(OP) = P(RP)
                        OP = OP + 1
                        RP = RP + 1
                    Loop Until RP > R
             'This merge is done.
                    Exit Do
                End If
            Else
         'This part is a mirror image of the last part.
                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 > MID
                    Exit Do
                End If
            End If
        Loop
    'Finally, we copy the pointers back from the extra array to the main array.
        For OP = L To R
             P(OP) = Q(OP)
        Next OP
    End If
End Sub

Sub pInsertS(L As Long, R As Long, A() As String, P() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    Dim T As String
    
    For RP = L + 1 To R
        TMP = P(RP)
        T = A(TMP)
        For LP = RP To L + 1 Step -1
            If T < A(P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
        Next LP
        P(LP) = TMP
    Next RP
End Sub

Sub MergeSortL(L As Long, R As Long, A() As Long, B() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim OP As Long
    Dim MID As Long
    
    If R - L < 12 Then
        InsertL L, R, A()
    Else
        MID = (L + R) \ 2
        MergeSortL L, MID, A, B
        MergeSortL MID + 1, R, A, B
        LP = L
        RP = MID + 1
        OP = L
        Do
            If A(LP) <= A(RP) Then
                B(OP) = A(LP)
                OP = OP + 1
                LP = LP + 1
                If LP > MID 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 > MID
                    Exit Do
                End If
            End If
        Loop
        For OP = L To R
             A(OP) = B(OP)
        Next OP
    End If
End Sub

Sub InsertL(L As Long, R As Long, A() As Long)
    Dim LP As Long
    Dim RP As Long
    Dim TMP As Long
    
    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
End Sub