VB版人气不高么，大家讨论起来吧：一个另类的排序问题，顶者有分！！提出好建议的给更多分！！！！！！！
相信每一个程序员在写程序的时候,都或多或少地接触过排序问题．（还别说，我就真见过从来不写排序代码的家伙，号称是写数据库应用的，只要写SORT BY什么的，从来不自己写排序代码的牛人）什么冒泡排序，插入排序，快速排序等等，想必都听出老茧来了．但是很多时候程序的要求并非直接要求你将一列数据从大到小，或者从小到大排一下就算完了．在此我想把我自己在实际应用中遇到的一种排序要求和我所使用的方法介绍给大家．
在我之前的系列文章中，曾经介绍了一种关于图像滤波的算法．该算法的效果不错，但是由于运算量比较大，所以处理速度相对其它功能就稍微慢一些．文章参考：http://blog.yesky.com/blog/wallescai/archive/2007/07/10/1692197.html
在该篇文章中，我主要介绍的是滤波算法的原理和算法．而这个算法中用到了一个比较另类的排序，具体要求如下：
在一个长度为N的乱序整数数列中指定某一个数字，选出整个数列中和该数字的差值最小的M个数字．然后将这些数字求平均值．（其实这就是前面提到的那个滤波算法的关键核心）
N = (R * 2 + 1)^2 (R = 1,2,3,4...); => N = (9，25，49，81...）
M = N／2 (一般取值略小于M的一半)
这并非严格意义上的排序，但是我想很多朋友如果在看完这些要求之后的第一反应就是：排序问题，然后就兴致勃勃的开始写代码．
先别急，还有一个附加条件，由于这个算法是嵌在图像处理算法中的，图像中的每一个像素都需要应用到这个算法３次（红，绿，蓝三种颜色都要参与计算），因此哪怕是一个800*600大小的图片最少也需要进行(800-2)*(600-2)*3 = 1431612次排序．所以要求这个算法异常精简快速．
关于这个排序的算法，我已经在CSDN的论坛中和大家讨论过，参考：http://topic.csdn.net/t/20060907/13/5005438.html
并且在帖子的后面，我总结出了一个比较快速的算法．并且将之用于我的程序之中，我所公布的那个最新版本的ImageCast就是采用了这个排序算法．
但是，今天在仔细研究了这个算法之后，我发现自己错了．这个算法还依然没有达到它的最高效率，它依然有可挖掘的地方．
首先介绍思路：
假定原数列为A(N)，选定的参考数字为S,最后要选出与S值最接近的M个数字
首先建立一个和原数列相同长度的数组B(N)．数组B用来存放A(N)中每一个元素和S的差的绝对值
然后将数组B的前M个值和后N-M个值去比较，如果前者大于后者，则两者交换位置，同时将远数组A的对应元素也交换位置．
测试代码为：
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll "() As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(All - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Private Sub Form_Load()
Dim I As Long
For I = 0 To ALL - 1
B(I) = Rnd * All '产生一个随机数列
Next
End Sub
Private Sub FSort(ByVal Test As Long)
Dim D(ALL - 1) As Long
Dim I As Long
Dim L As Long
Dim M As Long
Dim N As Long
For I = ０ To ALL - 1 '先获得数组每一个元素和指定数字的差值
D(I) = Abs(A(I) - Test)
Next
For N = 0 To NEAR '关键循环，总的循环次数为 Near*(All-Near)
For I = NEAR + 1 To 999
If D(N) > D(I) Then '将前面的值和后面的值比较
M = D(N) '如果后面的小，则交换差值
D(N) = D(I)
D(I) = M
M = A(N) '同时交换原数组元素
A(N) = A(I)
A(I) = M
End If
Next
Next
'上面的循环结束后，原数列中和指定值差距最小的M+1个数已经排列在数组A的最前面
For I = 0 To Near '将选定的数Test本身从中剔除
If A(I) = Test Then
M = A(I)
A(I) = A(Near)
A(Near) = M
Exit For
End If
Next
End Sub
调用：
Private Sub Command1_Click()
Dim T As Long
Dim I As Long
T=TimeGetTime
For I =0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
FSort 333
Next
Me.Cls
For I = 0 To 4
Me.Print A(I)
Next
Me.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & T & "ms "
End Sub
当N> > M的时候，算法复杂度为O(N)，当M=N/2的时候为：O(N^2)
因为当筛选完成后数组中最接近的数字已经被排列到数组的最前段，因此如果直接循环调用的话，后面几次调用的运算速度将远小于正常速度．
请大家仔细看程序中提到的关键循环：
For N = 0 To NEAR '关键循环，总的循环次数为 Near*(All-Near)
For I = NEAR + 1 To 999
If D(N) > D(I) Then '将前面的值和后面的值比较
M = D(N) '如果后面的小，则交换差值
D(N) = D(I)
D(I) = M
M = A(N) '同时交换原数组元素
A(N) = A(I)
A(I) = M
End If
Next
Next
我忽然醒悟到其实我根本不必去交换数组D中的元素，因为它的顺序并不影响最终结果，而对原始数组A的排序才是真正有用的东西．它起到的作用只是指出了数组A应该在何处交换位置而已．而在上面的程序中交换数组D中的元素内容，只是为了不使后面的循环中重复选择同样的数据而已．
思考了一番之后，我将上面的＂关键循环＂修改如下：
For N = 0 To NEAR
M = N
For I = NEAR + 1 To ALL
If D(M) > D(I) Then M = I '其实只要得到当前最小的元素的位置就可以了，根本不必急着交换
Next
If M <> N Then '上面的循环结束之后再根据得到的数组位置去交换原始数组即可
D(M) = D(N) '数组D的完整性不必考虑，只要保证已经被选过的数字不会再出现即可
I = A(N) '交换原始数组内容
A(N) = A(M)
A(M) = I
End If
Next
虽然算法本身复杂度不变，但是在改进了代码之后，速度的提高是相当显著的．
和原来的代码相比，当原数列的无序度越高，速度提高越明显．
因为只是讨论算法，我没有结合原来图像处理程序中的N和M取值范围，这样更便于大家实际应用．
如有错漏之处，请高手不吝指正．
原帖请参考我的BLOG：
http://blog.yesky.com/162/wallescai/1708162.shtml
[解决办法]
么这么长?
[解决办法]
mark
[解决办法]
支持楼主，学习了！
[解决办法]
学习
[解决办法]
高科技啊高科技
[解决办法]
見過見過
實在水平有限
除了冒泡排序，插入排序，快速排序等等用過之外
其它的......
[解决办法]
If D(M) > D(I) Then M = I '其实只要得到当前最小的元素的位置就可以了，根本不必急着交换
==================================================
我觉得效率提高的关键在这里,这才是最大的改进
原来的算法浪费了时间在无效的交换上面.
常规的选择排序,也是先记录下标,不是当场做交换的
相对来说,是否交换D,影响并不大
有了上面的改进,即使交换D,也仅仅增加Near次赋值操作而已
[解决办法]
jf
[解决办法]
可以不交换A,增加一个C
效率没有提高,但是可以保护A不被破坏
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Dim C(0 To NEAR) As Long
Private Sub Form_Load()
Dim I As Long
For I = 0 To ALL - 1
B(I) = Rnd * ALL '产生一个随机数列
Next
End Sub
Private Sub FSort(ByVal Test As Long)
Dim D(ALL - 1) As Long
Dim I As Long
Dim L As Long
Dim M As Long
Dim N As Long
Dim cn As Long
For I = 0 To ALL - 1 '先获得数组每一个元素和指定数字的差值
D(I) = Abs(A(I) - Test)
Next
For N = 0 To NEAR
M = N
For I = NEAR + 1 To ALL - 1
If D(M) > D(I) Then M = I '其实只要得到当前最小的元素的位置就可以了，根本不必急着交换
Next
D(M) = D(N) '数组D的完整性不必考虑，只要保证已经被选过的数字不会再出现即可
C(cn) = M
cn = cn + 1
Next
For I = 0 To NEAR '将选定的数Test本身从中剔除
If A(C(I)) = Test Then
M = C(I)
C(I) = C(NEAR)
C(NEAR) = M
Exit For
End If
Next
End Sub
Private Sub Command1_Click()
Dim T As Long
Dim I As Long
T = timeGetTime
For I = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
FSort 333
Next
Me.Cls
For I = 0 To 4
Me.Print A(C(I))
Next
Me.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & timeGetTime - T & "ms "
End Sub
[解决办法]
UP
[解决办法]
mark
[解决办法]
找出少量最近值没必要在那么大的数组中绕来绕去，另建一个数组专门处理最近值效率会更高些，另外我对楼主的要求有两点不太清楚：
1、是不是与测试值相等的值不算？
2、是不是多个相近值，若差值相同只算一个，不重复统计？
楼主的代码在我的机器上运行，IDE环境下为6.3秒左右
我按楼主的意思写了一个代码，思路完全不同，实测条件与输出结果相同，运行时间为1.8秒，有3倍以上的速度提升，看看是否有参考价值。
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Dim R1(NEAR - 1) As Long '存放最近差值的数组
Dim R2(NEAR - 1) As Long '存放与差值数组相对应的元素在原始数组中的下标
Private Sub Form_Load()
Dim I As Long
For I = 0 To ALL - 1
B(I) = Rnd * ALL '产生一个随机数列
Next
End Sub
Private Sub FSort(ByVal Test As Long)
Dim I As Long
Dim L As Long
Dim M As Long
Dim N As Long
For N = 0 To NEAR - 1
R1(N) = &H7FFFFFFF '初始化待比较值为最大正数
Next
For I = 0 To ALL - 1
M = Abs(A(I) - Test) '先获得数组每一个元素和指定数字的差值
If M > 0 And M < R1(NEAR - 1) Then '相等的不要，大于等于最大差值的不要
For N = 0 To NEAR - 2 '把这个值记录进最近值数组，并进行必要的排序
If M < R1(N) Then '若比数组中前面的差值还小，则要插入，把其后的值后移，保证数组中的差值始终从小到大
For L = NEAR - 1 To N + 1 Step -1
R1(L) = R1(L - 1)
R2(L) = R2(L - 1)
Next
Exit For
End If
Next
R1(N) = M
R2(N) = I
End If
Next
End Sub
Private Sub Command1_Click()
Dim T As Long
Dim I As Long
T = timeGetTime
For I = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4 '因原始数组不会变动，这句没必要再加了，保留它只是为了与原算法速度有个比较
FSort 333
Next
For I = 0 To 4
Debug.Print A(R2(I)) & ": " & R1(I) & ": " & R2(I)
Next
Debug.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & ",Time= " & timeGetTime - T & "ms "
End Sub
细节上应该还有一些可提高的地方，只是提供一个思路，感觉楼主的代码效率应该还有可提高的余地。
[解决办法]
Option Explicit
Private Type Diff
Count As Integer
Index As String
End Type
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
'Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
'Dim R1(NEAR - 1) As Long '存放最近差值的数组
Dim R2(NEAR - 1) As Long '存放与差值数组相对应的元素在原始数组中的下标
Private Sub Form_Load()
Dim I As Long
For I = 0 To ALL - 1
A(I) = Rnd * ALL '产生一个随机数列
Next
End Sub
Private Sub Command1_Click()
Dim T As Long
Dim I As Long
T = timeGetTime
For I = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
'CopyMemory A(0), B(0), ALL * 4 '因原始数组不会变动，这句没必要再加了，保留它只是为了与原算法速度有个比较
FSort 333
Next
For I = 0 To 4
Debug.Print A(R2(I)) & ": " & R2(I)
Next
Debug.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & ",Time= " & timeGetTime - T & "ms "
End Sub
Private Sub FSort(ByVal Test As Long)
Dim ArrDiff(ALL - 1) As Diff
Dim I As Long
Dim L As Long
Dim M As Long
Dim N As Long
Dim tmpIndex As Long, tmpA() As String, tmpS As String
For I = 0 To ALL - 1
tmpIndex = Abs(A(I) - Test)
ArrDiff(tmpIndex).Count = ArrDiff(tmpIndex).Count + 1
ArrDiff(tmpIndex).Index = ArrDiff(tmpIndex).Index & ", " & CStr(I)
Next I
I = 1
N = ArrDiff(1).Count
Do While N < NEAR
I = I + 1
N = N + ArrDiff(I).Count
Loop
For M = 1 To I
tmpS = tmpS & ArrDiff(I).Index
Next M
tmpA() = Split(Mid(tmpS, 2), ", ")
For M = 0 To NEAR - 1
R2(M) = tmpA(M)
Next M
End Sub
效率很差，本不应该贴上来，但思路不同，也算一种方法吧
[解决办法]
楼主的选择排序和homezj(小吉)的插入排序,适合Near比较小的情况
如果Near取值500,速度就慢的可怕了,这种时候还是换成快速排序比较好
而且如果修改一下快速排序,偷偷懒让它只排序左半边,达到目的后立刻退出
消耗的时间就会与Near成反比,Near越大速度越快
楼主的原始目的似乎是处理图象
RGB的取值范围很小,0-255,这种情况用桶排序应该是最快的
算完绝对值,结果也就出来了,效率应该是O(N)
[解决办法]
桶排序,假设每个数组中每个元素取值范围在0-1000 (HI) 之间
900ms左右完成,而且与NEAR取值无关,即使NEAR=500也是900ms完成(去掉debug.print语句)
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const HI As Long = 1000
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Dim C(0 To HI) As Long '用于保存排序结果
Dim D(0 To HI) As Long '用于保存最初的全0排序结果，每次测试时拷贝去将C初始化
Private Sub Form_Load()
Dim i As Long
For i = 0 To ALL - 1
B(i) = Rnd * HI '产生一个随机数列,
Next
End Sub
Private Sub FSort(ByVal test As Long)
Dim i As Long, n As Long
For i = 0 To ALL - 1 '先获得数组每一个元素和指定数字的差值
n = A(i)
C(n) = C(n) + 1
Next
End Sub
Private Sub Command1_Click()
Dim T As Long
Dim i As Long, j As Long, k As Long
Dim test As Long
test = 333
T = timeGetTime
For i = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), ALL * 4
FSort test
Next
Me.Cls
i = 1
j = test - 1
k = test + 1
Do While i < NEAR
If j > = 0 Then
Do While C(j) > 0
Debug.Print j
C(j) = C(j) - 1
i = i + 1
If i > = NEAR Then Exit Do
Loop
j = j - 1
End If
If k <= HI Then
Do While C(k) > 0
Debug.Print k
C(k) = C(k) - 1
i = i + 1
If i > = NEAR Then Exit Do
Loop
k = k + 1
End If
Loop
Debug.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & timeGetTime - T & "ms "
End Sub
[解决办法]
排序写了几行
输出结果谢了一大堆,呵呵
没调用abs函数
[解决办法]
大家用好!bbs.ab07.cn欢迎您的到来,本站刚上线!为了就是给爱好电脑的志同道合的朋友们一个好的交流平台!希望您的注册,发表您的文章,您你的想法,意见.你可以高谈阔论!
由于刚上线,很多东西不健全,包函!欢迎你的注册.欢迎您的加入!您可以成为管理员,或各级版主!有意做管理员或版主的请发往admin@ab07.cn , houzhanfeng@gmail.com
[解决办法]
楼上果然是搞IT的..........
[解决办法]
学习一下先，等有时间来看！！
[解决办法]
yachong(蚜虫)的测试方法有问题，你把排序循环移到10000次重复循环之外，这等于说：本该进行一万次的测试，你却只进行了一次，时间当然很少。
To:楼主
我之所以问了那两个问题，是因为，你的原代码就是这么做的，与你回复中的需求解释并不一致，以你代码中的随机数组为例，这个数组中可能会有5个以上的值都是333，到底哪个算“测试值本身这个值”？若这样，就算你去掉一个，前五个最近值中还是会全部都是333的，这与你的代码输出结果不符。
在你的代码中，其实对差值相等的数也是只取其一的，因为If D(M) > D(I) Then这句，对于D(M)= D(I)的差值是全部跳过，并不会被记录进M中。这样的结果，在有多个332与334时，却只取到一个332或334（谁先出现先取谁）。而且后面更远的331、335、330、336等，实际并不能排入前五的值都可能被取进来。
楼主提到关于ABS的函数调用问题，我觉得影响不大，因为VB6的内部函数调用不同于自定义函数或外部API调用，它是经过高度优化的，像ABS这样的函数可能也就相当于一次普通整数加减运算，对效率影响很小，我的代码中把Abs(A(I) - Test)，改成A(I)-1，运行时间只从1.8秒变成1.7秒，而且这是相当于在少了一次运算的条件下，综合来看，其影响可能只在1%左右。
基于上述观点，我觉得这个算法的核心还是应在减少循环次数上下功夫，我那段代码是基于NEAR值较小这个前提而写的，外循环是All次，内循环，在最理想情况下（最近值正好全部位于前NEAR位），只需运行NEAR次，若能加上一些判断，可能这NEAR次都能省掉，但在乱序情况下，意义不大，效率提高并不明显。
[解决办法]
homezj(小吉),我的排序确确实实调用了10000次
外面的while循环并非排序,而是为了输出结果
我改了一下,把输出结果部分也循环调用10000次,时间仍然在1000ms之内
当然,为了避免额外开销,我去掉了debug.print部分,调用10000次debug.print太费时间
Private Sub Command1_Click()
Dim T As Long
Dim i As Long, j As Long, k As Long, L As Long
Dim test As Long
test = 333
T = timeGetTime
For i = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), ALL * 4
FSort test
L = 1
j = test - 1
k = test + 1
Do While L < NEAR
If j > = 0 Then
Do While C(j) > 0
'Debug.Print j
C(j) = C(j) - 1
L = L + 1
If L > = NEAR Then Exit Do
Loop
j = j - 1
End If
If k <= HI Then
Do While C(k) > 0
'Debug.Print k
C(k) = C(k) - 1
L = L + 1
If L > = NEAR Then Exit Do
Loop
k = k + 1
End If
Loop
Next
Debug.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & timeGetTime - T & "ms "
End Sub
[解决办法]
明白楼主的意思了，按楼主的解释，我那个M> 0的判断完全可以去掉，没想到，速度一下大幅提高，由原来的1.8秒为1.2秒，接近yachong(蚜虫)的代码了，主过程修改如下：
Private Sub FSort(Test As Long)
Dim I As Long
Dim L As Long
Dim M As Long
Dim N As Long
For N = 0 To NEAR - 1
R1(N) = &H7FFFFFFF '初始化待比较值为最大正数
Next
For I = 0 To ALL - 1
M = Abs(A(I) - Test) '先获得数组每一个元素和指定数字的差值
If M < R1(NEAR - 1) Then '大于等于最大差值的不要
For N = 0 To NEAR - 2 '把这个值记录进最近值数组，并进行必要的排序
If M < R1(N) Then '若比数组中前面的差值还小，则要插入，把其后的值后移，保证数组中的差值始终从小到大
For L = NEAR - 1 To N + 1 Step -1
R1(L) = R1(L - 1)
R2(L) = R2(L - 1)
Next
Exit For
End If
Next
R1(N) = M
R2(N) = I
End If
Next
End Sub
这里不得不提一下yachong(蚜虫)的思路，今天仔细看了一下，觉得它存在三个不足：
1、原始数值范围受限较大，这要看楼主的实际应用需求了，若是基于Color值，取值范围是Long，那么这个代码将没有实用价值，若是基于RGB分量，那么取值范围是Byte，则该代码有重要参考意义；
2、该代码重在统计，并没有（也不方便）记录最近值在原始数组中的下标，这在实际使用中，可能会有问题，尤其是在基于RGB分量时，可能不记录下标，将无法定位原像素，这与前一个问题构成一个矛盾；
3、在IDE环境下虽是最快的，在我机器上输出结果为0.8秒，比我的代码快近50%，但有一点要注意，编译成N代码后，情况就不同了，因为Do循环中只在IDE下快，编译后远远不如For循环，所以，两个代码正好反过来，我的代码约比yachong(蚜虫)的代码快10%。为便于于测试，我将总测试次数增加10倍，设为100000次，结果我的用时为505ms，yachong(蚜虫)的用时为572ms。
不过，说了半天我还是推荐yachong(蚜虫)的代码，因为它的思路很好，效率很高，最最关键的一点，是它受NEAR值的影响最小，NEAR值增大10倍，IED下用时只增加不到一倍，而我的代码却增加超过10倍。
附上我优化后符合楼主测试格式的yachong(蚜虫)代码：
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Dim C(ALL - 1) As Long '用于保存排序结果
Dim D(ALL - 1) As Long '用于保存最初的全0排序结果，每次测试时拷贝去将C初始化
Dim R(NEAR - 1) As Long
Private Sub Form_Load()
Dim i As Long
For i = 0 To ALL - 1
B(i) = Rnd * ALL '产生一个随机数列,
Next
End Sub
Private Sub FSort(ByVal test As Long)
Dim i As Long, j As Long, k As Long, L As Long
For i = 0 To ALL - 1 '先获得数组每一个元素和指定数字的差值
C(A(i)) = C(A(i)) + 1
Next
j = test
k = test + 1
Do While L < NEAR
If j > = 0 Then
Do While C(j) > 0
'Debug.Print j
R(L) = j
C(j) = C(j) - 1
L = L + 1
If L > = NEAR Then Exit Sub
Loop
j = j - 1
End If
If k < ALL Then
Do While C(k) > 0
'Debug.Print k
R(L) = k
C(k) = C(k) - 1
L = L + 1
If L > = NEAR Then Exit Sub
Loop
k = k + 1
End If
Loop
End Sub
Private Sub Command1_Click()
Dim T As Long, i As Long
T = timeGetTime
For i = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), ALL * 4
FSort 333
Next
MsgBox timeGetTime - T
For i = 0 To NEAR - 1
Debug.Print R(i)
Next
Debug.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & timeGetTime - T & "ms "
End Sub
[解决办法]
面一下，收藏了。
[解决办法]
不错，不错，收藏起来研究一下，呵呵
[解决办法]
这种问题直接反应就桶排序（数据不能严重不均匀，要不也要挂掉 :)）,然后可以考虑经常做的统计Top N的做法（类似快速排序，复杂度 N),只是稍微要做一些特殊处理
没有达到O（N）的都可以优化
[解决办法]
很久不来，一来就看见楼主大作。。。
以前粗略看过小仙妹提到的一个直方图算法，或许可以变形应用到这个问题。。
先说说直方图算法的限制：1。源数据序列中数据的最大、最小值必须已知，2，源数据序列中数据的最大－最小值不能太大。
再说解决楼主问题的思路：
假定原数列为A(N)，选定的参考数字为S,最后要选出与S值最接近的M个数字
建一新数组b，长度为源数据序列中数据的最大－最小值。。。
for t=0 to N
k=abs(a(n)-s)
b(k)=b(k)+1
next
循环结束后从b(0)开始把元素值相加并记数，有需要可同时计算总值，直到凑够M为止。。。
如循环后b(0)：2，b(1)：3，b(2)：0，b(3)：3，b(4)：6，b(5)：1 要求M=10
可知结果为：同值两个，相差1三个，相差2没有，相差3三个，相差4两个
算法缺点：
1、abs的使用，只能知绝对值，是多的多还是少的多不知道，联想到这算法只是因为看到前面楼主说是应用到除噪方面，只需知道绝对值。
2、算法前提条件太呵刻
3、对楼主在图形处理方面的应用估计没有什么作用。。
4、现在已经没有vb作测试，不知效率如何。。
[解决办法]
lsftest所说的的办法与yachong(蚜虫)代码基本一致。实用价值与效率上感觉还是yachong(蚜虫)代码略高一些。但我又发现yachong(蚜虫)代码的两个不足：
1、取值不平均，总是先取完大于Test的最近值，再取小的，这会产生大值用光所有NEAR限额，而小的却一个没取，这对准确求平均值是不利的；
举个极端例子：如果在没有别的更近值的情况下，最近值正好有5个666与5个0时，那么它会取出全部666，却一个0也没取，平均值本是333的，它却得出666的结论，这会让误差高达100%。
2、它速度可能会受随机值分布影响较大，也是说，最近值离Test很近时，它后面的Do循环几乎不耗时，对速度影响多在5%以下，但若最近值离Test很远，循环量将是巨大的。
再举个极端例子：将“B(i) = Rnd * ALL”改成“B(i) = ALL-1”，然后，“FSort 333”改成“FSort 1”，这样再运行试试，耗时一下子增加了3倍多。
说这两个不足，对图像处理是有意义的，因为对于存在大块单色区域或色彩不够丰富的图片来说，这两种极端情况是很常见的。楼主是否采用这一方案是要酌情考虑一下。
[解决办法]
Up
[解决办法]
lsftest所说的的办法与yachong(蚜虫)代码基本一致。实用价值与效率上感觉还是yachong(蚜虫)代码略高一些。
=================================
不一样吧，看了一下yachong(蚜虫)兄的代码，似乎他的代码实用局限性更大。。。
我的方法着重于数据的数值计算、统计分析，对于数据的其他细节没有保留，主要是两个方面：
1、排序后的数值在源序列的下标，但我觉得这并不重要，因为我并没有破坏源序列，还是可以找得到的。
2、最主要的问题，结果序列b（）不能明确指出具体的数值。。。例如，测试值为test＝333，比较后得到我上面的举例的结果：b(0)：2，b(1)：3，b(2)：0，b(3)：3，b(4)：6，b(5)：1
可以看到，与333相差4的值有6个，这6个值必然是329或337，但329占6分之几，337占6分之几？？？不知道。。。。不过这问题也很好解决，只要多加一个序列c（），与b（）相对应，如源数据比测试值大，b（）与c（）相应项都加1，如源数据比测试值小，b（）相应项加1，c（）相应项减1，从而在最后的c（）序列c（4）的值中可以知道上面例子中329占6分之几，337占6分之几。。。
至于效率，由于没有测试条件，也不好说什么，但由于不必排序，循环的次数也并不多。。。应该还可以。。。
当然，我也承认，这算法在实际应用中适用范围确实不广。。。。
[解决办法]
另外，yachong(蚜虫)兄的代码也有些地方不是很明白。。
Private Sub FSort(ByVal test As Long)
Dim i As Long, n As Long
For i = 0 To ALL - 1 '先获得数组每一个元素和指定数字的差值
n = A(i)
C(n) = C(n) + 1
Next
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
子过程里面看不出test有什么用，是多余的还是这部分可能会有修改？
For i = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), ALL * 4
FSort 333
Next
MsgBox timeGetTime - T
For i = 0 To NEAR - 1
Debug.Print R(i)
Next
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
CopyMemory C(0), D(0), ALL * 4是必须的，但CopyMemory A(0), B(0), ALL * 4？？？？难道10000次都是对同一组数据进行处理吗？？？这样的测试结果可能会因为随机数分布的不同而结果相差很远。。。不省这一步，出10000次随机序列即使进行处理的结果应该准确一点。。。当然显示的结果用时必然大大多于你现在的结果。。。
[解决办法]
lsftest() ,老实说,我觉得你描述的算法跟我实现的一回事,桶排序而已
至于 "CopyMemory A(0), B(0), ALL * 4 "这个问题,从楼主的代码开始就是这样子的,我照搬的.
我试着这样写了一下:
Randomize Time
For i = 0 To 10000
'每次重新生成随机序列
For j = 0 To ALL - 1
B(j) = Rnd * ALL '产生一个随机数列,
Next
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), HI * 4
FSort test
Next
结果是时间从1000ms上升到了2000ms,每次执行都差不多,误差不超过100ms
原来的哪个参数test确实无用,忘记删除了
homezj(小吉)
1、取值不平均，总是先取完大于Test的最近值，再取小的
===========================================================
这确实是个问题,我修改了一下,顺便修改了别的几个错误
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Const HI As Long = 1000
Const ALL As Long = 1000 '待选数组长度,上文中的N
Const NEAR As Long = 5 '最接近选定数字的数量，上文中的M
Dim A(ALL - 1) As Long '这个数组用来存放原始数据
Dim B(ALL - 1) As Long '用于生成最初的原始数据，每次测试时拷贝去A将A初始化
Dim C(0 To HI) As Long '用于保存排序结果
Dim D(0 To HI) As Long '用于保存最初的全0排序结果，每次测试时拷贝去将C初始化
Dim Result(0 To NEAR - 1) As Long '保存排序后挑选出的Near个数据
Private Sub Form_Load()
Dim i As Long
For i = 0 To ALL - 1
B(i) = Rnd * ALL '产生一个随机数列,
Next
End Sub
Private Sub FSort(ByVal test As Long)
Dim i As Long, j As Long, k As Long, n As Long
For i = 0 To ALL - 1
n = A(i)
C(n) = C(n) + 1
Next
i = 0
j = test - 1
k = test + 1
Do While i < NEAR And j > = 0 And k <= HI
If j > = 0 Then
If C(j) > 0 Then
C(j) = C(j) - 1
Result(i) = j
i = i + 1
If i > = NEAR Then Exit Do
Else
j = j - 1
End If
End If
If k <= HI Then
If C(k) > 0 Then
C(k) = C(k) - 1
Result(i) = k
i = i + 1
If i > = NEAR Then Exit Do
Else
k = k + 1
End If
End If
Loop
End Sub
Private Sub Command1_Click()
Dim t As Long
Dim i As Long, j As Long, k As Long, n As Long
Dim test As Long
test = 333
t = timeGetTime
For i = 0 To 10000 '每次调用前先将原数组还原，否则前次排序将影响后次的结果
CopyMemory A(0), B(0), ALL * 4
CopyMemory C(0), D(0), HI * 4
FSort test
Next
Me.Cls
For i = 0 To NEAR - 1
Me.Print Result(i)
Next
Me.Print "All= " & ALL & ",Near= " & NEAR & ",Loop=10000 " & "Time= " & timeGetTime - t & "ms "
End Sub
[解决办法]
晕,新错误
Do While i < NEAR And j > = 0 And k <= HI
应该改为
Do While i < NEAR And (j > = 0 Or k <= HI)
加上后面对j k的判断,当随机序列中绝大部分数值与test相同,无法找到Near个临近数值时能退出循环
[解决办法]
你这个算法应该用 "亮度直方图 "。
假设A()为一个位平面的亮度数组（在灰度图里面只有一个、RGB格式有三个、CMYK有四个），其亮度值为0-255。La()为亮度直方图，是Long类型。
典型的一维直方图算法很简单：
ReDim La(0 to 255)
For i=0 to UBound(A())
La(A(i))=La(A(i))+1
Next
对于模式识别、色选用途的处理程序还可以用二维亮度直方图。二维直方图是两个位面共同建立的。比方说对R()、G()两个位面做二维直方图：
Dim La(255,255) '直方图的二维数组
For i=0 to UBound(R())
For j=0 to UBound(G())
La(R(i),G(j))=La(R(i),G(j))+1
Next
Next
二维直方图用于研究显示出来通常以45度视角的棒图高度来表示亮度，形成一张“地面”。对于一张自然拍摄的彩色图象，二维直方图通常看起来是沿着一个轴倾斜排列的“山脉”，通常有两座或者更多“山峰”。（一维直方图通常也会看到两座山峰）
同理，你还可以做三维直方图。但三维直方图不好用视觉方法表示。通常的办法是通过等比亮度来表示。
类似于直方图的算法对于取值范围有限的数据确实可以排序，而且效率非常高，比如用于破解传统的乱序密码表加密的密码。但直方图最多的是用于图象处理，对于图象处理算法有重要意义。我就是在学习数字图象处理的时候学会这种算法的。如果你要研究直方图，可以在Photoshop里直观地看到一维直方图。
对于直方图的具体运用，你可以参考图象相关的专业著作。
[解决办法]
呵呵。。。又见小仙妹。。。。。。。
最近又有没有些什么好玩的算法？？？？？
楼上诸位研究的已不仅仅楼主的图像处理问题了。。。
[解决办法]
替你顶一顶
[解决办法]
顺便说一下，上面二维直方图的算法写错了。应该是：
For i=0 to Ubound(R())
L(R(i),G(i))=L(R(i),G(i))+1
Next
[解决办法]
大家好！我是“顶者”，因为楼主说“顶者有分”，所以我纯粹来拿分的-o-
其实是因为题目太长了，不太想看…………
[解决办法]
mark
[解决办法]
mark
[解决办法]
mark
[解决办法]
强顶！
