五道难题求解

mathe

wayne 发表于 2025-2-22 08:37
16核全开,直接上暴力美学.
第一题: $1929374254627488900 = 1389019170^2$

第一题可以挺快的，首先平方是10的倍数，这个数必然是10的倍数，末尾可以不搜索。
其次它除以10以后，平方末三位是8x9,得到这个数末三位只有24种选择。
然后它的范围在\(10^8\)到\(\sqrt{2}10^8\)之间，我们需要穷举前5位加上最后3位24种选择共41422*24种情况。

wayne

末位数能被8整除, 所以有三种情况,$809, 849,889$. 然后就是 7位数的穷举. 我是这种思路.
如果计算模1000的情况,确实是24种情况,这样又少了3个数, 于是只需要 穷举 4位数. 重新 实现了一下mathe的思路, 很快.

1. tmp = Select[Range[10^3 - 1], IntegerDigits[#^2, 10, 3][[-1]] == 9 &&  IntegerDigits[#^2, 10, 3][[-3]] == 8 &];
   
2. sol = Flatten[
   
3.    Table[FromDigits[
   
4.      Flatten[{1, IntegerDigits[i, 10, 5],
   
5.        IntegerDigits[j, 10, 3]}]], {i, 1010, 38902}, {j, tmp}], 1];
   
6. Select[sol, AllTrue[Differences[IntegerDigits[#^2][[1 ;; -1 ;; 2]]], # == 1 &] &]

复制代码

wayne

基于mathe的思路,改成计算平方的末尾是五位数的情况,即模10^5, 有240个解.这样,前面的只需要计算10-389的情况. 总共只需要枚举$389*240$种情况, 于是1秒钟出结果.,

1. tmp=Select[Range[10^5-1],IntegerDigits[#^2,10,5][[{1, 3, 5}]]=={7,8,9}&];
   
2. sol=Flatten[Table[FromDigits[Flatten[{1,IntegerDigits[i,10,3],IntegerDigits[j,10,5]}]],{i,10,389},{j,tmp}],1];
   
3. ans=Select[sol,AllTrue[Differences[IntegerDigits[#^2][[1;;-1;;2]]],#==1&]&]

复制代码

northwolves

第4题的实现代码：

1. ClearAll["Global`*"];
   
2. x=Permutations[Range@9];y=Select[IntegerPartitions@9,Length@#>1&&Count[#,1]<5&];
   
3. n=0;s={};
   
4. Do[c=Product[m!,{m,Tally[b][[All,2]]}];k=0;
   
5. Do[r=TakeList[a,b];
   
6. k+=Times@@Boole[Union[PrimeQ/@FromDigits/@r]],{a,x}];
   
7. k/=c;n+=k;AppendTo[s,{k,b}],{b,y}];{n,s}

复制代码

{44680,{{11483,{8,1}},{8844,{7,2}},{2052,{7,1,1}},{6572,{6,3}},{2482,{6,2,1}},{205,{6,1,1,1}},{6424,{5,4}},{2049,{5,3,1}},{535,{5,2,2}},{646,{5,2,1,1}},{13,{5,1,1,1,1}},{942,{4,4,1}},{945,{4,3,2}},{449,{4,3,1,1}},{410,{4,2,2,1}},{54,{4,2,1,1,1}},{136,{3,3,3}},{292,{3,3,2,1}},{20,{3,3,1,1,1}},{32,{3,2,2,2}},{82,{3,2,2,1,1}},{2,{3,2,1,1,1,1}},{8,{2,2,2,2,1}},{3,{2,2,2,1,1,1}}}}

主要问题是重复计数的太多，该如何优化提速？

northwolves

仿3楼代码多核同时计算：

1. SetSharedVariable[n,lst];n=0;lst={};
   
2. x=Permutations[Range@9];y=Select[IntegerPartitions@9,Length@#>1&&Count[#,1]<5&];
   
3. ParallelDo[c=Product[m!,{m,Tally[b][[All,2]]}];k=0;
   
4. Do[r=TakeList[a,b];
   
5. k+=Times@@Boole[Union[PrimeQ/@FromDigits/@r]],{a,x}];
   
6. k/=c;n+=k;AppendTo[s,{k,b}],{b,y}];{n,s}

复制代码

wayne

素数都是形如$6n\pm1$,所以我们按照6为模分成6组.

wayne

northwolves 发表于 2025-2-22 16:30
第4题：44680

组合                     数量

可读性可能不那么好,代码需要 1.1秒钟. 局部地方有重复逻辑,是可以进一步优化速度的,比较懒,暂时先这样吧.

1. pool = Table[{i,Select[FromDigits /@ Permutations[Range[9], {i}], PrimeQ]}, {i, 1,8}];
   
2. ans = GroupBy[
   
3.    Flatten[Table[
   
4.      Union[Sort /@
   
5.        Lookup[NestWhile[
   
6.           GroupBy[Join[Lookup[#, True, {}],
   
7.              Flatten[Table[
   
8.                Flatten[Table[{Flatten[{p[[1]], t}],
   
9.                   Complement[p[[2]],
   
10.                    Flatten[IntegerDigits /@ {p[[1]], t}]]}, {len,
    
11.                   Flatten[{Range[IntegerLength[p[[1, -1]]],
    
12.                     Length[p[[2]]]/2], Length[p[[2]]]}]}, {t,
    
13.                   Select[FromDigits /@
    
14.                     Permutations[
    
15.                     Complement[p[[2]],
    
16.                     Flatten[IntegerDigits /@ {p[[1]], t}]], {len}],
    
17.                    PrimeQ]}], 1], {p, Lookup[#, False, {}]}],
    
18.               1]], #[[2]] == {} &] &,
    
19.           GroupBy[Table[{{i}, Complement[Range[9], IntegerDigits[i]]}, {i, pool[[m, 2]]}], #[[2]] == {} &],
    
20.           Lookup[#, False, {}] != {} &], True, {}][[All, 1]]], {m, 1,  4}], 1], Map[IntegerLength, #] &];
    
21. Length /@ ans

复制代码

1. {{{1,8},11483},{{1,1,7},2052},{{1,2,6},2482},{{1,3,5},2049},{{1,4,4},942},{{1,1,1,6},205},{{1,1,2,5},646},{{1,1,3,4},449},{{1,2,2,4},410},{{1,2,3,3},292},{{1,1,1,1,5},13},{{1,1,1,2,4},54},{{1,1,1,3,3},20},{{1,1,2,2,3},82},{{1,2,2,2,2},8},{{1,1,1,1,2,3},2},{{1,1,1,2,2,2},3},{{2,7},8844},{{2,2,5},535},{{2,3,4},945},{{2,2,2,3},32},{{3,6},6572},{{3,3,3},136},{{4,5},6424}}

复制代码