A better way of balancing a list in Haskell

Question

I'm learning Haskell by solving some online problems and training exercises.

Right now I'm trying to write a function that'd take a list and balance it like this

[2,3,2,3,2] ---> [[2,2,2], [3,3]]
[1,2,3,7,8] ---> [[1,2,7], [3,8]]
[1,2,9,10] ---> [[2,9],[1,10]]
[1,1,1,1,1,2,3] ---> [[1,1,1,1,1],[2,3]]

(always in two parts, either works in the case of 2nd)

---

The way I thought of doing this was by using Permutation function from base Data.List

and filtering out valid lists with a function like this

sumCheck x
  | sum (take (length x `div` 2) x) == sum (drop (length x `div` 2) x) = True
  | otherwise = False

if the length of the list is even. If not then a recursive function that'd

(take y x) (drop (y - (y - 0)) x)
(take (y - 1) x) (drop (y - (y - 1)) x) 

and so on.

or by just partitioning them like this

parts :: [a] -> [([a], [a])]
parts [] = [([], [])]
parts (x : xs) = let pts = parts xs in
    [(x : ys, zs) | (ys, zs) <- pts] ++ [(ys, x : zs) | (ys, zs) <- pts]

then checking the balance by

checkBal (xs, ys) = abs (sum xs - sum ys)

and sorting in ascending order, where the first one would be most balanced.

---

Now this works well for smaller lists but as you might have guessed, for large lists, it just keeps on processing.

I think binPack could help with this but I rather not use external packages and try to do it on my own. (with some help ofc!)

Answer 1

This is kind of a fun algorithm problem. I encourage you to keep thinking about it on your own; severe spoilers below.

Here's my plan: I'm going to compute all the possible sums of subsets, together with (just one) witness of who's in and who's out to achieve that sum. Then we'll just check which possible sum is closest to half the entire list's sum. So:

import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M

type Sums a = Map a ([a], [a])

update :: (Num a, Ord a) => a -> Sums a -> Sums a
update n sums = M.union
    (                          (\(i, o) -> (i, n:o)) <$> sums)
    (M.mapKeysMonotonic (n+) $ (\(i, o) -> (n:i, o)) <$> sums)

computeSums :: (Num a, Ord a) => [a] -> Sums a
computeSums = foldr update (M.singleton 0 ([], []))

balance :: (Integral a, Ord a) => [a] -> ([a], [a])
balance xs = snd . fromJust $ M.lookupLE (sum xs `div` 2) (computeSums xs)

Trying it out:

> mapM_ (\xs -> putStrLn $ show xs ++ " ---> " ++ show (balance xs)) [[2,3,2,3,2],[1,2,3,7,8],[1,2,9,10],[1,1,1,1,1,2,3]]
[2,3,2,3,2] ---> ([3,3],[2,2,2])
[1,2,3,7,8] ---> ([3,7],[1,2,8])
[1,2,9,10] ---> ([2,9],[1,10])
[1,1,1,1,1,2,3] ---> ([2,3],[1,1,1,1,1])

It also terminates relatively quickly on large lists:

> :set +s
> (\(a,b) -> (sum a, sum b)) . balance $ replicate 1001 1
(500,501)
(0.12 secs, 156,255,000 bytes)
> (\(a,b) -> (sum a, sum b)) . balance $ [1..200]
(10050,10050)
(1.25 secs, 752,015,256 bytes)
> (\(a,b) -> (sum a, sum b)) . balance $ take 20 (iterate (2*) 1)
(524287,524288)
(0.92 secs, 532,754,784 bytes)

This last example exercises the exponential worst-case behavior of this algorithm (since every subset of the powers of two gives a different sum).