[开_86] 比速度,看谁的程序更快.

香川群子

彭希仁 发表于 2012-10-8 17:56
Dim arr, z As Long, jj As Long, d, j%, xx
Sub peng()
    Set d = CreateObject("Scripting.Dictionar ...

这个代码就是为1-100自然递增序列求目标总和的要求【量身定做】的代码啊。

由于一次递归可以计算相邻的两个结果，所以速度有所提高……


但是由于采用了从小到大的升序递归法，计算量是线性增加的。

当原始数据是间隔不等的随机整数时，这个代码就可以洗洗睡了……慢的要死。

香川群子

因此，从通用代码的角度看，目前还是我的【降序递归+末位计算+累计值比较判断剪枝】方法最具实用性。

彭希仁

Dim arr, jj As Long
Sub peng()
    Dim z%
    jj = 0
    Open "d:\peng.txt" For Output As #1
    Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
    arr = Range("A1:B" & [A65536].End(xlUp).Row)
    z = Cells(1, 2)
    arr(1, 2) = arr(1, 1)
    For i = 2 To UBound(arr)    '定位
        arr(i, 2) = arr(i - 1, 2) + arr(i, 1)
    Next i
    aa = Timer
    Call xi("", UBound(arr), z)
    MsgBox "找到 " & jj & " 个解! 花费" & Format(Timer - aa, "0.00" & "保存在D:\peng.txt") & "秒"
    Close #1
End Sub
Sub xi(a, X%, y%)
    If y = arr(X, 1) Then
        jj = jj + 1
        'Print #1, arr(X, 1) & a
        X = X - 1
    End If
    If X < 2 Then Exit Sub    '最低层就退出
    If y > arr(X, 2) Then Exit Sub     '不够就退出
    If y > arr(X, 1) Then Call xi("+" & arr(X, 1) & a, X - 1, y - arr(X, 1))  '
    Call xi(a, X - 1, y)
End Sub

这样应该比你的快了吧

香川群子

还是我的递归更快一些。

尤其是，我的递归代码通用性好，对其它各种随机整数序列也照样很快计算出结果来……

但彭版最近的两个递归代码都做不到。


请看附件，只有计算过程，没有输出的代码。

另外，统计代码运行时间，只算递归过程开始运行直到结束的时间。


…………
为了尽量保证条件相同，我都把彭版的代码中的变量名称、变量类型也统一起来了。……甚至先后顺序。
确保没有造成代码干扰，完全是算法比拼了。呵呵。

香川群子

最终定型代码，以及解释说明：

1. 
   
2. 
   
3. Dim sj, jg(), m%, k, h%
   
4. '定义公用变量
   
5. 【sj】把原始数据读入数组、【jg()】输出结果到工作表时的内存数组、【m】原始数据最大个数、
   
6. 【k】计算结果累计数、【h】目标和值
   
7. 
   
8. Sub kagawa_5()
   
9.     Dim i%
   
10.    
    
11.     h = [b1] '获取目标和值
    
12.     m = [a1].End(4).Row '获取A列原始数据的最大行数
    
13.     [a1].Resize(m).Sort [a1], 1, , , 2 '原始数据按升序排序
    
14.     sj = [a1].Resize(m, 2) '把排序后的原始数据读入数组sj,并扩展1列储存累计数
    
15.    
    
16.     sj(1, 2) = sj(1, 1) '数组sj的第2列写入累计数，这个算法是我的发明，很重要。
    
17.     For i = 2 To m
    
18.         sj(i, 2) = sj(i - 1, 2) + sj(i, 1)
    
19.        '依次统计从第1行开始到本行的最大累计数。以后递归过程中可用来检查退出循环的时机，减少了无效的循环。
    
20.     Next
    
21.    
    
22. '    Open "D:\Backup\我的文档\Result.txt" For Output As #1 '结果写入记事本时
    
23. 
    
24.     k = 0: tms = Timer 'k值归零,开始计时
    
25.     Call dgH5(h, "", m + 1) '调用递归过程代码，注意参数输入【目标和值】、【文本结果表达式】、【计算起始位置】
    
26.     MsgBox "Result: " & k & "/ Time: " & Format(Timer - tms, "0.000s") '报告计算结果个数以及耗用时间。
    
27. '    Close #1 '关闭记事本文件
    
28. End Sub
    
29. 
    
30. 
    
31. '下面是递归计算过程代码，本过程特点为：
    
32. 【倒序递归计算】、【末位计算剪枝】、【累计数不足剪枝】
    
33. 
    
34. Sub dgH5(r%, s$, i%) '参数依次为：【剩余和值】、【文本结果表达式】、【当前计算起始位置】
    
35.     Dim j%
    
36.    
    
37.     For j = i - 1 To 1 Step -1 '【末位计算剪枝】，从当前位置开始倒序检查。
    
38.         If r = sj(j, 1) Then '如果查询到等于剩余和值时，即可作为正确的末位值结果
    
39. '            Print #1, s & "+" & r '写入记事本文件
    
40.             k = k + 1 '结果总数k+1
    
41.             Exit For '退出倒序检查
    
42.         ElseIf r > sj(j, 1) Then '当检查不到等于和值的数值时，还要比对检查位置的值是否已经不大于剩余和值。
    
43.             '这也是一个重要的剪枝算法。
    
44.             '原理是：如果sj(j, 1)>剩余和值r，则当前值没有加入计算的必要
    
45.             '如果是 sj(j, 1)=剩余和值r，那么就是得到结果。
    
46.             '因此，如果是sj(j,1)<r，则当前值有可能是符合递归计算条件的元素，必须停止循环，进入下一层次的递归了
    
47.             j = j + 1 '为了保证下一步的起算起点，需要+1调整
    
48.             Exit For '退出倒序检查
    
49.         End If
    
50.     Next
    
51. 
    
52.     For j = j - 1 To 2 Step -1 '倒序检查时最高效的，因为可以顺便检查累计值。由于末位可通过计算得到，所以循环下限值=2
    
53.         If r > sj(j, 2) Then '这里是关键的【累加值有效性剪枝】
    
54.             Exit For '如果当前位置的【累加值】已经小于剩余和值r，即表示剩余所有元素全部加入递归也不够……
    
55.                          '因此当然可以提前退出，而不需要递归计算下去了。 可不能不见黄河心不死啊……
    
56.         Else
    
57.             Call dgH5(r - sj(j, 1), s & "+" & sj(j, 1), j) '淡定地进入下一层次的递归，即加入下一个有效元素，进行新的递归计算……
    
58.         End If
    
59.     Next
    
60. 
    
61. End Sub

复制代码

香川群子

事实上，我也不是一开始就想到这么多的……

但是我做了一个不同算法代码的循环次数统计比较，
很快发现，不同的算法，剪枝效果有差异。

同时还发现，有时候并非循环次数越少越好，还要看循环中代码的利用效率、计算速度……等等。

最新的代码之所以速度又有提高，关键在于、倒序检查末位数是否存在的同时，把第一个小于剩余和值的有效递归元素位置也给确定下来了，
减少了后面的循环计算量。

彭希仁

香川群子 发表于 2012-10-9 22:30
还是我的递归更快一些。

尤其是，我的递归代码通用性好，对其它各种随机整数序列也照样很快计算出结果来 ...

你两次调用的都是旧代码。
新代码速度上差不了多少，而且还有剪枝空间。

香川群子

彭希仁 发表于 2012-10-9 23:57
你两次调用的都是旧代码。
新代码速度上差不了多少，而且还有剪枝空间。

经过算法上的进一步研究，速度又有了突破……

1-100的100个连续自然数，求目标和=100时，

新方法计算速度提高了一倍多，进入了1秒以内世界……！！！



原理是这样的：

我发现，余数较大时可以再拆分，例如：
3有2种，3 和 2+1
4有2种，4 和 3+1
5有3种，5 和 4+1 和 3+2
…………
而且这些拆分组合，实际上是一直固定不变的……


因此，如果事先把<h/2【小于目标和一半】的所有结果组合都计算出来，
并存入数组，则以后每次从大到小倒序计算剩余数r时，完全可以直接引用其各种组合结果了……

这个就是提速的关键。


请看附件。

不过，目前代码有个明显的bug，即不能计算随机的自然数序列，只能计算从1开始递增的自然数序列。

这个需要代码分析调试。

我这里先把半成品传上来，看看惊人的效果。

香川群子

这个方法，我称其为【数组预置法】

第一步骤计算出来的【数组预置结果】举例如下：

1  1=;+1
1  2=;+2
2  3=;+3;+2+1
2  4=;+4;+3+1
3  5=;+5;+4+1;+3+2
4  6=;+6;+5+1;+4+2;+3+2+1
5  7=;+7;+6+1;+5+2;+4+2+1;+4+3
6  8=;+8;+7+1;+6+2;+5+2+1;+5+3;+4+3+1
8  9=;+9;+8+1;+7+2;+6+2+1;+6+3;+5+3+1;+5+4;+4+3+2
10 10=;+10;+9+1;+8+2;+7+2+1;+7+3;+6+3+1;+6+4;+5+3+2;+5+4+1;+4+3+2+1
12 11=;+11;+10+1;+9+2;+8+2+1;+8+3;+7+3+1;+7+4;+6+3+2;+6+4+1;+6+5;+5+3+2+1;+5+4+2
15 12=;+12;+11+1;+10+2;+9+2+1;+9+3;+8+3+1;+8+4;+7+3+2;+7+4+1;+7+5;+6+3+2+1;+6+4+2;+6+5+1;+5+4+3;+5+4+2+1
……

香川群子

主代码中分别调用了两个递归过程

1. 
   
2. Dim sj, jg(), ys(), x(), m%, n%, k, h%, cnt
   
3. Sub kagawa_7() '递归组合求和-7 【数组预置结果方法】
   
4.     tms = Timer
   
5.     m = [a1].End(4).Row: ' sj0 = [a1].Resize(m)
   
6.     [a1].Resize(m).Sort [a1], 1, , , 2 '如果原始数据乱序则先升序排序
   
7.     sj = [a1].Resize(m, 2): ' [a1].Resize(m) = sj0 '排序处理后原始数据恢复原状
   
8.    
   
9.    Size = Array(20, 80, 300, 1200, 3800, 12000, 30000, 78000, 190000, 445000) '增加了对x数组大小的自动判断
   
10.     ReDim ys(1 To [b1])
    
11.     For i = 1 To m
    
12.         If i = 1 Then sj(1, 2) = sj(1, 1) Else sj(i, 2) = sj(i - 1, 2) + sj(i, 1)
    
13.         h = sj(i, 1)
    
14.         If h < [b1] / 2 Then
    
15.             ReDim x(Size([b1] / 20)) '根据计算目标和要求定义合适的x数组大小
    
16.             k = 1
    
17.             Call dgH71(h, "", i + 1)
    
18.             x(0) = k - 1
    
19.             ReDim Preserve x(k - 1)
    
20.             ys(h) = x
    
21.             'Cells(i, 4) = Join(x, ";") '调试时把前期计算好的【数组预置结果】写入工作表确认
    
22.         Else
    
23.             n = i: Exit For
    
24.         End If
    
25.     Next
    
26.     MsgBox "PreTime: " & Format(Timer - tms, "0.000s")
    
27. '    Exit Sub
    
28.    
    
29.     ReDim jg(65536, 0)
    
30.     k = 0: cnt = 0: tms = Timer
    
31.     h = [b1]
    
32.    
    
33.     Call dgH72(h, "", m + 1)
    
34.    
    
35.     MsgBox "Result: " & k & "/ Calc " & cnt & " Time: " & Format(Timer - tms, "0.000s")
    
36.     If k > 0 And k < 65536 Then [e:e] = "": [e1].Resize(k) = jg
    
37. End Sub
    
38. 
    
39. Sub dgH71(r%, s$, i%) '递归过程-1，仅仅计算返回所有<h/2的组合结果到预置数组中去
    
40.     Dim j%
    
41.    
    
42.     For j = 1 To i - 1
    
43.         If IsArray(ys(r)) Then
    
44.             For t = ys(r)(0) To 1 Step -1
    
45.                 If Val(s) > Val(ys(r)(t)) Then
    
46.                     x(k) = s & ys(r)(t)
    
47.                     k = k + 1
    
48.                 End If
    
49.             Next
    
50.             Exit For
    
51.         ElseIf r = sj(j, 1) Then
    
52.             x(k) = s & "+" & r
    
53.             k = k + 1
    
54.             Exit For
    
55.         ElseIf r < sj(j, 1) Then
    
56.             j = j + 1
    
57.             Exit For
    
58.         End If
    
59.     Next
    
60.         
    
61.     For j = j - 1 To 2 Step -1
    
62.         If r > sj(j, 2) Then
    
63.             Exit For
    
64.         Else
    
65.             Call dgH71(r - sj(j, 1), s & "+" & sj(j, 1), j)
    
66.         End If
    
67.     Next
    
68. End Sub
    
69. 
    
70. Sub dgH72(r%, s$, i%) '递归过程-2，用来计算本次最终结果。其中余数部分直接调用【数组预置结果】以提高速度。
    
71.     Dim j%
    
72.     cnt = cnt + 1
    
73.    
    
74.     For j = 1 To i - 1
    
75.         If IsArray(ys(r)) Then
    
76.             For t = ys(r)(0) To 1 Step -1
    
77.                 If sj(i, 1) <= Val(ys(r)(t)) Then Exit For
    
78. '                ss = s & ys(r)(t)
    
79. '                jg(k, 0) = s & ys(r)(t)
    
80.                 k = k + 1
    
81.             Next
    
82.             Exit For
    
83.         ElseIf r = sj(j, 1) Then
    
84. '            ss = s & "+" & r
    
85. '            jg(k, 0) = s & "+" & r
    
86.             k = k + 1
    
87.             Exit For
    
88.         End If
    
89.     Next
    
90.         
    
91.     For j = j - 1 To 2 Step -1
    
92.         Call dgH72(r - sj(j, 1), s & "+" & sj(j, 1), j)
    
93.     Next
    
94. End Sub

复制代码

比速度1-160最快(数组预置法).rar (33.41 KB, 下载次数: 140)

2012-10-14 14:37 上传

点击文件名下载附件