【VB】qsort和部分排序

天马座

调用方法和c语言一样
1 qsort和C语言的一样 就是回调函数多两个多余的参数因为使用CallWindowProc参数必须是4个

2 psort 一般用作部分排序

之前因为VB运算符优先级问题出现点BUG 搞了半天才找到错误的地方坑爹的VB

1. 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
2. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
3. Public Sub qsort(ByVal base As Long, ByVal num As Long, ByVal width As Long, ByVal compare As Long)
4.     '排序base开始的num个元素
5.     If num < 2 Then Exit Sub
6.     Call sort(base, base + num * width, Int(Log(num) / Log(2)) * 2, width, compare)
7. End Sub
8. Public Sub psort(ByVal base As Long, ByVal m As Long, ByVal num As Long, ByVal width As Long, ByVal compare As Long)
9.     '排序base开始的num个元素 保证前m个在正确的位置上
10.     If m < 1 Or num < m Then
11.         Exit Sub
12.     End If
13.     Dim n As Long, i As Long
14.     n = m * width
15.     For i = (m \ 2 - 1) * width To 0 Step -width
16.         Call shiftDown(base, i, n, width, compare)
17.     Next
18.     Dim p As Long, hi As Long
19.     hi = base + (num - 1) * width
20.     For p = base + n To hi Step width
21.         If CallWindowProc(compare, p, base, 0, 0) < 0 Then
22.             Call swap(p, base, width)
23.             Call shiftDown(base, 0, n, width, compare)
24.         End If
25.     Next
26.     For i = n - width To width Step -width
27.         Call swap(base, base + i, width)
28.         Call shiftDown(base, 0, i, width, compare)
29.     Next
30. End Sub
31. Private Sub shiftDown(ByVal base As Long, ByVal i As Long, ByVal n As Long, ByVal width As Long, ByVal compare As Long)
32.     Dim c As Long
33.     Do While 2 * i + width < n
34.         c = 2 * i + width
35.         If c < n - width Then
36.             If CallWindowProc(compare, base + c, base + c + width, 0, 0) < 0 Then
37.                 c = c + width
38.             End If
39.         End If
40.         If CallWindowProc(compare, base + i, base + c, 0, 0) >= 0 Then
41.             Exit Do
42.         End If
43.         Call swap(base + i, base + c, width)
44.         i = c
45.     Loop
46. End Sub
47. Private Sub sort(ByVal first As Long, ByVal last As Long, ByVal depth As Long, ByVal width As Long, ByVal compare As Long)
48.     Dim top As Long
49.     Dim stack((8 * 4 - 2) * 3 - 1) As Long
50.     top = 0
51.     stack(top) = first: top = top + 1
52.     stack(top) = last: top = top + 1
53.     stack(top) = depth: top = top + 1
54.     Dim cut As Long, num As Long
55.     Do While top <> 0
56.         top = top - 1: depth = stack(top)
57.         top = top - 1: last = stack(top)
58.         top = top - 1: first = stack(top)
59.         Do
60.             num = (last - first) \ width
61.             If num <= 16 Then
62.                 Call insertionSort(first, last, width, compare)
63.                 Exit Do
64.             End If
65.             If depth = 0 Then
66.                 Call psort(first, num, num, width, compare)
67.                 Exit Do
68.             End If
69.             depth = depth - 1
70.             cut = partition(first, last, median(first, first + (num \ 2) * width, last - width, compare), width, compare)
71.             If cut - first >= last - cut Then
72.                 If first < cut Then
73.                     stack(top) = first: top = top + 1
74.                     stack(top) = cut: top = top + 1
75.                     stack(top) = depth: top = top + 1
76.                 End If
77.                 first = cut
78.             Else
79.                 If cut < last Then
80.                     stack(top) = cut: top = top + 1
81.                     stack(top) = last: top = top + 1
82.                     stack(top) = depth: top = top + 1
83.                 End If
84.                 last = cut
85.             End If
86.         Loop
87.     Loop
88. End Sub
89. 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
90.     Do
91.         Do While CallWindowProc(compare, first, pivot, 0, 0) < 0
92.             first = first + width
93.         Loop
94.         last = last - width
95.         Do While CallWindowProc(compare, pivot, last, 0, 0) < 0
96.             last = last - width
97.         Loop
98.         If first >= last Then
99.             partition = first
100.             Exit Function
101.         End If
102.         Call swap(first, last, width)
103.         If first = pivot Then
104.             pivot = last
105.         ElseIf last = pivot Then
106.             pivot = first
107.         End If
108.         first = first + width
109.     Loop
110. End Function
111. Private Function median(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal compare As Long) As Long
112.     If CallWindowProc(compare, a, b, 0, 0) < 0 Then
113.         If CallWindowProc(compare, b, c, 0, 0) < 0 Then
114.             median = b
115.         ElseIf CallWindowProc(compare, a, c, 0, 0) < 0 Then
116.             median = c
117.         Else
118.             median = a
119.         End If
120.     ElseIf CallWindowProc(compare, a, c, 0, 0) < 0 Then
121.         median = a
122.     ElseIf CallWindowProc(compare, b, c, 0, 0) < 0 Then
123.         median = c
124.     Else
125.         median = b
126.     End If
127. End Function
128. Private Sub insertionSort(ByVal first As Long, ByVal last As Long, ByVal width As Long, ByVal compare As Long)
129.     Dim i As Long, j As Long
130.     For i = first + width To last - width Step width
131.         For j = i - width To first Step -width
132.             If CallWindowProc(compare, j, j + width, 0, 0) <= 0 Then
133.                 Exit For
134.             End If
135.             Call swap(j, j + width, width)
136.         Next
137.     Next
138. End Sub
139. Private Sub swap(ByVal elem1 As Long, ByVal elem2 As Long, ByVal width As Long)
140.     Dim t As Double, p As Long
141.     p = VarPtr(t)
142.     Do While width > 8
143.         CopyMemory p, elem1, 8
144.         CopyMemory elem1, elem2, 8
145.         CopyMemory elem2, p, 8
146.         elem1 = elem1 + 8
147.         elem2 = elem2 + 8
148.         width = width - 8
149.     Loop
150.     CopyMemory p, elem1, width
151.     CopyMemory elem1, elem2, width
152.     CopyMemory elem2, p, width
153. End Sub
154.   
155.   
156.   
157.   
158.   
159.   
160. Public Function comp(ByVal elem1 As Long, ByVal elem2 As Long, ByVal p1 As Long, ByVal p2 As Long) As Long
161.       '回调函数写法1
162.       Dim a As Long, b As Long
163.       CopyMemory VarPtr(a), elem1, 4
164.       CopyMemory VarPtr(b), elem2, 4
165.       If a < b Then
166.         comp = -1
167.       ElseIf a > b Then
168.         comp = 1
169.       Else
170.         comp = 0
171.       End If
172. End Function
174. Public Function comp1(ByRef elem1 As Long, ByRef elem2 As Long, ByVal p1 As Long, ByVal p2 As Long) As Long
175.       '回调函数写法2
176.       If elem1 < elem2 Then
177.         comp1 = -1
178.       ElseIf elem1 > elem2 Then
179.         comp1 = 1
180.       Else
181.         comp1 = 0
182.       End If
183. End Function
184.   
185.   
186.   
187.   
188. Public Sub main()
189.     Randomize
190.     Dim n As Long
191.     n = 100000
192.     ReDim a(n - 1) As Long
193.     Dim i As Long
194.     For i = 0 To n - 1
195.         a(i) = Int(Rnd * 100000000)
196.     Next
197.     qsort VarPtr(a(0)), n, 4, AddressOf comp1
198.     For i = 1 To n - 1
199.         If a(i) < a(i - 1) Then
200.             Debug.Print "错误"
201.             Exit For
202.         End If
203.     Next
204.     For i = 0 To n - 1
205.         a(i) = i
206.     Next
207.     Dim t As Long, r As Long
208.     For i = n - 1 To 1 Step -1
209.         r = Int(Rnd * (i + 1))
210.         t = a(r)
211.         a(r) = a(i)
212.         a(i) = t
213.     Next
214.     psort VarPtr(a(0)), 3, n, 4, AddressOf comp1
215.     If a(0) = 0 And a(1) = 1 And a(2) = 2 Then
216.     Else
217.           Debug.Print "错误"
218.     End If
219.     Debug.Print a(3) <> 3 '应该不是3
220.     qsort VarPtr(a(0)), n, 4, AddressOf comp1
221.     For i = 0 To n - 1
222.         If a(i) <> i Then
223.             Debug.Print "错误"
224.             Exit For
225.         End If
226.     Next
227.     Debug.Print "正确"
228. End Sub

复制代码

watermelon

牛的，看到和群里面其他同学一起交流，请教，最后完成了实现，真的很不错呢！