SortBase - Support sorting routines [ All Languages » VB »  Datastructure] Total Hit ( 2299) Rate this article:     Poor     Excellent   Submit Your Question/Comment about this article Rating

Click here to copy the following block Option Explicit Option Compare Binary Option Base 1 Public Type TRIAL   nKEYS As Long   nITS As Integer   PT As Long   TT As Long   ST As Long End Type Public Const RAD = 1 Public Const TQK = 2 Public Const QUI = 3 Public Const MER = 4 Public Const HEA = 5 Public Const COM = 6 Public Const SHE = 7 Public Const INS = 8 Public Const SEL = 9 Public Const LNG = 1 Public Const DBL = 2 Public Const STR = 3 Public Const MinDbl = -1.7976931348623E+308 Public Const MaxDbl = 1.7976931348623E+308 Public Const MinLng = -2147483647 Public Const MaxLng = 2147483647 Public Const MinStr = "              " Public Const MaxStr = "???????????????" Public TIMES(LNG To STR, RAD To SEL, 1 To 8) As TRIAL Public L0() As Long     'buffer for unsorted longs Public L1() As Long     'buffer for sorted longs Public L2() As Long     'extra buffer used by MergeSort Public D() As Double    'buffer for unsorted doubles Public pD0() As Long    'buffer for unsorted pointers to doubles Public S() As String    'buffer for unsorted strings Public pS0() As Long    'buffer for unsorted pointers to strings Public B() As Byte      'buffers used by TernaryQuickSort & MSDRadixSort Public pB() As Long Public P() As Long     'buffer used for sorted pointers Public RAW_LNGS As Range Public SORTED_LNGS As Range Public RAW_DBLS As Range Public SORTED_DBLS As Range Public RAW_STRS As Range Public SORTED_STRS As Range Public RESULTS As Range Public NAMES Public ROW As Integer Sub 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 LEVEL End Sub Sub WaitFor(NSECS As Long)   Dim TZERO As Long          TZERO = Timer   Do While Timer < TZERO + NSECS     DoEvents   Loop End Sub Sub 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 + 1 End Sub Sub 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 + 1 End Sub Sub 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 + 1 End Sub Sub 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 + 1 End Sub Sub Say(S As String)   Application.DisplayStatusBar = True   Application.StatusBar = S End Sub Sub 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) = MaxLng End Sub Sub 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 I End Sub Sub 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) = MaxDbl End Sub Sub 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 I End Sub Sub 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) = MaxStr End Sub Sub 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 I End Sub Sub 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 I End Sub Sub 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 StrNum End Sub Sub 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 I End Sub Sub 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 I End Sub Sub 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 I End Sub Sub 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 I End Sub Sub 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 I End Sub Sub 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 I End Sub

Related Article(s)

Submitted By : Nayan Patel  (Member Since : 5/26/2004 12:23:06 PM)
	Job Description : He is the moderator of this site and currently working as an independent consultant. He works with VB.net/ASP.net, SQL Server and other MS technologies. He is MCSD.net, MCDBA and MCSE. In his free time he likes to watch funny movies and doing oil painting.
View all (893) submissions by this author  (Birth Date : 7/14/1981 )