smallest integer not obtainable from {2,3,4,5,6,7,

问题:

I'm trying to solve the following problem using Mathematica:

What is the smallest positive integer not obtainable from the set {2,3,4,5,6,7,8} via arithmetic operations {+,-,*,/}, exponentiation, and parentheses. Each number in the set must be used exactly once. Unary operations are NOT allowed (1 cannot be converted to -1 with without using a 0, for example).

For example, the number 1073741824000000000000000 is obtainable via (((3+2)*(5+4))/6)^(8+7).

I am a beginner with Mathematica. I have written code that I believe solves the problems for the set {2,3,4,5,6,7} (I obtained 2249 as my answer), but my code is not efficient enough to work with the set {2,3,4,5,6,7,8}. (My code already takes 71 seconds to run on the set {2,3,4,5,6,7})

I would very much appreciate any tips or solutions to solving this harder problem with Mathematica, or general insights as to how I could speed my existing code.

My existing code uses a brute force, recursive approach:

(* this defines combinations for a set of 1 number as the set of that 1 number *)

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

(* this tests whether it's ok to exponentiate two numbers including (somewhat) arbitrary restrictions to prevent overflow *)

oktoexponent[number1_, number2_] :=

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

(* this takes a list and removes fractions with denominators greater than 100000 *)

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

(* this defines combinations for a set of 2 numbers - and returns a set of all possible numbers obtained via applications of + - * / filtered by oktoexponent and cleanup rules *)

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]],]}]

(* this extends combinations to work with sets of sets *)

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}]]]

(* for a given set, partition returns the set of all partitions into two non-empty subsets *)

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

(* this finally extends combinations to work with sets of any size *)

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}

回答1:

This is unhelpful, but I'm under my quota for useless babbling today:

(* 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}]}]]] 

The general idea here is to avoid calculating powers (which are expensive and non-commutative), while at the same time using the commutativity/associativity of addition/multiplication to reduce the cardinality of reach[].

Code above also available at:

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

along with literally gigabytes of other useless code, data, and humor.

回答2:

I think the answer to your question lays in the command Groupings. This allows you to create a binary tree of a list. The binary tree is very usefull as each of the operations you allow Plus, Subtract, Times, Divide, Power take two arguments. Eg.

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

Thus all we need to do is replace List with any combination of the allowed operations.

However, Groupings seems to be almighty as it has an option to do this. Imagine you have two functions foo and bar and both take 2 arguments, then you can make all combinations as :

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]]}

Now it is possible to count the amount of combinations we have :

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

This means that for 5 distinct numbers, we have 219352 unique combinations.

Sadly, many of these combinations cannot be evaluated due to overflow, division by zero or underflow. However, it is not evident which ones to remove. The value a^(b^(c^(d^e))) could be humongous, or just small. Fractional powers could result in perfect roots and divisions by large numbers can become perfect.

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}