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

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

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

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