{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.Knapsack.BB
-- Copyright   :  (c) Masahiro Sakai 2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Simple 0-1 knapsack problem solver that uses branch-and-bound with LP-relaxation based upper bound.
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.Knapsack.BB
  ( Weight
  , Value
  , solve
  ) where

import Control.Monad.State.Strict
import Data.Function (on)
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List

type Weight = Rational
type Value  = Rational

solve
  :: [(Value, Weight)]
  -> Weight
  -> (Value, Weight, [Bool])
solve :: [(Value, Value)] -> Value -> (Value, Value, [Bool])
solve [(Value, Value)]
items Value
limit =
  ( forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Value
v | (Int
n,(Value
v,Value
_)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items, Int
n Int -> IntSet -> Bool
`IntSet.member` IntSet
sol]
  , forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Value
w | (Int
n,(Value
_,Value
w)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items, Int
n Int -> IntSet -> Bool
`IntSet.member` IntSet
sol]
  , [Int
n Int -> IntSet -> Bool
`IntSet.member` IntSet
sol | (Int
n,(Value, Value)
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items]
  )
  where
    items' :: [(Value, Weight, Int)]
    items' :: [(Value, Value, Int)]
items' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [((Value
v, Value
w, Int
n), (Value
v forall a. Fractional a => a -> a -> a
/ Value
w, Value
v)) | (Int
n, (Value
v, Value
w)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items, Value
w forall a. Ord a => a -> a -> Bool
> Value
0, Value
v forall a. Ord a => a -> a -> Bool
> Value
0]

    sol :: IntSet
    sol :: IntSet
sol = [Int] -> IntSet
IntSet.fromList [Int
n | (Int
n, (Value
v, Value
w)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items, Value
w forall a. Eq a => a -> a -> Bool
== Value
0, Value
v forall a. Ord a => a -> a -> Bool
> Value
0] IntSet -> IntSet -> IntSet
`IntSet.union`
          [Int] -> IntSet
IntSet.fromList (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState ([(Value, Value, Int)]
-> Value -> ([Int], Value) -> State ([Int], Value) ()
f [(Value, Value, Int)]
items' Value
limit ([],Value
0)) ([],Value
0))

    f :: [(Value, Weight, Int)] -> Weight -> ([Int],Value) -> State ([Int],Value) ()
    f :: [(Value, Value, Int)]
-> Value -> ([Int], Value) -> State ([Int], Value) ()
f [(Value, Value, Int)]
items !Value
slack ([Int]
is, !Value
value) = do
      ([Int]
_, Value
bestVal) <- forall s (m :: * -> *). MonadState s m => m s
get
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Value, Value, Int)] -> Value -> Value -> Value
computeUB [(Value, Value, Int)]
items Value
slack Value
value forall a. Ord a => a -> a -> Bool
> Value
bestVal) forall a b. (a -> b) -> a -> b
$ do
        case [(Value, Value, Int)]
items of
          [] -> forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Int]
is,Value
value)
          (Value
v,Value
w,Int
i):[(Value, Value, Int)]
items -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
slack forall a. Ord a => a -> a -> Bool
>= Value
w) forall a b. (a -> b) -> a -> b
$ [(Value, Value, Int)]
-> Value -> ([Int], Value) -> State ([Int], Value) ()
f [(Value, Value, Int)]
items (Value
slack forall a. Num a => a -> a -> a
- Value
w) (Int
i forall a. a -> [a] -> [a]
: [Int]
is, Value
v forall a. Num a => a -> a -> a
+ Value
value)
            -- Drop all indistingushable items for symmetry breaking
            [(Value, Value, Int)]
-> Value -> ([Int], Value) -> State ([Int], Value) ()
f (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(Value
v',Value
w',Int
_) -> Value
vforall a. Eq a => a -> a -> Bool
==Value
v' Bool -> Bool -> Bool
&& Value
wforall a. Eq a => a -> a -> Bool
==Value
w') [(Value, Value, Int)]
items) Value
slack ([Int]
is, Value
value)

    computeUB :: [(Value, Weight, Int)] -> Weight -> Value -> Value
    computeUB :: [(Value, Value, Int)] -> Value -> Value -> Value
computeUB [(Value, Value, Int)]
items Value
slack Value
value = forall {t} {c}. (Ord t, Fractional t) => [(t, t, c)] -> t -> t -> t
go [(Value, Value, Int)]
items Value
slack Value
value
      where
        go :: [(t, t, c)] -> t -> t -> t
go [(t, t, c)]
_ t
0 t
val  = t
val
        go [] t
_ t
val = t
val
        go ((t
v,t
w,c
_):[(t, t, c)]
items) t
slack t
val
          | t
slack forall a. Ord a => a -> a -> Bool
>= t
w = [(t, t, c)] -> t -> t -> t
go [(t, t, c)]
items (t
slack forall a. Num a => a -> a -> a
- t
w) (t
val forall a. Num a => a -> a -> a
+ t
v)
          | Bool
otherwise   = t
val forall a. Num a => a -> a -> a
+ (t
v forall a. Fractional a => a -> a -> a
/ t
w) forall a. Num a => a -> a -> a
* t
slack