{-# 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 = 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 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, forall a. [a] -> [a]
reverse [Bool]
sol)
  where
    table :: Map weight (value, [Bool])
    table :: Map weight (value, [Bool])
table = 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 = 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 forall a. Ord a => a -> a -> Bool
< weight
0  = forall a. HasCallStack => [Char] -> a
error [Char]
"negative weight"
      | value
vi forall a. Ord a => a -> a -> Bool
<= value
0 = Map weight (value, [Bool])
m0
      | weight
wi forall a. Eq a => a -> a -> Bool
== weight
0 = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
vforall a. Num a => a -> a -> a
+value
vi, Bool
True 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 = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
v, Bool
False forall a. a -> [a] -> [a]
: [Bool]
sol)) Map weight (value, [Bool])
m
        m1 :: Map weight (value, [Bool])
m1 = forall k v. Ord k => k -> Map k v -> Map k v
splitLE weight
limit forall a b. (a -> b) -> a -> b
$ forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (forall a. Num a => a -> a -> a
+weight
wi) forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(value
v,[Bool]
sol) -> (value
vforall a. Num a => a -> a -> a
+value
vi, Bool
True forall a. a -> [a] -> [a]
: [Bool]
sol)) forall a b. (a -> b) -> a -> b
$ Map weight (value, [Bool])
m
        m2 :: Map weight (value, [Bool])
m2 = 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 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 = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {a} {b}. Ord t => t -> [(a, (t, b))] -> [(a, (t, b))]
loop (-value
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList 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 forall a. Ord a => a -> a -> Bool
< t
v1 = (a, (t, b))
x 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 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
_) -> 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 forall a. IntMap a -> (Int, a)
IntMap.findMax IntMap (value, [Bool])
table of
    (Int
w, (value
v, [Bool]
sol)) -> (value
v, Int
w, forall a. [a] -> [a]
reverse [Bool]
sol)
  where
    table :: IntMap (value, [Bool])
    table :: IntMap (value, [Bool])
table = 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 = 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 forall a. Ord a => a -> a -> Bool
< Int
0  = forall a. HasCallStack => [Char] -> a
error [Char]
"negative weight"
      | value
vi forall a. Ord a => a -> a -> Bool
<= value
0 = IntMap (value, [Bool])
m0
      | Int
wi forall a. Eq a => a -> a -> Bool
== Int
0 = forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
vforall a. Num a => a -> a -> a
+value
vi, Bool
True 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 = forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
v, Bool
False forall a. a -> [a] -> [a]
: [Bool]
sol)) IntMap (value, [Bool])
m
        m1 :: IntMap (value, [Bool])
m1 = forall v. Int -> IntMap v -> IntMap v
splitLE Int
limit forall a b. (a -> b) -> a -> b
$ forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (forall a. Num a => a -> a -> a
+Int
wi) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\(value
v,[Bool]
sol) -> (value
vforall a. Num a => a -> a -> a
+value
vi, Bool
True forall a. a -> [a] -> [a]
: [Bool]
sol)) forall a b. (a -> b) -> a -> b
$ IntMap (value, [Bool])
m
        m2 :: IntMap (value, [Bool])
m2 = 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 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 = forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {a} {b}. Ord t => t -> [(a, (t, b))] -> [(a, (t, b))]
loop (-value
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IntMap.toAscList 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 forall a. Ord a => a -> a -> Bool
< t
v1 = (a, (t, b))
x 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 forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound = IntMap v
m
      | Bool
otherwise =
          case forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IntMap.splitLookup (Int
kforall 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
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(value
_,Integer
w) -> Integer
w forall a. Ord a => a -> a -> Bool
<= Integer
maxInt) [(value, Integer)]
items' Bool -> Bool -> Bool
&& Integer
limit' forall a. Ord a => a -> a -> Bool
<= Integer
maxInt =
      case forall value.
Real value =>
[(value, Int)] -> Int -> (value, Int, [Bool])
solveInt [(value
v, forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) | (value
v,Integer
w) <- [(value, Integer)]
items'] (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
limit') of
        (value
v, Int
w, [Bool]
sol) -> (value
v, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w forall a. Num a => a -> a -> a
* Integer
d, [Bool]
sol)
  | Bool
otherwise =
      case 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 forall a. Num a => a -> a -> a
* Integer
d, [Bool]
sol)
  where
    d :: Integer
d = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(value, Integer)]
items then Integer
1 else forall a. (a -> a -> a) -> [a] -> a
foldl1' 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 forall a. Integral a => a -> a -> a
`div` Integer
d) | (value
v, Integer
w) <- [(value, Integer)]
items]
    limit' :: Integer
limit' = Integer
limit forall a. Integral a => a -> a -> a
`div` Integer
d
    maxInt :: Integer
maxInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)