Load Sort

[bplus]

Code: (Select All)

_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

[bplus]

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

Code: (Select All)

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

[SMcNeill]

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.  

[bplus]

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?

[bplus]

loadsort2 with binary search for insert point

Code: (Select All)

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

[bplus]

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

maybe with fixed strings but not variable length strings

[SMcNeill]

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.