7

Mathematica を使用して次の問題を解決しようとしています。

{2,3,4,5,6,7,8}算術演算{+,-,*,/}、累乗、および括弧を介してセットから取得できない最小の正の整数は何ですか? セット内の各数値は、1 回だけ使用する必要があります。単項演算は許可されていません (たとえば、0 を使用せずに 1 を -1 に変換することはできません)。

たとえば、番号1073741824000000000000000は を介し​​て取得でき(((3+2)*(5+4))/6)^(8+7)ます。

私は Mathematica の初心者です。セットの問題を解決すると思われるコードを作成しました{2,3,4,5,6,7}(回答として 2249 を取得しました) が、私のコードは set を操作するのに十分効率的ではありません{2,3,4,5,6,7,8}。(私のコードは、セットで実行するのに既に 71 秒かかります{2,3,4,5,6,7})

この困難な問題を Mathematica で解決するためのヒントや解決策、または既存のコードを高速化する方法に関する一般的な洞察をいただければ幸いです。

私の既存のコードは、ブルート フォースの再帰的アプローチを使用しています。

（*これは、1つの数のセットの組み合わせをその1つの数のセットとして定義します*）

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

(* これは、オーバーフローを防ぐための (ある程度) 任意の制限を含む 2 つの数値をべき乗してもよいかどうかをテストします *)

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 はすべてのパーティションのセットを 2 つの空でないサブセットに返します *)

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

2 に答える 2

0

これは役に立ちませんが、今日の無用なせせらぎの割り当てを下回っています。

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

ここでの一般的な考え方は、べき乗の計算 (高価で可換でない) を回避すると同時に、加算/乗算の可換性/結合性を使用して、reach[] のカーディナリティを減らすことです。

上記のコードは、次の場所でも入手できます。

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

文字通りギガバイトの他の役に立たないコード、データ、およびユーモアとともに。

于 2013-01-20T05:39:44.537 に答える