{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
[(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