Binpack 0.3.1 → 0.4

raw patch · 5 files changed

+551/−336 lines, 5 filesdep −QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck

API changes (from Hackage documentation)

Files

• Binpack.cabal +10/−7
• Data/BinPack.hs +103/−329
• Data/BinPack/Internals.hs +253/−0
• Data/BinPack/Internals/MFF.hs +105/−0
• Data/BinPack/Internals/SumOfSquares.hs +80/−0

@@ -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

@@ -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]

@@ -0,0 +1,253 @@+-- 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.++-- | 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

@@ -0,0 +1,105 @@+-- 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.++-- | 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+

@@ -0,0 +1,80 @@+-- 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.++-- | 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