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
Digg
del.icio.us
Newvine
furl
StumbleUpon
BlinkList
Newsvine
Magnolia
Facebook
Tailrank
Slashdot
Technorati
Google Bookmarks
Yahoo Favorites
Windows Live
Ask
