15
$\begingroup$

Given the following data:

constraints = {{11, 2}, {11, 3}, {11, 4}, {11, 6}, {11, 9}, {1, 6}, {5, 6}, {2, 5}};

weights = {3, 7, 3, 2, 4, 2, 2, 2, 3, 2, 1};

I wish to partition the integers from 1 to 11 into subsets such that:

  • each integer from 1 to 11 appears exactly once
  • the sum of weights[[s]] for each subset s is 7, 8 or 9
  • no subset contains any of the constraints pairs.

For clarity here is an example of such a solution:

example = {{1, 3, 4}, {2}, {5, 10, 11}, {6, 7, 8, 9}};

(* check 1 *)
Sort @ Flatten @ example == Range[11]
(* True *)

(* check 2 *)
AllTrue[example, 7 <= Total[weights[[#]]] <= 9 &]
(* True *)

(* check 3*)
Nor @@ SubsetQ @@@ Tuples[{example, constraints}]
(* True *)

How can I find all such solutions?

$\endgroup$
8
$\begingroup$

One can do it in five lines of code and ~0.02 seconds:

n = 11;
w = 7 | 8 | 9;

parts = Pick[#, #.weights Product[1 - Times@@Transpose@#[[;;,c]], {c, constraints}], w] &@
   Tuples[{0, 1}, n];
cliques = FindClique[#, ∞, All] &@ AdjacencyGraph[1 - Unitize[parts.Transpose@parts]];
subsets = Pick[Range@n, #, 1] & /@ parts;
num = Length /@ subsets;
partitions = Map[subsets[[#]] &, #, {2}] &@Pick[cliques, Plus @@ num[[#]] & /@ cliques, n];
  1. Find all possible subsets whose weights sum to a value 7, 8 or 9. Tuples and binary notation (included/not included) helps a lot.

  2. Find non-intersectings pairs of subsets and make a corresponding adjacency graph. Then FindClique does the hardest part of the job: find all possible sets of non-intersected subsets.

  3. Transform binary notations to subsets.

  4. Calculate the number of elements in each subset.

  5. Find sets of subsets whose gives 11 elements in total.

The result is correct

And @@ ((Sort@Flatten@# == Range[11] && 
      AllTrue[#, 7 <= Total[weights[[#]]] <= 9 &] && 
      Nor @@ SubsetQ @@@ Tuples[{#, constraints}]) & /@ partitions)
(* True *)
$\endgroup$
  • $\begingroup$ This is fantastic. It'll take me a while to work through the code and understand the algorithm! The speed is remarkable, 4 times faster than a reworked version of Martin's code. Thanks very much. $\endgroup$ – Simon Woods Jan 16 '15 at 22:10
  • $\begingroup$ +1 Time form me to go study graph theory. $\endgroup$ – george2079 Jan 16 '15 at 22:14
5
$\begingroup$

I think there's no generally efficient way to do this, since you can always choose the constraints such that they don't restrict anything, in which case you want to find all possible subset partitions.

That being said, there's almost certainly a better approach than mine, but it works, and solves your example input in a second or so. Let's go:

constraints = {{11, 2}, {11, 3}, {11, 4}, {11, 6}, {11, 9}, {1, 6}, {5, 6}, {2, 5}};
weights = {3, 7, 3, 2, 4, 2, 2, 2, 3, 2, 1};

First we remove some unnecessary constraints (in this case, the last one is unnecessary, because the weights prohibit these two from appearing in the same set anyway):

constraints = Cases[constraints, l_List /; Total@weights[[l]] <= 9];

Now we get a list of all subsets of Range@11 which can potentially appear in the partition. That is, all subsets whose weights sum to a value between 7 and 9, and which don't contain one of the constraint pairs:

parts = Cases[
  Subsets@Range@11, 
  l_List /; 7 <= Total@weights[[l]] <= 9 && NoneTrue[constraints, SubsetQ[l, #] &]
]
Length @ parts (* 107 *)

So we've got 107 potential sublists for the partition. Now we just recursively piece them together into disjoint groups, and Sow the result whenever it contains all 11 numbers:

f[partition_, parts_] := Module[{newPartition},
  If[Length@Flatten@partition == 11,
   Sow@partition,
   If[parts != {},
     newPartition = Append[partition, parts[[1]]];
     (* Try adding the first part to the partition, and recursively
        call f with all remaining disjoint parts. *)
     f[newPartition, 
      Cases[Rest@parts, 
       l_List /; Intersection[l, Flatten@newPartition] == {}]];
     (* Try the next part instead. *)
     f[partition, Rest@parts]
     ];
   ]
  ]
solutions = Reap[f[{}, parts]][[2, 1]];
Length@solutions (* 210 *)

So we find 210 solutions (which contains your example solution, I checked). Now just to verify that all of these are valid:

And @@ ((Sort@Flatten@# == Range[11] &&
      AllTrue[#, 7 <= Total[weights[[#]]] <= 9 &] &&
      Nor @@ SubsetQ @@@ Tuples[{#, constraints}]) & /@ solutions)
(* True *)
$\endgroup$
  • $\begingroup$ This is great, thanks. Just the sort of thing I was hoping for. It seems a fraction quicker if we sort the parts to put the longest ones first: parts = Reverse@SortBy[parts, Length] - I think this reduces the number of calls to f. There is also a slight gain from using Select instead of Cases in f. $\endgroup$ – Simon Woods Jan 16 '15 at 19:53
  • $\begingroup$ @SimonWoods Ah yes, I was actually considering, to sort by length, but forgot before posting. Also, I keep forgetting about Select being a much nicer alternative to Cases if I'm not actually trying to match a pattern. $\endgroup$ – Martin Ender Jan 16 '15 at 20:02
1
$\begingroup$

Edit - oops I see this is conceptually the same as Martin's..

A little different brute force approach: start by finding all subsets that meet the restrictions:

 constraints = {{11, 2}, {11, 3}, {11, 4}, {11, 6}, {11, 9}, {1, 6}, {5, 6}, {2, 5}};
 weights = {3, 7, 3, 2, 4, 2, 2, 2, 3, 2, 1};
 subsets =      Select[ Subsets[Range[11], 5] , 7 <= Total[weights[[#]]] <= 9 && 
     Function[ {set}, 
          And @@ ( (( Length@Intersection[ set  , # ] != 2 ) & /@ 
                         constraints)) ]@#  & ] 

this is obviously very specialized to the particular problem, but this all runs in seconds.

{{2}, {1, 5}, {2, 4}, {2, 6}, {2, 7}, {2, 8}, {2, 10}, ... {6, 8, 9, 10}, {7, 8, 9, 10}, {7, 8, 10, 11}}

 Length@subsets (* 107 *)

arbitrarily pick all the subsets with a 2..

 sets = {#} & /@ Select[ subsets, MemberQ[#, 2] & ];

{{{2}}, {{2, 4}}, {{2, 6}}, {{2, 7}}, {{2, 8}}, {{2, 10}}}

recursively add to each set any set with no overlap..

 result = Sort /@ 
     First@Last@
       Reap[Do[ 
          sets = Flatten[  (  
              Function[{s}, If[Sort[Flatten[s]] == Range[11], Sow[s]];            
                Append[s, #] & /@ (Select[ subsets  , 
                  Intersection[ # , Flatten@s ] == {} & ])]) /@ sets , 1] ,
                          {5}]] // Union ;

>

  Length@result

210

  result[[1 ;; ;; 10]] // MatrixForm

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.