QB64 Phoenix Edition

Code:
_Title "LoadSort Demo" ' fixed 2024-04-29

ReDim dat$(1 To 1)

Do

    Read insert$

    If insert$ <> "EOD" Then loadSort insert$, dat$() Else Exit Do

Loop

For i = LBound(dat$) To UBound(dat$)

    Print dat$(i); " ";

    If concat$ = "" Then

        lastWord$ = dat$(i)

        cntWord = 1

        concat$ = dat$(i) + "#" + _Trim$(Str$(cntWord))

    Else

        If dat$(i) = lastWord$ Then cntWord = cntWord + 1 Else cntWord = 1: lastWord$ = dat$(i)

        concat$ = concat$ + ", " + dat$(i) + "#" + _Trim$(Str$(cntWord))

    End If

Next

Print: Print: Print concat$

Data dog,cat,rabbit,frog,horse,dog,mouse,pig,cat,bat,cat,dog,bird,fish,cat,pig,dog,EOD

'this requires a separate dynamic array (used redim instead of dim) to load and sort array

Sub loadSort (insertN As String, dynArr() As String) '  version 2024-04-29

    'note this leaves dynArr(0) empty! so ubound of array is also number of items in list

    Dim ub, j, k

    ub = UBound(dynArr)

    If LBound(dynarr) = ub And dynArr(ub) = "" Then ' array not started yet

        dynArr(ub) = insertN

    Else

        ReDim _Preserve dynArr(LBound(dynArr) To ub + 1) As String

        For j = 1 To ub

            If insertN < dynArr(j) Then '  GT to LT according to descending or ascending sort

                For k = ub + 1 To j + 1 Step -1

                    dynArr(k) = dynArr(k - 1)

                Next

                Exit For

            End If

        Next

        dynArr(j) = insertN

    End If

End Sub

here is load sort setup to compare with gnome sort PLUS a couple of other sorts for collectors to compare

Code:
Option _Explicit

_Title "Gnome Sort vrs Load Sort" ' b+ 2024-04-28

Randomize Timer ' so we have a different array each time we compare

DefLng A-Z

Const nItems = 25000

Dim sa$(1 To nItems) ' setup a string array sa$() to sort

Dim copy$(1 To nItems) ' make a copy of sa$() to compare another sort to

Dim As Long i, j ' indexes to array  for building and displaying the arrays

Dim As Long r '  a random posw integer = 2 to 6

Dim t##, qtime##, ctime##

Dim b$ ' building string

For i = 1 To nItems ' make a random list to sort

    b$ = ""

    r = (Rnd * 5) \ 1 + 2

    For j = 0 To r

        b$ = b$ + Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.?", (Rnd * 64) \ 1 + 1, 1)

    Next

    sa$(i) = b$

    copy$(i) = b$

    Print b$,

Next

Print

Print "Press any to Load Sort"

Sleep

Cls

t## = Timer(.001)

ReDim loadMe$(1 To 1) ' match lower bound of sa$

For i = 1 To UBound(sa$)

    loadSort sa$(i), loadMe$()

Next

qtime## = Timer(.001) - t##

For i = 1 To 10

    Print loadMe$(i),

Next

Print: Print

For i = nItems - 9 To nItems

    Print loadMe$(i),

Next

Print: Print

Print "   Load Sort time:"; qtime##

Print

Print "   Press any to Gnome Sort with array copy, zzz..."

Print

Print

Sleep

t## = Timer(.001)

gnomesort copy$()

ctime## = Timer(.001) - t##

For i = 1 To 10

    Print copy$(i),

Next

Print: Print

For i = nItems - 9 To nItems

    Print copy$(i),

Next

Print: Print

Print "   Gnome Sort time:"; ctime##

Print

If ctime## < qtime## Then Print "   Gnome wins!" Else Print "   Load Sort wins!"

Sub QuickSort (start As Long, finish As Long, arr$())

    Dim Hi As Long, Lo As Long, Middle$

    Hi = finish: Lo = start

    Middle$ = arr$((Lo + Hi) / 2) 'find middle of arr$

    Do

        Do While arr$(Lo) < Middle$: Lo = Lo + 1: Loop

        Do While arr$(Hi) > Middle$: Hi = Hi - 1: Loop

        If Lo <= Hi Then

            Swap arr$(Lo), arr$(Hi)

            Lo = Lo + 1: Hi = Hi - 1

        End If

    Loop Until Lo > Hi

    If Hi > start Then Call QuickSort(start, Hi, arr$())

    If Lo < finish Then Call QuickSort(Lo, finish, arr$())

End Sub

' trans from johnno ref: https://rcbasic.freeforums.net/thread/779/sort-algorithms

Sub CombSort (arr$())

    Dim As Long itemCount, start, fini, swaps, gap, i

    start = LBound(arr$)

    itemCount = UBound(arr$) - start + 1

    fini = start + itemCount - 1

    gap = itemCount

    While gap > 1 Or swaps <> 0

        gap = Int(gap / 1.25)

        If gap < 1 Then gap = 1

        swaps = 0

        For i = start To itemCount - gap

            If arr$(i) > arr$(i + gap) Then

                Swap arr$(i), arr$(i + gap)

                swaps = 1

            End If

        Next

    Wend

End Sub

Sub gnomesort (array$())

    'sort a one dimensional array of any size using gnomesort

    'https://en.wikipedia.org/wiki/Gnome_sort

    Dim As Long i, j

    i = LBound(array$) + 1 'find the lowest element in the array and add 1 for the sorting routine

    j = i + 1

    While i <= UBound(array$)

        If array$(i - 1) <= array$(i) Then

            i = j

            j = j + 1

        Else If array$(i - 1) > array$(i) Then

                Swap array$(i - 1), array$(i)

                i = i - 1

                If i = LBound(array$) Then

                    i = j

                    j = j + 1

                End If

            End If

        End If

    Wend

End Sub

'this requires a separate dynamic array (used redim instead of dim) to load and sort array

Sub loadSort (insertN As String, dynArr() As String) '  version 2024-04-29

    'note this leaves dynArr(0) empty! so ubound of array is also number of items in list

    Dim ub, j, k

    ub = UBound(dynArr)

    If LBound(dynarr) = ub And dynArr(ub) = "" Then ' array not started yet

        dynArr(ub) = insertN

    Else

        ReDim _Preserve dynArr(LBound(dynArr) To ub + 1) As String

        For j = 1 To ub

            If insertN < dynArr(j) Then '  GT to LT according to descending or ascending sort

                For k = ub + 1 To j + 1 Step -1

                    dynArr(k) = dynArr(k - 1)

                Next

                Exit For

            End If

        Next

        dynArr(j) = insertN

    End If

End Sub

This really isn't a very efficient sort. ;(

For starters, your find the index on a linear search -- from start to finish. For 1000 items, that's 1000 comparisons to just *find* where to do the insert. At least swap that to a binary search method.

1000 items. Check 500. 250. 125. 62. 31. 15. 7. 3. 1. 0 <-- 10 checks MAX just found where to insert that new data, rather than 1000 max sequential checks.

Then inserting the data is a case of "shift every item right 1 element" from insert point to end of array. Again, not very efficient. Use _MEM, grab the whole block, move it all at once.

I've got a copy of this Binary Insertion Sort which uses mem either floating around here, or on the old forums somewhere. I'll see if I can dig it up for you later sometime, if you're interested in comparing its speed to yours. Wink

i know this isn't very effcient it is meant for little arrays and adding info whenever an item here an item there, instead of sorting an entire array at once, still it beats gnome???

i've got binary search apps too around here some place... non with mem for serious sorts though.

btw i swear i posted this before and same complaint and same response but couldn't find anything through search?

loadsort2 with binary search for insert point

Code:
Option _Explicit

$Console:Only

_Title "LoadSort2 Demo" ' fixed 2024-04-29

Randomize Timer

Dim insert$, i

ReDim dat$(1 To 1)

Do

    Read insert$

    If insert$ <> "EOD" Then

        loadSort2 insert$, dat$()

        'For i = 1 To UBound(dat$)

        '    Print dat$(i); " ";

        'Next

        'Print

    Else

        Exit Do

    End If

Loop

For i = LBound(dat$) To UBound(dat$)

    Print dat$(i); " ";

Next

Print

Print "press any for number load and sort, zzz..."

Sleep

Dim start#, theTime#

start# = Timer(.001)

ReDim dat$(1 To 1)

i = 1

While i <= 20000

    loadSort2 Right$(Space$(6) + Str$(Int(Rnd * 20000)), 6), dat$()

    i = i + 1

Wend

theTime# = Timer(.001) - start#

For i = 1 To 20000

    Print dat$(i);

Next

Print "20000 random numbers created, loaded and sorted Time:"; theTime#

Data dog,cat,rabbit,frog,horse,dog,mouse,pig,cat,bat,cat,dog,bird,fish,cat,pig,dog,EOD

'this requires a separate dynamic array (used redim instead of dim) to load and sort array

Sub loadSort (insertN As String, dynArr() As String) '  version 2024-04-29

    'note this leaves dynArr(0) empty! so ubound of array is also number of items in list

    Dim ub, j, k

    ub = UBound(dynArr)

    If LBound(dynarr) = ub And dynArr(ub) = "" Then ' array not started yet

        dynArr(ub) = insertN

    Else

        ReDim _Preserve dynArr(LBound(dynArr) To ub + 1) As String

        For j = 1 To ub

            If insertN < dynArr(j) Then '  GT to LT according to descending or ascending sort

                For k = ub + 1 To j + 1 Step -1

                    dynArr(k) = dynArr(k - 1)

                Next

                Exit For

            End If

        Next

        dynArr(j) = insertN

    End If

End Sub

Sub loadSort2 (insertN As String, dynArr() As String) '  version 2024-04-29

    'note this leaves dynArr(0) empty! so ubound of array is also number of items in list

    Dim As Long lb, ub, j, lo, hi, test, ins, i

    lb = LBound(dynArr)

    ub = UBound(dynArr)

    If lb = ub And dynArr(ub) = "" Then ' array not started yet

        dynArr(ub) = insertN

    Else

        ub = ub + 1

        ReDim _Preserve dynArr(lb To ub) As String

        If insertN >= dynArr(ub - 1) Then

            dynArr(ub) = insertN

        ElseIf insertN <= dynArr(1) Then

            j = ub

            While j >= lb + 1

                dynArr(j) = dynArr(j - 1)

                j = j - 1

            Wend

            dynArr(lb) = insertN

        Else

            lo = lb: hi = ub

            While lo <= hi

                test = Int((lo + hi) / 2)

                If dynArr(test) = insertN Then

                    j = ub

                    While j >= test + 1

                        dynArr(j) = dynArr(j - 1)

                        j = j - 1

                    Wend

                    dynArr(test) = insertN

                    Exit Sub

                Else

                    If dynArr(test) < insertN Then lo = test + 1 Else hi = test - 1

                End If

            Wend

            For i = test To test + 1

                If insertN < dynArr(i) Then ins = i: Exit For

            Next

            j = ub

            While j >= ins + 1

                dynArr(j) = dynArr(j - 1)

                j = j - 1

            Wend

            dynArr(ins) = insertN

        End If

    End If

End Sub

Quote:Use _MEM, grab the whole block, move it all at once.

maybe with fixed strings but not variable length strings

(04-30-2024, 08:27 PM)bplus Wrote: [ -> ]
Quote:Use _MEM, grab the whole block, move it all at once.

maybe with fixed strings but not variable length strings

Aye. _MEM doesn't work with variable length strings, but it'd work with any numeric type and fixed-length strings. Smile

QB64 Phoenix Edition

bplus

bplus

SMcNeill

bplus

bplus

bplus

SMcNeill