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

{- |

This module implements a number of common bin packing heurstics: 'FirstFit',
'LastFit', 'BestFit', 'WorstFit', and 'AlmostWorstFit'.  In addtion, 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').

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
(/"I've got n bins; which items can I take?"/; see 'binpack').

The well-known heuristics are described online in many places and are not
further discussed here. For example, see
<http://www.cs.arizona.edu/icon/oddsends/bpack/bpack.htm> for an overview.  A
description of the 'ModifiedFirstFit' algorithm is harder to come by online,
hence a brief description and references are provided below.

Note that most published analysis assumes items to be sorted in some specific
(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.

A short overview of the 'ModifiedFirstFit' heuristic follows. This overview is
based on the description given in (Yue and Zhang, 1995).

Let @lst@ denote the list of items to be bin-packed, let @x@ denote the size of
the smallest element in @lst@, and let @cap@ denote the capacity of one
bin. @lst@ is split into the four sub-lists, @lA@, @lB@, @lC@, @lD@.

[@lA@] All items strictly larger than @cap\/2@.

[@lB@] All items of size at most @cap\/2@ and strictly larger than @cap\/3@.

[@lC@] All items of size at most @cap\/3@ and stricly larger than @(cap - x)\/5@.

[@lD@] The rest, /i.e./, all items of size at most @(cap - x)\/5@.

Items are placed as follows:

 (1) Create a list of @length lA@ bins. Place each item in @lA@ into its own
     bin (while maintaining relative item order with respect to @lst@). Note:
     relevant published analysis assumes that @lst@ is sorted in order of
     'decreasing' size.

 (2) Take the list of bins created in Step 1 and reverse it.

 (3) Sequentially consider each bin @b@. If the two smallest items in @lC@ do
     NOT fit together into @b@ of if there a less than two items remaining in
     @lC@, then pack nothing into @b@ and move on to the next bin (if any).
     If they do fit together, then find the largest item @x1@ in @lC@ that
     would fit together with the smallest item in @lC@ into @b@. Remove @x1@
     from @lC@. Then find the largest item @x2@, @x2 \\= x1@, in @lC@ that will
     now fit into @b@ /together/ with @x1@. Remove @x1@ from @lC@. Place both
     @x1@ and @x2@ into @b@ and move on to the next item.

 (4) Reverse the list of bins again.

 (5) Use the 'FirstFit' heuristic to place all remaining items, /i.e./, @lB@,
     @lD@, and any remaining items of @lC@.

References:

 * D.S. Johnson and M.R. Garey. A 71/60 Theorem for Bin-Packing.
   /Journal of Complexity/, 1:65-106, 1985.

 * M. Yue and L. Zhang. 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.
-}

module Data.BinPack ( PlacementPolicy(..)
                    , OrderPolicy (AsGiven, Increasing, Decreasing)
                    , Measure
                    , Bin
                    , allOrders
                    , allPlacements
                    , allHeuristics
                    , 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

-- | What placement heuristic should be used?
data PlacementPolicy = FirstFit           -- ^ Traverse bin list from 'head' to
                                          -- 'last' and place item in the first
                                          -- bin that has sufficient capacity.
                     | ModifiedFirstFit   -- ^ See above.
                     | LastFit            -- ^ Traverse bin list from 'last' to
                                          -- 'head' and place item in the first
                                          -- bin that has sufficient capacity.
                     | BestFit            -- ^ Place item in the bin with the
                                          -- most capacity.
                     | WorstFit           -- ^ Place item in the bin with the
                                          -- least (but sufficient) capacity.
                     | AlmostWorstFit     -- ^ Choose the 2nd to worst-fitting
                                          -- bin.
                       deriving (Show, Eq, Ord)

-- | The list of all possible 'PlacmentPolicy' choices. Useful for benchmarking.
allPlacements :: [PlacementPolicy]
allPlacements = [FirstFit, ModifiedFirstFit, LastFit, BestFit, WorstFit, AlmostWorstFit]

instance Arbitrary PlacementPolicy where
    arbitrary = elements allPlacements

-- | All supported ordering and placment choices. Useful for benchmarking.
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 placment 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

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 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).

Examples:

* Pack the words of the senctene /"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.

  > 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"]])


* Similarly, for 'Int'. Note that we use 'id' as the 'Measure' for the size of an 'Int'. In this case, all bins are full.

  > minimizeBins FirstFit Decreasing id 11 [3,7,10,3,1,3,2,4]
  > ~~> ([0,0,0],[[2,3,3,3],[4,7],[1,10]])

-}

minimizeBins :: (Num a, Ord a) =>
                PlacementPolicy -- ^ How to order the items before placement.
             -> 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'

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

Examples:

* How many bins of size 11 characters each do we need to pack the words of the sentence
/"Bin packing heuristics are a lot of fun!"/?

  > 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'.

  > 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


{- |
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 bins, one of size 10 and one of size 12. Which words can
we fit in there?

> 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"])
-}

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.
        -> [b]                 -- ^ The items.
        -> ([a], [Bin b], [b]) -- ^ The result; a list of residue capacities,
                               -- the bins, and a list of items that could not
                               -- be placed.
binpack fitPol ordPol size capacities items =
    let
        fit       = placement fitPol
        emptyBins = replicate (length capacities) []
        items'    = order ordPol size items
    in
      case fitPol of
        ModifiedFirstFit -> binpackMFF ordPol size capacities emptyBins items'
        _ -> binpack' (fit size) capacities emptyBins items' []

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 y = False
      better x 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
        (c, i) : []      -> Just (insertAt i item s caps bins)
        _ : ((c, 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 (caps, 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

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]