{-# 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
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 a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Value
v | (Int
n,(Value
v,Value
_)) <- [Int] -> [(Value, Value)] -> [(Int, (Value, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Value, Value)]
items, Int
n Int -> IntSet -> Bool
`IntSet.member` IntSet
sol]
  , [Value] -> Value
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Value
w | (Int
n,(Value
_,Value
w)) <- [Int] -> [(Value, Value)] -> [(Int, (Value, Value))]
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)
_) <- [Int] -> [(Value, Value)] -> [(Int, (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' = (((Value, Value, Int), (Value, Value)) -> (Value, Value, Int))
-> [((Value, Value, Int), (Value, Value))] -> [(Value, Value, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Value, Value, Int), (Value, Value)) -> (Value, Value, Int)
forall a b. (a, b) -> a
fst ([((Value, Value, Int), (Value, Value))] -> [(Value, Value, Int)])
-> [((Value, Value, Int), (Value, Value))] -> [(Value, Value, Int)]
forall a b. (a -> b) -> a -> b
$ (((Value, Value, Int), (Value, Value))
 -> ((Value, Value, Int), (Value, Value)) -> Ordering)
-> [((Value, Value, Int), (Value, Value))]
-> [((Value, Value, Int), (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, Int), (Value, Value)) -> (Value, Value))
-> ((Value, Value, Int), (Value, Value))
-> ((Value, Value, Int), (Value, Value))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Value, Value, Int), (Value, Value)) -> (Value, Value)
forall a b. (a, b) -> b
snd) [((Value
v, Value
w, Int
n), (Value
v Value -> Value -> Value
forall a. Fractional a => a -> a -> a
/ Value
w, Value
v)) | (Int
n, (Value
v, Value
w)) <- [Int] -> [(Value, Value)] -> [(Int, (Value, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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 = [Int] -> IntSet
IntSet.fromList [Int
n | (Int
n, (Value
v, Value
w)) <- [Int] -> [(Value, Value)] -> [(Int, (Value, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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`
          [Int] -> IntSet
IntSet.fromList (([Int], Value) -> [Int]
forall a b. (a, b) -> a
fst (([Int], Value) -> [Int]) -> ([Int], Value) -> [Int]
forall a b. (a -> b) -> a -> b
$ State ([Int], Value) () -> ([Int], Value) -> ([Int], Value)
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) <- StateT ([Int], Value) Identity ([Int], Value)
forall s (m :: * -> *). MonadState s m => m s
get
      Bool -> State ([Int], Value) () -> State ([Int], Value) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Value, Value, Int)] -> Value -> Value -> Value
computeUB [(Value, Value, Int)]
items Value
slack Value
value Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
> Value
bestVal) (State ([Int], Value) () -> State ([Int], Value) ())
-> State ([Int], Value) () -> State ([Int], Value) ()
forall a b. (a -> b) -> a -> b
$ do
        case [(Value, Value, Int)]
items of
          [] -> ([Int], Value) -> State ([Int], Value) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Int]
is,Value
value)
          (Value
v,Value
w,Int
i):[(Value, Value, Int)]
items -> do
            Bool -> State ([Int], Value) () -> State ([Int], Value) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
slack Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
>= Value
w) (State ([Int], Value) () -> State ([Int], Value) ())
-> State ([Int], Value) () -> State ([Int], Value) ()
forall a b. (a -> b) -> a -> b
$ [(Value, Value, Int)]
-> Value -> ([Int], Value) -> State ([Int], Value) ()
f [(Value, Value, Int)]
items (Value
slack Value -> Value -> Value
forall a. Num a => a -> a -> a
- Value
w) (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is, Value
v Value -> Value -> Value
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 (((Value, Value, Int) -> Bool)
-> [(Value, Value, Int)] -> [(Value, Value, Int)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(Value
v',Value
w',Int
_) -> 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, 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 = [(Value, Value, Int)] -> Value -> 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 t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
w = [(t, t, c)] -> t -> t -> t
go [(t, t, c)]
items (t
slack t -> t -> t
forall a. Num a => a -> a -> a
- t
w) (t
val t -> t -> t
forall a. Num a => a -> a -> a
+ t
v)
          | Bool
otherwise   = t
val t -> t -> t
forall a. Num a => a -> a -> a
+ (t
v t -> t -> t
forall a. Fractional a => a -> a -> a
/ t
w) t -> t -> t
forall a. Num a => a -> a -> a
* t
slack