Programming challenges using QB64 in Rosetta Code
#1
Dear all,

QB64 Category page has been created in Rosetta Code, and also added a page for "Anagrams". http://rosettacode.org/wiki/Category:QB64
Please feel free to add more pages of code!

List of programming tasks:
http://rosettacode.org/wiki/Category:Sol...mming_Task

bplus et al, take it away! Smile
I like to program in BASIC
With code that is simple and slick
I learnt it in school
And it is still cool
So it is my number one pick
Reply
#2
Kudos for getting the ball rolling on this Adrian.

I do have some mixed feelings though. Had I known you were going to use my code for Anagrams I would have given you my latest greatest version (now posted in Anagrams http://www.thejoyfulprogrammer.com/qb64/...2537314363) not using Steve's super fast Memory techniques. I was of the opinion that Steve's code for Anagrams was the clear winner of the challenge. I wonder if he would have wanted to make some changes had he known his code would be submitted or did you check with him first? I think he just started playing along because he got interested in the problem and was curious what he could do with it, ha! the way it should be. Smile

My hope for the future is community involvement specially those learning QB64 and community consensus as to which code best represents what QB64 has to offer.
B += x
Reply
#3
hi bplus,

sorry if i had "jumped the gun"! i have posted your latest greatest version on Rosetta Code, replacing the previous version.
Output from Steve's program added. Smile

Cheers,
A.
I like to program in BASIC
With code that is simple and slick
I learnt it in school
And it is still cool
So it is my number one pick
Reply
#4
Thanks Adrian, That code gives Steve well deserved credit! Smile

I am impressed on how fast you moved! I would have fiddled around and probably never gotten around to doing anything.
B += x
Reply
#5
My pleasure, bplus.

look forward to seeing more tasks being done in QB64!
I like to program in BASIC
With code that is simple and slick
I learnt it in school
And it is still cool
So it is my number one pick
Reply
#6
Quote:I think he just started playing along because he got interested in the problem and was curious what he could do with it, ha! the way it should be. 

Aye.  I was mainly just curious to see for myself how quickly I could find the anagrams without resorting on any SORT routine.  Getting it down to about a second without sorting wasn't a bad run at all, I didn't think!  But, once I'd gotten it as quick as I could without sorting, I wanted to compare and see how quickly I could get it to go WITH sorting...

The end result isn't the cleanest code which I could come up with, but it *is* the fastest.  From my last test, most of the speed delay is actually in disk access speeds, moreso than in the sorting/match work needed for the program.  7000+ executions per second is nice, but that's on my 5200 RPM drive.  If I run the program (unoptimized without -Ofast, and in QB64-32bit) in a ramdrive, it jumps up to almost 10k loops per second.  Running it on a flash drive would probably be around 8500-9000 times per second.

It may not be the prettiest, but it is the fastest version I could come up with.  Honestly, I don't think there's a single thing I know to do to make it any speedier than it is.  I really wasn't trying to compete with anyone on the challenge (Heck, I didn't even know it was a challenge!); I was just trying to help a bit from where Bplus posted, "I am sure this code can be sped up:".
Reply
#7
Quote:look forward to seeing more tasks being done in QB64!

Here's the 2048 game for you:  http://www.qb64.net/forum/index.php?topi...#msg105154

Honestly, I'd have to go look at the list of challenges again to know which links to share for you, but I think many of them have already been solved by the community over at QB64.net.  Just do a search and you'll find almost all those topics covered at one time or another by the community there.  Wink
Reply
#8
Thanks Steve! Added!
http://rosettacode.org/wiki/2048#QB64

I have also added a link to TJP from QB64’s page.
I like to program in BASIC
With code that is simple and slick
I learnt it in school
And it is still cool
So it is my number one pick
Reply
#9
Code:
'* BucketSort Algorithm with single recursive step by CodeGuy, using QB64
'* approximately 3/4 GHzS to perform both verified sorts.
CONST TestN& = 131071
REDIM TestArray(0 TO TestN&) AS DOUBLE

TYPE MinMaxRec
    min AS LONG
    max AS LONG
END TYPE

acc! = 0
FOR sortdir& = -1 TO 1 STEP 2
    FOR SetTestArray& = LBOUND(TestArray) TO UBOUND(TestArray)
        TestArray(SetTestArray&) = (RND * 1023) AND 1023
    NEXT
    u! = TIMER(.001)
    BucketSort TestArray(), LBOUND(TestArray), UBOUND(TestArray), sortdir&, 1
    v! = TIMER(.001)
    acc! = acc! - u! + v!
    IF ArraySequenceCheck&(TestArray(), LBOUND(TestArray), UBOUND(TestArray), sortdir&) THEN
        PRINT "sort:"; v! - u!; acc!
    END IF
NEXT


SUB BucketSort (Array() AS DOUBLE, start AS LONG, finish AS LONG, order&, recurse%)
    DIM BS_Local_NBuckets AS INTEGER
    DIM BS_Local_ArrayRange AS DOUBLE
    DIM BS_Local_N AS LONG
    DIM BS_Local_S AS LONG
    DIM BS_Local_Z AS LONG
    DIM BS_Local_Remainder AS INTEGER
    DIM BS_Local_Index AS INTEGER
    DIM BS_Local_Last_Insert_Index AS LONG
    DIM BS_Local_Current_Insert_Index AS LONG
    DIM BS_Local_BucketIndex AS INTEGER
    REDIM BSMMrec AS MinMaxRec
    GetMinMaxArray Array(), start, finish, BSMMrec
    BS_Local_ArrayRange = Array(BSMMrec.max) - Array(BSMMrec.min)
    IF BS_Local_ArrayRange > 0 THEN
        BS_Local_NBuckets = 2 * INT(LOG(finish - start + 1) / LOG(2)) + 1
        BS_Local_N = (finish - start)
        BS_Local_Remainder = BS_Local_N MOD BS_Local_NBuckets
        BS_Local_NBuckets = BS_Local_NBuckets - 1
        REDIM BS_Buckets_Array(BS_Local_NBuckets, 0 TO (BS_Local_NBuckets * (1 + (BS_Local_N - BS_Local_Remainder) / BS_Local_NBuckets))) AS DOUBLE
        REDIM BS_Count_Array(0 TO BS_Local_NBuckets) AS LONG
        FOR BS_Local_S = start TO finish
            BS_Local_BucketIndex = BS_Local_NBuckets * ((Array(BS_Local_S) - Array(BSMMrec.min)) / BS_Local_ArrayRange)
            BS_Buckets_Array(BS_Local_BucketIndex, BS_Count_Array(BS_Local_BucketIndex)) = Array(BS_Local_S)
            BS_Count_Array(BS_Local_BucketIndex) = BS_Count_Array(BS_Local_BucketIndex) + 1
        NEXT
        BS_Local_Last_Insert_Index = start
        BS_Local_Current_Insert_Index = start
        IF order& = 1 THEN
            FOR BS_Local_S = 0 TO BS_Local_NBuckets
                IF BS_Count_Array(BS_Local_S) > 0 THEN
                    BS_Local_Last_Insert_Index = BS_Local_Current_Insert_Index
                    FOR BS_Local_Z = 0 TO BS_Count_Array(BS_Local_S) - 1
                        Array(BS_Local_Current_Insert_Index) = BS_Buckets_Array(BS_Local_S, BS_Local_Z)
                        BS_Local_Current_Insert_Index = BS_Local_Current_Insert_Index + 1
                    NEXT
                    IF recurse% THEN
                        BucketSort Array(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&, 0
                    ELSE
                        InsertionSort Array(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&
                    END IF
                END IF
            NEXT
            ERASE BS_Buckets_Array, BS_Count_Array
            EXIT SUB
        ELSE
            FOR BS_Local_S = BS_Local_NBuckets TO 0 STEP -1
                IF BS_Count_Array(BS_Local_S) > 0 THEN
                    BS_Local_Last_Insert_Index = BS_Local_Current_Insert_Index
                    FOR BS_Local_Z = 0 TO BS_Count_Array(BS_Local_S) - 1
                        Array(BS_Local_Current_Insert_Index) = BS_Buckets_Array(BS_Local_S, BS_Local_Z)
                        BS_Local_Current_Insert_Index = BS_Local_Current_Insert_Index + 1
                    NEXT
                    IF recurse% THEN
                        BucketSort Array(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&, 0
                    ELSE
                        InsertionSort Array(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&
                    END IF
                END IF
            NEXT
        END IF
        ERASE BS_Buckets_Array, BS_Count_Array
    END IF
END SUB

FUNCTION ArraySequenceCheck& (array() AS DOUBLE, start&, finish&, order&)
    oseq& = order&
    h& = start&
    i& = start&
    DO
        IF array(i&) < array(h&) THEN
            IF oseq& = 1 THEN
                '* this is a sequence error
                oseq& = 0
                EXIT DO
            ELSE
                oseq& = -1
                h& = i&
            END IF
        ELSEIF array(i&) > array(h&) THEN
            IF oseq& = -1 THEN
                '* this is also a sequence error
                oseq& = 0
                EXIT DO
            ELSE
                oseq& = 1
                h& = i&
            END IF
        END IF
        i& = i& + 1
    LOOP UNTIL i& > finish&
    ArraySequenceCheck& = (oseq& = order&)
END SUB

Freely submit or steal this code.
Reply
#10
On a side note, it's the single recursive step that makes ALL the difference in the world. From a shade over 10s for a SINGLE sort to around 350ms for BOTH. Cool, huh? That first sub is refactored to avoid variable name collisions when used as part of included code. I haven't yet dealt with the sequence check code.
Reply
#11
Implements CountingSort(), even on non-integer numeric data.
Code:
_TITLE "CGScaleArrayToInteger"
TYPE MinMaxRec
    min AS LONG
    max AS LONG
END TYPE
DIM T_minmax AS MinMaxRec


DIM SHARED DisplayRows AS INTEGER
DisplayRows = 40
WIDTH 140, DisplayRows

testn& = 16777215
REDIM T(0 TO testn&) AS DOUBLE
FOR s& = 0 TO UBOUND(T)
    T(s&) = RND '((RND * 255) AND 255) / 256
NEXT
t! = TIMER(.001)
CGScaleArrayToInteger T(), LBOUND(t), UBOUND(t), order&, T_minmax, TScale#
CGFrequencyCounts T(), LBOUND(t), UBOUND(t), order&, T_minmax, TScale#
u! = TIMER(.001)
PRINT u! - t!;
'* very handy for scaling arrays to integer values so they can be ranked, accumulated in histograms
'* or anything else where ranks within an array are important. Beats sorting by a LOT, although it
'* is not 100% precise. Through a bit of clever engineering, this CAN be made that way.

SUB CGScaleArrayToInteger (CGSortLibArr() AS DOUBLE, start&, finish&, order&, CGSortLibArr_mmrec AS MinMaxRec, CGSortLibArr_ScaleMultiplier AS DOUBLE)
    DIM CGScaleArray_Range AS DOUBLE
    DIM CGScaleArray_ScaleTemp AS DOUBLE
    DIM CGScaleArray_PowerOf2 AS LONG

    DIM CGScaleArray_rank AS LONG
    DIM CGScaleArray_Index AS LONG

    GetMinMaxArray CGSortLibArr(), start&, finish&, CGSortLibArr_mmrec
    CGScaleArray_Range = CGSortLibArr(CGSortLibArr_mmrec.max) - CGSortLibArr(CGSortLibArr_mmrec.min)
    IF CGScaleArray_Range <> 0 THEN
        CGScaleArray_ScaleTemp = CGScaleArray_Range
    ELSE
        CGScaleArray_ScaleTemp = CGSortLibArr(CGSortLibArr_mmrec.min)
        CGScaleArray_Range = 1
    END IF
    CGScaleArray_PowerOf2 = 0
    DO UNTIL CGScaleArray_ScaleTemp = INT(CGScaleArray_ScaleTemp)
        CGScaleArray_ScaleTemp = CGScaleArray_ScaleTemp * 2
        CGScaleArray_PowerOf2 = CGScaleArray_PowerOf2 + 1
    LOOP
    CGSortLibArr_ScaleMultiplier = 2 ^ CGScaleArray_PowerOf2
END SUB

SUB CGFrequencyCounts (CGSortLibArr() AS DOUBLE, Start&, Finish&, order&, CGSortLibArr_mmrec AS MinMaxRec, CGSortLibArr_ScaleMultiplier AS DOUBLE)
    '* a short example of using this multiplier to convert the range respresented by
    '* CGSortLibArr(start&) -> CGSortLibArr(finish&)
    '* to a scaled integer: the lowest valued element will appear as 0.
    REDIM CGFrequencyCounts_Array(0 TO Finish& - Start&) AS LONG
    DIM CGFrequencyCounts_IteratorU AS LONG
    DIM CGFrequencyCounts_Index AS LONG
    DIM CGFrequencyCounts_rank AS LONG
    DIM CGFrequencyCounts_x AS DOUBLE
    DIM CGFrequencyCounts_dx AS DOUBLE

    CGFrequencyCounts_dx = CGSortLibArr(CGSortLibArr_mmrec.max) - CGSortLibArr(CGSortLibArr_mmrec.min)
    FOR CGFrequencyCounts_IteratorU = Start& TO Finish&
        CGFrequencyCounts_x = CGSortLibArr(CGFrequencyCounts_IteratorU) - CGSortLibArr(CGSortLibArr_mmrec.min)
        CGFrequencyCounts_Index = INT(CGFrequencyCounts_x * (Finish& - Start&) / CGFrequencyCounts_dx)
        IF order& = 1 THEN
            CGFrequencyCounts_rank = Start& + CGFrequencyCounts_Index
        ELSE
            CGFrequencyCounts_rank = Finish& - CGFrequencyCounts_Index
        END IF
        CGFrequencyCounts_Array(CGFrequencyCounts_rank) = CGFrequencyCounts_Array(CGFrequencyCounts_rank) + 1
        'IF CGFrequencyCounts_IteratorU MOD 37 = 0 THEN
        '    LOCATE (CGFrequencyCounts_IteratorU MOD DisplayRows) + 1, 1
        '    PRINT USING "i=#,###,###,###,###"; CGFrequencyCounts_Index;
        '    PRINT USING "r=#,###,###,###,###"; CGFrequencyCounts_rank;
        '    PRINT USING "s=#################"; CGFrequencyCounts_x * CGSortLibArr_ScaleMultiplier;
        '    PRINT USING "t(###,###,###,###)="; CGFrequencyCounts_IteratorU;
        '    PRINT USING "###################"; CGSortLibArr(CGFrequencyCounts_IteratorU) * CGSortLibArr_ScaleMultiplier;
        '    PRINT USING "c=#,###,####,###,###"; CGFrequencyCounts_Array(CGFrequencyCounts_rank);
        'END IF
    NEXT
    FOR stx& = LBOUND(CGFrequencyCounts_Array) TO UBOUND(CGFrequencyCounts_Array)
        IF CGFrequencyCounts_Array(stx&) > 0 THEN
            b# = CGSortLibArr(CGSortLibArr_mmrec.min) + (CGSortLibArr(CGSortLibArr_mmrec.max) - CGSortLibArr(CGSortLibArr_mmrec.min)) * (stx& / UBOUND(CGFrequencyCounts_Array))
            'PRINT "{"; b#; ","; CGFrequencyCounts_Array(stx&); "}";
        END IF
    NEXT
    ERASE CGFrequencyCounts_Array
END SUB

SUB GetMinMaxArray (CGSortLibArr() AS DOUBLE, Start&, Finish&, GetMinMaxArray_minmax AS MinMaxRec)
    DIM GetGetMinMaxArray_minmaxArray_i AS LONG
    DIM GetMinMaxArray_n AS LONG
    DIM GetMinMaxArray_TT AS LONG
    DIM GetMinMaxArray_NMod2 AS INTEGER
    '* this is a workaround for the irritating malfunction
    '* of MOD using larger numbers and small divisors
    GetMinMaxArray_n = Finish& - Start&
    GetMinMaxArray_TT = GetMinMaxArray_n MOD 10000
    GetMinMaxArray_NMod2 = GetMinMaxArray_n - 10000 * ((GetMinMaxArray_n - GetMinMaxArray_TT) / 10000)
    IF (GetMinMaxArray_NMod2 MOD 2) THEN
        GetMinMaxArray_minmax.min = Start&
        GetMinMaxArray_minmax.max = Start&
        GetGetMinMaxArray_minmaxArray_i = Start& + 1
    ELSE
        IF CGSortLibArr(Start&) > CGSortLibArr(Finish&) THEN
            GetMinMaxArray_minmax.max = Start&
            GetMinMaxArray_minmax.min = Finish&
        ELSE
            GetMinMaxArray_minmax.min = Finish&
            GetMinMaxArray_minmax.max = Start&
        END IF
        GetGetMinMaxArray_minmaxArray_i = Start& + 2
    END IF

    WHILE GetGetMinMaxArray_minmaxArray_i < Finish&
        IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i) > CGSortLibArr(GetGetMinMaxArray_minmaxArray_i + 1) THEN
            IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i) > CGSortLibArr(GetMinMaxArray_minmax.max) THEN
                GetMinMaxArray_minmax.max = GetGetMinMaxArray_minmaxArray_i
            END IF
            IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i + 1) < CGSortLibArr(GetMinMaxArray_minmax.min) THEN
                GetMinMaxArray_minmax.min = GetGetMinMaxArray_minmaxArray_i + 1
            END IF
        ELSE
            IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i + 1) > CGSortLibArr(GetMinMaxArray_minmax.max) THEN
                GetMinMaxArray_minmax.max = GetGetMinMaxArray_minmaxArray_i + 1
            END IF
            IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i) < CGSortLibArr(GetMinMaxArray_minmax.min) THEN
                GetMinMaxArray_minmax.min = GetGetMinMaxArray_minmaxArray_i
            END IF
        END IF
        GetGetMinMaxArray_minmaxArray_i = GetGetMinMaxArray_minmaxArray_i + 2
    WEND
END SUB
Reply
#12
Not yet submitted as BucketSort() code has been. As long as you leave the credits, (Coded 25 Mar 2018 By CodeGuy) you can use or post elsewhere.

Code:
_TITLE "BFPRT Median of array by CodeGuy"
'* Demo of 48828125 double-precision elements takes a shade over 10s on 2.16GHz machine
'* Blum, M.; Floyd, R. W.; Pratt, V. R.; Rivest, R. L.; Tarjan, R. E. (August 1973). "Time bounds for selection" (PDF).
'* Journal of Computer and System Sciences. 7 (4): 448–461. doi:10.1016/S0022-0000(73)80033-9.
'* Coded 25 Mar 2018 By CodeGuy
REDIM anarray(0 TO 48828124) AS DOUBLE
FOR c& = 0 TO UBOUND(anarray)
    anarray(c&) = RND
NEXT
t! = TIMER(.001)
BFPRT anarray(), LBOUND(anarray), UBOUND(anarray), anarrayMedian#
u! = TIMER(.001)
PRINT anarrayMedian#; u! - t!

SUB BFPRT (CGSortLibArr() AS DOUBLE, start AS LONG, finish AS LONG, BFPRTMedian AS DOUBLE)
    bfprtn& = 5
    IF finish - start < bfprtn& - 1 THEN
        SELECT CASE (finish - start) MOD bfprtn&
            CASE 0, 2, 4
                BFPRTMedian = CGSortLibArr(start + (finish - start) \ 2)
            CASE 1
                BFPRTMedian = (CGSortLibArr(start) + CGSortLibArr(finish)) / 2
            CASE 3
                BFPRTMedian = (CGSortLibArr(start + 1) + CGSortLibArr(finish - 1)) / 2
        END SELECT
    ELSE
        REDIM BfprtArray(0 TO (finish - start) / bfprtn& + bfprtn&) AS DOUBLE
        s& = LBOUND(CGSortLibArr)
        BfprtCount& = 0
        DO
            IF s& - 1 > finish - bfprtn& THEN
                InsertionSort CGSortLibArr(), s&, finish, 1
                DO UNTIL s& > finish
                    BfprtArray(BfprtCount&) = CGSortLibArr(s&)
                    s& = s& + 1
                LOOP
                EXIT DO
            ELSE
                InsertionSort CGSortLibArr(), s&, s& + bfprtn& - 1, 1
                BfprtArray(BfprtCount&) = CGSortLibArr(s& + (bfprtn& - 1) \ 2)
                '* PRINT BfprtArray(BfprtCount&); BfprtCount&
                BfprtCount& = BfprtCount& + 1
                s& = s& + bfprtn&
            END IF
        LOOP
        BFPRT BfprtArray(), 0, BfprtCount& - 1, BFPRTMedian
    END IF
END SUB

SUB InsertionSort (CGSortLibArr() AS DOUBLE, start AS LONG, finish AS LONG, order&)
    DIM InSort_Local_ArrayTemp AS DOUBLE
    DIM InSort_Local_i AS LONG
    DIM InSort_Local_j AS LONG
    SELECT CASE order&
        CASE 1
            FOR InSort_Local_i = start + 1 TO finish
                InSort_Local_ArrayTemp = CGSortLibArr(InSort_Local_i)
                InSort_Local_j = InSort_Local_i - 1
                DO UNTIL InSort_Local_j < start
                    IF (InSort_Local_ArrayTemp < CGSortLibArr(InSort_Local_j)) THEN
                        CGSortLibArr(InSort_Local_j + 1) = CGSortLibArr(InSort_Local_j)
                        InSort_Local_j = InSort_Local_j - 1
                    ELSE
                        EXIT DO
                    END IF
                LOOP
                CGSortLibArr(InSort_Local_j + 1) = InSort_Local_ArrayTemp
            NEXT
        CASE ELSE
            FOR InSort_Local_i = start + 1 TO finish
                InSort_Local_ArrayTemp = CGSortLibArr(InSort_Local_i)
                InSort_Local_j = InSort_Local_i - 1
                DO UNTIL InSort_Local_j < start
                    IF (InSort_Local_ArrayTemp > CGSortLibArr(InSort_Local_j)) THEN
                        CGSortLibArr(InSort_Local_j + 1) = CGSortLibArr(InSort_Local_j)
                        InSort_Local_j = InSort_Local_j - 1
                    ELSE
                        EXIT DO
                    END IF
                LOOP
                CGSortLibArr(InSort_Local_j + 1) = InSort_Local_ArrayTemp
            NEXT
    END SELECT
END SUB
Reply
#13
BFPRT is not deterministic except when array sizes are exact powers of 5. Using QuickSelect or another is Ok too,

http://www.qb64.net/forum/index.php?topi...#msg128402 the library containing this code, among others.
Reply
#14
In your BFPRT could you modify the call to InsertionSort to be replaced with a ShellSort??

Erik.
dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#15
Using InsertionSort produces better timings than any other sorting method for BFPRTN& = 5. Yes, you can use other ODD numbers for BFPRTN&, but then it won't be BFPRT. There has already been discussion on StackOverflow and other sites as to WHY 5 is the optimal number. And I'm sure the original authors of this algorithm tested other methods too. BTW, I had to modify a modification to use BubbleSortModified(), which produced a shabby timing of around 16, but for other applications, it's actually quite fast, especially compared to BubbleSort().
Reply
#16
ICYW:
                'InsertionSort CGSortLibArr(), s&, finish, 1 --9.4s
                'ShellSort CGSortLibArr(), s&, finish, 1 -- 14.4s
                'BubbleSort CGSortLibArr(), s&, finish, 1 '13.7s
                BubbleSortModified CGSortLibArr(), s&, finish, 1 '16.7s

with either/any version of QuickSort, the time is around 30s. DEFINITELY not good.
Reply
#17
If you want faster timings on non-sorted, non-monotonic arrays AND deterministic, I already have a function coded to do this automatically. BFPRT is deterministic ONLY for (finish-start) = 5^k-1. Otherwise, it's a good guess that doesn't require potentially VERY slow sorting speeds. deterministic = answer is the ACTUAL answer, not a guess.
Reply
#18
Use QuickSort on an already-sorted or monotonic array and it becomes VERY slow.
Reply
#19
Did you know BST (Binary Search Trees) can be implemented in QB64? EASILY? That you DON'T need to know c/c++ to manipulate and use this wonderfully adept data structure? With CodeGuySortLib ®©™(etc), it is good as done, including correct traversal and even sortation for ascending/descending without the need to invert arrays? Anyone who claims you NEED c/c++ to implement this data structure quickly is a 100% liar. I'm NOT reposting code that isn't already available at qb64(org,net). The listing is FAR too long for the line limits of TJP, even stripped of comments.
Reply
#20
Walking the branches and inserting stuff into an array in the desired order. Pretty much standard stuff.
Code:
'* anyone claiming you need c/c++ to implement trees is telling you CRAP
'* This is a bit more complex than the standard non-copying version, but it is still
'* respectably fast. General complexity for TreeSort() is O(NLogN), EXCEPT when
'* presented with elements already sorted. One way to avoid this is to KnuthShuffle
'* the input first. Skipped in this implementation, but there is no reason you
'* can't do it prior to TreeSort(). Code modified/added from my repository. This
'* version allows multiple same-value nodes
'* Modified/added 26 March 2018.

SUB TreeSortUsingBST (CGSortLibArr() AS DOUBLE, start&, finish&, order&)
    DIM TSAmmrec AS MinMaxRec
    GetMinMaxArray CGSortLibArr(), start&, finish&, TSAmmrec
    delta# = CGSortLibArr(TSAmmrec.max) - CGSortLibArr(TSAmmrec.min)
    IF delta# = 0 THEN 'already sorted because they're all equal
        EXIT SUB
    END IF
    '*************************************
    '* CGSortLibArr() COULD be KnuthShuffle CGSortLibArr(), start&, finish&
    '* here. TreeSortUsingBST() performance on monotonic arrays seems to be fine anyway.
    '*************************************

    '* simple TreeNode struct, EXACTLY same as c/c++
    TYPE TreeNode
        value AS DOUBLE
        left AS LONG
        right AS LONG
    END TYPE
    DIM NextFreeNode AS LONG
    DIM CurrentNodePtr AS LONG
    DIM TreeScanX AS LONG
    DIM NilValuePtr AS LONG
    NilValuePtr = LBOUND(CGSortLibArr) - 1
    DIM TSUBST_tree(start& + 1 TO finish& + 1) AS TreeNode
    FOR TreeScanX = start& + 1 TO finish& + 1
        TSUBST_tree(TreeScanX).value = 0
        TSUBST_tree(TreeScanX).left = NilValuePtr
        TSUBST_tree(TreeScanX).right = NilValuePtr
    NEXT
    TSUBST_tree(LBOUND(TSUBST_tree)).value = CGSortLibArr(start&)
    NextFreeNode = LBOUND(TSUBST_tree) + 1
    IF order& = 1 THEN
        FOR TreeScanX = LBOUND(TSUBST_tree) + 1 TO UBOUND(TSUBST_tree)
            '* this is the primary root node - without starting HERE, nothing happens correctly
            CurrentNodePtr = LBOUND(TSUBST_tree)
            DO
                IF CGSortLibArr(TreeScanX - 1) < TSUBST_tree(CurrentNodePtr).value THEN
                    IF TSUBST_tree(CurrentNodePtr).left = NilValuePtr THEN
                        TSUBST_tree(CurrentNodePtr).left = NextFreeNode
                        TSUBST_tree(NextFreeNode).value = CGSortLibArr(TreeScanX - 1)
                        NextFreeNode = NextFreeNode + 1
                        EXIT DO
                    ELSE
                        CurrentNodePtr = TSUBST_tree(CurrentNodePtr).left
                    END IF
                ELSE
                    IF TSUBST_tree(CurrentNodePtr).right = NilValuePtr THEN
                        TSUBST_tree(CurrentNodePtr).right = NextFreeNode
                        TSUBST_tree(NextFreeNode).value = CGSortLibArr(TreeScanX - 1)
                        NextFreeNode = NextFreeNode + 1
                        EXIT DO
                    ELSE
                        CurrentNodePtr = TSUBST_tree(CurrentNodePtr).right
                    END IF
                END IF
            LOOP
        NEXT TreeScanX
    ELSE
        FOR TreeScanX = LBOUND(tree) + 1 TO UBOUND(tree)
            '* this is the primary root node - without starting HERE, nothing happens correctly
            CurrentNodePtr = LBOUND(tree)
            DO
                '* you notice this cool comparison sign change? THIS is important
                '*************************** <\|/> *****************************
                IF CGSortLibArr(TreeScanX - 1) > TSUBST_tree(CurrentNodePtr).value THEN
                    IF TSUBST_tree(CurrentNodePtr).left = NilValuePtr THEN
                        TSUBST_tree(CurrentNodePtr).left = NextFreeNode
                        TSUBST_tree(NextFreeNode).value = CGSortLibArr(TreeScanX - 1)
                        NextFreeNode = NextFreeNode + 1
                        EXIT DO
                    ELSE
                        CurrentNodePtr = TSUBST_tree(CurrentNodePtr).left
                    END IF
                ELSE
                    IF TSUBST_tree(CurrentNodePtr).right = NilValuePtr THEN
                        TSUBST_tree(CurrentNodePtr).right = NextFreeNode
                        TSUBST_tree(NextFreeNode).value = CGSortLibArr(TreeScanX - 1)
                        NextFreeNode = NextFreeNode + 1
                        EXIT DO
                    ELSE
                        CurrentNodePtr = TSUBST_tree(CurrentNodePtr).right
                    END IF
                END IF
            LOOP
        NEXT TreeScanX
    END IF
    depth& = start& + 1
    TraverseBST CGSortLibArr(), start& + 1, depth&, TSUBST_tree(), NilValuePtr
    ERASE TSUBST_tree
END SUB

SUB TraverseBST (CGSortLibArr() AS DOUBLE, NextPtr&, depth&, TBST_tree() AS TreeNode, NilValuePtr AS LONG)
    IF TBST_tree(NextPtr&).left <> NilValuePtr THEN
        TraverseBST CGSortLibArr(), TBST_tree(NextPtr&).left, depth&, TBST_tree(), NilValuePtr
    END IF
    CGSortLibArr(depth& - 1) = TBST_tree(NextPtr&).value
    depth& = depth& + 1
    IF TBST_tree(NextPtr&).right <> NilValuePtr THEN TraverseBST CGSortLibArr(), TBST_tree(NextPtr&).right, depth&, TBST_tree(), NilValuePtr
END SUB

you're welcome.
Reply