不能从 {2,3,4,5,6,7,8} 获得的最小整数（Mathematica）答案

【问题标题】：smallest integer not obtainable from {2,3,4,5,6,7,8} (Mathematica)不能从 {2,3,4,5,6,7,8} 获得的最小整数（Mathematica）
【发布时间】：2012-12-20 17:06:26
【问题描述】：

我正在尝试使用 Mathematica 解决以下问题：

通过算术运算{+,-,*,/}、求幂和括号无法从集合{2,3,4,5,6,7,8} 中获得的最小正整数是多少。集合中的每个数字必须只使用一次。不允许一元运算（例如，如果不使用 0，则 1 不能转换为 -1）。

例如，号码1073741824000000000000000 可通过(((3+2)*(5+4))/6)^(8+7) 获得。

我是 Mathematica 的初学者。我编写的代码我相信可以解决集合 {2,3,4,5,6,7} 的问题（我的答案是 2249），但是我的代码效率不足以处理集合 {2,3,4,5,6,7,8}。（我的代码已经在 {2,3,4,5,6,7} 集合上运行需要 71 秒）

我非常感谢使用 Mathematica 解决这个更困难的问题的任何提示或解决方案，或关于如何加快现有代码速度的一般见解。

我现有的代码使用暴力递归方法：

(* 这将一组 1 个数字的组合定义为该 1 个数字的集合 *)

combinations[list_ /; Length[list] == 1] := list

(* 这测试是否可以对两个数字求幂，包括（有点）任意限制以防止溢出 *)

oktoexponent[number1_, number2_] :=

 If[number1 == 0, number2 >= 0,
  If[number1 < 0,
   (-number1)^number2 < 10000 \[And] IntegerQ[number2],
   number1^number2 < 10000 \[And] IntegerQ[number2]]]

(* 这需要一个列表并删除分母大于 100000 *)

cleanup[list_] := Select[list, Denominator[#] < 100000 &]

(* 这定义了一组 2 个数字的组合 - 并返回一组通过 + - * / 由 oktoexponent 和清理规则过滤的应用获得的所有可能数字 *)

combinations[list_ /; Length[list] == 2 && Depth[list] == 2] :=
  cleanup[DeleteCases[#, Null] &@DeleteDuplicates@
    {list[[1]] + list[[2]],
     list[[1]] - list[[2]],
     list[[2]] - list[[1]],
     list[[1]]*list[[2]],
     If[oktoexponent[list[[1]], list[[2]]], list[[1]]^list[[2]],],
     If[oktoexponent[list[[2]], list[[1]]], list[[2]]^list[[1]],],
     If[list[[2]] != 0, list[[1]]/list[[2]],],
     If[list[[1]] != 0, list[[2]]/list[[1]],]}]

(* 这扩展了组合以使用集合集 *)

combinations[
  list_ /; Length[list] == 2 && Depth[list] == 3] := 
 Module[{m, n, list1, list2},
  list1 = list[[1]];
  list2 = list[[2]];
  m = Length[list1]; n = Length[list2];
  cleanup[
   DeleteDuplicates@
    Flatten@Table[
      combinations[{list1[[i]], list2[[j]]}], {i, m}, {j, n}]]]

(*对于给定的集合，partition返回所有partition的集合成两个非空子集*)

partition[list_] := Module[{subsets},
  subsets = Select[Subsets[list], # != {} && # != list &]; 
  DeleteDuplicates@
   Table[Sort@{subsets[[i]], Complement[list, subsets[[i]]]}, {i, 
     Length[subsets]}]]

(* 这最终扩展了组合以适用于任何大小的集合 *)

combinations[list_ /; Length[list] > 2] := 
 Module[{partitions, k},
  partitions = partition[list];
  k = Length[partitions]; 
  cleanup[Sort@
    DeleteDuplicates@
     Flatten@(combinations /@ 
        Table[{combinations[partitions[[i]][[1]]], 
          combinations[partitions[[i]][[2]]]}, {i, k}])]]

Timing[desiredset = combinations[{2, 3, 4, 5, 6, 7}];]

{71.5454, Null}

Complement[
   Range[1, 3000], #] &@(Cases[#, x_Integer /; x > 0 && x <= 3000] &@
   desiredset)

{2249, 2258, 2327, 2509, 2517, 2654, 2789, 2817, 2841, 2857, 2990, 2998}

【问题讨论】：

好吧，如果你向我们展示你的代码而不是它的粗略草图，我们中的一些人会剪切粘贴和摆弄。
不知何故这听起来像是一个学校作业..
我现在将发布我的代码 - 最初没有发布，只是因为我知道我是一个初学者，并且预计需要完全重写最佳代码。 Jari，不太清楚该说什么——不是——我正在努力学习 Mathematica，并且一直在通过 Project Euler 解决问题作为这样做的一种方式。这也是我亲自为自己设定的问题。
我在这里回答了类似的问题stackoverflow.com/a/3948113/353410
@Royce，确认一下，这不是 projecteuler.net 的问题，对吗？换句话说，你知道这个问题没有在线解决方案吗？我的想法：我认为您不能安全地丢弃较大的中间结果（溢出），因为它们可能会再次变小。我会建议一种符号方法（不一定使用 Mathematica），您可以在其中简化每一轮的符号（即“2*3”和“3*2”是相同的）。

标签： wolfram-mathematica

【解决方案1】：

这无济于事，但我今天无用的喋喋不休超出了我的配额：

(* it turns out the symbolizing + * is not that useful after all *) 
f[x_,y_] = x+y 
fm[x_,y_] = x-y 
g[x_,y_] = x*y 
gd[x_,y_] = x/y 

(* power properties *) 
h[h[a_,b_],c_] = h[a,b*c] 
h[a_/b_,n_] = h[a,n]/h[b,n] 
h[1,n_] = 1 

(* expand simple powers only! *) 
(* does this make things worse? *) 
h[a_,2] = a*a 
h[a_,3] = a*a*a 

(* all symbols for two numbers *) 
allsyms[x_,y_] := allsyms[x,y] =  
 DeleteDuplicates[Flatten[{f[x,y], fm[x,y], fm[y,x],  
 g[x,y], gd[x,y], gd[y,x], h[x,y], h[y,x]}]] 

allsymops[s_,t_] := allsymops[s,t] =  
 DeleteDuplicates[Flatten[Outer[allsyms[#1,#2]&,s,t]]] 

Clear[reach]; 
reach[{}] = {} 
reach[{n_}] := reach[n] = {n} 
reach[s_] := reach[s] = DeleteDuplicates[Flatten[ 
 Table[allsymops[reach[i],reach[Complement[s,i]]],  
  {i,Complement[Subsets[s],{ {},s}]}]]]

这里的总体思路是避免计算幂（即昂贵且不可交换），同时使用加法/乘法的交换性/结合性以减少到达[]的基数。

上面的代码也可以在：

https://github.com/barrycarter/bcapps/blob/master/playground.m#L20

还有大量其他无用的代码、数据和幽默。

【讨论】：

【解决方案2】：

我认为您的问题的答案在于命令Groupings。这允许您创建列表的二叉树。二叉树非常有用，因为您允许Plus, Subtract, Times, Divide, Power 的每个操作都需要两个参数。例如。

In>  Groupings[3,2]
Out> {List[List[1,2],3],List[1,List[2,3]]}

因此，我们需要做的就是将List 替换为允许的操作的任意组合。

但是，Groupings 似乎是全能的，因为它可以选择执行此操作。假设你有两个函数 foo 和 bar 并且都接受 2 参数，那么你可以将所有组合设为：

In>  Groupings[3,{foo->2,bar->2}]
Out> {foo[foo[1,2],3],foo[1,foo[2,3]],foo[bar[1,2],3],foo[1,bar[2,3]],
      bar[foo[1,2],3],bar[1,foo[2,3]],bar[bar[1,2],3],bar[1,bar[2,3]]}

现在可以计算我们拥有的组合数量：

In>  Groupings[Permutations[#],
               {Plus->2,Subtract->2,Times->2,Divide->2,Power->2}
              ] &@ {a,b,c,d,e};
In>  Length@%
In>  DeleteDuplicates@%%
In>  Length@%
Out> 1050000
Out>  219352

这意味着对于 5 个不同的数字，我们有 219352 个唯一的组合。

遗憾的是，由于上溢、被零除或下溢，许多这些组合无法评估。但是，尚不清楚要删除哪些。 a^(b^(c^(d^e))) 的值可能很大，也可能很小。分数幂可以产生完美的根，大数的除法可以变得完美。

In>  Groupings[Permutations[#],
               {Plus->2,Subtract->2,Times->2,Divide->2,Power->2}
              ] &@ {2, 3, 4};
In>  Union[Cases[%, _?(IntegerQ[#] && # >= 0 &)]];
In>  Split[%, #2 - #1 <= 1 &][[1]]
Out> {1, 2, 3, 4, 5, 6}

【讨论】：