问Haskell中的平衡分区

EN

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

unbalance :: Num a => ([a], [a]) -> a
unbalance (ys, zs) = abs (sum ys - sum zs)

balancedPartition :: (Num a, Ord a) => [a] -> ([a], [a])
balancedPartition = minimumBy (comparing unbalance) . partitions

module Balance where

import Data.List(minimumBy)
import Data.Ord(comparing)

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

unbalance :: Num a => ([a], [a]) -> a
unbalance (ys, zs) = abs (sum ys - sum zs)

balancedPartition :: (Num a, Ord a) => [a] -> ([a], [a])
balancedPartition = minimumBy (comparing unbalance) . partitions

balancedPartition :: (Num a, Ord a) => [a] -> ([a], [a])
balancedPartition = snd . head . partitionsByBadness . sort
  where
    -- recursively builds a list of possible partitionings and their badness
    -- sorted by their (increasing) badness
    partitionsByBadness []     = [(0, ([], []))]
    partitionsByBadness (x:xs) = let res = partitionsByBadness xs
                                     withX = map (      (+x) *** first  (x:)) res
                                     sansX = map (subtract x *** second (x:)) res
                                 in merge withX $ normalize sansX

    -- When items are added to the second list, the difference between the sums
    -- decreases - and might become negative
    -- We take those cases and swap the lists, so that the first list has always
    -- a greater sum and the difference is always positive
    -- So that we can sort the list again (with linear complexity)
    normalize xs = let (neg, pos) = span ((<0) . fst) xs
                   in merge pos $ reverse $ map (negate *** swap) neg

-- merge two sorted lists (as known from mergesort, but
-- omits "duplicates" with same badness)
merge :: Ord k => [(k, v)] -> [(k, v)] -> [(k, v)]
merge []         zss        = zss
merge yss        []         = yss
merge yss@(y:ys) zss@(z:zs) = case comparing fst y z of
                                LT -> y : merge ys zss
                                EQ -> merge ys zss
                                GT -> z : merge yss zs

% stack ghci --package Binpack
λ: import Data.BinPack
λ: let bins numberOfBins items = let totalSize = sum items; binSize = succ (totalSize `div` (max 1 numberOfBins)) in binpack WorstFit Decreasing id (replicate numberOfBins (emptyBin binSize)) items
λ: bins 2 [1,3,4,6,9]
([(0,[3,9]),(1,[1,4,6])],[])

λ: map snd . fst . bins 2 $ [1,3,4,6,9]
[[3,9],[1,4,6]]