Find sub-sets of vanishing additions or subtractions from a list?

Question

Let's say I have a list L containing n numerical numbers. Now I want to find all sub-sets of m < n different elements out of L such that at least one combination of summing or subtracting those m elements with each other gives zero to numerical precision. Is it possible to do that in Mathematica in a convenient way? Thanks for any suggestion!

Answer 1

Solution

Suppose the list is

list = Range[-3, 3]
(* {-3, -2, -1, 0, 1, 2, -3} *)

Then, the set of all subsets of, say, size 3 is

sets = Subsets[list, {3}];

We define a list of signs that give all possible combinations of plusses and minuses to attach to each subset:

signs = Tuples[{-1, 1}, 3]
(* {{-1, -1, -1}, {-1, -1, 1}, {-1, 1, -1}, {-1, 1, 1}
    , {1, -1, -1}, {1, -1, 1}, {1, 1, -1}, {1, 1, 1}} *)

Then, we want to select from the list sets the subsets that will be zero when dotted with at least one of the elements of signs. To make this happen, we will use Select, which takes as a second argument an expression that will accept an element a of sets as an input and output True if a Dotted with one of the elements of sign is zero and False otherwise. Select then keeps the ones that evaluate to True. The expression

Select[sets, (Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &]

results in

(* {{-3, -2, -1}, {-3, -2, 1}, {-3, -1, 2}, {-3, 0, 3}
    , {-3, 1, 2}, {-2, -1, 1}, {-2, -1, 3}, {-2, 0, 2}
    , {-2, 1, 3}, {-1, 0, 1}, {-1, 1, 2}, {-1, 2, 3}, {1, 2, 3}}  *)

Explanation

Let's pick the condition function apart. First,

Function[{x}, 0 == Dot[a, x]]

is a function that accepts an input x (which will be from signs), Dots it with a (which will be an element of sets) and compares it to 0, yielding True if it is equal to 0. For instance,

Function[{x}, 0 == Dot[{-1, 0, 1}, x]][{1, -1, 1}]

will yield True while

Function[{x}, 0 == Dot[{-1, 0, 1}, x]][{-1, -1, 1}]

will yield False. Then, for a particular a from sets, we Map this function over signs to yield all the possible comparisons:

Function[{x}, 0 == Dot[{-1, 0, 1}, x]] /@ signs
(* {True, False, True, False, False, True, False, True} *)

Finally, we Apply Or to this list to see if it at least one of the elements is True:

Or @@ Function[{x}, 0 == Dot[{-1, 0, 1}, x]] /@ signs
(* True *)

Finally, in order to make this work as the second argument of Select, we have to turn it into a function that will accept an element of sets as an input. Thus:

(Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &

This turns the expression into a pure function whose input goes where the # is. For instance, we can see that

(Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) & [{-1, 0, 1}]

is the same as what we just did in parts above. Since Select will go one-by-one through the list sets, we get to just call

Select[sets, (Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &]

Automate over all subset lengths

Finally, we can do this for every subset length (although, of course, this problem grows really fast, so user beware) as follows. We will do, as an example,

list = Range[-2, 2]
(* {-2, -1, 0, 1, 2} *)

Then,

Table[
 Select[
  Subsets[list, {m}]
  , (Or @@ Function[{x}, 0 == Dot[#, x]] /@ Tuples[{-1, 1}, {m}]) &
 ]
, {m, 1, Length@list}]

yielding

{
 {{0}}
 , {{-2, 2}, {-1, 1}}
 , {{-2, -1, 1}, {-2, 0, 2}, {-1, 0, 1}, {-1, 1, 2}}
 , {{-2, -1, 0, 1}, {-2, -1, 1, 2}, {-1, 0, 1, 2}}
 , {{-2, -1, 0, 1, 2}}
}

Answer 2

I'm not thrilled with the question since it provided no example, but there was a serious response and also a request to see an ILP approach. Here is one such.

Start by creating an example.

SeedRandom[1111];
n = 10;
m = 4;
intset = RandomInteger[100, n]

(* Out[335]= {9, 78, 23, 59, 95, 51, 24, 29, 99, 68} *)

Now we set up the ILP. We have our n -1/0/1 variables as multipliers of the set elements, and variables denoting absolute values thereof (so must be greater-equal to the corresponding multipliers and their negatives). These absolute value variables must sum to m. To enforce that the absolute variables are never strictly larger than corresponding multipliers we use another pair of 0-1 variables, with sum not exceeding 1 for each pair. These get used in pairs of equations for each multiplier/absolute value pair. Details are left to the code below.

cvars = Array[c, n];
abscvars = Array[ac, n];
uvars = Array[u, n];
vvars = Array[v, n];
allvars = Join[cvars, abscvars, uvars, vvars];
c1 = Map[-1 <= # <= 1 &, cvars];
c2 = Map[0 <= # <= 1 &, abscvars];
c3 = MapThread[{#2 >= #1, #2 >= -#1} &, {cvars, abscvars}];
c4 = Total[abscvars] == m;
c5 = cvars.intset == 0;
c6 = Map[0 <= # <= 1 &, Join[uvars, vvars]];
c7 = MapThread[#1 + #2 <= 1 &, {uvars, vvars}];
c8 = MapThread[{#1 + #2 - 2*#3 == 0, #1 - #2 - 2*#4 == 
      0} &, {abscvars, cvars, uvars, vvars}];
constraints = 
  Flatten[{c1, c2, c3, c4, c5, c6, c7, c8, 
    Element[allvars, Integers]}];

Here we solve it and reform as subsets with negatives where indicated. I probably should have added some constraint to remove trivial duplicates (wherein one solution is the negative of another).

Map[intset*# &, (cvars /. Solve[constraints, allvars])] /. 
 0 :> Sequence[]

(* Out[350]= {{-78, 95, 51, -68}, {-95, 51, -24, 68}, {95, -51, 
  24, -68}, {78, -95, -51, 68}} *)

Here is a substantially larger example.

SeedRandom[1111];
n = 20;
m = 8;
intset = RandomInteger[1000, n]

(* Out[354]= {79, 679, 93, 887, 870, 398, 413, 796, 273, 288, 947, 708,
232, 488, 464, 760, 458, 482, 174, 502} *)

cvars = Array[c, n];
abscvars = Array[ac, n];
uvars = Array[u, n];
vvars = Array[v, n];
allvars = Join[cvars, abscvars, uvars, vvars];
c1 = Map[-1 <= # <= 1 &, cvars];
c2 = Map[0 <= # <= 1 &, abscvars];
c3 = MapThread[{#2 >= #1, #2 >= -#1} &, {cvars, abscvars}];
c4 = Total[abscvars] == m;
c5 = cvars.intset == 0;
c6 = Map[0 <= # <= 1 &, Join[uvars, vvars]];
c7 = MapThread[#1 + #2 <= 1 &, {uvars, vvars}];
c8 = MapThread[{#1 + #2 - 2*#3 == 0, #1 - #2 - 2*#4 == 
      0} &, {abscvars, cvars, uvars, vvars}];
constraints = 
  Flatten[{c1, c2, c3, c4, c5, c6, c7, c8, 
    Element[allvars, Integers]}];

Timing[subsets = 
   Map[intset*# &, (cvars /. Solve[constraints, allvars])] /. 
    0 :> Sequence[];]

Length[subsets]

(* Out[370]= {76.94338, Null}

Out[371]= 7952 *)

Here are the first few.

subsets[[1 ;; 5]]

(* {{-79, -679, -93, -887, 708, -232, 760, 
  502}, {-79, -679, -93, -887, 288, 232, 760, 
  458}, {-79, -679, -93, -887, 398, 708, 458, 
  174}, {-79, -679, -93, -870, -398, 947, 708, 
  464}, {-79, -679, -93, -870, 947, -488, 760, 502}} *)

At small risk for correctness this could be made faster by writing an explicit branch-and-prune loop, using approximate linear programming on the relaxed problems (built-in Solve code uses exact linear programming on those). Some idea of how such a loop might be done can be found here.