Author Topic: Russian Sorting Halves Danilin (Read 6743 times)

DANILIN · « **on:** October 15, 2018, 07:40:40 pm »

Russian Sorting Halves and fast and human
sorts 1'000'000 in 2.2 seconds

number of elements is written to file with c:/N.txt or use variable n
array d(n) can be read from a file or synthesized in a program

Code: QB64: [Select]

' Russian Sorting Halves Danilin
 
DECLARE SUB RussianSortingHalvesDAV (ab!, yz!, part!, age!)
CLOSE
OPEN "c:/N.txt" FOR INPUT AS #1
INPUT #1, n
'n=1234567
age = 1 + LOG(n) / LOG(2)
PRINT n
 
DIM SHARED d(n) 'AS LONG
DIM SHARED a(n) 'AS LONG
 
'OPEN "c:/ISX.txt" FOR INPUT AS #2
'FOR i=1 TO n: INPUT #2, d(i): NEXT
 
'FOR i = 1 TO n: d(i) = n - i + 1: NEXT ' INT(RND*n)
FOR i = 1 TO n: d(i) = INT(RND * n): NEXT '
 
FOR k = 1 TO 20: PRINT d(k);: NEXT: PRINT: PRINT
FOR k = n - 19 TO n: PRINT d(k);: NEXT: PRINT: PRINT
 
start = TIMER
 
IF age > 0 THEN
    CALL RussianSortingHalvesDAV(1, n, 1, age)
END IF
 
finish = TIMER
 
PRINT finish - start; "second ": PRINT
 
OPEN "c:/=RuSortHalves_dav.txt" FOR OUTPUT AS #3
PRINT #3, finish - start; "second "
PRINT #3, n; "elements", "RECURSION"
FOR i = 1 TO 22: PRINT #3, d(i): NEXT
FOR i = n - 22 TO n: PRINT #3, d(i): NEXT
 
FOR k = 1 TO 20: PRINT d(k);: NEXT: PRINT: PRINT
FOR k = n - 19 TO n: PRINT d(k);: NEXT: PRINT: PRINT
 
END
 
SUB RussianSortingHalvesDAV (ab, yz, part, age)
 
IF yz - ab < 1 THEN EXIT SUB
 
FOR i = ab TO yz
    summa = summa + d(i)
NEXT
middle = summa / (yz - ab + 1)
 
abc = ab - 1
xyz = yz + 1
 
FOR i = ab TO yz
    IF d(i) < middle THEN abc = abc + 1: a(abc) = d(i): ELSE xyz = xyz - 1: a(xyz) = d(i)
NEXT
 
FOR i = ab TO yz: d(i) = a(i): NEXT
 
IF part < age THEN
    IF abc >= ab THEN CALL RussianSortingHalvesDAV(ab, abc, part + 1, age)
    IF xyz <= yz THEN CALL RussianSortingHalvesDAV(xyz, yz, part + 1, age)
END IF
 
END SUB
 

Russian Sorting Halves Danilin visualisation

http://kenokeno.ucoz.ru/win/rusortpol10.gif

[ You are not allowed to view this attachment ]

bplus · « **Reply #1 on:** October 15, 2018, 08:30:26 pm »

Welcome to the forum DANILIN,

Let me guess, you are running in Linux. Can't remember last time Windows let us print to root, c:\

Are files really necessary?

codeguy · « **Reply #2 on:** October 15, 2018, 09:35:17 pm »

With a couple mods, no. I found this sort for n=1234567 to be slower by considerable margins than even the visualized version of FlashSort.

Code: QB64: [Select]

TYPE SortRec
    Swaps AS DOUBLE
    compares AS DOUBLE
    writes AS DOUBLE
    timestart AS DOUBLE
    timeend AS DOUBLE
    accumulatedtime AS DOUBLE
    runs AS SINGLE
    NSorted AS DOUBLE
    retrievals AS DOUBLE
    NotSwapped AS DOUBLE
    title AS STRING * 256
    sorttocall AS INTEGER
END TYPE
 
TYPE PixelRec
    pcolor AS INTEGER
    pixnum AS LONG
END TYPE
DIM SHARED Sorts(0 TO 255) AS SortRec
DIM SHARED SortNum
DIM SHARED numcolors%
maxscreenx = 1366
maxscreeny = 768
numcolors% = 256
n& = (maxscreenx * maxscreeny)
DIM SHARED Pixels(0 TO n& - 1) AS PixelRec
SCREEN _NEWIMAGE(maxscreenx, maxscreeny, numcolors%)
DIM t AS SortRec
'* OpenFile t, "r", channel%, "stats.txt"
'DO
'    IF i& > LOF(channel%) \ LEN(t) THEN
'        EXIT DO
'    ELSE
'        i& = i& + 1
'        GET #channel%, i&, t
'        Sorts(i&) = t
'    END IF
'LOOP
lastsort% = -1
DO
    SortNum = 3 'INT(RND * 19)
    Sorts(SortNum).sorttocall = SortNum
    SELECT CASE SortNum
        CASE 1
            HandleSort Sorts(), "QuickSort (Recursive) -- CAR Hoare", 0, n& - 1, maxscreenx
        CASE 2
            HandleSort Sorts(), "ShellSort (Metzler Variant) -- (DL Shell) with improvement by Donald Metzler and seal of approval by Donald knuth", 0, n& - 1, maxscreenx
        CASE 3
            HandleSort Sorts(), "FlashSort -- (Karl Dietrich Neubert) non-comparison sort really fast", 1, n& - 1, maxscreenx
        CASE 4
            HandleSort Sorts(), "Radix Sort -- Jon Von Neumann", 0, n& - 1, maxscreenx
        CASE 5
            HandleSort Sorts(), "Shell Sort (Original) -- (DL Shell)", 0, (n& - 1) \ 8, maxscreenx
        CASE 6
            HandleSort Sorts(), "Shell Sort (Single pass per gap - shrink factor = 1.247...) -- (DL Shell)", 0, n& - 1, maxscreenx
        CASE 7
            HandleSort Sorts(), "HeapSort -- (BR Heap)", 0, n& - 1, maxscreenx
        CASE 8
            HandleSort Sorts(), "CombSort  -- Wlodzimierz Dobosiewicz (later, Lacey, Box)", 0, n& - 1, maxscreenx
        CASE 9
            HandleSort Sorts(), "ShearSort -- some CompuGeeks", 0, 16 * maxscreenx - 1, maxscreenx
            ResetScreen% = -1
        CASE 10
            HandleSort Sorts(), "PostSort -- Your Local Mailman", 0, n& - 1, maxscreenx
        CASE 11
            BatcherScreenX& = 1
            DO
                IF BatcherScreenX& * 2 > maxscreenx THEN
                    EXIT DO
                ELSE
                    BatcherScreenX& = BatcherScreenX& * 2
                END IF
            LOOP
            BatcherScreenY& = 1
            DO
                IF BatcherScreenY& * 2 > maxscreeny THEN
                    EXIT DO
                ELSE
                    BatcherScreenY& = BatcherScreenY& * 2
                END IF
            LOOP
            xy& = BatcherScreenX& * BatcherScreenY&
            HandleSort Sorts(), "Batcher Odd-even MergeSort -- Kenneth E Batcher", 0, xy& - 1, BatcherScreenX&
            ResetScreen% = -1
        CASE 12
            HandleSort Sorts(), "Bucket Sort -- Bucky T (not really)", 0, n& - 1, maxscreenx
        CASE 13
            HandleSort Sorts(), "MergeSort (recursive)", 0, n& - 1, maxscreenx
        CASE 14
            HandleSort Sorts(), "QuickSort Recursive (Stable) -- CAR Hoare, Codeguy!", 0, n& - 1, maxscreenx
        CASE 15
            HandleSort Sorts(), "QuickSort Iterative -- CAR Hoare", 0, n& - 1, maxscreenx
        CASE 16
            HandleSort Sorts(), "MergeExperiment -- ** codeguy! **", 0, n& - 1, maxscreenx
        CASE 17
            HandleSort Sorts(), "Bidirectional ShellSort -- guys in white coats & codeguy", 0, n& - 1, maxscreenx
        CASE 18
            HandleSort Sorts(), "CodeGuySort -- Who Knows but it works -- and fast -- invented by codeguy", 0, n& - 1, maxscreenx
        CASE 19
            HandleSort Sorts(), "Prime Gap Sort -- codeguy", 0, n& - 1, maxscreenx
        CASE 20
            HandleSort Sorts(), "QuickStepRecursive", 0, n& - 1, maxscreenx
        CASE 97
            HandleSort Sorts(), "Tree Sort Ascending -- the keebler elves", 0, 2 * (n& - 1) \ 8, maxscreenx
        CASE 98
            HandleSort Sorts(), "OESort", 0, n& - 1, maxscreenx
        CASE 99
            HandleSort Sorts(), "JSort -- Some guy named J", 0, (n& - 1) \ 16, maxscreenx
        CASE ELSE
            HandleSort Sorts(), "CodeGuySort -- Who Knows but it works -- and fast -- invented by codeguy", 0, n& - 1, maxscreenx
    END SELECT
    IF SortNum <> lastsort% THEN
        IF ResetScreen% THEN
            SCREEN _NEWIMAGE(maxscreenx, maxscreeny, numcolors%)
            ResetScreen% = 0
            lastsort% = SortNum
        END IF
    END IF
    x$ = INKEY$
    IF x$ = "\" THEN
        EXIT DO
    END IF
LOOP
nprinted = 0: GetRawSpeed% = -1
FOR i = 0 TO UBOUND(sorts)
    IF Sorts(i).runs > 0 THEN
        IF Sorts(i).accumulatedtime > 0 THEN
            IF Sorts(i).NSorted > 0 THEN
                LOCATE nprinted \ 2 + 1, (nprinted MOD 2) * 40 + 1
                PRINT USING "SpeedIndex(lo=fast)####.####:"; SpeedIndex#(Sorts(i), 0, n& - 1, GetRawSpeed%, tstart#, tend#, maxscreenx)
                PRINT USING "Swaps    ###,###,###,###,###:"; Sorts(i).Swaps
                PRINT USING "comparisons#,###,###,###,###:"; Sorts(i).compares
                PRINT USING "writes     #,###,###,###,###:"; Sorts(i).writes
                PRINT USING "10000(acc)time##,###,###,###:"; Sorts(i).accumulatedtime * 10000
                PRINT USING "times executed##,###,###,###:"; Sorts(i).runs
                PRINT USING "items sorted ###,###,###,###:"; Sorts(i).NSorted
                PRINT USING "NRetrievals#,###,###,###,###:"; Sorts(i).retrievals
                PRINT USING "Not Swapped#,###,###,###,###:"; Sorts(i).NotSwapped
                PRINT USING "Items/sec##,###,###,###.####:"; Sorts(i).NSorted / Sorts(i).accumulatedtime
                PRINT USING "time(start)  ##,###,###.####:"; Sorts(i).timestart
                PRINT USING "time(end)    ##,###,###.####:"; Sorts(i).timeend
                PRINT LTRIM$(RTRIM$(Sorts(i).title))
                PRINT STRING$(100, "-")
                nprinted = nprinted + 1
            END IF
        END IF
    END IF
    '* PUT #channel%, i, Sorts(i)
NEXT
'* OpenFile t, "c", channel%, "stats.txt"
DO
    x$ = INKEY$
LOOP UNTIL x$ = ""
DO
    x$ = INKEY$
LOOP UNTIL x$ = CHR$(27)
SYSTEM
 
SUB OpenFile (rec AS SortRec, mode$, channel%, f$)
    channel% = FREEFILE
    IF channel% > 0 THEN
        SELECT CASE mode$
            CASE "r"
                OPEN f$ FOR RANDOM AS channel% LEN = LEN(rec)
            CASE "o"
                OPEN f$ FOR OUTPUT AS channel%
            CASE "a"
                OPEN f$ FOR APPEND AS channel%
            CASE "i"
                OPEN f$ FOR INPUT AS channel%
            CASE "c"
                IF channel% > 0 THEN
                    CLOSE channel%
                END IF
        END SELECT
    END IF
END SUB
SUB HandleSort (s() AS SortRec, x$, start&, finish&, maxw)
    SortNum = s(SortNum).sorttocall
    s(SortNum).title = "[" + LTRIM$(STR$(SortNum)) + "]" + x$
    s(SortNum).sorttocall = SortNum
    _TITLE Sorts(SortNum).title
    s(SortNum).NSorted = s(SortNum).NSorted + finish& - start& + 1
    SCREEN _NEWIMAGE(maxw, (finish& - start& + 1) / maxw, numcolors%)
    FOR i& = start& TO finish&
        Pixels(i&).pcolor = INT(RND * numcolors%) + 1
        Pixels(i&).pixnum = i&
        PixelSet i&, maxw, Pixels(i&).pcolor
    NEXT
    s(SortNum).timestart = TIMER
    SELECT CASE SortNum
        CASE 1
            QuickSort start&, finish&, maxw
        CASE 2
            ShellSortMetzler start&, finish&, maxw
        CASE 3
            FlashSort start&, finish&, maxw
        CASE 4
            RadixSort start&, finish&, maxw
        CASE 5
            ShellSort start&, finish&, maxw
        CASE 6
            ShellSortSinglepass start&, finish&, maxw
        CASE 7
            HeapSort start&, finish&, maxw
        CASE 8
            CombSort start&, finish&, maxw
        CASE 9
            ShearSort start&, finish&, maxw
            ResetScreen% = -1
        CASE 10
            PostSort start&, finish&, maxw
        CASE 11
            BatcherOddEvenMergeSort start&, finish&, maxw
            ResetScreen% = -1
        CASE 12
            BucketSort start&, finish&, maxw
        CASE 13
            MergeSort start&, finish&, maxw
        CASE 14
            QuickSortRStable Pixels(), start&, finish&, maxw
        CASE 15
            QuickSortIterative start&, finish&, maxw
        CASE 16
            MergeExperiment start&, finish&, maxw
        CASE 17
            BidirectionalShellSort start&, finish&, maxw
        CASE 18
            CodeGuySort start&, finish&, maxw
        CASE 19
            PrimeGapSort start&, finish&, maxw
        CASE 20
            QuickStepRecursive start&, finish&, 2, maxw
            QuickStepRecursive start&, finish&, 1, maxw
        CASE 97
            TreeSortAscending start&, finish&, maxw
        CASE 98
            OESort start&, finish&, maxw
        CASE 99
            JSort start&, finish&, maxw
        CASE ELSE
            CodeGuySort start&, finish&, maxw
    END SELECT
    s(SortNum).timeend = TIMER
    s(SortNum).runs = s(SortNum).runs + 1
    IF s(SortNum).timeend < s(SortNum).timestart THEN
        s(SortNum).accumulatedtime = s(SortNum).accumulatedtime + (s(SortNum).timeend - s(SortNum).timestart) + 86400
    ELSE
        s(SortNum).accumulatedtime = s(SortNum).accumulatedtime + s(SortNum).timeend - s(SortNum).timestart
    END IF
END SUB
SUB SetRandomPixels (p() AS PixelRec, start&, finish&, maxw)
    FOR i& = start& TO finish&
        Pixels(i&).pixnum = i&
        Pixels(i&).pcolor = INT(RND * numcolors%) + 1
    NEXT
END SUB
 
SUB QuickSort (start&, finish&, maxw)
    IF finish& - start& = 1 THEN
        IF LessThan%(CompareScreen%(finish&, start&, maxw)) THEN
            PixelSwap start&, finish&, maxw
        END IF
    ELSE
        IF finish& - start& > 1 THEN
            i& = start&
            j& = finish&
            m% = GetPixel%(i& + RND * (j& - i& + 1), maxw)
            DO
                WHILE GetPixel%(i&, maxw) < m%
                    i& = i& + 1
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                WEND
                WHILE GetPixel%(j&, maxw) > m%
                    j& = j& - 1
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                WEND
                IF i& < j& THEN
                    PixelSwap i&, j&, maxw
                END IF
                i& = i& + 1
                j& = j& - 1
            LOOP UNTIL i& > j&
            QuickSort i&, finish&, maxw
            QuickSort start&, j&, maxw
        END IF
    END IF
END SUB
 
'* Radix sort is akin to Postman's sort, however instead of sorting items after they've been inserted into their proper "boxes,"
'* another pass is made using the next character (in this case bit) of the sortation key. bits& can be changed to the number of
'* characters in the sorting key (Field length). RadixSort also has a linear running time, but requires extra storage in exchange
'* for speed. RadixSort is not a true comparison sort. It's actually more of a computed distribution sort than anything else. RadixSort
'* in this implementation is Stable. Speed... Stability... Linear running time... (Hmmm...)
 
SUB RadixSort (Start&, Finish&, maxw)
    'ChangeTitleBar "RadixSort ****"
    FOR i& = Start& TO Finish&
        t% = GetPixel%(i&, maxw)
        IF t% > h% THEN
            h% = t%
        END IF
    NEXT
    DIM PsCount%(0 TO h%, Start& TO Finish&), ct&(h%), Pow2&(32)
    bits& = LOG(h% + 2) \ LOG(2) + 1
    FOR i = 0 TO bits&
        Pow2&(i) = 2 ^ i
    NEXT
    FOR j& = 0 TO bits&
        FOR i& = Start& TO Finish&
            a% = GetPixel%(i&, maxw)
            x% = a% AND Pow2&(j&)
            PsCount%(x%, ct&(x%)) = a%
            ct&(x%) = ct&(x%) + 1
        NEXT
        index& = Start&
        FOR u% = 0 TO h%
            FOR i& = 0 TO ct&(u%) - 1
                PixelSet index&, maxw, PsCount%(u%, i&)
                index& = index& + 1
            NEXT
            ct&(u%) = 0
        NEXT
    NEXT
END SUB
 
'* this is dl shell's sort but modified for faster running time than standard shellsort.
SUB ShellSortMetzler (Start&, Finish&, maxw)
    m& = Metzler&(Start&, Finish&)
    WHILE m& > 0
        FOR j& = Start& TO Finish& - m&
            l& = j& + m&
            B% = GetPixel%(l&, maxw)
            FOR i& = j& TO Start& STEP -m&
                IF GetPixel%(i&, maxw) > B% THEN
                    PixelSwap i& + m&, i&, maxw
                    l& = i&
                ELSE
                    i& = Start&
                END IF
                Sorts(SortNum).compares = Sorts(SortNum).compares + 1
            NEXT
            PixelSet l&, maxw, B%
        NEXT
        m& = (m& - 1) \ 3
    WEND
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
 
SUB ShellSort (start, finish&, maxw)
    Gap& = (finish& - Start& + 1)
    DO
        st& = Start&: b& = st&
        ends& = finish& - Gap&: a& = ends&
        DO
            st& = b&
            ends& = a&
            a& = st&
            b& = ends&
            FOR i& = st& TO ends&
                IF GetPixel%(i&, maxw) > GetPixel%(i& + Gap&, maxw) THEN
                    PixelSwap i&, i& + Gap&, maxw
                    a& = i&
                    IF i& < b& THEN
                        b& = i&
                    END IF
                END IF
            NEXT
        LOOP WHILE (a& > st&) ' OR (b& = ends&)
        Gap& = Gap& \ 2
        st& = Start&
        ends& = finish& - Gap&
    LOOP UNTIL Gap& < 1
END SUB
 
SUB ShellSortSinglepass (start&, finish&, maxw)
    Gap& = (finish& - start& + 1) \ 1.247#
    DO
        FOR i& = start& TO finish& - Gap&
            IF CompareScreen%(i&, i& + Gap&, maxw) = 1 THEN
                PixelSwap i&, i& + Gap&, maxw
            END IF
        NEXT
        Gap& = INT(Gap& / 1.247#)
    LOOP UNTIL Gap& < 1
END SUB
 
SUB FlashSort (Start&, finish&, maxw)
    m& = .128 * finish&
    DIM L(m&), a(Start& TO finish&)
    nmax& = Start&
    minptr& = Start&
    FOR i& = Start& TO finish&
        a(i&) = GetPixel%(i&, maxw)
        IF CompareScreen%(i&, minptr&, maxw) = -1 THEN minptr& = i&
        IF CompareScreen%(i&, nmax&, maxw) = 1 THEN nmax& = i&
    NEXT i&
    IF CompareScreen%(minptr&, nmax&, maxw) = 0 THEN EXIT SUB
    C1# = (m& - 1) / (a(nmax&) - a(minptr&))
    FOR k& = 1 TO m&
        L(k&) = 0
    NEXT k&
    FOR i& = Start& TO finish&
        k& = 1 + INT(C1# * (a(i&) - a(minptr&)))
        L(k&) = L(k&) + 1
    NEXT i&
    FOR k& = 2 TO m&
        L(k&) = L(k&) + L(k& - 1)
    NEXT k&
    anmin% = a(minptr&)
    hold% = a(nmax&)
    a(nmax&) = a(Start&)
    a(Start&) = hold%
    PixelSwap nmax&, Start&, maxw
    PixelSet Start&, hold%, maxw
    nmove& = 0
    j& = 1
    k& = m&
    WHILE (nmove& < (finish& - 1))
        WHILE (j& > L(k&))
            j& = j& + 1
            k& = 1 + INT(C1# * (a(j&) - anmin%))
        WEND
        flash% = a(j&)
        PixelSet j&, maxw, flash%
        WHILE (NOT (j& = (L(k&) + 1)))
            k& = 1 + INT(C1# * (flash% - anmin%))
            PixelSet L(k&), maxw, a(L(k&))
            hold% = a(L(k&))
            a(L(k&)) = flash%
            PixelSet L(k&), maxw, flash%
            flash% = hold%
            L(k&) = L(k&) - 1
            nmove& = nmove& + 1
        WEND
    WEND
    FOR i& = finish& - 2 TO Start& STEP -1
        IF CompareArray%(a(), i& + 1, i&) = -1 THEN
            hold% = a(i&)
            j& = i&
            WHILE (a(j& + 1) < hold%)
                PixelSwap j&, j& + 1, maxw
                a(j&) = a(j& + 1)
                j& = j& + 1
            WEND
            a(j&) = hold%
            PixelSet j&, maxw, hold%
        END IF
    NEXT i&
END SUB
 
FUNCTION GetPixel% (i&, maxw)
    col% = i& MOD maxw
    row% = (i& - col%) / maxw
    GetPixel% = POINT(col%, row%)
    Sorts(SortNum).retrievals = Sorts(SortNum).retrievals + 1
END FUNCTION
 
SUB PixelSet (i&, maxw, c%)
    col% = i& MOD maxw
    row% = (i& - col%) / maxw
    PSET (col%, row%), c%
    Sorts(SortNum).writes = Sorts(SortNum).writes + 1
    'Pixels(i&).pcolor = c%
END SUB
 
SUB PixelSwap (i&, j&, maxw)
    IF i& <> j& THEN
        a% = GetPixel%(i&, maxw)
        b% = GetPixel%(j&, maxw)
        IF a% = b% THEN
            Sorts(SortNum).NotSwapped = Sorts(SortNum).NotSwapped + 1
        ELSE
            PixelSet j&, maxw, a%
            PixelSet i&, maxw, b%
            Sorts(SortNum).Swaps = Sorts(SortNum).Swaps + 1
            'Pixels(i&).pcolor = b%
            'Pixels(j&).pcolor = a%
        END IF
    END IF
END SUB
 
FUNCTION CompareScreen% (i&, j&, maxw)
    s% = 0
    IF GetPixel%(i&, maxw) > GetPixel%(j&, maxw) THEN
        s% = 1
    ELSE
        IF GetPixel%(i&, maxw) < GetPixel%(j&, maxw) THEN
            s% = -1
        END IF
    END IF
    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
    CompareScreen% = s%
END SUB
 
FUNCTION CompareArray% (a(), i&, j&)
    s% = 0
    IF a(i&) < a(j&) THEN
        s% = -1
    ELSE
        IF a(i&) > a(j&) THEN
            s% = 1
        END IF
    END IF
    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
    CompareArray% = s%
END FUNCTION
 
FUNCTION LessThan% (a%)
    s% = 0
    IF a% = -1 THEN
        s% = -1
    END IF
    LessThan% = s%
END FUNCTION
 
SUB QuickStepRecursive (start&, finish&, incby%, maxw)
    IF finish& - start& < incby% ^ 2 THEN
        IF LessThan%(CompareScreen%(finish&, start&, maxw)) THEN
            PixelSwap finish&, start&, maxw
        END IF
    ELSE 'IF finish& - start& > incby% ^ 2 THEN
        i& = start&
        remainder% = (finish& - start&) MOD incby%
        j& = i& + incby% * ((finish& - start& - remainder%) / incby%)
        'j& = start& + incby% * ((finish& - start&) / (incby%))
        middle& = i& + (j& - i&) \ (incby%)
        m% = GetPixel%(middle&, maxw)
        DO
            WHILE GetPixel%(i&, maxw) < m% AND i& < j&
                i& = i& + incby%
            WEND
            WHILE GetPixel%(j&, maxw) > m% AND j& > i&
                j& = j& - incby%
            WEND
            IF i& < j& THEN
                PixelSwap i&, j&, maxw
            END IF
            i& = i& + incby%
            j& = j& - incby%
        LOOP UNTIL j& - i& <= incby% ^ 2
        QuickStepRecursive i&, finish&, incby%, maxw
        QuickStepRecursive start&, j&, incby%, maxw
    END IF
END SUB
 
FUNCTION NLOGN# (n&)
    NLOGN# = n& * (LOG(n&) / LOG(2))
END FUNCTION
 
' this version of HeapSort can now sort parts of lists, rather than being limited to entire lists. The one that usually appears is one that
' sorts from the beginning to the end.
 
SUB HeapSort (Start&, Finish&, maxw)
    FOR i& = Start& + 1 TO Finish&
        PercolateUp Start&, i&, maxw
    NEXT i&
 
    FOR i& = Finish& TO Start& + 1 STEP -1
        PixelSwap Start&, i&, maxw
        PercolateDown Start&, i& - 1, maxw
    NEXT i&
 
END SUB
 
SUB PercolateDown (Start&, MaxLevel&, maxw)
    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
        ' If there are two Child nodes, find out which one is bigger:
        ax& = Child& + 1
        IF ax& <= MaxLevel& THEN
            IF CompareScreen%(ax&, Child&, maxw) = 1 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 CompareScreen%(i&, Child&, maxw) = -1 THEN
            PixelSwap i&, Child&, maxw
            i& = Child&
 
            ' Otherwise, GetPixel%() has been restored to a heap from 0 to MaxLevel&,
            ' so exit:
        ELSE
            EXIT DO
        END IF
    LOOP
END SUB
 
SUB PercolateUp (Start&, MaxLevel&, maxw)
    i& = MaxLevel&
 
    ' Move the value in GetPixel%(MaxLevel&, maxw) 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 CompareScreen%(i&, Parent&, maxw) = 1 THEN
            PixelSwap Parent&, i&, maxw
            i& = Parent&
 
            ' Otherwise, the element has reached its proper place in the heap,
            ' so exit this procedure:
        ELSE
            EXIT DO
        END IF
    LOOP
END SUB
 
SUB CombSort (Start&, Finish&, maxw)
    m = INT(RND * 2)
    SELECT CASE m
        CASE 0
            ShrinkFactor# = 1.247330950103979#
        CASE ELSE
            ShrinkFactor# = 1.3#
    END SELECT
    gap& = Finish& - Start&
    BooleanSwapped% = -1
    WHILE (gap& > 1) OR BooleanSwapped%
        IF (gap& > 1) THEN
            gap& = INT(gap& / ShrinkFactor#)
        END IF
        BooleanSwapped% = 0
        FOR i& = Start& TO Finish& - gap&
            IF CompareScreen%(i&, i& + gap&, maxw) = 1 THEN
                PixelSwap i&, i& + gap&, maxw
                BooleanSwapped% = -1
            END IF
        NEXT
        IF (gap& = 1 AND NOT BooleanSwapped%) THEN
            EXIT SUB
        END IF
    WEND
END SUB
 
'* ShearSort rearranges elements into a "square" array and then sorts even and odd sets of columns and rows. this is the slice and dice method of sorting
'* which i assume runs far more quickly on multiprocessors. it is included only as a matter of interest as it is what i consider a "beautiful," even if not
'* blindingly fast sorting method. this is a parallel sorting algo translated to single-processor (could be tackled with simultaneous threading if our man
'* Galleon could find some way to exploit multiple threads and processors).
 
SUB ShearSort (start&, finish&, maxw)
    MakeSquare% = -1
    sortorder% = 1
    IF MakeSquare% THEN
        '* put elements into a "square" arrangement.
        rows& = INT(SQR(finish& - start& + 1))
        IF (finish& - start& + 1) MOD rows& THEN
            cols& = (finish& - start& + 1) \ rows& + 1
        ELSE
            cols& = (finish& - start& + 1) / rows&
        END IF
        IF rows& > cols& THEN
            rows& = cols&
        ELSE
            cols& = rows&
        END IF
    ELSE
        cols& = maxw
        rows& = (finish& - start& + 1) / maxw
    END IF
    SCREEN _NEWIMAGE(cols&, rows&, numcolors%)
    FOR i& = start& TO finish&
        PixelSet i&, cols&, Pixels(i&).pcolor
    NEXT
 
    colsminusone& = cols& - 1
    rminuslplusoneminuscols& = finish& - start& + 1 - cols&
    k& = rows&
    DO
        '* slice
        FOR j& = 1 TO cols&
            tmpj& = j& MOD 2
            FOR i& = start& TO finish& STEP cols&
                IF ((i& - start&) / cols&) MOD 2 THEN
                    OETransSort i& + tmpj&, i& + colsminusone&, 1, -sortorder%, cols& '-sortorder%
                ELSE
                    OETransSort i& + tmpj&, i& + colsminusone&, 1, sortorder%, cols& '+sortorder% +
                END IF
            NEXT
        NEXT
        '* and then dice
        FOR j& = 1 TO rows&
            tmpj& = j& MOD 2
            FOR i& = start& TO start& + colsminusone&
                SELECT CASE tmpj&
                    CASE 0
                        OETransSort i&, rminuslplusoneminuscols& + i&, cols&, -sortorder%, cols&
                    CASE ELSE
                        OETransSort i& + tmpj& * cols&, rminuslplusoneminuscols& + i&, cols&, -sortorder%, cols& '-s%
                END SELECT
            NEXT
        NEXT
        FOR j& = 1 TO cols&
            tmpj& = j& MOD 2
            FOR i& = l& TO r& STEP cols&
                SELECT CASE tmpj&
                    CASE 0
                        OETransSort i&, i& + colsminusone&, rows&, sortorder%, cols&
                    CASE ELSE
                        OETransSort i& + tmpj&, i& + colsminusone&, rows&, sortorder%, cols&
                END SELECT
            NEXT
        NEXT
        k& = (k& - (k& MOD 2)) \ 2
    LOOP WHILE k& > 2
 
    EXIT SUB
    FOR j& = 1 TO cols&
        tmpj& = j& MOD 2
        FOR i& = l& TO r& STEP cols&
            SELECT CASE tmpj&
                CASE 0
                    OETransSort i&, i& + colsminusone&, 1, sortorder%, cols&
                CASE ELSE
                    OETransSort i& + tmpj&, i& + colsminusone&, 1, sortorder%, cols&
            END SELECT
        NEXT
    NEXT
END SUB
 
SUB OETransSort (l&, r&, gap&, order%, maxw)
    rx& = gap&
    lst& = r& - rx&
    FOR i& = l& TO lst& STEP gap& * 2
        x% = CompareScreen%(i&, i& + gap&, maxw)
        IF x% <> order% THEN
            IF x% THEN
                PixelSwap i&, i& + gap&, maxw
            END IF
        END IF
    NEXT
END SUB
 
'* PostSort find the range of the data to be sorted and loads those into "boxes," which is essentially a 2-d array.
'* then sort what's in the "boxes" individually using whatever sort -- in this case quicksort.
SUB PostSort (start&, Finish&, maxw)
    FindMinMax start&, Finish&, lptr&, rptr&, maxw
    cmin% = GetPixel%(lptr&, maxw)
    cmax% = GetPixel%(rptr&, maxw)
    DIM PsCount&(cmin% TO cmax%, start& TO Finish&), ct&(cmin% TO cmax%)
    FOR i& = start& TO Finish&
        x% = GetPixel%(i&, maxw)
        PsCount&(x%, ct&(x%)) = x%
        ct&(x%) = ct&(x%) + 1
    NEXT
    Index& = start&
    Last = start&
    FOR i% = cmin% TO cmax%
        FOR j& = 0 TO ct&(i%) - 1
            PixelSet Index&, maxw, PsCount&(i%, start& + j&)
            Index& = Index& + 1
        NEXT
        QuickSort Last&, Last& + ct&(i%) - 1, maxw
        Last& = Index&
    NEXT
END SUB
 
SUB BatcherOddEvenMergeSort (Start&, Finish&, maxw)
    IF (Finish& > 1) THEN
        m& = (Finish& + (Finish& MOD 2)) \ 2
        BatcherOddEvenMergeSort Start&, m&, maxw
        BatcherOddEvenMergeSort Start& + m&, m&, maxw
        BatcheroddEvenMerge Start&, Finish&, 1, maxw
    END IF
END SUB
 
SUB BatcheroddEvenMerge (Start&, Finish&, r&, maxw)
    m& = r& * 2
    IF (m& < Finish&) AND m& > 0 THEN
        BatcheroddEvenMerge Start&, Finish&, m&, maxw
        BatcheroddEvenMerge Start& + r&, Finish&, m&, maxw
        i& = Start& + r&
        DO
            IF i& + m& > Start& + Finish& THEN
                EXIT DO
            ELSE
                IF GetPixel%(i&, maxw) > GetPixel%(i& + r&, maxw) THEN
                    PixelSwap i&, i& + r&, maxw
                END IF
                i& = i& + m&
            END IF
        LOOP
    ELSE
        IF GetPixel%(Start&, maxw) > GetPixel%(Start& + r&, maxw) THEN
            PixelSwap Start&, Start& + r&, maxw
        END IF
    END IF
END SUB
 
SUB JSortReHeap (length&, i&, maxw)
    done% = 0
    T% = GetPixel%(i&, maxw)
    parent& = i&
    child& = 2 * (i& + 1) - 1
    WHILE ((child& < length&) AND NOT (done%))
        IF (child& < length& - 1) THEN
            IF (GetPixel%(child&, maxw) >= GetPixel%(child& + 1, maxw)) THEN
                child& = child& + 1
            END IF
        END IF
        IF (T% < GetPixel%(child&, maxw)) THEN
            done% = -1
        ELSE
            PixelSet parent&, maxw, GetPixel%(child&, maxw)
            parent& = child&
            child& = 2 * (parent& + 1) - 1
        END IF
        PixelSet parent&, maxw, T%
    WEND
END SUB
 
SUB JSortInvReHeap (length&, i&, maxw)
    done% = 0
    T% = GetPixel%(length& - 1 - i&, maxw)
    parent& = i&
    child& = 2 * (i& + 1) - 1
    WHILE ((child& < length&) AND (NOT done%))
        IF (child& < length& - 1) THEN
            ns& = length& - 1
            IF GetPixel%(ns& - child&, maxw) <= GetPixel%(ns& - child& - 1, maxw) THEN
                child& = child& + 1
            END IF
        END IF
        IF T% > GetPixel%(length& - 1 - child&, maxw) THEN
            done% = -1
        ELSE
            PixelSet length& - 1 - parent&, maxw, GetPixel%(length& - 1 - child&, maxw)
            parent& = child&
            child& = 2 * (parent& + 1) - 1
        END IF
    WEND
    PixelSet length& - 1 - parent&, maxw, T%
END SUB
 
SUB JSort (start&, finish&, maxw)
    '// Do an insertion sort on the almost sorted array
    FOR j& = start& TO finish& - 1
        '// Heapify top down
        IF finish& > j& THEN
            FOR i& = finish& - 1 TO j& STEP -2
                JSortReHeap i&, j&, maxw
            NEXT
            FOR i& = finish& - 1 TO j& STEP -2
                JSortInvReHeap i&, j&, maxw
            NEXT
        END IF
        T% = GetPixel%(j&, maxw)
        a& = j&
        DO
            IF a& > start& THEN
                b& = a&
                a& = a& - 1
                IF GetPixel%(a&, maxw) > T% THEN
                    PixelSwap a&, b&, maxw
                ELSE
                    EXIT DO
                END IF
            ELSE
                EXIT DO
            END IF
        LOOP
        PixelSet b&, maxw, T%
    NEXT
END SUB
 
'* to keep BucketSort stable, you must use a stable sort on Lists&(), or if you prefer speed, just use quicksort if you don't care about
'* sort stability.
 
SUB BucketSort (start&, finish&, maxw)
    FindMinMax start&, finish&, lptr&, rptr&, maxw
    min% = GetPixel%(lptr&, maxw)
    max% = GetPixel%(rptr&, maxw)
    NBuckets& = SQR(((max% - min%) / 2) ^ 2)
    BucketSize& = 1.28 * (finish& - start& + 1) \ (NBuckets&)
    DIM Lists&(NBuckets&, BucketSize&), Counts&(min% TO max%), OverFlowedCt&(min% TO max%)
    difference& = (max% - min% + 1) \ NBuckets&
    FOR i& = start& TO finish&
        BucketNum& = GetPixel%(i&, maxw) \ difference&
        DO
            IF Counts&(BucketNum&) > BucketSize& THEN
                OverFlowedCt&(BucketNum&) = -1
                IF BucketNum& > 0 THEN
                    IF Counts&(BucketNum& - 1) > BucketSize& THEN
                        BucketNum& = BucketNum& + 1
                    ELSE
                        BucketNum& = BucketNum& - 1
                    END IF
                ELSE
                    IF BucketNum& < NBuckets& THEN
                        BucketNum& = BucketNum& + 1
                    ELSE
                        STOP
                    END IF
                END IF
            ELSE
                EXIT DO
            END IF
        LOOP
        Lists&(BucketNum&, Counts&(BucketNum&)) = GetPixel%(i&, maxw)
        Counts&(BucketNum&) = Counts&(BucketNum&) + 1
    NEXT
    idx& = start&
    last& = start&
    FOR i& = min% TO max%
        '* roughly sorts Lists&() in a stable manner
        SortBuckets Lists&(), 0, Counts&(i&) - 1, i&, maxw
        FOR u& = 0 TO Counts&(i&) - 1
            PixelSet idx&, maxw, Lists&(i&, u&)
            idx& = idx& + 1
        NEXT
        ShellSortMetzler last&, idx& - 1, maxw
        last& = idx&
    NEXT
END SUB
 
SUB SortBuckets (Lists&(), Start&, Finish&, ListIndex&, maxw)
    IF Finish& - Start& = 1 THEN
        IF Lists&(ListIndex&, Start&) > Lists&(ListIndex&, Finish&) THEN
            SWAP Lists&(ListIndex&, Start&), Lists&(ListIndex&, Finish&)
        END IF
    ELSE
        IF Finish& - Start& > 1 THEN
            'u& = (Finish& - Start&) MOD 2
            m& = Start& + (Finish& - Start&) \ 2
            SortBuckets Lists&(), Start&, m&, ListIndex&, maxw
            SortBuckets Lists&(), m&, Finish&, ListIndex&, maxw
        END IF
    END IF
END SUB
 
SUB FindMinMax (start&, finish&, MinPtr&, MaxPtr&, maxw)
    MinPtr& = start&: min% = GetPixel%(start&, maxw)
    MaxPtr& = start&: max% = GetPixel%(start&, maxw)
    FOR i& = start& TO finish&
        m% = GetPixel%(i&, maxw)
        IF m% < min% THEN
            min% = m%
            MinPtr& = i&
        END IF
        IF m% > max% THEN
            max% = m%
            MaxPtr& = i&
        END IF
    NEXT
END SUB
 
SUB MergeSort (start&, finish&, maxw)
    IF start& >= finish& THEN EXIT SUB
    length& = finish& - start& + 1
    middle& = start& + (finish& - start&) \ 2
    MergeSort start&, middle&, maxw
    MergeSort middle& + 1, finish&, maxw
    DIM temp(length& - 1)
    FOR i& = 0 TO length& - 1
        temp(i&) = GetPixel%(start& + i&, maxw)
    NEXT
    mptr& = 0
    sptr& = middle& - start& + 1
    FOR i& = 0 TO length& - 1
        IF sptr& <= finish& - start& THEN
            IF mptr& <= middle& - start& THEN
                IF temp(mptr&) > temp(sptr&) THEN
                    PixelSet i& + start&, maxw, temp(sptr&)
                    sptr& = sptr& + 1
                ELSE
                    PixelSet i& + start&, maxw, temp(mptr&)
                    mptr& = mptr& + 1
                END IF
            ELSE
                PixelSet i& + start&, maxw, temp(sptr&)
                sptr& = sptr& + 1
            END IF
        ELSE
            PixelSet i& + start&, maxw, temp(mptr&)
            mptr& = mptr& + 1
        END IF
    NEXT
END SUB
 
SUB OESort (Start&, Finish&, maxw)
    sorted = 0
    WHILE NOT sorted
        sorted = -1
        FOR i& = Start& TO Finish& - 1 STEP 2
            IF CompareScreen%(i&, i& + 1, maxw) = 1 THEN
                PixelSwap i&, i& + 1, maxw
                sorted = 0
            END IF
        NEXT
        FOR i& = Start& + 1 TO Finish& - 2 STEP 2
            IF CompareScreen%(i&, i& + 1, maxw) = 1 THEN
                PixelSwap i&, i& + 1, maxw
            END IF
        NEXT
    WEND
END SUB
 
SUB QuickSortRStable (r() AS PixelRec, start&, finish&, maxw)
    IF finish& - start& = 1 THEN
        CompareRecs r(), start&, finish&, maxw
    ELSE
        IF finish& - start& > 1 THEN
            i& = start&
            j& = finish&
            p# = StableIndex#(r(), (i& + (j& - i& + 1) \ 2), maxw)
            DO
                WHILE StableIndex#(r(), i&, maxw) < p#
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                    i& = i& + 1
                WEND
                WHILE StableIndex#(r(), j&, maxw) > p#
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                    j& = j& - 1
                WEND
                IF i& <= j& THEN
                    CompareRecs r(), i&, j&, maxw
 
                    i& = i& + 1
                    j& = j& - 1
                END IF
            LOOP UNTIL i& > j&
            QuickSortRStable r(), i&, finish&, maxw
            QuickSortRStable r(), start&, j&, maxw
        END IF
    END IF
END SUB
 
'* swapping indexes is much faster than swapping entire records
'* the index for this Pixels is simply the r().pixnum field of Pixels type PixelRec r()
SUB CompareRecs (r() AS PixelRec, i&, j&, maxw)
    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
    IF r(r(i&).pixnum).pcolor <= r(r(j&).pixnum).pcolor THEN
        IF r(i&).pixnum > r(j&).pixnum THEN
            SWAP r(i&).pixnum, r(j&).pixnum
        END IF
    ELSE
        Sorts(SortNum).compares = Sorts(SortNum).compares + 1
        IF r(r(i&).pixnum).pcolor > r(r(j&).pixnum).pcolor THEN
            SWAP r(i&).pixnum, r(j&).pixnum
        END IF
    END IF
    PixelSet i&, maxw, r(r(i&).pixnum).pcolor
    PixelSet j&, maxw, r(r(j&).pixnum).pcolor
    EXIT SUB
    IF StableIndex#(r(), i&, maxw) > StableIndex#(r(), j&, maxw) THEN
        PixelSwap r(r(i&).pixnum).pixnum, r(r(j&).pixnum).pixnum, maxw
        SWAP r(i&).pixnum, r(j&).pixnum
    END IF
END SUB
 
FUNCTION StableIndex# (r() AS PixelRec, a&, maxw)
    np# = 10 ^ (LOG(UBOUND(r) + 1) \ LOG(10))
    StableIndex# = r(r(a&).pixnum).pcolor * np# + r(a&).pixnum
END FUNCTION
 
SUB QuickSortIterative (Start&, Finish&, maxw)
    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% = GetPixel%(Mid&, maxw)
            DO
                DO WHILE GetPixel%(i&, maxw) < Compare%
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                    i& = i& + 1
                LOOP
                DO WHILE GetPixel%(j&, maxw) > Compare%
                    Sorts(SortNum).compares = Sorts(SortNum).compares + 1
                    j& = j& - 1
                LOOP
                IF i& < j& THEN
                    PixelSwap i&, j&, maxw
                END IF
                i& = i& + 1
                j& = j& - 1
            LOOP UNTIL i& > j&
            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
 
' this sort splits the list in half and then merges them, however, it requires extra space -- the travails of gaining extra speed!
' but on average, it is quicker than quicksorting the entire list as the arrays are already sorted by the time they get merged, which
' itself is a nearly linear process. as long as a stable sort is used to sort array segments, this should remain a stable sort!
SUB MergeExperiment (Start&, Finish&, maxw)
    HowManySets = 2 'LOG(Finish& - Start& + 1) \ LOG(2) + 1
    DIM Starts&(HowManySets), Ends&(HowManySets)
    m& = (Finish& - Start&) MOD HowManySets
    segment& = (Finish& - Start& - m&) / HowManySets
    u = HowManySets - 1
    f& = Finish&
    DO
        Ends&(u) = f&
        Starts&(u) = f& - segment&
        f& = f& - (segment& + 1)
        u = u - 1
    LOOP UNTIL u < 0
    index& = 0
    FOR i = 0 TO HowManySets - 1
        MergeSort Starts&(i), Ends&(i), maxw
    NEXT
    mergetosum& = 0
    FOR i = 0 TO HowManySets - 1 STEP 2
        StartMast& = Starts&(i)
        EndMast& = Ends&(i)
        StartSlave& = Starts&(i + 1)
        EndSlave& = Ends&(i + 1)
        REDIM Master%(StartMast& TO EndMast&)
        REDIM Slave%(StartSlave& TO EndSlave&)
        FOR i& = StartMast& TO EndMast&
            Master%(i&) = GetPixel%(i&, maxw)
        NEXT
        FOR i& = StartSlave& TO EndSlave&
            Slave%(i&) = GetPixel%(i&, maxw)
        NEXT
        Master& = StartMast&
        Slave& = StartSlave&
        index& = Start&
        DO
            IF Master& > EndMast& THEN
                IF Slave& > EndSlave& THEN '* both lists are fully traversed
                    EXIT DO
                ELSE '* empty the slave list
                    PixelSet index&, maxw, Slave%(Slave&)
                    Slave& = Slave& + 1
                END IF
            ELSE
                IF Slave& > EndSlave& THEN '* empty the master list
                    PixelSet index&, maxw, Master%(Master&)
                    Master& = Master& + 1
                ELSE '* Master%() and Slave%() both have unprocessed elements
                    IF Master%(Master&) > Slave%(Slave&) THEN
                        PixelSet index&, maxw, Slave%(Slave&)
                        Slave& = Slave& + 1
                    ELSE
                        PixelSet index&, maxw, Master%(Master&)
                        Master& = Master& + 1
                    END IF
                END IF
            END IF
            index& = index& + 1
        LOOP
    NEXT
END SUB
 
'* part 2, dammit!
 
'* 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 time when gap& is 1
SUB BidirectionalShellSort (Start&, Finish&, maxw)
    gap& = (Finish& - Start& + 1) \ 2
    DO
        up% = -1: down% = -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 CompareScreen%(i&, i& + gap&, maxw) = 1 THEN
                        PixelSwap i&, i& + gap&, maxw
                        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 CompareScreen%(i&, i& - gap&, maxw) = -1 THEN
                        PixelSwap i&, i& - gap&, maxw
                        IF i& > FirstDown& THEN
                            FirstDown& = i&
                        END IF
                        LastDown& = i&
                        down% = -1
                    END IF
                NEXT
                startdn& = FirstDown&
                enddown& = LastDown&
                SWAP FirstDown&, LastDown&
            END IF
        LOOP UNTIL NOT (up% OR down%)
        gap& = gap& \ 2
    LOOP WHILE gap& > 0
END SUB
 
'* for highly repetitive data, TreeSortAscending becomes like an insertion sort, which degenerates to polynomial time, which is NOT good. this sort is far
'* better suited to data that is not repetitive. by the way, 16 is an arbitrary number and can be set to whatever your threshold of pain for a possibly
'* polynomial time sort.
 
SUB TreeSortAscending (start&, finish&, maxw)
    FindMinMax start&, finish&, MinPtr&, MaxPtr&, maxw
    delta# = GetPixel%(MaxPtr&, maxw) - GetPixel%(MinPtr&, maxw)
    IF delta# = 0 THEN 'already sorted because they're all equal
        EXIT SUB
    ELSE
        IF ABS((finish& - start& + 1) / delta#) > 65535 THEN
            BucketSort start&, finish&, maxw
            EXIT SUB
        END IF
    END IF
    NilValue% = GetPixel%(MinPtr&, maxw) - 1
    TYPE TreeNode
        value AS LONG
        left AS LONG
        right AS LONG
    END TYPE
    DIM tree(start& + 1 TO finish& + 1) AS TreeNode
    FOR x& = start& + 1 TO finish& + 1
        tree(x&).value = NilValue%
        tree(x&).left = NilValue%
        tree(x&).right = NilValue%
    NEXT
    tree(1).value = GetPixel%(1 - 1, maxw)
    free& = 2
    FOR x& = 2 TO finish&
        pointer& = 1
        xv& = (GetPixel%(x& - 1, maxw))
        DO
            IF xv& < tree(pointer&).value THEN
                IF tree(pointer&).left = NilValue% THEN
                    tree(pointer&).left = free&
                    tree(free&).value = xv&
                    'PixelSet free& - 1, maxw, tree(tree(pointer&).left).value
                    free& = free& + 1
                    EXIT DO
                ELSE
                    pointer& = tree(pointer&).left
                END IF
            ELSE
                IF tree(pointer&).right = NilValue% THEN
                    tree(pointer&).right = free&
                    tree(free&).value = xv&
                    'PixelSet free& - 1, maxw, tree(tree(pointer&).right).value
                    free& = free& + 1
                    EXIT DO
                ELSE
                    pointer& = tree(pointer&).right
                END IF
            END IF
        LOOP
    NEXT x&
    depth& = 1
    traverse start& + 1, depth&, tree(), NilValue%, maxw
END SUB
 
SUB traverse (start&, depth&, tree() AS TreeNode, NilValue%, maxw)
    IF tree(start&).left <> NilValue% THEN traverse tree(start&).left, depth&, tree(), NilValue%, maxw
    PixelSet depth& - 1, maxw, tree(start&).value
    depth& = depth& + 1
    IF tree(start&).right <> NilValue% THEN traverse tree(start&).right, depth&, tree(), NilValue%, maxw
END SUB
 
'* this algo at first glance looks like it'd be just another slow version of shellsort, but crap if it doesn't rank well with my sortindex at 31
SUB CodeGuySort (Start&, Finish&, maxw)
    'rows& = (Finish& - Start& + 1) / maxw
    gap& = (Finish& - Start& + 1) \ 2
    DO
        IF gap& < maxw THEN
            m& = Start&
            FOR x% = 0 TO (Finish& - Start& + 1) \ maxw
                ShellSortMetzler m&, m& + gap&, maxw
                m& = m& + gap&
            NEXT
        ELSE
            rows& = (Finish& - Start& - gap&) / maxw
            FOR b% = 0 TO 1
                FOR offset& = b% TO maxw STEP b% + 1
                    FOR x% = b% TO (maxw - gap&) \ gap& STEP b% + 1
                        FOR j& = b% TO rows& STEP b% + 1
                            y& = j& * maxw + offset&
                            z& = y& + gap&
                            IF z& > Finish& THEN
                                exitnextfor = -1
                                EXIT FOR
                            END IF
                            IF CompareScreen%(y&, z&, maxw) = 1 THEN
                                PixelSwap y&, z&, maxw
                            END IF
                        NEXT
                        IF exitnextfor THEN
                            exitnextfor = 0
                            EXIT FOR
                        END IF
                    NEXT
                NEXT
            NEXT
        END IF
        gap& = INT((gap& / 5) * 4)
    LOOP UNTIL gap& < 1
END SUB
 
SUB SortColumns (Start&, Finish&, maxw)
    EXIT SUB
    FOR column& = 0 TO maxw - 1
        IF GetPixel%(column&, maxw) > GetPixel%(column& + maxw, maxw) THEN
            PixelSwap column&, column& + maxw, maxw
        END IF
    NEXT
END SUB
 
'* uses PrimeNumber&() function to calculate the prime number less than or equal to the gap
SUB PrimeGapSort (start&, finish&, maxw)
    Gap& = (finish& - start& + 1)
    DO
        FOR i& = start& TO finish& - Gap&
            'IF i& > finish& - Gap& THEN
            '    IF CompareScreen%(i&, i& + Gap& - finish&, maxw) = -1 THEN
            '        PixelSwap i&, i& + Gap& - finish&, maxw
            '    END IF
            'ELSE
            IF CompareScreen%(i&, i& + Gap&, maxw) = 1 THEN
                PixelSwap i&, i& + Gap&, maxw
            END IF
            'END IF
            'IF i& < Gap& THEN
            '    IF CompareScreen%(i&, i& - Gap& + finish&, maxw) = 1 THEN
            '        PixelSwap i&, i& - Gap& + finish&, maxw
            '    END IF
            'ELSE
            '    IF CompareScreen%(i&, i& - Gap&, maxw) = -1 THEN
            '        PixelSwap i&, i& - Gap&, maxw
            '    END IF
            'END IF
        NEXT
        Gap& = primeNumber&(Gap& * .727)
        'PrimeNumber&(Gap& \ 2)
    LOOP UNTIL Gap& <= 1
    FOR i& = finish& - 2 TO start& STEP -1
        IF CompareScreen%(i& + 1, i&, maxw) = -1 THEN
            hold% = GetPixel%(i&, maxw)
            j& = i&
            WHILE (GetPixel%(j& + 1, maxw) < hold%)
                PixelSwap j&, j& + 1, maxw
                'a(j&) = a(j& + 1)
                j& = j& + 1
            WEND
            'a(j&) = hold%
            PixelSet j&, maxw, hold%
        END IF
    NEXT i&
END SUB
 
FUNCTION primeNumber& (a&)
    ' Find a prime number below 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.
 
    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
 
FUNCTION SpeedIndex# (T AS SortRec, start&, finish&, doit%, tstart#, tend#, maxw)
    IF doit% THEN
        tstart# = TIMER
        FOR npixel& = start& TO finish&
            p% = GetPixel%(npixel&, maxw)
        NEXT
        tend# = TIMER
        IF tend# < start# THEN
            tend# = tend# + 86400
        END IF
        doit% = 0
    END IF
    SpeedIndex# = ((finish& - start& + 1) / (tend# - tstart#)) / (T.NSorted / T.accumulatedtime)
END FUNCTION
 

DANILIN · « **Reply #3 on:** October 15, 2018, 09:44:50 pm »

Using a simple configuration is convenient in conjunction with standalone exe and in the program it is possible to change the path and i welcome any improvements.

On Internet, more and more sites include visualization and comparison of sortings.

I assume on QB64 it is possible to create a program with a menu that compares 2 or more sorting live.

codeguy · « **Reply #4 on:** October 15, 2018, 09:57:19 pm »

The performance profile is similar to Bitonic Sort, respectable but not insanely efficient. Yes, you can visualize a lot of algorithms, just as I did in the code submitted to this thread.

DANILIN · « **Reply #5 on:** October 15, 2018, 10:09:35 pm »

feature of the algorithm of the topic:
everyone is able to understand this algorithm
unlike certain incomprehensible algorithms machine sorting.

especially considering: my algorithm is pretty quick.

means using for example sorting of goods
or sorting the way people can be sure:
algorithm and quick and understandable to people.

and another feature: speeds up slow sorts
2 ... 4 ... 8 times dividing the bubble sort array
which makes my algorithm even more human.

codeguy · « **Reply #6 on:** October 15, 2018, 10:19:16 pm »

It's comparable speed to MergeSort. Yes, it's a fairly simple but efficient algorithm. I will give it a passing review as it performs well enough to be competitive with O(NLogN) class sorting methods. The fact it's not in-place isn't much of a deterrent for reasonable array sizes. In all, nicely done. I have learned something new. Good luck.

DANILIN · « **Reply #7 on:** October 16, 2018, 04:30:50 am »

info for an expected review:

Russian Sorting Halves
author: Andrey Danilin

Danilin is last name

DANILIN · « **Reply #8 on:** October 18, 2018, 05:21:02 am »

O(N) = 3*N*LOG(N;2)

requires recalculation of entire array
and further distribution of entire array
and further return of sub-array back are required.

and number of distributions takes into account division by halves.
proves visualization and counters.

O(N) = 3*N*LOG(N;2)

Created 13 options are Russian sorting halves:

1. Acceleration of bubble sorting by 2 times
adding a few lines code by dividing array into 2 parts

2. Acceleration of bubble sorting 4 times
adding a few lines code by dividing array into 4 parts

3. Acceleration of selection sorting by 2 times
adding a few lines code by dividing array into 2 parts

4. Acceleration of selection sorting by 4 times
adding a few lines code by dividing array into 4 parts

5. Recursive of QB64 1'000'000 in 2.2 seconds
6. Recursive of PureBasic 1'000'000 in 0.3 seconds
7. Recursive of FreeBasic 1'000'000 in 0.15 seconds
8. Recursive of C# Csharp 1'000'000 in 0.2 seconds
9. QB64 sorting integral of letters

10. Excel fast for 250 items on 5 second
11. Excel animation for 250 items on 150 second

12. Acceleration of bubble sorting
by dividing into 4 parts C# Csharp
13. Nested loops and indexes of indexes

codeguy · « **Reply #9 on:** October 18, 2018, 08:56:52 am »

BubbleSortModified which can sort ranges is designed to be adaptive and increases speed over standard BubbleSort by twice on average for randomly arranged datasets. Also, if the array is mostly sorted by the time BubbleSort is called, you can use InsertionSort to better effect.

DANILIN · « **Reply #10 on:** October 18, 2018, 09:05:16 am »

to use insertionsort people need to know insertionsort
and for those who massively know only bubblesort:

a human-friendly solution that accelerates bubblesort 4 times:
division of array by method of Russian sorting halves.

Russian Sorting Halves and risk management:
in 1st approximation relative to risk of 50%:

to left events with minimal risk for large participation
to right of event with maximum risk for small participation

and still easy to sort inside 2 parts
at least dividing risks into 4 parts.

Russian Sort Halves Accelerate Danilin visualisation

DANILIN · « **Reply #11 on:** October 27, 2018, 07:57:49 am »

news:

Russian Sorting Halves and fast and human

9. Recursive version of C# Csharp 1'000'000 in 0.2 seconds

resume:

Russian Sorting Halves and fast and human
sorts 1'000'000 in 2.2 seconds on QB64
sorts 1'000'000 in 0.3 seconds on PureBasic
sorts 1'000'000 in 0.2 seconds on C# Csharp
sorts 1'000'000 in 0.15 seconds on Freebasic

bplus · « **Reply #12 on:** October 28, 2018, 11:04:14 am »

Quote from: codeguy on October 15, 2018, 10:19:16 pm

It's comparable speed to MergeSort. Yes, it's a fairly simple but efficient algorithm. I will give it a passing review as it performs well enough to be competitive with O(NLogN) class sorting methods. The fact it's not in-place isn't much of a deterrent for reasonable array sizes. In all, nicely done. I have learned something new. Good luck.

Blah! It sucks in comparison to simple, easy to understand, standard QSort:

Code: QB64: [Select]

_TITLE "Compare RussianSorting presented by Danilin to a Basic standard QuickSort by B+ 2018-10-28"
RANDOMIZE TIMER
 
'first here is Danilin's main code: ------------------------------------------------------------------------
'DECLARE SUB RussianSortingHalvesDAV (ab!, yz!, part!, age!)
'CLOSE
'OPEN "c:/N.txt" FOR INPUT AS #1
'INPUT #1, n
''n=1234567
'age = 1 + LOG(n) / LOG(2)
'PRINT n
 
'DIM SHARED d(n) 'AS LONG
'DIM SHARED a(n) 'AS LONG
 
''OPEN "c:/ISX.txt" FOR INPUT AS #2
''FOR i=1 TO n: INPUT #2, d(i): NEXT
 
''FOR i = 1 TO n: d(i) = n - i + 1: NEXT ' INT(RND*n)
'FOR i = 1 TO n: d(i) = INT(RND * n): NEXT '
'FOR k = 1 TO 20: PRINT d(k);: NEXT: PRINT: PRINT
'FOR k = n - 19 TO n: PRINT d(k);: NEXT: PRINT: PRINT
 
'start = TIMER
 
'IF age > 0 THEN
'    CALL RussianSortingHalvesDAV(1, n, 1, age)
'END IF
 
'finish = TIMER
 
'PRINT finish - start; "second ": PRINT
 
'OPEN "c:/=RuSortHalves_dav.txt" FOR OUTPUT AS #3
'PRINT #3, finish - start; "second "
'PRINT #3, n; "elements", "RECURSION"
'FOR i = 1 TO 22: PRINT #3, d(i): NEXT
'FOR i = n - 22 TO n: PRINT #3, d(i): NEXT
 
'FOR k = 1 TO 20: PRINT d(k);: NEXT: PRINT: PRINT
'FOR k = n - 19 TO n: PRINT d(k);: NEXT: PRINT: PRINT
 
'END  - of Danilin's code --------------------------------------------------------------------
 
'Since the timed test involves nothing to do with file input and output, leave that crap out!
'And since Danilin is advertising this crap as the cat's meow, lets do a sort of random type single
'
' Here is the only relevant parts of Danilin
CONST n = 1000000
DIM SHARED d(n) ' single
DIM SHARED a(n) ' single
DIM SHARED QS(n) ' to compare to Danilin's "simple" code
 
' Make a sample set of test data
FOR i = 1 TO n
    r = RND * n
    d(i) = r
    QS(i) = r
NEXT
 
' Since Danilin does not provide us with "c:/N.txt" file data, can't be important to his demo
age = 1 + LOG(n) / LOG(2)
start = TIMER
IF age > 0 THEN
    CALL RussianSortingHalvesDAV(1, n, 1, age)
END IF
finish = TIMER
PRINT finish - start; "second "
IF n > 100 THEN stopper = 100 ELSE stopper = n
FOR i = 1 TO stopper
    PRINT d(i); ", ";
NEXT
DanilinTime = finish - start
PRINT: PRINT: INPUT "Now for the Quick Sort Test, press enter...", enter$
CLS
 
'now try good ole Quick Sort
start = TIMER
qSort 1, n
finish = TIMER
PRINT finish - start; "sec."
IF n > 100 THEN stopper = 100 ELSE stopper = n
FOR i = 1 TO stopper
    PRINT d(i); ", ";
NEXT
QSortTime = finish - start
PRINT: PRINT: PRINT "Ha, ha, ha QSort took "; INT(QSortTime / DanilinTime * 1000) / 1000; " times lomger than Danilin's Sort!"
 
 
SUB RussianSortingHalvesDAV (ab, yz, part, age)
 
    IF yz - ab < 1 THEN EXIT SUB
 
    FOR i = ab TO yz '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> really a time waster and String Array Buster here!!!!!
        summa = summa + d(i)
    NEXT
    middle = summa / (yz - ab + 1)
 
    abc = ab - 1
    xyz = yz + 1
 
    FOR i = ab TO yz
        IF d(i) < middle THEN abc = abc + 1: a(abc) = d(i): ELSE xyz = xyz - 1: a(xyz) = d(i)
    NEXT
 
    FOR i = ab TO yz: d(i) = a(i): NEXT
 
    IF part < age THEN
        IF abc >= ab THEN CALL RussianSortingHalvesDAV(ab, abc, part + 1, age)
        IF xyz <= yz THEN CALL RussianSortingHalvesDAV(xyz, yz, part + 1, age)
    END IF
 
END SUB
 
'QS is DIM SHARED to compare to Danilin's method that needs two DIM SHARED Arrays for his SUB
SUB qSort (start AS LONG, finish AS LONG)
    DIM Hi AS LONG, Lo AS LONG, Middle AS SINGLE
    Hi = finish: Lo = start
    Middle = QS((Lo + Hi) / 2) 'find middle of array
    DO
        DO WHILE QS(Lo) < Middle: Lo = Lo + 1: LOOP
        DO WHILE QS(Hi) > Middle: Hi = Hi - 1: LOOP
        IF Lo <= Hi THEN
            SWAP QS(Lo), QS(Hi)
            Lo = Lo + 1: Hi = Hi - 1
        END IF
    LOOP UNTIL Lo > Hi
    IF Hi > start THEN qSort start, Hi
    IF Lo < finish THEN qSort Lo, finish
END SUB
 

EDIT: Sorry, in QSort sub, I had Middle dimensioned as _FLOAT, it should be single like the rest of the array items. It made a significant difference to timed test, now QSort compares even better!

DANILIN · « **Reply #13 on:** October 28, 2018, 11:42:04 am »

comparisons have long been known:

faster than:
selection insertion binary bubble
gnome comb heap smooth odd-even
cocktail bitonic cyrcle blockmerge

slower than:
merge quick shell radix tim

faster than human natural sorts
slower than machine sorts understandable <1% of people

bplus · « **Reply #14 on:** October 28, 2018, 12:15:11 pm »

Hi Danilin,

What's with all the file crap in your demo? It makes no sense. Sorry to be blunt.

News:

Author Topic: Russian Sorting Halves Danilin (Read 6743 times)

DANILIN

Russian Sorting Halves Danilin

bplus

Re: Russian Sorting Halves Danilin

codeguy

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

codeguy

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

codeguy

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

codeguy

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

bplus

Re: Russian Sorting Halves Danilin

DANILIN

Re: Russian Sorting Halves Danilin

bplus

Re: Russian Sorting Halves Danilin