-- Copyright (c) 2009, Bjoern B. Brandenburg <bbb [at] cs.unc.edu> -- -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- * Neither the name of the copyright holder nor the names of any -- contributors may be used to endorse or promote products derived from -- this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE -- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. {- | This module implements a number of common bin packing heuristics: 'FirstFit', 'LastFit', 'BestFit', 'WorstFit', and 'AlmostWorstFit'. In addition, the not-so-common, but analytically superior (in terms of worst-case behavior), 'ModifiedFirstFit' heuristic is also supported. Items can be packed in order of both 'Decreasing' and 'Increasing' size (and, of course, in unmodified order; see 'AsGiven'). The module supports both the standard (textbook) minimization problem (/"How many bins do I need to pack all items?"/; see 'minimizeBins' and 'countBins') and the more practical fitting problem (/"I've got n bins; which items can I take?"/; see 'binpack'). The well-known heuristics are described online in many places and are not further discussed here. For example, see <http://www.cs.arizona.edu/icon/oddsends/bpack/bpack.htm> for an overview. A description of the 'ModifiedFirstFit' algorithm is harder to come by online, hence a brief description and references are provided below. Note that most published analysis assumes items to be sorted in some specific (mostly 'Decreasing') order. This module does not enforce such assumptions, rather, any ordering can be combined with any placement heuristic. If unsure what to pick, then try 'FirstFit' 'Decreasing' as a default. Use 'BestFit' (in combination with 'binpack') if you want your bins filled evenly. A short overview of the 'ModifiedFirstFit' heuristic follows. This overview is based on the description given in (Yue and Zhang, 1995). Let @lst@ denote the list of items to be bin-packed, let @x@ denote the size of the smallest element in @lst@, and let @cap@ denote the capacity of one bin. @lst@ is split into the four sub-lists, @lA@, @lB@, @lC@, @lD@. [@lA@] All items strictly larger than @cap\/2@. [@lB@] All items of size at most @cap\/2@ and strictly larger than @cap\/3@. [@lC@] All items of size at most @cap\/3@ and strictly larger than @(cap - x)\/5@. [@lD@] The rest, /i.e./, all items of size at most @(cap - x)\/5@. Items are placed as follows: (1) Create a list of @length lA@ bins. Place each item in @lA@ into its own bin (while maintaining relative item order with respect to @lst@). Note: relevant published analysis assumes that @lst@ is sorted in order of 'decreasing' size. (2) Take the list of bins created in Step 1 and reverse it. (3) Sequentially consider each bin @b@. If the two smallest items in @lC@ do NOT fit together into @b@ of if there a less than two items remaining in @lC@, then pack nothing into @b@ and move on to the next bin (if any). If they do fit together, then find the largest item @x1@ in @lC@ that would fit together with the smallest item in @lC@ into @b@. Remove @x1@ from @lC@. Then find the largest item @x2@, @x2 \\= x1@, in @lC@ that will now fit into @b@ /together/ with @x1@. Remove @x1@ from @lC@. Place both @x1@ and @x2@ into @b@ and move on to the next item. (4) Reverse the list of bins again. (5) Use the 'FirstFit' heuristic to place all remaining items, /i.e./, @lB@, @lD@, and any remaining items of @lC@. References: * D.S. Johnson and M.R. Garey. A 71/60 Theorem for Bin-Packing. /Journal of Complexity/, 1:65-106, 1985. * M. Yue and L. Zhang. A Simple Proof of the Inequality MFFD(L) <= 71/60 OPT(L) + 1, L for the MFFD Bin-Packing Algorithm. /Acta Mathematicae Applicatae Sinica/, 11(3):318-330, 1995. -} module Data.BinPack ( PlacementPolicy(..) , OrderPolicy (AsGiven, Increasing, Decreasing) , Measure , Bin , allOrders , allPlacements , allHeuristics , minimizeBins , countBins , binpack ) where import List (sortBy, sort, partition, findIndex, intersect {- testing only -}) import Control.Monad (replicateM) -- for debugging import Test.QuickCheck -- | How to pre-process the input. data OrderPolicy = AsGiven -- ^ Don't modify item order. | Decreasing -- ^ Sort from largest to smallest. | Increasing -- ^ Sort from smallest to largest. deriving (Show, Eq, Ord) -- | The list of all possible 'OrderPolicy' choices. Useful for benchmarking. allOrders :: [OrderPolicy] allOrders = [Decreasing, Increasing, AsGiven] instance Arbitrary OrderPolicy where arbitrary = elements allOrders -- | What placement heuristic should be used? data PlacementPolicy = FirstFit -- ^ Traverse bin list from 'head' to -- 'last' and place item in the first -- bin that has sufficient capacity. | ModifiedFirstFit -- ^ See above. | LastFit -- ^ Traverse bin list from 'last' to -- 'head' and place item in the first -- bin that has sufficient capacity. | BestFit -- ^ Place item in the bin with the -- most capacity. | WorstFit -- ^ Place item in the bin with the -- least (but sufficient) capacity. | AlmostWorstFit -- ^ Choose the 2nd to worst-fitting -- bin. deriving (Show, Eq, Ord) -- | The list of all possible 'PlacementPolicy' choices. Useful for benchmarking. allPlacements :: [PlacementPolicy] allPlacements = [FirstFit, ModifiedFirstFit, LastFit, BestFit, WorstFit, AlmostWorstFit] instance Arbitrary PlacementPolicy where arbitrary = elements allPlacements -- | All supported ordering and placment choices. Useful for benchmarking. allHeuristics :: [(PlacementPolicy, OrderPolicy)] allHeuristics = [(p, o) | p <- allPlacements, o <- allOrders] -- | A 'Bin' is a list of items. type Bin = [] -- | A function that maps an item @b@ to its size @a@. The constraint @('Num' -- a, 'Ord' a)@ has been omitted from the type, but is required by the exposed -- functions. type Measure a b = (b -> a) -- | Given a 'Measure', an item @b@, a list of capacities @[a]@, and a list of -- bins @['Bin' b]@, a placement heuristic returns @Just@ an updated lists of -- capacities and bins if the item could be placed, and @Nothing@ otherwise. type Placement a b = Measure a b -> b -> [a] -> [Bin b] -> Maybe ([a],[Bin b]) placement :: (Ord a, Num a) => PlacementPolicy -> Placement a b placement WorstFit = worstfit placement BestFit = bestfit placement FirstFit = firstfit placement LastFit = lastfit placement AlmostWorstFit = almostWorstfit placement ModifiedFirstFit = error "Not a simple placment policy." order :: (Ord a) => OrderPolicy -> Order a b order AsGiven = const id order Decreasing = decreasing order Increasing = increasing -- | Given a 'Measure' for @b@s and a list of items @[b]@, an 'Order' returns -- a re-ordered version of the item list. type Order a b = Measure a b -> [b] -> [b] -- | Reorder items prior to processing. Items are placed into bins in the order -- from largest to smallest. decreasing :: (Ord a) => Order a b decreasing size items = sortBy decreasing' items where decreasing' x y = if size x >= size y then LT else GT -- | Reorder items prior to processing. Items are placed into bins in the order -- from smallest to largest. increasing :: (Ord a) => Order a b increasing size items = sortBy increasing' items where increasing' x y = if size x <= size y then LT else GT --------------------------------------------------------------------------- {- | Bin packing without a limit on the number of bins (minimization problem). Assumption: The maximum item size is at most the size of one bin (this is not checked). Examples: * Pack the words of the sentence /"Bin packing heuristics are a lot of fun!"/ into bins of size 11, assuming the size of a word is its length. The 'Increasing' ordering yields a sub-optimal result that leaves a lot of empty space in the bins. > minimizeBins FirstFit Increasing length 11 (words "Bin packing heuristics are a lot of fun!") > ~~> ([1,4,4,2],[["heuristics"],["packing"],["fun!","lot"],["are","Bin","of","a"]]) * Similarly, for 'Int'. Note that we use 'id' as the 'Measure' for the size of an 'Int'. In this case, all bins are full. > minimizeBins FirstFit Decreasing id 11 [3,7,10,3,1,3,2,4] > ~~> ([0,0,0],[[2,3,3,3],[4,7],[1,10]]) -} minimizeBins :: (Num a, Ord a) => PlacementPolicy -- ^ How to order the items before placement. -> OrderPolicy -- ^ The bin packing heuristic to use. -> Measure a b -- ^ How to size the items. -> a -- ^ The size of one bin. -> [b] -- ^ The items. -> ([a], [Bin b]) -- ^ The result: a list of the remaining -- capacities and a list of the bins. minimizeBins fitPol ordPol size capacity items = let fit = placement fitPol items' = order ordPol size items in case fitPol of ModifiedFirstFit -> minimizeMFF ordPol size capacity items _ -> minimize capacity size fit [] [] items' -- The actual workhorse. minimize traverses the list of items and -- tries to place each in a bin. If an item doesn't fit anymore, then a new -- empty bin is created and the item is placed in that bin. minimize :: (Num a, Ord a) => a -> Measure a b -> Placement a b -> [a] -> [Bin b] -> [b] -> ([a], [Bin b]) minimize _ _ _ caps bins [] = (caps, bins) minimize cap size fit caps bins (x : xs) = case fit size x caps bins of Nothing -> minimize cap size fit caps'' bins'' xs Just (caps', bins') -> minimize cap size fit caps' bins' xs where -- assumption: size x <= cap. Doesn't make much sense otherwise. caps'' = (cap - size x) : caps bins'' = [x] : bins {- | Wrapper around 'minimizeBins'; useful if only the number of required bins is of interest. See 'minimizeBins' for a description of the arguments. Examples: * How many bins of size 11 characters each do we need to pack the words of the sentence /"Bin packing heuristics are a lot of fun!"/? > countBins FirstFit Increasing length 11 (words "Bin packing heuristics are a lot of fun!") > ~~> 4 * Similarly, for 'Int'. Note that we use 'id' as the 'Measure' for the size of an 'Int'. > countBins FirstFit Decreasing id 11 [3,7,10,3,1,3,2,4] > ~~> 3 -} countBins :: (Num a, Ord a) => PlacementPolicy -> OrderPolicy -> Measure a b -> a -> [b] -> Int countBins fitPol ordPol size capacity items = length bins where (_, bins) = minimizeBins fitPol ordPol size capacity items {- | Bin pack with a given limit on the number (and sizes) of bins. Instead of creating new bins, this version will return a list of items that could not be packed (if any). Example: We have two bins, one of size 10 and one of size 12. Which words can we fit in there? > binpack WorstFit Decreasing length [10, 12] (words "Bin packing heuristics are a lot of fun!") > ~~> ([0,0],[["heuristics"],["a","fun!","packing"]],["of","lot","are","Bin"]) -} binpack :: (Num a, Ord a) => PlacementPolicy -- ^ The bin packing heuristic to use. -> OrderPolicy -- ^ How to order the items before placement. -> Measure a b -- ^ How to size the items. -> [a] -- ^ Intitial per-bin capacities. -> [b] -- ^ The items. -> ([a], [Bin b], [b]) -- ^ The result; a list of residue capacities, -- the bins, and a list of items that could not -- be placed. binpack fitPol ordPol size capacities items = let fit = placement fitPol emptyBins = replicate (length capacities) [] items' = order ordPol size items in case fitPol of ModifiedFirstFit -> binpackMFF ordPol size capacities emptyBins items' _ -> binpack' (fit size) capacities emptyBins items' [] -- | Actual binpacking function. Tries to place each item in order. binpack' :: (Num a, Ord a) => (b -> [a] -> [Bin b] -> Maybe ([a], [Bin b])) -- ^ Function to -- place on item. -> [a] -- ^ Remaining capacities. -> [Bin b] -- ^ The bins. -> [b] -- ^ Items yet to be placed. -> [b] -- ^ Items that didn't fit anywhere (accumulator). -> ([a], [Bin b], [b]) binpack' _ caps bins [] misfits = (caps, bins, misfits) binpack' fit caps bins (x : xs) misfits = case fit x caps bins of Nothing -> binpack' fit caps bins xs (x : misfits) Just (caps', bins') -> binpack' fit caps' bins' xs misfits --------------------------------- -- Simple bin packing heuristics. -- generic X fit heuristic xfit :: (Ord a, Num a) => (a -> a -> Bool) -> Placement a b xfit cmp size item caps bins = case best Nothing caps of Nothing -> Nothing opt -> Just (drop' False opt caps bins [] []) where fit c = if size item <= c then Just (c - size item) else Nothing better Nothing _ = False better _ Nothing = True better (Just a) (Just b) = a `cmp` b best = foldl (\ a b -> if better (fit b) a then fit b else a) drop' _ _ [] [] caps' bins' = (reverse caps', reverse bins') drop' dropped opt (c : caps) (b : bins) caps' bins' = if not dropped && better (fit c) opt then drop' True opt caps bins ((c - size item) : caps') ((item : b) : bins') else drop' dropped opt caps bins (c : caps') (b : bins') bestfit, firstfit, lastfit, worstfit :: (Ord a, Num a) => Placement a b bestfit = xfit (>=) worstfit = xfit (<=) firstfit = xfit (==) lastfit size item caps bins = case firstfit size item (reverse caps) (reverse bins) of Nothing -> Nothing Just (caps', bins') -> Just (reverse caps', reverse bins') -- almost worst fit: choose the 2nd to worst-fitting bin almostWorstfit :: (Ord a, Num a) => Placement a b almostWorstfit size item caps bins = let s = size item space = sort [ (c - s, i) | (c, i) <- zip caps (enumFrom 0), c >= s] in case space of [] -> Nothing (_, i) : [] -> Just (insertAt i item s caps bins) _ : ((_, i) : _) -> Just (insertAt i item s caps bins) -------------------------------------------------------------- -- Modified first fit heuristic (see above). minimizeMFF :: (Num a, Ord a) => OrderPolicy -> Measure a b -> a -> [b] -> ([a], [Bin b]) minimizeMFF ordPol size cap items = minimize cap size firstfit gC' gB' rest' where -- split in categories (lA, lC, rest) = splitMFF cap size items -- pack lA items gBins = map return lA gCaps = map (\i -> cap - size i) lA (rgC, rgB) = (reverse gCaps, reverse gBins) -- pack lC items (gC', gB', lC') = packCs size [] [] rgC rgB (increasing size lC) -- The rest that has yet to be packed. rest' = order ordPol size $ lC' ++ rest binpackMFF :: (Ord a, Num a) => OrderPolicy -> Measure a b -> [a] -> [[b]] -> [b] -> ([a], [[b]], [b]) binpackMFF ordPol size caps bins items = (c, b, rejA ++ rej) where cap = head caps -- We use the first bin as the representative bin; the -- assumption is that they are all of the same size. (lA, lC, rest) = splitMFF cap size items -- pack the lA items (caps', bins', rejA) = binpack' (firstfit size) caps bins lA [] (rC, rB) = (reverse caps', reverse bins') -- pack the lC items (caps'', bins'', rejC) = packCs size [] [] rC rB (increasing size lC) -- The rest that still might fit. rest' = order ordPol size $ rejC ++ rest -- pack the rest (c, b, rej) = binpack' (firstfit size) caps'' bins'' rest' [] -- | Split items into the A,B,C,D groups of the MFF algorithm. Only A, C, and -- | the rest are returned. splitMFF :: (Num a, Ord a) => a -> Measure a b -> [b] -> ([b], [b], [b]) splitMFF cap size items = (lA, lC, rest) where x = minimum . map size $ items (lA, items') = partition (\ i -> 2 * size i > cap) items (lC, rest) = partition (\ i -> 5 * size i > cap - x && 3 * size i <= cap) items' packCs :: (Num a, Ord a) => Measure a b -> [a] -> [Bin b] -- bins that we are done with -> [a] -> [Bin b] -- bins yet to do -> [b] -- remainder of lC, sorted from largest to -- smallest -> ([a], [Bin b], [b]) -- caps, bins, remainder (reversed) packCs _ caps bins [] [] lC = (caps, bins, lC) packCs _ caps bins caps2 bins2 [] = (caps ++ caps2, bins ++ bins2, []) packCs size caps bins (c:cs) (b:bs) (s1:lC) = if null lC || size s1 + size s2 > c then packCs size (c:caps) (b:bins) cs bs (s1:lC) -- there aren't two items that fit else -- approximate two largest items that fit let lC' = reverse lC Just (x1, lC'') = removeIf (\i -> size i + size s1 <= c) lC' in case removeIf (\i -> size i + size x1 <= c) lC'' of Just (x2, lC''') -> -- we can ignore s1 as something larger fits, too let caps' = (c - size x1 - size x2 : caps) bins' = ((x2:x1:b) : bins) in packCs size caps' bins' cs bs $ s1 : reverse lC''' Nothing -> -- s1, the smallest item in lC, is the only that fits with x1 let caps' = (c - size x1 - size s1 : caps) bins' = ((s1:x1:b) : bins) in packCs size caps' bins' cs bs $ reverse lC'' where s2 = head lC -------------------------------------------- -- Some convenience list handling functions. -- Like a map on a specific element. update :: Int -> (a -> a) -> [a] -> [a] update i f xs = pre ++ (f (head post) : tail post) where (pre, post) = splitAt i xs -- Insert an item into a bin and reduce the bin's capacity. insertAt :: (Num a) => Int -> b -> a -> [a] -> [[b]] -> ([a], [[b]]) insertAt i x s caps bins = (update i (\c -> c - s) caps, update i (\b -> x : b) bins) -- Retrieve an element from a list at a given index. removeAt :: Int -> [a] -> (a, [a]) removeAt i xs = (head post, pre ++ tail post) where (pre, post) = splitAt i xs -- Retrieve the first element from a list that satisfies -- a given condition. removeIf :: (a -> Bool) -> [a] -> Maybe (a, [a]) removeIf p lst = case findIndex p lst of Just idx -> Just $ removeAt idx lst Nothing -> Nothing ----------------------------------------------------- -- tests -- TODO: Move into testing module and add more tests. prop_lA, prop_lC1, prop_lC2, prop_rest :: [Double] -> Bool prop_lA nums = all (> 0.5) lA where (lA, _, _) = splitMFF 1.0 id nums prop_lC1 nums = all (<= 1/3.0) lC where (_, lC, _) = splitMFF 1.0 id nums prop_lC2 nums = all (> (1.0 - x) / 5.0) lC where (_, lC, _) = splitMFF 1.0 id nums x = minimum nums prop_rest nums = lA `intersect` rest == [] && lC `intersect` rest == [] where (lA, lC, rest) = splitMFF 1.0 id nums prop_notLossy :: PlacementPolicy -> OrderPolicy -> [Double] -> Bool prop_notLossy pPol oPol nums = sort nums == sort nums' where (_, bins) = minimizeBins pPol oPol id 1.0 nums nums' = concat bins prop_remCap :: PlacementPolicy -> OrderPolicy -> [Int] -> Bool prop_remCap pPol oPol nums = all (\ (c, b) -> sum b == 100 - c) $ zip caps bins where (caps, bins) = minimizeBins pPol oPol id 100 nums runTests :: IO () runTests = do let n = 100 i = replicateM n $ choose (1, 100) g = replicateM n $ choose (0.0, 1.0) quickCheck $ forAll g prop_lA quickCheck $ forAll g prop_lC1 quickCheck $ forAll g prop_lC2 quickCheck $ forAll g prop_rest sequence_ [quickCheck $ forAll g $ prop_notLossy p o | (p, o) <- allHeuristics] sequence_ [quickCheck $ forAll i $ prop_remCap p o | (p, o) <- allHeuristics]