{-# LANGUAGE Safe #-}
{-
Copyright (c) 2008-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : Data.BinPacking
   Copyright  : Copyright (C) 2008-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Tools for packing into bins

Written by John Goerzen, jgoerzen\@complete.org

This module is designed to solve this type of problem: Given a bunch of
objects of varying sizes, what is the best possible way to pack them into
fixed-size bins?  This can be used, for instance, by the datapacker program
to pack files onto CDs or DVDs; by manufacturing environments to pack
physical items into physicl bins; etc.

A description of bin packing algorithms can be found at
<http://en.wikipedia.org/wiki/Bin_packing_problem>.
-}

module Data.BinPacking (BinPacker,
                        BinPackerError(..),
                        packByOrder,
                        packLargeFirst
                       )

where

import Data.List (sortOn)

{- | Potential errors returned as Left values by 'BinPacker' functions.
Calling 'show' on this value will produce a nice error message suitable for
display. -}
data (Num size, Ord size, Show size, Show obj) => BinPackerError size obj =
    BPTooFewBins [(size, obj)]                -- ^ Ran out of bins; attached value is the list of objects that do not fit
    | BPSizeTooLarge size (size, obj)   -- ^ Bin size1 exceeded by at least the given object and size
    | BPOther String                    -- ^ Other error
      deriving (BinPackerError size obj -> BinPackerError size obj -> Bool
(BinPackerError size obj -> BinPackerError size obj -> Bool)
-> (BinPackerError size obj -> BinPackerError size obj -> Bool)
-> Eq (BinPackerError size obj)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall size obj.
(Num size, Ord size, Show size, Show obj, Eq obj) =>
BinPackerError size obj -> BinPackerError size obj -> Bool
/= :: BinPackerError size obj -> BinPackerError size obj -> Bool
$c/= :: forall size obj.
(Num size, Ord size, Show size, Show obj, Eq obj) =>
BinPackerError size obj -> BinPackerError size obj -> Bool
== :: BinPackerError size obj -> BinPackerError size obj -> Bool
$c== :: forall size obj.
(Num size, Ord size, Show size, Show obj, Eq obj) =>
BinPackerError size obj -> BinPackerError size obj -> Bool
Eq, ReadPrec [BinPackerError size obj]
ReadPrec (BinPackerError size obj)
Int -> ReadS (BinPackerError size obj)
ReadS [BinPackerError size obj]
(Int -> ReadS (BinPackerError size obj))
-> ReadS [BinPackerError size obj]
-> ReadPrec (BinPackerError size obj)
-> ReadPrec [BinPackerError size obj]
-> Read (BinPackerError size obj)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadPrec [BinPackerError size obj]
forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadPrec (BinPackerError size obj)
forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
Int -> ReadS (BinPackerError size obj)
forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadS [BinPackerError size obj]
readListPrec :: ReadPrec [BinPackerError size obj]
$creadListPrec :: forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadPrec [BinPackerError size obj]
readPrec :: ReadPrec (BinPackerError size obj)
$creadPrec :: forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadPrec (BinPackerError size obj)
readList :: ReadS [BinPackerError size obj]
$creadList :: forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
ReadS [BinPackerError size obj]
readsPrec :: Int -> ReadS (BinPackerError size obj)
$creadsPrec :: forall size obj.
(Num size, Ord size, Show size, Show obj, Read size, Read obj) =>
Int -> ReadS (BinPackerError size obj)
Read)

instance (Num size, Ord size, Show size, Show obj) => Show (BinPackerError size obj) where
    show :: BinPackerError size obj -> String
show (BPTooFewBins [(size, obj)]
_) = String
"Too few bins"
    show (BPSizeTooLarge size
binsize (size
objsize, obj
obj)) =
        String
"Size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ size -> String
forall a. Show a => a -> String
show size
objsize String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" greater than bin size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ size -> String
forall a. Show a => a -> String
show size
binsize
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ obj -> String
forall a. Show a => a -> String
show obj
obj
    show (BPOther String
x) = String
x

{- | The primary type for bin-packing functions.

These functions take a list of size of bins.  If every bin is the same size,
you can pass @repeat binSize@ to pass an infinite list of bins if the
same size.  Any surplus bins will simply be ignored.

> [size] is the sizes of bins
> [(size, obj)] is the sizes and objects
> result is Either error or results
-}
type BinPacker = forall size obj. (Num size, Ord size, Show size, Show obj) =>
                  [size]        -- The sizes of bins
               -> [(size, obj)] -- The sizes and objects
               -> Either (BinPackerError size obj) [[(size, obj)]] -- Either error or results


{- | Pack objects into bins, preserving order.  Objects will be taken from the
input list one by one, and added to each bin until the bin is full.  Work will
then proceed on the next bin.  No attempt is made to optimize allocations to
bins.  This is the simplest and most naive bin-packing algorithm, but
may not make very good use of bin space. -}
packByOrder :: BinPacker
packByOrder :: [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
packByOrder [size]
_ [] = [[(size, obj)]] -> Either (BinPackerError size obj) [[(size, obj)]]
forall a b. b -> Either a b
Right []                     -- Ran out of sizes
packByOrder [] [(size, obj)]
remainder = BinPackerError size obj
-> Either (BinPackerError size obj) [[(size, obj)]]
forall a b. a -> Either a b
Left ([(size, obj)] -> BinPackerError size obj
forall size obj. [(size, obj)] -> BinPackerError size obj
BPTooFewBins [(size, obj)]
remainder)
packByOrder (size
thisbinsize:[size]
otherbins) [(size, obj)]
sizes =
    let fillBin :: size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin size
_ [] = [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. b -> Either a b
Right []
        fillBin size
accumsize ((size
s, b
o):[(size, b)]
xs)
            | size
s size -> size -> Bool
forall a. Ord a => a -> a -> Bool
> size
thisbinsize = BinPackerError size b -> Either (BinPackerError size b) [(size, b)]
forall a b. a -> Either a b
Left (BinPackerError size b
 -> Either (BinPackerError size b) [(size, b)])
-> BinPackerError size b
-> Either (BinPackerError size b) [(size, b)]
forall a b. (a -> b) -> a -> b
$ size -> (size, b) -> BinPackerError size b
forall size obj. size -> (size, obj) -> BinPackerError size obj
BPSizeTooLarge size
thisbinsize (size
s, b
o)
            | size
s size -> size -> size
forall a. Num a => a -> a -> a
+ size
accumsize size -> size -> Bool
forall a. Ord a => a -> a -> Bool
> size
thisbinsize = [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. b -> Either a b
Right []
            | Bool
otherwise = do [(size, b)]
next <- size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin (size
accumsize size -> size -> size
forall a. Num a => a -> a -> a
+ size
s) [(size, b)]
xs
                             [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(size, b)] -> Either (BinPackerError size b) [(size, b)])
-> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. (a -> b) -> a -> b
$ (size
s, b
o) (size, b) -> [(size, b)] -> [(size, b)]
forall a. a -> [a] -> [a]
: [(size, b)]
next
        in do [(size, obj)]
thisset <- size
-> [(size, obj)] -> Either (BinPackerError size obj) [(size, obj)]
forall b.
Show b =>
size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin size
0 [(size, obj)]
sizes
              [[(size, obj)]]
next <- [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
BinPacker
packByOrder [size]
otherbins (Int -> [(size, obj)] -> [(size, obj)]
forall a. Int -> [a] -> [a]
drop ([(size, obj)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(size, obj)]
thisset) [(size, obj)]
sizes)
              [[(size, obj)]] -> Either (BinPackerError size obj) [[(size, obj)]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(size, obj)]
thisset [(size, obj)] -> [[(size, obj)]] -> [[(size, obj)]]
forall a. a -> [a] -> [a]
: [[(size, obj)]]
next)

{- | Pack objects into bins.  For each bin, start with the largest objects,
and keep packing the largest object from the remainder until no object can
be found to put in the bin.  This is substantially more efficient than
'packByOrder', but requires sorting the input. -}
packLargeFirst :: BinPacker
packLargeFirst :: [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
packLargeFirst [size]
bins [(size, obj)]
sizes = [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
BinPacker
packLargeFirst' [size]
bins (((size, obj) -> size) -> [(size, obj)] -> [(size, obj)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (size, obj) -> size
forall a b. (a, b) -> a
fst [(size, obj)]
sizes)

packLargeFirst' :: BinPacker
packLargeFirst' :: [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
packLargeFirst' [size]
_ [] = [[(size, obj)]] -> Either (BinPackerError size obj) [[(size, obj)]]
forall a b. b -> Either a b
Right []                     -- Ran out of sizes
packLargeFirst' [] [(size, obj)]
remainder = BinPackerError size obj
-> Either (BinPackerError size obj) [[(size, obj)]]
forall a b. a -> Either a b
Left ([(size, obj)] -> BinPackerError size obj
forall size obj. [(size, obj)] -> BinPackerError size obj
BPTooFewBins [(size, obj)]
remainder)
packLargeFirst' (size
thisbinsize:[size]
otherbins) [(size, obj)]
sizes =
    let fillBin :: size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin size
_ [] = [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. b -> Either a b
Right []
        fillBin size
accumsize [(size, b)]
sizelist =
            case ((size, b) -> Bool) -> [(size, b)] -> ([(size, b)], [(size, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(size, b)
x -> ((size, b) -> size
forall a b. (a, b) -> a
fst (size, b)
x) size -> size -> size
forall a. Num a => a -> a -> a
+ size
accumsize size -> size -> Bool
forall a. Ord a => a -> a -> Bool
<= size
thisbinsize) [(size, b)]
sizelist of
              ([(size, b)]
_, []) ->
                  if size
accumsize size -> size -> Bool
forall a. Eq a => a -> a -> Bool
== size
0
                     then BinPackerError size b -> Either (BinPackerError size b) [(size, b)]
forall a b. a -> Either a b
Left (BinPackerError size b
 -> Either (BinPackerError size b) [(size, b)])
-> BinPackerError size b
-> Either (BinPackerError size b) [(size, b)]
forall a b. (a -> b) -> a -> b
$ size -> (size, b) -> BinPackerError size b
forall size obj. size -> (size, obj) -> BinPackerError size obj
BPSizeTooLarge size
thisbinsize ([(size, b)] -> (size, b)
forall a. [a] -> a
head [(size, b)]
sizelist)
                     else [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. b -> Either a b
Right []
              ([(size, b)]
nonmatches, ((size
s, b
o):[(size, b)]
matchxs)) ->
                  do [(size, b)]
next <- size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin (size
accumsize size -> size -> size
forall a. Num a => a -> a -> a
+ size
s) ([(size, b)]
nonmatches [(size, b)] -> [(size, b)] -> [(size, b)]
forall a. [a] -> [a] -> [a]
++ [(size, b)]
matchxs)
                     [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(size, b)] -> Either (BinPackerError size b) [(size, b)])
-> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
forall a b. (a -> b) -> a -> b
$ (size
s, b
o) (size, b) -> [(size, b)] -> [(size, b)]
forall a. a -> [a] -> [a]
: [(size, b)]
next
        in do [(size, obj)]
thisset <- size
-> [(size, obj)] -> Either (BinPackerError size obj) [(size, obj)]
forall b.
Show b =>
size -> [(size, b)] -> Either (BinPackerError size b) [(size, b)]
fillBin size
0 [(size, obj)]
sizes
              [[(size, obj)]]
next <- [size]
-> [(size, obj)]
-> Either (BinPackerError size obj) [[(size, obj)]]
BinPacker
packLargeFirst' [size]
otherbins (Int -> [(size, obj)] -> [(size, obj)]
forall a. Int -> [a] -> [a]
drop ([(size, obj)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(size, obj)]
thisset) [(size, obj)]
sizes)
              [[(size, obj)]] -> Either (BinPackerError size obj) [[(size, obj)]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(size, obj)]
thisset [(size, obj)] -> [[(size, obj)]] -> [[(size, obj)]]
forall a. a -> [a] -> [a]
: [[(size, obj)]]
next)