Eine Variation von IntegerPartition?

Question

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

In Mathematica gibt dies eine Liste aller Möglichkeiten, n als Summe von drei bis zehn der ersten zehn Primzahlen zu erhalten, wobei bei Bedarf Duplikate verwendet werden.

Wie kann ich effizient die Summen finden, die n ergeben, wobei jedes Element nur einmal verwendet werden darf?

Die Verwendung der ersten zehn Primzahlen ist nur ein Spielbeispiel. Ich suche eine Lösung, die für beliebige Argumente gültig ist. In tatsächlichen Fällen benötigt das Generieren aller möglichen Summen, selbst unter Verwendung von Polynomkoeffizienten, zu viel Speicherplatz.

Ich habe vergessen zu erwähnen, dass ich Mathematica 7 verwende.

Answer 1

Die folgenden werden einen Binärbaum erstellen und analysieren und dann die Ergebnisse extrahieren:

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] := 
getPartitionsFromTree@intParts[num, Reverse@Sort[elems]];

Zum Beispiel,

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

Dies ist nicht extrem schnell, und vielleicht könnte der Algorithmus weiter optimiert werden, aber zumindest wächst die Anzahl der Partitionen nicht so schnell wie bei IntegerPartitions.

Bearbeitung:

Interessant ist, dass einfache Memoisierung die Lösung etwa zweimal schneller macht als bei dem zuvor verwendeten Beispiel:

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

Jetzt,

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

Out[118]= {0.219, 4660}

Answer 2

Kann über Integers gelöst werden, wobei die Multiplikatoren zwischen 0 und 1 eingeschränkt sind. Ich werde das anhand eines spezifischen Beispiels zeigen (ersten 10 Primzahlen, Summe ergibt 100), aber es ist einfach, ein allgemeines Verfahren dafür zu entwickeln.

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

Ergebnis [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}}}

---Bearbeiten--- Um dies in Version 7 durchzuführen, würde man Reduce anstelle von Solve verwenden. Ich werde dies in einer Funktion bündeln.

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

Hier ist das Beispiel von Leonid Shifrin:

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

Ergebnis [128]= {1,80373, 4660}

Nicht so schnell wie der Baumcode, aber dennoch (denke ich) akzeptables Verhalten. Zumindest nicht offensichtlich unvernünftig.

---Ende Bearbeiten---

Daniel Lichtblau Wolfram Research

Answer 3

Ich möchte einen Lösungsvorschlag machen, der im Geiste von Leonid, aber kürzer und weniger speicherintensiv ist. Anstatt den Baum zu erstellen und nachträglich zu bearbeiten, durchläuft der Code den Baum und Sows die Lösung, wenn sie gefunden wird:

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, {}, Reverse@Union[Cases[list, x_ /; x <= num]]]], 
   2, 1]]

Dieser Code ist langsamer als Leonids

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

Out[177]= {0.499, 4660}

verwendet aber etwa >~ 6 Mal weniger Speicher, was es ermöglicht, weiter zu gehen.