Author Topic: Sorting Methods. The Best and not necessarily fastest algorithms.  (Read 342 times)

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Sorting is one of the MOST commonly used procedures in data processing. It is also one of the MOST possibly confusing. Picking the correct weapon to use against the enemy (unsorted data) can mean the difference between a program's success or failure. I will present some of my favorites and those regularly shown in programming books and websites, However, my aim is to provide a comprehensive and tested code repository of library-quality code you can use in any program that requires sorting pf any kind and range to be performed flawlessly. I will add sequence verification and data integrity procedures later. Now feauring the latest and greatest: EVEN FASTER THAN FLASHSORT, 25% faster than ALL versions of QuickSort at 16777216 elements.
Code: [Select]
WIDTH 80, 40
REDIM array(0 TO 16777215) AS DOUBLE
REDIM b(0 TO UBOUND(array)) AS DOUBLE
FOR s& = LBOUND(array) TO UBOUND(array)
    array(s&) = (RND * (UBOUND(array) - LBOUND(array) + 1))
    b(s&) = array(s&)
NEXT
'* a simple test of EfficientMerge
REDIM a(0 TO 99) AS DOUBLE
a& = LBOUND(a)
b& = UBOUND(a)
c& = (b& - a&) \ 2
PRINT c&
FOR s& = a& TO c&
    a(s&) = s&
    PRINT a(s&);
NEXT
PRINT
FOR s& = c& + 1 TO b&
    a(s&) = s& - (c& + 1)
    PRINT a(s&);
NEXT
PRINT
EfficientMerge a(), a&, b&, 1
FOR s& = LBOUND(a) TO UBOUND(a)
    PRINT a(s&);
NEXT
ERASE a
PRINT
'DO
'    x$ = INKEY$
'LOOP UNTIL x$ > ""
'**************** THE END ************

[/code]
'*****************************
Code: [Select]
'******************************
'* KD Neubert FlashSort. Incredibly FAST numeric sort. This is a distribution sort, like BucketSort or PostSort, except far less overhead
'* in memory. Refactored By CodeGuy for the best clarity I can possibly provide. The original version has a .125(upperbound-lowerbound) array,
'* but was changed to .128(upperbound-lowerbound) avoid array bound errors. Tested. Fast. Works.
SUB FlashSort (Array() AS DOUBLE, start AS LONG, finish AS LONG, order&)
'* change these:
REDIM p(0 TO 2) AS LONG

DIM hold AS DOUBLE
DIM flash AS DOUBLE
DIM ANMiN AS DOUBLE
'* to the same type as the array being sorted

'* change these:
DIM KIndex AS LONG
DIM MIndex AS LONG
DIM SIndex AS LONG
'* to long for qbxx as qbxx has no _unsigned types

'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (INT(.128 * (finish - start + 1)) + 1) OR 2

'* change these:
DIM FlashTrackL(0 TO MIndex) AS LONG
DIM FlashI AS LONG
DIM FlashJ AS LONG
DIM NextFlashJ AS LONG
DIM FlashNMove AS LONG
DIM MaxValueIndex AS LONG
DIM MinValueIndex AS LONG
DIM FinishMinusOne AS LONG
'* to the appropriate type for the range being sorted (must match start, finish variables)

'* don't mess:
DIM FlashC1 AS DOUBLE '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)

' sorts array A with finish elements by use of
' index vector L with M elements, with M ca. 0.125(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy

'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4&) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well.

REM =============== CLASS FORMATION =================

ANMiN = Array(start)
MaxValueIndex = finish
MinValueIndex = start
FOR FlashI = start TO finish
    IF (Array(FlashI) > Array(MaxValueIndex)) THEN MaxValueIndex = FlashI
    IF (Array(FlashI) < Array(MinValueIndex)) THEN MinValueIndex = FlashI
NEXT FlashI
SWAP Array(MinValueIndex), Array(start): MinValueIndex = start: ANMiN = Array(MinValueIndex)
SWAP Array(MaxValueIndex), Array(finish): MaxValueIndex = finish

IF ANMiN = Array(MaxValueIndex) THEN
    '* this is a monotonic sequence array and by definition is already sorted
    EXIT SUB
END IF

DIM FlashTrackL(MIndex)
FlashC1 = (MIndex - 1) / (Array(MaxValueIndex) - ANMiN)

FOR FlashI = start + 1 TO finish - 1
    KIndex = INT(FlashC1 * (Array(FlashI) - ANMiN)) + 1
    FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
NEXT

FOR KIndex = LBOUND(FlashTrackL) + 1 TO MIndex
    FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
NEXT KIndex

REM ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
WHILE (FlashNMove < FinishMinusOne)
    WHILE (FlashJ > FlashTrackL(KIndex))
        FlashJ = FlashJ + 1
        KIndex = INT(FlashC1 * (Array(FlashJ) - ANMiN)) + 1
    WEND
    flash = Array(FlashJ)
    DO
        IF (FlashJ = (FlashTrackL(KIndex) + 1)) THEN
            EXIT DO
        ELSE
            IF FlashNMove < (FinishMinusOne) THEN
                KIndex = INT(FlashC1 * (flash - ANMiN)) + 1
                hold = Array(FlashTrackL(KIndex))
                Array(FlashTrackL(KIndex)) = flash
                flash = hold
                FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
                FlashNMove = FlashNMove + 1
            ELSE
                EXIT DO
            END IF
        END IF
    LOOP
WEND
'================= Insertion Sort============
FOR SIndex = LBOUND(FlashtrackL) + 1 TO MIndex
    '* sort subranges
    FOR FlashI = FlashTrackL(SIndex) - 1 TO FlashTrackL(SIndex - 1) STEP -1
        IF (Array(FlashI + 1) < Array(FlashI)) THEN
            hold = Array(FlashI)
            NextFlashJ = FlashI
            DO
                FlashJ = NextFlashJ
                IF FlashJ < FlashTrackL(SIndex) THEN
                    NextFlashJ = FlashJ + 1
                    IF (Array(NextFlashJ) < hold) THEN
                        SWAP Array(FlashJ), Array(NextFlashJ)
                    ELSE
                        EXIT DO
                    END IF
                ELSE
                    EXIT DO
                END IF
            LOOP
            Array(FlashJ) = hold
        END IF
    NEXT
    '* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
NEXT
IF order& = 1 THEN EXIT SUB
FlashI = start
FlashJ = finish
WHILE FlashJ > FlashI
    SWAP Array(FlashI), Array(FlashJ)
    FlashI = FlashI + 1
    FlashJ = FlashJ - 1
WEND
END SUB

'********************
'* InsertionSort is a simple to construct sort. Generally because of its O(n^2) running time, it's usually limited to VERY short runs
'* or used as a final sorting stage of many sorts. it is stable. The advantage of this sort for nearly sorted arrays is it runs in nearly O(n) time.
'********************
SUB InsertionSort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        FOR i& = start& + 1 TO finish&
            FOR j& = i& TO start& + 1 STEP -1
                IF Array(j& - 1) > Array(j&) THEN
                    SWAP Array(j&), Array(j& - 1)
                ELSE
                    EXIT FOR
                END IF
            NEXT
        NEXT
    CASE ELSE
        FOR i& = start& + 1 TO finish&
            FOR j& = i& TO start& + 1 STEP -1
                IF Array(j& - 1) < Array(j&) THEN
                    SWAP Array(j&), Array(j& - 1)
                ELSE
                    EXIT FOR
                END IF
            NEXT
        NEXT
END SELECT
END SUB

'******************************
'* ShellSort compares elements a gap distance apart, scans the array for out-of-order elements until none are
'* found and then continues reducing this gap distance until it reaches 0. It is not a stable sort, meaning elements
'* of equal value may appear in a position not the same order as it appears in the original array. It is reasonably easy to
'* code, adaptable for any data type and runs in reasonable time, thought to be around O(n^(5/4)). There are Numerous gap
'* reduction methods. The most "popular" being the (Gap/2) method. I have made several modifications to aid running time,
'* namely tracking the first and last position a swap occurred and using this to only scan to that point or less on successive
'* passes. The last pass of shellsort is the same as InsertionSort.
'******************************
SUB ShellSort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE finish& - start&
    CASE 1
        IF Array(start&) > Array(finish&) THEN
            IF order& = 1 THEN
                SWAP Array(start&), Array(finish&)
            END IF
        END IF
    CASE IS > 1
        IF order& = 1 THEN
            ShellSortGap& = (finish& - start&) \ 2
            DO
                IF ShellSortGap& > 1 THEN
                    LoopCount& = 0
                    xstart& = start&
                    xfinish& = finish& - ShellSortGap&
                    MaxPasses& = (finish& - start&) \ ShellSortGap&
                    DO
                        xfirst& = xfinish&
                        FOR ShellSortS& = xstart& TO xfinish&
                            IF Array(ShellSortS&) > Array(ShellSortS& + ShellSortGap&) THEN
                                SWAP Array(ShellSortS&), Array(ShellSortS& + ShellSortGap&)
                                Last& = ShellSortS&
                                IF ShellSortS& < xfirst& THEN
                                    xfirst& = ShellSortS&
                                END IF
                            END IF
                        NEXT
                        xfinish& = Last&
                        xstart& = xfirst&
                        LoopCount& = LoopCount& + 1
                    LOOP WHILE LoopCount& < MaxPasses& AND (xfinish& - xstart&) >= ShellSortGap&
                    ShellSortGap& = ShellSortGap& \ 2
                ELSE
                    InsertionSort Array(), start&, finish&, order&
                    EXIT DO
                END IF
            LOOP
        ELSE
            ShellSortGap& = (finish& - start&) \ 2
            DO
                IF ShellSortGap& > 1 THEN
                    LoopCount& = 0
                    xstart& = start&
                    xfinish& = finish& - ShellSortGap&
                    MaxPasses& = (finish& - start&) \ ShellSortGap&
                    DO
                        xfirst& = xfinish&
                        FOR ShellSortS& = xstart& TO xfinish&
                            IF Array(ShellSortS&) < Array(ShellSortS& + ShellSortGap&) THEN
                                SWAP Array(ShellSortS&), Array(ShellSortS& + ShellSortGap&)
                                Last& = ShellSortS&
                                IF ShellSortS& < xfirst& THEN
                                    xfirst& = ShellSortS&
                                END IF
                            END IF
                        NEXT
                        xfinish& = Last&
                        xstart& = xfirst&
                        LoopCount& = LoopCount& + 1
                    LOOP WHILE LoopCount& < MaxPasses& AND (xfinish& - xstart&) >= ShellSortGap&
                    ShellSortGap& = ShellSortGap& \ 2
                ELSE
                    InsertionSort Array(), start&, finish&, order&
                    EXIT DO
                END IF
            LOOP

        END IF
END SELECT
END SUB

'*******************************************
'* this has been modified to become a bidirectional shellsort, which is far faster than the bubblesort version, which is a special case where
'* gap& is 1, and runs in polynomial o(n^1(5/4)) time when like its unidirectional predecessor. Not Stable. No practical use in real life I've
'* seen, but entertaining if visualized.
'*******************************************
SUB ShellSortBidirectional (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        gap& = (finish& - start& + 1) \ 2
        DO
            up% = -1: down% = -1: passes& = 0: maxpasses& = (finish& - start& + 1) \ gap& - 1
            startup& = start&: endup& = finish& - gap&: FirstUp& = finish& - gap&: LastUp& = start&
            startdn& = finish&: enddown& = start& + gap&: FirstDown& = start& + gap&: LastDown& = finish&
            passes& = 0
            DO
                IF up% THEN
                    up% = 0
                    FOR i& = startup& TO endup&
                        IF Array(i&) > Array(i& + gap&) THEN
                            SWAP Array(i&), Array(i& + gap&)
                            IF i& < FirstUp& THEN
                                FirstUp& = i&
                            END IF
                            LastUp& = i&
                            up% = -1
                        END IF
                    NEXT
                    startup& = FirstUp&
                    endup& = LastUp&
                    SWAP FirstUp&, LastUp&
                END IF
                '*******************************
                IF down% THEN
                    down% = 0
                    FOR i& = startdn& TO enddown& STEP -1
                        IF Array(i&) < Array(i& - gap&) THEN
                            SWAP Array(i&), Array(i& - gap&)
                            IF i& > FirstDown& THEN
                                FirstDown& = i&
                            END IF
                            LastDown& = i&
                            down% = -1
                        END IF
                    NEXT
                    startdn& = FirstDown&
                    enddown& = LastDown&
                    SWAP FirstDown&, LastDown&
                END IF
                IF passes& < maxpasses& THEN
                    IF up% OR down% THEN
                        IF passes& < (enddown& - startdown&) \ gap& - 1 OR passes& < (endup& - startup&) \ gap& - 1 THEN
                            passes& = passes& + 1
                        ELSE
                            EXIT DO
                        END IF
                    ELSE
                        EXIT DO
                    END IF
                ELSE
                    EXIT DO
                END IF
            LOOP
            gap& = gap& \ 2
        LOOP WHILE gap& > 0
    CASE ELSE
        gap& = (finish& - start& + 1) \ 2
        DO
            up% = -1: down% = -1: passes& = 0: maxpasses& = (finish& - start& + 1) \ gap& - 1
            startup& = start&: endup& = finish& - gap&: FirstUp& = finish& - gap&: LastUp& = start&
            startdn& = finish&: enddown& = start& + gap&: FirstDown& = start& + gap&: LastDown& = finish&
            DO
                IF up% THEN
                    up% = 0
                    FOR i& = startup& TO endup&
                        IF Array(i&) < Array(i& + gap&) THEN
                            SWAP Array(i&), Array(i& + gap&)
                            IF i& < FirstUp& THEN
                                FirstUp& = i&
                            END IF
                            LastUp& = i&
                            up% = -1
                        END IF
                    NEXT
                    startup& = FirstUp&
                    endup& = LastUp&
                    SWAP FirstUp&, LastUp&
                END IF
                '*******************************
                IF down% THEN
                    down% = 0
                    FOR i& = startdn& TO enddown& STEP -1
                        IF Array(i&) > Array(i& - gap&) THEN
                            SWAP Array(i&), Array(i& - gap&)
                            IF i& > FirstDown& THEN
                                FirstDown& = i&
                            END IF
                            LastDown& = i&
                            down% = -1
                        END IF
                    NEXT
                    startdn& = FirstDown&
                    enddown& = LastDown&
                    SWAP FirstDown&, LastDown&
                END IF
                IF passes& < maxpasses& THEN
                    IF up% OR down% THEN
                        IF passes& < (enddown& - startdown&) \ gap& - 1 OR passes& < (endup& - startup&) \ gap& - 1 THEN
                            passes& = passes& + 1
                        ELSE
                            EXIT DO
                        END IF
                    ELSE
                        EXIT DO
                    END IF
                ELSE
                    EXIT DO
                END IF
            LOOP
            gap& = gap& \ 2
        LOOP WHILE gap& > 0
END SELECT
END SUB

'*******************************************
'* TESTED -- WORKS
'* QuickSortRecursive is reputedly the "fastest sort." This is not true in all cases. One way to defeat QuickSort and send it into
'* polynomial time O(n^2) is to presemt it with an already-sorted array. There are safeguards to this. One to shuffle the array
'* before executing quicksort or in the case of IntroSort, revert to MergeSort once a certain level of recursion or InsertionSort
'* once a small (usually 15-31) sublist size is reached.
'* Often mistakenly referred to as the fastest sort, it does around NLogN comparisons, which is the lower bound for
'* comparison sorts. Fast? Generally, but not always. This is the recursive version, fine for most modern processors that support
'* the use of hardware stacks. This is a divide-and-conquer algorithm as is MergeSort.

SUB QuickSortRecursive (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE finish& - start&
    CASE 1
        '* This is CRITICAL
        SELECT CASE order&
            CASE 1
                IF Array(start&) > Array(finish&) THEN
                    SWAP Array(start&), Array(finish&)
                END IF
            CASE ELSE
                IF Array(start&) < Array(finish&) THEN
                    SWAP Array(start&), Array(finish&)
                END IF
        END SELECT
    CASE IS > 1
        QuickSortIJ Array(), start&, finish&, i&, j&, order&
        IF (i& - start&) < (finish& - j&) THEN
            QuickSortRecursive Array(), start&, j&, order&
            QuickSortRecursive Array(), i&, finish&, order&
        ELSE
            QuickSortRecursive Array(), i&, finish&, order&
            QuickSortRecursive Array(), start&, j&, order&
        END IF
END SELECT
END SUB

'*********************************
'* TESTED -- WORKS
'* This is the iterative version of QuickSort, using a software stack, useful for OLD processors lacking hardware registers to support
'* recursion. Operationally, it is very much the same as the recursive version except the "stack" is software-based.

SUB QuickSortIterative (Array() AS DOUBLE, Start&, Finish&, order&)
DIM compare AS DOUBLE
MinStack& = LOG(Finish& - Start& + 1) \ LOG(2) + 1
DIM LStack&(MinStack&, 1)
StackPtr& = 0
LStack&(StackPtr&, 0) = Start&
LStack&(StackPtr&, 1) = Finish&
DO
    Low& = LStack&(StackPtr&, 0)
    Hi& = LStack&(StackPtr&, 1)
    DO
        i& = Low&
        j& = Hi&
        Mid& = Low& + (Hi& - Low& + 1) \ 2
        compare = Array(Mid&)
        SELECT CASE order&
            CASE 1
                DO
                    DO WHILE Array(i&) < compare
                        i& = i& + 1
                    LOOP
                    DO WHILE Array(j&) > compare
                        j& = j& - 1
                    LOOP
                    IF i& <= j& THEN
                        SWAP Array(i&), Array(j&)
                        i& = i& + 1
                        j& = j& - 1
                    END IF
                LOOP UNTIL i& > j&
            CASE ELSE
                DO
                    DO WHILE Array(i&) > compare
                        i& = i& + 1
                    LOOP
                    DO WHILE Array(j&) < compare
                        j& = j& - 1
                    LOOP
                    IF i& <= j& THEN
                        SWAP Array(i&), Array(j&)
                        i& = i& + 1
                        j& = j& - 1
                    END IF
                LOOP UNTIL i& > j&
        END SELECT
        IF j& - Low& < Hi& - i& THEN
            IF i& < Hi& THEN
                LStack&(StackPtr&, 0) = i&
                LStack&(StackPtr&, 1) = Hi&
                StackPtr& = StackPtr& + 1
            END IF
            Hi& = j&
        ELSE
            IF Low& < j& THEN
                LStack&(StackPtr&, 0) = Low&
                LStack&(StackPtr&, 1) = j&
                StackPtr& = StackPtr& + 1
            END IF
            Low& = i&
        END IF
    LOOP WHILE Low& < Hi&
    StackPtr& = StackPtr& - 1
LOOP UNTIL StackPtr& < 0
END SUB

'************************
'* TESTED -- WORKS
'* Yaroslavsky Dual-pivot QuickSort is useful for arrays having many repeating elements. Will still fail on some inputs but better than standard QuickSort
'* for the same lack of entropy in an array. This is a version of the standard Java QuickSort. There is a 3-pivot version, also adaptive.
SUB QuickSortDualPivot (Array() AS DOUBLE, start&, finish&, order&)
DIM CompareP AS DOUBLE
DIM CompareQ AS DOUBLE
IF start& < finish& THEN
    CompareP = Array(start&)
    CompareQ = Array(finish&)
    IF order& = 1 THEN
        IF CompareP > CompareQ THEN
            SWAP Array(start&), Array(finish&)
            SWAP CompareP, CompareQ
        END IF
    ELSE
        IF CompareP < CompareQ THEN
            SWAP Array(start&), Array(finish&)
            SWAP CompareP, CompareQ
        END IF
    END IF
    l& = start& + 1
    k& = l&
    g& = finish& - 1
    SELECT CASE order&
        CASE 1
            WHILE k& <= g&
                IF Array(k&) < CompareP THEN
                    SWAP Array(k&), Array(l&)
                    l& = l& + 1
                ELSE
                    IF Array(k&) >= CompareQ THEN
                        WHILE Array(g&) >= CompareQ AND k& < g&
                            g& = g& - 1
                        WEND
                        SWAP Array(k&), Array(g&)
                        g& = g& - 1
                        IF Array(k&) <= CompareP THEN
                            SWAP Array(k&), Array(l&)
                            l& = l& + 1
                        END IF
                    END IF
                END IF
                k& = k& + 1
            WEND
        CASE ELSE
            WHILE k& <= g&
                IF Array(k&) > CompareP THEN
                    SWAP Array(k&), Array(l&)
                    l& = l& + 1
                ELSE
                    IF Array(k&) <= CompareQ THEN
                        WHILE Array(g&) <= CompareQ AND k& < g&
                            g& = g& - 1
                        WEND
                        SWAP Array(k&), Array(g&)
                        g& = g& - 1
                        IF Array(k&) >= CompareP THEN
                            SWAP Array(k&), Array(l&)
                            l& = l& + 1
                        END IF
                    END IF
                END IF
                k& = k& + 1
            WEND
    END SELECT
    l& = l& - 1
    g& = g& + 1
    SWAP Array(start&), Array(l&)
    SWAP Array(finish&), Array(g&)
    QuickSortDualPivot Array(), start&, l& - 1, order&
    QuickSortDualPivot Array(), l& + 1, g& - 1, order&
    QuickSortDualPivot Array(), g& + 1, finish&, order&
END IF
END SUB

'***********************
'* MergeSort is an O(NlogN) complexity divide and conquer stable sorting algorithm. The primary source of lag is the array copying.
'* The number of recurive calls is the same as the number of elements. If stability and predictable, undefeatable running time are your
'* sorting goals, this is an excellent choice. The memory overhead is approximately N plus a few variables.

SUB mergeSort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE finish& - start&
    CASE IS > 31
        middle& = start& + (finish& - start&) \ 2
        mergeSort Array(), start&, middle&, order&
        mergeSort Array(), middle& + 1, finish&, order&
        IF order& = 1 THEN
            EfficientMerge Array(), start&, finish&, order&
        ELSE
            MergeRoutine Array(), start&, finish&, order&
        END IF
    CASE IS > 0
        InsertionSort Array(), start&, finish&, order&
END SELECT
END SUB

SUB bubblesort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        DO
            changed& = 0
            FOR I& = start& TO finish& - 1
                IF Array(I&) > Array(I& + 1) THEN
                    SWAP Array(I&), Array(I& + 1)
                    changed& = -1
                END IF
            NEXT
        LOOP WHILE changed&
    CASE ELSE
        DO
            changed& = 0
            FOR I& = start& TO finish& - 1
                IF Array(I&) < Array(I& + 1) THEN
                    SWAP Array(I&), Array(I& + 1)
                    changed& = -1
                END IF
            NEXT
        LOOP WHILE changed&
END SELECT
END SUB

'**************************
'* another variation of bubblesort, CocktailSort also runs in o(n^2) and essentially scans up and down the array swapping out-of-order
'* elements until none are found. Stable,

SUB CocktailSort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        runs& = 0
        DO
            p& = finish& - runs&
            done& = 1 '* assume it's sorted
            FOR i& = start& + runs& TO finish& - runs& - 1
                IF Array(i&) > Array(i& + 1) THEN
                    SWAP Array(i&), Array(i& + 1)
                    done& = 0
                END IF
                IF Array(p&) < Array(p& - 1) THEN
                    SWAP Array(p&), Array(p& - 1)
                    done& = 0
                END IF
                p& = p& - 1
            NEXT
            runs& = runs& + 1
        LOOP UNTIL done&
    CASE ELSE
        runs& = 0
        DO
            p& = finish& - runs&
            done& = 1 '* assume it's sorted
            FOR i& = start& + runs& TO finish& - runs& - 1
                IF Array(i&) < Array(i& + 1) THEN
                    SWAP Array(i&), Array(i& + 1)
                    done& = 0
                END IF
                IF Array(p&) > Array(p& - 1) THEN
                    SWAP Array(p&), Array(p& - 1)
                    done& = 0
                END IF
                p& = p& - 1
            NEXT
            runs& = runs& + 1
        LOOP UNTIL done&
END SELECT
END SUB

'**********************
'* helper function for InsertionSortBinary exactly the same as a binary search which runs in o(logN) time.
FUNCTION BinaryB& (Array() AS DOUBLE, start&, Nio&)
Bsrcha& = start&
BsrchB& = start& + Nio&
DO
    BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
    IF Array(BsrchC&) < Array(Nio&) THEN
        Bsrcha& = BsrchC& + 1
    ELSE
        BsrchB& = BsrchC&
    END IF
LOOP WHILE Bsrcha& < BsrchB&
BinaryB& = BsrchB&
END FUNCTION

'*****************************
'* InsertionSortBinary uses Binary Search to find the correct position of an array element in the portion already sorted.
'* It's approximately 25 percent faster than standard InsertionSort.
SUB InsertionSortBinary (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        Nsorted& = 0
        DO
            f& = BinaryB&(Array(), start&, Nsorted&)
            p& = start& + Nsorted&
            WHILE p& > f&
                x& = p& - 1
                SWAP Array(p&), Array(x&)
                p& = x&
            WEND
            Nsorted& = Nsorted& + 1
        LOOP UNTIL Nsorted& > finish& - start&
    CASE ELSE
        Nsorted& = 0
        DO
            f& = BinaryB&(Array(), start&, Nsorted&)
            p& = start& + Nsorted&
            WHILE p& > f&
                x& = p& - 1
                SWAP Array(p&), Array(x&)
                p& = x&
            WEND
            Nsorted& = Nsorted& + 1
        LOOP UNTIL Nsorted& > finish& - start&
        IF Array(start&) <> Array(finish&) THEN
            StableInvert Array(), start&, finish&, 1
        END IF
END SELECT
END SUB

SUB StableInvert (Array() AS DOUBLE, start&, finish&, dorecurse&)
'* first invert then invert the equal elements
a& = start&
b& = finish&
WHILE a& < b&
    SWAP Array(a&), Array(b&)
    a& = a& + 1
    b& = b& - 1
WEND
IF dorecurse& THEN
    '* then scan the array for runs of equal elements
    p& = start&
    DO
        IF p& < finish& THEN
            y& = p& + 1
            DO
                IF Array(p&) = Array(y&) THEN
                    IF y& < finish& THEN
                        y& = y& + 1
                    ELSE
                        StableInvert Array(), p&, y&, 0
                        EXIT DO
                    END IF
                ELSE
                    EXIT DO
                END IF
            LOOP
            p& = y&
        ELSE
            EXIT DO
        END IF
    LOOP
END IF
END SUB

'*****************************************
'* BucketSort
'*****************************************
SUB BucketSort (Array() AS DOUBLE, start&, finish&, order&)
NBuckets& = 32
N& = (finish& - start&)
r& = N& MOD NBuckets&
REDIM Buckets(0 TO (NBuckets& * (1 + (N& - r&) / NBuckets&))) AS LONG
REDIM counts(0 TO NBuckets& - 1) AS LONG
BucketSize& = (N& - r&) / NBuckets&
T& = UBOUND(buckets)
s& = NBuckets& - 1
DO
    counts(s&) = T&
    T& = T& - BucketSize&
    s& = s& + 1
LOOP UNTIL s& < 0
GetMinMaxArray Array(), start&, finish&, a&, b&
Range# = Array(b&) - Array(a&)
IF Range# > 0 THEN
    FOR s& = start& TO finish&
        Index& = (NBuckets& - 1) * ((Array(s&) - Array(a&)) / ramge#)
        Buckets(counts(Index&)) = Array(s&)
        counts(Index&) = counts(Index&) - 1
    NEXT
END IF
END SUB

SUB InsertionSortx (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        FOR i& = start& TO finish&
            j& = i&
            WHILE (j& > start&)
                p& = j& - 1
                IF Array(p&) > Array(j&) THEN
                    SWAP Array(p&), Array(j&)
                    j& = p&
                ELSE
                    EXIT WHILE
                END IF
            WEND
        NEXT
    CASE ELSE
        FOR i& = start& TO finish&
            j& = i&
            WHILE (j& > start&)
                p& = j& - 1
                IF Array(p&) < Array(j&) THEN
                    SWAP Array(p&), Array(j&)
                    j& = p&
                ELSE
                    EXIT WHILE
                END IF
            WEND
        NEXT
END SELECT
END SUB

SUB HeapSort (Array() AS DOUBLE, Start&, Finish&, order&)
FOR i& = Start& + 1 TO Finish&
    PercolateUp Array(), Start&, i&, order&
NEXT i&

FOR i& = Finish& TO Start& + 1 STEP -1
    SWAP Array(Start&), Array(i&)
    PercolateDown Array(), Start&, i& - 1, order&
NEXT i&
END SUB

SUB PercolateDown (Array() AS DOUBLE, Start&, MaxLevel&, order&)
i& = Start&
' Move the value in GetPixel&(Start&) down the heap until it has
' reached its proper node (that is, until it is less than its parent
' node or until it has reached MaxLevel&, the bottom of the current heap):
DO
    Child& = 2 * (i& - Start&) + Start& ' Get the subscript for the Child& node.
    ' Reached the bottom of the heap, so exit this procedure:
    IF Child& > MaxLevel& THEN EXIT DO
    SELECT CASE order&
        CASE 1
            ' If there are two Child nodes, find out which one is bigger:
            ax& = Child& + 1
            IF ax& <= MaxLevel& THEN
                IF Array(ax&) > Array(Child&) THEN
                    Child& = ax&
                END IF
            END IF

            ' Move the value down if it is still not bigger than either one of
            ' its Child&ren:
            IF Array(i&) < Array(Child&) THEN
                SWAP Array(i&), Array(Child&)
                i& = Child&

                ' Otherwise, array() has been restored to a heap from start& to MaxLevel&,
                ' so exit:
            ELSE
                EXIT DO
            END IF
        CASE ELSE
            ' If there are two Child nodes, find out which one is smaller:
            ax& = Child& + 1
            IF ax& <= MaxLevel& THEN
                IF Array(ax&) < Array(Child&) THEN
                    Child& = ax&
                END IF
            END IF

            ' Move the value down if it is still not smaller than either one of
            ' its Child&ren:
            IF Array(i&) > Array(Child&) THEN
                SWAP Array(i&), Array(Child&)
                i& = Child&

                ' Otherwise, array() has been restored to a heap from start& to MaxLevel&,
                ' so exit:
            ELSE
                EXIT DO
            END IF
    END SELECT
LOOP
END SUB

SUB PercolateUp (Array() AS DOUBLE, Start&, MaxLevel&, order&)
SELECT CASE order&
    CASE 1
        i& = MaxLevel&
        ' Move the value in array(MaxLevel&) up the heap until it has
        ' reached its proper node (that is, until it is greater than either
        ' of its Child& nodes, or until it has reached 1, the top of the heap):
        DO UNTIL i& = Start&
            Parent& = Start& + (i& - Start&) \ 2 ' Get the subscript for the parent node.
            ' The value at the current node is still bigger than the value at
            ' its parent node, so swap these two array elements:
            IF Array(i&) > Array(Parent&) THEN
                SWAP Array(Parent&), Array(i&)
                i& = Parent&

                ' Otherwise, the element has reached its proper place in the heap,
                ' so exit this procedure:
            ELSE
                EXIT DO
            END IF
        LOOP
    CASE ELSE
        i& = MaxLevel&
        ' Move the value in array(MaxLevel&) up the heap until it has
        ' reached its proper node (that is, until it is greater than either
        ' of its Child& nodes, or until it has reached 1, the top of the heap):
        DO UNTIL i& = Start&
            Parent& = Start& + (i& - Start&) \ 2 ' Get the subscript for the parent node.
            ' The value at the current node is still smaller than the value at
            ' its parent node, so swap these two array elements:
            IF Array(i&) < Array(Parent&) THEN
                SWAP Array(Parent&), Array(i&)
                i& = Parent&

                ' Otherwise, the element has reached its proper place in the heap,
                ' so exit this procedure:
            ELSE
                EXIT DO
            END IF
        LOOP
END SELECT
END SUB

'****************************************
'* The IntroSort() algorithm extended to QBxx because there is no qbxx-compatible code
'* The IntroSort algorithm extended to qb64 because i could find no pure qbxx code
'* 03Jun2017, by CodeGuy -- further mods for use in sorting library 03 Aug 2017
'* Introspoective Sort (IntroSort) falls back to MergeSort after so many levels of
'* recursion and is good for highly redundant data (aka few unique)
'* for very short runs, it falls back to InsertionSort.

SUB IntroSort (Array() AS DOUBLE, start&, finish&, order&)
STATIC level&
STATIC MaxRecurseLevel&
MaxRecurseLevel& = 15
IF start& < finish& THEN
    IF finish& - start& > 31 THEN
        IF level& > MaxRecurseLevel& THEN
            HeapSort Array(), start&, finish&, order&
        ELSE
            level& = level& + 1
            QuickSortIJ Array(), start&, finish&, i&, j&, order&
            IntroSort Array(), start&, j&, order&
            IntroSort Array(), i&, finish&, order&
            level& = level& - 1
        END IF
    ELSE
        InsertionSort Array(), start&, finish&, order&
    END IF
END IF
END SUB

SUB QuickSortIJ (Array() AS DOUBLE, start&, finish&, i&, j&, order&)
DIM Compare AS DOUBLE '* MUST be the same type as array()
i& = start&
j& = finish&
Compare = Array(i& + (j& - i&) \ 2)
SELECT CASE order&
    CASE 1
        DO
            DO WHILE Array(i&) < Compare
                i& = i& + 1
            LOOP
            DO WHILE Array(j&) > Compare
                j& = j& - 1
            LOOP
            IF i& <= j& THEN
                IF i& <> j& THEN
                    SWAP Array(i&), Array(j&)
                END IF
                i& = i& + 1
                j& = j& - 1
            END IF
        LOOP UNTIL i& > j&
    CASE ELSE
        DO
            DO WHILE Array(i&) > Compare
                i& = i& + 1
            LOOP
            DO WHILE Array(j&) < Compare
                j& = j& - 1
            LOOP
            IF i& <= j& THEN
                IF i& <> j& THEN
                    SWAP Array(i&), Array(j&)
                END IF
                i& = i& + 1
                j& = j& - 1
            END IF
        LOOP UNTIL i& > j&
END SELECT
END SUB

SUB GetMinMaxArray (Array() AS DOUBLE, start&, finish&, MinIndex&, MaxIndex&)
MinIndex& = start&
MaxIndex& = start&
FOR s& = start& TO finish&
    IF Array(s&) < Array(MinIndex&) THEN MinIndex& = s&
    IF Array(s&) > Array(MaxIndex&) THEN MaxIndex& = s&
NEXT
END SUB

'*********************************
'* The Standard Merge Algorithm extended to ascending or descending order
'* same tactic as MergeSort, but only MergeSorts halves amd then merges, with o(NlogN) for each half with straight Merge
'* the benefit of this method is not only faster completion but also a 50% reduction in array allocation and copying.
'* this approach can be used in pretty much any sort to yield a faster sort, including the already-fast FlashSort. I will
'* attempt a string version of FlashSort. It will be complex.
'*********************************
SUB MergeTwoWay (Array() AS DOUBLE, start&, finish&, order&)
middle& = start& + (finish& - start&) \ 2
mergeSort Array(), start&, middle&, order&
mergeSort Array(), middle& + 1, finish&, order&
IF order& = 1 THEN
    EfficientMerge Array(), start&, finish&, order&
ELSE
    MergeRoutine Array(), start&, finish&, order&
END IF
END SUB

'**********************
'* Standardized Merge procedure. Assumes array(start to middle), (middle+1 to finish) is already sorted on arrival.
'**********************
SUB MergeRoutine (Array() AS DOUBLE, start&, finish&, order&)
length& = finish& - start&
middle& = start& + length& \ 2
DIM temp(0 TO length&)
FOR i& = 0 TO length&
    temp(i&) = Array(start& + i&)
NEXT
'* for refactoring purposes,
'* mptr& = 0
'* sptr& = middle& - start& + 1
'* could be omitted from the select case blocks and declared here instead. However, I am leaving them as is
'* so code between SELECT CASE conditional checks can simply be copied for a fully functioning merge.

SELECT CASE order&
    CASE 1
        mptr& = 0
        sptr& = middle& - start& + 1
        FOR i& = 0 TO length&
            IF sptr& <= finish& - start& THEN
                IF mptr& <= middle& - start& THEN
                    IF temp(mptr&) > temp(sptr&) THEN
                        Array(i& + start&) = temp(sptr&)
                        sptr& = sptr& + 1
                    ELSE
                        Array(i& + start&) = temp(mptr&)
                        mptr& = mptr& + 1
                    END IF
                ELSE
                    Array(i& + start&) = temp(sptr&)
                    sptr& = sptr& + 1
                END IF
            ELSE
                Array(i& + start&) = temp(mptr&)
                mptr& = mptr& + 1
            END IF
        NEXT
    CASE ELSE
        mptr& = 0
        sptr& = middle& - start& + 1
        FOR i& = 0 TO length&
            IF sptr& <= finish& - start& THEN
                IF mptr& <= middle& - start& THEN
                    '* i see what you did there -- change from
                    '* temp(mptr&) > temp(sptr&) to temp(sptr&) > temp(mptr&)
                    IF temp(sptr&) > temp(mptr&) THEN
                        Array(i& + start&) = temp(sptr&)
                        sptr& = sptr& + 1
                    ELSE
                        Array(i& + start&) = temp(mptr&)
                        mptr& = mptr& + 1
                    END IF
                ELSE
                    Array(i& + start&) = temp(sptr&)
                    sptr& = sptr& + 1
                END IF
            ELSE
                Array(i& + start&) = temp(mptr&)
                mptr& = mptr& + 1
            END IF
        NEXT
END SELECT
ERASE temp
END SUB

FUNCTION SequenceCheck& (Array() AS DOUBLE, start&, finish&, order&)
SequenceCheck& = start&
i& = start&
SELECT CASE order&
    CASE 1
        FOR j& = start& + 1 TO finish&
            IF Array(j&) > Array(i&) THEN
                i& = j& '
            ELSEIF Array(j&) < Array(i&) THEN
                SequenceCheck& = j&
                EXIT FUNCTION
            END IF
        NEXT
    CASE ELSE
        FOR j& = start& + 1 TO finish&
            IF Array(j&) < Array(i&) THEN
                i& = j& '
            ELSEIF Array(j&) > Array(i&) THEN
                SequenceCheck& = j&
                EXIT FUNCTION
            END IF
        NEXT
END SELECT
SequenceCheck& = finish&
END FUNCTION

'***************************************************************************
'* string-specific code
'***************************************************************************
SUB FlashString (Strarray() AS STRING, start&, finish&, order&)
TYPE FlashRec
    Number AS _INTEGER64
    Index AS LONG
END TYPE
REDIM FlashStringArray(start& TO finish&) AS FlashRec
DIM shift##(0 TO 7)
IF order& = 1 THEN
    shift##(7) = 1
    FOR z% = 6 TO 0 STEP -1
        shift##(z%) = shift##(z% + 1) * 256
    NEXT
ELSE
    shift##(0) = 1
    FOR z% = 1 TO 7
        shift##(z%) = shift##(z% - 1) * 256
    NEXT
END IF
FOR s& = start& TO finish&
    acc## = 0
    WHILE z% < 8
        zp% = z% + 1
        p$ = MID$(Strarray(s&), zp%, 1)
        IF p$ > "" THEN
            acc## = acc## + shift##(z%) * ASC(p$)
            z% = zp%
        ELSE
            EXIT WHILE
        END IF
    WEND
    FlashStringArray(s&).Number = acc##
    FlashStringArray(s&).Index = s&
NEXT
flashSORTType FlashStringArray(), start&, finish&, order&
END SUB

SUB flashSORTType (Array() AS FlashRec, start AS DOUBLE, finish AS DOUBLE, iorder AS _BYTE)
'* change these:
DIM hold AS FlashRec
DIM flash AS FlashRec
DIM ANMiN AS FlashRec
'* to the same type as the array being sorted

'* change these:
DIM KIndex AS _UNSIGNED LONG
DIM MIndex AS _UNSIGNED LONG
DIM SIndex AS _UNSIGNED LONG
'* to long for qbxx as qbxx has no _unsigned types

'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (INT(.128 * (finish - start + 1)) + 1) OR 2

'* change these:
DIM FlashTrackL(0 TO MIndex) AS DOUBLE
DIM FlashI AS DOUBLE
DIM FlashJ AS DOUBLE
DIM NextFlashJ AS DOUBLE
DIM FlashNMove AS DOUBLE
DIM MaxValueIndex AS DOUBLE
DIM FinishMinusOne AS DOUBLE
'* to the appropriate type for the range being sorted (must match start, finish variables)

'* don't mess:
DIM FlashC1 AS DOUBLE '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)

' sorts array A with finish elements by use of
' index vector FlashTrackL with MIndex elements, with MIndex ca. 0.125(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy

'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4%) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well.

REM =============== CLASS FORMATION =================

ANMiN = Array(start)
MaxValueIndex = start
FOR FlashI = start TO finish
    IF (Array(FlashI).Number > Array(MaxValueIndex).Number) THEN MaxValueIndex = FlashI
    IF (Array(FlashI).Number < ANMiN.Number) THEN
        ANMiN = Array(FlashI)
        SWAP Array(start), Array(FlashI)
    END IF
NEXT FlashI

IF ANMiN.Number = Array(MaxValueIndex).Number THEN
    '* this is a monotonic sequence array and by definition is already sorted
    EXIT SUB
END IF

DIM FlashTrackL(MIndex)
FlashC1 = (MIndex - 1) / (Array(MaxValueIndex).Number - ANMiN.Number)

FOR FlashI = start + 1 TO finish
    KIndex = INT(FlashC1 * (Array(FlashI).Number - ANMiN.Number)) + 1
    FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
NEXT

FOR KIndex = LBOUND(FlashTrackL) + 1 TO MIndex
    FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
NEXT KIndex

REM ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
SWAP Array(finish), Array(MaxValueIndex)
WHILE (FlashNMove < FinishMinusOne)
    WHILE (FlashJ > FlashTrackL(KIndex))
        FlashJ = FlashJ + 1
        KIndex = INT(FlashC1 * (Array(FlashJ).Number - ANMiN.Number)) + 1
    WEND
    flash = Array(FlashJ)
    DO
        IF (FlashJ = (FlashTrackL(KIndex) + 1)) THEN
            EXIT DO
        ELSE
            IF FlashNMove < (FinishMinusOne) THEN
                KIndex = INT(FlashC1 * (flash.Number - ANMiN.Number)) + 1
                hold = Array(FlashTrackL(KIndex))
                Array(FlashTrackL(KIndex)) = flash
                flash = hold
                FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
                FlashNMove = FlashNMove + 1
            ELSE
                EXIT DO
            END IF
        END IF
    LOOP
WEND

'================= Insertion Sort============
FOR SIndex = LBOUND(FlashtrackL) + 1 TO MIndex
    '* sort subranges
    FOR FlashI = FlashTrackL(SIndex) - 1 TO FlashTrackL(SIndex - 1) STEP -1
        IF (Array(FlashI + 1).Number < Array(FlashI).Number) THEN
            hold = Array(FlashI)
            NextFlashJ = FlashI
            DO
                FlashJ = NextFlashJ
                IF FlashJ < FlashTrackL(SIndex) THEN
                    NextFlashJ = FlashJ + 1
                    IF (Array(NextFlashJ).Number < hold.Number) THEN
                        SWAP Array(FlashJ), Array(NextFlashJ)
                    ELSE
                        EXIT DO
                    END IF
                ELSE
                    EXIT DO
                END IF
            LOOP
            Array(FlashJ) = hold
        END IF
    NEXT
    '* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
NEXT
FOR s& = start& TO finish&
    SWAP StrArray(s&), StrArray(Array(s&).Index)
NEXT
FOR s& = start& TO finish& - 1
    FOR t& = s& + 1 TO finish&
        IF StrArray(s&) > StrArray(s& + 1) THEN
            SWAP StrArray(s&), StrArray(s& + 1)
        ELSE
            EXIT FOR
        END IF
    NEXT
NEXT
IF order <> 1 THEN
    IF order <> 0 THEN
        FlashI = start
        FlashJ = finish
        WHILE FlashI < FlashJ
            SWAP StrArray(FlashI), StrArray(FlashJ)
            FlashI = FlashI - 1
            FlashJ = FlashJ - 1
        WEND
    END IF
END IF
END SUB


'* PrimeGapSort uses PrimeNumber&() function to calculate the prime number less than or equal to the gap
'* this is a variation of shellsort.
'> merger: Skipping unused SUB primeGapSort (array(), start&, finish&)

SUB primeGapSort2 (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        gap& = (finish& - start& + 1)
        DO
            FOR i& = start& TO finish& - gap&
                IF Array(i&) > Array(i& + gap&) THEN
                    SWAP Array(i&), Array(i& + gap&)
                END IF
            NEXT
            gap& = primeNumber&(gap& * 0.727)
        LOOP WHILE gap& > 1
        InsertionSort Array(), start&, finish&, order&
    CASE ELSE
        gap& = (finish& - start& + 1)
        DO
            FOR i& = start& TO finish& - gap&
                IF Array(i&) < Array(i& + gap&) THEN
                    SWAP Array(i&), Array(i& + gap&)
                END IF
            NEXT
            gap& = primeNumber&(gap& * 0.727)
        LOOP WHILE gap& > 1
        InsertionSort Array(), start&, finish&, order&
END SELECT
END SUB

FUNCTION primeNumber& (a&)
' Find a prime number blow a& (excluding 3 and 5)
'
' Notice that there is a:
' 59,9% chance for a single successive guess,
' 83,9% chance for a successive guess out of two guesses,
' 93,6% chance for a successive guess out of three guesses,
' 97,4% chance for a successive guess out of four guesses,
' 99,98% chance for a successive guess out of ten guesses...
'
' Worst bad luck over 10000 tested primes: 19 guesses.

STATIC firstCall%
STATIC pps%() 'Previous Prime in Sequence. Contains about 59.9% of all primes modulo 30.
'* wheel factorization by Zom-B
IF firstCall% = 0 THEN
    firstCall% = -1
    REDIM pps%(0 TO 29)
    ' Map numbers from 0 to 29 to the next lower prime in the sequence {1,7,11,13,17,19,23,29}.
    pps%(0) = -1: pps%(1) = -1 ' -1 = 29 (modulo 30)
    pps%(2) = 1: pps%(3) = 1: pps%(4) = 1: pps%(5) = 1: pps%(6) = 1: pps%(7) = 1
    pps%(8) = 7: pps%(9) = 7: pps%(10) = 7: pps%(11) = 7
    pps%(12) = 11: pps%(13) = 11:
    pps%(14) = 13: pps%(15) = 13: pps%(16) = 13: pps%(17) = 13
    pps%(18) = 17: pps%(19) = 17
    pps%(20) = 19: pps%(21) = 19: pps%(22) = 19: pps%(23) = 19
    pps%(24) = 23: pps%(25) = 23: pps%(26) = 23: pps%(27) = 23: pps%(28) = 23: pps%(29) = 23
END IF

b& = a& + 1
c& = (b& \ 30) * 30: b& = c& + pps%(b& - c&)
div& = 3
DO
    IF b& MOD div& THEN
        IF b& / div& < div& THEN
            EXIT DO
        ELSE
            div& = div& + 2
        END IF
    ELSE
        c& = (b& \ 30) * 30: b& = c& + pps%(b& - c&)
        div& = 3
    END IF
LOOP
primeNumber& = b&
END FUNCTION


'*******************
'* CombSort is the same as shellsort except a reduction factor of 1.3
'*******************
SUB CombSort (Array() AS DOUBLE, start&, finish&, order&)
SELECT CASE finish& - start&
    CASE 1
        IF Array(start&) > Array(finish&) THEN
            IF order& = 1 THEN
                SWAP Array(start&), Array(finish&)
            END IF
        END IF
    CASE IS > 1
        IF order& = 1 THEN
            ShellSortGap& = INT(10 * (finish& - start&) / 13)
            DO
                IF ShellSortGap& > 1 THEN
                    LoopCount& = 0
                    xstart& = start&
                    xfinish& = finish& - ShellSortGap&
                    MaxPasses& = (finish& - start&) \ ShellSortGap&
                    DO
                        xfirst& = xfinish&
                        FOR ShellSortS& = xstart& TO xfinish&
                            IF Array(ShellSortS&) > Array(ShellSortS& + ShellSortGap&) THEN
                                SWAP Array(ShellSortS&), Array(ShellSortS& + ShellSortGap&)
                                Last& = ShellSortS&
                                IF ShellSortS& < xfirst& THEN
                                    xfirst& = ShellSortS&
                                END IF
                            END IF
                        NEXT
                        xfinish& = Last&
                        xstart& = xfirst&
                        LoopCount& = LoopCount& + 1
                    LOOP WHILE LoopCount& < MaxPasses& AND (xfinish& - xstart&) >= ShellSortGap&
                    ShellSortGap& = INT(10 * (ShellSortGap& / 13))
                ELSE
                    InsertionSort Array(), start&, finish&, order&
                    EXIT DO
                END IF
            LOOP
        ELSE
            ShellSortGap& = INT(10 * (finish& - start&) / 13)
            DO
                IF ShellSortGap& > 1 THEN
                    LoopCount& = 0
                    xstart& = start&
                    xfinish& = finish& - ShellSortGap&
                    MaxPasses& = (finish& - start&) \ ShellSortGap&
                    DO
                        xfirst& = xfinish&
                        FOR ShellSortS& = xstart& TO xfinish&
                            IF Array(ShellSortS&) < Array(ShellSortS& + ShellSortGap&) THEN
                                SWAP Array(ShellSortS&), Array(ShellSortS& + ShellSortGap&)
                                Last& = ShellSortS&
                                IF ShellSortS& < xfirst& THEN
                                    xfirst& = ShellSortS&
                                END IF
                            END IF
                        NEXT
                        xfinish& = Last&
                        xstart& = xfirst&
                        LoopCount& = LoopCount& + 1
                    LOOP WHILE LoopCount& < MaxPasses& AND (xfinish& - xstart&) >= ShellSortGap&
                    ShellSortGap& = INT(10 * (ShellSortGap& / 13))
                ELSE
                    InsertionSort Array(), start&, finish&, order&
                    EXIT DO
                END IF
            LOOP

        END IF
END SELECT
END SUB

'********************************
'* EfficientMerge, developed from StackOverflow, a horribly short description of the procedure.
'* Uses n/2 auxiliary array for a 50% memory reduction used in merging and similar reduction in
'* time-consuming array copying. Very handly when memory and time is limited.
'* assumes the array passed has already been sorted. Like all other algorithms, this may be
'* used recursively. However for the purpose of MergeSort, it is used as a helper procedure.
'********************************
SUB EfficientMerge (right() AS DOUBLE, start&, finish&, order&)
half& = start& + (finish& - start&) \ 2
REDIM left(start& TO half&) AS DOUBLE '* hold the first half of the array in slave()
FOR LoadLeft& = start& TO half&
    left(LoadLeft&) = right(LoadLeft&)
NEXT
SELECT CASE order&
    CASE 1
        i& = start&
        j& = half& + 1
        insert& = start&
        DO
            IF i& > half& THEN '* left() exhausted
                IF j& > finish& THEN '* right() exhausted
                    EXIT DO
                ELSE
                    '* stuff remains in right to be inserted, so flush right()
                    WHILE j& <= finish&
                        right(insert&) = right(j&)
                        j& = j& + 1
                        insert& = insert& + 1
                    WEND
                    EXIT DO
                    '* and exit
                END IF
            ELSE
                IF j& > finish& THEN
                    WHILE i& < LoadLeft&
                        right(insert&) = left(i&)
                        i& = i& + 1
                        insert& = insert& + 1
                    WEND
                    EXIT DO
                ELSE
                    IF right(j&) < left(i&) THEN
                        right(insert&) = right(j&)
                        j& = j& + 1
                    ELSE
                        right(insert&) = left(i&)
                        i& = i& + 1
                    END IF
                    insert& = insert& + 1
                END IF
            END IF
        LOOP
    CASE ELSE
        i& = half&
        j& = finish&
        insert& = finish&
        DO
            IF i& < start& THEN '* left() exhausted
                IF j& < half& + 1 THEN '* right() exhausted
                    EXIT DO
                ELSE
                    '* stuff remains in right to be inserted, so flush right()
                    WHILE j& >= half&
                        right(insert&) = right(j&)
                        j& = j& - 1
                        insert& = insert& - 1
                    WEND
                    EXIT DO
                    '* and exit
                END IF
            ELSE
                IF j& < half& + 1 THEN
                    WHILE i& >= start&
                        right(insert&) = left(i&)
                        i& = i& - 1
                        insert& = insert& - 1
                    WEND
                    EXIT DO
                ELSE
                    IF left(i&) > right(j&) THEN
                        right(insert&) = right(j&)
                        j& = j& - 1
                    ELSE
                        right(insert&) = left(i&)
                        i& = i& - 1
                    END IF
                    insert& = insert& - 1
                END IF
            END IF
        LOOP
END SELECT
ERASE left
END SUB

'**********************
'* SelectionSort, another o(n^2) sort. generally used only for very short lists. total comparisons is N(N+1)/2,
'* regardless of the state of sortation, making this only slightly better than bubblesort.
'**********************
SUB SelectionSort (array() AS DOUBLE, start&, finish&, order&)
SELECT CASE order&
    CASE 1
        FOR s& = start& TO finish& - 1
            u& = s&
            FOR t& = s& + 1 TO finish&
                IF array(t&) < array(u&) THEN
                    u& = t&
                END IF
            NEXT
            IF u& <> s& THEN
                SWAP array(s&), array(u&)
            END IF
        NEXT
    CASE ELSE
        FOR s& = start& TO finish& - 1
            u& = s&
            FOR t& = s& + 1 TO finish&
                IF array(t&) > array(u&) THEN
                    u& = t&
                END IF
            NEXT
            IF u& <> s& THEN
                SWAP array(s&), array(u&)
            END IF
        NEXT

END SELECT
END SUB

'********************
'* are writes to memory or disk time-consuming? this algorithm sorts and minimizes writes
'********************
SUB cycleSort (array() AS DOUBLE, start&, finish&, order&)
length& = finish& - start&
IF length& = 0 THEN EXIT SUB
DIM item AS DOUBLE '* MUST be same size and/or type as array() element
DIM position AS LONG
'* DIM writes AS LONG

' scan array() for cycles to rotate
FOR cycleStart& = start& TO finish& - 1
    item = array(cycleStart)
    '* find where to put the item
    position& = cycleStart&
    IF order& = 1 THEN
        FOR i& = cycleStart& + 1 TO UBOUND(array)
            IF array(i&) < item THEN position = position + 1
        NEXT
    ELSE
        FOR i& = cycleStart& + 1 TO UBOUND(array)
            IF array(i&) > item THEN position = position + 1
        NEXT
    END IF
    '* If the item is already in its correct position, this is not a cycle
    IF position <> cycleStart& THEN

        '* Otherwise, put the item there or right after any duplicates
        WHILE item = array(position)
            position = position + 1
        WEND
        SWAP array(position), item
        '* writes=writes+1

        'rotate the rest of the cycle
        WHILE position <> cycleStart
            '* Find where to put the item
            position = cycleStart
            IF order& = 1 THEN
                FOR i& = cycleStart + 1 TO UBOUND(array)
                    IF array(i&) < item THEN position = position + 1
                NEXT
            ELSE
                FOR i& = cycleStart + 1 TO UBOUND(array)
                    IF array(i&) > item THEN position = position + 1
                NEXT

            END IF
            ' Put the item there or right after any duplicates
            WHILE item = array(position)
                position = position + 1
            WEND
            SWAP array(position), item
            '* writes=writes+1
        WEND
    END IF
NEXT
END SUB

'**********************
'* this is dl shell's sort but modified for faster running time than standard shellsort.
'**********************
SUB shellSortMetzler (array() AS DOUBLE, start&, finish&, order&)
DIM b AS DOUBLE
SELECT CASE order&
    CASE 1
        m& = metzler&(start&, finish&)
        WHILE m& > 0
            FOR j& = start& TO finish& - m&
                l& = j& + m&
                b = array(l&)
                FOR i& = j& TO start& STEP -m&
                    IF array(i&) > b THEN
                        SWAP array(i& + m&), array(i&)
                        l& = i&
                    ELSE
                        i& = start&
                    END IF
                NEXT
                array(l&) = b
            NEXT
            m& = (m& - 1) \ 3
        WEND
    CASE ELSE
        m& = metzler&(start&, finish&)
        WHILE m& > 0
            FOR j& = start& TO finish& - m&
                l& = j& + m&
                b = array(l&)
                FOR i& = j& TO start& STEP -m&
                    IF array(i&) < b THEN
                        SWAP array(i& + m&), array(i&)
                        l& = i&
                    ELSE
                        i& = start&
                    END IF
                NEXT
                array(l&) = b
            NEXT
            m& = (m& - 1) \ 3
        WEND
END SELECT
END SUB

FUNCTION metzler& (a&, b&)
x& = (b& - a& + 1) \ 3
s& = 0
DO
    IF x& < 1 THEN
        EXIT DO
    ELSE
        s& = 3 * s& + 1
        x& = (x& - 1) \ 3
    END IF
LOOP
metzler& = s&
END FUNCTION
'*********************************
'* generates the Primes() table used by PrimeGapSort()
'* PrimeGapsSort2 uses wheel factoring to find primes.
'* I guess I could have used a Sieve of Eratosthenes too
'* But trial division is fast enough.
'*********************************
SUB PrimeGen (Primes() AS LONG, MaximumN&, NPrimes&)
DIM addtoskip5(0 TO 3) AS LONG

'* used correctly, this array will eliminate all integers of the form 10k+5 when added in sequence,
'* resulting in in integers ending in 1,3,7 or 9, saving 20% compute time versus blindly adding 2 each time.
addtoskip5(0) = 2
addtoskip5(1) = 4
addtoskip5(2) = 2
addtoskip5(3) = 2
Primes(0) = 2
s& = 1
r& = 2
p& = 0
NPrimes& = 1
DO
    s& = s& + addtoskip5(p&)
    p& = (p& + 1) MOD 4
    div& = 3
    r& = 1
    DO
        IF (s& / div&) < div& THEN
            '* this is a prime
            Primes(NPrimes&) = s&
            NPrimes& = NPrimes& + 1
            EXIT DO
        ELSE
            IF s& MOD div& THEN
                div& = div& + addtoskip5(r&)
                r& = (r& + 1) MOD 4
            ELSE
                EXIT DO
            END IF
        END IF
    LOOP
LOOP UNTIL NPrimes& > UBOUND(Primes) OR s& > MaximumN&
REDIM _PRESERVE Primes(0 TO NPrimes& - 1)
END SUB
'* the original invention by CodeGuy.
'* competitive time to MergeSort
SUB PrimeGapSort (array() AS DOUBLE, start&, finish&, order&)
'REDIM Primes(0 TO finish& - start& + 1) AS LONG
'PrimeGen Primes(), finish& - start& + 1, NPrimes&
IF order& = 1 THEN
    Gap& = finish& - start&
    b& = NPrimes&
    DO
        t& = INT(727 * (Gap& / 1000))
        a& = LBOUND(primes)
        DO
            c& = a& + (b& - a&) \ 2
            IF Primes(c&) > t& THEN
                b& = c& - 1
            ELSE
                a& = c&
            END IF
        LOOP WHILE b& > a& + 1
        b& = c& - 1
        Gap& = Primes(c&)
        FOR s& = start& TO finish& - Gap&
            IF array(s&) > array(s& + Gap&) THEN
                SWAP array(s&), array(s& + Gap&)
            END IF
        NEXT
    LOOP WHILE c& > 0
ELSE
    Gap& = finish& - start&
    b& = NPrimes&
    DO
        t& = INT(727 * (Gap& / 1000))
        a& = LBOUND(primes)
        DO
            c& = a& + (b& - a&) \ 2
            IF Primes(c&) > t& THEN
                b& = c& - 1
            ELSE
                a& = c&
            END IF
        LOOP WHILE b& > a& + 1
        b& = c& - 1
        Gap& = Primes(c&)
        FOR s& = start& TO finish& - Gap&
            IF array(s&) < array(s& + Gap&) THEN
                SWAP array(s&), array(s& + Gap&)
            END IF
        NEXT
    LOOP WHILE c& > 0
END IF
InsertionSort array(), start&, finish&, order&
END SUB

'*****************
'* as long as a stable subsorting algorithm is used, PostSort remains stable.
'* Surprisingly as NumPostBins& increases, the speed increases.
'*****************
SUB PostSort (array() AS DOUBLE, start&, finish&, order&)
'* surprisngly, PostSort in this variation performs MORE slowly with increasing NumPostBins&.
'* not certain why, but that is the result.
GetMinMaxArray array(), start&, finish&, IndexMin&, IndexMax&
IF IndexMin& = IndexMax& THEN EXIT SUB
NumPostBins& = 0
ps& = 1.1 * (finish& - start& + 1) / (NumPostBins& + 1 / (NumPostBins& + 1))
REDIM PostArray(0 TO NumPostBins&, 0 TO ps&) AS DOUBLE
REDIM Counts(0 TO NumPostBins&) AS LONG
Range# = array(IndexMax&) - array(IndexMin&)
IF order& = 1 THEN
    FOR s& = start& TO finish&
        Bin& = NumPostBins& * (array(s&) - array(IndexMin&)) / Range#
        PostArray(Bin&, Counts(bim&)) = array(s&)
        Counts(Bin&) = Counts(Bin&) + 1
    NEXT
    TotalInserted& = start&
    FOR a& = 0 TO NumPostBins&
        IF Counts(a&) > 0 THEN
            lastinsert& = Totalnserted&
            FOR q& = 0 TO Counts(a&) - 1
                array(TotalInserted&) = PostArray(a&, q&)
                TotalInserted& = TotalInserted& + 1
            NEXT
            mergeSort array(), lastinsert&, TotalInserted& - 1, order&
        END IF
    NEXT
ELSE
    FOR s& = start& TO finish&
        Bin& = NumPostBins& * (array(IndexMax&) - array(s&)) / Range#
        PostArray(Bin&, Counts(bim&)) = array(s&)
        Counts(Bin&) = Counts(Bin&) + 1
    NEXT
    TotalInserted& = start&
    FOR a& = 0 TO NumPostBins&
        IF Counts(a&) > 0 THEN
            lastinsert& = Totalnserted&
            FOR q& = 0 TO Counts(a&) - 1
                array(TotalInserted&) = PostArray(a&, q&)
                TotalInserted& = TotalInserted& + 1
            NEXT
            mergeSort array(), lastinsert&, TotalInserted& - 1, order&
        END IF
    NEXT
END IF
ERASE PostArray
ERASE Counts
END SUB

'******************************************
'* Yes, this is MY invention, by CodeGuy. Faster than FlashSort and relatively simple.
'* It involves an array roughly 25% bigger than the original array,
'* Yes, you read that Correctly, faster than FlashSort, even with a final InsertionSort.
'* Can also be used in place of CountingSort as it keeps track of repetitions (counts > 1).
'* 09 AUG 2017. 8388608 DOUBLE-precision elements sorted in about 10.95s (actually, a bit less),
'* versus 11.80s for FlashSort. 25% faster than FlashSort at N=16777216.
'******************************************
SUB HashListSort (array() AS DOUBLE, start&, finish&, order&)
GetMinMaxArray array(), start&, finish&, ptrmin&, ptrmax&
IF ptrmin& = ptrmax& THEN EXIT SUB
delta# = array(ptrmax&) - array(ptrmin&)
Probe& = primeNumber&(1.25# * (finish& - start&)) - 1
REDIM HashTable(0 TO Probe&) AS DOUBLE
REDIM Count(0 TO Probe&) AS LONG
FOR s& = start& TO finish&
    pnum# = array(s&) - array(ptrmin&)
    f& = INT(Probe& * pnum# / delta#)
    DO
        IF f& > Probe& THEN
            f& = f& - Probe&
        END IF
        IF f& < 0 THEN
            f& = f& + Probe&
        END IF
        IF HashTable(f&) = array(s&) THEN
            Count(f&) = Count(f&) + 1
            EXIT DO
        ELSE
            IF Count(f&) = 0 THEN
                HashTable(f&) = array(s&)
                Count(f&) = 1
                EXIT DO
            END IF
        END IF
        f& = f& + 1
    LOOP
NEXT
inserted& = start&
IF order& = 1 THEN
    FOR s& = 0 TO Probe&
        WHILE Count(s&) > 0
            array(inserted&) = HashTable(s&)
            inserted& = inserted& + 1
            Count(s&) = Count(s&) - 1
        WEND
    NEXT
ELSE
    FOR s& = Probe& TO 0 STEP -1
        WHILE Count(s&) > 0
            array(inserted&) = HashTable(s&)
            inserted& = inserted& + 1
            Count(s&) = Count(s&) - 1
        WEND
    NEXT
END IF
ERASE Count, HashTable
InsertionSort array(), start&, finish&, order&
END SUB
« Last Edit: August 13, 2017, 04:38:28 am by codeguy »

SMcNeill

  • Moderator
  • Hero Member
  • *****
  • Posts: 6071
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #1 on: August 02, 2017, 07:00:27 am »
Here's my little all purpose sort routine, which you can play around with for speed comparison:

Code: [Select]
CONST Limit = 10000000
DIM Byte_Array(Limit) AS _BYTE
DIM Integer_Array(Limit) AS INTEGER
DIM Float_Array(Limit) AS _FLOAT

DIM m AS _MEM

PRINT "Seeding arrays with data"
FOR i&& = 0 TO Limit 'make some large arrays
    Byte_Array(i) = RND * 256
    Integer_Array(i) = RND * 65556
    Float_Array(i) = RND * 1234567890
NEXT

PRINT "Sorting Byte Array"
t# = TIMER
m = _MEM(Byte_Array())
Sort m
t1# = TIMER

PRINT "Sorting Integer Array"
m = _MEM(Integer_Array())
Sort m
t2# = TIMER

PRINT "Sorting Float Array (May take a minute)"
m = _MEM(Float_Array())
Sort m
t3# = TIMER

PRINT USING "Sorted #,###,###,###,### byte elements in #,###.### seconds"; Limit, t1# - t#
PRINT USING "Sorted #,###,###,###,### integer elements in #,###.### seconds"; Limit, t2# - t1#
PRINT USING "Sorted #,###,###,###,### float elements in #,###.### seconds"; Limit, t3# - t2#


SUB Sort (m AS _MEM)
DIM i AS _UNSIGNED LONG
$IF 64BIT THEN
    DIM ES AS _INTEGER64, EC AS _INTEGER64
$ELSE
    DIM ES AS LONG, EC AS LONG
$END IF

IF NOT m.TYPE AND 65536 THEN EXIT SUB 'We won't work without an array
IF m.TYPE AND 1024 THEN DataType = 10
IF m.TYPE AND 1 THEN DataType = DataType + 1
IF m.TYPE AND 2 THEN DataType = DataType + 2
IF m.TYPE AND 4 THEN IF m.TYPE AND 128 THEN DataType = DataType + 4 ELSE DataType = 3
IF m.TYPE AND 8 THEN IF m.TYPE AND 128 THEN DataType = DataType + 8 ELSE DataType = 5
IF m.TYPE AND 32 THEN DataType = 6
IF m.TYPE AND 512 THEN DataType = 7

'Convert our offset data over to something we can work with
DIM m1 AS _MEM: m1 = _MEMNEW(LEN(ES))
_MEMPUT m1, m1.OFFSET, m.ELEMENTSIZE: _MEMGET m1, m1.OFFSET, ES 'Element Size
_MEMPUT m1, m1.OFFSET, m.SIZE: _MEMGET m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
_MEMFREE m1

EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count.  We subtract 1 so our arrays start at 0 and not 1.
'And work with it!
DIM o AS _OFFSET, o1 AS _OFFSET, counter AS _UNSIGNED LONG

SELECT CASE DataType
    CASE 1 'BYTE
        DIM temp1(-128 TO 127) AS _UNSIGNED LONG
        DIM t1 AS _BYTE
        i = 0
        DO
            _MEMGET m, m.OFFSET + i, t1
            temp1(t1) = temp1(t1) + 1
            i = i + 1
        LOOP UNTIL i > EC
        i1 = -128
        DO
            DO UNTIL temp1(i1) = 0
                _MEMPUT m, m.OFFSET + counter, i1 AS _BYTE
                counter = counter + 1
                temp1(i1) = temp1(i1) - 1
                IF counter > EC THEN EXIT SUB
            LOOP
            i1 = i1 + 1
        LOOP UNTIL i1 > 127
    CASE 2: 'INTEGER
        DIM temp2(-32768 TO 32767) AS _UNSIGNED LONG
        DIM t2 AS INTEGER
        i = 0
        DO
            _MEMGET m, m.OFFSET + i * 2, t2
            temp2(t2) = temp2(t2) + 1
            i = i + 1
        LOOP UNTIL i > EC
        i1 = -32768
        DO
            DO UNTIL temp2(i1) = 0
                _MEMPUT m, m.OFFSET + counter * 2, i1 AS INTEGER
                counter = counter + 1
                temp2(i1) = temp2(i1) - 1
                IF counter > EC THEN EXIT SUB
            LOOP
            i1 = i1 + 1
        LOOP UNTIL i1 > 32767
    CASE 3 'SINGLE
        DIM T3a AS SINGLE, T3b AS SINGLE
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 4
                o1 = m.OFFSET + (i + gap) * 4
                IF _MEMGET(m, o, SINGLE) > _MEMGET(m, o1, SINGLE) THEN
                    _MEMGET m, o1, T3a
                    _MEMGET m, o, T3b
                    _MEMPUT m, o1, T3b
                    _MEMPUT m, o, T3a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 4 'LONG
        DIM T4a AS LONG, T4b AS LONG
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 4
                o1 = m.OFFSET + (i + gap) * 4
                IF _MEMGET(m, o, LONG) > _MEMGET(m, o1, LONG) THEN
                    _MEMGET m, o1, T4a
                    _MEMGET m, o, T4b
                    _MEMPUT m, o1, T4b
                    _MEMPUT m, o, T4a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 5 'DOUBLE
        DIM T5a AS DOUBLE, T5b AS DOUBLE
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 8
                o1 = m.OFFSET + (i + gap) * 8
                IF _MEMGET(m, o, DOUBLE) > _MEMGET(m, o1, DOUBLE) THEN
                    _MEMGET m, o1, T5a
                    _MEMGET m, o, T5b
                    _MEMPUT m, o1, T5b
                    _MEMPUT m, o, T5a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 6 ' _FLOAT
        DIM T6a AS _FLOAT, T6b AS _FLOAT
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 32
                o1 = m.OFFSET + (i + gap) * 32
                IF _MEMGET(m, o, _FLOAT) > _MEMGET(m, o1, _FLOAT) THEN
                    _MEMGET m, o1, T6a
                    _MEMGET m, o, T6b
                    _MEMPUT m, o1, T6b
                    _MEMPUT m, o, T6a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 7 'String
        DIM T7a AS STRING, T7b AS STRING, T7c AS STRING
        T7a = SPACE$(ES): T7b = SPACE$(ES): T7c = SPACE$(ES)
        gap = EC
        DO
            gap = INT(gap / 1.247330950103979)
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * ES
                o1 = m.OFFSET + (i + gap) * ES
                _MEMGET m, o, T7a
                _MEMGET m, o1, T7b
                IF T7a > T7b THEN
                    T7c = T7b
                    _MEMPUT m, o1, T7a
                    _MEMPUT m, o, T7c
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = false
    CASE 8 '_INTEGER64
        DIM T8a AS _INTEGER64, T8b AS _INTEGER64
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 8
                o1 = m.OFFSET + (i + gap) * 8
                IF _MEMGET(m, o, _INTEGER64) > _MEMGET(m, o1, _INTEGER64) THEN
                    _MEMGET m, o1, T8a
                    _MEMGET m, o, T8b
                    _MEMPUT m, o1, T8b
                    _MEMPUT m, o, T8a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 11: '_UNSIGNED _BYTE
        DIM temp11(0 TO 255) AS _UNSIGNED LONG
        DIM t11 AS _UNSIGNED _BYTE
        i = 0
        DO
            _MEMGET m, m.OFFSET + i, t11
            temp11(t11) = temp11(t11) + 1
            i = i + 1
        LOOP UNTIL i > EC
        i1 = 0
        DO
            DO UNTIL temp11(i1) = 0
                _MEMPUT m, m.OFFSET + counter, i1 AS _UNSIGNED _BYTE
                counter = counter + 1
                temp11(i1) = temp11(i1) - 1
                IF counter > EC THEN EXIT SUB
            LOOP
            i1 = i1 + 1
        LOOP UNTIL i1 > 255
    CASE 12 '_UNSIGNED INTEGER
        DIM temp12(0 TO 65535) AS _UNSIGNED LONG
        DIM t12 AS _UNSIGNED INTEGER
        i = 0
        DO
            _MEMGET m, m.OFFSET + i * 2, t12
            temp12(t12) = temp12(t12) + 1
            i = i + 1
        LOOP UNTIL i > EC
        i1 = 0
        DO
            DO UNTIL temp12(i1) = 0
                _MEMPUT m, m.OFFSET + counter * 2, i1 AS _UNSIGNED INTEGER
                counter = counter + 1
                temp12(i1) = temp12(i1) - 1
                IF counter > EC THEN EXIT SUB
            LOOP
            i1 = i1 + 1
        LOOP UNTIL i1 > 65535
    CASE 14 '_UNSIGNED LONG
        DIM T14a AS _UNSIGNED LONG, T14b AS _UNSIGNED LONG
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 4
                o1 = m.OFFSET + (i + gap) * 4
                IF _MEMGET(m, o, _UNSIGNED LONG) > _MEMGET(m, o1, _UNSIGNED LONG) THEN
                    _MEMGET m, o1, T14a
                    _MEMGET m, o, T14b
                    _MEMPUT m, o1, T14b
                    _MEMPUT m, o, T14a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
    CASE 18: '_UNSIGNED _INTEGER64
        DIM T18a AS _UNSIGNED _INTEGER64, T18b AS _UNSIGNED _INTEGER64
        gap = EC
        DO
            gap = 10 * gap \ 13
            IF gap < 1 THEN gap = 1
            i = 0
            swapped = 0
            DO
                o = m.OFFSET + i * 8
                o1 = m.OFFSET + (i + gap) * 8
                IF _MEMGET(m, o, _UNSIGNED _INTEGER64) > _MEMGET(m, o1, _UNSIGNED _INTEGER64) THEN
                    _MEMGET m, o1, T18a
                    _MEMGET m, o, T18b
                    _MEMPUT m, o1, T18b
                    _MEMPUT m, o, T18a
                    swapped = -1
                END IF
                i = i + 1
            LOOP UNTIL i + gap > EC
        LOOP UNTIL gap = 1 AND swapped = 0
END SELECT
END SUB

I don't imagine it'll lose to any other sort routine out there, as long as the user's array is byte, unsigned byte, integer, or unsigned integer size.  As for other data types, it still works as one of the fastest "all purpose" sort routines out there. 

Best part??

One sort routine works with nearly ALL data types.  Signed or Unsigned Byte, Integer, Long.  Single, Double, Float.  Fixed Length Strings.  (It won't support variable length strings as _MEM itself doesn't support those as they can move about in memory as needed.)

Just point a mem variable at your array, and then send that variable as the parameter to the sort routine; it'll handle all the rest.  :)

NOTE:  QB64 version 1.1 and lower have a glitch with mem.ELEMENTSIZE and this may not work properly on 64-bit OSes. A fix was pushed into the repo today (08-02-2017), so you may need to grab a fresh copy of the daily build so that it'll work properly on a 64-bit version of QB64. 

Note2: Personally, I find this to be the "best" routine for me simply because it works across such a wide range of array variable types.  :)
http://bit.ly/TextImage -- Library of QB64 code to manipulate text and images, as a BM library.

http://bit.ly/Color32 -- A set of color CONST for use in 32 bit mode, as a BI library.

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #2 on: August 02, 2017, 07:05:38 am »
Thank you Steve. For a while someone has suggested I post up all my Sorting Algorithms code with explanations and analysis. So that's what I'm doing to help create a MASSIVE library of useful and fast sorts all in one convenient library. I a submitting it in qbxx-compatible code because I want it to be usable across different versions of qb/qbxx or easily adaptable even to interpreters. The Flashsort refactored sorts 8388608 double precision in roughly 10s on a 2 GHz machine. I don't know what you've named your sort, SteveMemSort()? I'll take a look at it and judging by its flexibility to work on all data types (I assume C-type struct too (aka TYPE), it will be worthwhile to include. Name it, I'll include it. 57s for 10M DOUBLE. explain how it's smoking on integer and byte. 1,5s for 10M elements.
« Last Edit: August 02, 2017, 07:49:00 am by codeguy »

SMcNeill

  • Moderator
  • Hero Member
  • *****
  • Posts: 6071
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #3 on: August 02, 2017, 07:42:06 am »
Thank you Steve. For a while someone has suggested I post up all my Sorting Algorithms code with explanations and analysis. So that's what I'm doing to help create a MASSIVE library of useful and fast sorts all in one convenient library. I a submitting it in qbxx-compatible code because I want it to be usable across different versions of qb/qbxx or easily adaptable even to interpreters. The Flashsort refactored sorts 8388608 double precision in roughly 10s on a 2 GHz machine. I don't know what you've named your sort, SteveMemSort()? I'll take a look at it and judging by its flexibility to work on all data types (I assume C-type struct too (aka TYPE), it will be worthwhile to include.

It only works on what _MEM will support, so User Defined Types and Variable Length Strings are out.  As for the name of it, I just kept it simple -- SORT -- but you can change it to whatever you feel is best for your purposes.  I'm just too lazy to type in something like SteveMemSort memarray() when I can get away with Sort m() for most of my needs.  :)

By that same lazy logic, it'd also need a little modification to add support for start/stop element limits (such as only sorting element 10-20 of a 100 element array), as I just needed to keep it simple enough to plug-and-play for sorting a whole array at once for my personal needs. 

I posted a collection of various sort routines in the past here: http://www.qb64.net/forum/index.php?topic=11446.0  If any of them are useful for you, feel free to take them and make use of them however you feel you want to.

Note:  If you look close, you'll see that these are (mainly) basically Combsort style routines, converted over to use the _MEM commands, as I tend to find it both simple enough to easily implement and fast enough for general use. 

Integer/Byte sort however has a nefarious secret behind them, which makes them so blazing fast...

They're not SORT routines at all!  They're basic COUNTER routines.  :D

It's much faster to just count a limited data set, than it is to sort and swap it all about in memory.  Think of it:  A BYTE array can ONLY have results from 0 to 255 stored there.  If we just count the number of 0s, the number of 1s, number of 2s... We then have the array "sorted", without ever having to swap places of anything in memory.

For example, lets say I have 10 elements of a _BIT nature:  0,1,1,0,0,1,0,1,1,1

Now, we can sort those by moving the 0's to the left, and the 1's to the right.  (Most sorts use this generally type of process.)

OR...

We just count the zeros and ones.  Four zeros, Six Ones.  Then we write them back into our array.  0,0,0,0,1,1,1,1,1,1  -- We're not swapping anything back and forth in memory at all!  We just counted and then rebuild the array from scratch... in a fraction of the time.  :D
« Last Edit: August 02, 2017, 07:58:21 am by SMcNeill »
http://bit.ly/TextImage -- Library of QB64 code to manipulate text and images, as a BM library.

http://bit.ly/Color32 -- A set of color CONST for use in 32 bit mode, as a BI library.

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #4 on: August 02, 2017, 07:51:26 am »
will do. However, some earlier versions of qb64 and especially qbxx aren't gonna like it. whatever.

SMcNeill

  • Moderator
  • Hero Member
  • *****
  • Posts: 6071
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #5 on: August 02, 2017, 08:00:44 am »
Edited my previous post, but you posted back while I was doing so.  :D

You should be able to see why integer and byte are so much faster than any other "sort" method out there, I'd think.  ;)

Edit:  Just to show the basic idea:

SELECT CASE DataType
    CASE 1 'BYTE
        DIM temp1(-128 TO 127) AS _UNSIGNED LONG
        DIM t1 AS _BYTE

^ As you can see, we just make a temp array with the limits of what a _BYTE could possibly represent (-128 to 127), and then we count the elements.  (Counter will break if we ever count more than the max limit of what an unsigned long will hold.)

Byte and Integer (signed and unsigned) work like this as we can make an array to count them without using a lot of memory.  LONG and above, however, would just use too large an array to store and count all the elements, so we have to truly sort those -- which is why we see such a difference in speed and performance in the various data types.

I'm confident that my little mem Sort routine won't be beat when it comes to byte/integer arrays...  Just because it really doesn't "sort" those arrays at all.  :D
« Last Edit: August 02, 2017, 08:16:12 am by SMcNeill »
http://bit.ly/TextImage -- Library of QB64 code to manipulate text and images, as a BM library.

http://bit.ly/Color32 -- A set of color CONST for use in 32 bit mode, as a BI library.

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #6 on: August 06, 2017, 04:13:38 am »
Is your beloved O(NLogN)/mergesort blowing up on you because of memory? Have I got a solution for you. It's called EfficientMerge, well at least in the code update I'll be posting shortly. It requires 1/2 the memory for merging the standard algorithm uses. At vetly large N, this can mean the difference between success and failure. Sure there are sorts that require no or little extra memory, but they lack stability. So to aid MergeSort to 33% more reliability and range. I'll submit the revised library code when I'm on my laptop. Not only does it save time, it also saves memory. And time? It saves 26&% at 33 million plus. Still, FlashSort remains the reigning champ, beating QuickSort by a margin of 18% in this same range. Because speed matters for huge datasets.

SMcNeill

  • Moderator
  • Hero Member
  • *****
  • Posts: 6071
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #7 on: August 06, 2017, 04:33:32 am »
Is your beloved O(NLogN)/mergesort blowing up on you because of memory? Have I got a solution for you. It's called EfficientMerge, well at least in the code update I'll be posting shortly. It requires 1/2 the memory for merging the standard algorithm uses. At vetly large N, this can mean the difference between success and failure. Sure there are sorts that require no or little extra memory, but they lack stability. So to aid MergeSort to 33% more reliability and range. I'll submit the revised library code when I'm on my laptop. Not only does it save time, it also saves memory. And time? It saves 26&% at 33 million plus. Still, FlashSort remains the reigning champ, beating QuickSort by a margin of 18% in this same range. Because speed matters for huge datasets.

Also, you might want to include an example of a Binary Inclusion Sort, which would be used to insert data into an already sorted array.  (When your dataset is already sorted, it's the best way to add new data.)

Say for example I have the following _BYTE values sorted:

0,10,20,30,40,50,60,70,80,90,100

And I want to add the value 55 to the list...

Since it's sorted, we start at the middle
lowend = element 0: highend = element 11: middle = (0 + 11) / 2 = 5.5

element 5 = 50  (0, 10, 20, 30, 40, 50 is the 5th element, counting starting at 0)

Since 55 > 50, we change the lowend to 50 and repeat...

Continue until we highend = lowend + 1, then we know where to put it.

In this case we use 2^n as a max number of comparisons to find where to put the value.

Then with _MEM we just move everything to the right of that point one step over, and then insert the new value.

I think I have a demo of doing this somewhere on the forums.  I'll see if I can dig it up for you later.  If not, I can write a new version sometime easily enough.

max 2^n comparisons, 1 memory move, 1 memory insert...  It's the fastest way to go when adding new data into an already existing dataset, of any noticeable size.
http://bit.ly/TextImage -- Library of QB64 code to manipulate text and images, as a BM library.

http://bit.ly/Color32 -- A set of color CONST for use in 32 bit mode, as a BI library.

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #8 on: August 06, 2017, 06:28:46 am »
InsertionSortBinary() already included. roughly 25% faster than standard InsertionSort. Also changed Mergeort to use EfficientMerge for a nice speedup and less memory overhead. And included a test harness as a separate program to execute and verify sort algorithms. Latest inclusion is CycleSort. You'll see I've included the start of a FlashString() to extend FlashSort() to string types.

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #9 on: August 09, 2017, 02:26:20 pm »
Code: [Select]
'******************************************
'* Yes, this is MY invention, by CodeGuy. Faster than FlashSort and relatively simple.
'* It involves an array roughly 25% bigger than the original array,
'* Yes, you read that Correctly, faster than FlashSort, even with a final InsertionSort.
'* Can also be used in place of CountingSort as it keeps track of repetitions (counts > 1).
'* 09 AUG 2017. 8388608 DOUBLE-precision elements sorted in about 10.95s (actually, a bit less),
'* versus 11.80s for FlashSort. 25% faster than FlashSort at N=16777216.
'******************************************
Code: [Select]
SUB HashListSort (array() AS DOUBLE, start&, finish&, order&)
GetMinMaxArray array(), start&, finish&, ptrmin&, ptrmax&
IF ptrmin& = ptrmax& THEN EXIT SUB
delta# = array(ptrmax&) - array(ptrmin&)
Probe& = primeNumber&(1.25# * (finish& - start&)) - 1
REDIM HashTable(0 TO Probe&) AS DOUBLE
REDIM Count(0 TO Probe&) AS LONG
FOR s& = start& TO finish&
    pnum# = array(s&) - array(ptrmin&)
    f& = INT(Probe& * pnum# / delta#)
    DO
        IF f& > Probe& THEN
            f& = f& - Probe&
        END IF
        IF f& < 0 THEN
            f& = f& + Probe&
        END IF
        IF HashTable(f&) = array(s&) THEN
            Count(f&) = Count(f&) + 1
            EXIT DO
        ELSE
            IF Count(f&) = 0 THEN
                HashTable(f&) = array(s&)
                Count(f&) = 1
                EXIT DO
            END IF
        END IF
        f& = f& + 1
    LOOP
NEXT
inserted& = start&
IF order& = 1 THEN
    FOR s& = 0 TO Probe&
        WHILE Count(s&) > 0
            array(inserted&) = HashTable(s&)
            inserted& = inserted& + 1
            Count(s&) = Count(s&) - 1
        WEND
    NEXT
ELSE
    FOR s& = Probe& TO 0 STEP -1
        WHILE Count(s&) > 0
            array(inserted&) = HashTable(s&)
            inserted& = inserted& + 1
            Count(s&) = Count(s&) - 1
        WEND
    NEXT
END IF
ERASE Count, HashTable
InsertionSort array(), start&, finish&, order&
END SUB

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #10 on: August 10, 2017, 02:08:39 am »
'********************
'* Some declare radix sort as faster than QuickSort. I have yet to see evidence of this in bitwise mode.
'* works with non-integer types too. for faster performance, change the Radix. In this case it is 2. This is bitwise.
'* ct&() needs to accomodate the numeric range of bits. the radix for one byte would be calculated by NTmpN AND 255
'* and requires ct&(-128 to 127). Unfortuately the final InsertionSort is required. Fortunately, it runs in nearly
'* O(n) time as the array is almost perfectly sorted prior.
'********************

Code: [Select]
SUB RadixSort (a() AS DOUBLE, start&, finish&, order&)
GetMinMaxArray a(), start&, finish&, minptr&, maxptr&
IF minptr& = maxptr& THEN EXIT SUB '* no div0 bombs
delta# = a(maxptr&) - a(minptr&)
DIM pow2 AS _UNSIGNED _INTEGER64
DIM NtmpN AS _UNSIGNED _INTEGER64
REDIM ct&(-1 TO 1)
REDIM Radixarray(-1 TO 1, finish& - start&) AS DOUBLE
REDIM Int64MaxShift AS _INTEGER64
Int64MaxShift = 2 ^ 64
pow2 = 1
FOR bits& = 0 TO 63
    FOR i& = start& TO finish&
        NtmpN = Int64MaxShift * (a(i&) - a(minptr&)) / (delta#)
        IF NtmpN AND pow2 THEN
            tmpradix% = 1
        ELSE
            tmpradix% = 0
        END IF
        Radixarray(tmpradix%, ct&(tmpradix%)) = a(i&)
        ct&(tmpradix%) = ct&(tmpradix%) + 1
    NEXT
    c& = start&
    FOR i& = 1 TO -1 STEP -1
        FOR j& = 0 TO ct&(i&) - 1
            a(c&) = Radixarray(i&, j&)
            c& = c& + 1
        NEXT
        ct&(i&) = 0
    NEXT
    pow2 = pow2 * 2
NEXT
ERASE Radixarray, ct&
IF order& = 1 THEN
    StableInvert a(), start&, finish&, 1
END IF
InsertionSort a(), start&, finish&, order&
END SUB

finally gve up trying to sort ascending using RadixSort, so ther's an array inversion called ascending order.
« Last Edit: August 10, 2017, 11:02:13 pm by codeguy »

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #11 on: September 02, 2017, 10:04:12 pm »
Code: [Select]
'* Possible _MEM sorter
'* this is where you'd copy _mem to a$ or whatever
ElementLength& = 4
a$ = ""
FOR i = 1 TO 1024
    a$ = a$ + CHR$(ASC("0") + INT(RND * (9)))
NEXT
QuickSortIterative a$, 0, LEN(a$) \ ElementLength& - 1, ElementLength&, 1

FOR s& = 0 TO LEN(a$) \ ElementLength& - 1
    PRINT MID$(a$, GetOffset&(s&, ElementLength&), ElementLength&); " ";
NEXT

SUB QuickSortIterative (a$, Start&, Finish&, elementLength&, order&)
DIM compare AS DOUBLE
MinStack& = LOG(Finish& - Start& + 1) \ LOG(2) + 1
DIM LStack&(MinStack&, 1)
StackPtr& = 0
LStack&(StackPtr&, 0) = Start&
LStack&(StackPtr&, 1) = Finish&
DO
    Low& = LStack&(StackPtr&, 0)
    Hi& = LStack&(StackPtr&, 1)
    DO
        i& = Low&
        j& = Hi&
        Mid& = Low& + (Hi& - Low& + 1) \ 2
        compare = GetElement&(a$, Mid&, elementLength&)
        SELECT CASE order&
            CASE 1
                DO
                    DO WHILE GetElement&(a$, i&, elementLength&) < compare
                        i& = i& + 1
                    LOOP
                    DO WHILE GetElement&(a$, j&, elementLength&) > compare
                        j& = j& - 1
                    LOOP
                    IF i& <= j& THEN
                        'SWAP GetElement&(a$,i&,elementlength&), GetElement&(a$,j&,elementlength&)
                        io& = GetOffset&(i&, elementLength&)
                        jo& = GetOffset&(j&, elementLength&)
                        b$ = MID$(a$, io&, elementLength&)
                        c$ = MID$(a$, jo&, elementLength&)
                        MID$(a$, io&, elementLength&) = c$
                        MID$(a$, jo&, elementLength&) = b$
                        i& = i& + 1
                        j& = j& - 1
                    END IF
                LOOP UNTIL i& > j&
            CASE ELSE
                DO
                    DO WHILE GetElement&(a$, i&, elementLength&) > compare
                        i& = i& + 1
                    LOOP
                    DO WHILE GetElement&(a$, j&, elementLength&) < compare
                        j& = j& - 1
                    LOOP
                    IF i& <= j& THEN
                        'SWAP GetElement&(i&), GetElement&(j&)
                        io& = GetOffset&(i&, elementLength&)
                        jo& = GetOffset&(j&, elementLength&)
                        b$ = MID$(a$, io&, elementLength&)
                        c$ = MID$(a$, jo&, elementLength&)
                        MID$(a$, io&, elementLength&) = c$
                        MID$(a$, jo&, elementLength&) = b$
                        i& = i& + 1
                        j& = j& - 1
                    END IF
                LOOP UNTIL i& > j&
        END SELECT
        IF j& - Low& < Hi& - i& THEN
            IF i& < Hi& THEN
                LStack&(StackPtr&, 0) = i&
                LStack&(StackPtr&, 1) = Hi&
                StackPtr& = StackPtr& + 1
            END IF
            Hi& = j&
        ELSE
            IF Low& < j& THEN
                LStack&(StackPtr&, 0) = Low&
                LStack&(StackPtr&, 1) = j&
                StackPtr& = StackPtr& + 1
            END IF
            Low& = i&
        END IF
    LOOP WHILE Low& < Hi&
    StackPtr& = StackPtr& - 1
LOOP UNTIL StackPtr& < 0
END SUB

FUNCTION GetOffset& (i&, numbytes&)
GetOffset& = i& * numbytes& + 1
'* for _mem, + 1 is changed to nothing
END FUNCTION

FUNCTION GetElement& (a$, i&, NumBytesElement&)
GetElement& = VAL(MID$(a$, GetOffset&(i&, NumBytesElement&), NumBytesElement&))
END FUNCTION

RhoSigma

  • Sr. Member
  • ****
  • Posts: 274
  • Out Of Time
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #12 on: September 03, 2017, 05:00:06 am »
Maybe another alternative to look at:
http://alienryderflex.com/quicksort/

codeguy

  • Hero Member
  • *****
  • Posts: 3945
  • what the h3ll did i name that code?
    • stuff at dkm
Re: Sorting Methods. The Best and not necessarily fastest algorithms.
« Reply #13 on: September 03, 2017, 05:18:16 pm »
The iterative version using a software stack is thus far the ONLY I can depend on for 100% error-free performance besides the Yaroslavsky dual-pivot version. These are the versions I'd recommend. BTW, stacks in software are faster than hardware stacks. At least versus current tech.

BTW, binary insertion is roughly 25% faster than InsertionSort. Already been there, done that.
« Last Edit: September 03, 2017, 05:35:11 pm by codeguy »