    {-# 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
    $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
    /= :: 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 obj, Read size) =>
    ReadPrec [BinPackerError size obj]
    forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    ReadPrec (BinPackerError size obj)
    forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    Int -> ReadS (BinPackerError size obj)
    forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    ReadS [BinPackerError size obj]
    $creadsPrec :: forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    Int -> ReadS (BinPackerError size obj)
    readsPrec :: Int -> ReadS (BinPackerError size obj)
    $creadList :: forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    ReadS [BinPackerError size obj]
    readList :: ReadS [BinPackerError size obj]
    $creadPrec :: forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    ReadPrec (BinPackerError size obj)
    readPrec :: ReadPrec (BinPackerError size obj)
    $creadListPrec :: forall size obj.
    (Num size, Ord size, Show size, Show obj, Read obj, Read size) =>
    ReadPrec [BinPackerError size obj]
    readListPrec :: ReadPrec [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 :: BinPacker
    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.
    (Num size, Ord size, Show size, Show 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.
    (Num size, Ord size, Show size, Show 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 a. a -> Either (BinPackerError size b) a
    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 a. [a] -> 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 a. a -> Either (BinPackerError size obj) a
    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 :: BinPacker
    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' :: BinPacker
    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.
    (Num size, Ord size, Show size, Show 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.
    (Num size, Ord size, Show size, Show obj) =>
    size -> (size, obj) -> BinPackerError size obj
    BPSizeTooLarge size
    thisbinsize ([(size, b)] -> (size, b)
    forall a. HasCallStack => [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 a. a -> Either (BinPackerError size b) a
    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 a. [a] -> 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 a. a -> Either (BinPackerError size obj) a
    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)