+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: Official Links (https://qb64phoenix.com/forum/forumdisplay.php?fid=16)
+--- Forum: Learning Resources and Archives (https://qb64phoenix.com/forum/forumdisplay.php?fid=13)
+--- Thread: CodeGuy's Sorting Collection (/showthread.php?tid=2639)
CodeGuy's Sorting Collection - SMcNeill - 04-29-2024
As folks are starting to discuss and compare various sort routines on the forums once again, I wanted to take a moment and make everyone aware of all the work that has already gone into this topic in the past via the old members of this forum, and the previous versions of this forum -- no matter where they existed.
BEHOLD -- CodeGuy's Sorting Collection:
Code: (Select All)
_Title "CGSortAlgorithmsLibraryAndTest12i"
'* Quora: Is there an algorithm to fimd duplicate elements in an array in O(N) time? Of COURSE there is. There are actually MANY that are
'* not only efficient, but relatively simple. The simplest is a HashTable. However, this requires knowledge beforehand of the number of
'* elements constant reconstruction of the HashTable on exceeding the efficient Load Factor, aka "emptiness," which is roughly 20%. Past
'* this, searching and probing become worse than the typical O(1.25) cited in many research papers and backed by personal experience.
'* The second involves application of a VERY fast sorting method and either traversal or partial sort and binary search of the remainder.
'* There is no algorithm that does this in less than O(N) time, although there are asymptotically close heuristics.
'* my answer assumes no prior knowledge of data type beyond numeric.
'* first, we will start with the typical element by element search. VERY slow and complexity is O(N^2).
'* yes, this is abysmally slow, so testing only with a small number of elements.
'* this example includes my ENTIRE library of sorting algorithms, some slightly modified from standard.
'* all tested and verified are indicated by a date stamp
'* tested/verified
'*******************************************************************************************************************************************************************
'Date tested O() Algorithm name time(ms) in-place deployment special notes
'2018-Mar-13 N FlashSort (CGSortLibArr() AS DOUBLE, start AS LONG, finish AS LONG, order&) 117 N requires inversion for descending order
'2018 Mar 13 NLogN QuickSortRecursive (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 148 Y Requires CPU stack, uses middle array element for
' partitioning step.
'2018 Mar 13 NLogN QSortRecursiveSimplified (CGSortLibArr() AS DOUBLE, start&, finish&) 160 Y Requires CPU stack
'2018nMar 13 NLogN QuickSortIterativeMedianOf3 (CGSortLibArr() AS DOUBLE, Start&, Finish&, order&) 161 Y Uses software-based stack, Median of Three
' Partitioning strategy used to defeat "QuickSort
' Killer" array arrangements for QuickSort algorithms
' using the middle element as the sole pivot chice.
' Remember, DDoS attacks using this flaw in Java?
'2018 Mar 13 NLogN QuickSortIterative (CGSortLibArr() AS DOUBLE, Start&, Finish&, order&) 164 Y Uses software-based stack, handy for old CPUs that do
' not support recursive stacks in hardware. Or just to
' implement for certainty where hardware or virtualization
' is not guaranteed to support hardware stacks.
'
'2018 Mar 13 N HashListSort (CGSortLibArr() AS DOUBLE, start AS LONG, Finish AS LONG, order&) 171 N Can be implemented without CGSortLibArr() with mods
' With the data type and range in this original demo
' HashListSort actually BEATS FlashSort by at least
' an 11% margin. Don't let this fool you. This is the
' result of a SINGLE run, and generalizing on a single
' run is not a good idea, which is why I assembled a
' test harness using multiple passes and ascending,
' descending order.
'2018 Mar 13 NLogN IntroSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 226 N uses MergeSort, HeapSort, InsertionSort and performs
' comparably and favorably to non-hybrid QuickSort,
' usually within a few percent or less.
'2018 Mar 13 NLogN QuickSortDualPivot (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 244 Y Not bulletproof but works for most cases of highly
' repetitive data fails for low-repetition data.
'2018 Mar 13 NLongN SnakeSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 250 N Auxiliary memory is O(N). Also a very nice-performing
' algorithm. Not the fastest (yes, compared to HashListSort
' with 70ms @ (0, 131071) elements, not even FlashSort can
' keep up.
'2018 Mar 13 NLogN MergeSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 257 N Auxiliary memory is O(N/2) when used with
' EfficientMerge
'2018 Mar 13 NLogN MergeSortTwoWay (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 287 N Good for memory-constrained systems
'2018 Mar 13 N RadixSort (a() AS DOUBLE, start&, finish&, order&) 296 N Only for integers, otherwise it will use MergeSort
' to maintain RadixSort's stability
'2018 Mar 14 BucketSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&, recurse%) 280 N Without recursion, 100 times slower 20812ns
' Final subarray sort done with MergeSort keeps this
' algorithm competitive.
'2018 Mar 13 SinglePassShellSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 335 Y Got this idea from reading LOTS of articles. Performs
' respectably.
'2018 Mar 13 PrimeGapSort2 (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 343 Y Invented by CodeGuy/Zom-B, uses wheel factorization
' to generate primes.
'2018 Mar 13 PostSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 351 N Large auxiliary overhead. Final sort of subarrays
' done with MergeSort also keeps this algorithm competitive
' Like BucketSort, except that it uses a fixed number of
' buckets. Using fewwer actually increases speed, at 1
' Bucket, it's essentially a MergeSort.
'2018 Mar 13 PrimeGapSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 382 Y Invented by CodeGuy. Proud to declare PrimeGapSort
' is competitive and performs on par with ShellSort or
' better. Uses gaps that are prime.
'2018 Mar 13 JoinSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 484 N A respectably quick algorithm. Also, not the fastest
' but for a comparison sort, good enough.
'2018 Mar 13 NLogN HeapSort (CGSortLibArr() AS DOUBLE, Start&, Finish&, order&) 492 Y
'2018 Mar 13 ShellSortMetzner (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 500 Y With this variant, it is appreciably faster than ShellSort.
'2018-Mar-13 ShellSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 546 Y
'2018 Mar 13 CombSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 898 Y
'2018 Mar 13 Nlog^2N BatcherOddEvenMergeSort (CGSortLibArr() AS DOUBLE, Start&, Finish&) 1093 Y Only works for power-of-2 sized arrays
'2018 Mar 13 SmoothSort (TypedCGSortLibArr() AS DataElement, order&) 1292 Y requires use of TYPE array) and only 0 to ubound.
' no ranges
'2018-Mar 13 ShellSortBidirectional (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 2421 Y
'2018 Mar 13 BitonicSort (CGSortLibArr() AS DOUBLE, lo&, n&, dir&) 2609 Y
'2018-Mar-13 N^2 InsertionSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 229133 Y Very fast for nearly-sorted arrays. Used as finishing
' run for many ShellSort variations.
'2018 Mar 13 N^2 InsertionSortBinary (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 330328 Y Supposedly faster than InsertionSort. Using randomized
' Double-precision, generally non-repeating, not proven
' in practice.
'2018 Mar 13 N^2 CycleSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) 784852 Y
' N^2 bubblesort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) ------
' N^2 CocktailSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) ------
' N^2 SelectionSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&) ------
' N^2 InsertionSortx (CGSortLibArr() AS DOUBLE, start&, finish&, order&) ------
' FlashSORTType (CGSortLibArr() AS FlashRec, start AS LONG, finish AS LONG, order&) ------ as yet untested. An experimental algorithm for use with
' string-type variables
'* InsertionSort(), BubbleSort(), MergeSort() are considered stable. The remainder either are not or as yet unconfirmed
'* I ran these individually and corrected flaws. Sorts that have times have been tested in ascending/descending order
'* this is a work in progress. The algorithms marked by ------ are too slow to be practical for this demo code
'* Tested on double-precision data.
'*******************************************************************************************************************************************************************
'[code=qb64]
If 0 Then
Dim crlf As String
crlf = Chr$(13) + Chr$(10)
io& = FreeFile
Open "CGSortAlgorithmsLibraryAndTest12i.bas" For Input As io&
casecount& = 0
copy$ = "select case SortChoose%" + crlf
While Not EOF(io&)
Line Input #io&, t$
t$ = LTrim$(t$)
If LCase$(Left$(t$, 4)) = "sub " Then
t$ = LCase$(Mid$(t$, 5))
If InStr(1, LCase$(t$), "sort") Then
p& = InStr(t$, "(")
If InStr(t$, "sort") < p& Then
If InStr(t$, "sort") > 0 Then
copy$ = copy$ + "case" + Str$(casecount&) + crlf
Asc(t$, p&) = 32
Asc(t$, Len(t$)) = 32
copy$ = copy$ + t$ + crlf
casecount& = casecount& + 1
End If
End If
End If
End If
Wend
copy$ = copy$ + "end select" + crlf
Close io&
_Clipboard$ = copy$
End If
'* this TYPE declaration MUST appear in your code to use my library
Type MinMaxRec
min As Long
max As Long
End Type
'* for Stabilized smoothsort
Type DataElement
thekey As Double
originalorder As Long
'Name AS STRING * 32
End Type
'* to here
Type SortPerfRec
Name As String * 40
AccumulatedTime As Double
runs As Long
Index As Integer
accnum As Double
End Type
ReDim SortResults(0 To 255) As SortPerfRec
ReDim PerformThis%(0 To 255)
For s& = LBound(PerformThis%) To UBound(PerformThis%)
PerformThis%(s&) = -1
Next
SortTestN& = 63
SortThreshhold& = 16
pgmh& = _NewImage(1366, 768, 32)
Screen pgmh&
outsf& = _LoadFont("c:\windows\fonts\cour.ttf", 14, "monospace")
_Font outsf&
Do
ReDim _Preserve TestArrayType(0 To 0) As DataElement
ReDim _Preserve TestCGSortLibArr(0 To SortTestN&) As Double
ReDim _Preserve ElementCounts(0 To SortTestN&) As Long '* only used for demo code
Main_Sorted_From_N& = LBound(TestCGSortLibArr)
Main_Sorted_To_N& = UBound(TestCGSortLibArr)
If 0 Then '* 104s is JUST too long for 65536 elements
t! = Timer(.001)
For SearchTestArrayIndex& = LBound(TestArray) To UBound(TestArray) - 1
'* skip this element if it has already been found
If ElementCounts(SearcTestArrayIndex&) <> -1 Then
For SearchNextOccurrence& = SearchTestOccurrence& + 1 To UBound(TestArray)
If ElementCounts(SearchNextOccurrence&) <> -1 Then
If TestCGSortLibArr(SearchTestArrayIndex&) = TestCGSortLibArr(SearchNextOccurrence&) Then
ElementCounts(SearchTestArrayIndex&) = ElementCounts(SearchTestArrayIndex&) + 1
ElementCounts(SearchNextOccurrence&) = -1
End If
End If
Next
End If
If ElementCounts(SearchTestArrayIndex&) > 1 Then
Print "("; TestCGSortLibArr(SearchTestArrayIndex&); ElementCounts(SearchTestArrayIndex&); ")";
End If
Next
u! = Timer(.001)
Print DeltaTime(t!, u!)
End If
'_FULLSCREEN
'* now we get a bit more clever and use a sorting method that isn't QuickSort, to bypass its potentially O(N^2) performance
'* One very fast algorithm posted in prior posts, KD Neubert FlashSort() comes to mind. Fast? Damn near O(N).
'* the new fastest sort I know of, invented by CodeGuy, beats FlashSort often enough to call a winner, especially for very
'* large N on repetitive sets.
NTrials& = 0 '* 1 less than you really want
$Checking:Off
For SortChoose% = 0 To UBound(SortResults)
If PerformThis%(SortChoose%) Then
For SetTestArray& = Main_Sorted_From_N& To Main_Sorted_To_N&
TestCGSortLibArr(SetTestArray&) = Rnd '*Main_Sorted_To_N& - SetTestArray& 'INT(RND * 1048576) AND 1
'TestArrayType(SetTestArray&).thekey = INT(256 * RND) '(RND * 1023) AND 1023
'TestArrayType(SetTestArray&).originalorder = SetTestArray&
Next
Locate 3, 1: Print SortResults(SortChoose%).Name;
For sortdir& = 1 To 1 Step 2
For passes& = 0 To NTrials&
$Checking:Off
'KnuthShuffle TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&
'* TestCGSortLibArr
u! = Timer(.001)
While Timer(.001) = u!
Wend
u! = Timer(.001)
Select Case SortChoose%
Case 0
SortResults(SortChoose%).Name = "[s+][i-][n ]Post"
PostSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 1
SortResults(SortChoose%).Name = "[s-][i-][n ]Flash"
FlashSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 2
SortResults(SortChoose%).Name = "[s-][i+][*****]Shell"
ShellSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 3
SortResults(SortChoose%).Name = "[s-][i+][*****]ShellBidirectional"
ShellSortBidirectional TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 4
SortResults(SortChoose%).Name = "[s-][i+][NLogN]QuickRecursive"
QuickSortRecursive TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 5
SortResults(SortChoose%).Name = "[s-][i+][NlogN]QuickIterative"
QuickSortIterative TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 6
SortResults(SortChoose%).Name = "[s-][i+][NLogN]QuickDualPivot"
QuickSortDualPivot TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 7
SortResults(SortChoose%).Name = "[s+][i-][NLogN]MergeRoutine"
MergeSortRoutine TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 8
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]Bubble"
BubbleSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 9
SortResults(SortChoose%).Name = "[s-][i+][n^2 ]Cocktail"
CocktailSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 10
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]InsertionBinary"
InsertionSortBinary TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 11
SortResults(SortChoose%).Name = "[s+][i-][n^1 ]Bucket"
r% = 1
BucketSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&, r%
Case 12
SortResults(SortChoose%).Name = "[s-][i+][NLogN]Heap"
HeapSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 13
SortResults(SortChoose%).Name = "[s-][i+][NLogN]QuickIntrospective"
QuickSortIntrospective TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 14
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]BubbleModified"
BubbleSortModified TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 15
SortResults(SortChoose%).Name = "[s+][i-][NLogN]MergeTwoWay"
MergeSortTwoWay TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 16
SortResults(SortChoose%).Name = "[s+][i-][NLogN]TreeUsingBST"
TreeSortUsingBST TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
'SortResults(SortChoose%).Name = "DistCountingSort"
'CountingSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
'flashstring TestArrayType() ,Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
'_CONTINUE
Case 17
SortResults(SortChoose%).Name = "[s-][i+][*****]PrimeGap2(codeGuy/Zom-B)"
primeGapSort2 TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 18
SortResults(SortChoose%).Name = "[s-][i+][*****]Comb"
CombSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 19
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]Selection"
SelectionSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 20
SortResults(SortChoose%).Name = "[s-][i+][n^2 ]Cycle"
cycleSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 21
SortResults(SortChoose%).Name = "[s-][i+][*****]ShellMetzner"
shellSortMetzner TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -22
SortResults(SortChoose%).Name = "[s-][i+][*****]PrimeGap"
PrimeGapSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 23
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]Insertion"
InsertionSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 24
SortResults(SortChoose%).Name = "[s-][i-][n ]HashList(CodeGuy)"
HashListSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 25
SortResults(SortChoose%).Name = "[s+][i-][NLogN]Radix"
RadixSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -26
SortResults(SortChoose%).Name = "[s-][i+][NLogN]BatcherOddEvenMerge"
BatcherOddEvenMergeSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 27
SortResults(SortChoose%).Name = "[s-][i+][*****]ShellSinglePass"
SinglePassShellSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 28
SortResults(SortChoose%).Name = "[s-][i+][*****]Bitonic"
BitonicSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 29
SortResults(SortChoose%).Name = "[s-][i-][NLogN]Snake"
SnakeSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 30
SortResults(SortChoose%).Name = "[s+][i-][NLogN]Tim=========>"
TimSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
'SortResults(SortChoose%).Name = "DistCountingSort"
'DIM T_minmax AS MinMaxRec: Tscale# = 1
'CGScaleArrayToInteger TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&, T_minmax, Tscale#
'CGFrequencyCounts TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&, T_minmax, Tscale#
'_CONTINUE
Case 31
SortResults(SortChoose%).Name = "[s-][i+][*****]Join"
JoinSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 32
SortResults(SortChoose%).Name = "[s-][i+][NLogN]QuickSimplifiedRecursive"
QSortRecursiveSimplified TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 33
'* Edsgar Djikstra's SmoothSort
SortResults(SortChoose%).Name = "[s+][i+][*****]Smooth_TypedArray"
s! = Timer(.001)
ReDim TestArrayType(0 To Main_Sorted_To_N&)
For s& = LBound(TestArrayType) To UBound(TestArrayType)
TestArrayType(s&).originalorder = s&
TestArrayType(s&).thekey = TestCGSortLibArr(s&)
Next
t! = Timer(.001)
SmoothSort_TypedArray TestArrayType(), sortdir&
x! = Timer(.001)
For s& = LBound(TestArrayType) To UBound(TestArrayType)
TestCGSortLibArr(s&) = TestArrayType(s&).thekey
Next
ReDim TestArrayType(0 To 0)
y! = Timer(.001)
subtracttime! = DeltaTime(x!, y!) + DeltaTime!(s!, t!)
SortResults(SortChoose%).AccumulatedTime = SortResults(SortChoose%).AccumulatedTime - subtracttime!
Case 34
SortResults(SortChoose%).Name = "[s-][i+][n^2 ]Gnome"
GnomeSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 35
SortResults(SortChoose%).Name = "[s-][i+][NLogN]QuickMedianOf3It"
QuickSortIterativeMedianOf3 TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 36
SortResults(SortChoose%).Name = "[s-][i+][n^2 ]SelectionUnstable"
SelectionSortUnstable TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 37
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]InsertionRecursive"
InsertionSortRecursive TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 38
SortResults(SortChoose%).Name = "[s+][i-][NLogN]MergeEmerge"
MergeSortEmerge TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 39
'* necessary because this routine eats a LOT of stack
If Main_Sorted_To_N& - Main_Sorted_From_N& > 8191 Then
PerformThis%(SortChoose%) = 0
Else
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]BubbleRecursive"
BubbleSortRecursive TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir
End If
Case 40
SortResults(SortChoose%).Name = "[s+][i+][n^2 ]BubbleRecursiveEmerge<-------"
BubbleSortRecursiveEmerge TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 41
SortResults(SortChoose%).Name = "[s+][i-][NLogN]MergeSortEfficient->"
MergeSortEfficient TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -42
SortResults(SortChoose%).Name = "[s+][i-][N ]CountingInteger"
CountingSortInteger TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -43
SortResults(SortChoose%).Name = "[s+][i-][N ]CountingNonInteger"
CountingSortNonInteger TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -44
SortResults(SortChoose%).Name = "[s+][i-][N ]BeadInteger"
BeadSortInteger TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -45
SortResults(SortChoose%).Name = "[s+][i-][N ]BeadNonInteger"
BeadSortNonInteger TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 46
SortResults(SortChoose%).Name = "[s-][i+][N^2 ]Pancake"
PancakeSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 47
SortResults(SortChoose%).Name = "[s-][i+][N^2 ]PrimeGap2(Split)"
PrimeGapSort2Split TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -48
SortResults(SortChoose%).Name = "[s-][i+][N^2 ]OneZero"
OneZeroSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -49
SortResults(SortChoose%).Name = "[s+][i+][N ]UniqueInteger"
UniqueIntegerSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 50
SortResults(SortChoose%).Name = "[s-][i-][N ]FlashSortGMMA"
FlashSortGMMA TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case 51
SortResults(SortChoose%).Name = "[s+][i+][NLogN]MergeInsert"
MergeInsert TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case -52
SortResults(SortChoose%).Name = "[s+][i+][N^2 ]ExchangeSort"
ExchangeSort TestCGSortLibArr(), Main_Sorted_From_N&, Main_Sorted_To_N&, sortdir&
Case Else
_Continue
End Select
v! = Timer(.001)
If ArraySequenceCheck&(TestCGSortLibArr(), LBound(TestArray), UBound(TestArray), sortdir&) Then
w! = Timer(.001)
CountArrayRepetitions TestCGSortLibArr(), LBound(TestArray), UBound(TestArray)
x! = Timer(.001)
Locate 1, 1
Print Using "## "; SortChoose%;
Print SortResults(SortChoose%).Name;
If sortdir& = 1 Then
Print "- ascending";
Else
Print "-descending";
End If
Print Using "####.########## "; DeltaTime!(u!, v!)
SortResults(SortChoose%).AccumulatedTime = SortResults(SortChoose%).AccumulatedTime + DeltaTime!(u!, v!)
SortResults(SortChoose%).runs = SortResults(SortChoose%).runs + 1
SortResults(SortChoose%).Index = SortChoose%
SortResults(SortChoose%).accnum = SortResults(SortChoose%).accnum + SortTestN& + 1
End If
$Checking:On
Next
Next
End If
Next
'* an example of using the DataElement sorts
ReDim Results(0 To UBound(SortResults)) As DataElement
Rcount& = LBound(Results)
For s& = 0 To UBound(Results)
If PerformThis%(s&) Then
If SortResults(s&).AccumulatedTime > 0 Then
If SortResults(s&).runs > 0 Then
Results(Rcount&).originalorder = s&
Results(Rcount&).thekey = CDbl(SortResults(s&).AccumulatedTime / SortResults(s&).accnum)
Rcount& = Rcount& + 1
End If
End If
End If
Next
If Rcount& > 0 Then
Cls
Rcount& = Rcount& - 1
ReDim _Preserve Results(LBound(Results) To Rcount&) As DataElement
'* give Djikstra some props and use his sort to do an ascending order sort on Results()
SmoothSort_TypedArray Results(), 1
'* index to the fastest performing sort
Locate 2, 1: Print "legend: [s]table, [i]n-place [complexity class]";
Locate 4, 1
Print Using "n=###,###,###,###"; (Main_Sorted_To_N& - Main_Sorted_From_N& + 1);
Locate 5, 1
FirstOrder& = Results(LBound(Results)).originalorder
halforder& = Results(LBound(Results) + (UBound(Results) - LBound(results) + 1) \ 2).originalorder
For s& = LBound(Results) To UBound(Results)
'COLOR (s& MOD 8) + 1, 1, 1
p& = Results(s&).originalorder
Print SortResults(p&).Name;
Print Using "####.######## "; SortResults(p&).AccumulatedTime;
Print Using "####.######## "; SortResults(p&).AccumulatedTime / SortResults(p&).accnum;
Print Using "####.############# "; SortResults(p&).AccumulatedTime / SortResults(FirstOrder&).AccumulatedTime
If SortResults(p&).AccumulatedTime / SortResults(halforder&).AccumulatedTime > SortThreshhold& Then
PerformThis%(p&) = 0
End If
Next
'COLOR 2, 1, 1
End If
'**********************
'CLS
'PRINT "N="; LTRIM$(STR$(Main_Sorted_To_N& - Main_Sorted_From_N& + 1))
'FOR h& = 0 TO 255
' IF SortResults(h&).runs > 0 THEN
' PRINT SortResults(h&).Name;
' PRINT USING "avg ###.###########"; SortResults(h&).AccumulatedTime / SortResults(h&).runs;
' 'PRINT SortResults(h&).runs;
' 'PRINT SortResults(h&).Index;
' PRINT USING "####.############## Index"; SortResults(h&).AccumulatedTime / SortResults(0).AccumulatedTime
' END IF
'NEXT
'* does what it says
'**********************
SortTestN& = SortTestN& * 2 + 1
Loop 'UNTIL SortTestN& > 16777215
Sub CountArrayRepetitions (CGSortLibArr() As Double, start&, finish&)
ReDim ElementCounts(0 To 0) As Long
ReDim ElementPointers(0 To 0) As Long
ProbeCount& = LBound(CGSortLibArr)
ElementCountIndex& = LBound(ElementCounts)
s& = start&
Do
If s& > finish& Then
Exit Do
Else
ElementPointers(ElementCountIndex&) = s&
r& = s&
Do
If r& > finish& Then
Exit Do
Else
If CGSortLibArr(r&) = CGSortLibArr(s&) Then
ElementCounts(ElementCountIndex&) = ElementCounts(ElementCountIndex&) + 1
r& = r& + 1
Else
Exit Do
End If
End If
Loop
s& = r&
ElementCountIndex& = ElementCountIndex& + 1
If ElementCountIndex& > UBound(ElementCounts) Then
ReDim _Preserve ElementCounts(LBound(ElementCounts) To ElementCountIndex&)
ReDim _Preserve ElementPointers(LBound(ElementPointers) To ElementCountIndex&)
End If
End If
Loop
If 0 Then
For s& = LBound(ElementCounts) To UBound(ElementCounts)
Print "("; CGSortLibArr(ElementPointers(s&)); ElementCounts(s&); ")";
Next
End If
End Sub
'*****************************************************************************************************************
'*******************************
'* The Tiny Library Starts Here:
'*******************************
'* answers the question, what's the Kth smallest element of an array of numbers. Generally
'* regarded as an O(n) algorithm, provided the array is not already in order, otherwise it
'* COULD become O(n^2) (think bubble, cycle or selection sorts, all of which are SLOW on
'* unordered datasets.
Sub OrderStatisticK (CGSortLibArr() As Double, start As Long, finish As Long, OSK_k)
Dim OSK_PivotX As Double '* MUST be same type as element of CGSortLibArr()
'* These MUST be same type as start and finish
Dim OSK_i As Long
Dim OSK_j As Long
Dim OSK_k As Long
Dim OSK_lower As Long
Dim OSK_upper As Long
'*********************************************
OSK_lower = start
OSK_upper = finish - 1
While OSK_lower < OSK_upper
OSK_i = OSK_lower
OSK_j = OSK_upper
OSK_PivotX = CGSortLibArr(OSK_k)
While OSK_i <= OSK_k And OSK_j >= OSK_k
While CGSortLibArr(OSK_i) < OSK_PivotX
OSK_i = OSK_i + 1
Wend
While CGSortLibArr(OSK_j) > OSK_PivotX
OSK_j = OSK_j - 1
Wend
Swap CGSortLibArr(OSK_i), CGSortLibArr(OSK_j)
OSK_i = OSK_i + 1
OSK_j = OSK_j - 1
Wend
If OSK_j < OSK_k Then
OSK_lower = OSK_i
End If
If OSK_i > OSK_k Then
OSK_upper = OSK_j
End If
Wend
End Sub
'******************************************
'* still VERY competitive until N>16,777,216
'* however, now dethroned by HashListSort
' sorts CGSortLibArr() with Start& to Finish& elements by use of
' index vector L with M elements, with M ca. 0.1 Finish&.
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Arbitrary numeric type version.
' This WAS the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
' strings may require some work. sounds like a project to me. I have changed a couple things from the original,
' namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
' kept popping up. Traced it to L() and added a minor (about 2.4%) increase in the upper bound of L(). I suppose this
' could also be used for non-integer and non-string types as well.
'* KD Neubert FlashSort. Incredibly FAST numeric sort. This is a distribution sort, like BucketSort or PostSort, except far less overhead
'* in memory. Refactored By CodeGuy for the best clarity I can possibly provide. The original version has a .125(upperbound-lowerbound) array,
'* but was changed to .128(upperbound-lowerbound) avoid array bound errors. Tested. Fast. Works.
'*********************************************
Sub FlashSort (CGSortLibArr() As Double, start As Long, finish As Long, order&)
'* change these:
Dim hold As Double
Dim flash As Double
Dim ANMiN As Double
'* to the same type as the array being sorted
'* change these:
Dim KIndex As Long
Dim MIndex As Long
Dim SIndex As Long
'* to long for qbxx as qbxx has no _unsigned types
'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (Int(.128 * (finish - start + 1)) + 1) Or 2
'* change these:
Dim FlashTrackL(0 To MIndex) As Long
Dim FlashI As Long
Dim FlashJ As Long
Dim NextFlashJ As Long
Dim FlashNMove As Long
Dim MaxValueIndex As Long
Dim MinValueIndex As Long
Dim FinishMinusOne As Long
'* to the appropriate type for the range being sorted (must match start, finish variables)
'* don't mess:
Dim FlashC1 As Double '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)
' sorts array A with finish elements by use of
' index vector L with M elements, with M ca. 0.128(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy
'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4&) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well. Note: For very large N, HashListSort()
'* works even faster and has a similar memory footprint. But yes, this is still faster than QuickSort for N>10000 and like
'* HashListSort, operates in asymptotically close to O(N) time.
Rem =============== CLASS FORMATION =================
ANMiN = CGSortLibArr(start)
MaxValueIndex = finish
MinValueIndex = start
For FlashI = start To finish
If (CGSortLibArr(FlashI) > CGSortLibArr(MaxValueIndex)) Then MaxValueIndex = FlashI
If (CGSortLibArr(FlashI) < CGSortLibArr(MinValueIndex)) Then MinValueIndex = FlashI
Next FlashI
Swap CGSortLibArr(MinValueIndex), CGSortLibArr(start): MinValueIndex = start: ANMiN = CGSortLibArr(MinValueIndex)
Swap CGSortLibArr(MaxValueIndex), CGSortLibArr(finish): MaxValueIndex = finish
If ANMiN = CGSortLibArr(MaxValueIndex) Then
'* this is a monotonic sequence array and by definition is already sorted
Exit Sub
End If
Dim FlashTrackL(MIndex)
FlashC1 = (MIndex - 1) / (CGSortLibArr(MaxValueIndex) - ANMiN)
For FlashI = start + 1 To finish - 1
KIndex = Int(FlashC1 * (CGSortLibArr(FlashI) - ANMiN)) + 1
FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
Next
For KIndex = LBound(FlashTrackL) + 1 To MIndex
FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
Next KIndex
Rem ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
While (FlashNMove < FinishMinusOne)
While (FlashJ > FlashTrackL(KIndex))
FlashJ = FlashJ + 1
KIndex = Int(FlashC1 * (CGSortLibArr(FlashJ) - ANMiN)) + 1
Wend
flash = CGSortLibArr(FlashJ)
Do
If (FlashJ = (FlashTrackL(KIndex) + 1)) Then
Exit Do
Else
If FlashNMove < (FinishMinusOne) Then
KIndex = Int(FlashC1 * (flash - ANMiN)) + 1
hold = CGSortLibArr(FlashTrackL(KIndex))
CGSortLibArr(FlashTrackL(KIndex)) = flash
flash = hold
FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
FlashNMove = FlashNMove + 1
Else
Exit Do
End If
End If
Loop
Wend
'================= Insertion Sort============
For SIndex = LBound(FlashTrackL) + 1 To MIndex
'* sort subranges
'********************* insertionsortz CGSortLibArr(), FlashTrackL(SIndex - 1), FlashTrackL(SIndex) - 1, order&
For FlashI = FlashTrackL(SIndex) - 1 To FlashTrackL(SIndex - 1) Step -1
If (CGSortLibArr(FlashI + 1) < CGSortLibArr(FlashI)) Then
hold = CGSortLibArr(FlashI)
NextFlashJ = FlashI
Do
FlashJ = NextFlashJ
If FlashJ < FlashTrackL(SIndex) Then
NextFlashJ = FlashJ + 1
If (CGSortLibArr(NextFlashJ) < hold) Then
Swap CGSortLibArr(FlashJ), CGSortLibArr(NextFlashJ)
Else
Exit Do
End If
Else
Exit Do
End If
Loop
CGSortLibArr(FlashJ) = hold
End If
Next
'* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
Next
Exit Sub
If order& = 1 Then Exit Sub
FlashI = start
FlashJ = finish
While FlashJ > FlashI
Swap CGSortLibArr(FlashI), CGSortLibArr(FlashJ)
FlashI = FlashI + 1
FlashJ = FlashJ - 1
Wend
End Sub
'********************
'* InsertionSort is a simple to construct sort. Generally because of its O(n^2) running time, it's usually limited to VERY short runs
'* or used as a final sorting stage of many sorts. it is stable. The advantage of this sort for nearly sorted arrays is it runs in nearly O(n) time.
'* InsertionSort is adaptive, meaning it takes advantage of pre-existing order. Modified for faster performance on already-sorted data 21 Apr 2018.
'********************
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_j = InSort_Local_i - 1
If CGSortLibArr(InSort_Local_i) < CGSortLibArr(InSort_Local_j) Then
InSort_Local_ArrayTemp = CGSortLibArr(InSort_Local_i)
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
End If
Next
Case Else
For InSort_Local_i = start + 1 To finish
InSort_Local_j = InSort_Local_i - 1
If CGSortLibArr(InSort_Local_i) > CGSortLibArr(InSort_Local_j) Then
InSort_Local_ArrayTemp = CGSortLibArr(InSort_Local_i)
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
End If
Next
End Select
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
'**********************************
'* Asymmetric performance and stack overflows make this algorithm a dog. BinaaryInsertionSort is almost twice
'* twice as fast and does not cause recursion problems. Time for descending sort is twice that of ascending.
'* mostly a conversation piece.
'* [s+][i+][n^2 ]
Sub InsertionSortRecursive (CgSortLibArr() As Double, start As Long, finish As Long, order&)
If finish - start > 8191 Then
'* this will help prevent stack overflows
InsertionSort CgSortLibArr(), start, finish, order&
Else
If (finish > start) Then
InsertionSortRecursive CgSortLibArr(), start, finish - 1, order&
Dim last As Double
Dim j As Long
Select Case order&
Case 1
last = CgSortLibArr(finish)
j = finish - 1
Do
If j < start Then
Exit Do
Else
If CgSortLibArr(j) > last Then
CgSortLibArr(j + 1) = CgSortLibArr(j)
j = j - 1
Else
Exit Do
End If
End If
Loop
CgSortLibArr(j + 1) = last
Case Else
last = CgSortLibArr(finish)
j = finish - 1
Do
If j < start Then
Exit Do
Else
If CgSortLibArr(j) < last Then
CgSortLibArr(j + 1) = CgSortLibArr(j)
j = j - 1
Else
Exit Do
End If
End If
Loop
CgSortLibArr(j + 1) = last
End Select
End If
End If
End Sub
'******************************
'* ShellSort compares elements a gap distance apart, scans the array for out-of-order elements until none are
'* found and then continues reducing this gap distance until it reaches 0. It is not a stable sort, meaning elements
'* of equal value may appear in a position not the same order as it appears in the original array. It is reasonably easy to
'* code, adaptable for any data type and runs in reasonable time, thought to be around O(n^(5/4)). There are Numerous gap
'* reduction methods. The most "popular" being the (Gap/2) method. I have made several modifications to aid running time,
'* namely tracking the first and last position a swap occurred and using this to only scan to that point or less on successive
'* passes. The last pass of shellsort is the same as InsertionSort.
'******************************
Sub ShellSort (CGSortLibArr() As Double, start&, finish&, order&)
Select Case finish& - start&
Case 1
If CGSortLibArr(start&) > CGSortLibArr(finish&) Then
If order& = 1 Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
End If
End If
Case Is > 1
If order& = 1 Then
ShellSortGap& = (finish& - start&) \ 2
Do
If ShellSortGap& > 1 Then
LoopCount& = 0
xstart& = start&
xfinish& = finish& - ShellSortGap&
MaxPasses& = (finish& - start&) \ ShellSortGap&
Do
xfirst& = xfinish&
For ShellSortS& = xstart& To xfinish&
If CGSortLibArr(ShellSortS&) > CGSortLibArr(ShellSortS& + ShellSortGap&) Then
Swap CGSortLibArr(ShellSortS&), CGSortLibArr(ShellSortS& + ShellSortGap&)
Last& = ShellSortS&
If ShellSortS& < xfirst& Then
xfirst& = ShellSortS&
End If
End If
Next
xfinish& = Last&
xstart& = xfirst&
LoopCount& = LoopCount& + 1
Loop While LoopCount& < MaxPasses& And (xfinish& - xstart&) >= ShellSortGap&
ShellSortGap& = ShellSortGap& \ 2
Else
InsertionSort CGSortLibArr(), start&, finish&, order&
Exit Do
End If
Loop
Else
ShellSortGap& = (finish& - start&) \ 2
Do
If ShellSortGap& > 1 Then
LoopCount& = 0
xstart& = start&
xfinish& = finish& - ShellSortGap&
MaxPasses& = (finish& - start&) \ ShellSortGap&
Do
xfirst& = xfinish&
For ShellSortS& = xstart& To xfinish&
If CGSortLibArr(ShellSortS&) < CGSortLibArr(ShellSortS& + ShellSortGap&) Then
Swap CGSortLibArr(ShellSortS&), CGSortLibArr(ShellSortS& + ShellSortGap&)
Last& = ShellSortS&
If ShellSortS& < xfirst& Then
xfirst& = ShellSortS&
End If
End If
Next
xfinish& = Last&
xstart& = xfirst&
LoopCount& = LoopCount& + 1
Loop While LoopCount& < MaxPasses& And (xfinish& - xstart&) >= ShellSortGap&
ShellSortGap& = ShellSortGap& \ 2
Else
InsertionSort CGSortLibArr(), start&, finish&, order&
Exit Do
End If
Loop
End If
End Select
End Sub
'*******************************************
'* this has been modified to become a bidirectional shellsort, which is far faster than the bubblesort version, which is a special case where
'* gap& is 1, and runs in polynomial o(n^1(5/4)) time when like its unidirectional predecessor. Not Stable. No practical use in real life I've
'* seen, but entertaining if visualized.
'*******************************************
Sub ShellSortBidirectional (CGSortLibArr() As Double, start&, finish&, order&)
Select Case order&
Case 1
gap& = (finish& - start& + 1) \ 2
Do Until gap& < 1
up% = -1: down% = -1: passes& = 0: maxpasses& = (finish& - start& + 1) \ gap& - 1
startup& = start&: endup& = finish& - gap&: FirstUp& = finish& - gap&: LastUp& = start&
startdn& = finish&: enddown& = start& + gap&: FirstDown& = start& + gap&: LastDown& = finish&
passes& = 0
Do
If up% Then
up% = 0
For i& = startup& To endup&
If CGSortLibArr(i&) > CGSortLibArr(i& + gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + gap&)
If i& < FirstUp& Then
FirstUp& = i&
End If
LastUp& = i&
up% = -1
End If
Next
startup& = FirstUp&
endup& = LastUp&
Swap FirstUp&, LastUp&
End If
'*******************************
If down% Then
down% = 0
For i& = startdn& To enddown& Step -1
If CGSortLibArr(i&) < CGSortLibArr(i& - gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& - gap&)
If i& > FirstDown& Then
FirstDown& = i&
End If
LastDown& = i&
down% = -1
End If
Next
startdn& = FirstDown&
enddown& = LastDown&
Swap FirstDown&, LastDown&
End If
If passes& < maxpasses& Then
If up% Or down% Then
If passes& < (enddown& - startdown&) \ gap& - 1 Or passes& < (endup& - startup&) \ gap& - 1 Then
passes& = passes& + 1
Else
Exit Do
End If
Else
Exit Do
End If
Else
Exit Do
End If
Loop
gap& = gap& \ 2
Loop
Case Else
gap& = (finish& - start& + 1) \ 2
Do Until gap& < 1
up% = -1: down% = -1: passes& = 0: maxpasses& = (finish& - start& + 1) \ gap& - 1
startup& = start&: endup& = finish& - gap&: FirstUp& = finish& - gap&: LastUp& = start&
startdn& = finish&: enddown& = start& + gap&: FirstDown& = start& + gap&: LastDown& = finish&
Do
If up% Then
up% = 0
For i& = startup& To endup&
If CGSortLibArr(i&) < CGSortLibArr(i& + gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + gap&)
If i& < FirstUp& Then
FirstUp& = i&
End If
LastUp& = i&
up% = -1
End If
Next
startup& = FirstUp&
endup& = LastUp&
Swap FirstUp&, LastUp&
End If
'*******************************
If down% Then
down% = 0
For i& = startdn& To enddown& Step -1
If CGSortLibArr(i&) > CGSortLibArr(i& - gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& - gap&)
If i& > FirstDown& Then
FirstDown& = i&
End If
LastDown& = i&
down% = -1
End If
Next
startdn& = FirstDown&
enddown& = LastDown&
Swap FirstDown&, LastDown&
End If
If passes& < maxpasses& Then
If up% Or down% Then
If passes& < (enddown& - startdown&) \ gap& - 1 Or passes& < (endup& - startup&) \ gap& - 1 Then
passes& = passes& + 1
Else
Exit Do
End If
Else
Exit Do
End If
Else
Exit Do
End If
Loop
gap& = gap& \ 2
Loop
End Select
End Sub
'*******************************************
'* TESTED -- WORKS
'* QuickSortRecursive is reputedly the "fastest sort." This is not true in all cases. One way to defeat QuickSort and send it into
'* polynomial time O(n^2) is to present it with an already-sorted array. There are safeguards to this. One to shuffle the array
'* before executing quicksort or in the case of IntroSort, revert to MergeSort once a certain level of recursion or InsertionSort
'* once a small (usually 15-31) sublist size is reached.
'* Often mistakenly referred to as the fastest sort, it does around NLogN comparisons, which is the lower bound for
'* comparison sorts. Fast? Generally, but not always. This is the recursive version, fine for most modern processors that support
'* the use of hardware stacks. This is a divide-and-conquer algorithm as is MergeSort.
Sub QuickSortRecursive (CGSortLibArr() As Double, start&, finish&, order&)
Select Case finish& - start&
Case 1
'* This is CRITICAL
Select Case order&
Case 1
If CGSortLibArr(start&) > CGSortLibArr(finish&) Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
End If
Case Else
If CGSortLibArr(start&) < CGSortLibArr(finish&) Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
End If
End Select
Case Is > 1
QuickSortIJ CGSortLibArr(), start&, finish&, i&, j&, order&
If (i& - start&) < (finish& - j&) Then
QuickSortRecursive CGSortLibArr(), start&, j&, order&
QuickSortRecursive CGSortLibArr(), i&, finish&, order&
Else
QuickSortRecursive CGSortLibArr(), i&, finish&, order&
QuickSortRecursive CGSortLibArr(), start&, j&, order&
End If
End Select
End Sub
'*********************************
'* TESTED -- WORKS
'* This is the iterative version of QuickSort, using a software stack, useful for OLD processors lacking hardware registers to support
'* recursion. Operationally, it is very much the same as the recursive version except the "stack" is software-based.
'* Modified 2018 March 13 for stack bounds correction. Also modified to indicate local variables, and make changing variables as
'* necessary to accommodate range and type more straightforward.
Sub QuickSortIterative (CGSortLibArr() As Double, QSIStart As Long, QSIFinish As Long, order&)
Dim QSI_Local_Compare As Double '* MUST be same type as element of CGSortLibArr()
'* These MUST be the appropriate type for the range being sorted
Dim QSI_Local_I As Long
Dim QSI_local_J As Long
Dim QSI_Local_Hi As Long
Dim QSI_Local_Low As Long
Dim QSI_Local_Mid As Long
'****************************************************************
'* Integer suffices for QSI_Local_MinStackPtr unless you're sorting more than 2^32767 elements.
Dim QSI_Local_MinStackPtr As Integer: QSI_Local_MinStackPtr = 0
Dim QSI_Local_QSI_local_CurrentStackPtr As Integer: QSI_Local_QSI_local_CurrentStackPtr = 0
Dim QSI_Local_FinishMinusStart As Long: QSI_Local_FinishMinusStart = QSIFinish - QSIStart
Dim QSI_local_Remainder As Integer
'* yes, the equation log(QSIfinish-QSIstart)/log(2)+1 works too
Do
QSI_local_Remainder = QSI_Local_FinishMinusStart - (2 * Int(QSI_Local_FinishMinusStart / 2))
QSI_Local_FinishMinusStart = (QSI_Local_FinishMinusStart - QSI_local_Remainder) / 2
QSI_Local_MinStackPtr = QSI_Local_MinStackPtr + 1
Loop Until QSI_Local_FinishMinusStart < 1
'* MUST be appropriate type to handle the range (QSIfinish-QSIstart) being sorted
Dim QSI_LStack(0 To QSI_Local_MinStackPtr, 0 To 1) As Long
QSI_local_CurrentStackPtr = 0
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSIStart
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSIFinish
Do
QSI_Local_Low = QSI_LStack(QSI_local_CurrentStackPtr, 0)
QSI_Local_Hi = QSI_LStack(QSI_local_CurrentStackPtr, 1)
Do
QSI_Local_I = QSI_Local_Low
QSI_local_J = QSI_Local_Hi
QSI_Local_Mid = QSI_Local_Low + (QSI_Local_Hi - QSI_Local_Low) \ 2
QSI_Local_Compare = CGSortLibArr(QSI_Local_Mid)
Select Case order&
Case 1
Do
Do While CGSortLibArr(QSI_Local_I) < QSI_Local_Compare
QSI_Local_I = QSI_Local_I + 1
Loop
Do While CGSortLibArr(QSI_local_J) > QSI_Local_Compare
QSI_local_J = QSI_local_J - 1
Loop
If QSI_Local_I <= QSI_local_J Then
Swap CGSortLibArr(QSI_Local_I), CGSortLibArr(QSI_local_J)
QSI_Local_I = QSI_Local_I + 1
QSI_local_J = QSI_local_J - 1
End If
Loop Until QSI_Local_I > QSI_local_J
Case Else
Do
Do While CGSortLibArr(QSI_Local_I) > QSI_Local_Compare
QSI_Local_I = QSI_Local_I + 1
Loop
Do While CGSortLibArr(QSI_local_J) < QSI_Local_Compare
QSI_local_J = QSI_local_J - 1
Loop
If QSI_Local_I <= QSI_local_J Then
Swap CGSortLibArr(QSI_Local_I), CGSortLibArr(QSI_local_J)
QSI_Local_I = QSI_Local_I + 1
QSI_local_J = QSI_local_J - 1
End If
Loop Until QSI_Local_I > QSI_local_J
End Select
If QSI_local_J - QSI_Local_Low < QSI_Local_Hi - QSI_Local_I Then
If QSI_Local_I < QSI_Local_Hi Then
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSI_Local_I
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSI_Local_Hi
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr + 1
End If
QSI_Local_Hi = QSI_local_J
Else
If QSI_Local_Low < QSI_local_J Then
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSI_Local_Low
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSI_local_J
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr + 1
End If
QSI_Local_Low = QSI_Local_I
End If
Loop While QSI_Local_Low < QSI_Local_Hi
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr - 1
Loop Until QSI_local_CurrentStackPtr < 0
End Sub
'************************
'* TESTED -- WORKS
'* Yaroslavsky Dual-pivot QuickSort is useful for arrays having many repeating elements. Will still fail on some inputs but better than standard QuickSort
'* for the same lack of entropy in an array. This is a version of the standard Java QuickSort. There is a 3-pivot version, also adaptive.
'************************
Sub QuickSortDualPivot (CGSortLibArr() As Double, start&, finish&, order&)
Dim CompareP As Double
Dim CompareQ As Double
If start& < finish& Then
CompareP = CGSortLibArr(start&)
CompareQ = CGSortLibArr(finish&)
If order& = 1 Then
If CompareP > CompareQ Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
Swap CompareP, CompareQ
End If
Else
If CompareP < CompareQ Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
Swap CompareP, CompareQ
End If
End If
l& = start& + 1
k& = l&
g& = finish& - 1
Select Case order&
Case 1
While k& <= g&
If CGSortLibArr(k&) < CompareP Then
Swap CGSortLibArr(k&), CGSortLibArr(l&)
l& = l& + 1
Else
If CGSortLibArr(k&) >= CompareQ Then
While CGSortLibArr(g&) >= CompareQ And k& < g&
g& = g& - 1
Wend
Swap CGSortLibArr(k&), CGSortLibArr(g&)
g& = g& - 1
If CGSortLibArr(k&) <= CompareP Then
Swap CGSortLibArr(k&), CGSortLibArr(l&)
l& = l& + 1
End If
End If
End If
k& = k& + 1
Wend
Case Else
While k& <= g&
If CGSortLibArr(k&) > CompareP Then
Swap CGSortLibArr(k&), CGSortLibArr(l&)
l& = l& + 1
Else
If CGSortLibArr(k&) <= CompareQ Then
While CGSortLibArr(g&) <= CompareQ And k& < g&
g& = g& - 1
Wend
Swap CGSortLibArr(k&), CGSortLibArr(g&)
g& = g& - 1
If CGSortLibArr(k&) >= CompareP Then
Swap CGSortLibArr(k&), CGSortLibArr(l&)
l& = l& + 1
End If
End If
End If
k& = k& + 1
Wend
End Select
l& = l& - 1
g& = g& + 1
Swap CGSortLibArr(start&), CGSortLibArr(l&)
Swap CGSortLibArr(finish&), CGSortLibArr(g&)
QuickSortDualPivot CGSortLibArr(), start&, l& - 1, order&
QuickSortDualPivot CGSortLibArr(), l& + 1, g& - 1, order&
QuickSortDualPivot CGSortLibArr(), g& + 1, finish&, order&
End If
End Sub
'***********************
'* MergeSort is an O(NlogN) complexity divide and conquer stable sorting algorithm. The primary source of lag is the array copying.
'* The number of recurive calls is the same as the number of elements. If stability and predictable, undefeatable running time are
'* your sorting goals, this is an excellent choice. The memory overhead is approximately N/2 plus a few variables. With
'* EfficientMerge, memory overhead is halved, thus saving costly array copying. On my machine, this method is faster than the
'* standard MergeSort using the MergeRoutine() method.
'***********************
Sub MergeSortEmerge (CGSortLibArr() As Double, start&, finish&, order&)
Select Case finish& - start&
Case Is > 31
middle& = start& + (finish& - start&) \ 2
MergeSortEmerge CGSortLibArr(), start&, middle&, order&
MergeSortEmerge CGSortLibArr(), middle& + 1, finish&, order&
EfficientMerge CGSortLibArr(), start&, finish&, order&
Case Is > 0
InsertionSort CGSortLibArr(), start&, finish&, order&
End Select
End Sub
'*******************************
'* This is the standard MergeSort using the MergeRoutine() method. This is an example of head recursion, where recursive calls precede
'* other procedures.
'*******************************
Sub MergeSortRoutine (CGSortLibArr() As Double, start&, finish&, order&)
Select Case finish& - start&
Case Is > 31
middle& = start& + (finish& - start&) \ 2
MergeSortRoutine CGSortLibArr(), start&, middle&, order&
MergeSortRoutine CGSortLibArr(), middle& + 1, finish&, order&
MergeRoutine CGSortLibArr(), start&, finish&, order&
Case Is > 0
InsertionSort CGSortLibArr(), start&, finish&, order&
End Select
End Sub
'**********************************************
'* BubbleSort is a terrible performer on random arrays. It is good for nearly sorted arrays.
'* Average-case quadratic performance that is not adaptive makes this sort unsuitable for even small N
'* (here, finish - start).
'**********************************************
Sub BubbleSort (CGSortLibArr() As Double, start&, finish&, order&)
Select Case order&
Case 1
Do
changed& = 0
For I& = start& To finish& - 1
If CGSortLibArr(I&) > CGSortLibArr(I& + 1) Then
Swap CGSortLibArr(I&), CGSortLibArr(I& + 1)
changed& = -1
End If
Next
Loop While changed&
Case Else
Do
changed& = 0
For I& = start& To finish& - 1
If CGSortLibArr(I&) < CGSortLibArr(I& + 1) Then
Swap CGSortLibArr(I&), CGSortLibArr(I& + 1)
changed& = -1
End If
Next
Loop While changed&
End Select
End Sub
'**************************
'* another variation of bubblesort, CocktailSort also runs in o(n^2) and essentially scans up and down the array swapping out-of-order
'* elements until none are found. Stable, mostly a conversation piece.
'**************************
Sub CocktailSort (CGSortLibArr() As Double, start&, finish&, order&)
Select Case order&
Case 1
runs& = 0
Do
p& = finish& - runs&
done& = 1 '* assume it's sorted
For i& = start& + runs& To finish& - runs& - 1
If CGSortLibArr(i&) > CGSortLibArr(i& + 1) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + 1)
done& = 0
End If
If CGSortLibArr(p&) < CGSortLibArr(p& - 1) Then
Swap CGSortLibArr(p&), CGSortLibArr(p& - 1)
done& = 0
End If
p& = p& - 1
Next
runs& = runs& + 1
Loop Until done&
Case Else
runs& = 0
Do
p& = finish& - runs&
done& = 1 '* assume it's sorted
For i& = start& + runs& To finish& - runs& - 1
If CGSortLibArr(i&) < CGSortLibArr(i& + 1) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + 1)
done& = 0
End If
If CGSortLibArr(p&) > CGSortLibArr(p& - 1) Then
Swap CGSortLibArr(p&), CGSortLibArr(p& - 1)
done& = 0
End If
p& = p& - 1
Next
runs& = runs& + 1
Loop Until done&
End Select
End Sub
'******************************
'* this one is horrible with stack. No speed improvement and generally quite limited
'* because of its extremenly heavy use of stack.
'******************************
Sub BubbleSortRecursive (CGSortLibArr() As Double, startIndex As Long, endIndex As Long, order&)
If startIndex < endIndex Then
If order& = 1 Then
For c& = startIndex To endIndex - 1
If CGSortLibArr(c&) > CGSortLibArr(c& + 1) Then
Swap CGSortLibArr(c&), CGSortLibArr(c& + 1)
End If
Next
BubbleSortRecursive CGSortLibArr(), startIndex, endIndex - 1, order&
Else
For c& = startIndex To endIndex - 1
If CGSortLibArr(c&) < CGSortLibArr(c& + 1) Then
Swap CGSortLibArr(c&), CGSortLibArr(c& + 1)
End If
Next
BubbleSortRecursive CGSortLibArr(), startIndex, endIndex - 1, order&
End If
End If
End Sub
'SUB CountingSort (CGSortLibArr() AS DOUBLE, start&, finish&, order&)
' DIM CountingSortMinMax AS MinMaxRec
' GetMinMaxArray CGSortLibArr(), start&, finish&, CountingSortMinMax
' IF CGSortLibArr(CountingSortMinMax.min) < CGSortLibArr(CountingSortMinMax.max) THEN
' REDIM csCounts(0 TO (finish& - start&)) AS LONG
' FOR s& = start& TO finish&
' '* NthPlace& (a() AS DOUBLE, NPMMrec AS MinMaxRec, start AS LONG, finish AS LONG, order&, npindex AS LONG)
' index& = NthPlace&(CGSortLibArr(), CountingSortMinMax, 0, finish& - start&, order&, s&)
' PRINT CGSortLibArr(s&); finish& - start&; index& > (finish& - start&); index&; CGSortLibArr(s&) - CGSortLibArr(CountingSortMinMax.min)
' csCounts(index&) = csCounts(index&) + 1
' '_DELAY .25
' NEXT
' index& = start&
' 'FOR s# = cs_Min TO cs_max
' ' WHILE csCounts(s#)
' ' CGSortLibArr(index&) = s#
' ' index& = index& + 1
' ' csCounts(s#) = csCounts(s#) - 1
' ' WEND
' 'NEXT
' ERASE csCounts
' InsertionSort CGSortLibArr(), start&, finish&, order&
' END IF
'END SUB
'**********************
'* helper function for InsertionSortBinary exactly the same as a binary search which runs in O(LogN) time.
'FUNCTION BinaryB& (CGSortLibArr() AS DOUBLE, start&, Nio&)
' Bsrcha& = start&
' BsrchB& = start& + Nio&
' DO
' BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
' IF CGSortLibArr(BsrchC&) < CGSortLibArr(Nio&) THEN
' Bsrcha& = BsrchC& + 1
' ELSE
' BsrchB& = BsrchC&
' END IF
' LOOP WHILE Bsrcha& < BsrchB&
' BinaryB& = BsrchB&
'END FUNCTION
'*****************************
'* InsertionSortBinary uses Binary Search to find the correct position of an array element in the portion already sorted.
'* It's approximately 25 percent faster than standard InsertionSort in SOME cases.
'*****************************
'SUB InsertionSortBinary (CGSortLibArr() AS DOUBLE, start&, finish&, order&)
' SELECT CASE order&
' CASE 1
' Nsorted& = 0
' DO
' f& = BinaryB&(CGSortLibArr(), start&, Nsorted&)
' p& = start& + Nsorted&
' WHILE p& > f&
' x& = p& - 1
' SWAP CGSortLibArr(p&), CGSortLibArr(x&)
' p& = x&
' WEND
' Nsorted& = Nsorted& + 1
' LOOP UNTIL Nsorted& > finish& - start&
' CASE ELSE
' Nsorted& = 0
' DO
' f& = BinaryB&(CGSortLibArr(), start&, Nsorted&)
' p& = start& + Nsorted&
' WHILE p& > f&
' x& = p& - 1
' SWAP CGSortLibArr(p&), CGSortLibArr(x&)
' p& = x&
' WEND
' Nsorted& = Nsorted& + 1
' LOOP UNTIL Nsorted& > finish& - start&
' IF CGSortLibArr(start&) <> CGSortLibArr(finish&) THEN
' StableInvert CGSortLibArr(), start&, finish&, 1
' END IF
' END SELECT
'END SUB
'SUB InsertionSortBinary (CGSortLibArr() AS DOUBLE, start&, finish&, order&)
' DIM InSortBinary_NSorted AS LONG
' DIM InSortBinary_F AS LONG
' DIM InSortBinary_P AS LONG
' DIM InSortBinary_X AS LONG
' SELECT CASE order&
' CASE 1
' InSortBinary_NSorted = 0
' DO
' InSortBinary_F = BinaryB&(CGSortLibArr(), start&, InSortBinary_NSorted, order&)
' InSortBinary_P = start& + InSortBinary_NSorted
' WHILE InSortBinary_P > InSortBinary_F
' InSortBinary_X = InSortBinary_P - 1
' SWAP CGSortLibArr(InSortBinary_P), CGSortLibArr(InSortBinary_X)
' InSortBinary_P = InSortBinary_X
' WEND
' InSortBinary_NSorted = InSortBinary_NSorted + 1
' LOOP UNTIL InSortBinary_NSorted > finish& - start&
' CASE ELSE
' InSortBinary_NSorted = 0
' DO
' InSortBinary_F = BinaryB&(CGSortLibArr(), start&, InSortBinary_NSorted, order&)
' InSortBinary_P = start& + InSortBinary_NSorted
' WHILE InSortBinary_P > InSortBinary_F
' InSortBinary_X = InSortBinary_P - 1
' SWAP CGSortLibArr(InSortBinary_P), CGSortLibArr(InSortBinary_X)
' InSortBinary_P = InSortBinary_X
' WEND
' InSortBinary_NSorted = InSortBinary_NSorted + 1
' LOOP UNTIL InSortBinary_NSorted > finish& - start&
' END SELECT
'END SUB
'FUNCTION BinaryB& (CGSortLibArr() AS DOUBLE, start&, Nio&, order&)
' IF order& = 1 THEN
' Bsrcha& = start&
' BsrchB& = start& + Nio&
' DO
' BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
' IF CGSortLibArr(BsrchC&) < CGSortLibArr(Nio&) THEN
' Bsrcha& = BsrchC& + 1
' ELSE
' BsrchB& = BsrchC&
' END IF
' LOOP WHILE Bsrcha& < BsrchB&
' BinaryB& = BsrchB&
' ELSE
' Bsrcha& = start&
' BsrchB& = start& + Nio&
' DO
' BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
' IF CGSortLibArr(BsrchC&) > CGSortLibArr(Nio&) THEN
' Bsrcha& = BsrchC& + 1
' ELSE
' BsrchB& = BsrchC&
' END IF
' LOOP WHILE Bsrcha& < BsrchB&
' BinaryB& = BsrchB&
' END IF
'END FUNCTION
'**************************************
'* Reworked to present correct results. Approximately (20-30)% faster than the standard version for unordered data.
'* Recommended uses: sorting mostly ordered data or runs that are 1024 or less (about 3.9ms/GHz for doubl-precision).
'* Yes, there are faster, but they are not strictly in-place (some require stack (software or hardware), or auxiliary
'* storage for copies of the array range to be sorted. and can be made to go quadratic, thus being no better or
'* actually worse than InsertionSortBinary(). The complexity class is still O(n^2), but for the use cases listed prior,
'* InsertionSortBinary() provides a nice performance profile. This algorithm can be adapted EASILY to other data types.
'**************************************
Sub InsertionSortBinary (CGSortLibArr() As Double, start&, finish&, order&)
Dim InSortBinary_NSorted As Long
Dim InSortBinary_F As Long
Dim InSortBinary_P As Long
Dim InSortBinary_X As Long
InSortBinary_NSorted = 0
Do
InSortBinary_F = InsertionBinaryB&(CGSortLibArr(), start&, InSortBinary_NSorted, order&)
InSortBinary_P = start& + InSortBinary_NSorted
While InSortBinary_P > InSortBinary_F
InSortBinary_X = InSortBinary_P - 1
Swap CGSortLibArr(InSortBinary_P), CGSortLibArr(InSortBinary_X)
InSortBinary_P = InSortBinary_X
Wend
InSortBinary_NSorted = InSortBinary_NSorted + 1
Loop Until InSortBinary_NSorted > finish& - start&
End Sub
Function InsertionBinaryB& (CGSortLibArr() As Double, start&, NumberAlreadyOrdered&, order&)
If NumberAlreadyOrdered& > 0 Then
If order& = 1 Then
Bsrcha& = start&
BsrchB& = start& + NumberAlreadyOrdered&
If CGSortLibArr(start& + NumberAlreadyOrdered&) < CGSortLibArr(start& + NumberAlreadyOrdered& - 1) Then
Do
BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
If CGSortLibArr(BsrchC&) < CGSortLibArr(NumberAlreadyOrdered&) Then
Bsrcha& = BsrchC& + 1
Else
BsrchB& = BsrchC&
End If
Loop While Bsrcha& < BsrchB&
End If
InsertionBinaryB& = BsrchB&
Else
Bsrcha& = start&
BsrchB& = start& + NumberAlreadyOrdered&
If CGSortLibArr(start& + NumberAlreadyOrdered&) > CGSortLibArr(start& + NumberAlreadyOrdered& - 1) Then
Do
BsrchC& = Bsrcha& + (BsrchB& - Bsrcha&) \ 2
If CGSortLibArr(BsrchC&) > CGSortLibArr(NumberAlreadyOrdered&) Then
Bsrcha& = BsrchC& + 1
Else
BsrchB& = BsrchC&
End If
Loop While Bsrcha& < BsrchB&
End If
InsertionBinaryB& = BsrchB&
End If
Else
InsertionBinaryB& = start&
End If
End Function
Sub StableInvert (CGSortLibArr() As Double, start&, finish&, dorecurse&)
'* first invert then invert the equal elements
a& = start&
b& = finish&
While a& < b&
Swap CGSortLibArr(a&), CGSortLibArr(b&)
a& = a& + 1
b& = b& - 1
Wend
If dorecurse& Then
'* then scan the array for runs of equal elements
p& = start&
Do
If p& < finish& Then
y& = p& + 1
Do
If CGSortLibArr(p&) = CGSortLibArr(y&) Then
If y& < finish& Then
y& = y& + 1
Else
StableInvert CGSortLibArr(), p&, y&, 0
Exit Do
End If
Else
Exit Do
End If
Loop
p& = y&
Else
Exit Do
End If
Loop
End If
End Sub
'*****************************************
'* BucketSort (refactored)
'*****************************************
'*****************************************
'* BucketSort (modified 2018 march 14 (pi day 2018 to recurse), speeding things SIGNIFICANTLY.
'* by making a recursive single non-repeating call to BucketSort(), it speeds this up IMMENSELY. In fact, by 30 times.
'* From 10s down to 350ms, verified and correct, quite an improvement.
'* BucketSort() works by making fixed-size containers to hold ranges of elements. Much like Postman's Sort.
'* refactored to prevent inadvertent use of variables that MAY be present as constants or shared variables in MAIN.
'*****************************************
Sub BucketSort (CGSortLibArr() 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_ArrayMinValue 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
BSMMrec.min = start
BSMMrec.max = start
For x& = tstart To finish
If CGSortLibArr(x&) < CGSortLibArr(BSMMrec.min) Then BSMMrec.min = x&
If CGSortLibArr(x&) > CGSortLibArr(BSMMrec.max) Then BSMMrec.max = x&
Next
'* ------------------- GetMinMaxArray CGSortLibArr(), start, finish, BSMMrec
If (CGSortLibArr(BSMMrec.max) - CGSortLibArr(BSMMrec.min)) <> 0 Then
'* BS_Local_ArrayRange = CGSortLibArr(BSMMrec.max) - CGSortLibArr(BSMMrec.min)
BS_Local_ArrayMinValue = CGSortLibArr(BSMMrec.min)
BS_Local_NBuckets = Int(Log(finish - start + 1) / Log(2)) + 1
BS_Local_N = (finish - start + 1)
BS_Local_Remainder = BS_Local_N Mod BS_Local_NBuckets
BS_Local_NBuckets = BS_Local_NBuckets - 1
ReDim BS_Buckets_CGSortLibArr(0 To BS_Local_NBuckets, 0 To BS_Local_NBuckets * (1 + (BS_Local_N - BS_Local_Remainder) / BS_Local_NBuckets)) As Double
ReDim BS_Count_CGSortLibArr(0 To BS_Local_NBuckets) As Long
For BS_Local_S = start To finish
BS_Local_BucketIndex = Int((BS_Local_NBuckets - 1) * ((CGSortLibArr(BS_Local_S) - BS_Local_ArrayMinValue) / (CGSortLibArr(BSMMrec.max) - CGSortLibArr(BSMMrec.min))))
'IF BS_Count_CGSortLibArr(BS_Local_BucketIndex) > UBOUND(BS_Buckets_CGSortLibArr, 2) THEN
' REDIM _PRESERVE BS_Buckets_CGSortLibArr(BS_Local_BucketIndex, BS_Count_CGSortLibArr(BS_Local_BucketIndex)) AS DOUBLE
'END IF
BS_Buckets_CGSortLibArr(BS_Local_BucketIndex, BS_Count_CGSortLibArr(BS_Local_BucketIndex)) = CGSortLibArr(BS_Local_S)
BS_Count_CGSortLibArr(BS_Local_BucketIndex) = BS_Count_CGSortLibArr(BS_Local_BucketIndex) + 1
Next
BS_Local_Last_Insert_Index = start
BS_Local_Current_Insert_Index = start
For BS_Local_S = 0 To BS_Local_NBuckets
If BS_Count_CGSortLibArr(BS_Local_S) > 0 Then
BS_Local_Last_Insert_Index = BS_Local_Current_Insert_Index
For BS_Local_Z = 0 To BS_Count_CGSortLibArr(BS_Local_S) - 1
CGSortLibArr(BS_Local_Current_Insert_Index) = BS_Buckets_CGSortLibArr(BS_Local_S, BS_Local_Z)
BS_Local_Current_Insert_Index = BS_Local_Current_Insert_Index + 1
Next
If recurse% Then
'* Without this, 28s+ at (0, 131071)
recurse% = 0
BucketSort CGSortLibArr(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&, recurse%
Else
MergeSortEmerge CGSortLibArr(), BS_Local_Last_Insert_Index, BS_Local_Current_Insert_Index - 1, order&
End If
End If
Next
Erase BS_Buckets_CGSortLibArr, BS_Count_CGSortLibArr
End If
End Sub
'* adapted for use with qb64. This method is roughly 20 percent more efficient than the standard vector scan algorithm for min/max
'* Roughly 6.19s versus 7.93 for n=134217728 (0 counts as 1, of course)
'* This may be a nice addition for perhaps _CGArrayMax() in qb64. Of course, I am not so vain as to insist about the CG part.
'* simply meant as a faster tool for a common array problem to be solved. Also adaptable to string types.
'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
'SUB GetMinMaxArray (CGSortLibArr() AS DOUBLE, Start&, Finish&, GetMinMaxArray_minmax AS MinMaxRec)
' DIM GetGetMinMaxArray_minmaxArray_i AS LONG
' SELECT CASE Finish& - Start&
' CASE IS < 31
' GetMinMaxArray_minmax.min = start
' GetMinMaxArray_minmax.max = start
' FOR GetGetMinMaxArray_minmaxArray_i = Start& TO Finish&
' IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i) < CGSortLibArr(GetMinMaxArray_minmax.min) THEN GetMinMaxArray_minmax.min = GetGetMinMaxArray_minmaxArray_i
' IF CGSortLibArr(GetGetMinMaxArray_minmaxArray_i) > CGSortLibArr(GetMinMaxArray_minmax.max) THEN GetMinMaxArray_minmax.max = GetGetMinMaxArray_minmaxArray_i
' NEXT
' CASE ELSE
' '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 SELECT
'END SUB
Sub GetArrayMinmax (a() As Double, start&, finish&, arec As MinMaxRec)
arec.min = start&
arec.max = start&
Dim GetArrayMinmax_u As Long
For GetArrayMinmax_u = start& + 1 To finish&
If a(GetArrayMinmax_u) < a(arec.min) Then arec.min = GetArrayMinmax_u
If a(GetArrayMinmax_u) > a(arec.max) Then arec.max = GetArrayMinmax_u
Next
End Sub
Sub GetMinMaxArray (cg() As Double, start&, finish&, MinMaxArray As MinMaxRec)
If finish& - start& > 31 Then
'DIM GetMinMaxArray_i AS LONG
Dim GetMinMaxArray_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&
int10000& = (finish& - start&) \ 10000
GetMinMaxArray_NMod2 = (finish& - start&) - 10000 * int10000&
'* GetMinMaxArray_NMod2 = GetMinMaxArray_n - 10000 * ((GetMinMaxArray_n - GetMinMaxArray_TT) / 10000)
If (GetMinMaxArray_NMod2 Mod 2) Then
MinMaxArray.min = start&
MinMaxArray.max = start&
GetMinMaxArray_i = start& + 1
Else
If cg(start&) > cg(finish&) Then
MinMaxArray.max = start&
MinMaxArray.min = finish&
Else
MinMaxArray.min = finish&
MinMaxArray.max = start&
End If
GetMinMaxArray_i = start& + 2
End If
While GetMinMaxArray_i < finish&
If cg(GetMinMaxArray_i) > cg(GetMinMaxArray_i + 1) Then
If cg(GetMinMaxArray_i) > cg(MinMaxArray.max) Then
MinMaxArray.max = GetMinMaxArray_i
End If
If cg(GetMinMaxArray_i + 1) < cg(MinMaxArray.min) Then
MinMaxArray.min = GetMinMaxArray_i + 1
End If
Else
If cg(GetMinMaxArray_i + 1) > cg(MinMaxArray.max) Then
MinMaxArray.max = GetMinMaxArray_i + 1
End If
If cg(GetMinMaxArray_i) < cg(MinMaxArray.min) Then
MinMaxArray.min = GetMinMaxArray_i
End If
End If
GetMinMaxArray_i = GetMinMaxArray_i + 2
Wend
Else
GetArrayMinmax cg(), start&, finish&, MinMaxArray
End If
End Sub
Sub HeapSort (CGSortLibArr() As Double, Start&, Finish&, order&)
For i& = Start& + 1 To Finish&
PercolateUp CGSortLibArr(), Start&, i&, order&
Next i&
For i& = Finish& To Start& + 1 Step -1
Swap CGSortLibArr(Start&), CGSortLibArr(i&)
PercolateDown CGSortLibArr(), Start&, i& - 1, order&
Next i&
End Sub
Sub PercolateDown (CGSortLibArr() As Double, Start&, MaxLevel&, order&)
i& = Start&
'* Move the value in GetPixel&(Start&) down the heap until it has
'* reached its proper node (that is, until it is less than its parent
'* node or until it has reached MaxLevel&, the bottom of the current heap):
Do
Child& = 2 * (i& - Start&) + Start& ' Get the subscript for the Child& node.
'* Reached the bottom of the heap, so exit this procedure:
If Child& > MaxLevel& Then Exit Do
Select Case order&
Case 1
'* If there are two Child nodes, find out which one is bigger:
ax& = Child& + 1
If ax& <= MaxLevel& Then
If CGSortLibArr(ax&) > CGSortLibArr(Child&) Then
Child& = ax&
End If
End If
'* Move the value down if it is still not bigger than either one of
'* its Child&ren:
If CGSortLibArr(i&) < CGSortLibArr(Child&) Then
Swap CGSortLibArr(i&), CGSortLibArr(Child&)
i& = Child&
Else
'* Otherwise, CGSortLibArr() has been restored to a heap from start& to MaxLevel&,
'* so exit:
Exit Do
End If
Case Else
'* If there are two Child nodes, find out which one is smaller:
ax& = Child& + 1
If ax& <= MaxLevel& Then
If CGSortLibArr(ax&) < CGSortLibArr(Child&) Then
Child& = ax&
End If
End If
'* Move the value down if it is still not smaller than either one of
'* its Child&ren:
If CGSortLibArr(i&) > CGSortLibArr(Child&) Then
Swap CGSortLibArr(i&), CGSortLibArr(Child&)
i& = Child&
Else
'* Otherwise, CGSortLibArr() has been restored to a heap from start& to MaxLevel&,
'* so exit:
Exit Do
End If
End Select
Loop
End Sub
Sub PercolateUp (CGSortLibArr() As Double, Start&, MaxLevel&, order&)
Select Case order&
Case 1
i& = MaxLevel&
'* Move the value in CGSortLibArr(MaxLevel&) up the heap until it has
'* reached its proper node (that is, until it is greater than either
'* of its Child& nodes, or until it has reached 1, the top of the heap):
Do Until i& = Start&
'* Get the subscript for the parent node.
Parent& = Start& + (i& - Start&) \ 2
'* The value at the current node is still bigger than the value at
'* its parent node, so swap these two array elements:
If CGSortLibArr(i&) > CGSortLibArr(Parent&) Then
Swap CGSortLibArr(Parent&), CGSortLibArr(i&)
i& = Parent&
Else
'* Otherwise, the element has reached its proper place in the heap,
'* so exit this procedure:
Exit Do
End If
Loop
Case Else
i& = MaxLevel&
'* Move the value in CGSortLibArr(MaxLevel&) up the heap until it has
'* reached its proper node (that is, until it is greater than either
'* of its Child& nodes, or until it has reached 1, the top of the heap):
Do Until i& = Start&
'* Get the subscript for the parent node.
Parent& = Start& + (i& - Start&) \ 2
'* The value at the current node is still smaller than the value at
'* its parent node, so swap these two array elements:
If CGSortLibArr(i&) < CGSortLibArr(Parent&) Then
Swap CGSortLibArr(Parent&), CGSortLibArr(i&)
i& = Parent&
Else
'* Otherwise, the element has reached its proper place in the heap,
'* so exit this procedure:
Exit Do
End If
Loop
End Select
End Sub
'****************************************
'* The IntroSort() algorithm extended to QBxx because there is no qbxx-compatible code
'* The IntroSort algorithm extended to qb64 because i could find no pure qbxx code
'* 03Jun2017, by CodeGuy -- further mods for use in sorting library 03 Aug 2017
'* Introspective Sort (IntroSort) falls back to MergeSort after so many levels of
'* recursion and is good for highly redundant data (aka few unique)
'* for very short runs, it falls back to InsertionSort.
Sub QuickSortIntrospective (CGSortLibArr() As Double, IntroSort_start As Long, IntroSort_finish As Long, order&)
Dim IntroSort_i As Long
Dim IntroSort_J As Long
Static IntroSort_level&
Static IntroSort_MaxRecurseLevel&
IntroSort_MaxRecurseLevel& = 15
If IntroSort_start < IntroSort_finish Then
If IntroSort_finish - IntroSort_start > 31 Then
If IntroSort_level& > IntroSort_MaxRecurseLevel& Then
HeapSort CGSortLibArr(), IntroSort_start, IntroSort_finish, order&
Else
IntroSort_level& = IntroSort_level& + 1
QuickSortIJ CGSortLibArr(), IntroSort_start, IntroSort_finish, IntroSort_i, IntroSort_J, order&
QuickSortIntrospective CGSortLibArr(), IntroSort_start, IntroSort_J, order&
QuickSortIntrospective CGSortLibArr(), IntroSort_i, IntroSort_finish, order&
IntroSort_level& = IntroSort_level& - 1
End If
Else
InsertionSort CGSortLibArr(), IntroSort_start, IntroSort_finish, order&
End If
End If
End Sub
Sub QuickSortIJ (CGSortLibArr() As Double, start&, finish&, i&, j&, order&)
Dim Compare As Double '* MUST be the same type as CGSortLibArr()
i& = start&
j& = finish&
Compare = CGSortLibArr(i& + (j& - i&) \ 2)
Select Case order&
Case 1
Do
Do While CGSortLibArr(i&) < Compare
i& = i& + 1
Loop
Do While CGSortLibArr(j&) > Compare
j& = j& - 1
Loop
If i& <= j& Then
If i& <> j& Then
Swap CGSortLibArr(i&), CGSortLibArr(j&)
End If
i& = i& + 1
j& = j& - 1
End If
Loop Until i& > j&
Case Else
Do
Do While CGSortLibArr(i&) > Compare
i& = i& + 1
Loop
Do While CGSortLibArr(j&) < Compare
j& = j& - 1
Loop
If i& <= j& Then
If i& <> j& Then
Swap CGSortLibArr(i&), CGSortLibArr(j&)
End If
i& = i& + 1
j& = j& - 1
End If
Loop Until i& > j&
End Select
End Sub
'*********************************
'* The Standard Merge Algorithm extended to ascending or descending order
'* same tactic as MergeSort, but only MergeSorts halves amd then merges, with o(NlogN) for each half with straight Merge
'* the benefit of this meOhod is not only faster completion but also a 50% reduction in array allocation and copying.
'* this approach can be used in pretty much any sort to yield a faster sort, including the already-fast FlashSort. I will
'* attempt a string version of FlashSort. It will be complex.
'*********************************
Sub MergeSortTwoWay (CGSortLibArr() As Double, start&, finish&, order&)
middle& = start& + (finish& - start&) \ 2
MergeSortEmerge CGSortLibArr(), start&, middle&, order&
MergeSortEmerge CGSortLibArr(), middle& + 1, finish&, order&
'IF order& = 1 THEN
' EfficientMerge CGSortLibArr(), start&, finish&, order&
'ELSE
' MergeRoutine CGSortLibArr(), start&, finish&, order&
'END IF
End Sub
'**********************
'* Standardized Merge procedure. Assumes CGSortLibArr(start to middle), CGSortLibArr(middle+1 to finish) is already sorted on arrival.
'**********************
Sub MergeRoutine (CGSortLibArr() As Double, start&, finish&, order&)
length& = finish& - start&
middle& = start& + length& \ 2
Dim temp(0 To length&) As Double
For i& = 0 To length&
temp(i&) = CGSortLibArr(start& + i&)
Next
'* for refactoring purposes,
'* mptr& = 0
'* sptr& = middle& - start& + 1
'* could be omitted from the select case blocks and declared here instead. However, I am leaving them as is
'* so code between SELECT CASE conditional checks can simply be copied for a fully functioning merge.
Select Case order&
Case 1
mptr& = 0
sptr& = middle& - start& + 1
For i& = 0 To length&
If sptr& <= finish& - start& Then
If mptr& <= middle& - start& Then
If temp(mptr&) > temp(sptr&) Then
CGSortLibArr(i& + start&) = temp(sptr&)
sptr& = sptr& + 1
Else
CGSortLibArr(i& + start&) = temp(mptr&)
mptr& = mptr& + 1
End If
Else
CGSortLibArr(i& + start&) = temp(sptr&)
sptr& = sptr& + 1
End If
Else
CGSortLibArr(i& + start&) = temp(mptr&)
mptr& = mptr& + 1
End If
Next
Case Else
mptr& = 0
sptr& = middle& - start& + 1
For i& = 0 To length&
If sptr& <= finish& - start& Then
If mptr& <= middle& - start& Then
'* i see what you did there -- change from
'* temp(mptr&) > temp(sptr&) to temp(sptr&) > temp(mptr&)
If temp(sptr&) > temp(mptr&) Then
CGSortLibArr(i& + start&) = temp(sptr&)
sptr& = sptr& + 1
Else
CGSortLibArr(i& + start&) = temp(mptr&)
mptr& = mptr& + 1
End If
Else
CGSortLibArr(i& + start&) = temp(sptr&)
sptr& = sptr& + 1
End If
Else
CGSortLibArr(i& + start&) = temp(mptr&)
mptr& = mptr& + 1
End If
Next
End Select
Erase temp
End Sub
Function SequenceCheck& (CGSortLibArr() As Double, start&, finish&, order&)
SequenceCheck& = start&
i& = start&
Select Case order&
Case 1
For j& = start& + 1 To finish&
If CGSortLibArr(j&) > CGSortLibArr(i&) Then
i& = j& '
ElseIf CGSortLibArr(j&) < CGSortLibArr(i&) Then
SequenceCheck& = j&
Exit Function
End If
Next
Case Else
For j& = start& + 1 To finish&
If CGSortLibArr(j&) < CGSortLibArr(i&) Then
i& = j& '
ElseIf CGSortLibArr(j&) > CGSortLibArr(i&) Then
SequenceCheck& = j&
Exit Function
End If
Next
End Select
SequenceCheck& = finish&
End Function
'***************************************************************************
'* string-specific code
'***************************************************************************
Sub FlashString (StrCGSortLibArr() As String, start&, finish&, order&)
Type FlashRec
Number As _Integer64
Index As Long
End Type
ReDim FlashStringCGSortLibArr(start& To finish&) As FlashRec
Dim shift##(0 To 7)
If order& = 1 Then
shift##(7) = 1
For z% = 6 To 0 Step -1
shift##(z%) = shift##(z% + 1) * 256
Next
Else
shift##(0) = 1
For z% = 1 To 7
shift##(z%) = shift##(z% - 1) * 256
Next
End If
For s& = start& To finish&
acc## = 0
While z% < 8
zp% = z% + 1
p$ = Mid$(StrCGSortLibArr(s&), zp%, 1)
If p$ > "" Then
acc## = acc## + shift##(z%) * Asc(p$)
z% = zp%
Else
Exit While
End If
Wend
FlashStringCGSortLibArr(s&).Number = acc##
FlashStringCGSortLibArr(s&).Index = s&
Next
flashSORTType FlashStringCGSortLibArr(), start&, finish&, order&
End Sub
Sub flashSORTType (CGSortLibArr() As FlashRec, start As Long, finish As Long, order&)
'* change these:
Dim hold As FlashRec
Dim flash As FlashRec
Dim ANMiN As FlashRec
'* to the same type as the array being sorted
'* change these:
Dim KIndex As _Unsigned Long
Dim MIndex As _Unsigned Long
Dim SIndex As _Unsigned Long
'* to long for qbxx as qbxx has no _unsigned types
'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (Int(.128 * (finish - start + 1)) + 1) Or 2
'* change these:
Dim FlashTrackL(0 To MIndex) As Long
Dim FlashI As Double
Dim FlashJ As Double
Dim NextFlashJ As Double
Dim FlashNMove As Double
Dim MaxValueIndex As Double
Dim FinishMinusOne As Double
'* to the appropriate type for the range being sorted (must match start, finish variables)
'* don't mess:
Dim FlashC1 As Double '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)
' sorts array A with finish elements by use of
' index vector FlashTrackL with MIndex elements, with MIndex ca. 0.125(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy
'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4%) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well.
Rem =============== CLASS FORMATION =================
ANMiN = CGSortLibArr(start)
MaxValueIndex = start
For FlashI = start To finish
If (CGSortLibArr(FlashI).Number > CGSortLibArr(MaxValueIndex).Number) Then MaxValueIndex = FlashI
If (CGSortLibArr(FlashI).Number < ANMiN.Number) Then
ANMiN = CGSortLibArr(FlashI)
Swap CGSortLibArr(start), CGSortLibArr(FlashI)
End If
Next FlashI
If ANMiN.Number = CGSortLibArr(MaxValueIndex).Number Then
'* this is a monotonic sequence array and by definition is already sorted
Exit Sub
End If
FlashC1 = (MIndex - 1) / (CGSortLibArr(MaxValueIndex).Number - ANMiN.Number)
For FlashI = start + 1 To finish
KIndex = Int(FlashC1 * (CGSortLibArr(FlashI).Number - ANMiN.Number)) + 1
FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
Next
For KIndex = LBound(FlashTrackL) + 1 To MIndex
FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
Next KIndex
Rem ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
Swap CGSortLibArr(finish), CGSortLibArr(MaxValueIndex)
While (FlashNMove < FinishMinusOne)
While (FlashJ > FlashTrackL(KIndex))
FlashJ = FlashJ + 1
KIndex = Int(FlashC1 * (CGSortLibArr(FlashJ).Number - ANMiN.Number)) + 1
Wend
flash = CGSortLibArr(FlashJ)
Do
If (FlashJ = (FlashTrackL(KIndex) + 1)) Then
Exit Do
Else
If FlashNMove < (FinishMinusOne) Then
KIndex = Int(FlashC1 * (flash.Number - ANMiN.Number)) + 1
hold = CGSortLibArr(FlashTrackL(KIndex))
CGSortLibArr(FlashTrackL(KIndex)) = flash
flash = hold
FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
FlashNMove = FlashNMove + 1
Else
Exit Do
End If
End If
Loop
Wend
'================= Insertion Sort============
For SIndex = LBound(FlashTrackL) + 1 To MIndex
'* sort subranges
For FlashI = FlashTrackL(SIndex) - 1 To FlashTrackL(SIndex - 1) Step -1
If (CGSortLibArr(FlashI + 1).Number < CGSortLibArr(FlashI).Number) Then
hold = CGSortLibArr(FlashI)
NextFlashJ = FlashI
Do
FlashJ = NextFlashJ
If FlashJ < FlashTrackL(SIndex) Then
NextFlashJ = FlashJ + 1
If (CGSortLibArr(NextFlashJ).Number < hold.Number) Then
Swap CGSortLibArr(FlashJ), CGSortLibArr(NextFlashJ)
Else
Exit Do
End If
Else
Exit Do
End If
Loop
CGSortLibArr(FlashJ) = hold
End If
Next
'* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
Next
For s& = start& To finish&
Swap StrCGSortLibArr(s&), StrCGSortLibArr(CGSortLibArr(s&).Index)
Next
For s& = start& To finish& - 1
For t& = s& + 1 To finish&
If StrCGSortLibArr(s&) > StrCGSortLibArr(s& + 1) Then
Swap StrCGSortLibArr(s&), StrCGSortLibArr(s& + 1)
Else
Exit For
End If
Next
Next
If order <> 1 Then
If order <> 0 Then
FlashI = start
FlashJ = finish
While FlashI < FlashJ
Swap StrCGSortLibArr(FlashI), StrCGSortLibArr(FlashJ)
FlashI = FlashI - 1
FlashJ = FlashJ - 1
Wend
End If
End If
End Sub
Sub PrimeGapSort2Split (CGSortLibArr() As Double, start As Long, finish As Long, order&)
primeGapSort2 CGSortLibArr(), start, start + (finish - start) \ 2, order&
primeGapSort2 CGSortLibArr(), start + (finish - start) \ 2 + 1, finish, order&
EfficientMerge CGSortLibArr(), start, finish, order&
End Sub
'*******************
'* PrimeGapSort2 uses PrimeNumber&() function to calculate the prime number less than or equal to the gap
'* this is a variation of shellsort. This variation is thus far the fastest non-recursive, in-place sorting
'* algorithm. Invented by CodeGuy. Tested, proven and improved by CodeGuy and Zom-B.
'*******************
Sub primeGapSort2 (CGSortLibArr() As Double, start&, finish&, order&)
Select Case order&
Case 1
gap& = (finish& - start& + 1)
Do
For i& = start& To finish& - gap&
If CGSortLibArr(i&) > CGSortLibArr(i& + gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + gap&)
End If
Next
gap& = primeNumber&(gap& * 0.727)
Loop While gap& > 1
InsertionSort CGSortLibArr(), start&, finish&, order&
Case Else
gap& = (finish& - start& + 1)
Do
For i& = start& To finish& - gap&
If CGSortLibArr(i&) < CGSortLibArr(i& + gap&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + gap&)
End If
Next
gap& = primeNumber&(gap& * 0.727)
Loop While gap& > 1
InsertionSort CGSortLibArr(), start&, finish&, order&
End Select
End Sub
Function primeNumber& (a&)
' Find a prime number below a& (excluding 3 and 5)
'
' Notice that there is a:
' 59,9% chance for a single successive guess,
' 83,9% chance for a successive guess out of two guesses,
' 93,6% chance for a successive guess out of three guesses,
' 97,4% chance for a successive guess out of four guesses,
' 99,98% chance for a successive guess out of ten guesses...
'
' Worst bad luck over 10000 tested primes: 19 guesses.
Static addtoskip5%()
Static firstCall%
Static pps%() 'Previous Prime in Sequence. Contains about 59.9% of all primes modulo 30.
'* wheel factorization by Zom-B
If firstCall% = 0 Then
firstCall% = -1
ReDim pps%(0 To 29)
' Map numbers from 0 to 29 to the next lower prime in the sequence {1,7,11,13,17,19,23,29}.
pps%(0) = -1: pps%(1) = -1 ' -1 = 29 (modulo 30)
pps%(2) = 1: pps%(3) = 1: pps%(4) = 1: pps%(5) = 1: pps%(6) = 1: pps%(7) = 1
pps%(8) = 7: pps%(9) = 7: pps%(10) = 7: pps%(11) = 7
pps%(12) = 11: pps%(13) = 11:
pps%(14) = 13: pps%(15) = 13: pps%(16) = 13: pps%(17) = 13
pps%(18) = 17: pps%(19) = 17
pps%(20) = 19: pps%(21) = 19: pps%(22) = 19: pps%(23) = 19
pps%(24) = 23: pps%(25) = 23: pps%(26) = 23: pps%(27) = 23: pps%(28) = 23: pps%(29) = 23
ReDim addtoskip5%(3)
addtoskip5%(0) = 2
addtoskip5%(1) = 4
addtoskip5%(2) = 2
addtoskip5%(3) = 2
End If
b& = a& + 1
c& = (b& \ 30) * 30
b& = c& + pps%(b& - c&)
div& = 3
asi% = 1
Do
If b& Mod div& Then
If b& / div& < div& Then
Exit Do
Else
div& = div& + addtoskip5%(asi%)
asi% = (asi% + 1) And 3
End If
Else
c& = (b& \ 30) * 30
b& = c& + pps%(b& - c&)
div& = 3
asi% = 1
End If
Loop
primeNumber& = b&
End Function
'*******************
'* CombSort is the same as shellsort except a reduction factor of 1.3
'*******************
Sub CombSort (CGSortLibArr() As Double, start&, finish&, order&)
Select Case finish& - start&
Case 1
If CGSortLibArr(start&) > CGSortLibArr(finish&) Then
If order& = 1 Then
Swap CGSortLibArr(start&), CGSortLibArr(finish&)
End If
End If
Case Is > 1
If order& = 1 Then
ShellSortGap& = Int(10 * (finish& - start&) / 13)
Do
If ShellSortGap& > 1 Then
LoopCount& = 0
xstart& = start&
xfinish& = finish& - ShellSortGap&
MaxPasses& = (finish& - start&) \ ShellSortGap&
Do
xfirst& = xfinish&
For ShellSortS& = xstart& To xfinish&
If CGSortLibArr(ShellSortS&) > CGSortLibArr(ShellSortS& + ShellSortGap&) Then
Swap CGSortLibArr(ShellSortS&), CGSortLibArr(ShellSortS& + ShellSortGap&)
Last& = ShellSortS&
If ShellSortS& < xfirst& Then
xfirst& = ShellSortS&
End If
End If
Next
xfinish& = Last&
xstart& = xfirst&
LoopCount& = LoopCount& + 1
Loop While LoopCount& < MaxPasses& And (xfinish& - xstart&) >= ShellSortGap&
ShellSortGap& = Int(10 * (ShellSortGap& / 13))
Else
InsertionSort CGSortLibArr(), start&, finish&, order&
Exit Do
End If
Loop
Else
ShellSortGap& = Int(10 * (finish& - start&) / 13)
Do
If ShellSortGap& > 1 Then
LoopCount& = 0
xstart& = start&
xfinish& = finish& - ShellSortGap&
MaxPasses& = (finish& - start&) \ ShellSortGap&
Do
xfirst& = xfinish&
For ShellSortS& = xstart& To xfinish&
If CGSortLibArr(ShellSortS&) < CGSortLibArr(ShellSortS& + ShellSortGap&) Then
Swap CGSortLibArr(ShellSortS&), CGSortLibArr(ShellSortS& + ShellSortGap&)
Last& = ShellSortS&
If ShellSortS& < xfirst& Then
xfirst& = ShellSortS&
End If
End If
Next
xfinish& = Last&
xstart& = xfirst&
LoopCount& = LoopCount& + 1
Loop While LoopCount& < MaxPasses& And (xfinish& - xstart&) >= ShellSortGap&
ShellSortGap& = Int(10 * (ShellSortGap& / 13))
Else
InsertionSort CGSortLibArr(), start&, finish&, order&
Exit Do
End If
Loop
End If
End Select
End Sub
'********************************
'* EfficientMerge, developed from StackOverflow, a horribly short description of the procedure.
'* Uses n/2 auxiliary array for a 50% memory reduction used in merging and similar reduction in
'* time-consuming array copying. Very handly when memory and time is limited.
'* assumes the array passed has already been sorted. Like all other algorithms, this may be
'* used recursively. However for the purpose of MergeSort, it is used as a helper procedure.
'* corrected to use the corresponding EfficientMerge method for both ascending and descending order.
'* provides performance symmetry regardless of sortation order. I will leave MergeRoutine as it is
'* proven stable, even if it is not as fast as EfficientMerge.
'********************************
Sub EfficientMerge (right() As Double, start&, finish&, order&)
half& = start& + (finish& - start&) \ 2
ReDim left(start& To half&) As Double '* hold the first half of the array in left() -- must be the same type as right()
For LoadLeft& = start& To half&
left(LoadLeft&) = right(LoadLeft&)
Next
Select Case order&
Case 1
i& = start&
j& = half& + 1
insert& = start&
Do
If i& > half& Then '* left() exhausted
If j& > finish& Then '* right() exhausted
Exit Do
Else
'* stuff remains in right to be inserted, so flush right()
While j& <= finish&
right(insert&) = right(j&)
j& = j& + 1
insert& = insert& + 1
Wend
Exit Do
'* and exit
End If
Else
If j& > finish& Then
While i& < LoadLeft&
right(insert&) = left(i&)
i& = i& + 1
insert& = insert& + 1
Wend
Exit Do
Else
If right(j&) < left(i&) Then
right(insert&) = right(j&)
j& = j& + 1
Else
right(insert&) = left(i&)
i& = i& + 1
End If
insert& = insert& + 1
End If
End If
Loop
Case Else
i& = start&
j& = half& + 1
insert& = start&
Do
If i& > half& Then '* left() exhausted
If j& > finish& Then '* right() exhausted
Exit Do
Else
'* stuff remains in right to be inserted, so flush right()
While j& <= finish&
right(insert&) = right(j&)
j& = j& + 1
insert& = insert& + 1
Wend
Exit Do
'* and exit
End If
Else
If j& > finish& Then
While i& < LoadLeft&
right(insert&) = left(i&)
i& = i& + 1
insert& = insert& + 1
Wend
Exit Do
Else
If right(j&) > left(i&) Then
right(insert&) = right(j&)
j& = j& + 1
Else
right(insert&) = left(i&)
i& = i& + 1
End If
insert& = insert& + 1
End If
End If
Loop
End Select
Erase left
End Sub
'**********************
'* SelectionSort, another o(n^2) sort. generally used only for very short lists. total comparisons is N(N+1)/2,
'* regardless of the state of sortation, making this only slightly better than bubblesort. This version is stable
'* Both the stable and unstable variants are VERY slow for large N aka (finish-start)
'* [s+][i+]{n^2 ]
'**********************
Sub SelectionSort (CGSortLibArr() As Double, start&, finish&, order&)
Select Case order&
Case 1
For s& = start& To finish& - 1
u& = s&
For t& = s& + 1 To finish&
If CGSortLibArr(t&) < CGSortLibArr(u&) Then
u& = t&
End If
Next
If u& <> s& Then
Swap CGSortLibArr(s&), CGSortLibArr(u&)
End If
Next
Case Else
For s& = start& To finish& - 1
u& = s&
For t& = s& + 1 To finish&
If CGSortLibArr(t&) > CGSortLibArr(u&) Then
u& = t&
End If
Next
If u& <> s& Then
Swap CGSortLibArr(s&), CGSortLibArr(u&)
End If
Next
End Select
End Sub
'*************************
'* On repetitive arrays, SelectionSortUnstable penalizes both slow reads and writes.
'* neither stable nor unstable SelectionSort is recommended. It is not adaptive,
'* performing n(n+1)/2 operations regardless of the state of sortation.
'*************************
'* [s-][i+][n^2 ]
Sub SelectionSortUnstable (CgSortLibArr() As Double, start As Long, finish As Long, order&)
'* these MUST match the numeric type of start and finish
Dim SelectionSortUnstableQ As Long
Dim SelectionSortUnstableR As Long
'*******************************************************
Select Case order&
Case 1
For SelectionSortUnstableQ = start& To finish& - 1
For SelectionSortUnstableR = SelectionSortUnstableQ + 1 To finish&
If CgSortLibArr(SelectionSortUnstableR) < CgSortLibArr(SelectionSortUnstableQ) Then
Swap CgSortLibArr(SelectionSortUnstableR), CgSortLibArr(SelectionSortUnstableQ)
End If
Next
Next
Case Else
For SelectionSortUnstableQ = start& To finish& - 1
For r& = SelectionSortUnstableQ + 1 To finish&
If CgSortLibArr(SelectionSortUnstableR) > CgSortLibArr(SelectionSortUnstableQ) Then
Swap CgSortLibArr(SelectionSortUnstableR), CgSortLibArr(SelectionSortUnstableQ)
End If
Next
Next
End Select
End Sub
'********************
'* are writes to memory or disk time-consuming? this algorithm sorts and minimizes writes
'* complexity class: O(n^2)
'********************
Sub cycleSort (CGSortLibArr() As Double, start&, finish&, order&)
length& = finish& - start&
If length& <= 0 Then Exit Sub
Dim item As Double '* MUST be same size and/or type as CGSortLibArr() element
Dim position As Long
'* DIM writes AS LONG
' scan CGSortLibArr() for cycles to rotate
For cycleStart& = start& To finish& - 1
item = CGSortLibArr(cycleStart&)
'* find where to put the item
position& = cycleStart&
If order& = 1 Then
For i& = cycleStart& + 1 To UBound(CGSortLibArr)
If CGSortLibArr(i&) < item Then position& = position& + 1
Next
Else
For i& = cycleStart& + 1 To UBound(CGSortLibArr)
If CGSortLibArr(i&) > item Then position& = position& + 1
Next
End If
'* If the item is already in its correct position, this is not a cycle
If position& <> cycleStart& Then
'* Otherwise, put the item there or right after any duplicates
While item = CGSortLibArr(position&)
position& = position& + 1
Wend
Swap CGSortLibArr(position&), item
'* writes=writes+1
'rotate the rest of the cycle
While position& <> cycleStart&
'* Find where to put the item
position& = cycleStart&
If order& = 1 Then
For i& = cycleStart& + 1 To UBound(CGSortLibArr)
If CGSortLibArr(i&) < item Then position& = position& + 1
Next
Else
For i& = cycleStart& + 1 To UBound(CGSortLibArr)
If CGSortLibArr(i&) > item Then position& = position& + 1
Next
End If
' Put the item there or right after any duplicates
While item = CGSortLibArr(position&)
position& = position& + 1
Wend
Swap CGSortLibArr(position&), item
'* writes=writes+1
Wend
End If
Next
End Sub
'**********************
'* this is dl shell's sort but modified for faster running time than standard shellsort.
'**********************
Sub shellSortMetzner (CGSortLibArr() As Double, start&, finish&, order&)
Dim b As Double
Select Case order&
Case 1
m& = Metzner&(start&, finish&)
While m& > 0
For j& = start& To finish& - m&
l& = j& + m&
b = CGSortLibArr(l&)
For i& = j& To start& Step -m&
If CGSortLibArr(i&) > b Then
Swap CGSortLibArr(i& + m&), CGSortLibArr(i&)
l& = i&
Else
i& = start&
End If
Next
CGSortLibArr(l&) = b
Next
m& = (m& - 1) \ 3
Wend
Case Else
m& = Metzner&(start&, finish&)
While m& > 0
For j& = start& To finish& - m&
l& = j& + m&
b = CGSortLibArr(l&)
For i& = j& To start& Step -m&
If CGSortLibArr(i&) < b Then
Swap CGSortLibArr(i& + m&), CGSortLibArr(i&)
l& = i&
Else
i& = start&
End If
Next
CGSortLibArr(l&) = b
Next
m& = (m& - 1) \ 3
Wend
End Select
End Sub
Function Metzner& (a&, b&)
x& = (b& - a& + 1) \ 3
s& = 0
Do
If x& < 1 Then
Exit Do
Else
s& = 3 * s& + 1
x& = (x& - 1) \ 3
End If
Loop
Metzner& = s&
End Function
'*********************************
'* generates the Primes() table used by PrimeGapSort()
'* PrimeGapsSort2 uses wheel factoring to find primes.
'* I guess I could have used a Sieve of Eratosthenes too
'* But trial division is fast enough.
'*********************************
Sub PrimeGen (Primes() As Long, MaximumN&, NPrimes&)
Static NeedPrimes%
If NeedPrimes% Or Primes(UBound(Primes)) ^ 2 < MaximumN& Then
Dim addtoskip5(0 To 3) As Long
'* used correctly, this array will eliminate all integers of the form 10k and 10k+5 when added in sequence,
'* resulting in in integers ending in 1,3,7 or 9, saving 20% compute time versus blindly adding 2 each time.
addtoskip5(0) = 2
addtoskip5(1) = 4
addtoskip5(2) = 2
addtoskip5(3) = 2
Primes(0) = 2
s& = 1
r& = 2
p& = 0
NPrimes& = 1
Do
s& = s& + addtoskip5(p&)
p& = (p& + 1) Mod 4
div& = 3
r& = 1
Do
If (s& / div&) < div& Then
'* this is a prime
If NPrimes& > UBound(Primes) Then
ReDim _Preserve Primes(0 To NPrimes&)
End If
Primes(NPrimes&) = s&
NPrimes& = NPrimes& + 1
Exit Do
Else
If s& Mod div& Then
div& = div& + addtoskip5(r&)
r& = (r& + 1) Mod 4
Else
Exit Do
End If
End If
Loop
Loop Until NPrimes& > UBound(Primes) Or s& > MaximumN&
Erase addtoskip5
ReDim _Preserve Primes(0 To NPrimes& - 1) As Long
NeedPrimes% = 0
End If
End Sub
'************************
'* the original invention by CodeGuy.
'* competitive time to MergeSort
'************************
Sub PrimeGapSort (CGSortLibArr() As Double, start&, finish&, order&)
ReDim Primes(0 To (finish& - start& + 1) / Log((finish& - start& + 1))) As Long
PrimeGen Primes(), finish& - start& + 1, Nprimes&
If order& = 1 Then
Gap& = finish& - start&
b& = Nprimes&
Do
t& = Int(727 * (Gap& / 1000))
a& = LBound(Primes)
Do
c& = a& + (b& - a&) \ 2
If Primes(c&) > t& Then
b& = c& - 1
Else
a& = c&
End If
Loop While b& > a& + 1
b& = c& - 1
Gap& = Primes(c&)
For s& = start& To finish& - Gap&
If CGSortLibArr(s&) > CGSortLibArr(s& + Gap&) Then
Swap CGSortLibArr(s&), CGSortLibArr(s& + Gap&)
End If
Next
Loop While c& > 0
Else
Gap& = finish& - start&
b& = Nprimes&
Do
t& = Int(727 * (Gap& / 1000))
a& = LBound(Primes)
Do
c& = a& + (b& - a&) \ 2
If Primes(c&) > t& Then
b& = c& - 1
Else
a& = c&
End If
Loop While b& > a& + 1
b& = c& - 1
Gap& = Primes(c&)
For s& = start& To finish& - Gap&
If CGSortLibArr(s&) < CGSortLibArr(s& + Gap&) Then
Swap CGSortLibArr(s&), CGSortLibArr(s& + Gap&)
End If
Next
Loop While c& > 0
End If
Erase Primes
InsertionSort CGSortLibArr(), start&, finish&, order&
End Sub
'*****************
'* as long as a stable subsorting algorithm is used, PostSort remains stable.
'* Surprisingly as NumPostBins& increases, the speed increases.
'*****************
Sub PostSort (CGSortLibArr() As Double, start&, finish&, order&)
'* surprisngly, PostSort in this variation performs MORE slowly with increasing NumPostBins&.
'* not certain why, but that is the result.
Dim PSMMrec As MinMaxRec
GetMinMaxArray CGSortLibArr(), start&, finish&, PSMMrec
If CGSortLibArr(PSMMrec.min) = CGSortLibArr(PSMMrec.max) Then Exit Sub
NumPostBins& = 7
ps& = 2 * Int((finish& - start& + 1) / (NumPostBins& + 1))
ReDim PostCGSortLibArr(0 To NumPostBins&, 0 To ps&) As Double
ReDim Counts(0 To NumPostBins&) As Long
Range# = CGSortLibArr(PSMMrec.max) - CGSortLibArr(PSMMrec.min)
For s& = start& To finish&
Bin& = NthPlace&(CGSortLibArr(), PSMMrec, 0, NumPostBins&, order&, s&)
If Counts(Bin&) > UBound(PostCGSortLibArr, 2) Then
ReDim _Preserve PostCGSortLibArr(0 To NumPostBins&, 0 To Counts(Bin&)) As Double
End If
PostCGSortLibArr(Bin&, Counts(Bin&)) = CGSortLibArr(s&)
Counts(Bin&) = Counts(Bin&) + 1
Next
TotalInserted& = start&
For a& = 0 To NumPostBins&
If Counts(a&) > 0 Then
lastinsert& = Totalnserted&
For q& = 0 To Counts(a&) - 1
CGSortLibArr(TotalInserted&) = PostCGSortLibArr(a&, q&)
TotalInserted& = TotalInserted& + 1
Next
MergeSortEmerge CGSortLibArr(), lastinsert&, TotalInserted& - 1, order&
End If
Next
Erase PostCGSortLibArr
Erase Counts
End Sub
'******************************************
'* I make no claims this is the fastest overall sort. In some cases, HashLisSort EASILY wins.
'* flashSort struggles with high repetition. HashListSort does not and actually performs better
'* when this is the case.
'* Yes, this is MY invention, by CodeGuy. Faster than FlashSort and relatively simple.
'* It involves an array roughly 25% bigger than the original array,
'* Yes, you read that Correctly, faster than FlashSort, even with a final InsertionSort.
'* Can also be used in place of CountingSort as it keeps track of repetitions (counts > 1).
'* 09 AUG 2017. 8388608 DOUBLE-precision elements sorted in about 10.95s (actually, a bit less),
'* versus 11.80s for FlashSort. 25% faster than FlashSort at N=16777216.
'* designed for arrays with high repetition (integer, or not) with minor, easy changes
'* to data types). HashListSort also outperforms FlashSort and DualPivotQuicksort
'* in this case, beating FlashSort by an (10-15)% margin, sometimes even higher.
'******************************************
Sub HashListSort (CGSortLibArr() As Double, Start As Long, Finish As Long, order&)
If Finish - Start > 15 Then
Dim Mrec As MinMaxRec
GetMinMaxArray CGSortLibArr(), Start, Finish, Mrec
If CGSortLibArr(Mrec.min) = CGSortLibArr(Mrec.max) Then
Exit Sub
End If
Dim HLS_NInserted As Long
Dim HLS_F As Long
Dim HLS_S As Long
Dim HLSDelta As Double
Dim MinValueInArray As Double
Dim HLSHashProbe As Long
HLSDelta = CGSortLibArr(Mrec.max) - CGSortLibArr(Mrec.min)
MinValueInArray = CGSortLibArr(Mrec.min)
HLSHashProbe = primeNumber&(2 * Int(1.25# * (Finish - Start) / 2) - 1)
ReDim HashTable(0 To HLSHashProbe) As Double
ReDim Count(0 To HLSHashProbe) As Long
For HLS_S = Start To Finish
HLS_F = Int(HLSHashProbe * (CGSortLibArr(HLS_S) - MinValueInArray) / HLSDelta)
Do
If HLS_F > HLSHashProbe Then
HLS_F = HLS_F - HLSHashProbe
End If
If HLS_F < 0 Then
HLS_F = HLS_F + HLSHashProbe
End If
If HashTable(HLS_F) = CGSortLibArr(HLS_S) Then
Count(HLS_F) = Count(HLS_F) + 1
Exit Do
Else
If Count(HLS_F) = 0 Then
HashTable(HLS_F) = CGSortLibArr(HLS_S)
Count(HLS_F) = 1
Exit Do
End If
End If
HLS_F = HLS_F + 1
Loop
Next
HLS_NInserted = Start
If order& = 1 Then
For HLS_S = 0 To HLSHashProbe
While Count(HLS_S) > 0
CGSortLibArr(HLS_NInserted) = HashTable(HLS_S)
HLS_NInserted = HLS_NInserted + 1
Count(HLS_S) = Count(HLS_S) - 1
Wend
Next
Else
For HLS_S = HLSHashProbe To 0 Step -1
While Count(HLS_S) > 0
CGSortLibArr(HLS_NInserted) = HashTable(HLS_S)
HLS_NInserted = HLS_NInserted + 1
Count(HLS_S) = Count(HLS_S) - 1
Wend
Next
End If
Erase Count, HashTable
End If
'* use when you KNOW the data is narrow range
'* BubbleSortModified CGSortLibArr(), Start, Finish, order&
'* otherwise, this one is plenty fast for general purpose.
'InsertionSortBinary CGSortLibArr(), Start, Finish, order&
'* InsertionSort wins.
InsertionSort CGSortLibArr(), Start, Finish, order&
End Sub
'*****************
'* It is rumored RadixSort is fast. In some cases, yes. BUT it is stable and for integer-domain numbers, it is quite suitable. It requires auxiliary
'* storage, so it is not an in-place algorithm.
'*****************
Sub RadixSort (CGSortLibArr() As Double, start&, finish&, order&)
ArrayIsInteger CGSortLibArr(), start&, finish&, errindex&, errcon&
If errcon& Then
'* use another stable sort and sort anyway
MergeSortEmerge CGSortLibArr(), start&, finish&, order&
Else
Dim RSMMrec As MinMaxRec
GetMinMaxArray CGSortLibArr(), start&, finish&, RSMMrec
If CGSortLibArr(RSMMrec.min) = CGSortLibArr(RSMMrec.max) Then Exit Sub '* no div0 bombs
delta# = CGSortLibArr(RSMMrec.max) - CGSortLibArr(RSMMrec.min)
Dim pow2 As _Unsigned _Integer64
Dim NtmpN As _Unsigned _Integer64
Dim Int64MaxShift As _Integer64: Int64MaxShift = 2 ^ 64
ReDim ct&(0 To 1)
ReDim RadixCGSortLibArr(0 To 1, finish& - start&) As Double
Select Case order&
Case 1
pow2 = Int64MaxShift
bits& = Len(Int64MaxShift) * 8
Do Until bits& < 0
For i& = start& To finish&
NtmpN = Int64MaxShift * (CGSortLibArr(i&) - CGSortLibArr(RSMMrec.min)) / (delta#)
If NtmpN And pow2 Then
tmpradix% = 1
Else
tmpradix% = 0
End If
RadixCGSortLibArr(tmpradix%, ct&(tmpradix%)) = CGSortLibArr(i&)
ct&(tmpradix%) = ct&(tmpradix%) + 1
Next
c& = start&
For i& = 0 To 1
For j& = 0 To ct&(i&) - 1
CGSortLibArr(c&) = RadixCGSortLibArr(i&, j&)
c& = c& + 1
Next
ct&(i&) = 0
Next
pow2 = pow2 / 2
bits& = bits& - 1
Loop
Case Else
pow2 = 1
For bits& = 0 To 63
For i& = start& To finish&
NtmpN = Int64MaxShift * (CGSortLibArr(i&) - CGSortLibArr(RSMMrec.min)) / (delta#)
If NtmpN And pow2 Then
tmpradix% = 1
Else
tmpradix% = 0
End If
RadixCGSortLibArr(tmpradix%, ct&(tmpradix%)) = CGSortLibArr(i&)
ct&(tmpradix%) = ct&(tmpradix%) + 1
Next
c& = start&
For i& = 0 To 1
For j& = 0 To ct&(i&) - 1
CGSortLibArr(c&) = RadixCGSortLibArr(i&, j&)
c& = c& + 1
Next
ct&(i&) = 0
Next
pow2 = pow2 * 2
Next
End Select
Erase RadixCGSortLibArr, ct&
End If
End Sub
'*****************
'* Used by RadixSort, which requires integer-domain arrays to function properly
'*****************
Sub ArrayIsInteger (CGSortLibArr() As Double, start&, finish&, errorindex&, IsInt&)
IsInt& = 1
errorindex& = start&
For IsIntegerS& = start& To finish&
If CGSortLibArr(IsIntegerS&) Mod 1 Then
errorindex& = IsIntegerS&
IsInt& = 0
Exit Sub
End If
Next
End Sub
'*****************
Sub BatcherOddEvenMergeSort (CGSortLibArr() As Double, Start&, Finish&, order&)
If (Finish& > 1) Then
m& = (Finish& + (Finish& Mod 2)) \ 2
BatcherOddEvenMergeSort CGSortLibArr(), Start&, m&, order&
BatcherOddEvenMergeSort CGSortLibArr(), Start& + m&, m&, order&
BatcheroddEvenMerge CGSortLibArr(), Start&, Finish&, 1, order&
End If
End Sub
Sub BatcheroddEvenMerge (CGSortLibArr() As Double, Start&, Finish&, r&, order&)
m& = r& * 2
If (m& < Finish&) And m& > 0 Then
BatcheroddEvenMerge CGSortLibArr(), Start&, Finish&, m&, order&
BatcheroddEvenMerge CGSortLibArr(), Start& + r&, Finish&, m&, order&
i& = Start& + r&
Do
If i& + m& > Start& + Finish& Then
Exit Do
Else
If order& = 1 Then
If CGSortLibArr(i&) > CGSortLibArr(i& + r&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + r&)
End If
Else
If CGSortLibArr(i&) < CGSortLibArr(i& + r&) Then
Swap CGSortLibArr(i&), CGSortLibArr(i& + r&)
End If
End If
i& = i& + m&
End If
Loop
Else
If order& = 1 Then
If CGSortLibArr(Start&) > CGSortLibArr(Start& + r&) Then
Swap CGSortLibArr(Start&), CGSortLibArr(Start& + r&)
End If
Else
If CGSortLibArr(Start&) < CGSortLibArr(Start& + r&) Then
Swap CGSortLibArr(Start&), CGSortLibArr(Start& + r&)
End If
End If
End If
End Sub
Sub SinglePassShellSort (CGSortLibArr() As Double, start&, finish&, order&)
Gap& = (finish& - start&)
Do
Select Case order&
Case 1
For c& = start& To finish& - Gap&
If CGSortLibArr(c&) > CGSortLibArr(c& + Gap&) Then
Swap CGSortLibArr(c&), CGSortLibArr(c& + Gap&)
End If
Next
Case Else
For c& = start& To finish& - Gap&
If CGSortLibArr(c&) < CGSortLibArr(c& + Gap&) Then
Swap CGSortLibArr(c&), CGSortLibArr(c& + Gap&)
End If
Next
End Select
Gap& = Int(Gap& / 1.247#)
Loop Until Gap& < 1
InsertionSort CGSortLibArr(), start&, finish&, order&
End Sub
'*********************
'* Another one of Kenneth Batcher's cool parallel sorting algorithms, also O(NLogN) classification complexity. I think the actual complexity
'* involves more Logs and such. Batcher Odd-Even MergeSort is also part of the parallel processing arsenal found on GPU-assisted parallel
'* processing algorithms. Donald Knuth speaks highly of it and correctly claims it can sort more items than there are on all the world's
'* computers. Corrected to use dir& = 1 for ascending
'*********************
Sub BitonicSort (CGSortLibArr() As Double, lo&, n&, dir&)
If (n& > 1) Then
m& = n& \ 2
If dir& = -1 Then
BitonicSort CGSortLibArr(), lo&, m&, 1
Else
BitonicSort CGSortLibArr(), lo&, m&, -1
End If
BitonicSort CGSortLibArr(), lo& + m&, n& - m&, dir&
BitonicMerge CGSortLibArr(), lo&, n&, dir&
End If
End Sub
Sub BitonicMerge (CGSortLibArr() As Double, lo&, n&, dir&)
If (n& > 1) Then
m& = greatestPowerOfTwoLessThan&(n&)
For i& = lo& To lo& + n& - m&
BitonicMergeCompare CGSortLibArr(), i&, i& + m&, dir&
Next
BitonicMerge CGSortLibArr(), lo&, m&, dir&
BitonicMerge CGSortLibArr(), lo& + m&, n& - m&, dir&
End If
End Sub
Sub BitonicMergeCompare (CGSortLibArr() As Double, i&, j&, dir&)
If (dir& = Sgn(CGSortLibArr(i&) - CGSortLibArr(j&))) Then
Swap CGSortLibArr(i&), CGSortLibArr(j&)
End If
End Sub
Function greatestPowerOfTwoLessThan& (n&)
k& = 1
While (k& < n&)
k& = k& * 2
Wend
greatestPowerOfTwoLessThan& = k& / 2
End Function
'***********************
'* Kth order statistic for CGSortLibArr()
'* this algorithm also modifies the passed array
'**********************
Sub QuickSelectRecursive (CGSortLibArr() As Double, start&, finish&, statistic&)
Dim PivotIndex As Long
PivotIndex = QSelectPartitionArray&(CGSortLibArr(), start&, finish&)
Select Case PivotIndex&
Case Is < statistic&
QuickSelectRecursive CGSortLibArr(), PivotIndex&, finish&, statistic&
Case Is > statistic&
QuickSelectRecursive CGSortLibArr(), start&, PivotIndex&, statistic&
Case Else
Exit Sub
End Select
End Sub
Function QSelectPartitionArray& (CGSortLibArr() As Double, start&, finish&)
'* this declaration of pivot MUST be the same type as CGSortLibArr()
Dim pivot As Double
pivotIndex& = start& + Rnd * (finish& - start&)
pivot = CGSortLibArr(pivotIndex&)
'* and a familiar shuffle routine reminiscent of QuickSort
Swap CGSortLibArr(pivotIndex&), CGSortLibArr(finish&)
pivotIndex& = start&
For i& = start& To finish&
If CGSortLibArr(i&) < pivot Then
Swap CGSortLibArr(i&), CGSortLibArr(pivotIndex&)
pivotIndex& = pivotIndex& + 1
End If
Next
Swap CGSortLibArr(pivotIndex&), CGSortLibArr(finish&)
QSelectPartitionArray& = pivotIndex&
End Function
Sub QuickselectIterative (CGSortLibArr() As Double, start&, finish&, k&)
LStart& = start&
LFinish& = finish&
Dim pivotindex As Long
pivotindex = QSelectPartitionArray&(CGSortLibArr(), LStart&, LFinish&)
While (pivotindex <> k&)
pivotindex& = QSelectPartitionArray&(CGSortLibArr(), LStart&, LFinish&)
If (pivotindex& < k&) Then
LStart& = pivotindex
ElseIf (pivotindex > kK) Then
LFinish& = pivotindex
End If
Wend
End Sub
'* adapted for use with qb64. This method is roughly 20 percent more efficient than the standard vector scan algorithm for min/max
'* Roughly 6.19s versus 7.93 for n=134217728 (0 counts as 1, of course)
'* This may be a nice addition for perhaps _CGArrayMax() in qb64. Of course, I am not so vain as to insist about the CG part.
'* simply meant as a faster tool for a common array problem to be solved. Also adaptable to string types.
'* returns indexes instead of TYPE structure (not used in this library, but pretty much same as GetminMaxCGSortLibArr().
Sub ArrayGetMinMax (CGSortLibArr() As Double, start&, finish&, ArrayMinIndex&, ArrayMaxIndex&)
n& = finish& - start&
If (n& Mod 2) Then
ArrayMinIndex& = start&
ArrayMaxIndex& = start&
i& = 1
Else
If CGSortLibArr(start&) > CGSortLibArr(finish&) Then
ArrayMaxIndex& = start&
ArrayMinIndex& = start& + 1
Else
ArrayMinIndex& = start&
ArrayMaxIndex& = start& + 1
End If
i& = 2
End If
While (i& < finish&)
If (CGSortLibArr(i&) > CGSortLibArr(i& + 1)) Then
If CGSortLibArr(i&) > CGSortLibArr(ArrayMaxIndex&) Then
ArrayMaxIndex& = i&
End If
If CGSortLibArr(i& + 1) < CGSortLibArr(ArrayMinIndex&) Then
ArrayMinIndex& = i& + 1
End If
Else
If CGSortLibArr(i& + 1) > CGSortLibArr(ArrayMaxIndex&) Then
ArrayMaxIndex& = i& + 1
End If
If CGSortLibArr(i&) < CGSortLibArr(ArrayMinIndex&) Then
ArrayMinIndex& = i&
End If
End If
i& = i& + 2
Wend
End Sub
'******************
'* yields the pointer to an array element whose frequency of occurrence is greatest
'******************
Function Mode& (CGSortLibArr() As Double, start&, finish&, frequency&)
FlashSort CGSortLibArr(), start&, finish&, 1
m& = 0
frequency& = 0
S& = start&
Do
R& = S&
q& = R&
Do
If R& < finish& Then
S& = S& + 1
If CGSortLibArr(R&) = CGSortLibArr(S&) Then
Else
Exit Do
End If
Else
Exit Do
End If
Loop
If q& - R& > m& Then
m& = q& - R&
modetemp& = R&
End If
Loop
frequency& = m& + 1
Mode& = modetemp&
End Function
Function ArrayMedian# (CGSortLibArr() As Double, start&, finish&)
FlashSort CGSortLibArr(), start&, finish&, 1
If (finish& - start&) Mod 2 Then
'* There's an even number of elements in this subset -- think about it
'* then then median is calculated by the average of these 2 elements
p0& = IndexCenter&(start&, finish&)
p1& = p& + 1
ArrayMedian# = (CGSortLibArr(p0&) + CGSortLibArr(p1&)) / 2
Else
'* there's an odd number of elements in this subset, so the ArrayMedian is the start+(finish-start-1)/2 element
ArrayMedian# = CGSortLibArr(IndexCenter&(start&, finish&))
End If
End Function
Function IndexCenter& (start&, finish&)
If start& <> finish& Then
t& = (finish& - start&) Mod 2
If t& Mod 2 Then
'* if it's even, such as 1,5
'* it will be calculated as start&+(finish&-start&)/2
IndexCenter& = start& + (finish& - start&) / 2
Else
'* otherwise, it will be calulated as start&+(finish&-start&-1)/2
IndexCenter& = start& + (finish& - start& - 1) / 2
End If
Else
IndexCenter& = start&
End If
End Function
Sub SnakeSort (CGSortLibArr() As Double, start&, finish&, order&)
'* these MUST be the same type as start& and finish&
'***************************
Dim i As Long
Dim L_MinInt As Long
Dim L_MaxInt As Long
Dim L_Index As Long
Dim L_Level As Long
Dim L_OldLevel As Long
Dim L_NewLevel As Long
Dim L_Direction As Long
'***************************
'*
Dim blnMirror As Integer
'* these MUST be the same type as the array elements being sorted
'****************************
Dim varSwap As Double
Dim ArrayAuxiliary As Double
'****************************
L_MinInt = start&
L_MaxInt = finish&
ReDim L_Index((L_MaxInt - L_MinInt + 3) \ 2)
L_Index(0) = L_MinInt
i = L_MinInt
' Initial loop: locate cutoffs for each ordered section
Do Until i >= L_MaxInt
Select Case L_Direction
Case 1
Do Until i = L_MaxInt
If CGSortLibArr(i) > CGSortLibArr(i + 1) Then Exit Do
i = i + 1
Loop
Case -1
Do Until i = L_MaxInt
If CGSortLibArr(i) < CGSortLibArr(i + 1) Then Exit Do
i = i + 1
Loop
Case Else
Do Until i = L_MaxInt
If CGSortLibArr(i) <> CGSortLibArr(i + 1) Then Exit Do
i = i + 1
Loop
If i = L_MaxInt Then L_Direction = 1
End Select
If L_Direction = 0 Then
If CGSortLibArr(i) > CGSortLibArr(i + 1) Then
L_Direction = -1
Else
L_Direction = 1
End If
Else
L_Level = L_Level + 1
L_Index(L_Level) = i * L_Direction
L_Direction = 0
End If
i = i + 1
Loop
If Abs(L_Index(L_Level)) < L_MaxInt Then
If L_Direction = 0 Then L_Direction = 1
L_Level = L_Level + 1
L_Index(L_Level) = i * L_Direction
End If
' If the list is already sorted, exit
If L_Level <= 1 Then
' If sorted descending, reverse before exiting
If L_Index(L_Level) < 0 Then
For i = 0 To (L_MaxInt - L_MinInt) \ 2
Swap CGSortLibArr(L_MinInt + i), CGSortLibArr(L_MaxInt - i)
'* varSwap = CGSortLibArr(L_MinInt + i)
'* CGSortLibArr(L_MinInt + i) = CGSortLibArr(L_MaxInt - i)
'* CGSortLibArr(L_MaxInt - i) = varSwap
Next
End If
Exit Sub
End If
'* Main loop - merge section pairs together until only one section left
ReDim ArrayAuxiliary(L_MinInt To L_MaxInt) As Double '* must be same type as CGSortLibArr()
Do Until L_Level = 1
L_OldLevel = L_Level
For L_Level = 1 To L_Level - 1 Step 2
If blnMirror Then
SnakeSortMerge ArrayAuxiliary(), L_Index(L_Level - 1), L_Index(L_Level), L_Index(L_Level + 1), CGSortLibArr(), order&
Else
SnakeSortMerge CGSortLibArr(), L_Index(L_Level - 1), L_Index(L_Level), L_Index(L_Level + 1), ArrayAuxiliary(), order&
End If
L_NewLevel = L_NewLevel + 1
L_Index(L_NewLevel) = Abs(L_Index(L_Level + 1))
Next
If L_OldLevel Mod 2 = 1 Then
If blnMirror Then
For i = L_Index(L_NewLevel) + 1 To L_MaxInt
CGSortLibArr(i) = ArrayAuxiliary(i)
Next
Else
For i = L_Index(L_NewLevel) + 1 To L_MaxInt
ArrayAuxiliary(i) = CGSortLibArr(i)
Next
End If
L_NewLevel = L_NewLevel + 1
L_Index(L_NewLevel) = L_Index(L_OldLevel)
End If
L_Level = L_NewLevel
L_NewLevel = 0
blnMirror = Not blnMirror
Loop
'* Copy ArrayAuxiliary to CGSortLibArr() if necessary
If blnMirror Then
If order& = 1 Then
For i = L_MinInt To L_MaxInt
CGSortLibArr(i) = ArrayAuxiliary(i)
Next
Else
For i = L_MaxInt To L_MinInt Step -1
CGSortLibArr(i) = ArrayAuxiliary(i)
Next
End If
Erase ArrayAuxiliary
Exit Sub
Else
If order& = 1 Then
Exit Sub
Else
While L_MinInt < L_MaxInt
Swap CGSortLibArr(L_MinInt), CGSortLibArr(L_MaxInt)
L_MinInt = L_MinInt + 1
L_MaxInt = L_MaxInt - 1
Wend
End If
End If
End Sub
Sub SnakeSortMerge (ArraySource() As Double, pL_Left As Long, pL_Mid As Long, pL_Right As Long, ArrayAuxiliary() As Double, order&)
Dim L_LeftPtr As Long
Dim L_LMin As Long
Dim LMax As Long
Dim LStep As Long
Dim L_RightPtr As Long
Dim L_RMin As Long
Dim RMax As Long
Dim RStep As Long
Dim OutCount As Long: OutCount = 0 '* Do not assume OutCount is set to 0
If pL_Left <> 0 Then OutCount = Abs(pL_Left) + 1
If pL_Mid > 0 Then
L_LMin = OutCount
LMax = Abs(pL_Mid)
LStep = 1
Else
L_LMin = Abs(pL_Mid)
LMax = OutCount
LStep = -1
End If
If pL_Right > 0 Then
L_RMin = Abs(pL_Mid) + 1
RMax = Abs(pL_Right)
RStep = 1
Else
L_RMin = Abs(pL_Right)
RMax = Abs(pL_Mid) + 1
RStep = -1
End If
L_LeftPtr = L_LMin
L_RightPtr = L_RMin
Do
If L_LeftPtr < pL_Left Or L_LeftPtr >= LMax Then
Exit Do
End If
If L_RightPtr > pL_Right Or L_RightPtr >= RMax Then
Exit Do
End If
If ArraySource(L_LeftPtr) <= ArraySource(L_RightPtr) Then
ArrayAuxiliary(OutCount) = ArraySource(L_LeftPtr)
If L_LeftPtr = LMax Then
For L_RightPtr = L_RightPtr To RMax Step RStep
OutCount = OutCount + 1
ArrayAuxiliary(OutCount) = ArraySource(L_RightPtr)
Next
Exit Do
End If
L_LeftPtr = L_LeftPtr + LStep
Else
ArrayAuxiliary(OutCount) = ArraySource(L_RightPtr)
If L_RightPtr = RMax Then
For L_LeftPtr = L_LeftPtr To LMax Step LStep
OutCount = OutCount + 1
ArrayAuxiliary(OutCount) = ArraySource(L_LeftPtr)
Next
Exit Do
End If
L_RightPtr = L_RightPtr + RStep
End If
OutCount = OutCount + 1
Loop
End Sub
'******************************
'* from: http://www.vbforums.com/attachment.php?attachmentid=64242&d=1211306594
'* not really fast, but included because it works reasonably.
'******************************
Sub JoinSort (CGSortLibArr() As Double, start&, finish&, order&)
Dim i As Long
Dim L_MinInt As Long
Dim L_MaxInt As Long
Dim j As Long
Dim jFirst As Long
Dim jLast As Long
Dim JStep As Long
Dim k As Long
Dim kFirst As Long
Dim kLast As Long
Dim kStep As Long
Dim O As Long
Dim L_Swap As Long
Dim L_Left As Long
Dim L_Right As Long
Dim ArrayAuxiliary As Double
Dim varSwap As Double
L_MinInt = start&
L_MaxInt = finish&
ReDim ArrayAuxiliary(L_MinInt To L_MaxInt)
Do
For i = L_MinInt To L_MaxInt
jFirst = i
JStep = 0
For jLast = i To L_MaxInt - 1
If CGSortLibArr(jLast) < CGSortLibArr(jLast + 1) Then
If JStep = -1 Then Exit For Else JStep = 1
ElseIf CGSortLibArr(jLast) > CGSortLibArr(jLast + 1) Then
If JStep = 1 Then Exit For Else JStep = -1
End If
Next
L_Left = jFirst
kFirst = jLast + 1
If jLast = L_MaxInt Then
If JStep = -1 Then
For j = 0 To (jLast - jFirst) \ 2
Swap CGSortLibArr(jFirst + j), CGSortLibArr(jLast - j)
'* varSwap = CGSortLibArr(jFirst + j)
'* CGSortLibArr(jFirst + j) = CGSortLibArr(jLast - j)
'* CGSortLibArr(jLast - j) = varSwap
Next
End If
L_Right = jLast
Exit For
End If
Select Case JStep
Case -1
L_Swap = jFirst
jFirst = jLast
jLast = L_Swap
Case 0
JStep = 1
End Select
kStep = 0
For kLast = kFirst To L_MaxInt - 1
If CGSortLibArr(kLast) < CGSortLibArr(kLast + 1) Then
If kStep = -1 Then Exit For Else kStep = 1
ElseIf CGSortLibArr(kLast) > CGSortLibArr(kLast + 1) Then
If kStep = 1 Then Exit For Else kStep = -1
End If
Next
L_Right = kLast
Select Case kStep
Case -1
L_Swap = kFirst
kFirst = kLast
kLast = L_Swap
Case 0
kStep = 1
End Select
O = L_Left
j = jFirst
k = kFirst
Do
If CGSortLibArr(j) < CGSortLibArr(k) Then
ArrayAuxiliary(O) = CGSortLibArr(j)
If j = jLast Then
For k = k To kLast Step kStep
O = O + 1
ArrayAuxiliary(O) = CGSortLibArr(k)
Next
Exit Do
End If
j = j + JStep
Else
ArrayAuxiliary(O) = CGSortLibArr(k)
If k = kLast Then
For j = j To jLast Step JStep
O = O + 1
ArrayAuxiliary(O) = CGSortLibArr(j)
Next
Exit Do
End If
k = k + kStep
End If
O = O + 1
Loop
For O = L_Left To L_Right
CGSortLibArr(O) = ArrayAuxiliary(O)
Next
i = L_Right
Next
Loop Until L_Left = L_MinInt And L_Right = L_MaxInt
Erase ArrayAuxiliary
If order& = -1 Then
L_MinInt = start&
L_MaxInt = finish&
While L_MinInt < L_MaxInt
Swap CGSortLibArr(L_MinInt), CGSortLibArr(L_MaxInt)
L_MinInt = L_MinInt + 1
L_MaxInt = L_MaxInt - 1
Wend
End If
End Sub
Sub QSortRecursiveSimplified (CGSortLibArr() As Double, start&, finish&, order&)
If (start& >= finish&) Then Exit Sub
Dim PartitionVal As Double
Dim QSRi As Long
Dim QSRj As Long
QSRi = start&
QSRj = finish&
PartitionVal = CGSortLibArr(start& + Int(Rnd * (finish& - start&)))
Select Case order&
Case 1
Do
While (CGSortLibArr(QSRi) < PartitionVal)
QSRi = QSRi + 1
Wend
While (CGSortLibArr(QSRj) > PartitionVal)
QSRj = QSRj - 1
Wend
If QSRi <= QSRj Then
Swap CGSortLibArr(QSRi), CGSortLibArr(QSRj)
QSRi = QSRi + 1
QSRj = QSRj - 1
End If
Loop Until QSRi > QSRj
Case Else
Do
While (CGSortLibArr(QSRi) > PartitionVal)
QSRi = QSRi + 1
Wend
While (CGSortLibArr(QSRj) < PartitionVal)
QSRj = QSRj - 1
Wend
If QSRi <= QSRj Then
Swap CGSortLibArr(QSRi), CGSortLibArr(QSRj)
QSRi = QSRi + 1
QSRj = QSRj - 1
End If
Loop Until QSRi > QSRj
End Select
QSortRecursiveSimplified CGSortLibArr(), start&, QSRj, order&
QSortRecursiveSimplified CGSortLibArr(), QSRi, finish&, order&
End Sub
'********************
'* Djikstra SmoothSort converted from VB 2018Feb20 by CodeGuy
'* There is no BYVAL, in QB64, so I did a workaround
'*************************
Sub SmoothSort_TypedArray (TypedCGSortLibArr() As DataElement, order&)
Dim lngOneBasedIndex As Long
Dim lngNodeIndex As Long
Dim lngLeftRightTreeAddress As Long
Dim lngSubTreeSize As Long
Dim lngLeftSubTreeSize As Long
lngLeftRightTreeAddress = 1
lngSubTreeSize = 1
lngLeftSubTreeSize = 1
lngOneBasedIndex = 1
lngNodeIndex = 0
Do While lngOneBasedIndex <> UBound(TypedCGSortLibArr) + 1
If lngLeftRightTreeAddress Mod 8 = 3 Then
SmoothSift_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = (lngLeftRightTreeAddress + 1) \ 4
SmoothUp_TypedArray lngSubTreeSize, lngLeftSubTreeSize
SmoothUp_TypedArray lngSubTreeSize, lngLeftSubTreeSize
ElseIf lngLeftRightTreeAddress Mod 4 = 1 Then 'This is always true if it gets here
If lngOneBasedIndex + lngLeftSubTreeSize < UBound(TypedCGSortLibArr) + 1 Then
SmoothSift_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngSubTreeSize, lngLeftSubTreeSize
Else
SmoothTrinkle_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngLeftRightTreeAddress, lngSubTreeSize, lngLeftSubTreeSize
End If
Do
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = lngLeftRightTreeAddress * 2
Loop While lngSubTreeSize <> 1 'Continue until we reach the bottom of the tree
lngLeftRightTreeAddress = lngLeftRightTreeAddress + 1
End If
lngOneBasedIndex = lngOneBasedIndex + 1
lngNodeIndex = lngNodeIndex + 1
Loop
SmoothTrinkle_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngLeftRightTreeAddress, lngSubTreeSize, lngLeftSubTreeSize
Do While lngOneBasedIndex <> 1
lngOneBasedIndex = lngOneBasedIndex - 1
If lngSubTreeSize = 1 Then
lngNodeIndex = lngNodeIndex - 1
lngLeftRightTreeAddress = lngLeftRightTreeAddress - 1
Do While lngLeftRightTreeAddress Mod 2 = 0
lngLeftRightTreeAddress = lngLeftRightTreeAddress / 2
SmoothUp_TypedArray lngSubTreeSize, lngLeftSubTreeSize
Loop
ElseIf lngSubTreeSize >= 3 Then 'It must fall in here, sub trees are either size 1,1,3,5,9,15 etc
lngLeftRightTreeAddress = lngLeftRightTreeAddress - 1
lngNodeIndex = lngNodeIndex + lngLeftSubTreeSize - lngSubTreeSize
If lngLeftRightTreeAddress <> 0 Then
SmoothSemiTrinkle_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngLeftRightTreeAddress, lngSubTreeSize, lngLeftSubTreeSize
End If
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = lngLeftRightTreeAddress * 2 + 1
lngNodeIndex = lngNodeIndex + lngLeftSubTreeSize
SmoothSemiTrinkle_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngLeftRightTreeAddress, lngSubTreeSize, lngLeftSubTreeSize
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = lngLeftRightTreeAddress * 2 + 1
End If
Loop
Restabilize_TypedArray TypedCGSortLibArr(), order&
End Sub
Sub SmoothUp_TypedArray (lngSubTreeSize As Long, lngLeftSubTreeSize As Long)
Dim sutemp As Long
sutemp = lngSubTreeSize + lngLeftSubTreeSize + 1
lngLeftSubTreeSize = lngSubTreeSize
lngSubTreeSize = sutemp
End Sub
Sub SmoothDown_TypedArray (lngSubTreeSize As Long, lngLeftSubTreeSize As Long)
Dim sdtemp As Long
sdtemp = lngSubTreeSize - lngLeftSubTreeSize - 1
lngSubTreeSize = lngLeftSubTreeSize
lngLeftSubTreeSize = sdtemp
End Sub
Sub SmoothSift_TypedArray (TypedCGSortLibArr() As DataElement, NodeIndex As Long, SubTreeSize As Long, LeftSubTreeSize As Long)
Dim lngNodeIndex As Long: lngNodeIndex = NodeIndex
Dim lngSubTreeSize As Long: lngSubTreeSize = SubTreeSize
Dim lngLeftSubTreeSize As Long: lngLeftSubTreeSize = LeftSubTreeSize
Dim lngChildIndex As Long
Do While lngSubTreeSize >= 3
lngChildIndex = lngNodeIndex - lngSubTreeSize + lngLeftSubTreeSize
If TypedCGSortLibArr(lngChildIndex).thekey < TypedCGSortLibArr(lngNodeIndex - 1).thekey Then
lngChildIndex = lngNodeIndex - 1
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
End If
If TypedCGSortLibArr(lngNodeIndex).thekey >= TypedCGSortLibArr(lngChildIndex).thekey Then
lngSubTreeSize = 1
Else
Exchange_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngChildIndex
lngNodeIndex = lngChildIndex
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
End If
Loop
End Sub
Sub SmoothTrinkle_TypedArray (TypedCGSortLibArr() As DataElement, NodeIndex As Long, LeftRightTreeAddress As Long, SubTreeSize As Long, LeftSubTreeSize As Long)
Dim lngNodeIndex As Long: lngNodeIndex = NodeIndex
Dim lngLeftRightTreeAddress As Long: lngLeftRightTreeAddress = LeftRightTreeAddress
Dim lngSubTreeSize As Long: lngSubTreeSize = SubTreeSize
Dim lngLeftSubTreeSize As Long: lngLeftSubTreeSize = LeftSubTreeSize
Dim lngChildIndex As Long
Dim lngPreviousCompleteTreeIndex As Long
Do While lngLeftRightTreeAddress > 0
Do While lngLeftRightTreeAddress Mod 2 = 0
lngLeftRightTreeAddress = lngLeftRightTreeAddress \ 2
SmoothUp_TypedArray lngSubTreeSize, lngLeftSubTreeSize
Loop
lngPreviousCompleteTreeIndex = lngNodeIndex - lngSubTreeSize
If lngLeftRightTreeAddress = 1 Then
lngLeftRightTreeAddress = 0
ElseIf TypedCGSortLibArr(lngPreviousCompleteTreeIndex).thekey <= TypedCGSortLibArr(lngNodeIndex).thekey Then
lngLeftRightTreeAddress = 0
Else
lngLeftRightTreeAddress = lngLeftRightTreeAddress - 1
If lngSubTreeSize = 1 Then
Exchange_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngPreviousCompleteTreeIndex
lngNodeIndex = lngPreviousCompleteTreeIndex
ElseIf lngSubTreeSize >= 3 Then
lngChildIndex = lngNodeIndex - lngSubTreeSize + lngLeftSubTreeSize
If TypedCGSortLibArr(lngChildIndex).thekey < TypedCGSortLibArr(lngNodeIndex - 1).thekey Then
lngChildIndex = lngNodeIndex - 1
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = lngLeftRightTreeAddress * 2
End If
If TypedCGSortLibArr(lngPreviousCompleteTreeIndex).thekey >= TypedCGSortLibArr(lngChildIndex).thekey Then
Exchange_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngPreviousCompleteTreeIndex
lngNodeIndex = lngPreviousCompleteTreeIndex
Else
Exchange_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngChildIndex
lngNodeIndex = lngChildIndex
SmoothDown_TypedArray lngSubTreeSize, lngLeftSubTreeSize
lngLeftRightTreeAddress = 0
End If
End If
End If
Loop
SmoothSift_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngSubTreeSize, lngLeftSubTreeSize
End Sub
Sub SmoothSemiTrinkle_TypedArray (TypedCGSortLibArr() As DataElement, NodeIndex As Long, LeftRightTreeAddress As Long, SubTreeSize As Long, LeftSubTreeSize As Long)
Dim lngNodeIndex As Long: lngNodeIndex = NodeIndex
Dim lngLeftRightTreeAddress As Long: lngLeftRightTreeAddress = LeftRightTreeAddress
Dim lngSubTreeSize As Long: lngSubTreeSize = SubTreeSize
Dim lngLeftSubTreeSize As Long: lngLeftSubTreeSize = LeftSubTreeSize
Dim lngIndexTopPreviousCompleteHeap As Long
lngIndexTopPreviousCompleteHeap = lngNodeIndex - lngLeftSubTreeSize
If TypedCGSortLibArr(lngIndexTopPreviousCompleteHeap).thekey > TypedCGSortLibArr(lngNodeIndex).thekey Then
Exchange_TypedArray TypedCGSortLibArr(), lngNodeIndex, lngIndexTopPreviousCompleteHeap
SmoothTrinkle_TypedArray TypedCGSortLibArr(), lngIndexTopPreviousCompleteHeap, lngLeftRightTreeAddress, lngSubTreeSize, lngLeftSubTreeSize
End If
End Sub
Sub Exchange_TypedArray (TypedCGSortLibArr() As DataElement, plng1 As Long, plng2 As Long)
If TypedCGSortLibArr(plng1).thekey <> TypedCGSortLibArr(plng2).thekey Then
Swap TypedCGSortLibArr(plng1), TypedCGSortLibArr(plng2)
Else
If TypedCGSortLibArr(plng1).originalorder > TypedCGSortLibArr(plng2).originalorder Then
Swap TypedCGSortLibArr(plng1), TypedCGSortLibArr(plng2)
End If
End If
End Sub
Sub Restabilize_TypedArray (TypedCGSortLibArr() As DataElement, order&)
If order& = 1 Then
Else
Rsa& = LBound(TypedCGSortLibArr)
Rsb& = UBound(TypedCGSortLibArr)
While Rsa& < Rsb&
If TypedCGSortLibArr(Rsa&).thekey <> TypedCGSortLibArr(Rsb&).thekey Then
Swap TypedCGSortLibArr(Rsa&), TypedCGSortLibArr(Rsb&)
End If
Rsa& = Rsa& + 1
Rsb& = Rsb& - 1
Wend
End If
q& = LBound(TypedCGSortLibArr)
Do
r& = q& + 1
Do
If r& > UBound(TypedCGSortLibArr) Then
Exit Sub
Else
If TypedCGSortLibArr(q&).thekey = TypedCGSortLibArr(r&).thekey Then
r& = r& + 1
Else
Exit Do
End If
End If
Loop
z& = r&
If r& - q& > 1 Then
Do
p& = r& - 1
If p& > q& Then
r& = p& - 1
If TypedCGSortLibArr(r&).originalorder > TypedCGSortLibArr(p&).originalorder Then
Swap TypedCGSortLibArr(r&), TypedCGSortLibArr(p&)
Else
Exit Do
End If
Else
Exit Do
End If
r& = p&
Loop
End If
q& = z&
Loop Until q& > UBound(TypedCGSortLibArr)
End Sub
'*********************************
'* TESTED -- WORKS
'* This is the iterative version of QuickSort, using a software stack, useful for OLD processors lacking hardware registers
'* supporting recursion. Operationally, it is very much the same as the recursive version except the "stack" is software-based.
'* Similar performance to recursive quicksort. Uses Median-of-Three partition method, randomly selected pivot between low and high.
'**********************************
Sub QuickSortIterativeMedianOf3 (CGSortLibArr() As Double, Start&, Finish&, order&)
Dim compare As Double
MinStack& = 2 * Log(Finish& - Start& + 1) \ Log(2) + 1
Dim LStack&(MinStack&, 1)
StackPtr& = 0
LStack&(StackPtr&, 0) = Start&
LStack&(StackPtr&, 1) = Finish&
Do
Low& = LStack&(StackPtr&, 0)
Hi& = LStack&(StackPtr&, 1)
Do
i& = Low&
j& = Hi&
'* one more tactic to help defeat O(n^2) worst-case performance
'* pick a RANDOM pivot. Use of fixed pivot 1/2 distance from Low&+(hi&-low&)\2 MAY result in infinite loop
If Hi& - Low& >= 2 Then
MedianOfThree CGSortLibArr(), Low&, Low& + (Hi& - Low&) \ 2, High&, MedianIndex&
compare = CGSortLibArr(MedianIndex&)
Else
compare = CGSortLibArr(Low& + (Hi& - Low&) \ 2)
End If
Select Case order&
Case 1
Do
Do While CGSortLibArr(i&) < compare
i& = i& + 1
Loop
Do While CGSortLibArr(j&) > compare
j& = j& - 1
Loop
If i& <= j& Then
Swap CGSortLibArr(i&), CGSortLibArr(j&)
i& = i& + 1
j& = j& - 1
End If
Loop Until i& > j&
Case Else
Do
Do While CGSortLibArr(i&) > compare
i& = i& + 1
Loop
Do While CGSortLibArr(j&) < compare
j& = j& - 1
Loop
If i& <= j& Then
Swap CGSortLibArr(i&), CGSortLibArr(j&)
i& = i& + 1
j& = j& - 1
End If
Loop Until i& > j&
End Select
If j& - Low& < Hi& - i& Then
If i& < Hi& Then
LStack&(StackPtr&, 0) = i&
LStack&(StackPtr&, 1) = Hi&
StackPtr& = StackPtr& + 1
End If
Hi& = j&
Else
If Low& < j& Then
LStack&(StackPtr&, 0) = Low&
LStack&(StackPtr&, 1) = j&
StackPtr& = StackPtr& + 1
End If
Low& = i&
End If
Loop While Low& < Hi&
StackPtr& = StackPtr& - 1
Loop Until StackPtr& < 0
End Sub
'* For QuickSort using the median of three partitioning method. Used to defeat "QuickSort Killer" arrays.
Sub MedianOfThree (CGSortLibArr() As Double, MotA As Long, MotB As Long, MotC As Long, MedianIndex As Long)
If CGSortLibArr(MotA) > CGSortLibArr(MotB) Then
If CGSortLibArr(MotA) < CGSortLibArr(MotC) Then
MedianIndex = MotA
ElseIf CGSortLibArr(MotB) > CGSortLibArr(MotC) Then
MedianIndex = MotB
Else
MedianIndex = MotC
End If
Else
If CGSortLibArr(MotA) > CGSortLibArr(MotC) Then
MedianIndex = MotA
ElseIf CGSortLibArr(MotB) < CGSortLibArr(MotC) Then
MedianIndex = MotB
Else
MedianIndex = MotC
End If
End If
End Sub
'************************************************
'* This version of BubbleSort actually performs BETTER than InsertionSort for low entropy,
'* roughly twice as fast as standard BubbleSort.
'************************************************
Sub BubbleSortModified (CGSortLibArr() As Double, start&, finish&, order&)
Dim BubbleSortModified_a As Long
Dim BubbleSortModified_b As Long
Dim BubbleSortModified_x As Long
Dim BubbleSortModified_SwapFirst As Long
Dim BubbleSortModified_SwapLast As Long
Dim BubbleSortModified_s As Integer
Select Case order&
Case 1
Do
BubbleSortModified_s = -1
BubbleSortModified_a = start&
BubbleSortModified_b = finish&
Do
BubbleSortModified_SwapFirst = BubbleSortModified_a
BubbleSortModified_SwapLast = BubbleSortModified_b - 1
For BubbleSortModified_x = BubbleSortModified_SwapFirst To BubbleSortModified_SwapLast
If CGSortLibArr(BubbleSortModified_x) > CGSortLibArr(BubbleSortModified_x + 1) Then
Swap CGSortLibArr(BubbleSortModified_x), CGSortLibArr(BubbleSortModified_x + 1)
If BubbleSortModified_x < BubbleSortModified_b Then
BubbleSortModified_b = BubbleSortModified_x
Else
BubbleSortModified_a = BubbleSortModified_x
End If
BubbleSortModified_s = 0
End If
Next
Swap BubbleSortModified_a, BubbleSortModified_b
Loop While BubbleSortModified_a < BubbleSortModified_b
Loop Until BubbleSortModified_s
Case Else
Do
BubbleSortModified_s = -1
BubbleSortModified_a = start&
BubbleSortModified_b = finish&
Do
BubbleSortModified_SwapFirst = BubbleSortModified_a
BubbleSortModified_SwapLast = BubbleSortModified_b - 1
For BubbleSortModified_x = BubbleSortModified_SwapFirst To BubbleSortModified_SwapLast
If CGSortLibArr(BubbleSortModified_x) < CGSortLibArr(BubbleSortModified_x + 1) Then
Swap CGSortLibArr(BubbleSortModified_x), CGSortLibArr(BubbleSortModified_x + 1)
If BubbleSortModified_x < BubbleSortModified_b Then
BubbleSortModified_b = BubbleSortModified_x
Else
BubbleSortModified_a = BubbleSortModified_x
End If
BubbleSortModified_s = 0
End If
Next
Swap BubbleSortModified_a, BubbleSortModified_b
Loop While BubbleSortModified_a < BubbleSortModified_b
Loop Until BubbleSortModified_s
End Select
End Sub
'*****************************
'* MergeEfficient is essentially MergeSort, except it uses the EfficientMerge routine requiring only half the auxiliary.
'* Just here for comparison against the standard MergeSort. Yes, it is faster because there is less array copying.
'*******************************
Sub MergeSortEfficient (CGSortLibArr() As Double, start As Long, finish As Long, order&)
If start < finish Then
Dim MergeEfficientMiddle As Long
MergeEfficientMiddle = start + (finish - start) \ 2
MergeSortEfficient CGSortLibArr(), start, MergeEfficientMiddle, order&
MergeSortEfficient CGSortLibArr(), MergeEfficientMiddle + 1, finish, order&
EfficientMerge CGSortLibArr(), start, finish, order&
End If
End Sub
'********************
'* approximately 4 times as fast as standard BubbleSort, making this algorithm less
'* computationally painful for larger unordered datasets.
'********************
Sub BubbleSortRecursiveEmerge (CGSortLibArr() As Double, start As Long, finish As Long, order&)
If start < finish Then
m& = start + (finish - start) \ 2
BubbleSortModified CGSortLibArr(), start, m&, order&
BubbleSortModified CGSortLibArr(), m& + 1, finish, order&
EfficientMerge CGSortLibArr(), start, finish, order&
End If
End Sub
'**************************
'* approximately twice as fast as the original version for unordered datasets.
'**************************
Sub BubbleSortModified_0 (a() As Double, start&, finish&, order&)
Select Case order&
Case 1
Do
s& = -1
a& = start&
b& = finish&
Do
first& = a&
last& = b& - 1
For x& = first& To last&
If a(x&) > a(x& + 1) Then
Swap a(x&), a(x& + 1)
If x& < b& Then
b& = x&
Else
a& = x&
End If
s& = 0
End If
Next
Swap a&, b&
Loop While a& < b&
Loop Until s&
Case Else
Do
s& = -1
a& = start&
b& = finish&
Do
first& = a&
last& = b& - 1
For x& = first& To last&
If a(x&) < a(x& + 1) Then
Swap a(x&), a(x& + 1)
If x& < b& Then
b& = x&
Else
a& = x&
End If
s& = 0
End If
Next
Swap a&, b&
Loop While a& < b&
Loop Until s&
End Select
End Sub
'*******************************
'* KnuthShuffle, named for its progenitor, Donald Knuth, rearranges CGSortLibArr() in randomized order, swapping element
'* KnuthStart& and some element after it up to CGSortLibArr(finish&)
'*******************************
Sub KnuthShuffle (CGSortLibArr() As Double, start As Long, finish As Long)
Dim KnuthStart As Long: KnuthStart = start
Dim Randomindexintoarray As Long
Do While (KnuthStart < finish)
Randomindexintoarray = KnuthStart + Int(Rnd * (finish - KnuthStart - 1))
Swap CGSortLibArr(KnuthStart), CGSortLibArr(Randomindexintoarray)
KnuthStart = KnuthStart + 1
Loop
End Sub
Function ArraySequenceCheck& (CGSortLibArr() As Double, start&, finish&, order&)
oseq& = order&
h& = start&
i& = start&
Do
If CGSortLibArr(i&) < CGSortLibArr(h&) Then
If oseq& = 1 Then
'* this is a sequence error
oseq& = 0
Exit Do
Else
oseq& = -1
h& = i&
End If
ElseIf CGSortLibArr(i&) > CGSortLibArr(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 Function
Function NthPlace& (a() As Double, NPMMrec As MinMaxRec, start As Long, finish As Long, order&, npindex As Long)
Dim NPx As Double: NPx = (a(npindex) - a(NPMMrec.min))
Dim NPy As Double: NPy = (a(NPMMrec.max) - a(NPMMrec.min))
Np& = Int((NPx * (finish - start)) \ NPy)
If order& = 1 Then
NthPlace& = start + Np&
Else
NthPlace& = finish - Np&
End If
End Function
'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
' FOR c& = start TO finish
' PRINT CGSortLibArr(c&); finish - start
' NEXT
' 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
'* Demo of 48828125 double-precision elements takes a shade over 10s on 2.16GHz machine, sometimes going low as 9.6s.
'* 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
'*******************************
Sub BFPRT (CGSortLibArr() As Double, start As Long, finish As Long, BFPRTMedian As Double)
Dim BFPRT_ScanIndexArray As Long
Dim BFPRT_countIndex As Long
Dim BFPRT_SubdivisionSize As Long: BFPRT_SubdivisionSize = 5
If finish - start < BFPRT_SubdivisionSize - 1 Then
Select Case (finish - start) Mod BFPRT_SubdivisionSize
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) / BFPRT_SubdivisionSize + BFPRT_SubdivisionSize) As Double
BFPRT_ScanIndexArray = LBound(CGSortLibArr)
BFPRT_CountArrayIndex = 0
Do
If BFPRT_ScanIndexArray - 1 > finish - BFPRT_SubdivisionSize Then
InsertionSort CGSortLibArr(), BFPRT_ScanIndexArray, finish, 1
Do Until BFPRT_ScanIndexArray > finish
BfprtArray(BFPRT_CountArrayIndex) = CGSortLibArr(BFPRT_ScanIndexArray)
BFPRT_ScanIndexArray = BFPRT_ScanIndexArray + 1
Loop
Exit Do
Else
InsertionSort CGSortLibArr(), BFPRT_ScanIndexArray, BFPRT_ScanIndexArray + BFPRT_SubdivisionSize - 1, 1
BfprtArray(BFPRT_CountArrayIndex) = CGSortLibArr(BFPRT_ScanIndexArray + (BFPRT_SubdivisionSize - 1) \ 2)
'* PRINT BfprtArray(BFPRT_CountArrayIndex); BFPRT_CountArrayIndex
BFPRT_CountArrayIndex = BFPRT_CountArrayIndex + 1
BFPRT_ScanIndexArray = BFPRT_ScanIndexArray + BFPRT_SubdivisionSize
End If
Loop
BFPRT BfprtArray(), 0, BFPRT_CountArrayIndex - 1, BFPRTMedian
End If
End Sub
'* used to defeat the "midnight bug."
Function DeltaTime! (time1!, time2!)
If time2! < time1! Then
DeltaTime! = (86400 - time1!) + time2!
Else
DeltaTime! = time2! - time1!
End If
End Function
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
For CGFrequencyCounts_IteratorU = Start& To Finish&
CGFrequencyCounts_Index = NthPlace&(CGSortLibArr(), CGSortLibArr_mmrec, Start&, Finish&, order&, CGFrequencyCounts_IteratorU)
'CGFrequencyCounts_Index = INT((CGSortLibArr(CGFrequencyCounts_IteratorU) - CGSortLibArr(CGSortLibArr_mmrec.min)) * (Finish& - Start&) / (CGSortLibArr(CGSortLibArr_mmrec.max) - CGSortLibArr(CGSortLibArr_mmrec.min)))
CGFrequencyCounts_Array(CGFrequencyCounts_rank) = CGFrequencyCounts_Array(CGFrequencyCounts_rank) + 1
'* this was for profiling purposes and short demo
'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 CGSetSortLibArray (CGSortLibArr() As Double, start&, finish&, order&, minimum As Double, maximum As Double, makeint&)
Dim CGSetSortLibArrDelta As Double
If minimum > maximum Then
CGSetSortLibArrDelta = minimum - maximum
Else
CGSetSortLibArrDelta = maximum - minimum
End If
CGSetSortLibArrDelta = CGSetSortLibArrDelta / (finish& - start& + 1)
MontonicValue# = mimumum + Rnd * (maximum - minimum)
For s& = start& To finish&
Select Case order&
Case -1 '* descending
CGSortLibArr(s&) = maximum - (s& - start&) * CGSetSortLibArrDelta
Case 0 '*random
CGSortLibArr(s&) = minimum + Rnd * (maximum - minimum)
Case 1 '* ascending
CGSortLibArr(s&) = minimum + (s& - start&) * CGSetSortLibArrDelta
Case 2 '* bitonic
m& = start& + (finish& - start&) \ 2
If s& > m& Then
CGSortLibArr(s&) = maximum - (s& - m&) * CGSetSortLibArrDelta
Else
CGSortLibArr(s&) = minimum + (s& - start&) * CGSetSortLibArrDelta
End If
Case 3 '* monotonic
CGSortLibArr(s&) = MontonicValue#
End Select
Next
If makeint& Then
ScaleArrayToInt CGSortLibArr(), start&, finish&
End If
End Sub
Sub ScaleArrayToInt (CGSortLibArr() As Double, start&, finish&)
Dim satimmrec As MinMaxRec
GetMinMaxArray CGSortLibArr(), start&, finish&, satimmrec
Dim sati_T As Double
Dim sati_m As Integer
If CGSortLibArr(satimmrec.min) <> 0 Then
sati_T = CGSortLibArr(satimmrec.min)
Else
sati_T = CGSortLibArr(satimmrec.max)
End If
If sati_T <> 0 Then
sati_m = 1
Do
If sati_T = Int(sati_T) Then
Exit Do
Else
sati_m = sati_m * 10
sati_T = sati_T * 10
End If
Loop
If sati_m > 1 Then
For s& = start& To finish&
CGSortLibArr(s&) = CGSortLibArr(s&) * sati_m
Next
End If
End If
End Sub
Sub BitInvert (C() As Double, start&, finish&, method&)
'* Method
'* 0 simply bit-inverts bits in an element of CGSortLibArr(), one by one
'* 1 Inverts the elements of CGSortLibArr()
'* 2 bit-inverts elements of CGSortLibArr()
End Sub
'// C++ program to perform TimSort.
'#include<bits/stdc++.h>
'using namespace std;
'const int RUN = 32;
'// this function sorts array from left index to
'// to right index which is of size atmost RUN
'void insertionSort(int arr[], int left, int right)
'{
' for (int i = left + 1; i <= right; i++)
' {
' int temp = arr[i];
' int j = i - 1;
' while (arr[j] > temp && j >= left)
' {
' arr[j+1] = arr[j];
' j--;
' }
' arr[j+1] = temp;
' }
'}
'// merge function merges the sorted runs
'void merge(int arr[], int l, int m, int r)
'{
' // original array is broken in two parts
' // left and right array
' int len1 = m - l + 1, len2 = r - m;
' int left[len1], right[len2];
' for (int i = 0; i < len1; i++)
' left[i] = arr[l + i];
' for (int i = 0; i < len2; i++)
' right[i] = arr[m + 1 + i];
' int i = 0;
' int j = 0;
' int k = l;
' // after comparing, we merge those two array
' // in larger sub array
' while (i < len1 && j < len2)
' {
' if (left[i] <= right[j])
' {
' arr[k] = left[i];
' i++;
' }
' else
' {
' arr[k] = right[j];
' j++;
' }
' k++;
' }
' // copy remaining elements of left, if any
' while (i < len1)
' {
' arr[k] = left[i];
' k++;
' i++;
' }
' // copy remaining element of right, if any
' while (j < len2)
' {
' arr[k] = right[j];
' k++;
' j++;
' }
'}
'// iterative Timsort function to sort the
'// array[0...n-1] (similar to merge sort)
'void timSort(int arr[], int n)
'{
' // Sort individual subarrays of size RUN
' for (int i = 0; i < n; i+=RUN)
' insertionSort(arr, i, min((i+31), (n-1)));
' // start merging from size RUN (or 32). It will merge
' // to form size 64, then 128, 256 and so on ....
' for (int size = RUN; size < n; size = 2*size)
' {
' // pick starting point of left sub array. We
' // are going to merge arr[left..left+size-1]
' // and arr[left+size, left+2*size-1]
' // After every merge, we increase left by 2*size
' for (int left = 0; left < n; left += 2*size)
' {
' // find ending point of left sub array
' // mid+1 is starting point of right sub array
' int mid = left + size - 1;
' int right = min((left + 2*size - 1), (n-1));
' // merge sub array arr[left.....mid] &
' // arr[mid+1....right]
' merge(arr, left, mid, right);
' }
' }
'}
'// utility function to print the Array
'void printArray(int arr[], int n)
'{
' for (int i = 0; i < n; i++)
' printf("%d ", arr[i]);
' printf("\n");
'}
'// Driver program to test above function
'int main()
'{
' int arr[] = {5, 21, 7, 23, 19};
' int n = sizeof(arr)/sizeof(arr[0]);
' printf("Given Array is\n");
' printArray(arr, n);
' timSort(arr, n);
' printf("After Sorting Array is\n");
' printArray(arr, n);
' return 0;
'}
Sub UnionIntersectionLists (array_a() As Double, array_a_start As Long, array_a_finish As Long, array_b() As Double, array_b_start As Long, array_b_finish As Long, UIArray() As Double, UIFunction%)
Select Case UIFunction%
Case 0 '* union"
Case Else '* intersection
End Select
ReDim UIArray(0 To 0) As Double
Dim inserted_in_UI As Long
Dim start_a As Long
Dim Start_b As Long
'* Give CodeGuy some props.
primeGapSort2 array_a(), array_a_start, array_a_finish, 1
primeGapSort2 array_b(), array_b_start, array_b_finish, 1
inserted_in_UI = LBound(UIArray)
start_a = array_a_start
Start_b = array_b_start
Select Case UIFunction%
Case 0 '* union
Do
If start_a > array_a_finish Then
While Start_b <= array_b_finish
ReDim _Preserve UIArray(0 To inserted_in_UI) As Double
UIArray(inserted_in_UI) = array_b(Start_b)
inserted_in_UI = inserted_in_UI + 1
Start_b = Start_b + 1
Wend
Exit Do
ElseIf Start_b > array_b_finish Then
While start_a <= array_a_finish
ReDim _Preserve UIArray(0 To inserted_in_UI) As Double
UIArray(inserted_in_UI) = array_a(start_a)
inserted_in_UI = inserted_in_UI + 1
start_a = start_a + 1
Wend
Exit Do
Else
ReDim _Preserve UIArray(0 To inserted_in_UI) As Double
If array_b(Start_b) < array_a(start_a) Then
UIArray(inserted_in_UI) = array_b(Start_b)
Start_b = Start_b + 1
Else
UIArray(inserted_in_UI) = array_a(start_a)
start_a = start_a + 1
End If
inserted_in_UI = inserted_in_UI + 1
End If
Loop
Case 1 '* intersection
'* binary search is fine for this operation too
'* intersection finds elements common to array_a() and array_b()
'* elements common to both arrays are inserted into UIArray()
Do
If start_a > array_a_finish Then
Exit Do
End If
If Start_b > array_b_finish Then
Exit Do
End If
If array_a(start_a) = array_b(Start_b) Then
ReDim _Preserve UIArray(0 To inserted_in_UI)
UIArray(inserted_in_UI) = array_a(start_a)
inserted_in_UI = inserted_in_UI + 1
start_a = start_a + 1
Start_b = Start_b + 1
ElseIf array_a(start_a) > array_b(Start_b) Then
Start_b = Start_b + 1
Else
start_a = start_a + 1
End If
Loop
End Select
End Sub
'**************************************
'* 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
NilValue& = LBound(CGSortLibArr) - 1
Type TreeNode
value As Double
left As Long
right As Long
End Type
Dim tree(start& + 1 To finish& + 1) As TreeNode
For x& = start& + 1 To finish& + 1
tree(x&).value = 0
tree(x&).left = NilValue&
tree(x&).right = NilValue&
Next
tree(1).value = CGSortLibArr(1 - 1)
free& = 2
If order& = 1 Then
For x& = 2 To finish&
pointer& = 1
Do
If CGSortLibArr(x& - 1) < tree(pointer&).value Then
If tree(pointer&).left = NilValue& Then
tree(pointer&).left = free&
tree(free&).value = CGSortLibArr(x& - 1)
free& = free& + 1
Exit Do
Else
pointer& = tree(pointer&).left
End If
Else
If tree(pointer&).right = NilValue& Then
tree(pointer&).right = free&
tree(free&).value = CGSortLibArr(x& - 1)
free& = free& + 1
Exit Do
Else
pointer& = tree(pointer&).right
End If
End If
Loop
Next x&
Else
For x& = 2 To finish&
pointer& = 1
Do
If CGSortLibArr(x& - 1) > tree(pointer&).value Then
If tree(pointer&).left = NilValue& Then
tree(pointer&).left = free&
tree(free&).value = CGSortLibArr(x& - 1)
free& = free& + 1
Exit Do
Else
pointer& = tree(pointer&).left
End If
Else
If tree(pointer&).right = NilValue& Then
tree(pointer&).right = free&
tree(free&).value = CGSortLibArr(x& - 1)
free& = free& + 1
Exit Do
Else
pointer& = tree(pointer&).right
End If
End If
Loop
Next x&
End If
depth& = start& + 1
Traverse_tree CGSortLibArr(), start& + 1, depth&, tree(), NilValue&
Erase tree
End Sub
Sub Traverse_tree (CGSortLibArr() As Double, NextPtr&, depth&, tree() As TreeNode, NilValue&)
If tree(NextPtr&).left <> NilValue& Then
Traverse_tree CGSortLibArr(), tree(NextPtr&).left, depth&, tree(), NilValue&
End If
CGSortLibArr(depth& - 1) = tree(NextPtr&).value
depth& = depth& + 1
If tree(NextPtr&).right <> NilValue& Then Traverse_tree CGSortLibArr(), tree(NextPtr&).right, depth&, tree(), NilValue&
End Sub
'* normopt& = 0 normalizes range (0,,1) inclusive
'* normopt& = 1 returns minimum NVT_ScaleMultiplier that multiplied by each element returns a whole (non-decimal) number
Sub NormalizeVectorTo (CGSortLibArr() As Double, start&, finish&, NormOpt&, NVT_ScaleMultiplier As Double)
Dim NormalizeVectorTo_minmax As MinMaxRec
Dim NVT_Minimum As Double
NVT_ScaleMultiplier = 1
GetMinMaxArray CGSortLibArr(), start&, finish&, NormalizeVectorTo_minmax: NVT_Minimum = CGSortLibArr(NormalizeVectorTo_minmax.min)
If CGSortLibArr(NormalizeVectorTo_minmax.min) < CGSortLibArr(NormalizeVectorTo_minmax.max) Then
If NormOpt& = 1 Then
NVT_ScaleMultiplier = CGSortLibArr(NormalizeVectorTo_minmax.max) - CGSortLibArr(NormalizeVectorTo_minmax.min)
For s& = start& To finish&
CGSortLibArr(s&) = (CGSortLibArr(s&) - NVT_Minimum) / NVT_ScaleMultiplier#
Next
Else
'*************************
If CGSortLibArr(NormalizeVectorTo_minmax.min) <> 0 Then
NVT_ScaleMultiplier = CGSortLibArr(NormalizeVectorTo_minmax.min)
Else
If CGSortLibArr(NormalizeVectorTo_minmax.max) <> 0 Then
NVT_ScaleMultiplier = CGSortLibArr(NormalizeVectorTo_minmax.max)
Else
Exit Sub
End If
End If
Do Until NVT_ScaleMultiplier = Int(NVT_ScaleMultiplier)
NVT_ScaleMultiplier = NVT_ScaleMultiplier * 2
Loop
End If
Else
'* monotonic
If CGSortLibArr(start&) <> 0 Then
For s& = start& To finish&
CGSortLibArr(s&) = 1
Next
NVT_ScaleMultiplier = CGSortLibArr(start&)
End If
End If
End Sub
'* assumes CGBI_element_d >=0
'* returns CGBI_element_d as bit-inverted version of CGBI_element_d
Sub CGBitInvert_element (CGBI_element_d As _Unsigned _Integer64)
Static CGBI_ShiftTable%
Static ui64_shift(0 To 63) As _Unsigned _Integer64
If CGBI_ShiftTable% = 0 Then
Dim CGBIO_s As Integer
ui64_shift(0) = 1
For cgbi_s = 1 To Len(ui64_shift(0)) * 8 - 1
ui64_shift(cgbi_s) = ui64_shift(cgbi_s - 1) * 2
Next
CGBI_ShiftTable% = -1
End If
Dim CGBI_element_r As Double: CGBI_element_r = 0
Dim CGBI_element_s As Integer
Dim CGBI_BitsInElement As Integer
CGBI_BitsInElement = Len(CGBI_element_d) * 8 - 1
Do
If CGBI_element_d < 0 Then
If CGBI_element_d > ui64_shift(CGBI_element_s) Then
CGBI_element_s = CGBI_element_s - 1
Else
CGBI_element_d = CGBI_element_d + ui64_shift(CGBI_element_s)
CGBI_element_r = CGBI_element_r + ui64_shift(CGBI_element_s)
End If
ElseIf CGBI_element_d > 0 Then
If CGBI_element_d < ui64_shift(cgb_element_s) Then
CGBI_element_s = CGBI_element_s - 1
Else
CGBI_element_d = CGBI_element_d - ui64_shift(CGBI_BitsInElement - CGBI_element_s)
CGBI_element_r = CGBI_element_r + uinsi64_shift(CGBI_BitsInElement - CGBI_element_s)
End If
Else
Exit Do
End If
Loop
CGBI_element_d = CGBI_element_r
End Sub
Function zb$ (d As Double)
Dim x As Double: x = d
p% = 0
Do
If x = Int(x) Then
Exit Do
Else
p% = p% + 1
x = x * 10
End If
Loop
CGBitInvert_element x
Print x
_Delay 10
End Function
'*********************
'* Timsort, slightly modified and highly simplified
'* O(NLogN) complexity and at 8388608 elements in 24s make this a good, fast stable sort.
'*********************
Sub TimSort (CGSortLibArr() As Double, start As Long, finish As Long, order&)
Dim minrun As Long: minrun = 32
If finish - start < minrun Then
InsertionSortBinary CGSortLibArr(), start, finish, order&
Else
Dim TimSort_Local_size As Long: TimSort_Local_size = minrun
Dim TimSort_Local_i As Long
Dim TimSort_local_left As Long
Dim TimSort_local_mid As Long
Dim TimSort_local_right As Long
For TimSort_Local_i = start To finish - minrun + 1 Step minrun
InsertionSortBinary CGSortLibArr(), TimSort_Local_i, TimSort_Local_i + minrun - 1, order&
Next
If TimSort_Local_i < finish Then
InsertionSortBinary CGSortLibArr(), TimSort_Local_i, finish, order&
End If
Do
TimSort_local_left = start
TimSort_local_mid = TimSort_local_left + TimSort_Local_size - 1
Do
If TimSort_local_mid + TimSort_Local_size > finish - TimSort_Local_size Then
Tim_merge CGSortLibArr(), TimSort_local_left, TimSort_local_mid, finish, order&
Exit Do
Else
TimSort_local_right = TimSort_local_mid + TimSort_Local_size
Tim_merge CGSortLibArr(), TimSort_local_left, TimSort_local_mid, TimSort_local_right, order&
End If
TimSort_local_left = TimSort_local_left + 2 * TimSort_Local_size
TimSort_local_mid = TimSort_local_left + TimSort_Local_size - 1
Loop
TimSort_Local_size = TimSort_Local_size * 2
Loop Until start + TimSort_Local_size > finish
End If
End Sub
Sub Tim_merge (CGSortLibArr() As Double, left As Long, middle As Long, right As Long, order&)
Dim Tim_Merge_LenLeft As Long
Dim Tim_Merge_LenRight As Long
Dim Tim_Merge_i As Long
Dim Tim_Merge_J As Long
Dim Tim_Merge_k As Long
Tim_Merge_LenLeft = middle - left + 1
Tim_Merge_LenRight = right - middle
Dim array_left(0 To Tim_Merge_LenLeft - 1) As Double
Dim array_right(0 To Tim_Merge_LenRight - 1) As Double
'* load up left side (lower half in left) (start ... middle)
For Tim_Merge_i = 0 To Tim_Merge_LenLeft - 1
array_left(Tim_Merge_i) = CGSortLibArr(left + Tim_Merge_i)
Next
'* load up right side (upper half in left) (middle + 1 ... finish)
For Tim_Merge_i = 0 To Tim_Merge_LenRight - 1
array_right(Tim_Merge_i) = CGSortLibArr(middle + Tim_Merge_i + 1)
Next
Tim_Merge_i = 0
Tim_Merge_J = 0
Tim_Merge_k = left
If order& = 1 Then
While (Tim_Merge_i < Tim_Merge_LenLeft And Tim_Merge_J < Tim_Merge_LenRight)
If (array_left(Tim_Merge_i) <= array_right(Tim_Merge_J)) Then
CGSortLibArr(Tim_Merge_k) = array_left(Tim_Merge_i)
Tim_Merge_i = Tim_Merge_i + 1
Else
CGSortLibArr(Tim_Merge_k) = array_right(Tim_Merge_J)
Tim_Merge_J = Tim_Merge_J + 1
End If
Tim_Merge_k = Tim_Merge_k + 1
Wend
Else
While (Tim_Merge_i < Tim_Merge_LenLeft And Tim_Merge_J < Tim_Merge_LenRight)
If (array_left(Tim_Merge_i) >= array_right(Tim_Merge_J)) Then
CGSortLibArr(Tim_Merge_k) = array_left(Tim_Merge_i)
Tim_Merge_i = Tim_Merge_i + 1
Else
CGSortLibArr(Tim_Merge_k) = array_right(Tim_Merge_J)
Tim_Merge_J = Tim_Merge_J + 1
End If
Tim_Merge_k = Tim_Merge_k + 1
Wend
End If
While (Tim_Merge_i < Tim_Merge_LenLeft)
CGSortLibArr(Tim_Merge_k) = array_left(Tim_Merge_i)
Tim_Merge_k = Tim_Merge_k + 1
Tim_Merge_i = Tim_Merge_i + 1
Wend
While (Tim_Merge_J < Tim_Merge_LenRight)
CGSortLibArr(Tim_Merge_k) = array_right(Tim_Merge_J)
Tim_Merge_k = Tim_Merge_k + 1
Tim_Merge_J = Tim_Merge_J + 1
Wend
Erase array_left
Erase array_right
End Sub
'SUB GnomeSort (array() AS DOUBLE, start AS LONG, finish AS LONG, order&)
' '* LOCATE 40, 1: PRINT USING "#####.################"; TIMER(.001);
' DIM GnomeSort_I AS LONG
' SELECT CASE order&
' CASE 1
' GnomeSort_I = start + 1
' DO UNTIL GnomeSort_I > finish
' IF (array(GnomeSort_I - 1) <= array(GnomeSort_I)) THEN
' GnomeSort_I = GnomeSort_I + 1
' ELSE
' SWAP array(GnomeSort_I), array(GnomeSort_I - 1)
' GnomeSort_I = GnomeSort_I - 1
' IF (GnomeSort_I < start + 1) THEN
' GnomeSort_I = start + 1
' END IF
' END IF
' LOOP
' CASE ELSE
' GnomeSort_I = start + 1
' DO UNTIL GnomeSort_I > finish
' IF (array(GnomeSort_I - 1) >= array(GnomeSort_I)) THEN
' GnomeSort_I = GnomeSort_I + 1
' ELSE
' SWAP array(GnomeSort_I), array(GnomeSort_I - 1)
' GnomeSort_I = GnomeSort_I - 1
' IF (GnomeSort_I < start + 1) THEN
' GnomeSort_I = start + 1
' END IF
' END IF
' LOOP
' END SELECT
' '* LOCATE 40, 1: PRINT USING "#####.################"; TIMER(.001);
'END SUB
Sub GnomeSort (CGSortLibArray() As Double, start As Long, finish As Long, order&)
Dim Gnome_i As Long
Dim Gnome_j As Long
Select Case order&
Case 1
Gnome_i = start + 1
Gnome_j = Gnome_i + 1
While (Gnome_i < finish - start)
If CGSortLibArray(Gnome_i - 1) <= CGSortLibArray(Gnome_i) Then
Gnome_i = Gnome_j
Gnome_j = Gnome_j + 1
Else
Swap CGSortLibArray(Gnome_i - 1), CGSortLibArray(Gnome_i)
Gnome_i = Gnome_i - 1
If Gnome_i < start + 1 Then
Gnome_i = Gnome_j
Gnome_j = Gnome_j + 1
End If
End If
Wend
Case Else
Gnome_i = start + 1
Gnome_j = Gnome_i + 1
While (Gnome_i < finish - start)
If CGSortLibArray(Gnome_i - 1) >= CGSortLibArray(Gnome_i) Then
Gnome_i = Gnome_j
Gnome_j = Gnome_j + 1
Else
Swap CGSortLibArray(Gnome_i - 1), CGSortLibArray(Gnome_i)
Gnome_i = Gnome_i - 1
If Gnome_i < start + 1 Then
Gnome_i = Gnome_j
Gnome_j = Gnome_j + 1
End If
End If
Wend
End Select
End Sub
'SUB CountingSort (CGSortLibArray() AS DOUBLE, start AS LONG, finish AS LONG, order&)
' DIM CSmmrec AS MinMaxRec
' GetMinMaxArray CGSortLibArray(), start, finish, CSmmrec
' DIM pow2_shift AS DOUBLE: pow2_shift = 1
' DIM XInsert AS LONG: XInsert = 0
' IF CGSortLibArray(CSmmrec.min) <> CGSortLibArray(CSmmrec.max) THEN
' ArrayIsInteger CGSortLibArray(), start, finish, ErrIndex&, IsIntegers&
' IF IsIntegers& THEN
' '* no scaling needed
' IF start = LBOUND(CGSortLibArray) THEN
' IF finish = UBOUND(CGSortLibArray) THEN
' redimc& = -1
' ELSE
' redimc& = 0
' END IF
' ELSE
' redimc& = 0
' END IF
' IF redimc& THEN
' REDIM Counts(0 TO CGSortLibArray(CSmmrec.max) - CGSortLibArray(CSmmrec.min)) AS LONG
' FOR scanarrayp& = start TO finish
' Counts(CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min)) = Counts(CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min)) + 1
' NEXT
' IF order& = 1 THEN
' XInsert = start
' FOR scanarrayp& = LBOUND(counts) TO UBOUND(counts)
' IF Counts(scanarrayp&) > 0 THEN
' FOR u& = 0 TO Counts(scanarrayp&) - 1
' CGSortLibArray(XInsert) = scanarrayp& + CGSortLibArray(CSmmrec.min)
' XInsert = XInsert + 1
' NEXT
' END IF
' NEXT
' ELSE
' XInsert = finish
' FOR scanarrayp& = UBOUND(counts) TO LBOUND(counts) STEP -1
' IF Counts(scanarrayp&) > 0 THEN
' FOR u& = Counts(scanarrayp&) - 1 TO 0 STEP -1
' CGSortLibArray(XInsert) = scanarrayp& + CGSortLibArray(CSmmrec.min)
' XInsert = XInsert - 1
' NEXT
' END IF
' NEXT
' END IF
' FOR x& = start TO finish
' PRINT CGSortLibArray(x&);
' NEXT
' ELSE
' FOR scanarrayp& = start TO finish
' Counts(CGSortLibArray(scanarrayp&) - MinArray) = Counts(CGSortLibArray(scanarrayp&) - MinArray) + 1
' NEXT
' FOR scanarrayp& = LBOUND(counts) TO UBOUND(counts)
' FOR u& = 0 TO Counts(scanarrayp&) - 1
' CGSortLibArray(XInsert) = scanarrayp& + MinArray
' XInsert = XInsert + 1
' NEXT
' '* REDIM _PRESERVE Counts(scanarrayp& TO finish) AS LONG
' NEXT
' END IF
' '* clear the Counts() array
' ERASE Counts
' ELSE
' DIM t AS DOUBLE
' IF CGSortLibArray(CSmmrec.min) <> 0 THEN
' t = CGSortLibArray(CSmmrec.min)
' ELSE
' t = CGSortLibArray(CSmmrec.max)
' END IF
' POW2_SHIFT& = 1
' DO UNTIL t = INT(t)
' t = t * 2
' pow2_shift = pow2_shift * 2
' LOOP
' REDIM Counts(0 TO pow2_shift * (CGSortLibArray(CSmmrec.max) - CGSortLibArray(CSmmrec.min)))
' FOR scanarrayp& = start TO finish
' x& = pow2_shift * (CGSortLibArray(scanarray&) - MinArray)
' Counts(x&) = Counts(x&) + 1
' NEXT
' IF order& = 1 THEN
' FOR scanarrayp& = LBOUND(counts) TO UBOUND(counts)
' FOR u& = 0 TO Counts(scanarrayp&) - 1
' CGSortLibArray(XInsert) = scanarrayp& + MinArray
' XInsert = XInsert + 1
' NEXT
' '* REDIM _PRESERVE Counts(scanarrayp& TO finish) AS LONG
' NEXT
' ELSE
' FOR scanarrayp& = UBOUND(counts) TO LBOUND(counts) STEP -1
' FOR u& = Counts(scanarrayp&) - 1 TO 0 STEP -1
' CGSortLibArray(XInsert) = scanarrayp& + MinArray
' XInsert = XInsert - 1
' NEXT
' '* REDIM _PRESERVE Counts(scanarrayp& TO finish) AS LONG
' NEXT
' END IF
' ERASE Counts
' END IF
' END IF
'END SUB
'SUB CountingSortInteger (CGSortLibArray() AS DOUBLE, start AS LONG, finish AS LONG, order&)
' DIM CSmmrec AS MinMaxRec
' GetMinMaxArray CGSortLibArray(), start, finish, CSmmrec
' DIM XInsert AS LONG: XInsert = 0
' IF CGSortLibArray(CSmmrec.min) <> CGSortLibArray(CSmmrec.max) THEN
' REDIM Counts(CGSortLibArray(CSmmrec.min) TO CGSortLibArray(CSmmrec.max)) AS LONG
' FOR scanarrayp& = start TO finish
' Counts(CLNG(CGSortLibArray(scanarrayp&))) = Counts(CLNG(CGSortLibArray(scanarrayp&))) + 1
' NEXT
' IF order& = 1 THEN
' XInsert = start
' FOR scanarrayp& = LBOUND(counts) TO UBOUND(counts)
' FOR u& = 0 TO Counts(scanarrayp&) - 1
' CGSortLibArray(XInsert) = scanarrayp&
' XInsert = XInsert + 1
' NEXT
' NEXT
' ELSE
' XInsert = start
' FOR scanarrayp& = UBOUND(counts) TO LBOUND(counts) STEP -1
' FOR u& = 0 TO Counts(scanarrayp&) - 1
' CGSortLibArray(XInsert) = scanarrayp&
' XInsert = XInsert + 1
' NEXT
' NEXT
' END IF
' '* clear the Counts() array
' ERASE Counts
' END IF
'END SUB
Sub CountingSortInteger (CGSortLibArray() As Double, start As Long, finish As Long, order&)
ArrayIsInteger CGSortLibArray(), start, finish, FirstNonIntegerElement&, errcon&
If errcon& Then
CountingSortNonInteger CGSortLibArray(), start, finish, order&
Else
Dim CSmmrec As MinMaxRec
CSmmrec.min = start
CSmmrec.max = finish
For scanarrayp& = start To finish
If CGSortLibArray(scanarrayp&) < CGSortLibArray(CSmmrec.min) Then CSmmrec.min = scanarrayp&
If CGSortLibArray(scanarrayp&) > CGSortLibArray(CSmmrec.max) Then CSmmrec.max = scanarrayp&
Next
Dim XInsert As Long: XInsert = 0
If CGSortLibArray(CSmmrec.min) <> CGSortLibArray(CSmmrec.max) Then
'* PRINT CGSortLibArray(CSmmrec.min); CGSortLibArray(CSmmrec.max)
'* no scaling needed
Dim cgslam As Double: cgslam = CGSortLibArray(CSmmrec.min)
ReDim Counts(0 To CGSortLibArray(CSmmrec.max) - CGSortLibArray(CSmmrec.min)) As Long
For scanarrayp& = start To finish
Counts(CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min)) = Counts(CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min)) + 1
Next
If order& = 1 Then
XInsert = start
For scanarrayp& = LBound(Counts) To UBound(Counts)
For u& = 0 To Counts(scanarrayp&) - 1
CGSortLibArray(XInsert) = scanarrayp& + cgslam
XInsert = XInsert + 1
Next
Next
Else
XInsert = start
For scanarrayp& = UBound(Counts) To LBound(Counts) Step -1
For u& = 0 To Counts(scanarrayp&) - 1
CGSortLibArray(XInsert) = scanarrayp& + cgslam
XInsert = XInsert + 1
Next
Next
End If
'* clear the Counts() array
Erase Counts
End If
End If
End Sub
'************************************
'* CountingSort() extended to non-integer
'* complexity class: O(N) -- Typical throughput: 600,000 double-precision/GHzS
'************************************
Sub CountingSortNonInteger (CGSortLibArray() As Double, start As Long, finish As Long, order&)
Dim CSmmrec As MinMaxRec
GetMinMaxArray CGSortLibArray(), start, finish, CSmmrec
Dim XInsert As Long: XInsert = 0
If CGSortLibArray(CSmmrec.min) <> CGSortLibArray(CSmmrec.max) Then
FindNonZeroElement CGSortLibArray(), start, finish, ascale#
If ascale# * (CGSortLibArray(CSmmrec.max) - CGSortLibArray(CSmmrec.min)) > (2 ^ 32) / (Len(CGSortLibArray(start))) Then
MergeSortEmerge CGSortLibArray(), start, finish, order&
Else
Dim cgslam As Double: cgslam = CGSortLibArray(CSmmrec.min)
cgslam = CGSortLibArray(CSmmrec.min)
ReDim Counts(0 To ascale# * (CGSortLibArray(CSmmrec.max) - CGSortLibArray(CSmmrec.min))) As Long
For scanarrayp& = start To finish
Counts(ascale# * (CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min))) = Counts(ascale# * (CGSortLibArray(scanarrayp&) - CGSortLibArray(CSmmrec.min))) + 1
Next
If order& = 1 Then
XInsert = start
For scanarrayp& = LBound(Counts) To UBound(Counts)
For u& = 0 To Counts(scanarrayp&) - 1
CGSortLibArray(XInsert) = scanarrayp& + cgslam
XInsert = XInsert + 1
Next
Next
Else
XInsert = start
For scanarrayp& = UBound(Counts) To LBound(Counts) Step -1
For u& = 0 To Counts(scanarrayp&) - 1
CGSortLibArray(XInsert) = scanarrayp& + cgslam
XInsert = XInsert + 1
Next
Next
End If
'* clear the Counts() array
Erase Counts
End If
End If
End Sub
'***********************************
'* finds the lowest power of 2 when multiplied by each array element yields an integer result
'***********************************
Sub FindNonZeroElement (Cg() As Double, start As Long, finish As Long, FindNZOScale As Double)
FindNZOScale = 1
Dim find_nzo As Long
Dim LowestNonZeroElement As Long: LowestNonZeroElement = start - 1
Dim highestNonZeroElement As Long: highestNonZeroElement = start - 1
Dim curhigp As Double: curhighp = 1
For find_nzo = start To finish
If Cg(find_nzo) <> 0 Then
If LowestNonZeroElement > start - 1 Then
If Cg(find_nzo) < Cg(LowestNonZeroElement) Then
LowestNonZeroElement = find_nzo
End If
If Cg(find_nzo) > Cg(LowestNonZeroElement) Then
highestNonZeroElement = find_nzo
End If
Else
LowestNonZeroElement = find_nzo
highestNonZeroElement = find_nzo
End If
curhighp = 1
Do Until curhighp * Cg(find_nzo) = Int(curhighp * Cg(find_nzo))
curhighp = curhighp * 2
Loop
If curhighp > FindNZOScale Then
FindNZOScale = curhighp
End If
End If
Next
End Sub
'* from this:
'#define BEAD(i, j) beads[i * max + j]
'// function to perform the above algorithm
'void beadSort(int *a, int len)
'{
' // Find the maximum element
' int max = a[start];
' for (int i = 1; i < len; i++)
' if (a[i] > max)
' max = a[i];
' // allocating memory
' unsigned char beads[max*len];
' memset(beads, 0, sizeof(beads));
' // mark the beads
' for (int i = 0; i < len; i++)
' for (int j = 0; j < a[i]; j++)
' BEAD(i, j) = 1;
' for (int j = 0; j < max; j++)
' {
' // count how many beads are on each post
' int sum = 0;
' for (int i=0; i < len; i++)
' {
' sum += BEAD(i, j);
' BEAD(i, j) = 0;
' }
' // Move beads down
' for (int i = len - sum; i < len; i++)
' BEAD(i, j) = 1;
' }
' // Put sorted values in array using beads
' for (int i = 0; i < len; i++)
' {
' int j;
' for (j = 0; j < max && BEAD(i, j); j++);
' a[i] = j;
' }
'}
'* to this:
'***************************************************
'* BeadSortInteger() is VERY fast. Typical performance is O(N), meaning only a constant extra
'* time per additional element. There was no QB64 code for this sort, so I whipped one up from
'* a c++ example. Translated, tested and such 06 Apr 2018. Everyone seems to think arrays always
'* need to be manipulated across their entire length. Sometimes a partial is all that's really
'* necessary. BeadSort performs in O(NlogN) (roughly same as quicksort -- WORST case. Usually O(n).
'* As key values (array values and ranges) go up, performance remains steady and predictable although
'* at larger bit ranges, it slows appreciably but still performs categorically O(NLogN), with a higher
'* constant. excellent for all integer array numerical distributions provided there is enough memory.
'* Integer/positive only at this point. Throughput is roughly 1000k+/GHzS for double-precision. This
'* is Related to CountingSort(). So far only useful for integers but I'm working on a modification
'* like I did to CountingSort() so it can be used with non-integer arrays as well.
'***************************************************
Sub BeadSortInteger (CGSortLibArray() As Double, start As Long, finish As Long, order&)
Dim BeadSort_MAX As Double: BeadSort_MAX = CGSortLibArray(start)
Dim BeadSort_Sum As Double
Dim BeadSort_I As Long
Dim BeadSort_J As Long
For BeadSort_I = start + 1 To (finish - start)
If (CGSortLibArray(BeadSort_I) > BeadSort_MAX) Then BeadSort_MAX = CGSortLibArray(BeadSort_I)
Next
ReDim beads((finish - start), BeadSort_MAX) As _Unsigned _Bit
For BeadSort_I = 0 To (finish - start) - 1
For BeadSort_J = 0 To CGSortLibArray(BeadSort_I) - 1
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
If order& = 1 Then
For BeadSort_J = 0 To BeadSort_MAX
BeadSort_Sum = 0
For BeadSort_I = 0 To (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
beads(BeadSort_I, BeadSort_J) = 0
Next
For BeadSort_I = (finish - start) - BeadSort_Sum To (finish - start)
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
For BeadSort_I = 0 To (finish - start)
BeadSort_J = 0
While BeadSort_J < BeadSort_MAX And beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
Wend
CGSortLibArray(BeadSort_I) = BeadSort_J
Next
Else
For BeadSort_J = BeadSort_MAX To 0 Step -1
BeadSort_Sum = 0
For BeadSort_I = 0 To (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
beads(BeadSort_I, BeadSort_J) = 0
Next
For BeadSort_I = (finish - start) To (finish - start) - BeadSort_Sum Step -1
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
For BeadSort_I = 0 To (finish - start)
BeadSort_J = 0
While BeadSort_J < max And beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
Wend
CGSortLibArray(finish - BeadSort_I) = BeadSort_J
Next
End If
End Sub
'***************************************************
'* BeadSortInteger() is VERY fast. Typical performance is O(N), meaning only a constant extra
'* time per additional element. There was no QB64 code for this sort, so I whipped one up from
'* a c++ example. Translated, tested and such 06 Apr 2018. Everyone seems to think arrays always
'* need to be manipulated across their entire length. Sometimes a partial is all that's really
'* necessary. BeadSort performs in O(NlogN) (roughly same as quicksort -- WORST case. Usually O(n).
'* As key values (array values and ranges) go up, performance remains steady and predictable although
'* at larger bit ranges, it slows appreciably but still performs categorically O(NLogN), with a higher
'* constant. excellent for all integer array numerical distributions provided there is enough memory.
'* Integer/positive only at this point. Throughput is roughly 1000k+/GHzS for double-precision. This
'* is Related to CountingSort(). So far only useful for integers but I'm working on a modification
'* like I did to CountingSort() so it can be used with non-integer arrays as well.
'***************************************************
Sub BeadSortNonInteger (CGSortLibArray() As Double, start As Long, finish As Long, order&)
Dim mmrec As MinMaxRec
mmrec.min = start
mmrec.max = start
For u& = start To finish
If CGSortLibArray(u&) < CGSortLibArray(mmrec.min) Then mmrec.min = u&
If CGSortLibArray(u&) > CGSortLibArray(mmrec.max) Then mmrec.max = u&
Next
Dim BSNI_dmin As Double
Dim BSNIScale As Double
Dim BeadSort_MAX As Double: BeadSort_MAX = CGSortLibArray(mmrec.max)
BSNI_dmin = CGSortLibArray(mmrec.min)
FindNonZeroElement CGSortLibArray(), start, finish, BSNIScale
If BSNIScale > 1 Then
For u& = start To finish
CGSortLibArray(u&) = (CGSortLibArray(u&) - BSNI_dmin) * BSNIScale
Next
End If
Dim BeadSort_Sum As _Integer64
Dim BeadSort_I As _Integer64
Dim BeadSort_J As _Integer64
ReDim beads((finish - start), BeadSort_MAX) As _Unsigned _Bit
For BeadSort_I = 0 To (finish - start) - 1
For BeadSort_J = 0 To CGSortLibArray(BeadSort_I) - 1
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
If order& = 1 Then
For BeadSort_J = 0 To BeadSort_MAX
BeadSort_Sum = 0
For BeadSort_I = 0 To (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
beads(BeadSort_I, BeadSort_J) = 0
Next
For BeadSort_I = (finish - start) - BeadSort_Sum To (finish - start)
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
For BeadSort_I = 0 To (finish - start)
BeadSort_J = 0
While BeadSort_J < BeadSort_MAX And beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
Wend
CGSortLibArray(BeadSort_I) = BeadSort_J
Next
Else
For BeadSort_J = BeadSort_MAX To 0 Step -1
BeadSort_Sum = 0
For BeadSort_I = 0 To (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
beads(BeadSort_I, BeadSort_J) = 0
Next
For BeadSort_I = (finish - start) To (finish - start) - BeadSort_Sum Step -1
beads(BeadSort_I, BeadSort_J) = 1
Next
Next
For BeadSort_I = 0 To (finish - start)
BeadSort_J = 0
While BeadSort_J < max And beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
Wend
CGSortLibArray(finish - BeadSort_I) = BeadSort_J
Next
End If
End Sub
Sub PancakeSort (strawberries() As Double, start As Long, finish As Long, order&)
If start < finish Then
Dim syrup As MinMaxRec
butter& = finish
whippedcream& = start
Do Until butter& < whippedcream&
GetMinMaxArray strawberries(), whippedcream&, butter&, syrup
If strawberries(syrup.max) > strawberries(butter&) Then
StableInvert strawberries(), syrup.max, butter&, 1
Else
If strawberries(syrup.min) < strawberries(whippedcream&) Then
StableInvert strawberries(), whippedcream&, syrup.min, 1
End If
whippedcream& = whippedcream& + 1
End If
butter& = butter& - 1
Loop
If order& <> 1 Then
StableInvert strawberries(), statrt, finish, 1
End If
End If
End Sub
Sub AnalyzeArray (CG() As Double, start As Long, finish As Long, order&)
ReDim Inverted(start To finish) As Double
ReDim InOrder(start To finish) As Double
Select Case order&
Case 1
h& = start
For q& = start To finish
If CG(q&) < CG(h&) Then
Swap CG(q&), CG(h&)
Inverted(Invertcount&) = CG(q&)
Invertcount& = Invertcount& + 1
Else
InOrder(inordercount&) = CG(q&)
inordercount& = inordercount& + 1
End If
h& = q&
Next
Case Else
End Select
End Sub
Sub OneZeroSort (cg() As Double, start, finish, order&)
Dim left As Long: left = start
Dim right As Long: right = finish
Select Case order&
Case 1
While left < right
While cg(left) = 0
left = left + 1
Wend
While cg(right)
right = right - 1
Wend
If left < right Then
Swap cg(left), cg(right)
left = left + 1
right = right - 1
End If
Wend
Case Else
While left < right
While cg(left)
left = left + 1
Wend
While cg(right) = 0
right = right - 1
Wend
If left < right Then
Swap cg(left), cg(right)
left = left + 1
right = right - 1
End If
Wend
End Select
End Sub
'***************************
'* Another specialized numeric sort: It is asymmetric, meaning sortation from reverse-ordered
'* datasets takes roughly twice as long. Even in this case, it is faster than FlashSort. This
'* sort method is EXTREMELY fast when used within design constraints: namely, integer and
'* consecutive sequential. UniqueIntegerSort is between 3 and 4 times
'* as fast as FlashSort, the fastest general-purpose number-specific sort in this library.
'* works only under specific circumstances and not easily adaptable to nonnumeric string
'* complexity class: O(n).
'***************************
Sub UniqueIntegerSort (cgSortLibArr() As Double, start As Long, finish As Long, order&)
For c& = start To finish
Do Until cgSortLibArr(c&) <= c& '* can be just = too.
Swap cgSortLibArr(c&), cgSortLibArr(cgSortLibArr(c&))
Loop
Next
If order& <> 1 Then
'* this step corrects asymmetric performance
'* since these are unique integers in a range,
'* restabilization is unnecessary.
StableInvert cgSortLibArr(), start, finish, 0
End If
'IF order& = 1 THEN
' FOR c& = start TO finish
' DO UNTIL a(c&) = c&
' SWAP a(c&), a(a(c&))
' LOOP
' NEXT
'ELSE
' FOR c& = start TO finish
' k& = finish - c&
' DO UNTIL a(c&) = k&
' SWAP a(c&), a(finish - a(c&))
' LOOP
' NEXT
'END IF
End Sub
'* do you need to know where an array of values balances? Good for balancing and constraint problems
'* such as maximum loading capacity.
Sub ApproximatelyEqualSums (cg() As Double, start As Long, finish As Long, order&, PartitionIndex&)
Dim lsum As Double: lindex& = start
Dim rsum As Double: rindex& = finish
lsum = 0
rsum = 0
Select Case order&
Case -1, 1
MergeSortEmerge cg(), start, finish, order&
While lindex& < rindex&
If rsum < lsum Then
rsum = rsum + cg(rindex&)
rindex& = rindex& - 1
Else
lsum = lsum + cg(lindex&)
lindex& = lindex& + 1
End If
Wend
Case Else
While lindex& < rindex&
If rsum > lsum Then
lsum = lsum + cg(rindex&)
lindex& = lindex& + 1
Else
rsum = rsum + cg(rindex&)
rindex& = rindex& - 1
End If
Wend
End Select
PartitionIndex& = lindex&
End Sub
'* Only works for integer nonnegative arrays
Sub AverageArray (cg() As Double, start As Long, finish As Long, Average#)
Dim xP As Double
Dim YP As Double
Dim yn As Double
Dim xn As Double
Dim bn As Double
Average# = 0
StatN& = finish - start + 1
For i& = start& To finish&
If cg(i&) < 0 Then
xn = xn + ch(i&) / StatN&
bn = cg(i&) Mod StatN&
If yn >= StatN& - bn Then
xn = xn + 1
yn = yn - StatN& - cg(i&)
Else
xn = xn - cg(i&)
End If
ElseIf cg(i&) > 0 Then
xP = xP + cg(i&) / StatN&
B = cg(i&) Mod StatN&
If YP >= N - B Then
xP = xP + 1
YP = YP - N + B
Else
YP = YP + B
End If
End If
Next
Average# = xP + YP / StatN&
End Sub
Sub CGStatMode (CGSortLibArr() As Long, start As Long, finish As Long, CGModeCountMaximum As Long, CGModeCountMaximumIndex As Long)
Dim CGModeNext As Long: CGModeNext = start + 1
Dim CGModePrev As Long: CGModePrev = start
Dim CModeCountCurrent As Long: CModeCountCurrent = 0
Do Until CGModeNext > finish
CModeCountCurrent = 0
Do
If CGModeNext > finish Then
Exit Do
Else
If CGSortLibArr(CGModeNext) = CGSortLibArr(CGModePrev) Then
CGModeNext = CGModeNext + 1
CModeCountCurrent = CModeCountCurrent + 1
Else
Exit Do
End If
End If
Loop
If CModeCountCurrent > CGModeCountMaximum Then
CGModeCountMaximumIndex = CGModePrev
CGModeCountMaximum = CModeCountCurrent
End If
CGModePrev = CGModeNext
CGModeNext = CGModePrev + 1
Loop
End Sub
'************************ 8156035173
Sub UniqueNumnberSort (cgSortLibArr() As Double, start As Long, finish As Long, order&)
Dim UNSMMrec As MinMaxRec
Dim UNSRange As Double
GetMinMaxArray cgSortLibArr(), start, finish, UNSMMrec
UNSRange = cgSortLibArr(UNSMMrec.max) - cgSortLibArr(UNSMMrec.min)
If UNSRange > 0 Then
Swap cgSortLibArr(start), cgSortLibArr(UNSMMrec.min)
Swap cgSortLibArr(finish), cgSortLibArr(UNSMMrec.max)
RangeDeltaPerOne# = UNSRange / (finish - start + 1)
ISum# = cgSortLibArr(UNSMMrec.min)
For c& = start + 1 To finish - 1
Do Until cgSortLibArr(c&) <= ISum# '* can be just = too.
Swap cgSortLibArr(c&), cgSortLibArr(cgSortLibArr(c&))
Loop
ISum# = ISum# + RangeDeltaPerOne#
Next
If order& <> 1 Then
'* this step corrects asymmetric performance
'* since these are unique integers in a range,
'* restabilization is unnecessary.
StableInvert cgSortLibArr(), start, finish, 0
End If
End If
InsertionSort cgSortLibArr(), start, finish, order&
End Sub
'**********************************************
'* the even FASTER version of FlashSort using the fastest vector min-max search I know.
'* short of using c++ STL, I don't believe there to be any faster method, even STL itself.
'*********************************************
Sub FlashSortGMMA (CGSortLibArr() As Double, start As Long, finish As Long, order&)
Dim FlashMM As MinMaxRec
'* GetMinMaxArrayIndexes CGSortLibArr(), start, finish, FlashMM.min, FlashMM.max
GetMinMaxArray CGSortLibArr(), start, finish, FlashMM
'* change these:
Dim hold As Double
Dim flash As Double
Dim ANMiN As Double
'* to the same type as the array being sorted
'* change these:
Dim KIndex As Long
Dim MIndex As Long
Dim SIndex As Long
'* to long for qbxx as qbxx has no _unsigned types
'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (Int(.128 * (finish - start + 1)) + 1) Or 2
'* change these:
Dim FlashTrackL(0 To MIndex) As Double
Dim FlashI As Long
Dim FlashJ As Long
Dim NextFlashJ As Long
Dim FlashNMove As Long
Dim FinishMinusOne As Long
'* to the appropriate type for the range being sorted (must match start, finish variables)
'* don't mess:
Dim FlashC1 As Double '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)
' sorts array A with finish elements by use of
' index vector L with M elements, with M ca. 0.128(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy
'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4&) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well. Note: For very large N, HashListSort()
'* works even faster and has a similar memory footprint. But yes, this is still faster than QuickSort for N>10000 and like
'* HashListSort, operates in asymptotically close to O(N) time.
Rem =============== CLASS FORMATION =================
';* ANMiN = CGSortLibArr(start)
Swap CGSortLibArr(FlashMM.min), CGSortLibArr(start): FlashMM.min = start: ANMiN = CGSortLibArr(FlashMM.min)
Swap CGSortLibArr(FlashMM.max), CGSortLibArr(finish): FlashMM.max = finish
If ANMiN = CGSortLibArr(FlashMM.max) Then
'* this is a monotonic sequence array and by definition is already sorted
Exit Sub
End If
Dim FlashTrackL(MIndex)
FlashC1 = (MIndex - 1) / (CGSortLibArr(FlashMM.max) - ANMiN)
For FlashI = start + 1 To finish - 1
KIndex = Int(FlashC1 * (CGSortLibArr(FlashI) - ANMiN)) + 1
FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
Next
For KIndex = LBound(FlashTrackL) + 1 To MIndex
FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
Next KIndex
Rem ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
While (FlashNMove < FinishMinusOne)
While (FlashJ > FlashTrackL(KIndex))
FlashJ = FlashJ + 1
KIndex = Int(FlashC1 * (CGSortLibArr(FlashJ) - ANMiN)) + 1
Wend
flash = CGSortLibArr(FlashJ)
Do
If (FlashJ = (FlashTrackL(KIndex) + 1)) Then
Exit Do
Else
If FlashNMove < (FinishMinusOne) Then
KIndex = Int(FlashC1 * (flash - ANMiN)) + 1
hold = CGSortLibArr(FlashTrackL(KIndex))
CGSortLibArr(FlashTrackL(KIndex)) = flash
flash = hold
FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
FlashNMove = FlashNMove + 1
Else
Exit Do
End If
End If
Loop
Wend
'================= Insertion Sort============
For SIndex = LBound(FlashTrackL) + 1 To MIndex
'* sort subranges
'********************* insertionsortz CGSortLibArr(), FlashTrackL(SIndex - 1), FlashTrackL(SIndex) - 1, order&
For FlashI = FlashTrackL(SIndex) - 1 To FlashTrackL(SIndex - 1) Step -1
If (CGSortLibArr(FlashI + 1) < CGSortLibArr(FlashI)) Then
hold = CGSortLibArr(FlashI)
NextFlashJ = FlashI
Do
FlashJ = NextFlashJ
If FlashJ < FlashTrackL(SIndex) Then
NextFlashJ = FlashJ + 1
If (CGSortLibArr(NextFlashJ) < hold) Then
Swap CGSortLibArr(FlashJ), CGSortLibArr(NextFlashJ)
Else
Exit Do
End If
Else
Exit Do
End If
Loop
CGSortLibArr(FlashJ) = hold
End If
Next
'* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
Next
If order& = 1 Then Exit Sub
FlashI = start
FlashJ = finish
While FlashJ > FlashI
Swap CGSortLibArr(FlashI), CGSortLibArr(FlashJ)
FlashI = FlashI + 1
FlashJ = FlashJ - 1
Wend
End Sub
Sub GetMinMaxArrayIndexes (cg() As Double, start&, finish&, MinMaxArrayMin As Long, MinMaxArrayMax As Long)
'DIM GetMinMaxArray_i AS LONG
Dim GetMinMaxArray_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&
int10000& = (finish& - start&) \ 10000
GetMinMaxArray_NMod2 = (finish& - start&) - 10000 * int10000&
'* GetMinMaxArray_NMod2 = GetMinMaxArray_n - 10000 * ((GetMinMaxArray_n - GetMinMaxArray_TT) / 10000)
If (GetMinMaxArray_NMod2 Mod 2) Then
MinMaxArrayMin = start&
MinMaxArrayMax = start&
GetMinMaxArray_i = start& + 1
Else
If cg(start&) > cg(finish&) Then
MinMaxArrayMax = start&
MinMaxArrayMin = finish&
Else
MinMaxArrayMin = finish&
MinMaxArrayMax = start&
End If
GetMinMaxArray_i = start& + 2
End If
While GetMinMaxArray_i < finish&
If cg(GetMinMaxArray_i) > cg(GetMinMaxArray_i + 1) Then
If cg(GetMinMaxArray_i) > cg(MinMaxArrayMax) Then
MinMaxArrayMax = GetMinMaxArray_i
End If
If cg(GetMinMaxArray_i + 1) < cg(MinMaxArrayMin) Then
MinMaxArrayMin = GetMinMaxArray_i + 1
End If
Else
If cg(GetMinMaxArray_i + 1) > cg(MinMaxArrayMax) Then
MinMaxArrayMax = GetMinMaxArray_i + 1
End If
If cg(GetMinMaxArray_i) < cg(MinMaxArrayMin) Then
MinMaxArrayMin = GetMinMaxArray_i
End If
End If
GetMinMaxArray_i = GetMinMaxArray_i + 2
Wend
End Sub
'***********************************
'* compares 2 arrays for similarity (equality or inequality).
'* equality will ONLY be satisfied if the range is the same AND all elements of subarrays are equal.
'***********************************
Function VectorComp% (CgSortArrayA() As Long, astart As Long, afinish As Long, CgSortArrayB() As Long, bstart As Long, bfinish As Long)
VectorCompA& = astart
VectorCompB& = bstart
Do
If VectorCompA& > afinish Then
If VectorCompB& > bfinish Then
VectorComp% = 0
Else
VectorComp% = -1
End If
Exit Function
Else
If VectorCompB& > bfinish Then
VectorComp% = 1
Exit Function
Else
If CgSortArrayA(VectorCompA&) = CgSortArrayB(VectorCompB&) Then
VectorCompA& = VectorCompA& + 1
VectorCompB& = VectorCompB& + 1
ElseIf CgSortArrayA(VectorCompA&) < CgSortArrayB(VectorCompB&) Then
VectorComp% = -1
Exit Function
Else
VectorComp% = 1
Exit Function
End If
End If
End If
Loop
End Function
'****************************
'* THE fastest stable sort I Invented. Just how fast? Compared to standard MergeSort,
'* MergeInsert is 25 percent faster and uses only half the memory. My other method may
'* be stable but it is not guaranteed.
'***************************
Sub MergeInsert (CGSortArray() As Double, start As Long, finish As Long, order&)
If finish - start > 5 Then
If (finish - start) And 0 Then
m& = start + (finish - start) / 4.390647888183594
MergeInsert CGSortArray(), start, m&, order&
MergeInsert CGSortArray(), m& + 1, finish, order&
Tim_merge CGSortArray(), start, m&, finish, order&
Else
m& = start + (finish - start) / 2
MergeInsert CGSortArray(), start, m&, order&
MergeInsert CGSortArray(), m& + 1, finish, order&
EfficientMerge CGSortArray(), start, finish, order&
End If
'ELSE
' InsertionSort CGSortArray(), start, finish, order&
End If
End Sub
Sub ExchangeSort (CgSortArray() As Double, start As Long, finish As Long, order&)
Dim ExchangeSort_i As Long
Dim ExchangeSort_j As Long
Select Case order&
Case 1
For ExchangeSort_i = start To finish - 1
For ExchangeSort_j = ExchangeSort_i + 1 To finish
If (CgSortArray(ExchangeSort_i) > CgSortArray(ExchangeSort_j)) Then
Swap CgSortArray(ExchangeSort_i), CgSortArray(ExchangeSort_j)
End If
Next
Next
Case Else
For ExchangeSort_i = start To finish - 1
For ExchangeSort_j = ExchangeSort_i + 1 To finish
If (CgSortArray(ExchangeSort_i) < CgSortArray(ExchangeSort_j)) Then
Swap CgSortArray(ExchangeSort_i), CgSortArray(ExchangeSort_j)
End If
Next
Next
End Select
End Sub
RE: CodeGuy's Sorting Collection - TerryRitchie - 04-29-2024
I remember when he was working on these. Great coder. Wish he was still around. Didn't he move in with Clippy or something?
RE: CodeGuy's Sorting Collection - Pete - 04-30-2024
Yeah, and he moved out when Zippy threw a coffee pot at him. (True story).
Pete
- When Clippy invites you for coffee, don't expect to get any sugar; you might just get creamed.
RE: CodeGuy's Sorting Collection - bplus - 04-30-2024
omg just a bit overwhelming
searching for mem tricks,... non?!
scanning code, i stumbled right onto one flaw about quicksort, CG has like 8 versions of it, one says in effect you don't need quick sort for an already sorted array or that is quick sorts main weakness thus my Load Sort is perfect complement to quick sort, for my own tool box anyway, i am a collector of only of the best of what i find and can work with easily. just need that mem trick to shift the array over.... working on it
imagine using quick sort every time you add an item to an array from the start at nothing, total that time up and see what a proper load sort can do for you, not saying i have it, yet!, but saying why i think it important ;-))
RE: CodeGuy's Sorting Collection - a740g - 04-30-2024
That's a treasure trove!
RE: CodeGuy's Sorting Collection - SMcNeill - 04-30-2024
(04-30-2024, 03:33 PM)bplus Wrote: omg just a bit overwhelming
searching for mem tricks,... non?!
scanning code, i stumbled right onto one flaw about quicksort, CG has like 8 versions of it, one says in effect you don't need quick sort for an already sorted array or that is quick sorts main weakness thus my Load Sort is perfect complement to quick sort, for my own tool box anyway, i am a collector of only of the best of what i find and can work with easily. just need that mem trick to shift the array over.... working on it
imagine using quick sort every time you add an item to an array from the start at nothing, total that time up and see what a proper load sort can do for you, not saying i have it, yet!, but saying why i think it important ;-))
Try the Flashsort. Last I checked, it was still faster than QuickSort in most instances.