05-04-2023, 02:29 AM (This post was last modified: 05-04-2023, 06:20 AM by eoredson.)
I know how much time and effort there has been in discussing sorting algorithms,
but I wanted to post this program that tests 6 different sorting subroutines and their timings.
This demo sorts a million items in about 1 sec, your takes so long I gotta think somethings way off.
Code: (Select All)
DefLng A-Z
Const nItems = 1000000
ReDim Shared sa$(1 To nItems) 'setup with string array sa$() shared so dont have to pass as parameter
For x = 1 To nItems ' make a random list to sort
b$ = ""
r = (Rnd * 5) \ 1 + 2
For i = 0 To r
b$ = b$ + Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.?", (Rnd * 64) \ 1 + 1, 1)
Next
sa$(x) = b$
Print b$,
Next
Print
Print "Press any to sort"
Sleep
t## = Timer(.01)
QSort 1, nItems
time## = Timer(.01) - t##
Cls
For i = 1 To nItems
Print sa$(i),
Next
Print
Print "time:"; time##
' modified for QB64 from JB
' This is the best all purpose sort routine around, don't worry how it works, it just does!
' To use this sub rountine store all the string values you want to sort into sa$() array
' call Qsort with Start = 1 and Finish = number of Items in your array
Sub QSort (Start, Finish) 'sa$ needs to be DIM SHARED !!!! array
Dim i As Long, j As Long, x$
i = Start
j = Finish
x$ = sa$(Int((i + j) / 2))
While i <= j
While sa$(i) < x$
i = i + 1
Wend
While sa$(j) > x$
j = j - 1
Wend
If i <= j Then
Swap sa$(i), sa$(j)
i = i + 1
j = j - 1
End If
Wend
If j > Start Then QSort Start, j
If i < Finish Then QSort i, Finish
End Sub
05-04-2023, 04:47 PM (This post was last modified: 05-04-2023, 04:47 PM by bplus.)
Here I try your routine @eoredson with my setup changing your array name to sa$ and your p to p$ it works for 100, 1000, 10,000 but really really bogs down starting at 100,000
Code: (Select All)
DefLng A-Z
Const nItems = 100000
ReDim Shared sa$(1 To nItems) 'setup with string array sa$() shared so dont have to pass as parameter
For x = 1 To nItems ' make a random list to sort
b$ = ""
r = (Rnd * 5) \ 1 + 2
For i = 0 To r
b$ = b$ + Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.?", (Rnd * 64) \ 1 + 1, 1)
Next
sa$(x) = b$
Print b$,
Next
Print
Print "Press any to sort"
Sleep
t## = Timer(.01)
'QSort 1, nItems
QuickSort 1, nItems
time## = Timer(.01) - t##
Cls
For i = 1 To nItems
Print sa$(i),
Next
Print
Print "time:"; time##
' modified for QB64 from JB
' This is the best all purpose sort routine around, don't worry how it works, it just does!
' To use this sub rountine store all the string values you want to sort into sa$() array
' call Qsort with Start = 1 and Finish = number of Items in your array
Sub QSort (Start, Finish) 'sa$ needs to be DIM SHARED !!!! array
Dim i As Long, j As Long, x$
i = Start
j = Finish
x$ = sa$(Int((i + j) / 2))
While i <= j
While sa$(i) < x$
i = i + 1
Wend
While sa$(j) > x$
j = j - 1
Wend
If i <= j Then
Swap sa$(i), sa$(j)
i = i + 1
j = j - 1
End If
Wend
If j > Start Then QSort Start, j
If i < Finish Then QSort i, Finish
End Sub
Sub QuickSort (L, H)
Dim r As Long, p As Long
Dim i As Long, j As Long
If Qexit Then ' recursively exit QuickSort
Exit Sub
End If
If L < H Then
If H - L = 1 Then
If sa$(L) > sa$(H) Then
Swap sa$(L), sa$(H)
End If
Else
r = Int(Rnd * (H - L + 1)) + L
Swap sa$(H), sa$(r)
p$ = sa$(H)
Do
If InKey$ = Chr$(27) Then Qexit = -1: Exit Sub
i = L
j = H
Do While (i < j) And (sa$(i) <= p$)
i = i + 1
Loop
Do While (j > i) And (sa$(j) >= p$)
j = j - 1
Loop
If i < j Then
Swap sa$(i), sa$(j)
End If
Loop While i < j
Swap sa$(i), sa$(H)
If (i - L) < (H - i) Then
Call QuickSort(L, i - 1)
Call QuickSort(i + 1, H)
Else
Call QuickSort(i + 1, H)
Call QuickSort(L, i - 1)
End If
End If
End If
End Sub
Quote:Here I try your routine @eoredson with my setup changing your array name to sa$ and your p to p$ it works for 100, 1000, 10,000 but really really bogs down starting at 100,000
I found the heap sort to be the fastest. It can sort 10,000,000 elements in just under 10 seconds.
