¿Una variación de IntegerPartition?

Question

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

En Mathematica esto proporcionará una lista de todas las formas de obtener n como la suma de tres a diez de los primeros diez números primos, permitiendo duplicados según sea necesario.

¿Cómo puedo encontrar eficientemente las sumas que igualan n, permitiendo que cada elemento se use solo una vez?

El uso de los primeros diez números primos es solo un ejemplo de juguete. Busco una solución que sea válida para argumentos arbitrarios. En casos reales, generar todas las sumas posibles, incluso utilizando coeficientes polinomiales, requiere demasiada memoria.

me olvidó incluir que estoy usando Mathematica 7.

Answer 1

A continuación se va a construir un árbol binario, y luego analizarla y extraer los resultados:

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

Para ejemplo,

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

Esto no es increíblemente rápido, y quizás el algoritmo podría optimizarse más, pero al menos el número de particiones no crece tan rápido como para IntegerPartitions.

Editar:

Es interesante que memoization sencilla acelera la solución hasta aproximadamente el doble en el ejemplo que he usado antes:

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

Ahora,

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

Out[118]= {0.219, 4660} 

Answer 2

puede utilizar resolver más de enteros, con multiplicadores constreñidos entre 0 y 1. Voy a mostrar un ejemplo específico (primeros 10 primos, suman 100) pero es fácil hacer un procedimiento general para esto.

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

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

--- edit --- Para hacer esto en la versión 7 uno lo haría use Reducir en lugar de Resolver. Voy a agrupar esto en una función.

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

Aquí está el ejemplo de Leonid Shifrin:

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

de salida [128] = {1,80373, 4660}

no tan rápido como el código árbol, pero aún así (creo) un comportamiento razonable . Al menos, no obviamente irrazonable.

--- --- final de edición

Daniel Lichtblau Wolfram Research

Answer 3

me gustaría proponer una solución, similar en espíritu a la de Leonid pero más corta y menos intensiva en memoria. En lugar de construir el árbol y post-procesamiento, el código recorre el árbol y Sow s la solución cuando se encontró:

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

Este código es más lento que el de Leonid

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

Out[177]= {0.499, 4660} 

pero utiliza sobre> ~ 6 veces menos memoria, lo que permite ir más allá.