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.