一道初级数学题

jimogsh

用1到9这九个数组成等式( )/( )( )+( )/( )( )+( )/( )( )=1
用1至9这9个数字怎么组合相加后等于1,不可以重复使用数字

引自http://zhidao.baidu.com/question/130993689.html?fr=uc_push

ggggwhw

发现用Table会出现内存不够的提示,后来修改后内存够了,但是还有一步判断很难进行:

1. brr = Select[Subsets[Range[1, 9], 3], Length[#] > 2 &];
   
2. lenb = Length[brr];
   
3. brr = Sort[Flatten[Table[Permutations[brr[[i]]], {i, 1, lenb}], 1]];
   
4. lenb = Length[brr];
   
5. brr = Table[{brr[[i, 1]], brr[[i, 2]], brr[[i, 3]],
   
6. brr[[i, 1]]/(10 brr[[i, 2]] + brr[[i, 3]])}, {i, 1, lenb}];
   
7. brr = Sort[brr, #1[[4]] < #2[[4]] &];
   
8. crr = Table[brr[[i, 4]], {i, 1, lenb}];
   
9. lenc = Length[Select[crr, # <= 1/3 &]];
   
10. lend = lenb + 1 - Length[Select[crr, # >= 1/3 &]];
    
11. drr = Delete[
    
12. Union[Flatten[
    
13. Table[If[
    
14. crr[[i]] + crr[[j]] + crr[[k]] == 1, {crr[[i]], crr[[j]],
    
15. crr[[k]]}, 0], {i, 1, lenb}, {j, lend, lenb}, {k, i + 1,
    
16. j - 1}], 2]], 1]

复制代码

后来改用For循环,发现内存不是问题,速度明显跟不上:

1. brr = Select[Subsets[Range[1, 9], 3], Length[#] > 2 &];
   
2. brr = Sort[
   
3. Flatten[Table[Permutations[brr[[i]]], {i, 1, Length[brr]}], 1]];
   
4. lenb = Length[brr];
   
5. brr = Table[{brr[[i, 1]], brr[[i, 2]], brr[[i, 3]],
   
6. brr[[i, 1]]/(10 brr[[i, 2]] + brr[[i, 3]])}, {i, 1, lenb}];
   
7. brr = Sort[brr, #1[[4]] < #2[[4]] &];
   
8. lenc = Length[Select[brr, #[[4]] <= 1/3 &]];
   
9. lend = lenb + 1 - Length[Select[brr, #[[4]] >= 1/3 &]];
   
10. rang = Range[9];
    
11. For[i[1] = 1, i[1] <= lenc, i[1]++,
    
12. For[i[2] = i[1] + 1, i[2] <= lenb, i[2]++,
    
13. For[i[3] = i[1] + 1, i[3] < i[2], i[3]++,
    
14. If[brr[[i[1], 4]] + brr[[i[2], 4]] + brr[[i[3], 4]] == 1,
    
15. If[Union[
    
16. Flatten[Table[{brr[[i[j], k]]}, {j, 1, 3}, {k, 1, 3}]]] ==
    
17. rang, Print[Table[{brr[[i[j], k]]}, {j, 1, 3}, {k, 1, 3}]]]
    
18. ]
    
19. ]
    
20. ]
    
21. ]

复制代码

不过5分钟内总算算完了.具体时间不知道没有测定.
输出结果是:

1. {{{7},{6},{8}},{{9},{1},{2}},{{5},{3},{4}}}

复制代码

即满足条件的数字是:
7/68+9/12+5/34=1

ljwxhlzp

这样快。最后的剔除方法不彻底，不过还好只乘下一个答案了。

1. m2 = Flatten@
   
2.     Position[(#[[1]])/(10 #[[2]] + #[[3]]) + (#[[
   
3.            4]])/(10 #[[5]] + #[[6]]) + (#[[
   
4.            7]])/(10 #[[8]] + #[[9]]) & /@ (m1 =
   
5.         Permutations[Range[9]]), 1] // m1[[#]] &;
   
6. DeleteDuplicates[m2, #1[[1 ;; 3]] == #2[[4 ;; 6]] || #1[[
   
7.      1 ;; 3]] == #2[[7 ;; 9]] || #1[[4 ;; 6]] == #2[[7 ;; 9]] &]
   

复制代码

shamohu

用1stOpt试了下，0.0几秒：

Parameter x(9)=[1,9,0];
Exclusive = True;
StartProgram;
Procedure MainModel;
Begin
     ObjectiveResult := sqr(x1/(x2*10+x3)+x4/(x5*10+x6)+x7/(x8*10+x9)-1);
End;
EndProgram;

结果：
x1: 7
x2: 6
x3: 8
x4: 9
x5: 1
x6: 2
x7: 5
x8: 3
x9: 4

jimogsh

4# shamohu 不太懂这个，不过看长度是够短了，不知道执行速度怎么样？把运行时间也给列出来吧。

smarten

重写，

1. Select[Permutations[
   
2.       Range[9]], (#[[1]])/(10 #[[2]] + #[[3]]) + (#[[4]])/(10 #[[5]] \
   
3. + #[[6]]) + (#[[7]])/(10 #[[8]] + #[[9]]) == 1 &] //
   
4.     Map[Sort[Partition[#, 3]] &, #] & // Union // Flatten // Timing

复制代码

3# ljwxhlzp

ljwxhlzp

谢谢 smarten 在新年的第一天给我们展示了这么好的代码。很感叹 Mathematica 语言的灵活与优美。

顺祝各位网友新年快乐！

shamohu

在1stOpt版出了个类似题：http://forum.simwe.com/thread-913619-1-1.html
这里的高手看看有无好的方法。

lin2009

这是个老贴子，是在 MathCad板块 就是楼上于20078-8 17：00发的“[1stOpt] 用1stOpt进行填数字游戏”
http://forum.simwe.com/viewthrea ... 6amp%3Btypeid%3D353

赞赏1stopt的简洁明了和快速
程序：
//把1到9填入下列空格，使等式成立，空格里的数字不能重复
//     □　      □　　   □　　
//    ──  +     ───  +    ─── = 1
//    □□  　   □□ 　    □□ 　

Parameter x(0:8)=[1,9,0];
Exclusive = True;
Function Sum(i=0:2)(x[3*i]/(10*x[3*i+1]+x[3*i+2]))-1;

====== 结果 ======

迭代数: 5
计算用时(时:分:秒:毫秒): 00:00:00:422
计算中止原因: 达到收敛判定标准
优化算法: 最大继承法
目标函数值(最小): 0
x1: 5
x2: 3
x3: 4
x4: 7
x5: 6
x6: 8
x7: 9
x8: 1
x9: 2

====== 计算结束 ======

lin2009

得出4组解
     1     9     6     5     3     2     7     8     4
     3     5     4     9     8     1     6     7     2
     1     2     6     7     8     4     5     3     9
     1     4     8     5     3     2     7     9     6

TBE_Legend

想问一下楼上的，当和为1/4时，解有四个，你能用该软件把解都给出来吗
waynebuaa 发表于 2010-1-4 21:34

1stopt 的确很厉害。

wayne：我以前做过，用优化方法来做这类问题Mathematica似乎很差？ 你试过吗？

TBE_Legend

16# TBE_Legend
1stopt的确很不错。
但我觉得这样比较没意义~~，两个软件算法都不一样。
就相当于你用Mathematica来穷举，而其他人用C来编一个高效的随机算法一样，难道你就说Mathematica比C差吗？

我差不多 ...
waynebuaa 发表于 2010-1-9 19:31

我一年前就在用1stopt了，不是打靶，也不是什么随即，它内部的算法很神秘。不知道是DOE做得好，还是优化做得好，它手册中只提到了全局优化算法。

Isight我也用过，也似乎没有1stopt效果了，当然只是限于我的问题是这样的。我一直好奇，1stopt内部的算法。

没有比，不要老是说比啊比的，谁还不懂这个道理？我没有比，我用Mathematica做优化多些。就是想看看Mathematica的NMinimize为什么做不出来，是我一些选项选得不好？ 还是别的什么？

请不要断章取义，我只是说对于这类问题Mathematica的优化不理想，而且我用了似乎两字。我没有说Mathematica比1stopt差什么乱七八糟的。我又不是卖软件的！

lin2009

17# waynebuaa
是用1stopt做的，但每次只能得出一组解，运行多次或循环运行，得出的结果可能相同也可能不同，再从中剔除重复的解答（这一步我用的是其它软件来辅助完成）。

thanatus

好厉害的代码啊，真是开眼界拉～：）

lin2009

这个问题在H21版讨论得比较热烈
http://forum.simwe.com/thread-913619-1-1.html
有Forcal，1stopt和matlab三种不同的代码，各有千秋。
1stopt语法简单，编程量少，可以较迅速地得出答案，但不容易得出所有的解。
其它2种主要是用穷举法来算，可以得出全部的解。编程量大，但可以得出全部解。
循环次数多，运算时间长，但Forcal的表现相当不错，只用了28分钟。

chyanog

贴上我的一个效率不算高的方法：

1. 
   
2. L = Range[9];
   
3. For[i1 = 1, i1 <= 9, i1++, a = L[[i1]];
   
4.     L2 = Delete[L, i1];
   
5.      For[i2 = 1, i2 <= 8, i2++, b = L2[[i2]];
   
6.        L3 = Delete[L2, i2];
   
7.        For[i3 = 1, i3 <= 7, i3++, c = L3[[i3]];
   
8.          L4 = Delete[L3, i3];
   
9.          For[i4 = 1, i4 <= 6, i4++, d = L4[[i4]];
   
10.            L5 = Delete[L4, i4];
    
11.            For[i5 = 1, i5 <= 5, i5++, e = L5[[i5]];
    
12.       L6 = Delete[L5, i5];
    
13.        For[i6 = 1, i6 <= 4, i6++, f = L6[[i6]];
    
14.        L7 = Delete[L6, i6];
    
15.         For[i7 = 1, i7 <= 3, i7++, g = L7[[i7]];
    
16.         L8 = Delete[L7, i7];
    
17.          For[i8 = 1, i8 <= 2, i8++, h = L8[[i8]];
    
18.          L9 = Delete[L8, i8];
    
19.          i = L9[[1]];   
    
20.          If[a < d < g &&
    
21.            a/(10 b + c) + d/(10 e + f) + g/(10 h + i) == 1,
    
22.           Print[a, b, c, " ", d, e, f, " ", g, h, i]]]]]]]]]] // Timing

复制代码

534 768 912

{6.906, Null}

chyanog

不太喜欢Mathematica中大量的[[]]，这几种方法可以避免

1. Do[If[(#1 < #4 < #7 && #1/(10 #2 + #3) + #4/(10 #5 + #6) + #7/(10 #8 + #9) == 1) & @@ x, Print@x], {x, Permutations@Range[9]}] // Timing

复制代码

可使用Compile加速

1. ToExpression[
   
2.    "Compile[{},Do[If[" <>
   
3.     StringDrop[#1 < #4 < #7 && #1/(10 #2 + #3) + #4/(10 #5 + #6) + #7/(10 #8 + #9) == 1 & /. Slot[t_] :> x[[t]] // InputForm //
   
4.       ToString, -2] <>
   
5.     ",Print@x],{x,Permutations@Range[9]}]]"][] // Timing

复制代码

1. Symbol /@ CharacterRange["a", "i"] /.
   
2.   var_ :> Compile[{}, Module[var, Do[var = x;
   
3.        If[ a < d < g && a/(10 b + c) + d/(10 e + f) + g/(10 h + i) == 1,
   
4.         Print@x], {x, Permutations@Range[9]}]]][] // Timing

复制代码