快速排序代码比拼

loquat

仅仅针对Long类型的数据来做排序算法的话，我目前见过的最快的算法如下。
欢迎也希望大侠能指点
这个排序仅仅对整数数组效率比较好，对字符串或者浮点数都没有较高效率
主要是swap在字符串和浮点数时，会大大降低效率，我的理解应该是这样

代码一是完全的API算法，调用msvcrt.dll里的qsort函数，在IDE界面下大部分情况下优势相当明显
代码二是纯VB算法，在VB编译后的情况下比代码一还要强大，且各种类型的数据表现都大体一致

另，发一个各种快排代码的比拼。。。 DualPivotQuickSortCountComparisons.zip (144.45 KB, 下载次数: 196)

2015-6-8 11:49 上传

点击文件名下载附件

附件是VB工程，工程里已经验证了排序结果，不需要再另外验证。
具体有问题请vbgood相关帖子，链接一个：ht【补丁】tp://ww【补丁】w.vbgood.c【补丁】om/thread-141406-1-1.h【补丁】tml

1. 
   
2. 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
   
3. Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
   
4. Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
   
5. Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
   
6. 
   
7. Private m_bCode(42) As Byte, m_hMod As Long, m_lpFunc As Long
   
8. 
   
9. Friend Sub QuickSort(idxArray() As Long, ByVal nStart As Long, ByVal nEnd As Long)
   
10. If nEnd - nStart <= 1 Then Exit Sub
    
11. If m_lpFunc Then
    
12.     CallWindowProc VarPtr(m_bCode(0)), VarPtr(idxArray(nStart)), nEnd - nStart + 1, m_lpFunc, 0
    
13.     Exit Sub
    
14. End If
    
15. End Sub
    
16. 
    
17. Private Sub Class_Initialize()
    
18. Dim s As String, m As Long, i As Long
    
19. m_hMod = LoadLibrary("msvcrt.dll")
    
20. m_lpFunc = GetProcAddress(m_hMod, "qsort")
    
21. s = "89E0E800000000830424156A04FF7008" + _
    
22.     "FF7004FF500C83C410C21000" + _
    
23.     "8B4C24048B4424088B108B0129D0C3"
    
24. m = Len(s) \ 2
    
25. For i = 0 To m - 1
    
26.     m_bCode(i) = CLng("&H" + Mid(s, i + i + 1, 2))
    
27. Next i
    
28. End Sub
    
29. Private Sub Class_Terminate()
    
30. FreeLibrary m_hMod
    
31. End Sub
    

复制代码

1. Public Sub QSort2(ByRef key_arr() As Long, L As Long, R As Long)
   
2.     Dim i As Long, j As Long
   
3.     Dim x As Long, Swap As Long
   
4.     Const k As Long = 60
   
5.     If R - L <= k Then
   
6.         For i = L + 1 To R
   
7.             x = key_arr(i)
   
8.                
   
9.             For j = i - 1 To L Step -1
   
10.                 If key_arr(j) <= x Then Exit For
    
11.                 key_arr(j + 1) = key_arr(j)
    
12.             Next
    
13.             key_arr(j + 1) = x
    
14.         Next
    
15.     Else
    
16.         x = key_arr((L + R) \ 2)
    
17.         i = L
    
18.         j = R
    
19.         Do While i <= j
    
20.             Do While key_arr(i) < x
    
21.                 i = i + 1
    
22.             Loop
    
23.             
    
24.             Do While key_arr(j) > x
    
25.                 j = j - 1
    
26.             Loop
    
27.            
    
28.             If i <= j Then
    
29.                 Swap = key_arr(i)
    
30.                 key_arr(i) = key_arr(j)
    
31.                 key_arr(j) = Swap
    
32.                 i = i + 1
    
33.                 j = j - 1
    
34.             End If
    
35.         Loop
    
36. 
    
37.         '递归方法
    
38.         If L < j Then
    
39.             Do While key_arr(j) = x
    
40.                 j = j - 1
    
41.                 If j = L Then Exit Do
    
42.             Loop
    
43.             Call QSort2(key_arr, L, j)
    
44.         End If
    
45.         If i < R Then
    
46.             Do While key_arr(i) = x
    
47.                 i = i + 1
    
48.                 If i = R Then Exit Do
    
49.             Loop
    
50.             Call QSort2(key_arr, i, R)
    
51.         End If
    
52.     End If
    
53. End Sub

复制代码

loquat

对比不同算法时，采用如下代码测试比较

1. Sub 正确性验证和效率对比()
   
2. Dim n() As Long
   
3. m = 1048576    '很多个随机数
   
4. ReDim n(1 To m)
   
5. For i = 1 To m
   
6.     n(i) = 10000 * Rnd
   
7. Next
   
8. Dim a() As Long, b() As Long
   
9. a = n: b = n    '保证不同算法使用同一个数组，以证明效率
   
10. t = Timer
    
11. QuickSort_1 a  '对数组a排序
    
12. Debug.Print Timer - t
    
13. iSum = 0
    
14. For i = 1 To m - 1
    
15.     iSum = iSum - (a(i) > a(i + 1))   '验证正确性
    
16. Next
    
17. Debug.Print iSum  '如果iSum不等于0，证明算法有误
    
18. t = Timer
    
19. QuickSort_2 b           '对数组b排序
    
20. Debug.Print Timer - t
    
21. iSum = 0
    
22. For i = 1 To m - 1
    
23.     iSum = iSum - (b(i) > b(i + 1))   '验证正确性
    
24. Next
    
25. Debug.Print iSum  '如果iSum不等于0，证明算法有误
    
26. End Sub

复制代码

lujkhua

沙发学习了，谢谢 loquat

liucqa

可以用指针交换来快速交换字符串

loquat

liucqa 发表于 2015-5-5 09:20
可以用指针交换来快速交换字符串

我觉得也应该用指针，但是还没学会指针用法

loquat

CSDN上找到如下代码，但是直接移植过来好像效率没升反降

1. 'VB标准方法：
   
2. Sub SwapStrPtr(sA As String, sB As String)
   
3.     Dim lTmp As Long
   
4.     CopyMemory lTmp, ByVal VarPtr(sA), 4
   
5.     CopyMemory ByVal VarPtr(sA), ByVal VarPtr(sB), 4
   
6.     CopyMemory ByVal VarPtr(sB), lTmp, 4
   
7. End Sub
   
8. '用指针的方法：
   
9. Sub SwapStrPtr2(sA As String, sB As String)
   
10.     Dim lTmp As Long
    
11.     Dim pTmp As Long, psA As Long, psB As Long
    
12.     pTmp = VarPtr(lTmp): psA = VarPtr(sA): psB = VarPtr(sB)
    
13.     CopyMemoryPtr pTmp, psA, 4
    
14.     CopyMemoryPtr psA, psB, 4
    
15.     CopyMemoryPtr psB, pTmp, 4
    
16. End Sub
    
17. 
    
18. '最快的方法
    
19. Sub SwapStrPtr3(sA As String, sB As String)
    
20.     Dim lTmp As Long
    
21.     Dim pTmp As Long, psA As Long, psB As Long
    
22.     pTmp = StrPtr(sA): psA = VarPtr(sA): psB = VarPtr(sB)
    
23.     CopyMemory ByVal psA, ByVal psB, 4
    
24.     CopyMemory ByVal psB, pTmp, 4
    
25. End Sub

复制代码

汇铁

loquat 发表于 2015-5-5 12:36
我觉得也应该用指针，但是还没学会指针用法

用数组做索引。数组先指向各字符串。排序要交换时，就把数组中的值做交换。

loquat

汇铁 发表于 2015-5-6 22:40
用数组做索引。数组先指向各字符串。排序要交换时，就把数组中的值做交换。

了然，但是我还不太懂指针，继续研究一下。。。

loquat

应该要加一个Optional ByVal SortUpDown As Boolean = True

loquat

之前的全部推翻，这个才是最快的。。。
不过本函数其实还有优化的空间，那个for循环应该还可以用汇编做提高效率。

1. 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
   
2. Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
   
3. Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
   
4. Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
   
5. 
   
6. Private m_bCode(42) As Byte, m_hMod As Long, m_lpFunc As Long
   
7. 
   
8. Friend Sub QuickSort(idxArray() As Long, ByVal nStart As Long, ByVal nEnd As Long)
   
9. If nEnd - nStart <= 1 Then Exit Sub
   
10. If m_lpFunc Then
    
11.     CallWindowProc VarPtr(m_bCode(0)), VarPtr(idxArray(nStart)), nEnd - nStart + 1, m_lpFunc, 0
    
12.     Exit Sub
    
13. End If
    
14. End Sub
    
15. 
    
16. Private Sub Class_Initialize()
    
17. Dim s As String, m As Long, i As Long
    
18. m_hMod = LoadLibrary("msvcrt.dll")
    
19. m_lpFunc = GetProcAddress(m_hMod, "qsort")
    
20. s = "89E0E800000000830424156A04FF7008" + _
    
21.     "FF7004FF500C83C410C21000" + _
    
22.     "8B4C24048B4424088B108B0129D0C3"
    
23. m = Len(s) \ 2
    
24. For i = 0 To m - 1
    
25.     m_bCode(i) = Val("&H" + Mid(s, i + i + 1, 2))
    
26. Next i
    
27. End Sub
    
28. 
    
29. Private Sub Class_Terminate()
    
30. FreeLibrary m_hMod
    
31. End Sub

复制代码

调用
Sub test2()
m = 1048576
ReDim n(1 To m) As Long
ReDim b(1 To m) As Long
For i = 1 To m
    n(i) = 10000 * Rnd
Next
t = Timer
Dim a As New ISort2
b = n
a.QuickSort b, 1, m, a
Debug.Print Timer - t
For i = 1 To m - 1
    iSum = iSum - (b(i) <= b(i + 1))
Next
Debug.Print iSum
End Sub