{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.Knapsack.DPSparse
-- Copyright   :  (c) Masahiro Sakai 2015
-- 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.DPSparse
  ( solve
  , solveInt
  , solveInteger
  , solveGeneric
  ) where

import Data.List
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

{-# RULES
"solve/Int"     solve = solveInt
"solve/Integer" solve = solveInteger
  #-}

solve
  :: forall value weight. (Real value, Real weight)
  => [(value, weight)]
  -> weight
  -> (value, weight, [Bool])
solve :: forall value weight.
(Real value, Real weight) =>
[(value, weight)] -> weight -> (value, weight, [Bool])
solve = [(value, weight)] -> weight -> (value, weight, [Bool])
forall value weight.
(Real value, Real weight) =>
[(value, weight)] -> weight -> (value, weight, [Bool])
solveGeneric

solveGeneric
  :: forall value weight. (Real value, Real weight)
  => [(value, weight)]
  -> weight
  -> (value, weight, [Bool])
solveGeneric :: forall value weight.
(Real value, Real weight) =>
[(value, weight)] -> weight -> (value, weight, [Bool])
solveGeneric [(value, weight)]
items weight
limit =
  case Map weight (value, [Bool]) -> (weight, (value, [Bool]))
forall k a. Map k a -> (k, a)
Map.findMax Map weight (value, [Bool])
table of
    (weight
w, (value
v, [Bool]
sol)) -> (value
v, weight
w, [Bool] -> [Bool]
forall a. [a] -> [a]
reverse [Bool]
sol)
  where
    table :: Map weight (value, [Bool])
    table :: Map weight (value, [Bool])
table = (Map weight (value, [Bool])
 -> (value, weight) -> Map weight (value, [Bool]))
-> Map weight (value, [Bool])
-> [(value, weight)]
-> Map weight (value, [Bool])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map weight (value, [Bool])
-> (value, weight) -> Map weight (value, [Bool])
f Map weight (value, [Bool])
empty [(value, weight)]
items

    empty :: Map weight (value, [Bool])
    empty :: Map weight (value, [Bool])
empty = weight -> (value, [Bool]) -> Map weight (value, [Bool])
forall k a. k -> a -> Map k a
Map.singleton weight
0 (value
0,[])

    f :: Map weight (value, [Bool]) -> (value, weight) -> Map weight (value, [Bool])
    f :: Map weight (value, [Bool])
-> (value, weight) -> Map weight (value, [Bool])
f Map weight (value, [Bool])
m (value
vi,weight
wi)
      | weight
wi weight -> weight -> Bool
forall a. Ord a => a -> a -> Bool
< weight
0  = [Char] -> Map weight (value, [Bool])
forall a. HasCallStack => [Char] -> a
error [Char]
"negative weight"
      | value
vi value -> value -> Bool
forall a. Ord a => a -> a -> Bool
<= value
0 = Map weight (value, [Bool])
m0
      | weight
wi weight -> weight -> Bool
forall a. Eq a => a -> a -> Bool
== weight
0 = ((value, [Bool]) -> (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
vvalue -> value -> value
forall a. Num a => a -> a -> a
+value
vi, Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) Map weight (value, [Bool])
m
      | Bool
otherwise = Map weight (value, [Bool]) -> Map weight (value, [Bool])
removeDominated Map weight (value, [Bool])
m2
      where
        m0 :: Map weight (value, [Bool])
m0 = ((value, [Bool]) -> (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
v, Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) Map weight (value, [Bool])
m
        m1 :: Map weight (value, [Bool])
m1 = weight -> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall k v. Ord k => k -> Map k v -> Map k v
splitLE weight
limit (Map weight (value, [Bool]) -> Map weight (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b. (a -> b) -> a -> b
$ (weight -> weight)
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (weight -> weight -> weight
forall a. Num a => a -> a -> a
+weight
wi) (Map weight (value, [Bool]) -> Map weight (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b. (a -> b) -> a -> b
$ ((value, [Bool]) -> (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
vvalue -> value -> value
forall a. Num a => a -> a -> a
+value
vi, Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) (Map weight (value, [Bool]) -> Map weight (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b. (a -> b) -> a -> b
$ Map weight (value, [Bool])
m
        m2 :: Map weight (value, [Bool])
m2 = ((value, [Bool]) -> (value, [Bool]) -> (value, [Bool]))
-> Map weight (value, [Bool])
-> Map weight (value, [Bool])
-> Map weight (value, [Bool])
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\a :: (value, [Bool])
a@(value
v1,[Bool]
_) b :: (value, [Bool])
b@(value
v2,[Bool]
_) -> if value
v1 value -> value -> Bool
forall a. Ord a => a -> a -> Bool
< value
v2 then (value, [Bool])
b else (value, [Bool])
a) Map weight (value, [Bool])
m0 Map weight (value, [Bool])
m1

    removeDominated :: Map weight (value, [Bool]) -> Map weight (value, [Bool])
    removeDominated :: Map weight (value, [Bool]) -> Map weight (value, [Bool])
removeDominated Map weight (value, [Bool])
m = Map weight (value, [Bool])
m2
      where
        m2 :: Map weight (value, [Bool])
m2 = [(weight, (value, [Bool]))] -> Map weight (value, [Bool])
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(weight, (value, [Bool]))] -> Map weight (value, [Bool]))
-> (Map weight (value, [Bool]) -> [(weight, (value, [Bool]))])
-> Map weight (value, [Bool])
-> Map weight (value, [Bool])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> [(weight, (value, [Bool]))] -> [(weight, (value, [Bool]))]
forall {t} {a} {b}. Ord t => t -> [(a, (t, b))] -> [(a, (t, b))]
loop (-value
1) ([(weight, (value, [Bool]))] -> [(weight, (value, [Bool]))])
-> (Map weight (value, [Bool]) -> [(weight, (value, [Bool]))])
-> Map weight (value, [Bool])
-> [(weight, (value, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map weight (value, [Bool]) -> [(weight, (value, [Bool]))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map weight (value, [Bool]) -> Map weight (value, [Bool]))
-> Map weight (value, [Bool]) -> Map weight (value, [Bool])
forall a b. (a -> b) -> a -> b
$ Map weight (value, [Bool])
m
        loop :: t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
_ [] = []
        loop !t
vmax (x :: (a, (t, b))
x@(a
_,(t
v1,b
_)) : [(a, (t, b))]
xs)
          | t
vmax t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
v1 = (a, (t, b))
x (a, (t, b)) -> [(a, (t, b))] -> [(a, (t, b))]
forall a. a -> [a] -> [a]
: t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
v1 [(a, (t, b))]
xs
          | Bool
otherwise = t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
vmax [(a, (t, b))]
xs

    splitLE :: Ord k => k -> Map k v -> Map k v
    splitLE :: forall k v. Ord k => k -> Map k v -> Map k v
splitLE k
k Map k v
m =
      case k -> Map k v -> (Map k v, Maybe v, Map k v)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup k
k Map k v
m of
        (Map k v
lo, Maybe v
Nothing, Map k v
_) -> Map k v
lo
        (Map k v
lo, Just v
v, Map k v
_) -> k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k v
v Map k v
lo

solveInt
  :: forall value. (Real value)
  => [(value, Int)]
  -> Int
  -> (value, Int, [Bool])
solveInt :: forall value.
Real value =>
[(value, Int)] -> Int -> (value, Int, [Bool])
solveInt [(value, Int)]
items Int
limit =
  case IntMap (value, [Bool]) -> (Int, (value, [Bool]))
forall a. IntMap a -> (Int, a)
IntMap.findMax IntMap (value, [Bool])
table of
    (Int
w, (value
v, [Bool]
sol)) -> (value
v, Int
w, [Bool] -> [Bool]
forall a. [a] -> [a]
reverse [Bool]
sol)
  where
    table :: IntMap (value, [Bool])
    table :: IntMap (value, [Bool])
table = (IntMap (value, [Bool]) -> (value, Int) -> IntMap (value, [Bool]))
-> IntMap (value, [Bool])
-> [(value, Int)]
-> IntMap (value, [Bool])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap (value, [Bool]) -> (value, Int) -> IntMap (value, [Bool])
f IntMap (value, [Bool])
empty [(value, Int)]
items

    empty :: IntMap (value, [Bool])
    empty :: IntMap (value, [Bool])
empty = Int -> (value, [Bool]) -> IntMap (value, [Bool])
forall a. Int -> a -> IntMap a
IntMap.singleton Int
0 (value
0,[])

    f :: IntMap (value, [Bool]) -> (value, Int) -> IntMap (value, [Bool])
    f :: IntMap (value, [Bool]) -> (value, Int) -> IntMap (value, [Bool])
f IntMap (value, [Bool])
m (value
vi,Int
wi)
      | Int
wi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = [Char] -> IntMap (value, [Bool])
forall a. HasCallStack => [Char] -> a
error [Char]
"negative weight"
      | value
vi value -> value -> Bool
forall a. Ord a => a -> a -> Bool
<= value
0 = IntMap (value, [Bool])
m0
      | Int
wi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ((value, [Bool]) -> (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
vvalue -> value -> value
forall a. Num a => a -> a -> a
+value
vi, Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) IntMap (value, [Bool])
m
      | Bool
otherwise = IntMap (value, [Bool]) -> IntMap (value, [Bool])
removeDominated IntMap (value, [Bool])
m2
      where
        m0 :: IntMap (value, [Bool])
m0 = ((value, [Bool]) -> (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
v, Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) IntMap (value, [Bool])
m
        m1 :: IntMap (value, [Bool])
m1 = Int -> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall v. Int -> IntMap v -> IntMap v
splitLE Int
limit (IntMap (value, [Bool]) -> IntMap (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
wi) (IntMap (value, [Bool]) -> IntMap (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> a -> b
$ ((value, [Bool]) -> (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
vvalue -> value -> value
forall a. Num a => a -> a -> a
+value
vi, Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
sol)) (IntMap (value, [Bool]) -> IntMap (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> a -> b
$ IntMap (value, [Bool])
m
        m2 :: IntMap (value, [Bool])
m2 = ((value, [Bool]) -> (value, [Bool]) -> (value, [Bool]))
-> IntMap (value, [Bool])
-> IntMap (value, [Bool])
-> IntMap (value, [Bool])
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith (\a :: (value, [Bool])
a@(value
v1,[Bool]
_) b :: (value, [Bool])
b@(value
v2,[Bool]
_) -> if value
v1 value -> value -> Bool
forall a. Ord a => a -> a -> Bool
< value
v2 then (value, [Bool])
b else (value, [Bool])
a) IntMap (value, [Bool])
m0 IntMap (value, [Bool])
m1

    removeDominated :: IntMap (value, [Bool]) -> IntMap (value, [Bool])
    removeDominated :: IntMap (value, [Bool]) -> IntMap (value, [Bool])
removeDominated IntMap (value, [Bool])
m = IntMap (value, [Bool])
m2
      where
        m2 :: IntMap (value, [Bool])
m2 = [(Int, (value, [Bool]))] -> IntMap (value, [Bool])
forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList ([(Int, (value, [Bool]))] -> IntMap (value, [Bool]))
-> (IntMap (value, [Bool]) -> [(Int, (value, [Bool]))])
-> IntMap (value, [Bool])
-> IntMap (value, [Bool])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. value -> [(Int, (value, [Bool]))] -> [(Int, (value, [Bool]))]
forall {t} {a} {b}. Ord t => t -> [(a, (t, b))] -> [(a, (t, b))]
loop (-value
1) ([(Int, (value, [Bool]))] -> [(Int, (value, [Bool]))])
-> (IntMap (value, [Bool]) -> [(Int, (value, [Bool]))])
-> IntMap (value, [Bool])
-> [(Int, (value, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (value, [Bool]) -> [(Int, (value, [Bool]))]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList (IntMap (value, [Bool]) -> IntMap (value, [Bool]))
-> IntMap (value, [Bool]) -> IntMap (value, [Bool])
forall a b. (a -> b) -> a -> b
$ IntMap (value, [Bool])
m
        loop :: t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
_ [] = []
        loop !t
vmax (x :: (a, (t, b))
x@(a
_,(t
v1,b
_)) : [(a, (t, b))]
xs)
          | t
vmax t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
v1 = (a, (t, b))
x (a, (t, b)) -> [(a, (t, b))] -> [(a, (t, b))]
forall a. a -> [a] -> [a]
: t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
v1 [(a, (t, b))]
xs
          | Bool
otherwise = t -> [(a, (t, b))] -> [(a, (t, b))]
loop t
vmax [(a, (t, b))]
xs

    splitLE :: Int -> IntMap v -> IntMap v
    splitLE :: forall v. Int -> IntMap v -> IntMap v
splitLE Int
k IntMap v
m
      | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound = IntMap v
m
      | Bool
otherwise =
          case Int -> IntMap v -> (IntMap v, Maybe v, IntMap v)
forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IntMap.splitLookup (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) IntMap v
m of
            (IntMap v
lo, Maybe v
_, IntMap v
_) -> IntMap v
lo

solveInteger
  :: forall value. (Real value)
  => [(value, Integer)]
  -> Integer
  -> (value, Integer, [Bool])
solveInteger :: forall value.
Real value =>
[(value, Integer)] -> Integer -> (value, Integer, [Bool])
solveInteger [(value, Integer)]
items Integer
limit
  | ((value, Integer) -> Bool) -> [(value, Integer)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(value
_,Integer
w) -> Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxInt) [(value, Integer)]
items' Bool -> Bool -> Bool
&& Integer
limit' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxInt =
      case [(value, Int)] -> Int -> (value, Int, [Bool])
forall value.
Real value =>
[(value, Int)] -> Int -> (value, Int, [Bool])
solveInt [(value
v, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) | (value
v,Integer
w) <- [(value, Integer)]
items'] (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
limit') of
        (value
v, Int
w, [Bool]
sol) -> (value
v, Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
d, [Bool]
sol)
  | Bool
otherwise =
      case [(value, Integer)] -> Integer -> (value, Integer, [Bool])
forall value weight.
(Real value, Real weight) =>
[(value, weight)] -> weight -> (value, weight, [Bool])
solveGeneric [(value, Integer)]
items' Integer
limit' of
        (value
v, Integer
w, [Bool]
sol) -> (value
v, Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
d, [Bool]
sol)
  where
    d :: Integer
d = if [(value, Integer)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(value, Integer)]
items then Integer
1 else (Integer -> Integer -> Integer) -> [Integer] -> Integer
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd [Integer
w | (value
_v, Integer
w) <- [(value, Integer)]
items]
    items' :: [(value, Integer)]
items' = [(value
v, Integer
w Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d) | (value
v, Integer
w) <- [(value, Integer)]
items]
    limit' :: Integer
limit' = Integer
limit Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d
    maxInt :: Integer
maxInt = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)