有史以来最快的希尔排序 - 比历史贴快10倍，比Excel排序更快 - 兼论堆排序和快速排序

Zamyi · 发表于 2015-4-27 15:08

loquat 发表于 2015-4-27 14:56
1.法师大侠，我拿您的代码出去交流，结果别人给我了一段很简单的快排代码。比您本帖提供的快了将近50%
我 ...

1、你那排序结果不对；
2、要比较，需在同条件下，数组、变量类型都要相同。

loquat · 发表于 2015-4-27 15:47

Zamyi 发表于 2015-4-27 15:08
1、你那排序结果不对；
2、要比较，需在同条件下，数组、变量类型都要相同。

的确发现结果有误，继续研究。。。

loquat · 发表于 2015-4-27 16:28

对楼主的代码稍作优化，使用模拟堆栈提高效率。

Option Explicit
'///////////////////////////////////////////////////////////////
'// QucikSort_V2 function class
'//
'// LastUpdate:2004-1-22
'// by Kwanhong Young (r4c Studio)
'--
'-- Updated: 20150427
'-- by loquat
'--
'///////////////////////////////////////////////////////////////
Private stack As cStack_long
Private Sub Class_Initialize()
Set stack = New cStack_long
End Sub
Private Sub Class_Terminate()
Set stack = Nothing
End Sub
Private Sub QuickSort(ByRef key_arr() As Long, L As Long, R As Long)
Dim i As Long, j As Long, a As Long, b As Long, Mid As Long, offset As Long
Dim Pivot, Swap
If R - L <= 60 Then
For offset = 0 To 18
For i = L + offset To R Step 19
Swap = key_arr(i)
For j = i - 19 To L + offset Step -19
If Swap < key_arr(j) Then
key_arr(j + 19) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Next offset
For offset = 0 To 4
For i = L + offset To R Step 5
Swap = key_arr(i)
For j = i - 5 To L + offset Step -5
If Swap < key_arr(j) Then
key_arr(j + 5) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Next offset
For i = L + 1 To R
Swap = key_arr(i)
For j = i - 1 To L Step -1
If Swap < key_arr(j) Then
key_arr(j + 1) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Else
Mid = L + 1 + Int(Rnd * (R - L - 1))
' Mid = (L + R) / 2
If key_arr(L) > key_arr(R) Then
Swap = key_arr(R)
key_arr(R) = key_arr(L)
key_arr(L) = Swap
End If
If key_arr(Mid) > key_arr(R) Then
Swap = key_arr(R)
key_arr(R) = key_arr(Mid)
key_arr(Mid) = Swap
End If
If key_arr(L) > key_arr(Mid) Then
Swap = key_arr(L)
key_arr(L) = key_arr(Mid)
key_arr(Mid) = Swap
End If
Pivot = key_arr(Mid)
key_arr(Mid) = key_arr(R - 1)
key_arr(R - 1) = Pivot
i = L + 1
j = R - 2
While (i < j)
For i = i To R
If key_arr(i) >= Pivot Then Exit For
Next i
For j = j To L Step -1
If key_arr(j) <= Pivot Then Exit For
Next j
If (i < j) Then
Swap = key_arr(i)
key_arr(i) = key_arr(j)
key_arr(j) = Swap
i = i + 1
j = j - 1
End If
Wend
For a = j To L Step -1
If key_arr(a) < Pivot Then Exit For
Next a
For b = i To R
If key_arr(b) > Pivot Then Exit For
Next b
'递归方法
'If (L < A) Then Call QuickSort(key_arr, L, A)
'If (B < R) Then Call QuickSort(key_arr, B, R)
'压栈方法
If (b < R) Then
stack.Push b
stack.Push R
End If
If (L < a) Then
stack.Push L
stack.Push a
End If
End If
End Sub
Public Sub StartSort(ByRef vArray() As Long)
Dim iLow As Long
Dim iHi As Long
'//get range of array
iLow = LBound(vArray) '//Low bound
iHi = UBound(vArray) '//High bound
'//push low value to stack first
stack.Push iLow
stack.Push iHi
'//use STACK, not RECURSION
Do
iHi = stack.Pop
iLow = stack.Pop
QuickSort vArray(), iLow, iHi '//call the procedure
Loop Until stack.Count = 0
End Sub
;----cStack_Long.cls----
Option Explicit
'-----------------------------------------------------------------------
'堆栈 (stack) - FOR LONG DATA TYPE
'数据结构中的 Stack，有Push、Pop、Peek等方法
'
'LastUpdate:2004-1-23
'by Kwanhong Young (r4c Studio)
'-----------------------------------------------------------------------
Private sItem() As Long
Private iCount As Long
Private Sub Class_Initialize()
'//start...
ReDim sItem(0)
iCount = 0
End Sub
Private Sub Class_Terminate()
'//over
ReDim sItem(0)
iCount = 0
End Sub
Public Sub Push(ByVal vValue As Long)
sItem(iCount) = vValue
iCount = iCount + 1
ReDim Preserve sItem(iCount)
End Sub
Public Function Pop() As Long
If iCount > 0 Then
iCount = iCount - 1
Pop = sItem(iCount)
ReDim Preserve sItem(iCount)
End If
End Function
Public Function Peek() As Long
If iCount > 0 Then Peek = sItem(iCount - 1)
End Function
Public Property Get Count() As Long
Count = iCount
End Property
Public Sub GetAllItem(itm() As Long)
ReDim itm(iCount)
Dim i As Long
For i = 0 To iCount - 1
itm(i) = sItem(i)
Next
End Sub
Public Function GetAllItem_toString(Optional ByVal cDelimiter As String = "|") As String
If iCount = 0 Then Exit Function
GetAllItem_toString = Join(sItem, cDelimiter)
End Function

复制代码

loquat · 发表于 2015-4-27 16:32

另贴一个函数供交流，vbgood acme_pjz从qsort.c翻译来的代码。
http://www.vbgood.com/thread-89774-1-1.html
本楼代码默认是翻译的代码，如果设置成UseMSVCRT = 1，则使用系统msvcrt.dll中qsort

Option Explicit
#Const UseMSVCRT = 0
#If UseMSVCRT Then '使用msvcrt.dll中的qsort函数
'/***
'*qsort(base, num, wid, comp) - quicksort function for sorting arrays
'*
'*Purpose:
'* quicksort the array of elements
'* side effects: sorts in place
'* maximum array size is number of elements times size of elements,
'* but is limited by the virtual address space of the processor
'*
'*Entry:
'* char *base = pointer to base of array
'* size_t num = number of elements in the array
'* size_t width = width in bytes of each array element
'* int (*comp)() = pointer to function returning analog of strcmp for
'* strings, but supplied by user for comparing the array elements.
'* it accepts 2 pointers to elements.
'* Returns neg if 1<2, 0 if 1=2, pos if 1>2.
'*
'*Exit:
'* returns void
'*
'*Exceptions:
'* Input parameters are validated. Refer to the validation section of the function.
'*
'*******************************************************************************/
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private m_bCode(255) As Byte, m_hMod As Long, m_lpFunc As Long
Private m_lpObjPtr As Long, m_nUserData As Long
#End If
Public Function Compare(ByVal Index1 As Long, ByVal Index2 As Long, ByVal nUserData As Long) As Long
'default implementation (???)
If Index1 < Index2 Then Compare = -1 Else _
If Index1 > Index2 Then Compare = 1 Else Compare = 0
End Function
Friend Sub QuickSort(idxArray() As Long, ByVal nStart As Long, ByVal nEnd As Long, Optional ByVal obj As ISort2, Optional ByVal nUserData As Long, Optional ByVal nLimit As Long = 8)
'///check
If nEnd - nStart <= 1 Then Exit Sub
If obj Is Nothing Then Set obj = Me
'///
#If UseMSVCRT Then
If m_lpFunc Then
m_lpObjPtr = ObjPtr(obj)
m_nUserData = nUserData
CallWindowProc VarPtr(m_bCode(0)), VarPtr(idxArray(nStart)), nEnd - nStart + 1, m_lpFunc, 0
Exit Sub
End If
#Else
'////////////////////////////////TODO:translate qsort.c into VB
Dim i As Long, j As Long, k As Long 'temp
Dim nMid As Long '/* points to middle of subarray */
Dim lpStart As Long, lpEnd As Long '/* traveling pointers for partition step */
Dim nSize As Long '/* size of the sub-array */
Dim nStartStack(31) As Long, nEndStack(31) As Long, nStack As Long '/* stack for saving sub-array to be processed */
'/* this entry point is for pseudo-recursion calling: setting
' lo and hi and jumping to here is like recursion, but stkptr is
' preserved, locals aren't, so we preserve stuff on the stack */
Recurse:
'size = (hi - lo) / width + 1; /* number of el's to sort */
nSize = nEnd - nStart + 1
'/* below a certain size, it is faster to use a O(n^2) sorting method */
If nSize <= nLimit Then
'shortsort
If nSize > 1 Then
Do
lpStart = nStart
i = idxArray(lpStart)
For lpEnd = nStart + 1 To nEnd
j = idxArray(lpEnd)
If obj.Compare(j, i, nUserData) > 0 Then lpStart = lpEnd: i = j
Next lpEnd
If lpStart < nEnd Then idxArray(lpStart) = idxArray(nEnd): idxArray(nEnd) = i
nEnd = nEnd - 1
Loop While nEnd > nStart
End If
Else
' /* First we pick a partitioning element. The efficiency of the
' algorithm demands that we find one that is approximately the median
' of the values, but also that we select one fast. We choose the
' median of the first, middle, and last elements, to avoid bad
' performance in the face of already sorted data, or data that is made
' up of multiple sorted runs appended together. Testing shows that a
' median-of-three algorithm provides better performance than simply
' picking the middle element for the latter case. */
' mid = lo + (size / 2) * width; /* find middle element */
nMid = nStart + nSize \ 2
'
' /* Sort the first, middle, last elements into order */
' if (__COMPARE(context, lo, mid) > 0) swap(lo, mid, width);
i = idxArray(nStart): j = idxArray(nMid)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nStart) = j: idxArray(nMid) = i
' if (__COMPARE(context, lo, hi) > 0) swap(lo, hi, width);
i = idxArray(nStart): j = idxArray(nEnd)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nStart) = j: idxArray(nEnd) = i
' if (__COMPARE(context, mid, hi) > 0) swap(mid, hi, width);
i = idxArray(nMid): j = idxArray(nEnd)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nMid) = j: idxArray(nEnd) = i
'
' /* We now wish to partition the array into three pieces, one consisting
' of elements <= partition element, one of elements equal to the
' partition element, and one of elements > than it. This is done
' below; comments indicate conditions established at every step. */
'
' loguy = lo;
' higuy = hi;
lpStart = nStart
lpEnd = nEnd
'
' /* Note that higuy decreases and loguy increases on every iteration,
' so loop must terminate. */
' for (;;) {
Do
' /* lo <= loguy < hi, lo < higuy <= hi,
' A[i] <= A[mid] for lo <= i <= loguy,
' A[i] > A[mid] for higuy <= i < hi,
' A[hi] >= A[mid] */
'
' /* The doubled loop is to avoid calling comp(mid,mid), since some
' existing comparison funcs don't work when passed the same
' value for both pointers. */
i = idxArray(nMid)
' if (mid > loguy) {
' do {
' loguy += width;
' } while (loguy < mid && __COMPARE(context, loguy, mid) <= 0);
' }
If nMid > lpStart Then
Do
lpStart = lpStart + 1
j = idxArray(lpStart)
If lpStart >= nMid Then Exit Do
Loop While obj.Compare(j, i, nUserData) <= 0
End If
' if (mid <= loguy) {
' do {
' loguy += width;
' } while (loguy <= hi && __COMPARE(context, loguy, mid) <= 0);
' }
If nMid <= lpStart Then
Do
lpStart = lpStart + 1
If lpStart > nEnd Then Exit Do
j = idxArray(lpStart)
Loop While obj.Compare(j, i, nUserData) <= 0
End If
'
' /* lo < loguy <= hi+1, A[i] <= A[mid] for lo <= i < loguy,
' either loguy > hi or A[loguy] > A[mid] */
'
' do {
' higuy -= width;
' } while (higuy > mid && __COMPARE(context, higuy, mid) > 0);
Do
lpEnd = lpEnd - 1
k = idxArray(lpEnd)
If lpEnd <= nMid Then Exit Do
Loop While obj.Compare(k, i, nUserData) > 0
'
' /* lo <= higuy < hi, A[i] > A[mid] for higuy < i < hi,
' either higuy == lo or A[higuy] <= A[mid] */
'
' if (higuy < loguy)
' break;
If lpEnd < lpStart Then Exit Do
'
' /* if loguy > hi or higuy == lo, then we would have exited, so
' A[loguy] > A[mid], A[higuy] <= A[mid],
' loguy <= hi, higuy > lo */
'
' swap(loguy, higuy, width);
If lpEnd > lpStart Then idxArray(lpStart) = k: idxArray(lpEnd) = j
'
' /* If the partition element was moved, follow it. Only need
' to check for mid == higuy, since before the swap,
' A[loguy] > A[mid] implies loguy != mid. */
'
' if (mid == higuy)
' mid = loguy;
If nMid = lpEnd Then nMid = lpStart
'
' /* A[loguy] <= A[mid], A[higuy] > A[mid]; so condition at top
' of loop is re-established */
' }
Loop
'
' /* A[i] <= A[mid] for lo <= i < loguy,
' A[i] > A[mid] for higuy < i < hi,
' A[hi] >= A[mid]
' higuy < loguy
' implying:
' higuy == loguy-1
' or higuy == hi - 1, loguy == hi + 1, A[hi] == A[mid] */
'
' /* Find adjacent elements equal to the partition element. The
' doubled loop is to avoid calling comp(mid,mid), since some
' existing comparison funcs don't work when passed the same value
' for both pointers. */
'
' higuy += width;
lpEnd = lpEnd + 1
' if (mid < higuy) {
' do {
' higuy -= width;
' } while (higuy > mid && __COMPARE(context, higuy, mid) == 0);
' }
i = idxArray(nMid)
If nMid < lpEnd Then
Do
lpEnd = lpEnd - 1
If lpEnd <= nMid Then Exit Do
Loop While obj.Compare(idxArray(lpEnd), i, nUserData) = 0
End If
' if (mid >= higuy) {
' do {
' higuy -= width;
' } while (higuy > lo && __COMPARE(context, higuy, mid) == 0);
' }
If nMid >= lpEnd Then
Do
lpEnd = lpEnd - 1
If lpEnd <= nStart Then Exit Do
Loop While obj.Compare(idxArray(lpEnd), i, nUserData) = 0
End If
'
' /* OK, now we have the following:
' higuy < loguy
' lo <= higuy <= hi
' A[i] <= A[mid] for lo <= i <= higuy
' A[i] == A[mid] for higuy < i < loguy
' A[i] > A[mid] for loguy <= i < hi
' A[hi] >= A[mid] */
'
' /* We've finished the partition, now we want to sort the subarrays
' [lo, higuy] and [loguy, hi].
' We do the smaller one first to minimize stack usage.
' We only sort arrays of length 2 or more.*/
'
' if ( higuy - lo >= hi - loguy ) {
If lpEnd - nStart >= nEnd - lpStart Then
' if (lo < higuy) {
' lostk[stkptr] = lo;
' histk[stkptr] = higuy;
' ++stkptr;
' } /* save big recursion for later */
If nStart < lpEnd Then
nStartStack(nStack) = nStart
nEndStack(nStack) = lpEnd
nStack = nStack + 1
End If
' if (loguy < hi) {
' lo = loguy;
' goto recurse; /* do small recursion */
' }
If lpStart < nEnd Then
nStart = lpStart
GoTo Recurse
End If
' }
Else
' else {
' if (loguy < hi) {
' lostk[stkptr] = loguy;
' histk[stkptr] = hi;
' ++stkptr; /* save big recursion for later */
' }
If lpStart < nEnd Then
nStartStack(nStack) = lpStart
nEndStack(nStack) = nEnd
nStack = nStack + 1
End If
'
' if (lo < higuy) {
' hi = higuy;
' goto recurse; /* do small recursion */
' }
If nStart < lpEnd Then
nEnd = lpEnd
GoTo Recurse
End If
' }
End If
End If
'/* We have sorted the array, except for any pending sorts on the stack.
' Check if there are any, and do them. */
nStack = nStack - 1
If nStack >= 0 Then
nStart = nStartStack(nStack)
nEnd = nEndStack(nStack)
GoTo Recurse '/* pop subarray from stack */
End If
'else
' return; /* all subarrays done */
'////////////////////////////////
#End If
End Sub
#If UseMSVCRT Then
Private Sub Class_Initialize()
Dim s As String
'///
m_hMod = LoadLibrary("msvcrt.dll")
m_lpFunc = GetProcAddress(m_hMod, "qsort")
'///
s = "89 E0 E8 00 00 00 00 83 04 24 15 6A 04 FF 70 08" + _
"FF 70 04 FF 50 0C 83 C4 10 C2 10 00 6A 00 89 E0" + _
"8B 15 ObjPtr 50 FF 35 UserData 8B 48 0C" + _
"8B 40 08 FF 31 FF 30 8B 0A 52 FF 51 1C 58 C3"
s = Replace(s, "ObjPtr", ReverseHex(VarPtr(m_lpObjPtr)))
s = Replace(s, "UserData", ReverseHex(VarPtr(m_nUserData)))
CodeFromString s, m_bCode
End Sub
Private Sub Class_Terminate()
FreeLibrary m_hMod
End Sub
Private Sub CodeFromString(ByVal s As String, ByRef b() As Byte)
Dim m As Long, i As Long
s = Replace(s, " ", "")
s = Replace(s, ",", "")
m = Len(s) \ 2
For i = 0 To m - 1
b(i) = Val("&H" + Mid(s, i + i + 1, 2))
Next i
End Sub
Private Function ReverseHex(ByVal n As Long) As String
Dim s As String
s = Right("00000000" + Hex(n), 8)
ReverseHex = Mid(s, 7, 2) + Mid(s, 5, 2) + Mid(s, 3, 2) + Mid(s, 1, 2)
End Function
#End If

复制代码

loquat · 发表于 2015-4-27 16:46

一个代码供大婶们来修改上文代码，vbGood坛acme_pjz翻译的qsort.c
上文主要是两个类模块，应该可以只用一个做到吧

Option Explicit
#Const UseMSVCRT = 0
#If UseMSVCRT Then
'/***
'*qsort(base, num, wid, comp) - quicksort function for sorting arrays
'*
'*Purpose:
'* quicksort the array of elements
'* side effects: sorts in place
'* maximum array size is number of elements times size of elements,
'* but is limited by the virtual address space of the processor
'*
'*Entry:
'* char *base = pointer to base of array
'* size_t num = number of elements in the array
'* size_t width = width in bytes of each array element
'* int (*comp)() = pointer to function returning analog of strcmp for
'* strings, but supplied by user for comparing the array elements.
'* it accepts 2 pointers to elements.
'* Returns neg if 1<2, 0 if 1=2, pos if 1>2.
'*
'*Exit:
'* returns void
'*
'*Exceptions:
'* Input parameters are validated. Refer to the validation section of the function.
'*
'*******************************************************************************/
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private m_bCode(255) As Byte, m_hMod As Long, m_lpFunc As Long
Private m_lpObjPtr As Long, m_nUserData As Long
#End If
Public Function Compare(ByVal Index1 As Long, ByVal Index2 As Long, ByVal nUserData As Long) As Long
'default implementation (???)
If Index1 < Index2 Then Compare = -1 Else _
If Index1 > Index2 Then Compare = 1 Else Compare = 0
End Function
Friend Sub QuickSort(idxArray() As Long, ByVal nStart As Long, ByVal nEnd As Long, Optional ByVal obj As ISort2, Optional ByVal nUserData As Long, Optional ByVal nLimit As Long = 8)
'///check
If nEnd - nStart <= 1 Then Exit Sub
If obj Is Nothing Then Set obj = Me
'///
#If UseMSVCRT Then
If m_lpFunc Then
m_lpObjPtr = ObjPtr(obj)
m_nUserData = nUserData
CallWindowProc VarPtr(m_bCode(0)), VarPtr(idxArray(nStart)), nEnd - nStart + 1, m_lpFunc, 0
Exit Sub
End If
#Else
'////////////////////////////////TODO:translate qsort.c into VB
Dim i As Long, j As Long, k As Long 'temp
Dim nMid As Long '/* points to middle of subarray */
Dim lpStart As Long, lpEnd As Long '/* traveling pointers for partition step */
Dim nSize As Long '/* size of the sub-array */
Dim nStartStack(31) As Long, nEndStack(31) As Long, nStack As Long '/* stack for saving sub-array to be processed */
'/* this entry point is for pseudo-recursion calling: setting
' lo and hi and jumping to here is like recursion, but stkptr is
' preserved, locals aren't, so we preserve stuff on the stack */
Recurse:
'size = (hi - lo) / width + 1; /* number of el's to sort */
nSize = nEnd - nStart + 1
'/* below a certain size, it is faster to use a O(n^2) sorting method */
If nSize <= nLimit Then
'shortsort
If nSize > 1 Then
Do
lpStart = nStart
i = idxArray(lpStart)
For lpEnd = nStart + 1 To nEnd
j = idxArray(lpEnd)
If obj.Compare(j, i, nUserData) > 0 Then lpStart = lpEnd: i = j
Next lpEnd
If lpStart < nEnd Then idxArray(lpStart) = idxArray(nEnd): idxArray(nEnd) = i
nEnd = nEnd - 1
Loop While nEnd > nStart
End If
Else
' /* First we pick a partitioning element. The efficiency of the
' algorithm demands that we find one that is approximately the median
' of the values, but also that we select one fast. We choose the
' median of the first, middle, and last elements, to avoid bad
' performance in the face of already sorted data, or data that is made
' up of multiple sorted runs appended together. Testing shows that a
' median-of-three algorithm provides better performance than simply
' picking the middle element for the latter case. */
' mid = lo + (size / 2) * width; /* find middle element */
nMid = nStart + nSize \ 2
'
' /* Sort the first, middle, last elements into order */
' if (__COMPARE(context, lo, mid) > 0) swap(lo, mid, width);
i = idxArray(nStart): j = idxArray(nMid)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nStart) = j: idxArray(nMid) = i
' if (__COMPARE(context, lo, hi) > 0) swap(lo, hi, width);
i = idxArray(nStart): j = idxArray(nEnd)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nStart) = j: idxArray(nEnd) = i
' if (__COMPARE(context, mid, hi) > 0) swap(mid, hi, width);
i = idxArray(nMid): j = idxArray(nEnd)
If obj.Compare(i, j, nUserData) > 0 Then idxArray(nMid) = j: idxArray(nEnd) = i
'
' /* We now wish to partition the array into three pieces, one consisting
' of elements <= partition element, one of elements equal to the
' partition element, and one of elements > than it. This is done
' below; comments indicate conditions established at every step. */
'
' loguy = lo;
' higuy = hi;
lpStart = nStart
lpEnd = nEnd
'
' /* Note that higuy decreases and loguy increases on every iteration,
' so loop must terminate. */
' for (;;) {
Do
' /* lo <= loguy < hi, lo < higuy <= hi,
' A[i] <= A[mid] for lo <= i <= loguy,
' A[i] > A[mid] for higuy <= i < hi,
' A[hi] >= A[mid] */
'
' /* The doubled loop is to avoid calling comp(mid,mid), since some
' existing comparison funcs don't work when passed the same
' value for both pointers. */
i = idxArray(nMid)
' if (mid > loguy) {
' do {
' loguy += width;
' } while (loguy < mid && __COMPARE(context, loguy, mid) <= 0);
' }
If nMid > lpStart Then
Do
lpStart = lpStart + 1
j = idxArray(lpStart)
If lpStart >= nMid Then Exit Do
Loop While obj.Compare(j, i, nUserData) <= 0
End If
' if (mid <= loguy) {
' do {
' loguy += width;
' } while (loguy <= hi && __COMPARE(context, loguy, mid) <= 0);
' }
If nMid <= lpStart Then
Do
lpStart = lpStart + 1
If lpStart > nEnd Then Exit Do
j = idxArray(lpStart)
Loop While obj.Compare(j, i, nUserData) <= 0
End If
'
' /* lo < loguy <= hi+1, A[i] <= A[mid] for lo <= i < loguy,
' either loguy > hi or A[loguy] > A[mid] */
'
' do {
' higuy -= width;
' } while (higuy > mid && __COMPARE(context, higuy, mid) > 0);
Do
lpEnd = lpEnd - 1
k = idxArray(lpEnd)
If lpEnd <= nMid Then Exit Do
Loop While obj.Compare(k, i, nUserData) > 0
'
' /* lo <= higuy < hi, A[i] > A[mid] for higuy < i < hi,
' either higuy == lo or A[higuy] <= A[mid] */
'
' if (higuy < loguy)
' break;
If lpEnd < lpStart Then Exit Do
'
' /* if loguy > hi or higuy == lo, then we would have exited, so
' A[loguy] > A[mid], A[higuy] <= A[mid],
' loguy <= hi, higuy > lo */
'
' swap(loguy, higuy, width);
If lpEnd > lpStart Then idxArray(lpStart) = k: idxArray(lpEnd) = j
'
' /* If the partition element was moved, follow it. Only need
' to check for mid == higuy, since before the swap,
' A[loguy] > A[mid] implies loguy != mid. */
'
' if (mid == higuy)
' mid = loguy;
If nMid = lpEnd Then nMid = lpStart
'
' /* A[loguy] <= A[mid], A[higuy] > A[mid]; so condition at top
' of loop is re-established */
' }
Loop
'
' /* A[i] <= A[mid] for lo <= i < loguy,
' A[i] > A[mid] for higuy < i < hi,
' A[hi] >= A[mid]
' higuy < loguy
' implying:
' higuy == loguy-1
' or higuy == hi - 1, loguy == hi + 1, A[hi] == A[mid] */
'
' /* Find adjacent elements equal to the partition element. The
' doubled loop is to avoid calling comp(mid,mid), since some
' existing comparison funcs don't work when passed the same value
' for both pointers. */
'
' higuy += width;
lpEnd = lpEnd + 1
' if (mid < higuy) {
' do {
' higuy -= width;
' } while (higuy > mid && __COMPARE(context, higuy, mid) == 0);
' }
i = idxArray(nMid)
If nMid < lpEnd Then
Do
lpEnd = lpEnd - 1
If lpEnd <= nMid Then Exit Do
Loop While obj.Compare(idxArray(lpEnd), i, nUserData) = 0
End If
' if (mid >= higuy) {
' do {
' higuy -= width;
' } while (higuy > lo && __COMPARE(context, higuy, mid) == 0);
' }
If nMid >= lpEnd Then
Do
lpEnd = lpEnd - 1
If lpEnd <= nStart Then Exit Do
Loop While obj.Compare(idxArray(lpEnd), i, nUserData) = 0
End If
'
' /* OK, now we have the following:
' higuy < loguy
' lo <= higuy <= hi
' A[i] <= A[mid] for lo <= i <= higuy
' A[i] == A[mid] for higuy < i < loguy
' A[i] > A[mid] for loguy <= i < hi
' A[hi] >= A[mid] */
'
' /* We've finished the partition, now we want to sort the subarrays
' [lo, higuy] and [loguy, hi].
' We do the smaller one first to minimize stack usage.
' We only sort arrays of length 2 or more.*/
'
' if ( higuy - lo >= hi - loguy ) {
If lpEnd - nStart >= nEnd - lpStart Then
' if (lo < higuy) {
' lostk[stkptr] = lo;
' histk[stkptr] = higuy;
' ++stkptr;
' } /* save big recursion for later */
If nStart < lpEnd Then
nStartStack(nStack) = nStart
nEndStack(nStack) = lpEnd
nStack = nStack + 1
End If
' if (loguy < hi) {
' lo = loguy;
' goto recurse; /* do small recursion */
' }
If lpStart < nEnd Then
nStart = lpStart
GoTo Recurse
End If
' }
Else
' else {
' if (loguy < hi) {
' lostk[stkptr] = loguy;
' histk[stkptr] = hi;
' ++stkptr; /* save big recursion for later */
' }
If lpStart < nEnd Then
nStartStack(nStack) = lpStart
nEndStack(nStack) = nEnd
nStack = nStack + 1
End If
'
' if (lo < higuy) {
' hi = higuy;
' goto recurse; /* do small recursion */
' }
If nStart < lpEnd Then
nEnd = lpEnd
GoTo Recurse
End If
' }
End If
End If
'/* We have sorted the array, except for any pending sorts on the stack.
' Check if there are any, and do them. */
nStack = nStack - 1
If nStack >= 0 Then
nStart = nStartStack(nStack)
nEnd = nEndStack(nStack)
GoTo Recurse '/* pop subarray from stack */
End If
'else
' return; /* all subarrays done */
'////////////////////////////////
#End If
End Sub
#If UseMSVCRT Then
Private Sub Class_Initialize()
Dim s As String
'///
m_hMod = LoadLibrary("msvcrt.dll")
m_lpFunc = GetProcAddress(m_hMod, "qsort")
'///
s = "89 E0 E8 00 00 00 00 83 04 24 15 6A 04 FF 70 08" + _
"FF 70 04 FF 50 0C 83 C4 10 C2 10 00 6A 00 89 E0" + _
"8B 15 ObjPtr 50 FF 35 UserData 8B 48 0C" + _
"8B 40 08 FF 31 FF 30 8B 0A 52 FF 51 1C 58 C3"
s = Replace(s, "ObjPtr", ReverseHex(VarPtr(m_lpObjPtr)))
s = Replace(s, "UserData", ReverseHex(VarPtr(m_nUserData)))
CodeFromString s, m_bCode
End Sub
Private Sub Class_Terminate()
FreeLibrary m_hMod
End Sub
Private Sub CodeFromString(ByVal s As String, ByRef b() As Byte)
Dim m As Long, i As Long
s = Replace(s, " ", "")
s = Replace(s, ",", "")
m = Len(s) \ 2
For i = 0 To m - 1
b(i) = Val("&H" + Mid(s, i + i + 1, 2))
Next i
End Sub
Private Function ReverseHex(ByVal n As Long) As String
Dim s As String
s = Right("00000000" + Hex(n), 8)
ReverseHex = Mid(s, 7, 2) + Mid(s, 5, 2) + Mid(s, 3, 2) + Mid(s, 1, 2)
End Function
#End If

复制代码

Zamyi · 发表于 2015-4-27 16:53

法师的几个所谓快速排序实质上是混合排序，用快速排序+（希尔、插入、冒泡）作为排序，它的优化体现在以下几个好处：
1、减少递归，当排序的R-L小于某个值时，改用其他（如希尔）排序，这样递归次数减少不少，但深度还不够，这个判断应该放在在调用递归时候判断，可以省一倍递归量；
2、优化对重复值的敏感性，原始快速排序对重复值多速度下降得很快；
3、用随机枢纽值+三值取中提高快排的稳定性。
如果按随机值作数据源，这个优化也就快17%左右而已。而事实上，如果真要提到速度上，指定数据类型是必不可少的，对于数值型，快慢差别不大，对于字符串型，相差很大，需要用指针才能做得更快。

汇铁 · 发表于 2015-4-27 17:09

本帖最后由汇铁于 2015-4-27 17:10 编辑

Zamyi 发表于 2015-4-27 16:53
法师的几个所谓快速排序实质上是混合排序，用快速排序+（希尔、插入、冒泡）作为排序，它的优化体现在以下几 ...

在这折腾啊。我还在那边等你。你在我的一亿取十万中，首次给出的的代码是不是有误？

字符型，要快的话。可不是用指针的问题。要用链表。我是这样想的。

汇铁 · 发表于 2015-4-27 17:17

本帖最后由汇铁于 2015-4-27 17:18 编辑

Zamyi 发表于 2015-4-27 16:53
法师的几个所谓快速排序实质上是混合排序，用快速排序+（希尔、插入、冒泡）作为排序，它的优化体现在以下几 ...

Zamyi VB有链表吗？
可用数组代替或叫模拟。

我在一亿取十万的链排序中。已经用了。

loquat · 发表于 2015-4-28 08:41

Zamyi 发表于 2015-4-27 15:08
1、你那排序结果不对；
2、要比较，需在同条件下，数组、变量类型都要相同。

'测试代码
Sub test()
Dim n() As Long
m = 1048576
ReDim n(1 To m)
For i = 1 To m
n(i) = 10000 * Rnd
Next
Dim a() As Long, b() As Long '保证变量类型相同
a = n: b = n '保证数组相同
t = Timer
QuickSort_A1 a, LBound(a), UBound(a) '对数组a排序
Debug.Print Timer - t
iSum = 0
For i = 1 To m - 1
iSum = iSum - (a(i) > a(i + 1))
Next
Debug.Print iSum '如果iSum不等于0，证明算法有误
t = Timer
QuickSort b '对数组b排序
Debug.Print Timer - t
jSum = 0
For i = 1 To m - 1
jSum = jSum - (b(i) > b(i + 1))
Next
Debug.Print jSum '如果iSum不等于0，证明算法有误
End Sub

复制代码

'仙剑魔的代码
Public Sub QuickSort(ByRef vArray() As Long)
Dim iLow As Long
Dim iHi As Long
'//get range of array
iLow = LBound(vArray) '//Low bound
iHi = UBound(vArray) '//High bound
'//use STACK, not RECURSION
StartSort vArray(), iLow, iHi '//call the procedure
End Sub
Private Sub StartSort(ByRef key_arr() As Long, L As Long, R As Long)
Dim i As Long, j As Long
Dim x As Long, Swap As Long
If R - L <= 16 Then
For i = L To R
x = i
For j = i + 1 To R
If key_arr(j) < key_arr(x) Then
x = j
End If
Next j
If x > i Then
Swap = key_arr(i)
key_arr(i) = key_arr(x)
key_arr(x) = Swap
End If
Next i
Else
x = key_arr((L + R) \ 2)
i = L
j = R
Do While i <= j
Do While key_arr(i) < x
i = i + 1
Loop
Do While key_arr(j) > x
j = j - 1
Loop
If i <= j Then
Swap = key_arr(i)
key_arr(i) = key_arr(j)
key_arr(j) = Swap
i = i + 1
j = j - 1
End If
Loop
'递归方法
If (L < j) Then Call StartSort(key_arr, L, j)
If (i < R) Then Call StartSort(key_arr, i, R)
End If
End Sub

复制代码

'法师的代码
Public Sub QuickSort_A1(ByRef key_arr() As Long, L As Long, R As Long)
Dim i As Long, j As Long, a As Long, b As Long, Mid As Long, offset As Long
Dim Pivot, Swap
If R - L <= 60 Then
For offset = 0 To 18
For i = L + offset To R Step 19
Swap = key_arr(i)
For j = i - 19 To L + offset Step -19
If Swap < key_arr(j) Then
key_arr(j + 19) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Next offset
For offset = 0 To 4
For i = L + offset To R Step 5
Swap = key_arr(i)
For j = i - 5 To L + offset Step -5
If Swap < key_arr(j) Then
key_arr(j + 5) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Next offset
For i = L + 1 To R
Swap = key_arr(i)
For j = i - 1 To L Step -1
If Swap < key_arr(j) Then
key_arr(j + 1) = key_arr(j)
key_arr(j) = Swap
Else
Exit For
End If
Next j
Next i
Else
Mid = L + 1 + Int(Rnd * (R - L - 1))
' Mid = (L + R) / 2
If key_arr(L) > key_arr(R) Then
Swap = key_arr(R)
key_arr(R) = key_arr(L)
key_arr(L) = Swap
End If
If key_arr(Mid) > key_arr(R) Then
Swap = key_arr(R)
key_arr(R) = key_arr(Mid)
key_arr(Mid) = Swap
End If
If key_arr(L) > key_arr(Mid) Then
Swap = key_arr(L)
key_arr(L) = key_arr(Mid)
key_arr(Mid) = Swap
End If
Pivot = key_arr(Mid)
key_arr(Mid) = key_arr(R - 1)
key_arr(R - 1) = Pivot
i = L + 1
j = R - 2
While (i < j)
For i = i To R
If key_arr(i) >= Pivot Then Exit For
Next i
For j = j To L Step -1
If key_arr(j) <= Pivot Then Exit For
Next j
If (i < j) Then
Swap = key_arr(i)
key_arr(i) = key_arr(j)
key_arr(j) = Swap
i = i + 1
j = j - 1
End If
Wend
For a = j To L Step -1
If key_arr(a) < Pivot Then Exit For
Next a
For b = i To R
If key_arr(b) > Pivot Then Exit For
Next b
'递归方法
If (L < a) Then Call QuickSort_A1(key_arr, L, a)
If (b < R) Then Call QuickSort_A1(key_arr, b, R)
End If
End Sub

复制代码

loquat · 发表于 2015-4-28 08:45

本帖最后由 loquat 于 2015-4-28 09:00 编辑

测试环境，win7 32位 i5-3470 3.2GHz, 4G内存
楼上代码本人电脑上的测试结果：
1.425781
0
.9628906
0
提升了32%
如果在VB6里，开启优化，编译后的结果如下：
.3867188
0
.1660156
0
提升了57%

		自动登录	找回密码
密码			免费注册

[原创] 有史以来最快的希尔排序 - 比历史贴快10倍，比Excel排序更快 - 兼论堆排序和快速排序

评分

点评