GnomeSort

[bplus]

so sorry

Code: (Select All)

Option _Explicit
_Title "Gnome Sort vrs Quick Sort" ' b+ 2024-04-26
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 Quick Sort"
Sleep
Cls
t## = Timer(.001)
QuickSort 1, nItems, sa$()
qtime## = Timer(.001) - t##
For i = 1 To 10
    Print sa$(i),
Next
Print: Print
For i = nItems - 9 To nItems
    Print sa$(i),
Next
Print: Print
Print "   Quick 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 "   Quick Sort wins again!"


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

sanmayce can blow quick sort out of the water but i don't know what the heck he is using?!
https://qb64phoenix.com/forum/showthread...ight=qsort