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

grf1973

36828  21605   两个结果都提交了，结果错误。。。。。。

grf1973

n=4,考察2p2的情况，只有（14，23）。。。。。1种
n=5,也只需考察2p2的情况，有C(5,4)*1=5种
n=6, 考察2p2的情况，有C(6,4)*1=15种
             3P3的情况，有(156,234),(146,235),(136,245),(126,345),(145,236) 5种
             共计20种
n=7, 考察2p2的情况，有C(7,4)*1=35种
             3P3的情况，有C(7,6)*5=35种
             共计70种。
可令f(n,m)为n个元素的集合，考察mPm的情形
      f(n+1,m)=C(n+1,2*m)*f(n,m)
只要能计算出f(2n,n)的个数，那么可以推导也所有f

我是这么想的，不知道对不对

grf1973

好象应该是这样：
可令f(n,m)为n个元素的集合，g(2m,m)为2m个元素中需考察mPm的个数
      f(n+1,m)=C(n+1,2*m)*g(2m,m)

grf1973

可令f(n,m)为n个元素的集合，需考察mPm的情形
g(2m,m)为2m个元素中需考察mPm的个数
f(n,m)=C(n,2*m)*g(2m,m)

grf1973

g(4,2)=1,g(6,3)=5,g(8,4)=?,g(10,5)=?,g(12,6)=?
g应该可以通过组合等方式得到
有了g，可以推出所有的f。

香川群子

grf1973 发表于 2018-1-2 14:01
36828  21605   两个结果都提交了，结果错误。。。。。。

我知道了，还有 122211、122221111……等各种情形也许考虑进去。

这样的话，需要用正则来判断了。

香川群子

重新计算后的结果时=21384，少了一些。

4  3  1
5  15  5
6  55  20
7  175  70
8  525  231
9  1533  735
10  4431  2289
11  12771  7029
12  36828  21384
0.254s

改进做法，专门写了一个检查状态的自定义函数：

检查原理是：
如果先出现的1、后面跟上2，那么成为1组【1<2对子】结果肯定是1<2
继续检查下一个出现的1、以及这个1之后出现的2，组成新的1组【1<2对子】，则仍能保证1<2
……
这样全部检查配对完成，直到已经找不到新的1时，说明之前的1和2都能组成【1<2对子】，所以结果是1<2不可能有机会相等。

反之，如果在某个1出现之后，找不到比这个1更大一些的2了，说明无法配对组合【1<2对子】，则结果就是1221类型，有可能会造成 2-1=1-2的相等局面。

1. Function f(s) As Boolean '检查12对子的排列情况
   
2.     Do
   
3.         j1 = InStr(j1 + 1, s, "1")
   
4.         If j1 = 0 Then Exit Function '没有新的【1<2对子】了
   
5.         
   
6.         If j2 < j1 Then j2 = j1 '只检查比1更大一些的2成为1组【1<2对子】
   
7.         j2 = InStr(j2 + 1, s, "2")
   
8.     Loop Until j2 = 0 '找不到比上个1更大的2时 就产生1221类型的相等可能性
   
9.     f = True
   
10. End Function

复制代码

香川群子

完整的代码：

不需要用字典，但是我是用字典统计、观察之后，才算彻底明白怎么回事的。
之前只检查1221或2112的状态，是不准确的。
例如 112212 就能组成3个【1<2对子】最后组合结果肯定是1<2的。所以之前的计算结果偏大了。

1. Dim ar(), dic, k&, k1&, m&, n&, tms#
   
2. Sub test() 'by kagawa 2018/1/1
   
3.     tms = Timer
   
4.    
   
5.     For m = 4 To 12
   
6.         ReDim ar(1 To m)
   
7.     '    Set dic = CreateObject("Scripting.Dictionary")
   
8.         k = 0: k1 = 0
   
9.         For n = 2 To Int(m / 2)
   
10.             Call dgZH(0, 1) '调用组合递归 列出S(B)个数等于S(C)的组合 检查是否可能相等(含1221或2112顺序)
    
11.         Next
    
12.     '    [a1].Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
    
13.         Debug.Print m; k; k1
    
14.     Next
    
15.     Debug.Print Format(Timer - tms, "0.000s")
    
16.     MsgBox Format(Timer - tms, "0.000s") & vbCr & m & vbCr & k & vbCr & k1
    
17. End Sub
    
18. Sub dgZH(i1&, t&) '生成个数较少的S(C)组合
    
19.     Dim i&, i2&
    
20.     For i = i1 + 1 To m - n + t
    
21.         ar(i) = 1 '在ar数组记录该元素已被S(C)使用
    
22.         If t < n Then
    
23.             Call dgZH(i, t + 1)
    
24.         Else
    
25.             For i2 = 1 To m
    
26.                 If ar(i2) = 1 Then Exit For '仅需检查C组开始以后的元素组合
    
27.             Next
    
28.             Call dgZH2(i2, 1) '调用生成S(B)组合的递归
    
29.         End If
    
30.         ar(i) = ""
    
31.     Next
    
32. End Sub
    
33. Sub dgZH2(i2&, t&) '生成个数较多的S(B)组合
    
34.     Dim i&, s$, ss$
    
35.     For i = i2 + 1 To m - n + t
    
36.         If ar(i) = "" Then '检查是否未被S(C)使用
    
37.             ar(i) = 2 '在ar数组记录该组合
    
38.             If t < n Then
    
39.                 Call dgZH2(i, t + 1)
    
40.             Else
    
41.                 k = k + 1 '36828
    
42.                 s = Join(ar, "")
    
43.                 If f(s) Then k1 = k1 + 1
    
44. '                dic(s) = ""
    
45. '                If InStr(s, "1221") + InStr(s, "2112") Then k1 = k1 + 1 '21605
    
46.             End If
    
47.             ar(i) = ""
    
48.         End If
    
49.     Next
    
50. End Sub
    
51. Function f(s) As Boolean '检查12对子的排列情况
    
52.     Do
    
53.         j1 = InStr(j1 + 1, s, "1")
    
54.         If j1 = 0 Then Exit Function '没有新的12对子了
    
55.         
    
56.         If j2 < j1 Then j2 = j1 '只检查比1更大一些的2成为1组12对子
    
57.         j2 = InStr(j2 + 1, s, "2")
    
58.     Loop Until j2 = 0 '找不到比上个1更大的2时 就产生1221类型的相等可能性
    
59.     f = True
    
60. End Function
    

复制代码

grf1973

折腾了一下午，终于搞定，结果正确。

1. Sub tt()
   
2.     Dim g(12, 6)
   
3.     g(4, 2) = 1: g(6, 3) = 5: g(8, 4) = 21: g(10, 5) = 84: g(12, 6) = 330
   
4.     n = 12
   
5.     For m = 2 To n / 2
   
6.         res = res + Application.combin(n, 2 * m) * g(2 * m, m)
   
7.     Next
   
8.     Debug.Print res
   
9. End Sub

复制代码

grf1973

嗯，香川的结果对了，是21384