# Divide a list into two lists with equal sums

I have a list with L elements. I want to find an index within the list, that divides the list to two separate lists so the sum of elements in each of them are equal.

For example, in the list s = {3, 0, 2, 4, 5} it is the 4th element:

Total[{3, 0, 2, 4}] == Total[{4, 5}]


I tried

Solve[Total[s[[1 ;; x]]] == Total[s[[x ;; -1]]], x]


but it fails with

Solve::nsmet: This system cannot be solved with the methods available to Solve.

• What do you mean by "summary"? – Szabolcs Mar 19 at 15:29
• If you care about efficiency, i.e., your L might be high value, you could first use the fact that the desired sum is Total[aList]/2. Then create a loop that adds consecutive entries end stops when sum>desiredSum, the loop index would be your desired index. This would also work when your problem does not have one and precise solution, i.e., if you deal with real numbers. Anyhow, this is more algorithmic rather than Mathematica comment. – MK. Mar 20 at 10:39

a = {3, 0, 2, 4, 5};
Position[Abs[Accumulate[a] - Reverse[Accumulate[Reverse[a]]]], 0]


{{4}}

Of course, for general lists, there need not exist a solution to this problem. Also, it is possible that several indices solve the problem.

In order to obtain all indices that solve the problem best (the absolute distance of left and right sum is minimal), you may use

With[{b = Abs[Abs[Accumulate[a] - Reverse[Accumulate[Reverse[a]]]]]},
Position[b, Min[b]]
]

• Ordering[data, 1] finds the index of the smallest element – Szabolcs Mar 19 at 16:06
• @Szabolcs You see, I tried to ensure that all minima are returned, not only the first one. For example for b = {2, 2, 2}; compare Ordering[b, 1] vs. Position[b, Min[b]]. – Henrik Schumacher Mar 19 at 16:08

Accumulate[s] is a list of the possible sums of the first subset.
The $$i$$'th element of (Total[s] + s)/2. is half the sum of both subsets when splitting at position $$i$$.

One $$i$$ that makes them as close as possible can be found by:

s = {3, 0, 2, 4, 5};
Ordering[Abs[(Total[s] + s)/2. - Accumulate[s]], 1]
(* {4} *)


Nearest can be used to get all $$i$$s that minimize the difference:

s = {12, 2, 2, 2, 12, 2};
Nearest[Abs[(Total[s] + s)/2. - Accumulate[s]] -> "Index", 0]
(* {3, 4} *)


For a list of integers, it may be preferable to write Abs[Total[s] + s - 2 Accumulate[s]] where everything is multiplied by 2 which doesn't affect the ordering, and avoids the division.

A brute force approach:

Clear["Global*"]

s = {3, 0, 2, 4, 5};

Select[Range[2, Length[s] - 1],
Total[s[[;; #]]] == Total[s[[# ;;]]] &]

(* {4} *)
`