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