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