số nguyên nhỏ nhất không thể nhận được từ {2,3,4,5,6,7,8} (Mathematica)

Question

Tôi đang cố gắng giải quyết vấn đề sau bằng cách sử dụng Mathematica:

Số nguyên dương nhỏ nhất không thể đạt được là gì từ tập hợp {2,3,4,5,6,7,8} thông qua các phép tính số học {+,-,*,/}, lũy thừa và dấu ngoặc đơn. Mỗi số trong tập hợp phải được sử dụng chính xác một lần. Các phép toán unary không được phép (1 không thể chuyển đổi thành -1 mà không sử dụng 0 chẳng hạn).

Ví dụ: số 1073741824000000000000000 có thể nhận được qua (((3+2)*(5+4))/6)^(8+7).

Tôi là người mới bắt đầu với Mathematica. Tôi đã viết mã mà tôi tin rằng giải quyết các vấn đề cho tập hợp {2,3,4,5,6,7} (Tôi nhận được câu trả lời là 2249), nhưng mã của tôi không đủ hiệu quả để làm việc với tập hợp {2,3,4,5,6,7,8}. (Mã của tôi đã mất 71 giây để chạy trên tập hợp {2,3,4,5,6,7})

Tôi rất trân trọng mọi lời khuyên hoặc giải pháp để giải quyết vấn đề khó khăn hơn này với Mathematica, hoặc những hiểu biết chung về cách tôi có thể tăng tốc mã hiện tại của mình.

mã hiện tại của tôi sử dụng một lực lượng vũ phu, phương pháp đệ quy:

(* này định nghĩa kết hợp cho một tập của 1 số như bộ mà 1 số *)

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

(* kiểm tra này cho dù đó là ok để exponentiate hai số bao gồm (phần nào) tùy ý hạn chế để ngăn chặn tràn *)

oktoexponent[number1_, number2_] := 

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

(* này có một danh sách và loại bỏ các phân số với mẫu số g reater hơn 100000 *)

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

(* này định nghĩa kết hợp cho một bộ 2 số - và trả về một tập hợp của tất cả các số có thể thu được thông qua các ứng dụng của + - */lọc bởi oktoexponent và dọn dẹp quy tắc *)

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

(* này kéo dài kết hợp làm việc với các bộ bộ *)

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

(* cho một tập hợp, phân vùng trả về các thiết lập của tất cả các phân vùng thành hai tập con không rỗng *)

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

(* này cuối cùng đã mở rộng kết hợp làm việc với các bộ của bất kỳ kích thước *)

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} 

Answer 1

Đây là vô ích, nhưng tôi theo hạn ngạch của tôi cho bập bẹ vô dụng ngày hôm nay:

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

Ý tưởng chung ở đây là tránh tính toán các quyền hạn (là tốn kém và không giao hoán), trong khi cùng lúc sử dụng commutativity/associativ ity của phép cộng/nhân để giảm cardinality của phạm vi tiếp cận [].

Mã ở trên cũng có sẵn tại địa chỉ:

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

cùng với nghĩa đen gigabyte mã khác vô dụng, dữ liệu, và hài hước.