【VB】qsort和部分排序
本帖最后由 天马座 于 2020-9-24 22:03 编辑调用方法和c语言一样
1 qsort和C语言的一样 就是回调函数多两个多余的参数因为使用CallWindowProc参数必须是4个
2 psort 一般用作部分排序
之前因为VB运算符优先级问题出现点BUG 搞了半天才找到错误的地方坑爹的VB
Private Declare Function CallWindowProc Lib "user32" 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" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
Public Sub qsort(ByVal base As Long, ByVal num As Long, ByVal width As Long, ByVal compare As Long)
'排序base开始的num个元素
If num < 2 Then Exit Sub
Call sort(base, base + num * width, Int(Log(num) / Log(2)) * 2, width, compare)
End Sub
Public Sub psort(ByVal base As Long, ByVal m As Long, ByVal num As Long, ByVal width As Long, ByVal compare As Long)
'排序base开始的num个元素 保证前m个在正确的位置上
If m < 1 Or num < m Then
Exit Sub
End If
Dim n As Long, i As Long
n = m * width
For i = (m \ 2 - 1) * width To 0 Step -width
Call shiftDown(base, i, n, width, compare)
Next
Dim p As Long, hi As Long
hi = base + (num - 1) * width
For p = base + n To hi Step width
If CallWindowProc(compare, p, base, 0, 0) < 0 Then
Call swap(p, base, width)
Call shiftDown(base, 0, n, width, compare)
End If
Next
For i = n - width To width Step -width
Call swap(base, base + i, width)
Call shiftDown(base, 0, i, width, compare)
Next
End Sub
Private Sub shiftDown(ByVal base As Long, ByVal i As Long, ByVal n As Long, ByVal width As Long, ByVal compare As Long)
Dim c As Long
Do While 2 * i + width < n
c = 2 * i + width
If c < n - width Then
If CallWindowProc(compare, base + c, base + c + width, 0, 0) < 0 Then
c = c + width
End If
End If
If CallWindowProc(compare, base + i, base + c, 0, 0) >= 0 Then
Exit Do
End If
Call swap(base + i, base + c, width)
i = c
Loop
End Sub
Private Sub sort(ByVal first As Long, ByVal last As Long, ByVal depth As Long, ByVal width As Long, ByVal compare As Long)
Dim top As Long
Dim stack((8 * 4 - 2) * 3 - 1) As Long
top = 0
stack(top) = first: top = top + 1
stack(top) = last: top = top + 1
stack(top) = depth: top = top + 1
Dim cut As Long, num As Long
Do While top <> 0
top = top - 1: depth = stack(top)
top = top - 1: last = stack(top)
top = top - 1: first = stack(top)
Do
num = (last - first) \ width
If num <= 16 Then
Call insertionSort(first, last, width, compare)
Exit Do
End If
If depth = 0 Then
Call psort(first, num, num, width, compare)
Exit Do
End If
depth = depth - 1
cut = partition(first, last, median(first, first + (num \ 2) * width, last - width, compare), width, compare)
If cut - first >= last - cut Then
If first < cut Then
stack(top) = first: top = top + 1
stack(top) = cut: top = top + 1
stack(top) = depth: top = top + 1
End If
first = cut
Else
If cut < last Then
stack(top) = cut: top = top + 1
stack(top) = last: top = top + 1
stack(top) = depth: top = top + 1
End If
last = cut
End If
Loop
Loop
End Sub
Private Function partition(ByVal first As Long, ByVal last As Long, ByVal pivot As Long, ByVal width As Long, ByVal compare As Long) As Long
Do
Do While CallWindowProc(compare, first, pivot, 0, 0) < 0
first = first + width
Loop
last = last - width
Do While CallWindowProc(compare, pivot, last, 0, 0) < 0
last = last - width
Loop
If first >= last Then
partition = first
Exit Function
End If
Call swap(first, last, width)
If first = pivot Then
pivot = last
ElseIf last = pivot Then
pivot = first
End If
first = first + width
Loop
End Function
Private Function median(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal compare As Long) As Long
If CallWindowProc(compare, a, b, 0, 0) < 0 Then
If CallWindowProc(compare, b, c, 0, 0) < 0 Then
median = b
ElseIf CallWindowProc(compare, a, c, 0, 0) < 0 Then
median = c
Else
median = a
End If
ElseIf CallWindowProc(compare, a, c, 0, 0) < 0 Then
median = a
ElseIf CallWindowProc(compare, b, c, 0, 0) < 0 Then
median = c
Else
median = b
End If
End Function
Private Sub insertionSort(ByVal first As Long, ByVal last As Long, ByVal width As Long, ByVal compare As Long)
Dim i As Long, j As Long
For i = first + width To last - width Step width
For j = i - width To first Step -width
If CallWindowProc(compare, j, j + width, 0, 0) <= 0 Then
Exit For
End If
Call swap(j, j + width, width)
Next
Next
End Sub
Private Sub swap(ByVal elem1 As Long, ByVal elem2 As Long, ByVal width As Long)
Dim t As Double, p As Long
p = VarPtr(t)
Do While width > 8
CopyMemory p, elem1, 8
CopyMemory elem1, elem2, 8
CopyMemory elem2, p, 8
elem1 = elem1 + 8
elem2 = elem2 + 8
width = width - 8
Loop
CopyMemory p, elem1, width
CopyMemory elem1, elem2, width
CopyMemory elem2, p, width
End Sub
Public Function comp(ByVal elem1 As Long, ByVal elem2 As Long, ByVal p1 As Long, ByVal p2 As Long) As Long
'回调函数写法1
Dim a As Long, b As Long
CopyMemory VarPtr(a), elem1, 4
CopyMemory VarPtr(b), elem2, 4
If a < b Then
comp = -1
ElseIf a > b Then
comp = 1
Else
comp = 0
End If
End Function
Public Function comp1(ByRef elem1 As Long, ByRef elem2 As Long, ByVal p1 As Long, ByVal p2 As Long) As Long
'回调函数写法2
If elem1 < elem2 Then
comp1 = -1
ElseIf elem1 > elem2 Then
comp1 = 1
Else
comp1 = 0
End If
End Function
Public Sub main()
Randomize
Dim n As Long
n = 100000
ReDim a(n - 1) As Long
Dim i As Long
For i = 0 To n - 1
a(i) = Int(Rnd * 100000000)
Next
qsort VarPtr(a(0)), n, 4, AddressOf comp1
For i = 1 To n - 1
If a(i) < a(i - 1) Then
Debug.Print "错误"
Exit For
End If
Next
For i = 0 To n - 1
a(i) = i
Next
Dim t As Long, r As Long
For i = n - 1 To 1 Step -1
r = Int(Rnd * (i + 1))
t = a(r)
a(r) = a(i)
a(i) = t
Next
psort VarPtr(a(0)), 3, n, 4, AddressOf comp1
If a(0) = 0 And a(1) = 1 And a(2) = 2 Then
Else
Debug.Print "错误"
End If
Debug.Print a(3) <> 3 '应该不是3
qsort VarPtr(a(0)), n, 4, AddressOf comp1
For i = 0 To n - 1
If a(i) <> i Then
Debug.Print "错误"
Exit For
End If
Next
Debug.Print "正确"
End Sub
牛的，看到和群里面其他同学一起交流，请教，最后完成了实现，真的很不错呢！
页:
[1]