用VBA解欧拉计划题目（92）--平方数字链

grf1973

平方数字链

将一个数的所有数字的平方相加得到一个新的数，不断重复直到新的数已经出现过为止，这构成了一条数字链。

例如，

44 → 32 → 13 → 10 → 1 → 1
85 → 89 → 145 → 42 → 20 → 4 → 16 → 37 → 58 → 89

可见，任何一个到达1或89的数字链都会陷入无尽的循环。更令人惊奇的是，从任意数开始，最终都会到达1或89。

有多少个小于一千万的数最终会到达89？

大灰狼1976

没有找到取巧的方法，目前考虑以下几步：
n=10^7
1、最大的平方和为9999999各位平方相加，等于567，那么从568开始到n为止的数先汇总至1~567的二维数组内，第1列存放累计个数，第2列后面标记用；
2、567以下最大平方和为499各位平方相加，等于178，故将179~567的各个数字平方和汇总至数组的1~178内，累计个数相加；
3、然后对1~178进行逐个判断，结果为1或89的在数组第2维做标记，过程中出现的也做标记，1~178应该很快
4、对1~178进行条件求和
现在还在写，但是仅步骤1就需要5秒多，不知道有没有什么高效的方法。

大灰狼1976

现在总时间4秒以内，结果为8581146
代码贴不上来。

grf1973

结果正确。
比我自编的高效。我自己的代码运行了18秒。

1. 'P92:平方数字链'
   
2. '将一个数的所有数字的平方相加得到一个新的数，不断重复直到新的数已经出现过为止，这构成了一条数字链。'
   
3. '例如，'
   
4. '44 → 32 → 13 → 10 → 1 → 1
   
5. '85 → 89 → 145 → 42 → 20 → 4 → 16 → 37 → 58 → 89'
   
6. '可见，任何一个到达1或89的数字链都会陷入无尽的循环。更令人惊奇的是，从任意数开始，最终都会到达1或89。'
   
7. '有多少个小于一千万的数最终会到达89？
   
8. 
   
9. Sub problem92()        '到达89共有：8581146         到达1共有：1418853          共运行18.48438秒
   
10.     tm = Timer
    
11.     Dim i&, x&, flag As Boolean
    
12.     Nmax = 10 ^ 7
    
13.     ReDim arr(1 To 81 * 7 + 1) As Byte '放置能到89的，平方数和最大到9*9*7即可
    
14.     ReDim brr(1 To 81 * 7 + 1) As Byte '放置最终到1的
    
15.     arr(89) = 1: brr(1) = 1
    
16.    
    
17.     Set tmpd = CreateObject("scripting.dictionary")   '每次的临时路径
    
18.     For i = 1 To Nmax - 1
    
19.         x = 平方相加(i)   '第一个平方数和
    
20.         If brr(x) = 1 Then  '如果最终到1，直接下一个
    
21.             t = t + 1
    
22.         ElseIf arr(x) = 1 Then   '如果最终能到89的，累计，去下一个
    
23.             s = s + 1
    
24.         Else   '开始构成数字链
    
25.             tmpd.RemoveAll
    
26.             tmpd(x) = ""
    
27.             'Flag = False
    
28.             Do While x <> 1 And x <> 89
    
29.                x = 平方相加(x)
    
30.                tmpd(x) = ""
    
31.                If arr(x) = 1 Then x = 89 '在构链过程中，如果发现某个位置肯定可以到81，那么跳出
    
32.                If brr(x) = 1 Then x = 1
    
33.             Loop
    
34.             If x = 89 Then    '如果构成一条直到89的链，把所有链节数字放入数组arr
    
35.                 s = s + 1
    
36.                 For Each k In tmpd.keys
    
37.                     arr(k) = 1
    
38.                 Next
    
39.             ElseIf x = 1 Then   '如果构成一条直到1的链，把所有链节数字放入数组brr
    
40.                 t = t + 1
    
41.                 For Each k In tmpd.keys
    
42.                     brr(k) = 1
    
43.                 Next
    
44.             End If
    
45.         End If
    
46.     Next
    
47.     Debug.Print "到达89共有：" & s, "到达1共有：" & t, "共运行" & Timer - tm & "秒"
    
48. End Sub
    
49. 
    
50. Function 平方相加(i&) As Integer
    
51.     p = i
    
52.     Do While p > 0
    
53.         s = s + (p Mod 10) ^ 2
    
54.         p = p \ 10
    
55.     Loop
    
56.     平方相加 = s
    
57. End Function

复制代码

grf1973

第29行的 函数 平方相加 可以用事先计算好的数组代替，但速度并没提高多少

grf1973

发现自己还编了一个快捷版的。。。。。。

1. Sub problem92a()        '到达89共有：8581146         到达1共有：1418853          共运行8.79秒
   
2.     tm = Timer
   
3.     Dim i&, x&, s&, p&
   
4.     Nmax = 10 ^ 7
   
5.     ReDim arr(1 To 81 * 7 + 1) As Byte '放置能到89的，平方数和最大到9*9*7即可
   
6.     For i = 1 To 81 * 7   '标记1--81*7的最终结果
   
7.         p = i: s = 0
   
8.         Do While True
   
9.             Do While p > 0
   
10.                 s = s + (p Mod 10) ^ 2
    
11.                 p = p \ 10
    
12.             Loop
    
13.             If s = 1 Or s = 89 Then Exit Do
    
14.             p = s: s = 0
    
15.         Loop
    
16.         If s = 89 Then arr(i) = 1
    
17.     Next
    
18.     Debug.Print Timer - tm
    
19.     For i = 1 To Nmax - 1   '1--10^7只计算一次平方和，限制范围在81*7之内
    
20.         p = i: s = 0
    
21.         Do While p > 0
    
22.             s = s + (p Mod 10) ^ 2
    
23.             p = p \ 10
    
24.         Loop
    
25.         If arr(s) = 1 Then res = res + 1
    
26.     Next
    
27.     Debug.Print "到达89共有：" & res, "到达1共有：" & Nmax - 1 - res, "共运行" & Timer - tm & "秒"
    
28. End Sub

复制代码

grf1973

用递推优化平方和的计算，速度还可以提高一倍，终于4秒左右出结果。

1. Sub problem92b()        '到达89共有：8581146         到达1共有：1418853          共运行4.6秒
   
2.     tm = Timer
   
3.     Dim i&, x&, s&, p&
   
4.     Nmax = 10 ^ 7
   
5.     ReDim arr(1 To 81 * 7 + 1) As Byte '放置能到89的，平方数和最大到9*9*7即可
   
6.     For i = 1 To 81 * 7   '标记1--81*7的最终结果
   
7.         p = i: s = 0
   
8.         Do While True
   
9.             Do While p > 0
   
10.                 s = s + (p Mod 10) ^ 2
    
11.                 p = p \ 10
    
12.             Loop
    
13.             If s = 1 Or s = 89 Then Exit Do
    
14.             p = s: s = 0
    
15.         Loop
    
16.         If s = 89 Then arr(i) = 1
    
17.     Next
    
18.     Debug.Print Timer - tm   '第一步用时0秒
    
19.    
    
20.     ReDim pfh%(Nmax)   '记录每个数的平方和
    
21.     For i = 0 To 9
    
22.         pfh(i) = i * i
    
23.     Next
    
24.     For i = 1 To Nmax - 1   '1--10^7只计算一次平方和，限制范围在81*7之内
    
25.         pfh(i) = pfh(i \ 10) + (i Mod 10) * (i Mod 10)   'n位数各位的平方和=前n-1位各位的平方和+最后一位的平方和
    
26.         p = pfh(i): s = 0
    
27.         Do While p > 0
    
28.             s = s + (p Mod 10) ^ 2
    
29.             p = p \ 10
    
30.         Loop
    
31.         If arr(s) = 1 Then res = res + 1
    
32.     Next
    
33.     Debug.Print "到达89共有：" & res, "到达1共有：" & Nmax - 1 - res, "共运行" & Timer - tm & "秒"
    
34. End Sub

复制代码

grf1973

26行到30行属于多余，可以去掉。0.5秒就出结果了。

1. Sub problem92b()        '到达89共有：8581146         到达1共有：1418853          共运行0.5秒
   
2.     tm = Timer
   
3.     Dim i&, x&, s&, p&
   
4.     Nmax = 10 ^ 7
   
5.     ReDim arr(1 To 81 * 7 + 1) As Byte '放置能到89的，平方数和最大到9*9*7即可
   
6.     For i = 1 To 81 * 7   '标记1--81*7的最终结果
   
7.         p = i: s = 0
   
8.         Do While True
   
9.             Do While p > 0
   
10.                 s = s + (p Mod 10) ^ 2
    
11.                 p = p \ 10
    
12.             Loop
    
13.             If s = 1 Or s = 89 Then Exit Do
    
14.             p = s: s = 0
    
15.         Loop
    
16.         If s = 89 Then arr(i) = 1
    
17.     Next
    
18.     Debug.Print Timer - tm   '第一步用时0秒
    
19.    
    
20.     ReDim pfh%(Nmax)   '记录每个数的平方和
    
21.     For i = 0 To 9
    
22.         pfh(i) = i * i
    
23.     Next
    
24.     For i = 1 To Nmax - 1   '1--10^7只计算一次平方和，限制范围在81*7之内
    
25.         pfh(i) = pfh(i \ 10) + (i Mod 10) * (i Mod 10)   'n位数各位的平方和=前n-1位各位的平方和+最后一位的平方和
    
26.         If arr(pfh(i)) = 1 Then res = res + 1
    
27.     Next
    
28.     Debug.Print "到达89共有：" & res, "到达1共有：" & Nmax - 1 - res, "共运行" & Timer - tm & "秒"
    
29. End Sub
    

复制代码

grf1973

21--23行也属于多余。
这下完美了，改无可改。

1. Sub problem92b()        '到达89共有：8581146         到达1共有：1418853          共运行0.5秒
   
2.     tm = Timer
   
3.     Dim i&, x&, s&, p&
   
4.     Nmax = 10 ^ 7
   
5.     ReDim arr(1 To 81 * 7 + 1) As Byte '放置能到89的，平方数和最大到9*9*7即可
   
6.     For i = 1 To 81 * 7   '标记1--81*7的最终结果
   
7.         p = i: s = 0
   
8.         Do While True
   
9.             Do While p > 0
   
10.                 s = s + (p Mod 10) ^ 2
    
11.                 p = p \ 10
    
12.             Loop
    
13.             If s = 1 Or s = 89 Then Exit Do
    
14.             p = s: s = 0
    
15.         Loop
    
16.         If s = 89 Then arr(i) = 1
    
17.     Next
    
18.    
    
19.     ReDim pfh%(Nmax)   '记录每个数的平方和
    
20.     For i = 1 To Nmax - 1   '1--10^7只计算一次平方和，限制范围在81*7之内
    
21.         pfh(i) = pfh(i \ 10) + (i Mod 10) * (i Mod 10)   'n位数各位的平方和=前n-1位各位的平方和+最后一位的平方和
    
22.         If arr(pfh(i)) = 1 Then res = res + 1
    
23.     Next
    
24.     Debug.Print "到达89共有：" & res, "到达1共有：" & Nmax - 1 - res, "共运行" & Timer - tm & "秒"
    
25. End Sub

复制代码

苏子龙

好厉害，只有膜拜了