Вариант IntegerPartition? 

IntegerPartitions[n, {3, 10}, Prime ~Array~ 10]

В Mathematica это даст список всех способов получить n в виде суммы от трех до десяти первых десяти простых чисел, позволяя дублировать по мере необходимости.

Как я могу эффективно найти суммы, равные n, позволяя каждому элементу использоваться только один раз?

Использование первых десяти простых чисел является лишь игрушечным примером. Я ищу решение, которое справедливо для произвольных аргументов. В реальных случаях генерация всех возможных сумм, даже с использованием полиномиальных коэффициентов, занимает слишком много памяти.

Я забыл включить, что я использую Mathematica 7.

Ответы

Ответ 1

Следующее построит двоичное дерево, а затем проанализирует его и извлечет результаты:

Clear[intParts];
intParts[num_, elems_List] /; Total[elems] < num := p[];
intParts[num_, {fst_, rest___}] /; 
   fst < num := {p[fst, intParts[num - fst, {rest}]], intParts[num, {rest}]};
intParts[num_, {fst_, rest___}] /; fst > num := intParts[num, {rest}];
intParts[num_, {num_, rest___}] := {pf[num], intParts[num, {rest}]};


Clear[nextPosition];
nextPosition = 
  Compile[{{pos, _Integer, 1}},
     Module[{ctr = 0, len = Length[pos]},
       While[ctr < len && pos[[len - ctr]] == 1, ++ctr];
       While[ctr < len && pos[[len - ctr]] == 2, ++ctr];
       Append[Drop[pos, -ctr], 1]], CompilationTarget -> "C"];

Clear[getPartitionsFromTree, getPartitions];
getPartitionsFromTree[tree_] :=
  Map[Extract[tree, #[[;; -3]] &@FixedPointList[nextPosition, #]] &, 
     Position[tree, _pf, Infinity]] /. pf[x_] :> x;
getPartitions[num_, elems_List] := 
    [email protected][num, [email protected][elems]];

Например,

In[14]:= getPartitions[200,Prime~Array~150]//Short//Timing

Out[14]= {0.5,{{3,197},{7,193},{2,5,193},<<4655>>,{3,7,11,13,17,19,23,29,37,41},      
       {2,3,5,11,13,17,19,23,29,37,41}}}

Это не безумно быстро, и, возможно, алгоритм может быть оптимизирован дальше, но по крайней мере количество разделов не растет так же быстро, как для IntegerPartitions.

Edit:

Интересно, что простая memoization ускоряет решение примерно вдвое в примере, который я использовал ранее:

Clear[intParts];
intParts[num_, elems_List] /; Total[elems] < num := p[];
intParts[num_, seq : {fst_, rest___}] /; fst < num := 
    intParts[num, seq] = {p[fst, intParts[num - fst, {rest}]], 
          intParts[num, {rest}]};
intParts[num_, seq : {fst_, rest___}] /; fst > num := 
    intParts[num, seq] = intParts[num, {rest}];
intParts[num_, seq : {num_, rest___}] := 
    intParts[num, seq] = {pf[num], intParts[num, {rest}]};

Теперь

In[118]:= getPartitions[200, Prime~Array~150] // Length // Timing

Out[118]= {0.219, 4660}

Ответ 2

Может использовать Solve over Integer, с множителями, ограниченными между 0 и 1. Я покажу вам для конкретного примера (первые 10 простых чисел, добавьте к 100), но для этого легко сделать общую процедуру.

primeset = Prime[Range[10]];
mults = Array[x, Length[primeset]];
constraints01 = Map[0 <= # <= 1 &, mults];
target = 100;

Timing[res = mults /. 
  Solve[Flatten[{mults.primeset == target, constraints01}],
    mults, Integers];
  Map[Pick[primeset, #, 1] &, res]
 ]

Out [178] = {0,004, {{7, 11, 13, 17, 23, 29}, {5, 11, 13, 19, 23, 29}, {5, 7, 17, 19, 23, 29}, {2, 5, 11, 13, 17, 23, 29}, {2, 3, 11, 13, 19, 23, 29} {2, 3, 7, 17, 19, 23, 29}, {2, 3, 5, 7, 11, 13, 17, 19, 23}}}

--- редактировать --- Чтобы сделать это в версии 7, вместо "Решить" следует использовать "Сократить". Я свяжу это с одной функцией.

knapsack[target_, items_] := Module[
  {newset, x, mults, res},
  newset = Select[items, # <= target &];
  mults = Array[x, Length[newset]];
  res = mults /.
    {ToRules[Reduce[
       Flatten[{mults.newset == target, Map[0 <= # <= 1 &, mults]}],
       mults, Integers]]};
  Map[Pick[newset, #, 1] &, res]]

Вот пример Леонида Шифрина:

Timing[Length[knapsack[200, Prime[Range[150]]]]]

Вывод [128] = {1.80373, 4660}

Не так быстро, как древовидный код, но все же (я думаю) разумное поведение. По крайней мере, не очевидно, необоснованно.

--- конец редактирования ---

Даниэль Лихтблау Wolfram Research

Ответ 3

Я хотел бы предложить решение, подобное духу Леониду, но более короткое и менее интенсивное в памяти. Вместо того, чтобы строить дерево и обрабатывать его, код перемещает дерево и Sow решение при обнаружении:

Clear[UniqueIntegerParitions];
UniqueIntegerParitions[num_Integer?Positive, 
  list : {__Integer?Positive}] := 
 Block[{f, $RecursionLimit = Infinity},
  f[n_, cv_, {n_, r___}] :=
   (Sow[Flatten[{cv, n}]]; f[n, cv, {r}];);
  f[n_, cv_, {m_, r___}] /; m > n := f[n, cv, {r}];
  f[n_, cv_, {m_, r___}] /; 
    Total[{r}] >= n - m := (f[n - m, {cv, m}, {r}]; f[n, cv, {r}]);
  f[___] := Null;
  Part[Reap[f[num, {}, [email protected][Cases[list, x_ /; x <= num]]]], 
   2, 1]]

Этот код медленнее, чем

In[177]:= 
UniqueIntegerParitions[200, Prime~Array~PrimePi[200]] // 
  Length // Timing

Out[177]= {0.499, 4660}

но использует память в > ~ 6 раз меньше, что позволяет идти дальше.