6

I want to pick all possible sublists of a given list of integers so that the sum of the sublist elements is a fixed value n, in terms of the original positions of the sublist elements.

For example, with

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

I hope to get

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

How can I do this?

urgrue
  • 63
  • 5

4 Answers4

15

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).

Mark Adler
  • 4,949
  • 1
  • 22
  • 37
9

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]
   ]
Community
  • 1
KennyColnago
  • 15,209
  • 26
  • 62
  • 1
    Actually this solution seems to only generate about twice as many intermediate solutions as mine does for large lists, so the space used doesn't seem to be an issue. However the FrobeniusSolve is much slower than my solution for some reason, taking about 50 times as long. Also while mine works with zeros, FrobeniusSolve will bail if any of the elements are zero. – Mark Adler Nov 13 '16 at 18:19
  • Reduce is indeed much faster. It is now only 10-20 times slower than the direct approach. – Mark Adler Nov 14 '16 at 15:56
  • Also this one works with zeros and negative numbers. – Mark Adler Nov 14 '16 at 16:15
4
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.

Community
  • 1
corey979
  • 23,947
  • 7
  • 58
  • 101
0

The previous answers suggested the following:

list={2,1,11,3,10,7,7,9,4};
n = 10;
m=Length[list];

Sort[(Times[Range[m],#)& /@ Select[FrobeniusSolve[list,n],Max[#]==1&]) /. {0->Nothing}]

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

Thanks.

Slightly shorter is

Sort[Pick[Range[m],#,1]& /@ Select[FrobeniusSolve[list,n],Max[#]==1&]]
urgrue
  • 63
  • 5