# How to partition a list of numbers in two lists of numbers such that each lists elements sums up to the same number?

I have the following list of squares.

{1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256}


Their sum is $1496$, I want to make two partitions with the given numbers and each partition should have a sum of $748$, does Mathematica have a built-in function for that?

-
Just for the counting of possible solutions, is the order of the two partitions important or not? –  Yves Klett Oct 29 '13 at 8:03

Can be done with a bit of programming. Below I also enforce that exactly half the values be used in each subset. I show one subset in the result and obviously its complement would be the companion subset.

vals = Range[16]^2;
vars = Array[x, Length[vals]];
c1 = Map[0 <= # <= 1 &, vars];
c2 = Total[vars] == 8;
c3 = 2*vars.vals == Total[vals];
DeleteCases[(vars*vals) /.
First[FindInstance[Flatten[{c1, c2, c3}], vars, Integers]], 0]


--- Edit ---

There are other solutions in this case. Can find them all using Reduce.

DeleteCases[(vars*vals) /. {ToRules[
Reduce[Flatten[{c1, c2, c3}], vars, Integers]]}, 0, {2}]

(* {{16, 25, 36, 81, 100, 121, 144, 225}, {9, 36, 49, 64, 100,
121, 144, 225}, {9, 36, 49, 64, 81, 144, 169, 196}, {9, 25, 36, 49,
64, 144, 196, 225}, {9, 16, 36, 64, 81, 121, 196, 225}, {9, 16, 36,
49, 100, 144, 169, 225}, {9, 16, 25, 36, 81, 100, 225, 256}, {4, 25,
49, 64, 81, 100, 169, 256}, {4, 25, 36, 64, 81, 144, 169, 225}, {4,
16, 49, 64, 100, 121, 169, 225}, {4, 16, 25, 49, 81, 121, 196,
256}, {4, 16, 25, 49, 64, 169, 196, 225}, {4, 9, 64, 81, 100, 121,
144, 225}, {4, 9, 36, 49, 81, 144, 169, 256}, {4, 9, 25, 64, 100,
121, 169, 256}, {4, 9, 25, 64, 81, 144, 196, 225}, {4, 9, 25, 36,
49, 144, 225, 256}, {4, 9, 16, 81, 100, 144, 169, 225}, {4, 9, 16,
36, 81, 121, 225, 256}, {1, 25, 49, 64, 100, 144, 169, 196}, {1, 25,
36, 49, 64, 121, 196, 256}, {1, 16, 64, 81, 100, 121, 169,
196}, {1, 16, 36, 49, 100, 121, 169, 256}, {1, 16, 36, 49, 81, 144,
196, 225}, {1, 16, 25, 64, 100, 121, 196, 225}, {1, 16, 25, 36, 49,
169, 196, 256}, {1, 9, 36, 81, 100, 121, 144, 256}, {1, 9, 36, 64,
100, 144, 169, 225}, {1, 9, 25, 36, 81, 144, 196, 256}, {1, 9, 16,
49, 100, 121, 196, 256}, {1, 9, 16, 36, 121, 144, 196, 225}, {1, 4,
49, 64, 121, 144, 169, 196}, {1, 4, 25, 64, 81, 121, 196, 256}, {1,
4, 25, 49, 100, 144, 169, 256}, {1, 4, 16, 81, 100, 121, 169,
256}, {1, 4, 16, 25, 100, 121, 225, 256}, {1, 4, 16, 25, 81, 169,
196, 256}, {1, 4, 9, 49, 64, 169, 196, 256}} *)


--- Edit #2 ---

Here is a method that is somewhat generating function related, but unfortunately it is not very efficient. The idea is to expand a certain multinomial to its 7th power, making sure to get no nontrivial powers of factors (as that would correspond to repeated use of elements from our list). We also repress powers that exceed our goal sum.

tv = Total[vars*t^(Range[16]^2)]

(*
t x[1] + t^4 x[2] + t^9 x[3] + t^16 x[4] + t^25 x[5] + t^36 x[6] +
t^49 x[7] + t^64 x[8] + t^81 x[9] + t^100 x[10] + t^121 x[11] +
t^144 x[12] + t^169 x[13] + t^196 x[14] + t^225 x[15] + t^256 x[16] *)

Timing[
expanded =
Nest[Expand[#*tv] /. {x[_]^n_ :> 0,
t^m_ /; m > (Total[vals]/2) :> 0} &, tv, 7];]

(* {2.990000, Null} *)

Coefficient[expanded, t^(Total[vals]/2)]

(*
40320 x[1] x[4] x[8] x[9] x[10] x[11] x[13] x[14] +
40320 x[3] x[6] x[7] x[8] x[9] x[12] x[13] x[14] +
40320 x[1] x[5] x[7] x[8] x[10] x[12] x[13] x[14] +
40320 x[1] x[2] x[7] x[8] x[11] x[12] x[13] x[14] +
40320 x[3] x[6] x[7] x[8] x[10] x[11] x[12] x[15] +
40320 x[4] x[5] x[6] x[9] x[10] x[11] x[12] x[15] +
40320 x[2] x[3] x[8] x[9] x[10] x[11] x[12] x[15] +
40320 x[2] x[4] x[7] x[8] x[10] x[11] x[13] x[15] +
40320 x[2] x[5] x[6] x[8] x[9] x[12] x[13] x[15] +
40320 x[3] x[4] x[6] x[7] x[10] x[12] x[13] x[15] +
40320 x[1] x[3] x[6] x[8] x[10] x[12] x[13] x[15] +
40320 x[2] x[3] x[4] x[9] x[10] x[12] x[13] x[15] +
40320 x[3] x[4] x[6] x[8] x[9] x[11] x[14] x[15] +
40320 x[1] x[4] x[5] x[8] x[10] x[11] x[14] x[15] +
40320 x[3] x[5] x[6] x[7] x[8] x[12] x[14] x[15] +
40320 x[1] x[4] x[6] x[7] x[9] x[12] x[14] x[15] +
40320 x[2] x[3] x[5] x[8] x[9] x[12] x[14] x[15] +
40320 x[1] x[3] x[4] x[6] x[11] x[12] x[14] x[15] +
40320 x[2] x[4] x[5] x[7] x[8] x[13] x[14] x[15] +
40320 x[1] x[3] x[6] x[9] x[10] x[11] x[12] x[16] +
40320 x[2] x[5] x[7] x[8] x[9] x[10] x[13] x[16] +
40320 x[1] x[4] x[6] x[7] x[10] x[11] x[13] x[16] +
40320 x[2] x[3] x[5] x[8] x[10] x[11] x[13] x[16] +
40320 x[1] x[2] x[4] x[9] x[10] x[11] x[13] x[16] +
40320 x[2] x[3] x[6] x[7] x[9] x[12] x[13] x[16] +
40320 x[1] x[2] x[5] x[7] x[10] x[12] x[13] x[16] +
40320 x[1] x[5] x[6] x[7] x[8] x[11] x[14] x[16] +
40320 x[2] x[4] x[5] x[7] x[9] x[11] x[14] x[16] +
40320 x[1] x[2] x[5] x[8] x[9] x[11] x[14] x[16] +
40320 x[1] x[3] x[4] x[7] x[10] x[11] x[14] x[16] +
40320 x[1] x[3] x[5] x[6] x[9] x[12] x[14] x[16] +
40320 x[1] x[4] x[5] x[6] x[7] x[13] x[14] x[16] +
40320 x[1] x[2] x[3] x[7] x[8] x[13] x[14] x[16] +
40320 x[1] x[2] x[4] x[5] x[9] x[13] x[14] x[16] +
40320 x[3] x[4] x[5] x[6] x[9] x[10] x[15] x[16] +
40320 x[2] x[3] x[4] x[6] x[9] x[11] x[15] x[16] +
40320 x[1] x[2] x[4] x[5] x[10] x[11] x[15] x[16] +
40320 x[2] x[3] x[5] x[6] x[7] x[12] x[15] x[16] *)


What would be nice is to have a more sensible way of doing this. By sensible I mean something that extracts a coefficient but does not have to work so hard to repress unwanted terms in a polynomial or series expansion.

-
@Daniel_Lichtblau can you add a version that uses Reduce ? –  PlaysDice Oct 28 '13 at 15:29
@Yves Klett Unfortunately I do not know how to count the number of solutions without generating all of them. There may be a generating function method but, if so, I'm not seeing it at the moment. –  Daniel Lichtblau Oct 28 '13 at 15:38
@DanielLichtblau not to worry, but man am I happy my results concur with yours (for the record, in a deleted comment I asked about counting the number of possible combinations). –  Yves Klett Oct 28 '13 at 15:41
You imposed the unnecessary constraint that there would be equal numbers of digits in each subset of the partition. (I made the same mistake in my first two attempts.) Consequently, you only found 38 partitions. Your assumption caused you to miss 19 partitions in which the subsets were of differing lengths: e.g. {{1, 16, 81, 169, 225, 256}, {4, 9, 25, 36, 49, 64, 100, 121, 144, 196}}. –  David Carraher Oct 28 '13 at 20:35
@David Carraher Actually I stated that rather explicitly. Removing it is not difficult, just get rid of c2 in the constraint list. One could modify the other approach by using NestList and keeping lower powers. –  Daniel Lichtblau Oct 28 '13 at 21:39

An easy way, using PowersRepresentations[]:

$PowersRepresentations[n,k,p]$ gives the distinct representations of the integer n as a sum of k non-negative p^th integer powers.

s1 = Join@@ (Select[PowersRepresentations[748,#,2], # ⋂ Range@16 == # &] & /@ Range@8)


Gives all possible ways to total 748.

For filtering the ones that are complementaries:

s = Tally[s1, Union[#1, #2] == Range@16 &][[All, 1]];
Length@s
(*
57
*)

-
Thanks to Halirutan and ssch for the beautiful [Intersection] symbol –  belisarius Oct 29 '13 at 22:40

According to Wikipedia this simple algorithm often works (it only generates a single solution, as is how I interpreted the needs of the OP).

set = Reverse@Sort[{1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256}];
listA = {};
listB = {};
Do[
If[Total[listA] < Total[listB],
AppendTo[listA, i],
AppendTo[listB, i]],
{i, set}
]

{Total[listA], Total[listB]}


{748, 748}

It's iterating through each element and appends it to whatever list has the smallest sum. It's important that the set is in descending order, which is why I put Reverse@Sort in there, even if Sort isn't technically needed for this specific set.

-
Maybe Scan[If[Total[listA] < Total[listB], listA = Flatten[{listA, #}], listB = Flatten[{listB, #}]] &, set] in preference to Do –  Mike Honeychurch Oct 28 '13 at 23:18
@MikeHoneychurch Yes, that's a bit better; we could also keep the linked lists as linked lists and write Total[listA, Infinity]. –  Pickett Oct 29 '13 at 5:03
I dont know what counts as "often" but this is pretty easy to break. eg {16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256} –  george2079 Oct 29 '13 at 17:09
@george2079 Technically it says "This works well when the numbers in the set are of about the same size as its cardinality or less." which I paraphrased. It's so quick, you can try this first and then try more expensive algorithms. –  Pickett Oct 29 '13 at 17:39

This is a small version of a PE problem which asks for counts of certain solutions. If the OP is interested, there is a generating function approach to finding such counts. Consider the product of binomial terms where the power of z is the sequence of squares defined in the problem statement.

Expand[Product[(1 + z^k), {k, Range[16]^2}]]


The coefficient of $z^{748}$ gives the number of ways of writing 748 as a sum of squares from the list of the first 16 squares. The following use ofCoefficientshows there are 114 ways.

Coefficient[Expand[Product[(1 + z^k), {k, Range[16]^2}]], z, 748]


The number of squares m summed for any particular representation of 748 is given by incorporating an additional parameter t. The exponent of t in the coefficient of $z^{748}$ in the following expansion gives the number of squares m.

Coefficient[Expand[Product[(1 + t*z^k), {k, Range[16]^2}]], z, 748]
(* 10 t^6 + 28 t^7 + 38 t^8 + 28 t^9 + 10 t^10 *)


The result shows there must be from m=6 to m=10 squares summed to represent 748, and the number of ways for each m is given by the corresponding coefficient.

The challenge becomes to find such counts when there are 100 rather than simply 16 squares in the original set. Enumerating the partitions is doomed, even expanding the generating function may exceed memory limits. The trick is for the OP, if pursuing PE solutions, to find a recursive method of constructing only the "interesting" part of the generating function.

-
I knew there was a sensible way to use a generating function. Kinda' bothers me that I've done problems like this before and still could not work out the right formulation. –  Daniel Lichtblau Oct 29 '13 at 20:33
@DanielLichtblau Yes maybe, but when I get stuck on something, I look to your answers here, and usually find a way forward. Thanks for your continued participation! –  KennyColnago Oct 30 '13 at 0:22

The following will produce all 114 subsets that total 748. Note: Only 38 of these are of length 8.

d = Table[j^2, {j, 16}];
s=Select[Subsets[d], Total[#] == 748 &];
Length[%]


114

Clearly, the complement of each of these with d, the full set, will return the partitions we seek. We then use Sort and Union to eliminate duplicates, partitions with the elements in both orders.

This results in 57 partitions.

Union[Sort /@ ({#, Complement[d, #]} & /@ s)];
Length[%]


57

-

I am not aware of an inbuilt function. The following is a brute-force ugly (which I am sure will be put to shame shortly, by some number theory wizardry):

l={1, 4, 9, 16, 25, 36, 49, 64, 81, 100, 121, 144, 169, 196, 225, 256};

hits = Select[Subsets[l], Plus @@ # == Plus @@ l/2 &]

{#, Complement[l, #]} & /@ hits


which will run into a lot of trouble for larger lists, but works for your example. There seem to be 114 ways to partition your lists (or half that number, if ordering is not considered).

Finding partitions of equal (or arbitrary) length is very easy using the second argument of Subsets:

hits = Select[Subsets[l, {8}], Plus @@ # == Plus @@ l/2 &]


which reduces the number of combinations to 38 (19).

-
Small improvement you can sort the list and easily precompute the max and min possible lengths, then supply those bounds to Subsets[]. Might speed things up a tad. Also select can take an additional arg if you want it to find only the first match for example. –  george2079 Oct 28 '13 at 15:54
With[{sum = Total[#]/2, len = Length[#]},
Reap@Do[If[(#.i == sum), Sow[{Pick[#, i, 1], Pick[#, i, 0]}]],
{i, Tuples[{0, 1}, {len}][[;; 2^(len - 1)]]}]
] &[list]

-
Your procedure produces duplicate answers. –  David Carraher Oct 28 '13 at 21:07
@DavidCarraher I'm aware of that, I've said so in the first line :). I will correct this. –  Kuba Oct 28 '13 at 21:14
@DavidCarraher ok, corrected :) –  Kuba Oct 28 '13 at 21:27

This is my attempt on solving this (I hope I did not over read something).

I wrote a function SymmetricPartitionSum which takes a list and a goal, where the list has the constraint to be of even length.

SymmetricPartitionSum[list_ /; EvenQ[Length[list]], goal_] :=
Select[Subsets[list, {Length[list]/2}], Total[#] == goal &]


Since your list seems to be the squares: $a(n)=a^2$ you can use this such as:

SymmetricPartitionSum[Table[n^2,{n,1,18}], 751]

=> {{1,4,9,16,25,64,144,196,256},{1,4,9,16,25,81,121,169,289},
{1,4,9,16,36,64,100,196,289},{1,4,9,16,36,81,100,144,324}, ... }


Which you can reuse using Subset to pair the results and pick your favourite.

It would be nice, if Mathematica would provide a Partition definition, which takes a partition criteria as an argument. Which could be a lambda (or a regular function).

With this you can formulate questions like: give me all the partitions of this list of length n, where the partition's point constraint is of following definition...

-

Here's another approach. It uses a recursive subroutine that, given a list of positive integers, finds all the subsets with a given sum. [EDIT - This is a slightly faster version.]

f[y_,t_] := Block[{F},
F[j_,s_] := If[j == 1, If[ y[[1]] == s, {1},{} ],
Switch[Sign[y[[j]] - s],
1,     F[j-1,s]*2,
0,Join[F[j-1,s]*2, {1}],
_,Join[F[j-1,s]*2,
F[j-1,s-y[[j]]]*2 + 1] ] ];
F[Length@y,t] ]

a = f[x = {1,3,5,4,2}, 7]
(* {10, 5, 19} *)

b = IntegerDigits[a, 2, Length@x]
(* {{0,1,0,1,0}, {0,0,1,0,1}, {1,0,0,1,1}} *)

Pick[x,#,1]& /@ b
(* {{3,4}, {5,2}, {1,4,2}} *)


Now use f to find all the partitions of xx into two sublists with the same sum, taking advantage of the symmetry of the problem by getting only the sublists that contain the last element of xx.

t = Tr[ xx = Range[16]^2 ]
s = t/2 - Last@xx
m = MaxMemoryUsed[];

(* 1496 *)
(* 492 *)

AbsoluteTiming@Length[ yy =
Pick[xx,#,1]& /@ IntegerDigits[f[Most@xx,s]*2+1,2,Length@xx] ]
Union[Tr/@yy]*2
m = (Print[#-m];#)&@MaxMemoryUsed[];

(* {0.274014 Second, 57} *)
(* {1496} *)
(* 0 *)


For comparison, here's a faster solution that uses more memory.

AbsoluteTiming@Length[ zz =
Append[#,Last@xx]& /@ (Pick[#,Tr/@#,s]&) @ Subsets[Most@xx] ]
Union[Tr/@zz]*2
m = (Print[#-m];#)&@MaxMemoryUsed[];

(* {0.187110 Second, 57} *)
(* {1496} *)
(* 2985008 *)

zz == Sort@yy
(* True *)


With xx = Range[24]^2 there are 5419 equal-sum partitions; {time, memory} are
{62.63, 1589960} for yy vs {48.67, 1043591688} for zz.

-