VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 3041|回复: 19

找到3个比较有效率的快速排序算法,求修改

[复制链接]
发表于 2015-4-24 16:55:08 | 显示全部楼层 |阅读模式
代码贴1楼,问题见2楼
  1. Sub QuickSort_A1(ByRef key_arr(), L As Long, R As Long)
  2. Dim i As Long, j As Long, a As Long, b As Long, Mid As Long, offset As Long
  3. Dim Pivot, Swap

  4. Iteration = Iteration + 1
  5.    
  6.     If R - L <= 60 Then
  7.         For offset = 0 To 18
  8.             For i = L + offset To R Step 19
  9.                 Swap = key_arr(i)
  10.                 For j = i - 19 To L + offset Step -19
  11.                     If Swap < key_arr(j) Then
  12.                         key_arr(j + 19) = key_arr(j)
  13.                         key_arr(j) = Swap
  14.                     Else
  15.                         Exit For
  16.                     End If
  17.                 Next j
  18.             Next i
  19.         Next offset
  20.         
  21.         For offset = 0 To 4
  22.             For i = L + offset To R Step 5
  23.                 Swap = key_arr(i)
  24.                 For j = i - 5 To L + offset Step -5
  25.                     If Swap < key_arr(j) Then
  26.                         key_arr(j + 5) = key_arr(j)
  27.                         key_arr(j) = Swap
  28.                     Else
  29.                         Exit For
  30.                     End If
  31.                 Next j
  32.             Next i
  33.         Next offset
  34.         
  35.         For i = L + 1 To R
  36.             Swap = key_arr(i)
  37.             For j = i - 1 To L Step -1
  38.                 If Swap < key_arr(j) Then
  39.                     key_arr(j + 1) = key_arr(j)
  40.                     key_arr(j) = Swap
  41.                 Else
  42.                     Exit For
  43.                 End If
  44.             Next j
  45.         Next i
  46.     Else
  47.    
  48.         Mid = L + 1 + Int(Rnd * (R - L - 1))
  49. '        Mid = (L + R) / 2
  50.         If key_arr(L) > key_arr(R) Then
  51.             Swap = key_arr(R)
  52.             key_arr(R) = key_arr(L)
  53.             key_arr(L) = Swap
  54.         End If
  55.         If key_arr(Mid) > key_arr(R) Then
  56.             Swap = key_arr(R)
  57.             key_arr(R) = key_arr(Mid)
  58.             key_arr(Mid) = Swap
  59.         End If
  60.         If key_arr(L) > key_arr(Mid) Then
  61.             Swap = key_arr(L)
  62.             key_arr(L) = key_arr(Mid)
  63.             key_arr(Mid) = Swap
  64.         End If
  65.         
  66.         Pivot = key_arr(Mid)
  67.         key_arr(Mid) = key_arr(R - 1)
  68.         key_arr(R - 1) = Pivot
  69.         i = L + 1
  70.         j = R - 2
  71.         While (i < j)
  72.             For i = i To R
  73.                 If key_arr(i) >= Pivot Then Exit For
  74.             Next i
  75.             For j = j To L Step -1
  76.                 If key_arr(j) <= Pivot Then Exit For
  77.             Next j
  78.             If (i < j) Then
  79.                 Swap = key_arr(i)
  80.                 key_arr(i) = key_arr(j)
  81.                 key_arr(j) = Swap
  82.                 i = i + 1
  83.                 j = j - 1
  84.             End If
  85.         Wend

  86.         For a = j To L Step -1
  87.             If key_arr(a) < Pivot Then Exit For
  88.         Next a
  89.         For b = i To R
  90.             If key_arr(b) > Pivot Then Exit For
  91.         Next b
  92.         
  93.         If (L < a) Then Call QuickSort_A1(key_arr, L, a)
  94.         If (b < R) Then Call QuickSort_A1(key_arr, b, R)
  95.    
  96.     End If
  97. End Sub
复制代码
  1. Option Explicit

  2. '///////////////////////////////////////////////////////////////
  3. '// QucikSort_V2 function class
  4. '//
  5. '// LastUpdate:2004-1-22
  6. '// by Kwanhong Young (r4c Studio)
  7. '///////////////////////////////////////////////////////////////

  8. Private stack       As cStack_long

  9. Private Sub Class_Initialize()
  10.     Set stack = New cStack_long
  11. End Sub

  12. Private Sub Class_Terminate()
  13.     Set stack = Nothing
  14. End Sub

  15. Public Sub StartSort_Long(ByRef vArray() As Long, Optional SortUpDown As Boolean = True)
  16.     Dim iLow As Long
  17.     Dim iHi As Long
  18.    
  19.     '//get range of array
  20.     iLow = LBound(vArray) '//Low bound
  21.     iHi = UBound(vArray)  '//High bound
  22.    
  23.     '//push low value to stack first
  24.     stack.Push iLow
  25.     stack.Push iHi
  26.    
  27.     '//use STACK, not RECURSION
  28.     Do
  29.         iHi = stack.Pop
  30.         iLow = stack.Pop
  31.         QuickSort_Long vArray(), iLow, iHi   '//call the procedure
  32.     Loop Until stack.Count = 0
  33.    
  34. End Sub

  35. Private Sub QuickSort_Long(ByRef vArray() As Long, ByVal iLow As Long, ByVal iHi As Long)
  36. '//QuickSort procedure
  37. '//vArray()   The array to sort
  38. '//iLow      Lower bound of sort point
  39. '//iHi       Upper bound of sort point
  40.    
  41.     Dim iMid    As Long '//middle value
  42.     Dim tmpSwap As Long '//variou for swap function
  43.    
  44.     '//two working pointer
  45.     Dim tmpLow  As Long
  46.     Dim tmpHi   As Long
  47.    
  48.     '//Save to the working pointer
  49.     tmpLow = iLow
  50.     tmpHi = iHi
  51.    
  52.     '//Get middle value
  53.     iMid = vArray((iLow + iHi) \ 2)
  54.    
  55.     Do While (tmpLow <= tmpHi)
  56.    
  57.         '//look up the first value that large than MIDDLE
  58.         Do While (vArray(tmpLow) < iMid And tmpLow < iHi)
  59.             tmpLow = tmpLow + 1
  60.         Loop
  61.         
  62.         '//loop up the first value the small than MIDDLE
  63.         Do While (iMid < vArray(tmpHi) And tmpHi > iLow)
  64.             tmpHi = tmpHi - 1
  65.         Loop
  66.         
  67.         '//swap the two items.
  68.         If (tmpLow <= tmpHi) Then
  69.             tmpSwap = vArray(tmpLow)
  70.             vArray(tmpLow) = vArray(tmpHi)
  71.             vArray(tmpHi) = tmpSwap
  72.             '//swap ok
  73.             tmpLow = tmpLow + 1
  74.             tmpHi = tmpHi - 1
  75.         End If
  76.    
  77.     Loop
  78.    
  79.     '//do the remain - RECURSION METHOD
  80.     'If (iLow < tmpHi) Then QuickSort_Long vArray, iLow, tmpHi
  81.     'If (tmpLow < iHi) Then QuickSort_Long vArray, tmpLow, iHi
  82.    
  83.     '//do the remain - STACK METHOD
  84.     If (tmpLow < iHi) Then
  85.         stack.Push tmpLow
  86.         stack.Push iHi
  87.     End If
  88.    
  89.     If (iLow < tmpHi) Then
  90.         stack.Push iLow
  91.         stack.Push tmpHi
  92.     End If
  93. End Sub
  94. '----------------------------------------- FOR STRING DATA TYPE ------------------------------------


  95. Public Sub StartSort_String(vArray() As String)
  96.     Dim iLow As Long
  97.     Dim iHi As Long
  98.    
  99.     '//get range of array
  100.     iLow = LBound(vArray) '//Low bound
  101.     iHi = UBound(vArray)  '//High bound
  102.    
  103.     '//push low value to stack first
  104.     stack.Push iLow
  105.     stack.Push iHi
  106.    
  107.     '//use STACK, not RECURSION
  108.     Do
  109.         iHi = stack.Pop
  110.         iLow = stack.Pop
  111.         QuickSort_String vArray(), iLow, iHi   '//call the procedure
  112.     Loop Until stack.Count = 0
  113.    
  114. End Sub

  115. Private Sub QuickSort_String(vArray() As String, iLow As Long, iHi As Long)
  116. '//QuickSort procedure
  117. '//vArray()   The array to sort
  118. '//iLow      Lower bound of sort point
  119. '//iHi       Upper bound of sort point
  120.    
  121.     Dim iMid    As String '//middle value
  122.     Dim tmpSwap As String '//variou for swap function
  123.    
  124.     '//two working pointer
  125.     Dim tmpLow  As Long
  126.     Dim tmpHi   As Long
  127.    
  128.     '//Save to the working pointer
  129.     tmpLow = iLow
  130.     tmpHi = iHi
  131.    
  132.     '//Get middle value
  133.     iMid = vArray((iLow + iHi) \ 2)
  134.    
  135.     Do While (tmpLow <= tmpHi)
  136.    
  137.         '//look up the first value that large than MIDDLE
  138.         Do While (vArray(tmpLow) < iMid And tmpLow < iHi)
  139.             tmpLow = tmpLow + 1
  140.         Loop
  141.         
  142.         '//loop up the first value the small than MIDDLE
  143.         Do While (iMid < vArray(tmpHi) And tmpHi > iLow)
  144.             tmpHi = tmpHi - 1
  145.         Loop
  146.         
  147.         '//swap the two items.
  148.         If (tmpLow <= tmpHi) Then
  149.             tmpSwap = vArray(tmpLow)
  150.             vArray(tmpLow) = vArray(tmpHi)
  151.             vArray(tmpHi) = tmpSwap
  152.             '//swap ok
  153.             tmpLow = tmpLow + 1
  154.             tmpHi = tmpHi - 1
  155.         End If
  156.     Loop
  157.    
  158.     '//do the remain - STACK METHOD
  159.     If (tmpLow < iHi) Then
  160.         stack.Push tmpLow
  161.         stack.Push iHi
  162.     End If
  163.     If (iLow < tmpHi) Then
  164.         stack.Push iLow
  165.         stack.Push tmpHi
  166.     End If
  167. End Sub
  168. '######################
  169. '#       以下是cStack_long.cls        #
  170. '######################
  171. Option Explicit

  172. '-----------------------------------------------------------------------
  173. '堆栈 (stack) - FOR LONG DATA TYPE
  174. '数据结构中的 Stack, 有Push、Pop、Peek等方法
  175. '
  176. 'LastUpdate:2004-1-23
  177. 'by Kwanhong Young (r4c Studio)
  178. '-----------------------------------------------------------------------

  179. Private sItem()   As Long
  180. Private iCount    As Long

  181. Private Sub Class_Initialize()
  182. '//start...
  183.     ReDim sItem(0)
  184.     iCount = 0
  185. End Sub

  186. Private Sub Class_Terminate()
  187. '//over
  188.     ReDim sItem(0)
  189.     iCount = 0
  190. End Sub

  191. Public Sub Push(ByVal vValue As Long)
  192.     sItem(iCount) = vValue
  193.     iCount = iCount + 1
  194.     ReDim Preserve sItem(iCount)
  195. End Sub

  196. Public Function Pop() As Long
  197.     If iCount > 0 Then
  198.         iCount = iCount - 1
  199.         Pop = sItem(iCount)
  200.         ReDim Preserve sItem(iCount)
  201.     End If
  202. End Function

  203. Public Function Peek() As Long
  204.     If iCount > 0 Then Peek = sItem(iCount - 1)
  205. End Function

  206. Public Property Get Count() As Long
  207.     Count = iCount
  208. End Property

  209. Public Sub GetAllItem(itm() As Long)
  210.     ReDim itm(iCount)
  211.     Dim i   As Long
  212.     For i = 0 To iCount - 1
  213.         itm(i) = sItem(i)
  214.     Next
  215. End Sub

  216. Public Function GetAllItem_toString(Optional ByVal cDelimiter As String = "|") As String
  217.     If iCount = 0 Then Exit Function
  218.     GetAllItem_toString = Join(sItem, cDelimiter)   '//VB6
  219.    
  220.     '//--------------------------------------------- //VB5
  221.     'Dim i       As Long
  222.     'Dim strTmp  As String
  223.     'For i = 0 To iCount - 1
  224.     '    strTmp = strTmp & sItem(i) & cDelimiter
  225.     'Next
  226.     'GetAllItem_toString = Left(strTmp, Len(strTmp) - 1)
  227.    
  228. End Function
复制代码
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "ISort2"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit

  11. '/***
  12. '*qsort(base, num, wid, comp) - quicksort function for sorting arrays
  13. '*
  14. '*Purpose:
  15. '*   quicksort the array of elements
  16. '*   side effects:  sorts in place
  17. '*   maximum array size is number of elements times size of elements,
  18. '*   but is limited by the virtual address space of the processor
  19. '*
  20. '*Entry:
  21. '*   char *base = pointer to base of array
  22. '*   size_t num  = number of elements in the array
  23. '*   size_t width = width in bytes of each array element
  24. '*   int (*comp)() = pointer to function returning analog of strcmp for
  25. '*           strings, but supplied by user for comparing the array elements.
  26. '*           it accepts 2 pointers to elements.
  27. '*           Returns neg if 1<2, 0 if 1=2, pos if 1>2.
  28. '*
  29. '*Exit:
  30. '*   returns void
  31. '*
  32. '*Exceptions:
  33. '*   Input parameters are validated. Refer to the validation section of the function.
  34. '*
  35. '*******************************************************************************/

  36. 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
  37. Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  38. Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  39. Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
  40. Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long

  41. Private m_bCode(255) As Byte, m_hMod As Long, m_lpFunc As Long
  42. Private m_lpObjPtr As Long, m_nUserData As Long


  43. Public Function Compare(ByVal Index1 As Long, ByVal Index2 As Long, ByVal nUserData As Long) As Long
  44. 'default implementation (???)
  45. If Index1 < Index2 Then Compare = -1 Else _
  46. If Index1 > Index2 Then Compare = 1 Else Compare = 0
  47. End Function

  48. 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)
  49. '///check
  50. If nEnd - nStart <= 1 Then Exit Sub
  51. If obj Is Nothing Then Set obj = Me
  52. '///

  53. If m_lpFunc Then
  54. m_lpObjPtr = ObjPtr(obj)
  55. m_nUserData = nUserData
  56. CallWindowProc VarPtr(m_bCode(0)), VarPtr(idxArray(nStart)), nEnd - nStart + 1, m_lpFunc, 0
  57. Exit Sub
  58. End If
  59. End Sub

  60. Private Sub Class_Initialize()
  61. Dim s As String
  62. '///
  63. m_hMod = LoadLibrary("msvcrt.dll")
  64. m_lpFunc = GetProcAddress(m_hMod, "qsort")
  65. '///
  66. s = "89 E0 E8 00 00 00 00 83 04 24 15 6A 04 FF 70 08" + _
  67. "FF 70 04 FF 50 0C 83 C4 10 C2 10 00 6A 00 89 E0" + _
  68. "8B 15 ObjPtr 50 FF 35 UserData 8B 48 0C" + _
  69. "8B 40 08 FF 31 FF 30 8B 0A 52 FF 51 1C 58 C3"
  70. s = Replace(s, "ObjPtr", ReverseHex(VarPtr(m_lpObjPtr)))
  71. s = Replace(s, "UserData", ReverseHex(VarPtr(m_nUserData)))
  72. CodeFromString s, m_bCode
  73. End Sub

  74. Private Sub Class_Terminate()
  75. FreeLibrary m_hMod
  76. End Sub

  77. Private Sub CodeFromString(ByVal s As String, ByRef b() As Byte)
  78. Dim m As Long, i As Long
  79. s = Replace(s, " ", "")
  80. s = Replace(s, ",", "")
  81. m = Len(s) \ 2
  82. For i = 0 To m - 1
  83. b(i) = Val("&H" + Mid(s, i + i + 1, 2))
  84. Next i
  85. End Sub

  86. Private Function ReverseHex(ByVal n As Long) As String
  87. Dim s As String
  88. s = Right("00000000" + Hex(n), 8)
  89. ReverseHex = Mid(s, 7, 2) + Mid(s, 5, 2) + Mid(s, 3, 2) + Mid(s, 1, 2)
  90. End Function
复制代码
 楼主| 发表于 2015-4-24 16:59:52 | 显示全部楼层
以上三个代码在本人电脑上排100W电脑生成的随机整数
代码1和代码3在1.7s左右,代码2在2.4s左右
代码1是灰袍法师分享的
代码2是CSDN上的VirtualAlloc分享的
代码3是本坛acme_pjz分享的
现希望大神给以上代码稍作修改
   1.加一个参数:Option ByVal SortUp2Down As Boolean = True
   2.代码3使用时需要Implements,且只能在窗体中使用,请问它能否做成可以在普通模块中使用的类模块,且能加一个参数

另另在Matthew Curland的《Advanced Visual Basic 6》中找到这份代码,但是不知道怎么使用。
所以无法测定效率

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x

点评

我那个本来就能加参数啊,不是有个UserData么  发表于 2015-4-25 13:07
回复 支持 反对

使用道具 举报

发表于 2015-4-24 18:36:55 | 显示全部楼层
1.
搞个比较函数替换里面的比较运算,有点麻烦
包装一下原先的函数更简单,SortUp2Down 其实只要把排好序的数据做个翻转

2.
代码3不已经是类模块了么...
而且也没规定只能在窗体中使用啊...
你想搞个简单调用的函数出来?也是可以的
另,RAR里的代码复杂程度已经超越了123,我觉得普通的使用没必要搞那么复杂...
回复 支持 反对

使用道具 举报

发表于 2015-4-25 02:41:26 | 显示全部楼层
mark一下。。。。。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2015-4-26 17:30:38 | 显示全部楼层
@acme_pjz
Userdata嵌入汇编码了,对小弟来说过于复杂啊
回复 支持 反对

使用道具 举报

 楼主| 发表于 2015-4-26 23:41:25 | 显示全部楼层
突然想到,将代码1和代码2结合起来,会不会提高效率呢?
代码1的特点是减少了循环次数,代码2的特点是模拟了汇编语言的方法。
代码2的算法,我感觉我看到过其普通版本的代码。。。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2015-4-27 10:16:47 | 显示全部楼层
本帖最后由 loquat 于 2015-4-27 10:34 编辑

果然代码1和代码2组合能提高将近15%
现在在VBE环境中1.4s, VBA环境中1.5s,VB6开启优化编译成Exe后0.4s

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
回复 支持 反对

使用道具 举报

 楼主| 发表于 2015-4-27 11:21:20 | 显示全部楼层
@acme_pjz
您觉得哪里还能优化吗?
stack类还能优化吗?

点评

长度貌似至少要 log(length)*4 ?  发表于 2015-4-28 10:49
stack不要用类,就用一个定长数组就行了,你看过我翻译的那个qsort VB版代码么  发表于 2015-4-27 12:52
回复 支持 反对

使用道具 举报

发表于 2015-4-27 12:58:16 | 显示全部楼层
本帖最后由 仙剑魔 于 2015-4-27 16:57 编辑

代码2那个栈模拟在VB里没有意义
因为push/pop被搞成了函数,调用反而会消耗时间
一般情况下递归的快排已经够用了
真想优化的话,在小段的时候用选择排序什么的替换一下



  1. Private Sub QuickSort(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.     If R - L <= 16 Then
  5.         For i = L To R
  6.             x = i
  7.             For j = i + 1 To R
  8.                 If key_arr(j) < key_arr(x) Then
  9.                     x = j
  10.                 End If
  11.             Next j
  12.             
  13.             If x > i Then
  14.                 Swap = key_arr(i)
  15.                 key_arr(i) = key_arr(x)
  16.                 key_arr(x) = Swap
  17.             End If
  18.         Next i
  19.     Else
  20.         x = key_arr((L + R) \ 2)
  21.         i = L
  22.         j = R
  23.         Do While i <= j
  24.             Do While key_arr(i) < x
  25.                 i = i + 1
  26.             Loop
  27.             
  28.             Do While key_arr(j) > x
  29.                 j = j - 1
  30.             Loop
  31.            
  32.             If i <= j Then
  33.                 Swap = key_arr(i)
  34.                 key_arr(i) = key_arr(j)
  35.                 key_arr(j) = Swap
  36.                 i = i + 1
  37.                 j = j - 1
  38.             End If
  39.         Loop

  40.         '递归方法
  41.         If (L < j) Then Call QuickSort(key_arr, L, j)
  42.         If (i < R) Then Call QuickSort(key_arr, i, R)
  43.     End If
  44. End Sub

  45. Public Sub StartSort(ByRef vArray() As Long)
  46.     Dim iLow As Long
  47.     Dim iHi As Long
  48.    
  49.     '//get range of array
  50.     iLow = LBound(vArray) '//Low bound
  51.     iHi = UBound(vArray)  '//High bound
  52.    
  53.     '//use STACK, not RECURSION
  54.     QuickSort vArray(), iLow, iHi   '//call the procedure
  55.    
  56. End Sub



复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2015-4-27 14:26:32 | 显示全部楼层
仙剑魔 发表于 2015-4-27 12:58
代码2那个栈模拟在VB里没有意义
因为push/pop被搞成了函数,调用反而会消耗时间
一般情况下递归的快排已经 ...

代码1就是做了如下优化的版本。
1.当R-L小于60时,就开始采用希尔排序,降低递归次数
2.划分元素不再是简单取中间元素 = (L+R) / 2,而是取L,R,(L+R)/2的中间值,并且顺带排序好这这三个元素,再次递归时就可以少算三个元素,略微提速
3.对小于12个元素,用三层希尔排序取代一层插入排序
4.不把处于中间位置的枢纽值带入下一步递归,对元素重复度高的排序有奇效
原本描述的效果如上,附件顺带传上。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x

点评

12个元素的时候还是插入排序最快  发表于 2015-4-28 13:34
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-1 22:00

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表