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