How to find most complete partition of a list

Question

How to find most complete partition of a list?

For example:

list1={5,8}

list2={4,4,2,3,6}

8 can be comprised of {4,4} or {2,6}

But 5 can only be comprised of {2,3}

If I choose {2,6} for 8 , there is no combination for 5 in list2.

How can I get {4,4} for 8 and {2,3} for 5? Actually the numbers in list1 may be comprised of 3 or more numbers in list2.

How to write the code or design the algorithm?

The actual problem is more difficult, because may be there are some numbers not used in list1 and the numbers in lists are float.

Answer 1

Can be cast as a 0-1 integer linear programming problem e.g. as below.

list1 = {5, 8};
list2 = {4, 4, 2, 3, 6};
n = Length[list2];
vars = Array[c, {2, n}];
c1 = Map[0 <= # <= 1 &, vars];
c2 = Map[# <= 1 &, Total[vars]];
c3 = Thread[vars.list2 == list1];
constraints = Join[c1, c2, c3];
soln = Solve[constraints, Flatten[vars], Integers]

(* Out[141]= {{c[1, 1] -> 0, c[1, 2] -> 0, c[1, 3] -> 1, c[1, 4] -> 1, 
  c[1, 5] -> 0, c[2, 1] -> 1, c[2, 2] -> 1, c[2, 3] -> 0, 
  c[2, 4] -> 0, c[2, 5] -> 0}} *)

Package the result:

Map[list2*# &, (vars /. soln[[1]])] /. 0 -> Nothing

(* Out[142]= {{2, 3}, {4, 4}} *)

Answer 2

This response constructs a state space to represent the problem and then searches that space to find a solution. To skip the details, proceed directly to the section Putting It All Together at the bottom of this post.

States

We start by defining a state to be comprised of a result obtained thus far along with a description of the numbers we have available for partitioning. Since there might be duplicates among the available numbers, we keep a count of each:

initial[avail_] := <| "result" -> {}, "available" -> Counts[avail] |>

The initial state for list2 from the question looks like this:

list2

(* {4, 4, 2, 3, 6} *)

$state = initial[list2]

(* <|"result" -> {}, "available" -> <|4 -> 2, 2 -> 1, 3 -> 1, 6 -> 1|>|> *)

Updating A State

The heart of this implementation lies in the operation of updating a state to reflect the use of a partition:

update[state_][part_] :=
  Merge[{state["available"], Thread[part->-1] // Merge[Total]}, Total] /.
    { a_ /; AnyTrue[a, Negative] :> Nothing
    , a_ :> Query[{"result" -> Append[Total[part] -> part], "available" -> (a&)}][state]
    }

There are two possibilities. The numbers in a partition might be available, or they might not. In the former case, we obtain an updated state where the result includes the partition and the partition's numbers are no longer available. In the latter case, we have hit a dead end (represented by Nothing).

update[$state][{6, 2}]

(* <|"result" -> {8 -> {6, 2}}, "available" -> <|4 -> 2, 2 -> 0, 3 -> 1, 6 -> 0|>|> *)

update[$state][{5,3}]    

(* Nothing *)

Finding Successor States

We will define the notion of expanding a state to mean computing the set of successor states that result from updating the first state by each of a possible set of partitions:

expand[state_][parts_] := Prepend[update[state] /@ parts, state]

If we expand list2 state using all of the integer partitions of 8, we obtain three successors.

expand[$state][IntegerPartitions[8]] // Column

(*
   <| "result -> {}, "available" -> <|4->2,2->1,3->1,6->1|>|>
   <| "result -> {8->{6,2}}, "available" -> <|4->2,2->0,3->1,6->0|>|>
   <| "result -> {8->{4,4}}, "available" -> <|4->0,2->1,3->1,6->1|>|>
*)

Note that we have arranged it so that a state itself is always one of its own successors. This allows the forthcoming search strategy to continue even if a particular partition is a dead end.

Since the expansion of a state is a set of states, the general expansion operation will need to take a set as input and produce a set as output:

expandAll[states_][parts_] := Join @@ Query[expand /@ states][parts] // DeleteDuplicates

So then:

expandAll[initial /@ {{8}, {4, 4}}][{{8}, {4, 4}}] // Column

(*
   <|"result" -> {}, "available" -> <|8 -> 1|>|>
   <|"result" -> {8 -> {8}}, "available" -> <|8 -> 0|>|>
   <|"result" -> {}, "available" -> <|4 -> 2|>|>
   <|"result" -> {8 -> {4, 4}}, "available" -> <|4 -> 0|>|>
*)

DeleteDuplicates is used to prune the search space.

Exploring the State Space

We are now in a position to generate all possibilities by starting from the initial state and applying the general expansion operation against all possible integer partitions of the target numbers:

possibilities[targets_, avail_] :=
  Fold[expandAll[#][#2] &, {initial[avail]}, IntegerPartitions /@ targets][[All, "result"]]

The Fold operation starts from a single point in the state space, and then expands the search frontier until all of the available partitions have been tried.

For list1 and list2:

possibilities[list1, list2] // Column

(*
   {}
   {8->{6,2}}
   {8->{4,4}}
   {5->{3,2}}
   {5->{3,2},8->{4,4}}
*)

We can extract the "maximal" solution from this list:

possibilities[list1, list2] // MaximalBy[Length] // First

(* {5 -> {3,2}, 8 -> {4,4}} *)

Scoring Solutions

In the general case, there are some subtleties as to what constitutes "maximal". Consider:

$solutions = possibilities[{5, 8},{3, 2, 4, 4, 5, 3, 7, 1}];
$solutions // Column

(*
   {}
   {8 -> {7, 1}}
   {8 -> {5, 3}}
   {8 -> {5, 2, 1}}
   {8 -> {4, 4}}
   {8 -> {4, 3, 1}}
   {8 -> {3, 3, 2}}
   {5 -> {5}}
   {5 -> {5}, 8 -> {7, 1}}
   {5 -> {5}, 8 -> {4, 4}}
   {5 -> {5}, 8 -> {4, 3, 1}}
   {5 -> {5}, 8 -> {3, 3, 2}}
   {5 -> {4, 1}}
   {5 -> {4, 1}, 8 -> {5, 3}}
   {5 -> {4, 1}, 8 -> {3, 3, 2}}
   {5 -> {3, 2}}
   {5 -> {3, 2}, 8 -> {7, 1}}
   {5 -> {3, 2}, 8 -> {5, 3}}
   {5 -> {3, 2}, 8 -> {4, 4}}
   {5 -> {3, 2}, 8 -> {4, 3, 1}}
*)

There are numerous candidates for "maximal". The choice, of course, depends upon the final application. Here we define two scoring functions:

score[result_] := result // Query[{Length, Minus@*Total}, 2, Length]

score2[solution_] := solution // Query[{Length, Total}, 2, Length]

Both value the maximal number of target numbers. But in the event of multiple solutions having the same number of targets, the first values the smallest total number of partition values:

$solutions // MaximalBy[score] // Column

(* {5 -> {5}, 8 -> {7, 1}}
   {5 -> {5}, 8 -> {4, 4}} *)

By contrast, the second scoring function the second values the largest total number of partition values:

$solutions // MaximalBy[score2] // Column

(* {5 -> {4, 1}, 8 -> {3, 3, 2}}
   {5 -> {3, 2}, 8 -> {4, 3, 1}} *)

The scoring possibilities are endless and must be chosen in the context of the actual application.

Here is the final solve function, which uses the first scoring function:

solve[targets_, avail_] := possibilities[targets, avail] // MaximalBy[score]

Scope

This solution could be improved in many ways. For example:

• We could reduce the number of calls to IntegerPartitions should there be duplicates among the target numbers.
• If we know that there will only every be one scoring function, it is possible that knowledge of that function could be baked into the expansion functions to prune unnecessary search paths.
• We could take greater measures to avoid the brute-force frontier expansion approach taken here.

Such improvements are out of scope for the present response. They might not even be necessary depending upon the actual problem size. The goal here has been to describe a framework that could be customized for the actual application.

Putting It All Together

initial[avail_] := <| "result" -> {}, "available" -> Counts[avail] |>

update[state_][part_] :=
  Merge[{state["available"], Thread[part->-1] // Merge[Total]}, Total] /.
    { a_ /; AnyTrue[a, Negative] :> Nothing
    , a_ :> Query[{"result" -> Append[Total[part] -> part], "available" -> (a&)}][state]
    }

expand[state_][parts_] := Prepend[update[state] /@ parts, state]

expandAll[states_][parts_] := Join @@ Query[expand /@ states][parts] // DeleteDuplicates

possibilities[targets_, avail_] :=
  Fold[expandAll[#][#2] &, {initial[avail]}, IntegerPartitions /@ targets][[All, "result"]]

score[result_] := result // Query[{Length, Minus@*Total}, 2, Length]

solve[targets_, avail_] := possibilities[targets, avail] // MaximalBy[score]

So then:

solve[list1, list2] // First

(* {5 -> {3, 2}, 8 -> {4, 4}} *)

Answer 3

ClearAll@completePartitions;
completePartitions[list1_, list2_] := 
Module[{permute, possibleCombinations,
flattenedComb, func, listinplace = list1, pick},

permute = Subsets[list1, All];
possibleCombinations = Map[# -> GroupBy[permute, Total][#] &, list2];
flattenedComb = Flatten@Map[Thread, possibleCombinations];

SetAttributes[func, HoldFirst];
func[list_][int_] := Module[{member, pos},
member = And @@ Map[MemberQ[list, #] &, int];

Which[member == True && (First@int != Last@int),
 (pos = First /@ Map[Position[list, #] &, int];
  list = Delete[list, pos]; member),
 member == True,
 (pos = Take[Position[list, First@int], 2];
  list = Delete[list, pos]; member),
 member == False, member]
];

pick = Map[func[listinplace][#] &, Values@flattenedComb];
GroupBy[Pick[flattenedComb, pick, True], Keys -> Values]
]

using the above function

completePartitions[{4, 4, 2, 3, 6}, {5, 8}]
(* <|5 -> {{2, 3}}, 8 -> {{4, 4}}|> *)

now if we reverse the second list

completePartitions[{4, 4, 2, 3, 6}, {8, 5}]
(* <|8 -> {{4, 4}, {2, 6}}|> *)

now with a bigger list:

completePartitions[{4, 4, 4, 4, 2, 2, 2, 3, 3, 2, 3, 2, 3, 2, 6, 6}, {5, 6, 8}]
(* <|5 -> {{2, 3}, {2, 3}, {2, 3}, {2, 3}}, 6 -> {{6}, {4, 2}, {4, 2}}, 
8 -> {{4, 4}}|> *)