{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.Knapsack.DPDense
-- 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 DP.
--
-----------------------------------------------------------------------------
module ToySolver.Combinatorial.Knapsack.DPDense
  ( Weight
  , Value
  , solve
  ) where

import Control.Exception (assert)
import Control.Loop
import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.Function (on)
import Data.List

type Weight = Int
type Value = Rational

solve
  :: [(Value, Weight)]
  -> Weight
  -> (Value, Weight, [Bool])
solve :: [(Value, Weight)] -> Weight -> (Value, Weight, [Bool])
solve [(Value, Weight)]
items Weight
limit = (forall s. ST s (Value, Weight, [Bool])) -> (Value, Weight, [Bool])
forall a. (forall s. ST s a) -> a
runST forall s. ST s (Value, Weight, [Bool])
m
  where
    m :: forall s. ST s (Value, Weight, [Bool])
    m :: ST s (Value, Weight, [Bool])
m = do
      (STArray s Weight (Value, Weight, [Bool])
table :: STArray s Weight (Value, Weight, [Bool])) <- (Weight, Weight)
-> (Value, Weight, [Bool])
-> ST s (STArray s Weight (Value, Weight, [Bool]))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Weight
0, Weight
limit)  (Value
0,Weight
0,[])
      [(Value, Weight)] -> ((Value, Weight) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Value, Weight)]
items (((Value, Weight) -> ST s ()) -> ST s ())
-> ((Value, Weight) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Value
v,Weight
w) -> do
        Weight
-> (Weight -> Bool)
-> (Weight -> Weight)
-> (Weight -> ST s ())
-> ST s ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Weight
limit (Weight -> Weight -> Bool
forall a. Ord a => a -> a -> Bool
>=Weight
0) (Weight -> Weight -> Weight
forall a. Num a => a -> a -> a
subtract Weight
1) ((Weight -> ST s ()) -> ST s ()) -> (Weight -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Weight
c -> do
          Bool -> ST s () -> ST s ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Weight
w Weight -> Weight -> Bool
forall a. Ord a => a -> a -> Bool
>= Weight
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          if Weight
w Weight -> Weight -> Bool
forall a. Ord a => a -> a -> Bool
<= Weight
c then do
            (Value
obj1, Weight
w1, [Bool]
sol1) <- STArray s Weight (Value, Weight, [Bool])
-> Weight -> ST s (Value, Weight, [Bool])
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Weight (Value, Weight, [Bool])
table Weight
c
            (Value
obj2, Weight
w2, [Bool]
sol2) <- STArray s Weight (Value, Weight, [Bool])
-> Weight -> ST s (Value, Weight, [Bool])
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Weight (Value, Weight, [Bool])
table (Weight
c Weight -> Weight -> Weight
forall a. Num a => a -> a -> a
- Weight
w)
            Weight -> ST s () -> ST s ()
seq Weight
w1 (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ Weight -> ST s () -> ST s ()
seq Weight
w2 (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- XXX
            if Value
v Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
>= Value
0 Bool -> Bool -> Bool
&& Value
obj2 Value -> Value -> Value
forall a. Num a => a -> a -> a
+ Value
v Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
> Value
obj1 then do
              STArray s Weight (Value, Weight, [Bool])
-> Weight -> (Value, Weight, [Bool]) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Weight (Value, Weight, [Bool])
table Weight
c (Value
obj2 Value -> Value -> Value
forall a. Num a => a -> a -> a
+ Value
v, Weight
w2 Weight -> Weight -> Weight
forall a. Num a => a -> a -> a
+ Weight
w, Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol2)
            else
              STArray s Weight (Value, Weight, [Bool])
-> Weight -> (Value, Weight, [Bool]) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Weight (Value, Weight, [Bool])
table Weight
c (Value
obj1, Weight
w1, Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol1)
          else do
            (Value
obj1, Weight
w1, [Bool]
sol1) <- STArray s Weight (Value, Weight, [Bool])
-> Weight -> ST s (Value, Weight, [Bool])
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Weight (Value, Weight, [Bool])
table Weight
c
            STArray s Weight (Value, Weight, [Bool])
-> Weight -> (Value, Weight, [Bool]) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Weight (Value, Weight, [Bool])
table Weight
c (Value
obj1, Weight
w1, Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol1)
      (Value
obj, Weight
w, [Bool]
sol) <- STArray s Weight (Value, Weight, [Bool])
-> Weight -> ST s (Value, Weight, [Bool])
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Weight (Value, Weight, [Bool])
table Weight
limit
      (Value, Weight, [Bool]) -> ST s (Value, Weight, [Bool])
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
obj, Weight
w, [Bool] -> [Bool]
forall a. [a] -> [a]
reverse [Bool]
sol)

test1 :: (Value, Weight, [Bool])
test1 = [(Value, Weight)] -> Weight -> (Value, Weight, [Bool])
solve [(Value
5,Weight
4), (Value
4,Weight
5), (Value
3,Weight
2)] Weight
9
test2 :: (Value, Weight, [Bool])
test2 = [(Value, Weight)] -> Weight -> (Value, Weight, [Bool])
solve [(Value
45,Weight
5), (Value
48,Weight
8), (Value
35,Weight
3)] Weight
10