Binpack-0.4: Data/BinPack/Internals.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.
-- | 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