Binpack-0.3.1: Data/BinPack.hs
-- 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]