Find elements of a list with a given sum

This culls subsequences whose sum exceeds n, to limit somewhat the exponential growth of the possible subsequences:

subs[list_, n_] := 
 If[#1 == n, #2, Nothing] & @@@ 
  Fold[Function[{x, a}, 
    Join[x, (If[#1 + a[[2]] > n, 
         Nothing, {#1 + a[[2]], Append[#2, a[[1]]]}] & @@@ 
       x)]], {{0, {}}}, Transpose@{Range@Length@list, list}]

It uses Fold to update a list of subsequences with each number in the list. Only subsequences with sums less than or equal to n are retained. It therefore assumes that the list elements are non-negative. At the end, subsequences with sums less than n are removed.

This makes use of the recently added Nothing object, which removes itself from lists. I like Nothing (which does not mean that I don't like anything).


Check out the answer here, by @s0rce and @DanielLichtblau, for an ingenious use of FrobeniusSolve.

KnapsackLikeProblem[list_List, n_Integer] :=
   With[{s = FrobeniusSolve[list, n]},
        Map[Flatten[Position[#, 1]] &, Pick[s, Map[Max, s], 1]]
   ]

For very large lists, the number of Frobenius solutions can be very large. In this case, the technique by @MarkAdler may be more appropriate.

Edit

Prompted by @MarkAdler's comment that FrobeniusSolve is slow, I adapted another knapsack response from @DanielLichtblau. Using Reduce is quite a bit faster, for this problem.

DanielSubsetSum[list_List, n_Integer] :=
   Block[{c, v, s},
      c = Array[v, Length[list]];
      s = c /. {ToRules[Reduce[
         Join[Map[1 >= # >= 0 &, c], {Total[c] >= 1, c.list == n}],
         c, Integers]]};
      Map[Flatten[Position[#, 1]] &, s]
   ]

list = {2, 1, 11, 3, 10, 7, 7, 9, 4};
n = 10;

Brutal brute force (because it's more brutal than a regular brute force)

Pick[Range@Length@list, #, 1] & /@ 
 Tuples[{0, 1}, 
   Length@list][[Flatten@
    Position[Tuples[{0, 1}, Length@list].list, n]]]

{{5}, {4, 7}, {4, 6}, {2, 8}, {1, 2, 7}, {1, 2, 6}, {1, 2, 4, 9}}

Warning: Fails for Length@list > 24 due to lack of memory.


A more reasonable way using the same approach (and a proper answer)

Pick[Range@Length@list, #, 1] & /@ 
 Select[FrobeniusSolve[list, n], Max@# == 1 &]

{{5}, {4, 7}, {4, 6}, {2, 8}, {1, 2, 7}, {1, 2, 6}, {1, 2, 4, 9}}


The use of IntegerPartitions seems natural:

This gives the partitions of n into elements from list:

elem = Select[IntegerPartitions[n, All, list], sublist2Q[list, #] &]

{{4, 3, 1, 2}, {9, 1}, {7, 3}, {7, 1, 2}, {7, 3}, {7, 1, 2}, {10}}

where sublist2Q is

sublist2Q[l_List, {s___}] := 
 MatchQ[l, {OrderlessPatternSequence[s, ___]}]

To find the positions of elements of elem:

pos = Table[Sort@Flatten@(FirstPosition[list, #] & /@ elem[[i]]), {i, 1, Length@elem}]

{{1, 2, 4, 9}, {2, 8}, {4, 6}, {1, 2, 6}, {4, 6}, {1, 2, 6}, {5}}

This could be sorted by length:

SortBy[pos, Length]

{{5}, {2, 8}, {4, 6}, {4, 6}, {1, 2, 6}, {1, 2, 6}, {1, 2, 4, 9}}

There's an ambguity with the repeating elements, i.e. 7 in this case: {4, 6} occurs twice in pos, as well as {1, 2, 6}. I guess this would need further processing.