diff --git a/Binpack.cabal b/Binpack.cabal --- a/Binpack.cabal +++ b/Binpack.cabal @@ -1,5 +1,5 @@ Name: Binpack -Version: 0.3.1 +Version: 0.4 Cabal-Version: >= 1.2 License: BSD3 License-File: LICENSE @@ -7,13 +7,13 @@ Maintainer: bbb@cs.unc.edu Category: Algorithms, Heuristics Build-Type: Simple -Synopsis: Common bin packing heuristics +Synopsis: Common bin-packing heuristics. Description: An implementation of the first-fit, modified-first-fit, last-fit, best-fit, - worst-fit, and almost-last-fit bin packing heuristics. Items can be packed in - order of both decreasing and increasing size (and, of course, in unmodified - order). + sum-of-squares-fit, worst-fit, and almost-last-fit bin packing + heuristics. Items can be packed in order of both decreasing and increasing + size (and, of course, in unmodified order). . The module supports both the standard (textbook) minimization problem (/How many bins do I need?/) and the more practical fitting problem @@ -30,7 +30,10 @@ Library Exposed-Modules: Data.BinPack - Build-Depends: base >= 3 && < 5, haskell98, QuickCheck - Ghc-Options: -Wall -fno-warn-unused-binds -fno-warn-unused-imports + Other-Modules: Data.BinPack.Internals + , Data.BinPack.Internals.MFF + , Data.BinPack.Internals.SumOfSquares + Build-Depends: base >= 3 && < 5, haskell98 + Ghc-Options: -Wall if impl(ghc >= 6.8) Ghc-Options: -fwarn-tabs diff --git a/Data/BinPack.hs b/Data/BinPack.hs --- a/Data/BinPack.hs +++ b/Data/BinPack.hs @@ -27,13 +27,17 @@ {- | -This module implements a number of common bin packing heuristics: 'FirstFit', +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'). +'ModifiedFirstFit' heuristic is also supported. Further, the (slow) +'SumOfSquaresFit' heuristic, which has been considered in the context of online +bin-packing (Bender et al., 2008), 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 @@ -49,9 +53,9 @@ (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. +If unsure what to pick, then try 'FirstFit' 'Decreasing' or 'BestFit' +'Decreasing' as a default. Use 'WorstFit' 'Decreasing' (in combination with +'binpack') if you want a pre-determined number of bins filled evenly. A short overview of the 'ModifiedFirstFit' heuristic follows. This overview is based on the description given in (Yue and Zhang, 1995). @@ -93,45 +97,49 @@ References: - * D.S. Johnson and M.R. Garey. A 71/60 Theorem for Bin-Packing. - /Journal of Complexity/, 1:65-106, 1985. + * D.S. Johnson and M.R. Garey (1985). A 71/60 Theorem for Bin-Packing. + /Journal of Complexity/, 1:65-106. - * M. Yue and L. Zhang. A Simple Proof of the Inequality MFFD(L) <= 71/60 + * M. Yue and L. Zhang (1995). 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. + /Acta Mathematicae Applicatae Sinica/, 11(3):318-330. + + * M.A. Bender, B. Bradley, G. Jagannathan, and K. Pillaipakkamnatt (2008). + Sum-of-Squares Heuristics for Bin Packing and Memory Allocation. + /ACM Journal of Experimental Algorithmics/, 12:1-19. -} -module Data.BinPack ( PlacementPolicy(..) +module Data.BinPack ( + -- * Types + PlacementPolicy(..) , OrderPolicy (AsGiven, Increasing, Decreasing) , Measure - , Bin + -- * Feature Enumeration + -- $features , allOrders , allPlacements , allHeuristics + -- * Bin Abstraction + -- $bin + , Bin + , emptyBin + , emptyBins + , asBin + , tryAddItem + , addItem + , addItems + , items + , gap + -- * Bin-Packing Functions , 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 +import Data.BinPack.Internals +import Data.BinPack.Internals.MFF (binpackMFF, minimizeMFF) +import Data.BinPack.Internals.SumOfSquares (sosfit, sosfitAnyFit) -- | What placement heuristic should be used? data PlacementPolicy = FirstFit -- ^ Traverse bin list from 'head' to @@ -147,120 +155,84 @@ -- least (but sufficient) capacity. | AlmostWorstFit -- ^ Choose the 2nd to worst-fitting -- bin. + | SumOfSquaresFit -- ^ Choose bin such that sum-of-squares + -- heuristic is minimized. deriving (Show, Eq, Ord) --- | The list of all possible 'PlacementPolicy' choices. Useful for benchmarking. +-- $features +-- Lists of all supported heuristics. Useful for benchmarking and testing. + +-- | The list of all possible 'PlacementPolicy' choices. allPlacements :: [PlacementPolicy] -allPlacements = [FirstFit, ModifiedFirstFit, LastFit, BestFit, WorstFit, AlmostWorstFit] +allPlacements = [FirstFit, ModifiedFirstFit, LastFit, BestFit + , WorstFit, AlmostWorstFit, SumOfSquaresFit] -instance Arbitrary PlacementPolicy where - arbitrary = elements allPlacements +-- | The list of all possible 'OrderPolicy' choices. +allOrders :: [OrderPolicy] +allOrders = [Decreasing, Increasing, AsGiven] --- | All supported ordering and placment choices. Useful for benchmarking. +-- | All supported ordering and placment choices. 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 WorstFit = worstfit +placement BestFit = bestfit +placement FirstFit = firstfit +placement LastFit = lastfit +placement AlmostWorstFit = almostWorstfit +placement SumOfSquaresFit = sosfitAnyFit 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] +-- $bin +-- Conceptually, a bin is defined by its remaining capacity and the contained +-- items. Currently, it is just a tuple, but this may change in future +-- releases. Clients of this module should rely on the following accessor +-- functions. --- | 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). +{- | 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. + 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"]]) + > ~~> [(2,["are","Bin","of","a"]),(4,["fun!","lot"]),(4,["packing"]),(1,["heuristics"])] -* Similarly, for 'Int'. Note that we use 'id' as the 'Measure' for the size of an 'Int'. In this case, all bins are full. +* Similarly, for 'Int'. Note that we use 'id' as a 'Measure' of the size of an 'Int'. > minimizeBins FirstFit Decreasing id 11 [3,7,10,3,1,3,2,4] - > ~~> ([0,0,0],[[2,3,3,3],[4,7],[1,10]]) + > ~~> [(0,[1,10]),(0,[4,7]),(0,[2,3,3,3])] -} minimizeBins :: (Num a, Ord a) => PlacementPolicy -- ^ How to order the items before placement. - -> OrderPolicy -- ^ The bin packing heuristic to use. + -> 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' + -> [Bin a b] -- ^ The result: a list of 'Bins'. +minimizeBins fitPol ordPol size capacity objects = + case fitPol of + -- special MFF: more complicated looping; no re-ordered items. + ModifiedFirstFit -> minimizeMFF ordPol size capacity objects + -- special SOS: not an any-fit heuristic. + SumOfSquaresFit -> minimize capacity size (sosfit capacity) [] items' + -- everything else can be handled by minimize+placement. + _ -> minimize capacity size (placement fitPol) [] items' + where items' = order ordPol size objects --- 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. @@ -273,243 +245,45 @@ > 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'. +* Similarly, for 'Int'. As before, we use 'id' as a '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 + PlacementPolicy -> OrderPolicy -> Measure a b -> a -> [b] -> Int +countBins fitPol ordPol size cap = length + . minimizeBins fitPol ordPol size cap +{- | Bin-pack a list of items into a list of (possibly non-uniform) bins. If + an item cannot be placed, instead of creating a new bin, this version will + return a list of items that could not be packed (if any). -{- | -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 empty bins, one of size 10 and one of size 12. + Which words can we fit in there? -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 [emptyBin 10, emptyBin 12] (words "Bin packing heuristics are a lot of fun!") +> ~~> ([(0,["Bin","packing"]),(0,["of","heuristics"])],["a","lot","are","fun!"]) -> 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"]) --} +Both bins were filled completely, and the words /"are a lot fun!"/ coult not be +packed. -} 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. + -> [Bin a b] -- ^ The bins; may be non-uniform and pre-filled. -> [b] -- ^ The items. - -> ([a], [Bin b], [b]) -- ^ The result; a list of residue capacities, - -- the bins, and a list of items that could not + -> ([Bin a b], [b]) -- ^ The result; a list of bins + -- and a list of items that could not -- be placed. -binpack fitPol ordPol size capacities items = +binpack fitPol ordPol size bins objects = let fit = placement fitPol - emptyBins = replicate (length capacities) [] - items' = order ordPol size items + items' = order ordPol size objects 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 + ModifiedFirstFit -> binpackMFF ordPol size bins items' + _ -> binpack' (fit size) bins items' [] -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] diff --git a/Data/BinPack/Internals.hs b/Data/BinPack/Internals.hs new file mode 100644 --- /dev/null +++ b/Data/BinPack/Internals.hs @@ -0,0 +1,253 @@ +-- Copyright (c) 2009, Bjoern B. Brandenburg +-- +-- 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. + +-- | The implementation of 'Data.BinPack'. This module should not be imported +-- directly; all relevant functions are re-exported by 'Data.BinPack'. + +module Data.BinPack.Internals where + +import List (sortBy + , maximumBy + , minimumBy + ) + +import Data.Ord (comparing) + +---------------------------------------------- +-- Some convenience type and function aliases. + +-- | 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) + +-- | 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 -> [Bin a b] -> + Maybe [Bin a b] + +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 xs = sortBy decreasing' xs + 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 xs = sortBy increasing' xs + where + increasing' x y = if size x <= size y then LT else GT + +----------------------- +-- The Bin abstraction. + +-- | A 'Bin' consists of the remaining capacity together with a list of items +-- already placed. +type Bin a b = (a, [b]) + +-- | Create an empty bin. +emptyBin :: (Num a, Ord a) => + a -- ^ The initial capacity. + -> Bin a b -- ^ The empty bin. +emptyBin cap = (cap, []) + +-- | Create multiple empty bins with uniform capacity. +emptyBins :: (Num a, Ord a) => + a -- ^ The initial capacity. + -> Int -- ^ Number of bins. + -> [Bin a b] +emptyBins cap = flip replicate $ emptyBin cap + +-- | Try placing an item inside a 'Bin'. +tryAddItem :: (Num a, Ord a) => + a -- ^ The item's size. + -> b -- ^ The item. + -> Bin a b -- ^ The bin. + -> Maybe (Bin a b) -- ^ 'Just' the updated bin with the item inside, + -- 'Nothing' if it does not fit. +tryAddItem s _ (c, _) | s > c = Nothing +tryAddItem s x (c, xs) = Just (c - s, x:xs) + +-- | Place an item inside a 'Bin'. Fails if there is insufficient capacity. +addItem :: (Num a, Ord a) => + a -- ^ The item's size. + -> b -- ^ The item. + -> Bin a b -- ^ The bin. + -> Bin a b -- ^ 'Just' the updated bin with the item inside, + -- 'Nothing' if it does not fit. +addItem s x b = case tryAddItem s x b of + Nothing -> error "Bin overflow." + Just b' -> b' + +-- | Add a list of items to an existing bin. Fails if there is +-- insufficient capacity. +addItems :: (Ord a, Num a) => + Bin a b -- ^ The bin that should be augmented. + -> Measure a b -- ^ A function to determine each item's size. + -> [b] -- ^ The items that are to be added. + -> Bin a b -- ^ The resulting bin. +addItems (avail, obj) size xs = + if req <= avail + then (avail - req, xs ++ obj) + else error "Data.BinPack.addItems: insufficient capacity." + where + req = sum . map size $ xs + +-- | Turn a list of items into a pre-filled bin. +asBin :: (Ord a, Num a) => a -> Measure a b -> [b] -> Bin a b +asBin cap = addItems (emptyBin cap) + +makeBin :: (Ord a, Num a) => Measure a b -> a -> b -> Bin a b +makeBin size cap x = asBin cap size [x] + +-- | Get the items in a bin. +items :: Bin a b -> [b] +items = snd + +-- | Get the remaining capacity of a bin. +gap :: Bin a b -> a +gap = fst + +-------------------------------------------- +-- 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 rst) : tail rst) + where (pre, rst) = splitAt i xs + +-- Insert an item into a bin and reduce the bin's capacity. +insertAt :: (Num a) => Int -> b -> a -> [Bin a b] -> [Bin a b] +insertAt i x s = update i (\ (c, xs) -> (c - s, x:xs)) + +-- Retrieve the first element from a list that satisfies +-- a given condition. +removeIf :: (a -> Bool) -> [a] -> Maybe (a, [a]) +removeIf p lst = case break p lst of + (_, []) -> Nothing + (pre, rst) -> Just (head rst, pre ++ tail rst) + +--------------------------------- +-- Simple bin packing heuristics. + +-- generic X fit heuristic +xfit :: (Ord a, Num a) => ([(Int, a)] -> (Int, a)) -> Placement a b +xfit _ _ _ [] = Nothing +xfit choose size item bins = + let + s = size item + gaps = filter (\(_, g) -> g >= s) . zip [0..] . map gap + in + case gaps bins of + [] -> Nothing + pl -> let (i, _) = choose pl in Just (insertAt i item s bins) + +bestfit, firstfit, lastfit, worstfit, almostWorstfit + :: (Ord a, Num a) => Placement a b +bestfit = xfit chooseBest +worstfit = xfit chooseWorst +firstfit = xfit head +lastfit = xfit last +almostWorstfit = xfit chooseAlmostWorst + +chooseBest, chooseWorst, chooseAlmostWorst :: (Ord a, Ord b) => + [(a, b)] -> (a, b) +chooseBest = minimumBy (comparing snd `withTieBreakOn` fst) +chooseWorst = maximumBy (comparing snd `withReverseTieBreakOn` fst) +-- almost worst fit: choose the 2nd to worst-fitting bin +chooseAlmostWorst pl = case filter (/= worst) pl of + [] -> worst + rest -> chooseWorst rest + where worst = chooseWorst pl + + +withReverseTieBreakOn, withTieBreakOn :: (Ord a, Ord b) => + (a -> a -> Ordering) + -> (a -> b) + -> a -> a + -> Ordering +withTieBreakOn cmp key x y = + case x `cmp` y of + EQ -> (key x) `compare` (key y) + ord -> ord + +withReverseTieBreakOn cmp key x y = + case x `cmp` y of + EQ -> (key y) `compare` (key x) + ord -> ord + + +-------------------------------------------- +-- The actual bin-packing functions. + +-- | '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 -> [Bin a b] -> [b] -> [Bin a b] +minimize _ _ _ bins [] = bins +minimize cap size fit bins (x : xs) = + case fit size x bins of + Just bins' -> minimize cap size fit bins' xs + Nothing -> minimize cap size fit bins'' xs + where + -- assumption: size x <= cap. Doesn't make much sense otherwise. + -- concat at end is ugly, but required for first/last semantics + bins'' = bins ++ [makeBin size cap x] + + +-- | Actual binpacking function. Tries to place each item in order. +binpack' :: (Num a, Ord a) => + (b -> [Bin a b] -> Maybe [Bin a b]) -- ^ Function to + -- place on item. + -> [Bin a b] -- ^ The bins. + -> [b] -- ^ Items yet to be placed. + -> [b] -- ^ Items that didn't fit anywhere (accumulator). + -> ([Bin a b], [b]) +binpack' _ bins [] misfits = (bins, misfits) +binpack' fit bins (x : xs) misfits = + case fit x bins of + Nothing -> binpack' fit bins xs (x : misfits) + Just bins' -> binpack' fit bins' xs misfits diff --git a/Data/BinPack/Internals/MFF.hs b/Data/BinPack/Internals/MFF.hs new file mode 100644 --- /dev/null +++ b/Data/BinPack/Internals/MFF.hs @@ -0,0 +1,105 @@ +-- Copyright (c) 2009, Bjoern B. Brandenburg +-- +-- 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. + +-- | Modified-first-fit heuristic support. + +module Data.BinPack.Internals.MFF where + +import Data.BinPack.Internals + +import List (partition) + +minimizeMFF :: (Num a, Ord a) => + OrderPolicy -> Measure a b -> a -> [b] -> [Bin a b] +minimizeMFF ordPol size cap objects = minimize cap size firstfit gB' rest' + where + -- split in categories + (lA, lC, rest) = splitMFF cap size objects + -- pack lA items + bins = map (makeBin size cap) lA + -- pack lC items + (gB', lC') = packCs size [] (reverse bins) (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 -> [Bin a b] -> [b] -> ([Bin a b], [b]) +binpackMFF ordPol size bins objects = (bins''', rejA ++ rej) + where + (cap, _) = head bins -- 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 objects + -- pack the lA items + (bins', rejA) = binpack' (firstfit size) bins lA [] + -- pack the lC items + (bins'', rejC) = packCs size [] (reverse bins') (increasing size lC) + -- The rest that still might fit. + rest' = order ordPol size $ rejC ++ rest + -- pack the rest + (bins''', rej) = binpack' (firstfit size) 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 objects = (lA, lC, rest) + where + x = minimum . map size $ objects + (lA, items') = partition (\ i -> 2 * size i > cap) objects + (lC, rest) = partition (\ i -> 5 * size i > cap - x && 3 * size i <= cap) items' + +packCs :: (Num a, Ord a) => + Measure a b -- sizing function + -> [Bin a b] -- bins that we are done with + -> [Bin a b] -- bins yet to do + -> [b] -- remainder of lC, sorted from largest to + -- smallest + -> ([Bin a b], [b]) -- caps, bins, remainder (reversed) +packCs _ bins [] lC = (bins, lC) +packCs _ bins bins2 [] = (bins ++ bins2, []) +packCs size bins ((c,b):bs) (s1:lC) = + if null lC || size s1 + size s2 > c + then packCs size ((c,b):bins) bs (s1:lC) -- there aren't two fitting items + 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 + bins' = (c - size x1 - size x2, (x2:x1:b)) : bins + in + packCs size bins' bs $ s1 : reverse lC''' + Nothing -> + -- s1, the smallest item in lC, is the only that fits with x1 + let + bins' = (c - size x1 - size s1, s1:x1:b) : bins + in + packCs size bins' bs $ reverse lC'' + where + s2 = head lC + diff --git a/Data/BinPack/Internals/SumOfSquares.hs b/Data/BinPack/Internals/SumOfSquares.hs new file mode 100644 --- /dev/null +++ b/Data/BinPack/Internals/SumOfSquares.hs @@ -0,0 +1,80 @@ +-- Copyright (c) 2009, Bjoern B. Brandenburg +-- +-- 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. + +-- | Sum-of-squares heuristic support. + +module Data.BinPack.Internals.SumOfSquares where + +import Data.List ( group + , sort + , minimumBy) + +import Data.Ord (comparing) + +import Data.BinPack.Internals + +-- | Sum of squares metric. The sum of the square of the counts of each gap +-- size, ignoring empty and completely-packed bins. +sumOfSquares :: (Num a, Ord a) => + [Bin a b] -- ^ The bins. + -> Int -- ^ Sum of the squared 'gapCount's. +sumOfSquares = sum + . map sqrlen -- square heuristic + . group . sort -- find bins with equal gaps + . filter (/= 0) -- ignore completely packed bins + . map gap -- determine gap + . filter (not . null . items) -- ignore empty bins + where sqrlen xs = length xs * length xs + +-- | Pick a bin that minimizes the sum-of-squares heuristic. +sosfit' :: (Ord a, Num a) => + Measure a b -> b -> [Bin a b] -> Maybe (Int, [Bin a b]) +sosfit' _ _ [] = Nothing +sosfit' size item bins = + let + s = size item + placed = map (\(_,bs) -> (sumOfSquares bs, bs)) + . map (\(i,_) -> (i, insertAt i item s bins)) + . filter (\(_,b) -> gap b >= s) + . zip [0..] + best = minimumBy (comparing fst) + in + case placed bins of + [] -> Nothing + pl -> Just $ best pl + +-- | sosfit, but without the option of adding an additional bin. +sosfitAnyFit :: (Ord a, Num a) => Placement a b +sosfitAnyFit size item = fmap snd . sosfit' size item + +-- | sofit, which may add a bin if it lowers the sum-of-squares heuristic. +sosfit :: (Ord a, Num a) => a -> Placement a b +sosfit cap size item bins = fmap testAppend . sosfit' size item $ bins + where + app = bins ++ [makeBin size cap item] + sos = sumOfSquares app + testAppend (sos', bins') = if sos' <= sos then bins' else app