VB6: Sorting algorithms (sort array, sorting arrays)

[Ellis Dee]

The examples posted use variant arrays, which are less efficient than typed arrays, and they only work on single-dimension arrays.

Some basic terminology:

Stable
A stable sorting algorithm is one that maintains relative order for duplicate keys. (This is only relevant for two-dimensional arrays.) As a conceptual example, let's say you were sorting the 365 days of the year by day-of month. In a stable algorithm, the first 12 elements in order will be: January 1, February 1, March 1, April 1, etc... An unstable algorithm will produce unpredictable results for identical keys, so the first twelve elements in order might be: October 1, March 1, June 1, etc...

In-Place
In a nutshell, "in-place" algorithms are those that don't need "extra" memory for their sorting operations. This gets complicated when categorizing recursive algorithms, so for the purposes of this thread, an in-place algorithm is defined as one that sorts the array directly by swapping around the elements. Conversely, an out-of-place algorithm will make a sorted copy of the original array, thus requiring double the memory. Out-of-place algorithms are useful for creating indexes, though that functionality is not implemented here. (It is much more efficient to sort two-dimensional arrays out-of-place, due to the expensive nature of swapping elements.)

Online
An online algorithm is one that can sort an array even if it only gets pieces of the array at a time. (ie: Receiving packets over the internet.)

Recursive
Recursive algorithms call themselves during normal operation. As a general rule, recursive functions are both efficient and complex.

Grade
The grade is an arbitrary letter grade that I personally awarded to each implementation.


Sort Name.........Stable..InPlace..Online..Recursive..Grade
----------------..------..-------..------..---------..-----
Bubble sort.......Yes.....Yes......No......No.........D-
Cocktail sort.....Yes.....Yes......No......No.........D-
Comb sort.........No......Yes......No......No.........B+
Gnome sort........Yes.....Yes......No......No.........C-
Heap sort.........No......Yes......No......No.........A-
Insertion sort....Yes.....Yes......Yes.....No.........C
JSort.............No......Yes......No......No.........C+
Jump sort.........No......Yes......No......No.........B-
Linked List sort..No......No.......Yes.....No.........C-
Merge sort........Yes.....No.......No......Yes........A-
Quick sort........No......Yes......No......Yes........A
Quicksort3........No......Yes......No......Yes........A+
Selection sort....No......Yes......No......No.........C-
Shaker sort.......Yes.....Yes......No......No.........B
Shear sort........No......Yes......No......No.........D
Shell sort........No......Yes......No......No.........B+
Smooth sort.......No......Yes......No......No.........A-
Snake sort........No......No.......No......No.........A

It is worth pointing out that Jump Sort was created by our very own Code Doc. Also, thanks to Doogle for debugging smooth sort, and Merri for providing both Shaker sort and Shear sort.

For those just looking for basic code, here's quicksort, binary search, and the Knuth shuffle:

Option Explicit
Option Compare Text

' Omit plngLeft & plngRight; they are used internally during recursion
Public Sub QuickSort(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim varSwap As Variant
    
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = pvarArray((plngLeft + plngRight) \ 2)
    Do
        Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            varSwap = pvarArray(lngFirst)
            pvarArray(lngFirst) = pvarArray(lngLast)
            pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort pvarArray, lngFirst, plngRight
End Sub

' Simple binary search. Be sure array is sorted first.
' Returns index of first match, or -1 if no match found
Public Function BinarySearch(pvarArray As Variant, pvarFind As Variant) As Long
    Dim lngFirst As Long
    Dim lngMid As Long
    Dim lngLast As Long

    BinarySearch = -1
    lngMid = -1
    lngFirst = LBound(pvarArray)
    lngLast = UBound(pvarArray)
    Do While lngFirst <= lngLast
        lngMid = (lngFirst + lngLast) \ 2
        If pvarArray(lngMid) > pvarFind Then
            lngLast = lngMid - 1
        ElseIf pvarArray(lngMid) < pvarFind Then
            lngFirst = lngMid + 1
        Else
            Exit Do
        End If
    Loop
    ' Make sure this is the first match in array
    Do While lngMid > lngFirst
        If pvarArray(lngMid - 1) <> pvarFind Then Exit Do
        lngMid = lngMid - 1
    Loop
    ' Set return value if match was found
    If pvarArray(lngMid) = pvarFind Then BinarySearch = lngMid
End Function

' Knuth shuffle (very fast)
Public Function ShuffleArray(pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim lngReplace As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    For i = iMax To iMin + 1 Step -1
        lngReplace = Int((i - iMin + 1) * Rnd + iMin)
        varSwap = pvarArray(i)
        pvarArray(i) = pvarArray(lngReplace)
        pvarArray(lngReplace) = varSwap
    Next
End Function

Attached is the current state of the sorting program. It is still a work in progress; it currently only does the graphical representation of the algorithms. Double-click an algorithm to see detailed information on it.

[Ellis Dee]

Once an array is sorted, searching for a given value can be done very quickly using a binary search. The idea is to split the sorted list in half by recursively comparing against the middle element, and subsequently dividing the list in half. Which half you keep searching is determined by whether the search term is higher or lower than the middle element.

' Simple binary search. Be sure array is sorted first.
' Returns index of first match, or -1 if no match found
Public Function BinarySearch1(pvarArray As Variant, pvarFind As Variant) As Long
    Dim lngFirst As Long
    Dim lngMid As Long
    Dim lngLast As Long
 
    BinarySearch1 = -1
    lngMid = -1
    lngFirst = LBound(pvarArray)
    lngLast = UBound(pvarArray)
    Do While lngFirst <= lngLast
        lngMid = (lngFirst + lngLast) \ 2
        If pvarArray(lngMid) > pvarFind Then
            lngLast = lngMid - 1
        ElseIf pvarArray(lngMid) < pvarFind Then
            lngFirst = lngMid + 1
        Else
            Exit Do
        End If
    Loop
    ' Make sure this is the first match in array
    Do While lngMid > lngFirst
        If pvarArray(lngMid - 1) <> pvarFind Then Exit Do
        lngMid = lngMid - 1
    Loop
    ' Set return value if match was found
    If pvarArray(lngMid) = pvarFind Then BinarySearch1 = lngMid
End Function

Another common issue is shuffling an array. The Knuth shuffle involves moving through the array, swapping each element in turn with another element from a random position that has not yet been passed through (including itself).

' Knuth shuffle (very fast)
Public Function ShuffleArray1(pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim lngReplace As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    For i = iMax To iMin + 1 Step -1
        lngReplace = Int((i - iMin + 1) * Rnd + iMin)
        varSwap = pvarArray(i)
        pvarArray(i) = pvarArray(lngReplace)
        pvarArray(lngReplace) = varSwap
    Next
End Function

[Ellis Dee]

Bubble sort

Stable: Yes
In-Place: Yes
Online: No
Recursive: No
Grade: D-

Bubble sort is a simple sorting algorithm. It works by repeatedly stepping through the list to be sorted, comparing two items at a time and swapping them if they are in the wrong order. The pass through the list is repeated until no swaps are needed, which means the list is sorted.

The algorithm gets its name from the way smaller elements "bubble" to the top (i.e. the beginning) of the list via the swaps. One way to optimize bubblesort (implemented here) is to note that, after each pass, the largest element will always move down to the bottom. Thus it suffices to sort the remaining n - 1 elements each subsequent pass.

Although simple, this algorithm is highly inefficient and is rarely used except in education.

Public Sub BubbleSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    Dim blnSwapped As Boolean
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray) - 1
    Do
        blnSwapped = False
        For i = iMin To iMax
            If pvarArray(i) > pvarArray(i + 1) Then
                varSwap = pvarArray(i)
                pvarArray(i) = pvarArray(i + 1)
                pvarArray(i + 1) = varSwap
                blnSwapped = True
            End If
        Next
        iMax = iMax - 1
    Loop Until Not blnSwapped
End Sub

[Ellis Dee]

Cocktail sort

Stable: Yes
In-Place: Yes
Online: No
Recursive: No
Grade: D-

Cocktail sort is a variation of bubble sort that sorts in both directions each pass through the list.

One optimization (implemented here) is to add an if-statement that checks whether there has been a swap after the first pass each iteration. If there hasn't been a swap the list is sorted and the algorithm can stop.

Public Sub CocktailSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    Dim blnSwapped As Boolean
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray) - 1
    Do
        blnSwapped = False
        For i = iMin To iMax
            If pvarArray(i) > pvarArray(i + 1) Then
                varSwap = pvarArray(i)
                pvarArray(i) = pvarArray(i + 1)
                pvarArray(i + 1) = varSwap
                blnSwapped = True
            End If
        Next
        iMax = iMax - 1
        If Not blnSwapped Then Exit Do
        For i = iMax To iMin Step -1
            If pvarArray(i) > pvarArray(i + 1) Then
                varSwap = pvarArray(i)
                pvarArray(i) = pvarArray(i + 1)
                pvarArray(i + 1) = varSwap
                blnSwapped = True
            End If
        Next
        iMin = iMin + 1
    Loop Until Not blnSwapped
End Sub

[Ellis Dee]

Comb sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: B+

Comb sort was invented by Stephen Lacey and Richard Box, who first described it to Byte Magazine in 1991. It improves on bubble sort and rivals in speed more complex algorithms like quicksort. The idea is to eliminate turtles, or small values near the end of the list, since in a bubble sort these slow the sorting down tremendously. (Rabbits, large values around the beginning of the list, do not pose a problem in bubble sort.)

In bubble sort, when any two elements are compared, they always have a gap (distance from each other) of one. The basic idea of comb sort is that the gap can be much more than one.

The gap starts out as the length of the list being sorted divided by the shrink factor (generally 1.3; see below), and the list is sorted with that value (rounded down to an integer if needed) for the gap. Then the gap is divided by the shrink factor again, the list is sorted with this new gap, and the process repeats until the gap is one. At this point, comb sort reverts to a true bubble sort, using a gap of one until the list is fully sorted. In this final stage of the sort most turtles have already been dealt with, so a bubble sort will be efficient.

The shrink factor has a great effect on the efficiency of comb sort. In the original article, the authors suggested 1.3 after trying some random lists and finding it to be generally the most effective. A value too small slows the algorithm down because more comparisons must be made, whereas a value too large may not kill enough turtles to be practical.

Public Sub CombSort1(ByRef pvarArray As Variant)
    Const ShrinkFactor = 1.3
    Dim lngGap As Long
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    Dim blnSwapped As Boolean
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    lngGap = iMax - iMin + 1
    Do
        If lngGap > 1 Then
            lngGap = Int(lngGap / ShrinkFactor)
            If lngGap = 10 Or lngGap = 9 Then lngGap = 11
        End If
        blnSwapped = False
        For i = iMin To iMax - lngGap
            If pvarArray(i) > pvarArray(i + lngGap) Then
                varSwap = pvarArray(i)
                pvarArray(i) = pvarArray(i + lngGap)
                pvarArray(i + lngGap) = varSwap
                blnSwapped = True
            End If
        Next
    Loop Until lngGap = 1 And Not blnSwapped
End Sub

[Ellis Dee]

Gnome sort

Stable: Yes
In-Place: Yes
Online: No
Recursive: No
Grade: C-

Gnome sort is a sorting algorithm which is similar to insertion sort except that moving an element to its proper place is accomplished by a series of swaps, as in bubble sort. It is conceptually simple, requiring no nested loops. In practice the algorithm has been reported to generally run as fast as Insertion sort, although this depends on the details of the architecture and the implementation

The name comes from the behavior of the Dutch garden gnome in sorting a line of flowerpots. He looks at the flower pot next to him and the previous one; if they are in the right order he steps one pot forward, otherwise he swaps them and steps one pot backwards. If there is no previous pot, he steps forwards; if there is no pot next to him, he is done

Effectively, the algorithm always finds the first place where two adjacent elements are in the wrong order, and swaps them. It takes advantage of the fact that performing a swap can only introduce a new out-of-order adjacent pair right before the two swapped elements, and so checks this position immediately after performing such a swap.

Public Sub GnomeSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim j As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray) + 1
    iMax = UBound(pvarArray)
    i = iMin
    j = i + 1
    Do While i <= iMax
        If pvarArray(i) < pvarArray(i - 1) Then
            varSwap = pvarArray(i)
            pvarArray(i) = pvarArray(i - 1)
            pvarArray(i - 1) = varSwap
            If i > iMin Then i = i - 1
        Else
            i = j
            j = j + 1
        End If
    Loop
End Sub

[Ellis Dee]

Heap sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: A-

Heap sort is a much more efficient version of selection sort. Invented by John William Joseph Williams in 1964, it works efficiently by using a data structure called a heap.

A heap is a specialized tree-based data structure that satisfies the heap property: if B is a child node of A, then key(A) >= key(B). This implies that the element with the greatest key is always in the root node. All elements to be sorted are inserted into a heap, and the heap organizes the elements added to it in such a way that the largest value can be quickly extracted.

Once the data list has been made into a heap, the root node is guaranteed to be the largest element. It is removed and placed at the end of the list, then the heap is rearranged so the largest element remaining moves to the root. Using the heap, finding the next largest element takes much less time than scanning every remaining element, which gives heap sort much better performance than selection sort. Similar to selection sort, the initial conditions have little or no effect on the amount of time required.

Heap sort is one of the best general-purpose sorting algorithms. Although somewhat slower in practice on most machines than a good implementation of quicksort, it has a better worst-case runtime.

Public Sub HeapSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    For i = (iMax + iMin) \ 2 To iMin Step -1
        Heap1 pvarArray, i, iMin, iMax
    Next i
    For i = iMax To iMin + 1 Step -1
        varSwap = pvarArray(i)
        pvarArray(i) = pvarArray(iMin)
        pvarArray(iMin) = varSwap
        Heap1 pvarArray, iMin, iMin, i - 1
    Next i
End Sub
 
Private Sub Heap1(ByRef pvarArray As Variant, ByVal i As Long, iMin As Long, iMax As Long)
    Dim lngLeaf As Long
    Dim varSwap As Variant
    
    Do
        lngLeaf = i + i - (iMin - 1)
        Select Case lngLeaf
            Case Is > iMax: Exit Do
            Case Is < iMax: If pvarArray(lngLeaf + 1) > pvarArray(lngLeaf) Then lngLeaf = lngLeaf + 1
        End Select
        If pvarArray(i) > pvarArray(lngLeaf) Then Exit Do
        varSwap = pvarArray(i)
        pvarArray(i) = pvarArray(lngLeaf)
        pvarArray(lngLeaf) = varSwap
        i = lngLeaf
    Loop
End Sub

[Ellis Dee]

Insertion sort

Stable: Yes
In-Place: Yes
Online: Yes
Recursive: No
Grade: C

Insertion sort is a simple comparison sort in which the sorted array (or list) is built one entry at a time. It is much less efficient on large lists than more advanced algorithms such as quicksort, heapsort, or merge sort, but it's very efficient on small (5-50 key) lists, as well as lists that are mostly sorted to begin with.

In abstract terms, every iteration of an insertion sort removes an element from the input data, inserting it at the correct position in the already sorted list, until no elements are left in the input. The choice of which element to remove from the input is arbitrary and can be made using almost any choice algorithm.

Public Sub InsertionSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim j As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray) + 1
    iMax = UBound(pvarArray)
    For i = iMin To iMax
        varSwap = pvarArray(i)
        For j = i To iMin Step -1
            If varSwap < pvarArray(j - 1) Then pvarArray(j) = pvarArray(j - 1) Else Exit For
        Next j
        pvarArray(j) = varSwap
    Next i
End Sub

[Ellis Dee]

JSort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: C+

JSort is a hybrid of heap sort and insertion sort developed by Jason Morrison. It works by running two heap passes to roughly order the array, and then finishes with an insertion sort.

The first heap pass converts the array to a heap, moving the smallest item to the top. The second heap pass works in reverse, moving the largest element to the bottom. These two passes combine to roughly order the array, though much work is still left to the final insertion sort.

Because each heap pass only partially orders the list, the larger the array the more work is left for the final insertion sort pass, which can end up being highly ineffecient.

For small lists, JSort is extremely efficient, but due to its design it does not scale well.

(code not currently available)

[Ellis Dee]

Jump sort (written by Code Doc)

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: B-

Similar to shell sort and comb sort, jump sort employs a gap value that decreases in each successive pass that allows out-of-place elements to be moved very far initially. The underlying framework is based on bubble sort instead of the more efficient insertion sort, but due to the initial ordering in the early passes it ends up being very efficient in practice, though still somewhat slower than either shell sort or comb sort.

Public Sub JumpSort1(ByRef pvarArray As Variant)
    Dim lngJump As Long
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    Dim blnSwapped As Boolean
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    lngJump = iMax - iMin
    If lngJump < 2 Then lngJump = 2
    Do
        lngJump = lngJump \ 2
        Do
            blnSwapped = False
            For i = iMin To iMax - lngJump
                If pvarArray(i) > pvarArray(i + lngJump) Then
                    varSwap = pvarArray(i)
                    pvarArray(i) = pvarArray(i + lngJump)
                    pvarArray(i + lngJump) = varSwap
                    blnSwapped = True
                End If
            Next
        Loop Until Not blnSwapped
    Loop Until lngJump = 1
End Sub

[Ellis Dee]

Linked List sort

Stable: No
In-Place: No
Online: Yes
Recursive: No
Grade: C-

(writeup and code not currently available)

[Ellis Dee]

Merge sort

Stable: Yes
In-Place: No
Online: No
Recursive: Yes
Grade: A-

Similar to quicksort, merge sort is a recursive algorithm based on a divide and conquer strategy. First, the sequence to be sorted is split into two halves. Each half is then sorted independently, and the two sorted halves are merged to a sorted sequence. Merge sort takes advantage of the ease of merging together already sorted lists.

In many implementations, merge sort calls out to an external algorithm -- usually insertion sort -- when it reaches a level of around 10-20 elements. This is not necessary in Visual Basic; in fact such an implementation appears to slow merge sort's overall performance in practice.

Instead, the implementation here uses the purest form of merge sort, where the list is recursively divided into halves until it reaches a list size of two, at which point those two elements are sorted.

Unfortunately, extra memory is required to combine two sorted lists together. The extra memory in this implementation is in the form of a full copy of the initial array. There are various optimizations that can be made to improve on this, but that is left as an exercise for the reader.

Invented in 1945 by John von Neumann, merge sort is far and away the fastest stable algorithm.

' Omit pvarMirror, plngLeft & plngRight; they are used internally during recursion
Public Sub MergeSort1(ByRef pvarArray As Variant, Optional pvarMirror As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngMid As Long
    Dim L As Long
    Dim R As Long
    Dim O As Long
    Dim varSwap As Variant
 
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
        ReDim pvarMirror(plngLeft To plngRight)
    End If
    lngMid = plngRight - plngLeft
    Select Case lngMid
        Case 0
        Case 1
            If pvarArray(plngLeft) > pvarArray(plngRight) Then
                varSwap = pvarArray(plngLeft)
                pvarArray(plngLeft) = pvarArray(plngRight)
                pvarArray(plngRight) = varSwap
            End If
        Case Else
            lngMid = lngMid \ 2 + plngLeft
            MergeSort1 pvarArray, pvarMirror, plngLeft, lngMid
            MergeSort1 pvarArray, pvarMirror, lngMid + 1, plngRight
            ' Merge the resulting halves
            L = plngLeft ' start of first (left) half
            R = lngMid + 1 ' start of second (right) half
            O = plngLeft ' start of output (mirror array)
            Do
                If pvarArray(R) < pvarArray(L) Then
                    pvarMirror(O) = pvarArray(R)
                    R = R + 1
                    If R > plngRight Then
                        For L = L To lngMid
                            O = O + 1
                            pvarMirror(O) = pvarArray(L)
                        Next
                        Exit Do
                    End If
                Else
                    pvarMirror(O) = pvarArray(L)
                    L = L + 1
                    If L > lngMid Then
                        For R = R To plngRight
                            O = O + 1
                            pvarMirror(O) = pvarArray(R)
                        Next
                        Exit Do
                    End If
                End If
                O = O + 1
            Loop
            For O = plngLeft To plngRight
                pvarArray(O) = pvarMirror(O)
            Next
    End Select
End Sub

[Ellis Dee]

Quick sort

Stable: No
In-Place: Yes
Online: No
Recursive: Yes
Grade: A

Quicksort was originally invented in 1960 by Charles Antony Richard Hoare. It is a divide and conquer algorithm which relies on a partition operation.

To partition an array, a pivot element is first randomly selected, and then compared against every other element. All smaller elements are moved before the pivot, and all larger elements are moved after. The lesser and greater sublists are then recursively processed until the entire list is sorted. This can be done efficiently in linear time and in-place.

Quick sort turns out to be the fastest sorting algorithm in practice. However, in the (very rare) worst case quick sort is as slow as bubble sort. There are good sorting algorithms with a better worst case, e.g. heap sort and merge sort, but on the average they are slower than quick sort by a consistent margin.

The implementation here uses Niklaus Wirth's variant for selecting the pivot value, which is simply using the middle value. This works particularly well for already sorted lists.

Its speed and modest space usage makes quick sort one of the most popular sorting algorithms, available in many standard libraries.

' Omit plngLeft & plngRight; they are used internally during recursion
Public Sub QuickSort1(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim varSwap As Variant
    
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = pvarArray((plngLeft + plngRight) \ 2)
    Do
        Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            varSwap = pvarArray(lngFirst)
            pvarArray(lngFirst) = pvarArray(lngLast)
            pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort1 pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort1 pvarArray, lngFirst, plngRight
End Sub

[Ellis Dee]

Quicksort3

Stable: No
In-Place: Yes
Online: No
Recursive: Yes
Grade: A+

The critical operation in the standard quick sort is choosing a pivot: the element around which the list is partitioned. The simplest pivot selection algorithm is to take the first or the last element of the list as the pivot, causing poor behavior for the case of sorted or nearly-sorted input. Niklaus Wirth's variant uses the middle element to prevent these occurrences, degenerating to O(n²) for contrived sequences.

The median-of-3 pivot selection algorithm takes the median of the first, middle, and last elements of the list; however, even though this performs well on many real-world inputs, it is still possible to contrive a median-of-3 killer list that will cause dramatic slowdown of a quicksort based on this pivot selection technique. Such inputs could potentially be exploited by an aggressor, for example by sending such a list to an Internet server for sorting as a denial of service attack.

The quicksort3 implementation here uses a median-of-3 technique, but instead of using the first, last and middle elements, three elements are chosen at random. This has the advantage of being immune to intentional attacks, though there is still a possibility (however remote) of realizing the worst case scenario.

' Omit plngLeft & plngRight; they are used internally during recursion
Public Sub MedianThreeQuickSort1(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim lngIndex As Long
    Dim varSwap As Variant
    Dim a As Long
    Dim b As Long
    Dim c As Long
    
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    lngIndex = plngRight - plngLeft + 1
    a = Int(lngIndex * Rnd) + plngLeft
    b = Int(lngIndex * Rnd) + plngLeft
    c = Int(lngIndex * Rnd) + plngLeft
    If pvarArray(a) <= pvarArray(b) And pvarArray(b) <= pvarArray(c) Then
        lngIndex = b
    Else
        If pvarArray(b) <= pvarArray(a) And pvarArray(a) <= pvarArray(c) Then
            lngIndex = a
        Else
            lngIndex = c
        End If
    End If
    varMid = pvarArray(lngIndex)
    Do
        Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            varSwap = pvarArray(lngFirst)
            pvarArray(lngFirst) = pvarArray(lngLast)
            pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If lngLast – plngLeft < plngRight – lngFirst Then
        If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast
        If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight
    Else
        If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight
        If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast
    End If
End Sub

[Ellis Dee]

Selection sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: C-

Selection sort is a simple sorting algorithm that mimics the way humans instinctively sort. It works by first scanning the entire list to find the smallest element, swapping it into the first position. It then finds the next smallest element, swapping that into the second position, and so on until the list is sorted.

Selection sort is unique compared to almost any other algorithm in that its running time is not affected by the prior ordering of the list; it always performs the same number of operations because of its simple structure. Selection sort also requires only n swaps, which can be very attractive if writes are the most expensive operation.

Unless writes are very expensive, selection sort will usually be outperformed by the more complicated algorithms, though it will always outperform a basic bubble sort. Heap sort is an efficient variation of selection sort that is both very fast and also scales well.

Public Sub SelectionSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim j As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
 
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    For i = iMin To iMax - 1
        iMin = i
        For j = (i + 1) To iMax
            If pvarArray(j) < pvarArray(iMin) Then iMin = j
        Next
        varSwap = pvarArray(i)
        pvarArray(i) = pvarArray(iMin)
        pvarArray(iMin) = varSwap
    Next
End Sub

[Ellis Dee]

Shaker sort

Stable: Yes
In-Place: Yes
Online: No
Recursive: No
Grade: B

Shaker sort is a gap-based bubble sort with a twist. Most gap sorts -- shell sort, comb sort, et al. -- begin with a large gap and gradually shrink it down to one. By the time the gap reaches one, the list should be mostly ordered so the final pass should be efficient.

Like other gap sorts, shaker sort begins with a large gap which gradually shrinks. However, once the gap reaches one, the gap gets expanded again before shrinking back toward one. The expanding and contracting gap sizes constitute the "shaking" part of shaker sort. Each additional expansion is smaller and smaller until it eventually resolves to one, when no further expansion is done. At this point the list is almost certain to be nearly sorted, so the final bubble sort pass is very efficient.

Public Function ShakerSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    Dim blnSwapped As Boolean
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    i = (iMax - iMin) \ 2 + iMin
    Do While i > iMin
        j = i
        Do While j > iMin
            For k = iMin To i - j
                If pvarArray(k) > pvarArray(k + j) Then
                    varSwap = pvarArray(k)
                    pvarArray(k) = pvarArray(k + j)
                    pvarArray(k + j) = varSwap
                End If
            Next
            j = j \ 2
        Loop
        i = i \ 2
    Loop
    iMax = iMax - 1
    Do
        blnSwapped = False
        For i = iMin To iMax
            If pvarArray(i) > pvarArray(i + 1) Then
                varSwap = pvarArray(i)
                pvarArray(i) = pvarArray(i + 1)
                pvarArray(i + 1) = varSwap
                blnSwapped = True
            End If
        Next i
        If blnSwapped Then
            blnSwapped = False
            iMax = iMax - 1
            For i = iMax To iMin Step -1
                If pvarArray(i) > pvarArray(i + 1) Then
                    varSwap = pvarArray(i)
                    pvarArray(i) = pvarArray(i + 1)
                    pvarArray(i + 1) = varSwap
                    blnSwapped = True
                End If
            Next i
            iMin = iMin + 1
        End If
    Loop Until Not blnSwapped
End Function

[Ellis Dee]

Shear sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: D

(no writeup available)

Public Function ShearSort1(ByRef pvarArray As Variant)
    Dim Log As Long, Rows As Long, Cols As Long
    Dim pow As Long, div As Long
    Dim h() As Long
    Dim i As Long, k As Long, j As Long
    Dim LMax As Long, LMin As Long
    
    LMax = UBound(pvarArray) + 1
    LMin = LBound(pvarArray)
    pow = 1
    div = 1
    Do While i * i <= LMax
        If i > 0 Then
            If LMax Mod i = 0 Then div = i
        Else
            div = i
        End If
        i = i + 1
    Loop
    Rows = div
    Cols = LMax \ div
    Do While pow <= Rows
        pow = pow * 2
        Log = Log + 1
    Loop
    ReDim h(Rows)
    For i = 0 To Rows
        h(i) = i * Cols
    Next i
    
    For k = 0 To Log - 1
        For j = 0 To Cols \ 2 - 1
            For i = 0 To Rows - 1
                ShearPart1 pvarArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
            For i = 0 To Rows - 1
                ShearPart2 pvarArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
        Next j
        For j = 0 To Rows \ 2 - 1
            For i = 0 To Cols - 1
                ShearPart1 pvarArray, i, Rows * Cols + i, Cols, True
            Next i
            For i = 0 To Cols - 1
                ShearPart2 pvarArray, i, Rows * Cols + i, Cols, True
            Next i
        Next j
    Next k
 
    For j = 0 To Cols \ 2 - 1
        For i = 0 To Rows - 1
            ShearPart1 pvarArray, h(i), h(i + 1), 1, True
        Next i
        For i = 0 To Rows - 1
            ShearPart2 pvarArray, h(i), h(i + 1), 1, True
        Next i
    Next j
 
    For i = 0 To Rows - 1
        h(i) = -1
    Next i
    
'    GnomeSort pvarArray ' Because I'm too lazy to debug the algorithm
End Function
 
Private Sub ShearPart1(ByRef pvarArray As Variant, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Long
    Dim j As Long
    Dim varSwap As Variant
    
    j = Lo
    If Up Then
        Do While j + Nx < Hi
            If pvarArray(j) > pvarArray(j + Nx) Then
                varSwap = pvarArray(j)
                pvarArray(j) = pvarArray(j + Nx)
                pvarArray(j + Nx) = varSwap
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            If pvarArray(j) < pvarArray(j + Nx) Then
                varSwap = pvarArray(j)
                pvarArray(j) = pvarArray(j + Nx)
                pvarArray(j + Nx) = varSwap
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub
 
Private Sub ShearPart2(ByRef pvarArray As Variant, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Variant
    Dim j As Long
    Dim varSwap As Variant
    
    j = Lo + Nx
    If Up Then
        Do While j + Nx < Hi
            If pvarArray(j) > pvarArray(j + Nx) Then
                varSwap = pvarArray(j)
                pvarArray(j) = pvarArray(j + Nx)
                pvarArray(j + Nx) = varSwap
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            If pvarArray(j) < pvarArray(j + Nx) Then
                varSwap = pvarArray(j)
                pvarArray(j) = pvarArray(j + Nx)
                pvarArray(j + Nx) = varSwap
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub

[Ellis Dee]

Shell sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: B+

Shell sort is a variation of insertion sort that was invented by (and takes its name from) Donald Shell, who published the algorithm in 1959.

Shell sort improves on insertion sort by comparing elements separated by a gap of several positions. This lets an element take "bigger steps" toward its expected position. Multiple passes over the data are taken using insertion sort with smaller and smaller gap sizes. The last step of Shell sort is with a gap size of one -- meaning it is a standard insertion sort -- guaranteeing that the final list is sorted. By then, the list will be almost sorted already, so the final pass is efficient.

The gap sequence is an integral part of the shellsort algorithm. Any increment sequence will work, so long as the last element is 1. Donald Shell originally suggested a gap sequence starting at half the size of the list, dividing by half every iteration until it reached one. While offering significant improvement over a standard insertion sort, it was later found that steps of three improve performance even further.

In the implementation here, the initial gap size is calculated by an iterative formula x=3x+1, where x starts at 0 and grows until the gap is larger than the list size. Each insertion sort loop begins by dividing the gap by three, thus ensuring a very large starting gap.

A key feature of shell sort is that the elements remain k-sorted even as the gap diminishes. For instance, if a list was 5-sorted and then 3-sorted, the list is now not only 3-sorted, but both 5- and 3-sorted. If this were not true, the algorithm would undo work that it had done in previous iterations, and would not achieve such a low running time.

Although shell sort is inefficient for large data sets, it is one of the fastest algorithms for sorting small numbers of elements (sets with less than 1000 or so elements). Another advantage of this algorithm is that it requires relatively small amounts of memory. It is worth noting that shell sort enjoyed a brief period when it was the fastest sorting algorithm known, only to be eclipsed by quicksort one year later.

Public Sub ShellSort1(ByRef pvarArray As Variant)
    Dim lngHold As Long
    Dim lngGap As Long
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    lngGap = iMin
    Do
        lngGap = 3 * lngGap + 1
    Loop Until lngGap > iMax
    Do
        lngGap = lngGap \ 3
        For i = lngGap + iMin To iMax
            varSwap = pvarArray(i)
            lngHold = i
            Do While pvarArray(lngHold - lngGap) > varSwap
                pvarArray(lngHold) = pvarArray(lngHold - lngGap)
                lngHold = lngHold - lngGap
                If lngHold < iMin + lngGap Then Exit Do
            Loop
            pvarArray(lngHold) = varSwap
        Next i
    Loop Until lngGap = 1
End Sub

[Ellis Dee]

Smooth sort

Stable: No
In-Place: Yes
Online: No
Recursive: No
Grade: A-

Smooth sort is a variation of heap sort developed by Edsger Dijkstra in 1981. (Here is a direct link to his original paper in pdf form.)

Smooth sort has a similar average case to heap sort but a much better best case, with a smooth transition between the two. This is where the name comes from. The advantage of smoothsort is that it's faster if the input is already sorted to some degree.

Due to its complexity, smoothsort is rarely used.

' This code is not mine; converted from java code
Public Sub SmoothSort1(ByRef pvarArray As Variant)
    Dim q As Long
    Dim R As Long
    Dim p As Long
    Dim b As Long
    Dim c As Long
    Dim temp As Long
    
    q = 1
    p = 1
    b = 1
    c = 1
    Do While q <> UBound(pvarArray) + 1
        If p Mod 8 = 3 Then
            SmoothSift pvarArray, R, b, c
            p = (p + 1) \ 4
            SmoothUp b, c
            SmoothUp b, c
        ElseIf p Mod 4 = 1 Then
            If q + c < UBound(pvarArray) + 1 Then
                SmoothSift pvarArray, R, b, c
            Else
                SmoothTrinkle pvarArray, R, p, b, c
            End If
            Do
                SmoothDown b, c
                p = p * 2
            Loop While b <> 1
            p = p + 1
        End If
        q = q + 1
        R = R + 1
    Loop
    SmoothTrinkle pvarArray, R, p, b, c
    Do While q <> 1
        q = q - 1
        If b = 1 Then
            R = R - 1
            p = p - 1
            Do While p Mod 2 = 0
                p = p / 2
                SmoothUp b, c
            Loop
        ElseIf b >= 3 Then
            p = p - 1
            R = R + c - b
            If p <> 0 Then SmoothSemiTrinkle pvarArray, R, p, b, c
            SmoothDown b, c
            p = p * 2 + 1
            R = R + c
            SmoothSemiTrinkle pvarArray, R, p, b, c
            SmoothDown b, c
            p = p * 2 + 1
        End If
    Loop
End Sub
 
Private Sub SmoothUp(b As Long, c As Long)
    Dim temp As Long
    
    temp = b + c + 1
    c = b
    b = temp
End Sub
 
Private Sub SmoothDown(b As Long, c As Long)
    Dim temp As Long
    
    temp = b - c - 1
    b = c
    c = temp
End Sub
 
Private Sub SmoothSift(ByRef pvarArray As Variant, ByVal R As Long, ByVal b As Long, ByVal c As Long)
    Dim r2 As Long
    Dim varSwap As Variant
    
    Do While b >= 3
        r2 = R - b + c
        If pvarArray(r2) < pvarArray(R - 1) Then
            r2 = R - 1
            SmoothDown b, c
        End If
        If pvarArray(R) >= pvarArray(r2) Then
            b = 1
        Else
            varSwap = pvarArray(R)
            pvarArray(R) = pvarArray(r2)
            pvarArray(r2) = varSwap
            R = r2
            SmoothDown b, c
        End If
    Loop
End Sub
 
Private Sub SmoothTrinkle(pvarArray As Variant, ByVal R As Long, ByVal p As Long, ByVal b As Long, ByVal c As Long)
    Dim r2 As Long
    Dim r3 As Long
    Dim varSwap As Variant
    
    Do While p > 0
        Do While p Mod 2 = 0
            p = p \ 2
            SmoothUp b, c
        Loop
        r3 = R - b
        If p = 1 Then
            p = 0
        ElseIf pvarArray(r3) <= pvarArray(R) Then
            p = 0
        Else
            p = p - 1
            If b = 1 Then
                varSwap = pvarArray(R)
                pvarArray(R) = pvarArray(r3)
                pvarArray(r3) = varSwap
                R = r3
            ElseIf b >= 3 Then
                r2 = R - b + c
                If pvarArray(r2) < pvarArray(R - 1) Then
                    r2 = R - 1
                    SmoothDown b, c
                    p = p * 2
                End If
                If pvarArray(r3) >= pvarArray(r2) Then
                    varSwap = pvarArray(R)
                    pvarArray(R) = pvarArray(r3)
                    pvarArray(r3) = varSwap
                    R = r3
                Else
                    varSwap = pvarArray(R)
                    pvarArray(R) = pvarArray(r2)
                    pvarArray(r2) = varSwap
                    R = r2
                    SmoothDown b, c
                    p = 0
                End If
            End If
        End If
    Loop
    SmoothSift pvarArray, R, b, c
End Sub
 
Private Sub SmoothSemiTrinkle(pvarArray As Variant, ByVal R As Long, ByVal p As Long, ByVal b As Long, ByVal c As Long)
    Dim r1 As Long
    Dim varSwap As Variant
    
    r1 = R - c
    If pvarArray(r1) > pvarArray(R) Then
        varSwap = pvarArray(R)
        pvarArray(R) = pvarArray(r1)
        pvarArray(r1) = varSwap
        SmoothTrinkle pvarArray, r1, p, b, c
    End If
End Sub

[Ellis Dee]

Snake Sort

Stable: No
In-Place: No
Online: No
Recursive: No
Grade: A

An original algorithm, snake sort was invented by me in 2007 while I was writing this program. It is as fast or faster than any other algorithm, including quicksort, and it scales up as well as quick sort excluding memory constraints. It is in the merge sort family, and is unstable, out-of-place, offline, and non-recursive. I call it snake sort due to its similarities to fantasy football snake drafts.

The idea is simple: A random ordering will result in very small contiguous ordered blocks in either direction. Snake sort begins by identifying all those blocks, and then merges them together. Each merge pass will halve the remaining number of blocks, so it very quickly resolves to a sorted state.

It uses quite a bit of memory: a full copy of the original array, plus an index array (to remember the block cutoffs) half the size of the original array.

One key feature is to bounce the array contents back and forth between the original array and the mirror array. The standard merge sort wastes operations by first merging to a mirror array and then copying the result back each step. Snake sort does a similar merge each pass, but then leaves the result in whichever array was merged to. Each subsequent pass merges to the other array, in effect snaking the results back and forth until the list is fully sorted. This means that if the last step leaves the contents in the mirror array, a final pass must be run to copy that back over the original.

The most interesting feature of snake sort is that the more ordered the array is initially, the faster it runs. Because it is in the unique position of knowing when the intial order is descending, it is optimally efficient at transposing such a list to an ordered state.

Public Sub SnakeSort1(ByRef pvarArray As Variant)
    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim lngIndex() As Long
    Dim lngLevel As Long
    Dim lngOldLevel As Long
    Dim lngNewLevel As Long
    Dim varMirror As Variant
    Dim lngDirection As Long
    Dim blnMirror As Boolean
    Dim varSwap As Variant
    
    iMin = LBound(pvarArray)
    iMax = UBound(pvarArray)
    ReDim lngIndex((iMax - iMin + 3) \ 2)
    lngIndex(0) = iMin
    i = iMin
    ' Initial loop: locate cutoffs for each ordered section
    Do Until i >= iMax
        Select Case lngDirection
            Case 1
                Do Until i = iMax
                    If pvarArray(i) > pvarArray(i + 1) Then Exit Do
                    i = i + 1
                Loop
            Case -1
                Do Until i = iMax
                    If pvarArray(i) < pvarArray(i + 1) Then Exit Do
                    i = i + 1
                Loop
            Case Else
                Do Until i = iMax
                    If pvarArray(i) <> pvarArray(i + 1) Then Exit Do
                    i = i + 1
                Loop
                If i = iMax Then lngDirection = 1
        End Select
        If lngDirection = 0 Then
            If pvarArray(i) > pvarArray(i + 1) Then
                lngDirection = -1
            Else
                lngDirection = 1
            End If
        Else
            lngLevel = lngLevel + 1
            lngIndex(lngLevel) = i * lngDirection
            lngDirection = 0
        End If
        i = i + 1
    Loop
    If Abs(lngIndex(lngLevel)) < iMax Then
        If lngDirection = 0 Then lngDirection = 1
        lngLevel = lngLevel + 1
        lngIndex(lngLevel) = i * lngDirection
    End If
    ' If the list is already sorted, exit
    If lngLevel <= 1 Then
        ' If sorted descending, reverse before exiting
        If lngIndex(lngLevel) < 0 Then
            For i = 0 To (iMax - iMin) \ 2
                varSwap = pvarArray(iMin + i)
                pvarArray(iMin + i) = pvarArray(iMax - i)
                pvarArray(iMax - i) = varSwap
            Next
        End If
        Exit Sub
    End If
    ' Main loop - merge section pairs together until only one section left
    ReDim varMirror(iMin To iMax)
    Do Until lngLevel = 1
        lngOldLevel = lngLevel
        For lngLevel = 1 To lngLevel - 1 Step 2
            If blnMirror Then
                SnakeSortMerge varMirror, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), pvarArray
            Else
                SnakeSortMerge pvarArray, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), varMirror
            End If
            lngNewLevel = lngNewLevel + 1
            lngIndex(lngNewLevel) = Abs(lngIndex(lngLevel + 1))
        Next
        If lngOldLevel Mod 2 = 1 Then
            If blnMirror Then
                For i = lngIndex(lngNewLevel) + 1 To iMax
                    pvarArray(i) = varMirror(i)
                Next
            Else
                For i = lngIndex(lngNewLevel) + 1 To iMax
                    varMirror(i) = pvarArray(i)
                Next
            End If
            lngNewLevel = lngNewLevel + 1
            lngIndex(lngNewLevel) = lngIndex(lngOldLevel)
        End If
        lngLevel = lngNewLevel
        lngNewLevel = 0
        blnMirror = Not blnMirror
    Loop
    ' Copy back to main array if necessary
    If blnMirror Then
        For i = iMin To iMax
            pvarArray(i) = varMirror(i)
        Next
    End If
End Sub
 
Private Sub SnakeSortMerge(pvarSource As Variant, plngLeft As Long, plngMid As Long, plngRight As Long, pvarDest As Variant)
    Dim L As Long
    Dim LMin As Long
    Dim LMax As Long
    Dim LStep As Long
    Dim R As Long
    Dim RMin As Long
    Dim RMax As Long
    Dim RStep As Long
    Dim O As Long
    
    If plngLeft <> 0 Then O = Abs(plngLeft) + 1
    If plngMid > 0 Then
        LMin = O
        LMax = Abs(plngMid)
        LStep = 1
    Else
        LMin = Abs(plngMid)
        LMax = O
        LStep = -1
    End If
    If plngRight > 0 Then
        RMin = Abs(plngMid) + 1
        RMax = Abs(plngRight)
        RStep = 1
    Else
        RMin = Abs(plngRight)
        RMax = Abs(plngMid) + 1
        RStep = -1
    End If
    L = LMin
    R = RMin
    Do
        If pvarSource(L) <= pvarSource(R) Then
            pvarDest(O) = pvarSource(L)
            If L = LMax Then
                For R = R To RMax Step RStep
                    O = O + 1
                    pvarDest(O) = pvarSource(R)
                Next
                Exit Do
            End If
            L = L + LStep
        Else
            pvarDest(O) = pvarSource(R)
            If R = RMax Then
                For L = L To LMax Step LStep
                    O = O + 1
                    pvarDest(O) = pvarSource(L)
                Next
                Exit Do
            End If
            R = R + RStep
        End If
        O = O + 1
    Loop
End Sub

[Merri]

Did something just because I thought it looks cool. Not fast, but cool:

Public Function ShearSort1(ByRef pvarArray As Variant)
    Dim Log As Long, Rows As Long, Cols As Long
    Dim pow As Long, div As Long
    Dim h() As Long
    Dim i As Long, k As Long, j As Long
    
    Dim lMax As Long, lMin As Long
    lMax = UBound(pvarArray) + 1
    lMin = LBound(pvarArray)
    pow = 1
    div = 1
    Do While i * i <= lMax
        If i > 0 Then
            If lMax Mod i = 0 Then div = i
        Else
            div = i
        End If
        i = i + 1
    Loop
    Rows = div
    Cols = lMax \ div
    Do While pow <= Rows
        pow = pow * 2
        Log = Log + 1
    Loop
    ReDim h(Rows)
    For i = 0 To Rows
        h(i) = i * Cols
    Next i
    
    For k = 0 To Log - 1
        For j = 0 To Cols \ 2 - 1
            For i = 0 To Rows - 1
                ShearPart1 pvarArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
            For i = 0 To Rows - 1
                ShearPart2 pvarArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
        Next j
        For j = 0 To Rows \ 2 - 1
            For i = 0 To Cols - 1
                ShearPart1 pvarArray, i, Rows * Cols + i, Cols, True
            Next i
            For i = 0 To Cols - 1
                ShearPart2 pvarArray, i, Rows * Cols + i, Cols, True
            Next i
        Next j
    Next k

    For j = 0 To Cols \ 2 - 1
        For i = 0 To Rows - 1
            ShearPart1 pvarArray, h(i), h(i + 1), 1, True
        Next i
        For i = 0 To Rows - 1
            ShearPart2 pvarArray, h(i), h(i + 1), 1, True
        Next i
    Next j

    For i = 0 To Rows - 1
        h(i) = -1
    Next i
End Function

Private Sub ShearPart1(ByRef a As Variant, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Variant
    Dim j As Long
    j = Lo
    If Up Then
        Do While j + Nx < Hi
            If a(j) > a(j + Nx) Then
                t = a(j)
                a(j) = a(j + Nx)
                a(j + Nx) = t
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            If a(j) < a(j + Nx) Then
                t = a(j)
                a(j) = a(j + Nx)
                a(j + Nx) = t
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub

Private Sub ShearPart2(ByRef a As Variant, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Variant
    Dim j As Long
    j = Lo + Nx
    If Up Then
        Do While j + Nx < Hi
            If a(j) > a(j + Nx) Then
                t = a(j)
                a(j) = a(j + Nx)
                a(j + Nx) = t
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            If a(j) < a(j + Nx) Then
                t = a(j)
                a(j) = a(j + Nx)
                a(j + Nx) = t
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub

Public Function ShearSort(ByRef plngArray() As Long)
    Dim Log As Long, Rows As Long, Cols As Long
    Dim pow As Long, div As Long
    Dim h() As Long
    Dim i As Long, k As Long, j As Long
    
    Dim lMax As Long, lMin As Long
    lMax = UBound(plngArray) + 1
    lMin = LBound(plngArray)
    pow = 1
    div = 1
    Do While i * i <= lMax
        If i > 0 Then
            If lMax Mod i = 0 Then div = i
        Else
            div = i
        End If
        i = i + 1
    Loop
    Rows = div
    Cols = lMax \ div
    Do While pow <= Rows
        pow = pow * 2
        Log = Log + 1
    Loop
    ReDim h(Rows)
    For i = 0 To Rows
        h(i) = i * Cols
    Next i
    
    For k = 0 To Log - 1
        For j = 0 To Cols \ 2 - 1
            For i = 0 To Rows - 1
                ShearPart1 plngArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
            For i = 0 To Rows - 1
                ShearPart2 plngArray, h(i), h(i + 1), 1, i Mod 2 = 0
            Next i
        Next j
        For j = 0 To Rows \ 2 - 1
            For i = 0 To Cols - 1
                ShearPart1 plngArray, i, Rows * Cols + i, Cols, True
            Next i
            For i = 0 To Cols - 1
                ShearPart2 plngArray, i, Rows * Cols + i, Cols, True
            Next i
        Next j
    Next k

    For j = 0 To Cols \ 2 - 1
        For i = 0 To Rows - 1
            ShearPart1 plngArray, h(i), h(i + 1), 1, True
        Next i
        For i = 0 To Rows - 1
            ShearPart2 plngArray, h(i), h(i + 1), 1, True
        Next i
    Next j

    For i = 0 To Rows - 1
        h(i) = -1
    Next i
End Function

Private Sub ShearPart1(ByRef a() As Long, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Long
    Dim j As Long
    j = Lo
    If Up Then
        Do While j + Nx < Hi
            Compare aeShakersort, j, j + Nx
            If a(j) > a(j + Nx) Then
                Exchange aeShakersort, j, j + Nx
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            Compare aeShakersort, j, j + Nx
            If a(j) < a(j + Nx) Then
                Exchange aeShakersort, j, j + Nx
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub

Private Sub ShearPart2(ByRef a As Variant, ByVal Lo As Long, ByVal Hi As Long, ByVal Nx As Long, ByVal Up As Boolean)
    Dim t As Variant
    Dim j As Long
    j = Lo + Nx
    If Up Then
        Do While j + Nx < Hi
            Compare aeShakersort, j, j + Nx
            If a(j) > a(j + Nx) Then
                Exchange aeShakersort, j, j + Nx
            End If
            j = j + 2 * Nx
        Loop
    Else
        Do While j + Nx < Hi
            Compare aeShakersort, j, j + Nx
            If a(j) < a(j + Nx) Then
                Exchange aeShakersort, j, j + Nx
            End If
            j = j + 2 * Nx
        Loop
    End If
End Sub

[Ellis Dee]

hehheh, that's funny. It looks particularly trippy when doing the worst case. (And it seems to have a panic attack when dealing with best case.) And hey, it's faster than bubblesort, so I'm including it. I'm thinking I could fit a third row in there.

I think you're almost as into watching those little lines draw as I am. I swear, I can just sit and stare at them like a mental patient. I don't need food, or drink, or sleep; must watch lines.

[Ellis Dee]

I came up with a new sorting algorithm that is as fast or faster than any other algorithm, including quick sort, and it scales up as well as quicksort excluding memory constraints. It is in the merge sort family, and it is unstable, out-of-place, offline, and non-recursive. I call it snake sort due to its similarity to fantasy football snake drafts.

The idea is simple: A random ordering will result in very small contiguous ordered blocks in either direction. Snake sort begins by identifying all those blocks, and then merges them together. Each merge pass will halve the remaining number of blocks, so it very quickly resolves to a sorted state.

It uses quite a bit of memory; a full copy of the original array, plus an index array (to remember the block cutoffs) of longs half the size of the original array.

Consider the 10 character string SJDFGASLKD. The first three letters, SJD, are already in descending order, so they are the first block. FG are in ascending order, so that's the second block. AS becomes the third block, and LKD (descending order) rounds us out with the fourth and final block.

One key optimization is to bounce the array contents back and forth between the original array and the mirror array instead of merging to the mirror and then copying back to the original each step. This means that if the last step leaves the contents in the mirror, an additional pass must be run to copy that back over the original.

Due to the support of both ascending and descending blocks and the bouncing back and forth between the two arrays -- both of which greatly improve efficiency -- the code sprawl is significant. I've moved the merging code into a separate function to help alleviate this, which means it could still be slightly improved by moving it all into a single function. That optimization would make the code sprawl severe, and likely wouldn't improve sorting times that much.

Here's the debug info I generated in testing for a shuffled array in the graphical screen. Notice how descending blocks are denoted by negative numbers: (Blocks are called levels.)

----------------------
|   Copy to Mirror   |
----------------------
(0)=73...Level(0)=0
(1)=69
(2)=49
(3)=15...Level(1)=-3
(4)=91
(5)=1...Level(2)=-5
(6)=47
(7)=23...Level(3)=-7
(8)=53
(9)=13...Level(4)=-9
(10)=81
(11)=79
(12)=55...Level(5)=-12
(13)=57
(14)=9...Level(6)=-14
(15)=31
(16)=39...Level(7)=16
(17)=7
(18)=33
(19)=63
(20)=97...Level(8)=20
(21)=83
(22)=11...Level(9)=-22
(23)=25
(24)=59
(25)=89...Level(10)=25
(26)=35
(27)=37
(28)=67...Level(11)=28
(29)=3
(30)=21...Level(12)=30
(31)=17
(32)=75...Level(13)=32
(33)=61
(34)=51...Level(14)=-34
(35)=71
(36)=29
(37)=27
(38)=5...Level(15)=-38
(39)=85
(40)=87...Level(16)=40
(41)=41
(42)=95...Level(17)=42
(43)=77
(44)=43...Level(18)=-44
(45)=45
(46)=99...Level(19)=46
(47)=19
(48)=93...Level(20)=48
(49)=65...Level(21)=49
----------------------
|  Copy to Original  |
----------------------
(0)=1...Level(0)=0
(1)=15
(2)=49
(3)=69
(4)=73
(5)=91...Level(1)=5
(6)=13
(7)=23
(8)=47
(9)=53...Level(2)=9
(10)=9
(11)=55
(12)=57
(13)=79
(14)=81...Level(3)=14
(15)=7
(16)=31
(17)=33
(18)=39
(19)=63
(20)=97...Level(4)=20
(21)=11
(22)=25
(23)=59
(24)=83
(25)=89...Level(5)=25
(26)=3
(27)=21
(28)=35
(29)=37
(30)=67...Level(6)=30
(31)=17
(32)=51
(33)=61
(34)=75...Level(7)=34
(35)=5
(36)=27
(37)=29
(38)=71
(39)=85
(40)=87...Level(8)=40
(41)=41
(42)=43
(43)=77
(44)=95...Level(9)=44
(45)=19
(46)=45
(47)=93
(48)=99...Level(10)=48
(49)=65...Level(11)=49
----------------------
|   Copy to Mirror   |
----------------------
(0)=1...Level(0)=0
(1)=13
(2)=15
(3)=23
(4)=47
(5)=49
(6)=53
(7)=69
(8)=73
(9)=91...Level(1)=9
(10)=7
(11)=9
(12)=31
(13)=33
(14)=39
(15)=55
(16)=57
(17)=63
(18)=79
(19)=81
(20)=97...Level(2)=20
(21)=3
(22)=11
(23)=21
(24)=25
(25)=35
(26)=37
(27)=59
(28)=67
(29)=83
(30)=89...Level(3)=30
(31)=5
(32)=17
(33)=27
(34)=29
(35)=51
(36)=61
(37)=71
(38)=75
(39)=85
(40)=87...Level(4)=40
(41)=19
(42)=41
(43)=43
(44)=45
(45)=77
(46)=93
(47)=95
(48)=99...Level(5)=48
(49)=65...Level(6)=49
----------------------
|  Copy to Original  |
----------------------
(0)=1...Level(0)=0
(1)=7
(2)=9
(3)=13
(4)=15
(5)=23
(6)=31
(7)=33
(8)=39
(9)=47
(10)=49
(11)=53
(12)=55
(13)=57
(14)=63
(15)=69
(16)=73
(17)=79
(18)=81
(19)=91
(20)=97...Level(1)=20
(21)=3
(22)=5
(23)=11
(24)=17
(25)=21
(26)=25
(27)=27
(28)=29
(29)=35
(30)=37
(31)=51
(32)=59
(33)=61
(34)=67
(35)=71
(36)=75
(37)=83
(38)=85
(39)=87
(40)=89...Level(2)=40
(41)=19
(42)=41
(43)=43
(44)=45
(45)=65
(46)=77
(47)=93
(48)=95
(49)=99...Level(3)=49
----------------------
|   Copy to Mirror   |
----------------------
(0)=1...Level(0)=0
(1)=3
(2)=5
(3)=7
(4)=9
(5)=11
(6)=13
(7)=15
(8)=17
(9)=21
(10)=23
(11)=25
(12)=27
(13)=29
(14)=31
(15)=33
(16)=35
(17)=37
(18)=39
(19)=47
(20)=49
(21)=51
(22)=53
(23)=55
(24)=57
(25)=59
(26)=61
(27)=63
(28)=67
(29)=69
(30)=71
(31)=73
(32)=75
(33)=79
(34)=81
(35)=83
(36)=85
(37)=87
(38)=89
(39)=91
(40)=97...Level(1)=40
(41)=19
(42)=41
(43)=43
(44)=45
(45)=65
(46)=77
(47)=93
(48)=95
(49)=99...Level(2)=49
----------------------
|  Copy to Original  |
----------------------
(0)=1
(1)=3
(2)=5
(3)=7
(4)=9
(5)=11
(6)=13
(7)=15
(8)=17
(9)=19
(10)=21
(11)=23
(12)=25
(13)=27
(14)=29
(15)=31
(16)=33
(17)=35
(18)=37
(19)=39
(20)=41
(21)=43
(22)=45
(23)=47
(24)=49
(25)=51
(26)=53
(27)=55
(28)=57
(29)=59
(30)=61
(31)=63
(32)=65
(33)=67
(34)=69
(35)=71
(36)=73
(37)=75
(38)=77
(39)=79
(40)=81
(41)=83
(42)=85
(43)=87
(44)=89
(45)=91
(46)=93
(47)=95
(48)=97
(49)=99
----------------------
|   Sort Complete    |
----------------------

Once the initial pass identifies the original blocks, no basic comparisons are needed ever again, since by definition any elements inside a block are already in a sorted order. Each subsequent pass merges two blocks together, so the new block cutoffs are already known. This is another key optimization, which resulted in huge time savings. (Almost doubling the speed.)

[Ellis Dee]

Public Sub SnakeSort1(ByRef pvarArray As Variant)
Dim i As Long
Dim iMin As Long
Dim iMax As Long
Dim lngIndex() As Long
Dim lngLevel As Long
Dim lngOldLevel As Long
Dim lngNewLevel As Long
Dim varMirror As Variant
Dim lngDirection As Long
Dim blnMirror As Boolean
Dim varSwap As Variant

iMin = LBound(pvarArray)
iMax = UBound(pvarArray)
ReDim lngIndex((iMax - iMin + 3) \ 2)
lngIndex(0) = iMin
i = iMin
' Initial loop: locate cutoffs for each block
Do Until i >= iMax
    Select Case lngDirection
        Case 1
            Do Until i = iMax
                If pvarArray(i) > pvarArray(i + 1) Then Exit Do
                i = i + 1
            Loop
        Case -1
            Do Until i = iMax
                If pvarArray(i) < pvarArray(i + 1) Then Exit Do
                i = i + 1
            Loop
        Case Else
            Do Until i = iMax
                If pvarArray(i) <> pvarArray(i + 1) Then Exit Do
                i = i + 1
            Loop
            If i = iMax Then lngDirection = 1
    End Select
    If lngDirection = 0 Then
        If pvarArray(i) > pvarArray(i + 1) Then
            lngDirection = -1
        Else
            lngDirection = 1
        End If
    Else
        lngLevel = lngLevel + 1
        lngIndex(lngLevel) = i * lngDirection
        lngDirection = 0
    End If
    i = i + 1
Loop
If Abs(lngIndex(lngLevel)) < iMax Then
    If lngDirection = 0 Then lngDirection = 1
    lngLevel = lngLevel + 1
    lngIndex(lngLevel) = i * lngDirection
End If
' If the list is already sorted, exit
If lngLevel <= 1 Then
    ' If sorted descending, reverse before exiting
    If lngIndex(lngLevel) < 0 Then
        For i = 0 To (iMax - iMin) \ 2
            varSwap = pvarArray(iMin + i)
            pvarArray(iMin + i) = pvarArray(iMax - i)
            pvarArray(iMax - i) = varSwap
        Next
    End If
    Exit Sub
End If
' Main loop - merge section pairs together until only one section left
ReDim varMirror(iMin To iMax)
Do Until lngLevel = 1
    lngOldLevel = lngLevel
    For lngLevel = 1 To lngLevel - 1 Step 2
        If blnMirror Then
            SnakeSortMerge varMirror, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), pvarArray
        Else
            SnakeSortMerge pvarArray, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), varMirror
        End If
        lngNewLevel = lngNewLevel + 1
        lngIndex(lngNewLevel) = Abs(lngIndex(lngLevel + 1))
    Next
    If lngOldLevel Mod 2 = 1 Then
        If blnMirror Then
            For i = lngIndex(lngNewLevel) + 1 To iMax
                pvarArray(i) = varMirror(i)
            Next
        Else
            For i = lngIndex(lngNewLevel) + 1 To iMax
                varMirror(i) = pvarArray(i)
            Next
        End If
        lngNewLevel = lngNewLevel + 1
        lngIndex(lngNewLevel) = lngIndex(lngOldLevel)
    End If
    lngLevel = lngNewLevel
    lngNewLevel = 0
    blnMirror = Not blnMirror
Loop
' Copy back to main array if necessary
If blnMirror Then
    For i = iMin To iMax
        pvarArray(i) = varMirror(i)
    Next
End If
End Sub

Private Sub SnakeSortMerge(pvarSource As Variant, plngLeft As Long, plngMid As Long, plngRight As Long, pvarDest As Variant)
Dim L As Long
Dim LMin As Long
Dim LMax As Long
Dim LStep As Long
Dim R As Long
Dim RMin As Long
Dim RMax As Long
Dim RStep As Long
Dim O As Long

If plngLeft <> 0 Then O = Abs(plngLeft) + 1
If plngMid > 0 Then
    LMin = O
    LMax = Abs(plngMid)
    LStep = 1
Else
    LMin = Abs(plngMid)
    LMax = O
    LStep = -1
End If
If plngRight > 0 Then
    RMin = Abs(plngMid) + 1
    RMax = Abs(plngRight)
    RStep = 1
Else
    RMin = Abs(plngRight)
    RMax = Abs(plngMid) + 1
    RStep = -1
End If
L = LMin
R = RMin
Do
    If pvarSource(L) <= pvarSource(R) Then
        pvarDest(O) = pvarSource(L)
        If L = LMax Then
            For R = R To RMax Step RStep
                O = O + 1
                pvarDest(O) = pvarSource(R)
            Next
            Exit Do
        End If
        L = L + LStep
    Else
        pvarDest(O) = pvarSource(R)
        If R = RMax Then
            For L = L To LMax Step LStep
                O = O + 1
                pvarDest(O) = pvarSource(L)
            Next
            Exit Do
        End If
        R = R + RStep
    End If
    O = O + 1
Loop
End Sub

Private Sub SnakeSort(ByRef plngArray() As Long)
Dim i As Long
Dim iMin As Long
Dim iMax As Long
Dim lngIndex() As Long
Dim lngLevel As Long
Dim lngOldLevel As Long
Dim lngNewLevel As Long
Dim varMirror As Variant
Dim lngDirection As Long
Dim blnMirror As Boolean

iMin = LBound(plngArray)
iMax = UBound(plngArray)
ReDim lngIndex((iMax - iMin + 3) \ 2)
lngIndex(0) = iMin
i = iMin
' Initial loop: locate cutoffs for each block
Do Until i >= iMax
    Select Case lngDirection
        Case 1
            Do Until i = iMax
                Compare aeSnakesort, i, i + 1
                If plngArray(i) > plngArray(i + 1) Then Exit Do
                i = i + 1
            Loop
        Case -1
            Do Until i = iMax
                Compare aeSnakesort, i, i + 1
                If plngArray(i) < plngArray(i + 1) Then Exit Do
                i = i + 1
            Loop
        Case Else
            Do Until i = iMax
                Compare aeSnakesort, i, i + 1
                If plngArray(i) <> plngArray(i + 1) Then Exit Do
                i = i + 1
            Loop
            If i = iMax Then lngDirection = 1
    End Select
    If lngDirection = 0 Then
        Compare aeSnakesort, i, i + 1
        If plngArray(i) > plngArray(i + 1) Then
            lngDirection = -1
        Else
            lngDirection = 1
        End If
    Else
        lngLevel = lngLevel + 1
        lngIndex(lngLevel) = i * lngDirection
        lngDirection = 0
    End If
    i = i + 1
Loop
If Abs(lngIndex(lngLevel)) < iMax Then
    If lngDirection = 0 Then lngDirection = 1
    lngLevel = lngLevel + 1
    lngIndex(lngLevel) = i * lngDirection
End If
' If the list is already sorted, exit
If lngLevel <= 1 Then
    ' If sorted descending, reverse before exiting
    If lngIndex(lngLevel) < 0 Then
        For i = 0 To (iMax - iMin) \ 2
            Exchange aeSnakesort, iMin + i, iMax - i
        Next
    End If
    Erase lngIndex
    Exit Sub
End If
' Main loop - merge section pairs together until only one section left
ReDim varMirror(iMin To iMax)
Do Until lngLevel = 1
    lngOldLevel = lngLevel
    For lngLevel = 1 To lngLevel - 1 Step 2
        If blnMirror Then
            SnakeSortMerge varMirror, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), plngArray
        Else
            SnakeSortMerge plngArray, lngIndex(lngLevel - 1), lngIndex(lngLevel), lngIndex(lngLevel + 1), varMirror
        End If
        lngNewLevel = lngNewLevel + 1
        lngIndex(lngNewLevel) = Abs(lngIndex(lngLevel + 1))
    Next
    If lngOldLevel Mod 2 = 1 Then
        If blnMirror Then
            For i = lngIndex(lngNewLevel) + 1 To iMax
                SnakeMerge aeSnakesort, i, varMirror(i), lngIndex(lngNewLevel) + 1, iMax
                plngArray(i) = varMirror(i)
            Next
        Else
            For i = lngIndex(lngNewLevel) + 1 To iMax
                SnakeMerge aeSnakesort, i, plngArray(i), lngIndex(lngNewLevel) + 1, iMax
                varMirror(i) = plngArray(i)
            Next
        End If
        lngNewLevel = lngNewLevel + 1
        lngIndex(lngNewLevel) = lngIndex(lngOldLevel)
    End If
    lngLevel = lngNewLevel
    lngNewLevel = 0
    blnMirror = Not blnMirror
Loop
' Copy back to main array if necessary
If blnMirror Then
    For i = iMin To iMax
        SnakeMerge aeSnakesort, i, varMirror(i), iMin, iMax
        plngArray(i) = varMirror(i)
    Next
End If
End Sub

Private Sub SnakeSortMerge(pvarSource As Variant, plngLeft As Long, plngMid As Long, plngRight As Long, pvarDest As Variant)
Dim L As Long
Dim LMin As Long
Dim LMax As Long
Dim LStep As Long
Dim R As Long
Dim RMin As Long
Dim RMax As Long
Dim RStep As Long
Dim O As Long

If plngLeft <> 0 Then O = Abs(plngLeft) + 1
If plngMid > 0 Then
    LMin = O
    LMax = Abs(plngMid)
    LStep = 1
Else
    LMin = Abs(plngMid)
    LMax = O
    LStep = -1
End If
If plngRight > 0 Then
    RMin = Abs(plngMid) + 1
    RMax = Abs(plngRight)
    RStep = 1
Else
    RMin = Abs(plngRight)
    RMax = Abs(plngMid) + 1
    RStep = -1
End If
L = LMin
R = RMin
Do
    Compare aeSnakesort, Abs(plngLeft), Abs(plngRight)
    If pvarSource(L) <= pvarSource(R) Then
        SnakeMerge aeSnakesort, O, pvarSource(L), Abs(plngLeft), Abs(plngRight)
        pvarDest(O) = pvarSource(L)
        If L = LMax Then
            For R = R To RMax Step RStep
                O = O + 1
                SnakeMerge aeSnakesort, O, pvarSource(R), Abs(plngLeft), Abs(plngRight)
                pvarDest(O) = pvarSource(R)
            Next
            Exit Do
        End If
        L = L + LStep
    Else
        SnakeMerge aeSnakesort, O, pvarSource(R), Abs(plngLeft), Abs(plngRight)
        pvarDest(O) = pvarSource(R)
        If R = RMax Then
            For L = L To LMax Step LStep
                O = O + 1
                SnakeMerge aeSnakesort, O, pvarSource(L), Abs(plngLeft), Abs(plngRight)
                pvarDest(O) = pvarSource(L)
            Next
            Exit Do
        End If
        R = R + RStep
    End If
    O = O + 1
Loop
End Sub

Private Sub SnakeMerge(penGraph As AlgorithmEnum, plngIndex As Long, ByVal plngValue As Long, plngLeft As Long, plngRight As Long)
With grph(penGraph)
    .Exchanges = .Exchanges + 1
End With
LogOperation penGraph, oeMerge, plngLeft, plngRight, plngIndex, plngValue
End Sub

[Ellis Dee]

The most interesting feature of snake sort is that the more ordered the array is initially, the faster it runs. Each alogorithm has its own unique worst case scenario. Quick sort's worst case appears to be a camel hump, such as:

.1
.....5
.........9
.......7
...3

This puts the first pivot in the worst possible place, and it goes downhill from there. To see this in action, add this to the end of the seAscending Case in the GenerateArray() function:

            For i = 0 To 24
                mlngLines(i) = i * 4 + 1
                mlngLines(49 - i) = (i + 1) * 4 - 1
            Next

It would be logical to conclude that snake sort's worst case is alternating blocks of two. To see this, add this to the end of the seDescending Case:

            For i = 0 To 48 Step 2
                mlngLines(i) = (i * 2) + 3
                mlngLines(i + 1) = (i * 2) + 1
            Next

Finally, rename the SnakeSort() function to HeapSort(), and rename HeapSort() to something like HeapSortOld().

Snakesort is far more efficient on already ordered lists; virtually equal to bubblesort. It really shines on descending lists, where it can transform the array by looping only halfway through it and swapping the ends. (Comment out the added code from above to see it on ascending and descending lists.)

Most importantly, it's absolute worst case scenario is light years faster than quicksort's worst case. (Both scenarios are, IMO, unlikely in the extreme.) Given that the Time numbers are a rough approximation, where exchanges are assumed to take twice as long as comparisons and non-array comparisons and assignments are ignored, these are the Time numbers from the graphical screen:

Best case (ascending):
Quicksort: 317
Snakesort: 50 (absolute minimum + 1)

Descending:
Quicksort: 368
Snakesort: 100

Quicksort's worst case: (camel hump)
Quicksort: 884
Snakesort: 199

Snakesort's worst case: (thatched)
Quicksort: 408
Snakesort: 510

Random shuffle:
Quckisort: (roughly) 500
Snakesort: (roughly) 560

As you can see, snake sort approaches quicksort efficiency on randomly ordered lists, but gets much faster the moment any order presents itself, unlike quicksort.

(I find it odd that snake sort seems to process its "worst case" faster than it handles an arbitrary random case, but whatever.)

[Merri]

Your graphical time numbers aren't comparable to the real performance, because processing of the log can add a lot of processing into a loop that otherwise would work very quickly. But when you add the logging code in, it slows down the function a lot.

So you can only take a look at what results you get without graphical display's shown results.


(And I'm waiting for you to update the first post, I'm all too lazy to start going through the code now and putting it together, and I assume so are many others.)

[Ellis Dee]

It'll be a couple weeks, but it will be worth the wait. I'm incorporating the graphical screen in a more fundamental way, plus several new algorithms. (Your new shaker, shear, my snake sort, leinad's insertion sort if I can get it to work for any type of array, plus the joke sorts like bogosort.) I also want to expand the starting conditions to include true worst case scenarios instead of just inverted.

Everybody is welcome to contribute any idea they have for an algorithm. It doesn't have to be fast or efficient; all it has to do is sort.

As for the timing numbers, they at least give you a feel for what's going on. Here's some true timing numbers, each with three different trials (sorting the same array in the same trial):

Random Array - 99 elements
Snake sort: 0.00074, 0.00076, 0.00076 (Average: 0.00075)
Quick sort: 0.00078, 0.00077, 0.00080 (Average: 0.00078) -4%

Random Array - 999 elements
Snake sort: 0.0117, 0.0115, 0.0114 (Average: 0.0115)
Quick sort: 0.0142, 0.0128, 0.0125 (Average: 0.0132) -15%

Random Array - 9,999 elements
Snake sort: 0.172, 0.173, 0.154 (Average: 0.166)
Quick sort: 0.166, 0.175, 0.165 (Average: 0.169) -2%

Random Array - 99,999 elements
Snake sort: 2.122, 2.129, 2.125 (Average: 2.125)
Quick sort: 2.136, 2.123, 2.131 (Average: 2.130) -2%

Random Array - 999,999 elements
Quick sort: 25.189, 25.628, 25.113 (Average: 25.310)
Snake sort: 26.635, 26.230, 26.322 (Average: 26.396) -4%

Ascending order - 10,000 elements
Snake sort: 0.033
Quick sort: 0.096 -191%

Descending order - 10,000 elements
Snake sort: 0.011
Quick sort: 0.102 -827%

5% unsorted - 10,000 elements
Snake sort: 0.122
Quick sort: 0.130 -7%

Snake sort would appear to be competitive with quick sort.

[sunburnt]

It might be worth looking at the mathematical reason that some of these are faster than others.

Bubble Sort, Selection Sort, Insertion Sort and Shell Sort are all O(n²) algorithms. This means that as n (the number of items in the list) increases, the time it takes for the algorithm to run increases at a rate of n².


For example, if a list with 10 items may be sorted in 100 ms; A list with 100 items will take 10 seconds. As such, O(n²) Algorithms are not a good choice for sets with large amounts of data. (Obviously these exact times are made up; we aren't trying to determine how long it will take for a certain time, but rather how it scales.)

I see that you gave Heap, Merge, and Quicksort 'A's, which is right on the money. These sorts are O(nlog(n)), which means that the time does not increase as quickly when the number of items increases.

For example (using log base 2), a list with 10 items might take 33 ms to sort; a list with 100 items will then take 664 ms. A list with 1000 items will take just under 10 seconds. You can see that this is a marked improvement over the other sorts.

This is not to say that the other sorts are useless; for example, some of these algorithms will run very very quickly if you know that a list is almost sorted, whereas a more complicated algorithm will take more time.


An interesting special-case sort is the counting/bucket sort -- It's an O(n) algorithm, which means that the time it takes to run scales linearly with the number of items in the list; it can only be used when you can make specific claims about the data, however. It works by first counting the number of occurrences of each value, and then generating an array of those values in order.


You can find VB Code here and probably better C++ code at wikipedia

#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
#include <memory.h>

// data:  an array of unsorted integers
// data_size:  the number of integers in the 'data' array
// result:  an OUT parameter: where to store the sorted array
// min:  the minimum value of all elements in 'data'
// max:  the maximum value of all elements in 'data'.
void counting_sort(int* data, size_t data_size, int* result, int min, int max)
{
   size_t bucket_size = (max - min) + 1;
   
   // create an array for each of the values between 'max' and 'min':
   int bucket[bucket_size];

   // set each item in the bucket aray to 0.
   for(int i = 0; i < bucket_size; ++i)
   {
      bucket[i] = 0;
   }
   
   // for each item in the array
   for(int i = 0; i < data_size; ++i)
   {
      // convert the value in the array to an index into 'bucket'
      int index = data[i] - min;
      // increment the count for this value.
      bucket[index]++;
   }

   int result_index = 0;
   
   // now, build our result array:
   // for each value in the bucket:
   for(int i = 0; i < bucket_size; ++i)
   {     
      while(bucket[i]-- > 0)
	 result[result_index++] = i + min;
   }
}

// test it out:
int main()
{
   // array to sort
   int s[] = {7, 7, 8, 5,
	      6, 3, 1, 2,
	      4, 5, 6, 7,
	      8, 1, 1, 3};

   // result array
   int r[12];

   // print unsorted array
   for(int i = 0; i < 12; ++i)
      printf("%d ", s[i]);

   printf("\n");

   counting_sort(s, 12, r, 1, 8);

   // print sorted array
   for(int i = 0; i < 12; ++i)
      printf("%d ", r[i]);

   printf("\n");
}

Actually, if you go over the algorithm you'll see that the claim of O(n) is not exactly true; rather, the order is O(m+n) where m is the range of the data. With a small m and large n you can get good performance.


EDIT: I had to post using the code tag instead of the highlight tag because the highlight tag breaks the array notation making the code unreadable.

[AC_AC_AC187]

i've never actually used an array in vb6. but i need to create an array with the numbers 1 to 25 and shuffle them into a random order in the array, then take each number from that array seperately

[Ellis Dee]

i've never actually used an array in vb6. but i need to create an array with the numbers 1 to 25 and shuffle them into a random order in the array, then take each number from that array seperately

This isn't really the proper forum for such a question; the CodeBank is a repository for generic code.

If you create a new thread in the Classic Visual Basic forum, I (and no doubt many others) would be happy to help with your specific question.

[AC_AC_AC187]

sorry about that, i followed a link from the forum and didn't realise i was in the codebank...

could you please help me out here

[Ellis Dee]

sorry about that, i followed a link from the forum and didn't realise i was in the codebank...

could you please help me out here

It would appear that I already did last month. Ask any followup questions you have in that thread.

[NeedSomeAnswers]

The application no longer appears to be attached to the post !!??

[swinster]

Quirky question - should a sort algorithm be defined as a Function returning an array as the result or a procedure altering the array passed by reference?

[Milk]

Re: Quirky question, You could argue either way.. As a function you can always reassign the passed array with the return of the function, so it's nice and versitile. Obviously this will use twice the memory so if that is a concern then a Sub and ByRef is better.

Horses for courses

[randem]

Ellis Dee,

I used the QuickSort routine with an String array of 10000 with each element in sequential order (ex. String000000 - String049999) With these strings duplicated in the last 5000 entries. Now going thru the QuickSort I get Out Of Memory. This is definitely because of the recursiveness of the routine.

Did you know about this or is this the reason this routine is listed as Not Stable?

[Ellis Dee]

Ellis Dee,

I used the QuickSort routine with an String array of 10000 with each element in sequential order (ex. String000000 - String049999) With these strings duplicated in the last 5000 entries. Now going thru the QuickSort I get Out Of Memory. This is definitely because of the recursiveness of the routine.

Did you know about this or is this the reason this routine is listed as Not Stable?

Well that's no good. Could you post some (non)functional code to reproduce the error?

I must warn you, though, that this may possibly be just a limitation of the algorithm itself.

EDIT: And no, "Not Stable" doesn't mean it occasionally fails. heh. Stable and unstable refer to how the algorithm handles duplicate keys. Stable algorithms retain the original order, while unstable ones may shuffle them around. This doesn't matter for single-dimension arrays.

[randem]

Here ya go. Just press the command button to start... When it starts to sort the array, it will look not busy for a while then crash...

I am running 1.5ghz Intel, 2gb RAM with 1.5 gb free RAM and 47 gb free hard disk space

[Ellis Dee]

I hate saying this, but that's a feature, not a bug. (Okay, I actually love saying that.)

This happens to be the worst-case scenario for quicksort, where it performs on par with bubble sort. And since it uses recursion, it's unsurprising that it runs out of stack space. (Incidentally, when it comes to stack space, I'm not sure it matters how much memory you have.)

For a graphical representation of what's happening, run this project and select "thatched" order on the toolbar. (I replaced the thatched order with your order.) Have it sort and it becomes clear what's happening.

The worst case scenario I coded for quicksort is called "Camel Hump." Try that order as well for comparison. To really get the effect, isolate quicksort by clicking it and clicking filter on the toolbar.

Note that I implemented yoru sort order as a quickie hack, so it messes up the line definitions a little. Correct them by changing the filter.

It's worth pointing out that QuickSort3 (median of 3 partition technique) is much better at handling these worst case scenarios. It ends up being roughly quivalent to heap sort, but median of 3 technique has its own unique worst case stack killers.

This weakness is why heap sort is so popular for mission critical implementations. Unlike quicksort, heap sort doesn't have a worst case scenario where it degenerates into exponential iterations.

[Ellis Dee]

Also note that as far as I can tell, the absolute best all-purpose sorting algorithm when it comes to reliability, scalability, and efficiency is smooth sort. Sadly, I need help debugging the algorithm, and would dearly love any help you could give. (The code is in basGraphical.bas.)

If you can afford the expense of spending 2.5 times the memory of the original array, snake sort is the best comparison algorithm I've seen.