求算24点的程序,要求快且求出所有解!

mathematica

如今回头看,这真的不是一个难题

mathematica

mathematica 发表于 2018-7-25 15:07
如今回头看,这真的不是一个难题

1. Clear["Global`*"];(*Clear all variables*)
   
2. abcd={"a","b","c","d"}
   
3. pers=Permutations@abcd
   
4. mark=Tuples[{"+","-","*","/"},{3}]
   
5. (*函数,给出一个{"a","b","c","d"} 给出所有排列,返回结果的元素是"a*b+c-d"这种*)
   
6. fun[z_]:=StringJoin[#]&/@(Riffle[z,#]&/@mark)
   
7. mylist={
   
8. {"((a","b)","c)","d"},
   
9. {"(a","b)","(c","d)"},
   
10. {"a","(b","c)","d"},
    
11. {"a","((b","c)","d)"},
    
12. {"a","(b","(c","d))"}
    
13. }
    
14. (*abcd顺序不变,得到所有的可能情况*)
    
15. out=Flatten[fun[#]&/@mylist]
    
16. (*函数,对于一个字符串"a*b+c/d",得到所有的顺序可以改变的字符串列表*)
    
17. strall[str_]:=StringReplace[str,Thread[{"a","b","c","d"}->#]]&/@pers
    
18. sol=Flatten[strall[#]&/@out]
    

复制代码

暴力求解,列举出所有可能的情况

mathematica

"((a+b)+c)+d","((a+b)+d)+c","((a+c)+b)+d","((a+c)+d)+b","((a+d)+b)+c","((a+d)+c)+b","((b+a)+c)+d","((b+a)+d)+c","((b+c)+a)+d","((b+c)+d)+a","((b+d)+a)+c","((b+d)+c)+a","((c+a)+b)+d","((c+a)+d)+b","((c+b)+a)+d","((c+b)+d)+a",
"((c+d)+a)+b","((c+d)+b)+a","((d+a)+b)+c","((d+a)+c)+b","((d+b)+a)+c","((d+b)+c)+a","((d+c)+a)+b","((d+c)+b)+a","((a+b)+c)-d","((a+b)+d)-c","((a+c)+b)-d","((a+c)+d)-b","((a+d)+b)-c","((a+d)+c)-b","((b+a)+c)-d","((b+a)+d)-c",
"((b+c)+a)-d","((b+c)+d)-a","((b+d)+a)-c","((b+d)+c)-a","((c+a)+b)-d","((c+a)+d)-b","((c+b)+a)-d","((c+b)+d)-a","((c+d)+a)-b","((c+d)+b)-a","((d+a)+b)-c","((d+a)+c)-b","((d+b)+a)-c","((d+b)+c)-a","((d+c)+a)-b","((d+c)+b)-a",
"((a+b)+c)*d","((a+b)+d)*c","((a+c)+b)*d","((a+c)+d)*b","((a+d)+b)*c","((a+d)+c)*b","((b+a)+c)*d","((b+a)+d)*c","((b+c)+a)*d","((b+c)+d)*a","((b+d)+a)*c","((b+d)+c)*a","((c+a)+b)*d","((c+a)+d)*b","((c+b)+a)*d","((c+b)+d)*a",
"((c+d)+a)*b","((c+d)+b)*a","((d+a)+b)*c","((d+a)+c)*b","((d+b)+a)*c","((d+b)+c)*a","((d+c)+a)*b","((d+c)+b)*a","((a+b)+c)/d","((a+b)+d)/c","((a+c)+b)/d","((a+c)+d)/b","((a+d)+b)/c","((a+d)+c)/b","((b+a)+c)/d","((b+a)+d)/c",
"((b+c)+a)/d","((b+c)+d)/a","((b+d)+a)/c","((b+d)+c)/a","((c+a)+b)/d","((c+a)+d)/b","((c+b)+a)/d","((c+b)+d)/a","((c+d)+a)/b","((c+d)+b)/a","((d+a)+b)/c","((d+a)+c)/b","((d+b)+a)/c","((d+b)+c)/a","((d+c)+a)/b","((d+c)+b)/a",
"((a+b)-c)+d","((a+b)-d)+c","((a+c)-b)+d","((a+c)-d)+b","((a+d)-b)+c","((a+d)-c)+b","((b+a)-c)+d","((b+a)-d)+c","((b+c)-a)+d","((b+c)-d)+a","((b+d)-a)+c","((b+d)-c)+a","((c+a)-b)+d","((c+a)-d)+b","((c+b)-a)+d","((c+b)-d)+a",
"((c+d)-a)+b","((c+d)-b)+a","((d+a)-b)+c","((d+a)-c)+b","((d+b)-a)+c","((d+b)-c)+a","((d+c)-a)+b","((d+c)-b)+a","((a+b)-c)-d","((a+b)-d)-c","((a+c)-b)-d","((a+c)-d)-b","((a+d)-b)-c","((a+d)-c)-b","((b+a)-c)-d","((b+a)-d)-c",

为了节省篇幅,仅仅列举出一部分结果
所有结果放在附件里面

mathematica

mathematica 发表于 2018-7-25 16:40
暴力求解,列举出所有可能的情况

Groupings[Permutations[{a,b,c,d},{4}],{Plus,Subtract,Times,Divide}->2,HoldForm]
这个{Plus,Subtract,Times,Divide}->2是什么意思?

所有可能的表达式有7680种，去重后有1170种。这个1170怎么得到的?

mathematica

mathematica 发表于 2018-7-25 17:26
Groupings,{Plus,Subtract,Times,Divide}->2,HoldForm]
这个{Plus,Subtract,Times,Divide}->2是什么 ...

1. #算24点程序
   
2. use strict;use warnings;use diagnostics;
   
3. my $a=9;
   
4. my $b=5;
   
5. my $c=2;
   
6. my $d=7;
   
7. #利用穷举法,列出abcd四个变量之间所有的各种排列
   
8. &cacu($a,$b,$c,$d);
   
9. &cacu($a,$b,$d,$c);
   
10. &cacu($a,$c,$b,$d);
    
11. &cacu($a,$c,$d,$b);
    
12. &cacu($a,$d,$b,$c);
    
13. &cacu($a,$d,$c,$b);
    
14. &cacu($b,$a,$c,$d);
    
15. &cacu($b,$a,$d,$c);
    
16. &cacu($b,$c,$a,$d);
    
17. &cacu($b,$c,$d,$a);
    
18. &cacu($b,$d,$a,$c);
    
19. &cacu($b,$d,$c,$a);
    
20. &cacu($c,$a,$b,$d);
    
21. &cacu($c,$a,$d,$b);
    
22. &cacu($c,$b,$a,$d);
    
23. &cacu($c,$b,$d,$a);
    
24. &cacu($c,$d,$a,$b);
    
25. &cacu($c,$d,$b,$a);
    
26. &cacu($d,$a,$b,$c);
    
27. &cacu($d,$a,$c,$b);
    
28. &cacu($d,$b,$a,$c);
    
29. &cacu($d,$b,$c,$a);
    
30. &cacu($d,$c,$a,$b);
    
31. &cacu($d,$c,$b,$a);
    
32. #子函数,利用三重循环计算abcd位置不变的时候的所有可能,
    
33. #四个数之间只可能有三种运算符,加括号只可能有五种可能.
    
34. sub cacu
    
35. {
    
36.     my ($a,$b,$c,$d)=@_;
    
37.     my @op=("+","-","*","/");#运算符数组
    
38.     foreach my $x (@op)#第一个运算符
    
39.     {
    
40.         foreach my $y (@op)#第二个运算符
    
41.         {
    
42.             foreach my $z (@op)#第三个运算符
    
43.             {
    
44.                 my $str1="(($a$x$b)$y$c)$z$d";
    
45.                 my $str2="($a$x$b)$y($c$z$d)";
    
46.                 my $str3="($a$x($b$y$c))$z$d";
    
47.                 my $str4="$a$x(($b$y$c)$z$d)";
    
48.                 my $str5="$a$x($b$y($c$z$d))";
    
49.                 if(abs(eval($str1)-24)<0.000001){print $str1 . "=24\n";}
    
50.                 if(abs(eval($str2)-24)<0.000001){print $str2 . "=24\n";}
    
51.                 if(abs(eval($str3)-24)<0.000001){print $str3 . "=24\n";}
    
52.                 if(abs(eval($str4)-24)<0.000001){print $str4 . "=24\n";}
    
53.                 if(abs(eval($str5)-24)<0.000001){print $str5 . "=24\n";}
    
54.             }
    
55.         }
    
56.     }
    
57. }
    

复制代码

贴一下我的perl代码,居然在分母等于零的时候也能运行,我真佩服perl,
代码写起来真爽!
perl太牛逼了

chyanog

chyanog 发表于 2013-6-25 12:11
((1+2)+3)*4=24

(1+(2+3))*4=24

不用字符串，不考虑去重

1. Clear["`*"];
   
2. calc24[list_] :=
   
3.   Cases[
   
4.     Tuples[{Tuples[{Plus, Subtract, Times, Divide}, 3], Permutations[list]}] /.
   
5.      {{o1_, o2_, o3_}, {a_, b_, c_, d_}} ->
   
6.       HoldForm /@ {
   
7.         a~o1~b~o2~c~o3~d,
   
8.         (a~o1~b)~o2~(c~o3~d),
   
9.         (a~o1~(b~o2~c))~o3~d,
   
10.         a~o1~(b~o2~(c~o3~d)),
    
11.          a~o1~((b~o2~c)~o3~d)
    
12.         },
    
13.     e_ /; ReleaseHold@e == 24, {2}
    
14.     ] // Quiet;
    
15. 
    
16. calc24[{2, 3, 5, 7}]

复制代码

考虑去重

1. Clear["`*"];
   
2. calc24[list_] :=
   
3.   Groupings[Permutations[{a, b, c, d}], {Plus -> {2, Orderless}, Subtract -> 2, Times -> {2, Orderless}, Divide -> 2}, HoldForm] //
   
4.        DeleteDuplicatesBy[Factor@*ReleaseHold] //
   
5.       ReplaceAll[Thread[{a, b, c, d} -> list]] //
   
6.      DeleteDuplicates //
   
7.     Pick[#, ReleaseHold@# /. ComplexInfinity -> 0, 24] & //
   
8.    Quiet;
   
9. 
   
10. calc24[{2, 3, 5, 7}]

复制代码

mathematica

chyanog 发表于 2018-7-27 15:22
不用字符串，不考虑去重

考虑去重

我想写一个穷举法列举出所有的不重的表达式a+b+c*d这种的,
对应的mathematica代码是?

mathematica

chyanog 发表于 2018-7-27 15:22
不用字符串，不考虑去重

考虑去重

其实如果代码都在1秒之内执行完毕,
任何语言都没啥差别,
以可维护性 可读性为差别的标准

mathematica

mathematica 发表于 2018-7-25 17:26
Groupings,{Plus,Subtract,Times,Divide}->2,HoldForm]
这个{Plus,Subtract,Times,Divide}->2是什么 ...

@chyanog
下面两个计算结果不一样，一个长度是1170，一个长度是1192

1. (*为什么两个结果不一样呢*)
   
2. Clear["Global`*"];
   
3. aa=Groupings[Permutations[{a,b,c,d},{4}],{Plus->{2,Orderless},Subtract->2,Times->{2,Orderless},Divide->2},HoldForm];
   
4. (*下面的结果是1170*)
   
5. bb=Union[Together@FullSimplify[ReleaseHold[#]]&/@aa]//Length
   
6. (*下面的结果是1192*)
   
7. cc=Union[FullSimplify[ReleaseHold[#]]&/@aa]//Length
   

复制代码

正确结果应该是1170，为什么呢？
看下面的代码，用无理数带进去，最后结果长度是1170

1. Clear["Global`*"];
   
2. aa=Groupings[Permutations[{a,b,c,d},{4}],{Plus->{2,Orderless},Subtract->2,Times->{2,Orderless},Divide->2},HoldForm];
   
3. bb=FullSimplify[ReleaseHold[#]]&/@aa;
   
4. (*带入四个无理数，乘以10^8,然后高精度计算，如果表达式不相等，那么计算结果很难相等*)
   
5. cc=IntegerPart[N[10^8*#,100]]&/@(bb/.Thread[{a,b,c,d}->{EulerGamma,Pi,E,Sqrt[2]}]);
   
6. dd=Union@cc
   
7. Length@dd
   

复制代码

mathematica

mathematica 发表于 2019-1-21 13:28
@chyanog
下面两个计算结果不一样，一个长度是1170，一个长度是1192

同样的union函数，为什么结果不一样呢？