用VBA解欧拉计划题目（106）--特殊的子集和：元检验

grf1973

全部代码

1. 'P106:特殊的子集和: 元检验
   
2. '
   
3. '记S(A)是大小为n的集合A中所有元素的和。若任取A的任意两个非空且不相交的子集B和C都满足下列条件，我们称A是一个特殊的和集：'
   
4. 'S(B) ≠ S(C)；也就是说，任意子集的和不相同。
   
5. '如果B中的元素比C多，则S(B) > S(C)。
   
6. '在这个问题中我们假定集合中包含有n个严格单调递增的元素，并且已知其满足第二个条件。'
   
7. '令人惊奇的是，当n = 4时，在所有可能的25组子集对中只有1组需要检验子集和是否相等（第一个条件）。同样地，当n = 7时，在所有可能的966组子集对中只有70组需要检验。'
   
8. '当n = 12时，在所有可能的261625组子集对中有多少组需要检验？
   
9. 
   
10. '分析：
    
11. 'n=4,考察2p2的情况，只有（14，23）。。。。。1种
    
12. 'n=5,也只需考察2p2的情况，有C(5,4)*1=5种
    
13. 'n=6, 考察2p2的情况，有C(6,4)*1=15种
    
14. '             3P3的情况，有(156,234),(146,235),(136,245),(126,345),(145,236) 5种
    
15. '             共计20种
    
16. 'n=7, 考察2p2的情况，有C(7,4)*1=35种
    
17. '             3P3的情况，有C(7,6)*5=35种
    
18. '             共计70种?
    
19. '可令f(n,m)为n个元素的集合，考察mPm的情形
    
20. '      f(n, m) = c(n , 2 * m) * g(2*m, m)，其中g(2m,m)为2m个元素中需考察mPm的个数
    
21. '只要能计算出g(2*m,m)的个数，那么可以推导也所有f
    
22. Dim brr, t
    
23. Sub problem106()
    
24.     n = 12
    
25.     For m = 2 To n / 2
    
26.       '  res = res + Application.combin(n, 2 * m) * g(2 * m, m)
    
27.       res = res + Application.combin(n, 2 * m) * g(m)
    
28.     Next
    
29.     Debug.Print res
    
30. End Sub
    
31. 
    
32. Function g(n)   '2n个数中选n-n需比对的个数      初始数组arr,返回brr,n为选取个数
    
33.     t = 0
    
34.     ReDim arr(2 * n - 1)
    
35.     For k = 1 To 2 * n
    
36.         arr(k - 1) = k
    
37.     Next
    
38.     'arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    
39.     'n = (UBound(arr) + 1) / 2
    
40.     ReDim result(0 To UBound(arr))
    
41.     ReDim brr(1 To Application.combin(UBound(arr) + 1, n))    '结果的个数
    
42.     Call Cmbine(arr, 0, result, n, n, UBound(arr) + 1)   '用递归生成数组brr，为集合arr取n个的所有组合，首尾相对
    
43.     For i = 1 To UBound(brr) / 2
    
44.         s1 = Split(brr(i), ","): s2 = Split(brr(UBound(brr) - i + 1), ",")  '首尾两两配对
    
45.         tmp = 0
    
46.         For t = 1 To UBound(s1)
    
47.             a = Val(s1(t)): b = Val(s2(t))
    
48.             tmp = tmp + Sgn(a - b)   'sgn：符号函数，正数为1，负数为-1
    
49.         Next
    
50.         If Abs(tmp) < n Then res = res + 1     '关键句：两个集合B,C，如果不是B所有元素都大于或小于C所有元素，那么需要检验
    
51.     Next
    
52.     g = res
    
53. End Function
    
54. 
    
55. '//arr为原始数组
    
56. '//start为遍历起始位置
    
57. '//result保存结果，为一维数组
    
58. '//count为result数组的索引值，起辅助作用
    
59. '//NUM为要选取的元素个数
    
60. '//arr_len为原始数组的长度，为定值
    
61. Sub Cmbine(arr, start, result, count, NUM, arr_len)
    
62.     i = 0
    
63.     For i = start To arr_len + 1 - count - 1
    
64.         result(count - 1) = i
    
65.         If count - 1 = 0 Then
    
66.             For j = NUM - 1 To 0 Step -1
    
67.                 s = s & "," & arr(result(j))
    
68.             Next
    
69.             t = t + 1
    
70.             brr(t) = s: s = ""
    
71.         Else
    
72.             Call Cmbine(arr, i + 1, result, count - 1, NUM, arr_len)
    
73.         End If
    
74.     Next
    
75. End Sub
    

复制代码

grf1973

核心是：对于各含n个元素两个有序的子集B,C，将其对应元素两两相减（B(1)-C(1)，B(2)-C(2)，。。B(n)-C(n)），如果全部同正负，那么无需检验，否则需要检验。
比如1234，显然只有14，23需要检验

香川群子

grf1973 发表于 2018-1-2 16:05
折腾了一下午，终于搞定，结果正确。

g值正确。但你是怎么推算出来的？
是硬算吗？哈哈哈。

我的算法虽然稍复杂一些，却是完全可以自动计算的。


…………
哈哈哈，看到新的回帖了，也是需要生成全部组合进行计算的。
但是，比我的方法总是节省时间了。

其实我的也可以简化，直接生成Combin(m,m/2)的各种组合就可以了。

香川群子

grf1973 发表于 2018-1-2 16:07
嗯，香川的结果对了，是21384

按你的思路，修改一下，就更简单了：

1. 递归生成1开始的2n取n组合，并检查每个组合是否需要检查可能相等。
2. 和组合结果进行累乘积。

1. Dim k&, n&, s$
   
2. Sub test() 'by kagawa 2018/1/2 仅检查相等部分需多少次？
   
3.     Dim m&, r&, t&, tms#
   
4.     tms = Timer
   
5.    
   
6.     m = 12
   
7.     For n = 2 To m / 2
   
8.         s = String(n * 2, "2")
   
9.         k = 0: Call dgZH(0, 1)
   
10.         
    
11.         t = Application.Combin(m, 2 * n)
    
12.         Debug.Print k; t; k * t
    
13.         r = r + k * t
    
14.     Next
    
15.     Debug.Print Format(Timer - tms, "0.000s"); r
    
16.     MsgBox Format(Timer - tms, "0.000s") & vbCr & m & vbCr & r
    
17. End Sub
    
18. Sub dgZH(i1&, t&) '生成个数较少的S(C)组合
    
19.     Dim i&
    
20.     For i = i1 + 1 To IIf(t = 1, 1, n + t) '只需生成1开始的组合
    
21.         Mid(s, i, 1) = 1
    
22.         If t < n Then
    
23.             Call dgZH(i, t + 1)
    
24.         Else
    
25.             If f(s) Then k = k + 1 '检查统计
    
26.         End If
    
27.         Mid(s, i, 1) = 2
    
28.     Next
    
29. End Sub
    
30. Function f(s) As Boolean '检查12对子的排列情况
    
31.     Dim j1&, j2&
    
32.     Do
    
33.         j1 = InStr(j1 + 1, s, "1")
    
34.         If j1 = 0 Then Exit Function '没有新的12对子了
    
35.         
    
36.         If j2 < j1 Then j2 = j1 '只检查比1更大一些的2成为1组12对子
    
37.         j2 = InStr(j2 + 1, s, "2")
    
38.     Loop Until j2 = 0 '找不到比上个1更大的2时 就产生1221类型的相等可能性
    
39.     f = True
    
40. End Function

复制代码