`Option ExplicitOption Compare BinaryOption Base 1Public Type TRIAL nKEYS As Long nITS As Integer PT As Long TT As Long ST As LongEnd TypePublic Const RAD = 1Public Const TQK = 2Public Const QUI = 3Public Const MER = 4Public Const HEA = 5Public Const COM = 6Public Const SHE = 7Public Const INS = 8Public Const SEL = 9Public Const LNG = 1Public Const DBL = 2Public Const STR = 3Public Const MinDbl = -1.7976931348623E+308Public Const MaxDbl = 1.7976931348623E+308Public Const MinLng = -2147483647Public Const MaxLng = 2147483647Public Const MinStr = " "Public Const MaxStr = "???????????????"Public TIMES(LNG To STR, RAD To SEL, 1 To 8) As TRIALPublic L0() As Long 'buffer for unsorted longsPublic L1() As Long 'buffer for sorted longsPublic L2() As Long 'extra buffer used by MergeSortPublic D() As Double 'buffer for unsorted doublesPublic pD0() As Long 'buffer for unsorted pointers to doublesPublic S() As String 'buffer for unsorted stringsPublic pS0() As Long 'buffer for unsorted pointers to stringsPublic B() As Byte 'buffers used by TernaryQuickSort & MSDRadixSortPublic pB() As LongPublic P() As Long 'buffer used for sorted pointersPublic RAW_LNGS As RangePublic SORTED_LNGS As RangePublic RAW_DBLS As RangePublic SORTED_DBLS As RangePublic RAW_STRS As RangePublic SORTED_STRS As RangePublic RESULTS As RangePublic NAMESPublic ROW As IntegerSub TrySorts() Dim NK Dim ITS Dim ITS2 Dim LEVEL As Integer Dim SORT As Integer Dim nKEYS As Long Dim nITS As Integer Dim nITS2 As Integer Dim T As Long Dim tL As Long Dim tD As Long Dim tS As Long Dim tB As Long Dim tL2 As Long Dim tD2 As Long Dim tS2 As Long Dim I As Integer NK = Array(150, 500, 1500, 5000, 15000, 50000, 150000, 500000) ITS = Array(3000, 1000, 300, 100, 30, 10, 3, 1) ITS2 = Array(2000, 200, 20, 2, 0, 0, 0, 0) NAMES = Array("RadixSort", "TernQuickSort", "QuickSort", "MergeSort", _ "HeapSort", "CombSort", "ShellSort", "InsertionSort", "SelectionSort") Say "Setting up ranges." Set RAW_LNGS = Cells(2, 1).Resize(50, 1) Set SORTED_LNGS = Cells(2, 2).Resize(50, 1) Set RAW_DBLS = Cells(2, 3).Resize(50, 1) Set SORTED_DBLS = Cells(2, 4).Resize(50, 1) Set RAW_STRS = Cells(2, 5).Resize(50, 1) Set SORTED_STRS = Cells(2, 6).Resize(50, 1) Set RESULTS = Cells(2, 8).Resize(1000, 8) RAW_LNGS.Clear SORTED_LNGS.Clear RAW_DBLS.Clear SORTED_DBLS.Clear RAW_STRS.Clear SORTED_STRS.Clear RESULTS.Clear Cells(1, 1).Value = "raw lngs" Cells(1, 2).Value = "sorted lngs" Cells(1, 3).Value = "raw dbls" Cells(1, 4).Value = "sorted dbls" Cells(1, 5).Value = "raw strs" Cells(1, 6).Value = "sorted strs" Cells(1, 8).Value = "sort" Cells(1, 9).Value = "type" Cells(1, 10).Value = "# of keys" Cells(1, 11).Value = "repeats" Cells(1, 12).Value = "prep time" Cells(1, 13).Value = "total time" Cells(1, 14).Value = "sort time" Cells(1, 15).Value = "time/rep" Say "Dimensioning arrays." ReDim L0(0 To 500001) ReDim L1(0 To 500001) ReDim L2(0 To 500001) ReDim D(0 To 500001) ReDim pD0(0 To 500001) ReDim S(0 To 500001) ReDim pS0(0 To 500001) ReDim B(0 To 5000001) ReDim pB(0 To 500001) ReDim P(0 To 500001) ROW = 1 For LEVEL = 4 To 8 Say "Level " & CStr(LEVEL) nKEYS = CLng(NK(LEVEL)) nITS = CInt(ITS(LEVEL)) nITS2 = CInt(ITS2(LEVEL)) Say "Measuring long prep times." GetRndLngs nKEYS, L0 ListLngs RAW_LNGS, L0, 50 ACopyL 1, nKEYS, L0, L1 T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 Next I tL = Timer - T T = Timer For I = 1 To nITS2 ACopyL 1, nKEYS, L0, L1 Next I tL2 = Timer - T Say "Measuring double prep times." GetRndDbls nKEYS, D, pD0 pListDbls RAW_DBLS, D, pD0, 50 ACopyL 1, nKEYS, pD0, P T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P Next I tD = Timer - T T = Timer For I = 1 To nITS2 ACopyL 1, nKEYS, pD0, P Next I tD2 = Timer - T Say "Measuring string prep times." GetRndStrs nKEYS, 10, S, pS0 pListStrs RAW_STRS, S, pS0, 50 ACopyL 1, nKEYS, pS0, P T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P Next I tS = Timer - T T = Timer For I = 1 To nITS2 ACopyL 1, nKEYS, pS0, P Next I tS2 = Timer - T Strs2Bytes S, 1, nKEYS, B, pB T = Timer For I = 1 To nITS Strs2Bytes S, 1, nKEYS, B, pB Next I tB = Timer - T For SORT = RAD To SEL Select Case SORT Case RAD RunSortB RAD, LEVEL, nKEYS, nITS, tB Case TQK RunSortB TQK, LEVEL, nKEYS, nITS, tB Case QUI RunSortL QUI, LEVEL, nKEYS, nITS, tL RunSortD QUI, LEVEL, nKEYS, nITS, tD RunSortS QUI, LEVEL, nKEYS, nITS, tS Case MER RunSortL MER, LEVEL, nKEYS, nITS, tL RunSortD MER, LEVEL, nKEYS, nITS, tD RunSortS MER, LEVEL, nKEYS, nITS, tS Case HEA RunSortL HEA, LEVEL, nKEYS, nITS, tL RunSortD HEA, LEVEL, nKEYS, nITS, tD RunSortS HEA, LEVEL, nKEYS, nITS, tS Case COM RunSortL COM, LEVEL, nKEYS, nITS, tL RunSortD COM, LEVEL, nKEYS, nITS, tD RunSortS COM, LEVEL, nKEYS, nITS, tS Case SHE RunSortL SHE, LEVEL, nKEYS, nITS, tL RunSortD SHE, LEVEL, nKEYS, nITS, tD RunSortS SHE, LEVEL, nKEYS, nITS, tS Case INS If LEVEL < 5 Then RunSortL INS, LEVEL, nKEYS, nITS2, tL2 RunSortD INS, LEVEL, nKEYS, nITS2, tD2 RunSortS INS, LEVEL, nKEYS, nITS2, tS2 End If Case SEL If LEVEL < 5 Then RunSortL SEL, LEVEL, nKEYS, nITS2, tL2 RunSortD SEL, LEVEL, nKEYS, nITS2, tD2 RunSortS SEL, LEVEL, nKEYS, nITS2, tS2 End If End Select Cells(2, 1).Resize(1000, 15).Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Cells(ROW, 1).Select Next SORT ROW = ROW + 1 Say "Waiting for possible break." Beep WaitFor 5 Next LEVELEnd SubSub WaitFor(NSECS As Long) Dim TZERO As Long TZERO = Timer Do While Timer < TZERO + NSECS DoEvents LoopEnd SubSub RunSortL(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _ PT As Long) Dim T As Long Dim I As Integer SORTED_LNGS.Clear Say NAMES(SORT) & " longs" Select Case SORT Case INS T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 InsertL 1, nKEYS, L1 Next I Case SEL T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 SelectionSortL 1, nKEYS, L1 Next I Case SHE T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 ShellSortL 1, nKEYS, L1 Next I Case COM T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 CombSortL 1, nKEYS, L1 Next I Case HEA T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 HeapSortL 1, nKEYS, L1 Next I Case MER T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 MergeSortL 1, nKEYS, L1, L2 Next I Case QUI T = Timer For I = 1 To nITS ACopyL 1, nKEYS, L0, L1 QuickSortL 1, nKEYS, L1 Next I End Select With TIMES(LNG, SORT, LEVEL) .nKEYS = nKEYS .nITS = nITS .PT = PT .TT = Timer - T .ST = .TT - .PT ListLngs SORTED_LNGS, L1, 50 RESULTS(ROW, 1).Value = NAMES(SORT) RESULTS(ROW, 2).Value = "long" RESULTS(ROW, 3).Value = nKEYS RESULTS(ROW, 4).Value = nITS RESULTS(ROW, 5).Value = .PT RESULTS(ROW, 6).Value = .TT RESULTS(ROW, 7).Value = .ST RESULTS(ROW, 8).Value = CDbl(.ST) / nITS End With ROW = ROW + 1End SubSub RunSortD(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _ PT As Long) Dim T As Long Dim I As Integer SORTED_DBLS.Clear Say NAMES(SORT) & " doubles" Select Case SORT Case INS T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pInsertD 1, nKEYS, D, P Next I Case SEL T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pSelectionSortD 1, nKEYS, D, P Next I Case SHE T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pShellSortD 1, nKEYS, D, P Next I Case COM T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pCombSortD 1, nKEYS, D, P Next I Case HEA T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pHeapSortD 1, nKEYS, D, P Next I Case MER T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pMergeSortD 1, nKEYS, D, P, L2 Next I Case QUI T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pD0, P pQuickSortD 1, nKEYS, D, P Next I End Select With TIMES(DBL, SORT, LEVEL) .nKEYS = nKEYS .nITS = nITS .PT = PT .TT = Timer - T .ST = .TT - .PT pListDbls SORTED_DBLS, D, P, 50 RESULTS(ROW, 1).Value = NAMES(SORT) RESULTS(ROW, 2).Value = "double" RESULTS(ROW, 3).Value = nKEYS RESULTS(ROW, 4).Value = nITS RESULTS(ROW, 5).Value = .PT RESULTS(ROW, 6).Value = .TT RESULTS(ROW, 7).Value = .ST RESULTS(ROW, 8).Value = CDbl(.ST) / nITS End With ROW = ROW + 1End SubSub RunSortS(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _ PT As Long) Dim T As Long Dim I As Integer SORTED_STRS.Clear Say NAMES(SORT) & " strings" Select Case SORT Case INS T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pInsertS 1, nKEYS, S, P Next I Case SEL T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pSelectionSortS 1, nKEYS, S, P Next I Case SHE T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pShellSortS 1, nKEYS, S, P Next I Case COM T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pCombSortS 1, nKEYS, S, P Next I Case HEA T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pHeapSortS 1, nKEYS, S, P Next I Case MER T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pMergeSortS 1, nKEYS, S, P, L2 Next I Case QUI T = Timer For I = 1 To nITS ACopyL 1, nKEYS, pS0, P pQuickSortS 1, nKEYS, S, P Next I End Select With TIMES(DBL, SORT, LEVEL) .nKEYS = nKEYS .nITS = nITS .PT = PT .TT = Timer - T .ST = .TT - .PT pListStrs SORTED_STRS, S, P, 50 RESULTS(ROW, 1).Value = NAMES(SORT) RESULTS(ROW, 2).Value = "string" RESULTS(ROW, 3).Value = nKEYS RESULTS(ROW, 4).Value = nITS RESULTS(ROW, 5).Value = .PT RESULTS(ROW, 6).Value = .TT RESULTS(ROW, 7).Value = .ST RESULTS(ROW, 8).Value = CDbl(.ST) / nITS End With ROW = ROW + 1End SubSub RunSortB(SORT As Integer, LEVEL As Integer, nKEYS As Long, nITS As Integer, _ PT As Long) Dim T As Long Dim I As Integer SORTED_STRS.Clear Say NAMES(SORT) & " strings" Select Case SORT Case RAD T = Timer For I = 1 To nITS Strs2Bytes S, 1, nKEYS, B, pB pRadixSortS B, pB, nKEYS Next I Case TQK T = Timer For I = 1 To nITS Strs2Bytes S, 1, nKEYS, B, pB pTernaryQuickSortS 1, nKEYS, B, pB Next I End Select With TIMES(STR, SORT, LEVEL) .nKEYS = nKEYS .nITS = nITS .PT = PT .TT = Timer - T .ST = .TT - .PT pListBytes SORTED_STRS, B, pB, nKEYS, 50 RESULTS(ROW, 1).Value = NAMES(SORT) RESULTS(ROW, 2).Value = "string" RESULTS(ROW, 3).Value = nKEYS RESULTS(ROW, 4).Value = nITS RESULTS(ROW, 5).Value = .PT RESULTS(ROW, 6).Value = .TT RESULTS(ROW, 7).Value = .ST RESULTS(ROW, 8).Value = CDbl(.ST) / nITS End With ROW = ROW + 1End SubSub Say(S As String) Application.DisplayStatusBar = True Application.StatusBar = SEnd SubSub LoadLngs(BLK As Range, A() As Long, N As Long) Dim ROW As Long Dim COL As Integer Dim V N = BLK.Columns.COUNT * BLK.Rows.COUNT If UBound(A) < N + 1 Then ReDim A(0 To N + 1) A(0) = MinLng N = 1 For COL = 1 To BLK.Columns.COUNT For ROW = 1 To BLK.Rows.COUNT V = BLK(ROW, COL).Value If Not IsEmpty(V) Then A(N) = CLng(V) N = N + 1 If N Mod 10000 = 0 Then Say CStr(N) & " longs loaded" End If Next ROW Next COL A(N) = MaxLngEnd SubSub ListLngs(BLK As Range, A() As Long, ByVal N As Long, _ Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1) Dim I As Long Dim ROW As Long Dim COL As Integer For I = 1 To N ROW = I Mod MAXROWS If ROW = 0 Then ROW = MAXROWS ElseIf ROW = 1 Then COL = COL + 1 If COL > MAXCOLS Then Exit Sub End If BLK(ROW, COL).Value = A(I) If I Mod 10000 = 0 Then Say CStr(I) & " longs listed" Next IEnd SubSub LoadDbls(BLK As Range, A() As Double, P() As Long, N As Long) Dim ROW As Long Dim COL As Integer Dim V N = BLK.Columns.COUNT * BLK.Rows.COUNT If UBound(A) < N + 1 Then ReDim A(0 To N + 1) A(0) = MinDbl N = 1 For COL = 1 To BLK.Columns.COUNT For ROW = 1 To BLK.Rows.COUNT V = BLK(ROW, COL).Value If Not IsEmpty(V) Then A(N) = CDbl(V) P(N) = N N = N + 1 If N Mod 10000 = 0 Then Say CStr(N) & " doubles loaded" End If Next ROW Next COL A(N) = MaxDblEnd SubSub pListDbls(BLK As Range, A() As Double, P() As Long, ByVal N As Long, _ Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1) Dim I As Long Dim ROW As Long Dim COL As Integer For I = 1 To N ROW = I Mod MAXROWS If ROW = 0 Then ROW = MAXROWS ElseIf ROW = 1 Then COL = COL + 1 If COL > MAXCOLS Then Exit Sub End If BLK(ROW, COL).Value = A(P(I)) If I Mod 10000 = 0 Then Say CStr(I) & " doubles listed" Next IEnd SubSub LoadStrs(BLK As Range, A() As String, P() As Long, N As Long) Dim ROW As Long Dim COL As Integer Dim V N = BLK.Columns.COUNT * BLK.Rows.COUNT If UBound(A) < N + 1 Then ReDim A(0 To N + 1) A(0) = MinStr N = 1 For COL = 1 To BLK.Columns.COUNT For ROW = 1 To BLK.Rows.COUNT V = BLK(ROW, COL).Value If Not IsEmpty(V) Then A(N) = CStr(V) P(N) = N N = N + 1 If N Mod 10000 = 0 Then Say CStr(N) & " strings loaded" End If Next ROW Next COL A(N) = MaxStrEnd SubSub pListStrs(BLK As Range, A() As String, P() As Long, ByVal N As Long, _ Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1) Dim I As Long Dim ROW As Long Dim COL As Integer For I = 1 To N ROW = I Mod MAXROWS If ROW = 0 Then ROW = MAXROWS ElseIf ROW = 1 Then COL = COL + 1 If COL > MAXCOLS Then Exit Sub End If BLK(ROW, COL).Value = A(P(I)) If I Mod 10000 = 0 Then Say CStr(I) & " strings listed" Next IEnd SubSub pListBytes(BLK As Range, B() As Byte, P() As Long, ByVal N As Long, _ Optional MAXROWS As Long = 50000, Optional MAXCOLS As Integer = 1) Dim I As Long Dim ROW As Long Dim COL As Integer Dim J As Long Dim S As String For I = 1 To N ROW = I Mod MAXROWS If ROW = 0 Then ROW = MAXROWS ElseIf ROW = 1 Then COL = COL + 1 If COL > MAXCOLS Then Exit Sub End If S = "" J = P(I) Do S = S & Chr(B(J)) J = J + 1 Loop Until B(J) = 0 BLK(ROW, COL).Value = S If I Mod 10000 = 0 Then Say CStr(I) & " strings listed" Next IEnd SubSub Strs2Bytes(A() As String, L As Long, R As Long, B() As Byte, P() As Long) Dim StrNum As Long Dim nPtrs As Long Dim nBytes As Long Dim DEPTH As Integer nBytes = 0 nPtrs = 0 For StrNum = L To R nBytes = nBytes + Strings.Len(A(StrNum)) + 1 nPtrs = nPtrs + 1 Next StrNum ReDim B(1 To nBytes) ReDim P(1 To nPtrs) nPtrs = 1 nBytes = 1 For StrNum = L To R P(nPtrs) = nBytes For DEPTH = 1 To Strings.Len(A(StrNum)) B(nBytes) = Asc(Strings.MID(A(StrNum), DEPTH, 1)) nBytes = nBytes + 1 Next DEPTH B(nBytes) = 0 nBytes = nBytes + 1 nPtrs = nPtrs + 1 If StrNum Mod 10000 = 0 Then Say CStr(StrNum) & " converted" Next StrNumEnd SubSub ACopyS(L As Long, R As Long, A() As String, B() As String) Dim I As Long For I = L To R B(I) = A(I) Next IEnd SubSub ACopyL(L As Long, R As Long, A() As Long, B() As Long) Dim I As Long For I = L To R B(I) = A(I) Next IEnd SubSub ACopyD(L As Long, R As Long, A() As Double, B() As Double) Dim I As Long For I = L To R B(I) = A(I) Next IEnd SubSub GetRndStrs(CNT As Long, LENGTH As Integer, A() As String, P() As Long) Dim I As Long Dim J As Integer Dim C As Integer Dim S As String Randomize ReDim A(0 To CNT + 1) For I = 1 To CNT S = "" For J = 1 To LENGTH C = (Rnd() * 2999) Mod 47 If C < 10 Then C = C + 48 ElseIf C = 46 Then C = 32 Else C = C + 55 End If If C > 90 Then If I < 1 Then Exit For Else S = S & Strings.Chr(C) End If Next J J = 1 While Strings.MID(S, J, 1) = " " J = J + 1 Wend A(I) = Strings.MID(S, J) P(I) = I If I Mod 1000 = 0 Then Say "GetRndStrs " & CStr(I) Next IEnd SubSub GetRndDbls(CNT As Long, A() As Double, P() As Long) Dim I As Long Dim D As Double Randomize ReDim A(0 To CNT + 1) For I = 1 To CNT D = CDbl(Exp(Rnd() * WorksheetFunction.LN(MaxDbl))) If Rnd < 0.5 Then A(I) = -D Else A(I) = D P(I) = I Next IEnd SubSub GetRndLngs(CNT As Long, A() As Long) Dim I As Long Dim L As Long Randomize ReDim A(0 To CNT + 1) For I = 1 To CNT L = CLng(Exp(Rnd() * WorksheetFunction.LN(MaxLng))) If Rnd < 0.5 Then A(I) = -L Else A(I) = L Next IEnd Sub`