用VBA解欧拉计划题目（74）--数字阶乘链

grf1973

第74题：数字阶乘链

145之所以广为人知，是因为它的各位数字的阶乘之和恰好等于本身：

1! + 4! + 5! = 1 + 24 + 120 = 145

而169则可能不太为人所知，尽管从169开始不断地取各位数字的阶乘之和构成了最长的循环回到169；事实上，只存在三个这样的循环：

169 → 363601 → 1454 → 169
871 → 45361 → 871
872 → 45362 → 872

不难证明，从任意数字出发最终都会陷入循环。例如，

69 → 363600 → 1454 → 169 → 363601 (→ 1454)
78 → 45360 → 871 → 45361 (→ 871)
540 → 145 (→ 145)

从69开始可以得到一个拥有五个不重复项的链，但是从一个小于一百万的数出发能够得到的最长的无重复项链包含有60项。

从小于一百万的数出发，有多少条链恰好包含有60个不重复项？

香川群子

这就是暴力遍历，跑个程序而已：

1. Dim b&(9)
   
2. Sub test()
   
3.     Dim a&(), i&, j&, k&, s$, t, tms#
   
4.     tms = Timer
   
5.    
   
6.     b(0) = 1: b(1) = 1
   
7.     For i = 2 To 9
   
8.         b(i) = i * b(i - 1)
   
9.     Next
   
10.    
    
11.     For i = 1 To 10 ^ 6
    
12. '    For i = 69 To 69
    
13.         t = i
    
14.         s = "-" & t & "-"
    
15.         j = 0
    
16.         Do
    
17.             j = j + 1
    
18.             t = GetFactSum(t)
    
19.             If InStr(s, "-" & t & "-") Then Exit Do
    
20.             s = s & t & "-"
    
21.         Loop
    
22.         If j = 60 Then k = k + 1
    
23.     Next
    
24.     Debug.Print Format(Timer - tms, "0.000s"); k
    
25. End Sub
    
26. Function GetFactSum(t)
    
27.     Dim i&, r&, s$
    
28.     s = CStr(t)
    
29.     For i = 1 To Len(s)
    
30.         r = r + b(Mid(s, i, 1))
    
31.     Next
    
32.     GetFactSum = r
    
33. End Function

复制代码

运行结果：
89.281s 402

大灰狼1976

我对数据做了标记，但是因为用了字典，效率还是不高。

1. Sub aaa()
   
2. Dim i&, j&, s$, n, k&, d As Object, d1 As Object, cnt&, m, arr, s1$, l&, brr, r&
   
3. arr = Array(1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880)
   
4. t = Timer
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. For i = 0 To 1000000
   
8.   d(i) = ""
   
9.   m = i
   
10.   Do
    
11.     If d1.exists(m) Then
    
12.       l = d1(m) - 1
    
13.       If d.Count > 1 Then
    
14.         brr = d.keys
    
15.         r = UBound(brr)
    
16.         For j = 0 To r - 1
    
17.           d1(brr(j)) = r + l - j + 1
    
18.         Next j
    
19.       End If
    
20.       Exit Do
    
21.     End If
    
22.     s = m
    
23.     m = 0
    
24.     For j = 1 To Len(s)
    
25.       m = m + arr(Mid(s, j, 1))
    
26.     Next j
    
27.     If Not d.exists(m) Then
    
28.       d(m) = ""
    
29.     Else
    
30.       If d.Count > 1 Then
    
31.         brr = d.keys
    
32.         r = UBound(brr)
    
33.         For j = 0 To r
    
34.           d1(brr(j)) = r - j + 1
    
35.         Next j
    
36.       Else
    
37.         d1(i) = 1
    
38.       End If
    
39.       Exit Do
    
40.     End If
    
41.   Loop
    
42.   If d1(i) = 60 Then cnt = cnt + 1
    
43.   d.RemoveAll
    
44. Next i
    
45. MsgBox cnt & Chr(10) & Timer - t
    
46. End Sub

复制代码

香川群子

大灰狼1976 发表于 2017-12-1 17:06
我对数据做了标记，但是因为用了字典，效率还是不高。

检查数范围较小时，用字典还是很快的。
但是数量增大以后，字典就反而拖累了。


下面改用数组+字典记录以后，速度大大提高，仅需5-10秒。

香川群子

用数组+字典记录已经计算过的结果，这样确实快多了。

1. Sub test() 'by kagawa 2017/12/1
   
2.     Dim a&(), b&(9), c&(60), dic, i&, j&, j1&, j2&, j3&, k&, l&, l2&, m&, n&, r$, s$, t, tms#
   
3.     tms = Timer
   
4.    
   
5.     n = 10 ^ 6 '检查取数范围 最大值n
   
6.     j1 = 60    '需统计的不重复链长标准j1
   
7.     ReDim a&(n) '存放过程中检查结果的数组a() 代替字典但比字典快多了
   
8.    
   
9.     b(0) = 1: b(1) = 1
   
10.     For i = 2 To 9
    
11.         b(i) = i * b(i - 1) '存放0-9的阶乘数结果 直接检索加快速度
    
12.     Next
    
13.    
    
14.     Set dic = CreateObject("Scripting.Dictionary") '存放>n的结果
    
15.     '因为<=n的都直接用数组a记录了，所以需要使用字典的部分(溢出数)非常少
    
16.    
    
17.     For i = 0 To n '遍历检查范围
    
18.         If a(i) = 0 Then '如果该数值未被计算过
    
19.             t = i '该数赋值于循环计算变量t
    
20.             r = "-" & t & "-" '用于检查并记录不重复链的字符串结果r
    
21.             c(0) = t '数组c中记录不重复链过程(代替字典2)
    
22.             
    
23.             j = 0 '不重复链计数 j 归零
    
24.             Do
    
25.                 j = j + 1
    
26.                
    
27.                 s = CStr(t)
    
28.                 t = 0 '阶乘计算值t归零
    
29.                 For l = 1 To Len(s)
    
30.                     t = t + b(Mid(s, l, 1)) '遍历累计阶乘值
    
31.                 Next
    
32.                 c(j) = t '记录新的阶乘计算结果t(循环变量)
    
33.                
    
34.                 If t < n Then m = a(t) Else m = dic(t) '根据数值大小分别使用数组记录或字典记录
    
35.                 If m Then '如已有记录(即之前的计算已经产生该数值结果、只需引用结果即可)
    
36.                     For l = 0 To j - 1 '遍历本次不重复链 记录链长结果
    
37.                         If c(l) < n Then a(c(l)) = m + j - l Else dic(c(l)) = m + j - l
    
38.                     Next
    
39.                     Exit Do '阶乘数已有记录可提前退出
    
40.                 End If
    
41.                
    
42.                 If InStr(r, "-" & t & "-") Then '如果当前阶乘数t已经在本链中有重复
    
43.                     For l = 0 To j
    
44.                         If c(l) = t Then Exit For '检查到该重复值t时结束
    
45.                         If c(l) < n Then a(c(l)) = j - l Else dic(c(l)) = j - l
    
46.                     Next
    
47.                     For l2 = l + 1 To j '剩余部分是短循环
    
48.                         If c(l) < n Then a(c(l)) = j - l Else dic(c(l)) = j - l
    
49.                     Next
    
50.                     Exit Do '链已经重复本次检查结束
    
51.                 End If
    
52.                
    
53.                 r = r & t & "-" '链未重复 Do循环继续
    
54.             Loop
    
55.             If j > j2 Then j2 = j '统计Do循环检查最大循环次数j2
    
56.         End If
    
57.         
    
58.         If a(i) = j1 Then k = k + 1: Debug.Print k; i  '统计满足不重复链长=j1的个数
    
59.         If a(i) > j3 Then j3 = a(i): Debug.Print i; a(i) '统计最大不重复链长j3
    
60.     Next
    
61.     Debug.Print Format(Timer - tms, "0.000s"); k; j1; j2; j3; dic.Count
    
62.     '输出程序耗时、指定不重复链长的个数k、指定链长j1、最大循环次数j2、最大不重复链长j3、字典项数
    
63. End Sub

复制代码

grf1973

香川群子 发表于 2017-12-1 22:58
用数组+字典记录已经计算过的结果，这样确实快多了。

嗯，确实够快。比我的快了20倍。

1. Sub problem74()   '结果是402，运行240秒
   
2.     tm = Timer
   
3.     Nmax = 1000000
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For kk = 3 To Nmax
   
6.         k = kk
   
7.         d.RemoveAll: bs = 0
   
8.         Do While Not d.exists(k)
   
9.             bs = bs + 1: If bs > 60 Then Exit Do
   
10.             d(k) = "": s = 0
    
11.             For m = 1 To Len(k)
    
12.                  s = s + 阶乘(Val(Mid(k, m, 1)))
    
13.             Next
    
14.             k = s
    
15.         Loop
    
16.         If bs = 60 Then res = res + 1: Debug.Print res, kk
    
17.     Next
    
18.     Debug.Print "共运行" & Timer - tm & "秒"
    
19. End Sub

复制代码

这是我没做任何优化的代码，也能整出来。
其中“阶乘”是自编的函数。

大灰狼1976

考虑了好多投机取巧的方法，最终未能实现，只能在现有思路的基础上进行改善，运用了grf1973前辈在其它题中的好方法，将每个数的阶乘结果先存入数组，再循环判断并做标记，目前可以在0.8秒左右跑完，我试试能否发代码。

大灰狼1976

分段发：

1. Sub aaa()
   
2. Dim n&, i&, k&, m&, p&, cnt&, n1&
   
3. t = Timer
   
4. n = 10 ^ 6: n1 = 2177280
   
5. ReDim arr&(0 To n1)
   
6. ReDim brr&(0 To n1)
   
7. arr(0) = 1
   
8. For i = 1 To 9
   
9.   arr(i) = arr(i - 1) * i
   
10. Next i
    
11. For i = 10 To n1
    
12.   arr(i) = arr(i \ 10) + arr(i Mod 10)
    
13. Next i
    
14. For i = 1 To n
    
15.   ReDim crr&(1 To 60)
    
16.   m = i: k = 0

复制代码

大灰狼1976

1.   Do
   
2.     If brr(m) = 0 Then
   
3.       brr(m) = -1
   
4.       k = k + 1
   
5.       crr(k) = m
   
6.       m = arr(m)
   
7.     Else
   
8.       If brr(m) > 0 Then p = brr(m) Else p = 0
   
9.       For j = k To 1 Step -1
   
10.         brr(crr(j)) = k - j + 1 + p
    
11.       Next j

复制代码

大灰狼1976

1.       If brr(crr(1)) = 60 Then cnt = cnt + 1
   
2.       Exit Do
   
3.     End If
   
4.   Loop
   
5. Next i
   
6. 输出cnt
   
7. End Sub

复制代码