{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module ToySolver.Combinatorial.SubsetSum
( Weight
, subsetSum
, maxSubsetSum
, minSubsetSum
) where
import Control.Exception (assert)
import Control.Monad
import Control.Monad.ST
import Data.STRef
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Vector.Generic ((!))
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VM
import qualified Data.Vector.Unboxed as VU
type Weight = Integer
maxSubsetSum
:: VG.Vector v Weight
=> v Weight
-> Weight
-> Maybe (Weight, VU.Vector Bool)
maxSubsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
maxSubsetSum v Integer
w Integer
c =
case forall (v :: * -> *).
Vector v Integer =>
(v Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeWeightsToPositive (v Integer
w,Integer
c) of
(Vector Integer
w1, Integer
c1, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1)
| Integer
c1 forall a. Ord a => a -> a -> Bool
< Integer
0 -> forall a. Maybe a
Nothing
| Bool
otherwise ->
case (Vector Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalize2 (Vector Integer
w1, Integer
c1) of
(Vector Integer
w2, Integer
c2, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2) ->
case (Vector Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeGCDLe (Vector Integer
w2, Integer
c2) of
(Vector Integer
w3, Integer
c3, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3) ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1 forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2 forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3 forall a b. (a -> b) -> a -> b
$ Vector Integer -> Integer -> (Integer, Vector Bool)
maxSubsetSum' Vector Integer
w3 Integer
c3
normalizeWeightsToPositive
:: VG.Vector v Weight
=> (v Weight, Weight)
-> (V.Vector Weight, Weight, (Weight, VU.Vector Bool) -> (Weight, VU.Vector Bool))
normalizeWeightsToPositive :: forall (v :: * -> *).
Vector v Integer =>
(v Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeWeightsToPositive (v Integer
w,Integer
c)
| forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
VG.all (forall a. Ord a => a -> a -> Bool
>=Integer
0) v Integer
w = (forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
VG.convert v Integer
w, Integer
c, forall a. a -> a
id)
| Bool
otherwise = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MVector (PrimState (ST s)) Integer
w2 <- forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new (forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length v Integer
w)
let loop :: Int -> Integer -> ST s Integer
loop !Int
i !Integer
offset
| Int
i forall a. Ord a => a -> a -> Bool
>= forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length v Integer
w = forall (m :: * -> *) a. Monad m => a -> m a
return Integer
offset
| Bool
otherwise = do
let wi :: Integer
wi = v Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
i
if Integer
wi forall a. Ord a => a -> a -> Bool
< Integer
0 then do
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) Integer
w2 Int
i (- Integer
wi)
Int -> Integer -> ST s Integer
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) (Integer
offset forall a. Num a => a -> a -> a
+ Integer
wi)
else do
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) Integer
w2 Int
i Integer
wi
Int -> Integer -> ST s Integer
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) Integer
offset
Integer
offset <- Int -> Integer -> ST s Integer
loop Int
0 (Integer
0::Integer)
Vector Integer
w2' <- forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
VG.unsafeFreeze MVector (PrimState (ST s)) Integer
w2
let trans :: (Integer, Vector Bool) -> (Integer, Vector Bool)
trans (Integer
obj, Vector Bool
bs) = (Integer
obj forall a. Num a => a -> a -> a
+ Integer
offset, Vector Bool
bs2)
where
bs2 :: Vector Bool
bs2 = forall a b.
(Unbox a, Unbox b) =>
(Int -> a -> b) -> Vector a -> Vector b
VU.imap (\Int
i Bool
bi -> if v Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
i forall a. Ord a => a -> a -> Bool
< Integer
0 then Bool -> Bool
not Bool
bi else Bool
bi) Vector Bool
bs
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Integer
w2', Integer
c forall a. Num a => a -> a -> a
- Integer
offset, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans)
normalize2
:: (V.Vector Weight, Weight)
-> (V.Vector Weight, Weight, (Weight, VU.Vector Bool) -> (Weight, VU.Vector Bool))
normalize2 :: (Vector Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalize2 (Vector Integer
w,Integer
c)
| forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
VG.all (\Integer
wi -> Integer
0forall a. Ord a => a -> a -> Bool
<Integer
wi Bool -> Bool -> Bool
&& Integer
wiforall a. Ord a => a -> a -> Bool
<=Integer
c) Vector Integer
w = (Vector Integer
w, Integer
c, forall a. a -> a
id)
| Bool
otherwise = (forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> v a
VG.filter (\Integer
wi -> Integer
0forall a. Ord a => a -> a -> Bool
<Integer
wi Bool -> Bool -> Bool
&& Integer
wiforall a. Ord a => a -> a -> Bool
<=Integer
c) Vector Integer
w, Integer
c, forall {v :: * -> *} {a}.
Vector v Bool =>
(a, v Bool) -> (a, Vector Bool)
trans)
where
trans :: (a, v Bool) -> (a, Vector Bool)
trans (a
obj, v Bool
bs) = (a
obj, Vector Bool
bs2)
where
bs2 :: Vector Bool
bs2 = forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
VU.create forall a b. (a -> b) -> a -> b
$ do
MVector (PrimState (ST s)) Bool
v <- forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new (forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w)
let loop :: Int -> Int -> ST s ()
loop !Int
i !Int
j =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
< forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) forall a b. (a -> b) -> a -> b
$ do
let wi :: Integer
wi = Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
i
if Integer
0 forall a. Ord a => a -> a -> Bool
< Integer
wi Bool -> Bool -> Bool
&& Integer
wi forall a. Ord a => a -> a -> Bool
<= Integer
c then do
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) Bool
v Int
i (v Bool
bs forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
j)
Int -> Int -> ST s ()
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) (Int
jforall a. Num a => a -> a -> a
+Int
1)
else do
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) Bool
v Int
i Bool
False
Int -> Int -> ST s ()
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) Int
j
Int -> Int -> ST s ()
loop Int
0 Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return MVector (PrimState (ST s)) Bool
v
normalizeGCDLe
:: (V.Vector Weight, Weight)
-> (V.Vector Weight, Weight, (Weight, VU.Vector Bool) -> (Weight, VU.Vector Bool))
normalizeGCDLe :: (Vector Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeGCDLe (Vector Integer
w,Integer
c)
| forall (v :: * -> *) a. Vector v a => v a -> Bool
VG.null Vector Integer
w Bool -> Bool -> Bool
|| Integer
d forall a. Eq a => a -> a -> Bool
== Integer
1 = (Vector Integer
w, Integer
c, forall a. a -> a
id)
| Bool
otherwise = (forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
VG.map (forall a. Integral a => a -> a -> a
`div` Integer
d) Vector Integer
w, Integer
c forall a. Integral a => a -> a -> a
`div` Integer
d, forall {b}. (Integer, b) -> (Integer, b)
trans)
where
d :: Integer
d = forall (v :: * -> *) a. Vector v a => (a -> a -> a) -> v a -> a
VG.foldl1' forall a. Integral a => a -> a -> a
gcd Vector Integer
w
trans :: (Integer, b) -> (Integer, b)
trans (Integer
obj, b
bs) = (Integer
obj forall a. Num a => a -> a -> a
* Integer
d, b
bs)
normalizeGCDEq
:: (V.Vector Weight, Weight)
-> Maybe (V.Vector Weight, Weight, (Weight, VU.Vector Bool) -> (Weight, VU.Vector Bool))
normalizeGCDEq :: (Vector Integer, Integer)
-> Maybe
(Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeGCDEq (Vector Integer
w,Integer
c)
| forall (v :: * -> *) a. Vector v a => v a -> Bool
VG.null Vector Integer
w Bool -> Bool -> Bool
|| Integer
d forall a. Eq a => a -> a -> Bool
== Integer
1 = forall a. a -> Maybe a
Just (Vector Integer
w, Integer
c, forall a. a -> a
id)
| Integer
c forall a. Integral a => a -> a -> a
`mod` Integer
d forall a. Eq a => a -> a -> Bool
== Integer
0 = forall a. a -> Maybe a
Just (forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
VG.map (forall a. Integral a => a -> a -> a
`div` Integer
d) Vector Integer
w, Integer
c forall a. Integral a => a -> a -> a
`div` Integer
d, forall {b}. (Integer, b) -> (Integer, b)
trans)
| Bool
otherwise = forall a. Maybe a
Nothing
where
d :: Integer
d = forall (v :: * -> *) a. Vector v a => (a -> a -> a) -> v a -> a
VG.foldl1' forall a. Integral a => a -> a -> a
gcd Vector Integer
w
trans :: (Integer, b) -> (Integer, b)
trans (Integer
obj, b
bs) = (Integer
obj forall a. Num a => a -> a -> a
* Integer
d, b
bs)
maxSubsetSum' :: V.Vector Weight -> Weight -> (Weight, VU.Vector Bool)
maxSubsetSum' :: Vector Integer -> Integer -> (Integer, Vector Bool)
maxSubsetSum' !Vector Integer
w !Integer
c
| Integer
wsum forall a. Ord a => a -> a -> Bool
<= Integer
c = (Integer
wsum, forall (v :: * -> *) a. Vector v a => Int -> a -> v a
VG.replicate (forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) Bool
True)
| Integer
c forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int) =
Vector Int -> Int -> Integer -> (Integer, Vector Bool)
maxSubsetSumInt' (forall (v :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
VG.generate (forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) (\Int
i -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
VG.! Int
i))) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
c) Integer
wsum
| Bool
otherwise =
Vector Integer -> Integer -> Integer -> (Integer, Vector Bool)
maxSubsetSumInteger' Vector Integer
w Integer
c Integer
wsum
where
wsum :: Integer
wsum = forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum Vector Integer
w
maxSubsetSumInteger' :: V.Vector Weight -> Weight -> Weight -> (Weight, VU.Vector Bool)
maxSubsetSumInteger' :: Vector Integer -> Integer -> Integer -> (Integer, Vector Bool)
maxSubsetSumInteger' Vector Integer
w !Integer
c Integer
wsum = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
wbar forall a. Ord a => a -> a -> Bool
<= Integer
c) forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
wbar forall a. Num a => a -> a -> a
+ (Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
b) forall a. Ord a => a -> a -> Bool
> Integer
c) forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
STRef s (Integer, [Int], [Int])
objRef <- forall a s. a -> ST s (STRef s a)
newSTRef (Integer
wbar, [], [])
let updateObj :: Map Integer [Int] -> Map Integer [Int] -> ST s ()
updateObj Map Integer [Int]
gs Map Integer [Int]
ft = do
let loop :: [(Integer, [Int])] -> [(Integer, [Int])] -> ST s ()
loop [] [(Integer, [Int])]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop [(Integer, [Int])]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop xxs :: [(Integer, [Int])]
xxs@((Integer
gobj,[Int]
gsol):[(Integer, [Int])]
xs) yys :: [(Integer, [Int])]
yys@((Integer
fobj,[Int]
fsol):[(Integer, [Int])]
ys)
| Integer
c forall a. Ord a => a -> a -> Bool
< Integer
gobj forall a. Num a => a -> a -> a
+ Integer
fobj = [(Integer, [Int])] -> [(Integer, [Int])] -> ST s ()
loop [(Integer, [Int])]
xs [(Integer, [Int])]
yys
| Bool
otherwise = do
(Integer
curr, [Int]
_, [Int]
_) <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Integer, [Int], [Int])
objRef
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
curr forall a. Ord a => a -> a -> Bool
< Integer
gobj forall a. Num a => a -> a -> a
+ Integer
fobj) forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Integer, [Int], [Int])
objRef (Integer
gobj forall a. Num a => a -> a -> a
+ Integer
fobj, [Int]
gsol, [Int]
fsol)
[(Integer, [Int])] -> [(Integer, [Int])] -> ST s ()
loop [(Integer, [Int])]
xxs [(Integer, [Int])]
ys
[(Integer, [Int])] -> [(Integer, [Int])] -> ST s ()
loop (forall k a. Map k a -> [(k, a)]
Map.toDescList Map Integer [Int]
gs) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Integer [Int]
ft)
let loop :: Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, v Bool)
loop !Int
s !Int
t !Map Integer [Int]
gs !Map Integer [Int]
ft !Bool
flag = do
(Integer
obj, [Int]
gsol, [Int]
fsol) <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Integer, [Int], [Int])
objRef
if Integer
obj forall a. Eq a => a -> a -> Bool
== Integer
c Bool -> Bool -> Bool
|| (Int
s forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
t forall a. Eq a => a -> a -> Bool
== Int
nforall a. Num a => a -> a -> a
-Int
1) then do
let sol :: v Bool
sol = forall (v :: * -> *) a.
Vector v a =>
(forall s. ST s (Mutable v s a)) -> v a
VG.create forall a b. (a -> b) -> a -> b
$ do
Mutable v s Bool
bs <- forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new Int
n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
bforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
True
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
b..Int
nforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
False
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
fsol forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
True
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
gsol forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return Mutable v s Bool
bs
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
obj, v Bool
sol)
else do
let updateF :: ST s (Integer, v Bool)
updateF = do
let t' :: Int
t' = Int
t forall a. Num a => a -> a -> a
+ Int
1
wt' :: Integer
wt' = Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
t'
m :: Map Integer [Int]
m = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (forall a. Num a => a -> a -> a
+ Integer
wt') forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int
t' forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => k -> Map k v -> Map k v
splitLE (Integer
c forall a. Num a => a -> a -> a
- Integer
wt') Map Integer [Int]
ft
ft' :: Map Integer [Int]
ft' = Map Integer [Int]
ft forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Integer [Int]
m
Map Integer [Int] -> Map Integer [Int] -> ST s ()
updateObj Map Integer [Int]
gs Map Integer [Int]
m
Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, v Bool)
loop Int
s Int
t' Map Integer [Int]
gs Map Integer [Int]
ft' (Bool -> Bool
not Bool
flag)
updateG :: ST s (Integer, v Bool)
updateG = do
let s' :: Int
s' = Int
s forall a. Num a => a -> a -> a
- Int
1
ws :: Integer
ws = Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
s'
m :: Map Integer [Int]
m = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int
s' forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ Map Integer [Int] -> Map Integer [Int]
g_drop 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
subtract Integer
ws) forall a b. (a -> b) -> a -> b
$ Map Integer [Int]
gs
gs' :: Map Integer [Int]
gs' = Map Integer [Int]
gs forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Integer [Int]
m
Map Integer [Int] -> Map Integer [Int] -> ST s ()
updateObj Map Integer [Int]
m Map Integer [Int]
ft
Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, v Bool)
loop Int
s' Int
t Map Integer [Int]
gs' Map Integer [Int]
ft (Bool -> Bool
not Bool
flag)
if Int
s forall a. Eq a => a -> a -> Bool
== Int
0 then
ST s (Integer, v Bool)
updateF
else if Int
t forall a. Eq a => a -> a -> Bool
== Int
nforall a. Num a => a -> a -> a
-Int
1 then
ST s (Integer, v Bool)
updateG
else
if Bool
flag then ST s (Integer, v Bool)
updateG else ST s (Integer, v Bool)
updateF
let
fb' :: Map Integer [Int]
fb' :: Map Integer [Int]
fb' = forall k a. k -> a -> Map k a
Map.singleton Integer
0 []
gb :: Map Integer [Int]
gb :: Map Integer [Int]
gb = forall k a. k -> a -> Map k a
Map.singleton Integer
wbar []
forall {v :: * -> *}.
Vector v Bool =>
Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, v Bool)
loop Int
b (Int
bforall a. Num a => a -> a -> a
-Int
1) Map Integer [Int]
gb Map Integer [Int]
fb' Bool
True
where
n :: Int
n = forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w
b :: Int
b :: Int
b = Int -> Integer -> Int
loop (-Int
1) Integer
0
where
loop :: Int -> Integer -> Int
loop :: Int -> Integer -> Int
loop !Int
i !Integer
s
| Integer
s forall a. Ord a => a -> a -> Bool
> Integer
c = Int
i
| Bool
otherwise = Int -> Integer -> Int
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) (Integer
s forall a. Num a => a -> a -> a
+ (Vector Integer
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! (Int
iforall a. Num a => a -> a -> a
+Int
1)))
wbar :: Weight
wbar :: Integer
wbar = forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.slice Int
0 Int
b Vector Integer
w
max_f :: Weight
max_f :: Integer
max_f = Integer
wsum forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
wbar
min_g :: Weight
min_g :: Integer
min_g = Integer
0 forall a. Ord a => a -> a -> a
`max` (Integer
c forall a. Num a => a -> a -> a
- Integer
max_f)
g_drop :: Map Integer [Int] -> Map Integer [Int]
g_drop :: Map Integer [Int] -> Map Integer [Int]
g_drop Map Integer [Int]
g =
case forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup Integer
min_g Map Integer [Int]
g of
(Map Integer [Int]
lo, Maybe [Int]
_, Map Integer [Int]
_) | forall k a. Map k a -> Bool
Map.null Map Integer [Int]
lo -> Map Integer [Int]
g
(Map Integer [Int]
_, Just [Int]
v, Map Integer [Int]
hi) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Integer
min_g [Int]
v Map Integer [Int]
hi
(Map Integer [Int]
lo, Maybe [Int]
Nothing, Map Integer [Int]
hi) ->
case forall k a. Map k a -> (k, a)
Map.findMax Map Integer [Int]
lo of
(Integer
k,[Int]
v) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Integer
k [Int]
v Map Integer [Int]
hi
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
maxSubsetSumInt' :: VU.Vector Int -> Int -> Weight -> (Weight, VU.Vector Bool)
maxSubsetSumInt' :: Vector Int -> Int -> Integer -> (Integer, Vector Bool)
maxSubsetSumInt' Vector Int
w !Int
c Integer
wsum = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
wbar forall a. Ord a => a -> a -> Bool
<= Int
c) forall a b. (a -> b) -> a -> b
$ forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
wbar forall a. Num a => a -> a -> a
+ (Vector Int
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
b) forall a. Ord a => a -> a -> Bool
> Int
c) forall a b. (a -> b) -> a -> b
$ forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
STRef s (Int, [Int], [Int])
objRef <- forall a s. a -> ST s (STRef s a)
newSTRef (Int
wbar, [], [])
let updateObj :: IntMap [Int] -> IntMap [Int] -> ST s ()
updateObj IntMap [Int]
gs IntMap [Int]
ft = do
let loop :: [(Int, [Int])] -> [(Int, [Int])] -> ST s ()
loop [] [(Int, [Int])]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop [(Int, [Int])]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop xxs :: [(Int, [Int])]
xxs@((Int
gobj,[Int]
gsol):[(Int, [Int])]
xs) yys :: [(Int, [Int])]
yys@((Int
fobj,[Int]
fsol):[(Int, [Int])]
ys)
| Int
c forall a. Ord a => a -> a -> Bool
< Int
gobj forall a. Num a => a -> a -> a
+ Int
fobj = [(Int, [Int])] -> [(Int, [Int])] -> ST s ()
loop [(Int, [Int])]
xs [(Int, [Int])]
yys
| Bool
otherwise = do
(Int
curr, [Int]
_, [Int]
_) <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Int, [Int], [Int])
objRef
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curr forall a. Ord a => a -> a -> Bool
< Int
gobj forall a. Num a => a -> a -> a
+ Int
fobj) forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Int, [Int], [Int])
objRef (Int
gobj forall a. Num a => a -> a -> a
+ Int
fobj, [Int]
gsol, [Int]
fsol)
[(Int, [Int])] -> [(Int, [Int])] -> ST s ()
loop [(Int, [Int])]
xxs [(Int, [Int])]
ys
[(Int, [Int])] -> [(Int, [Int])] -> ST s ()
loop (forall a. IntMap a -> [(Int, a)]
IntMap.toDescList IntMap [Int]
gs) (forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap [Int]
ft)
let loop :: Int
-> Int -> IntMap [Int] -> IntMap [Int] -> Bool -> ST s (a, v Bool)
loop !Int
s !Int
t !IntMap [Int]
gs !IntMap [Int]
ft !Bool
flag = do
(Int
obj, [Int]
gsol, [Int]
fsol) <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Int, [Int], [Int])
objRef
if Int
obj forall a. Eq a => a -> a -> Bool
== Int
c Bool -> Bool -> Bool
|| (Int
s forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
t forall a. Eq a => a -> a -> Bool
== Int
nforall a. Num a => a -> a -> a
-Int
1) then do
let sol :: v Bool
sol = forall (v :: * -> *) a.
Vector v a =>
(forall s. ST s (Mutable v s a)) -> v a
VG.create forall a b. (a -> b) -> a -> b
$ do
Mutable v s Bool
bs <- forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new Int
n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
bforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
True
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
b..Int
nforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
False
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
fsol forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
True
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
gsol forall a b. (a -> b) -> a -> b
$ \Int
i -> forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
bs Int
i Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return Mutable v s Bool
bs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
obj, v Bool
sol)
else do
let updateF :: ST s (a, v Bool)
updateF = do
let t' :: Int
t' = Int
t forall a. Num a => a -> a -> a
+ Int
1
wt' :: Int
wt' = Vector Int
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
t'
m :: IntMap [Int]
m = forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (forall a. Num a => a -> a -> a
+ Int
wt') forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (Int
t' forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall v. Int -> IntMap v -> IntMap v
splitLE (Int
c forall a. Num a => a -> a -> a
- Int
wt') IntMap [Int]
ft
ft' :: IntMap [Int]
ft' = IntMap [Int]
ft forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` IntMap [Int]
m
IntMap [Int] -> IntMap [Int] -> ST s ()
updateObj IntMap [Int]
gs IntMap [Int]
m
Int
-> Int -> IntMap [Int] -> IntMap [Int] -> Bool -> ST s (a, v Bool)
loop Int
s Int
t' IntMap [Int]
gs IntMap [Int]
ft' (Bool -> Bool
not Bool
flag)
updateG :: ST s (a, v Bool)
updateG = do
let s' :: Int
s' = Int
s forall a. Num a => a -> a -> a
- Int
1
ws :: Int
ws = Vector Int
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
s'
m :: IntMap [Int]
m = forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (Int
s' forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ IntMap [Int] -> IntMap [Int]
g_drop forall a b. (a -> b) -> a -> b
$ forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (forall a. Num a => a -> a -> a
subtract Int
ws) forall a b. (a -> b) -> a -> b
$ IntMap [Int]
gs
gs' :: IntMap [Int]
gs' = IntMap [Int]
gs forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` IntMap [Int]
m
IntMap [Int] -> IntMap [Int] -> ST s ()
updateObj IntMap [Int]
m IntMap [Int]
ft
Int
-> Int -> IntMap [Int] -> IntMap [Int] -> Bool -> ST s (a, v Bool)
loop Int
s' Int
t IntMap [Int]
gs' IntMap [Int]
ft (Bool -> Bool
not Bool
flag)
if Int
s forall a. Eq a => a -> a -> Bool
== Int
0 then
ST s (a, v Bool)
updateF
else if Int
t forall a. Eq a => a -> a -> Bool
== Int
nforall a. Num a => a -> a -> a
-Int
1 then
ST s (a, v Bool)
updateG
else
if Bool
flag then ST s (a, v Bool)
updateG else ST s (a, v Bool)
updateF
let
fb' :: IntMap [Int]
fb' :: IntMap [Int]
fb' = forall a. Int -> a -> IntMap a
IntMap.singleton Int
0 []
gb :: IntMap [Int]
gb :: IntMap [Int]
gb = forall a. Int -> a -> IntMap a
IntMap.singleton Int
wbar []
forall {a} {v :: * -> *}.
(Num a, Vector v Bool) =>
Int
-> Int -> IntMap [Int] -> IntMap [Int] -> Bool -> ST s (a, v Bool)
loop Int
b (Int
bforall a. Num a => a -> a -> a
-Int
1) IntMap [Int]
gb IntMap [Int]
fb' Bool
True
where
n :: Int
n = forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Int
w
b :: Int
b :: Int
b = Int -> Integer -> Int
loop (-Int
1) Integer
0
where
loop :: Int -> Integer -> Int
loop :: Int -> Integer -> Int
loop !Int
i !Integer
s
| Integer
s forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c = Int
i
| Bool
otherwise = Int -> Integer -> Int
loop (Int
iforall a. Num a => a -> a -> a
+Int
1) (Integer
s forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int
w forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! (Int
iforall a. Num a => a -> a -> a
+Int
1)))
wbar :: Int
wbar :: Int
wbar = forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.slice Int
0 Int
b Vector Int
w
max_f :: Integer
max_f :: Integer
max_f = Integer
wsum forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wbar
min_g :: Int
min_g :: Int
min_g = if Integer
max_f forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c then Int
c forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
max_f else Int
0
g_drop :: IntMap [Int] -> IntMap [Int]
g_drop :: IntMap [Int] -> IntMap [Int]
g_drop IntMap [Int]
g =
case forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IntMap.splitLookup Int
min_g IntMap [Int]
g of
(IntMap [Int]
lo, Maybe [Int]
_, IntMap [Int]
_) | forall a. IntMap a -> Bool
IntMap.null IntMap [Int]
lo -> IntMap [Int]
g
(IntMap [Int]
_, Just [Int]
v, IntMap [Int]
hi) -> forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
min_g [Int]
v IntMap [Int]
hi
(IntMap [Int]
lo, Maybe [Int]
Nothing, IntMap [Int]
hi) ->
case forall a. IntMap a -> (Int, a)
IntMap.findMax IntMap [Int]
lo of
(Int
k,[Int]
v) -> forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k [Int]
v IntMap [Int]
hi
splitLE :: Int -> IntMap v -> IntMap v
splitLE :: forall v. Int -> IntMap v -> IntMap v
splitLE Int
k IntMap v
m =
case forall a. Int -> IntMap a -> (IntMap a, Maybe a, IntMap a)
IntMap.splitLookup Int
k IntMap v
m of
(IntMap v
lo, Maybe v
Nothing, IntMap v
_) -> IntMap v
lo
(IntMap v
lo, Just v
v, IntMap v
_) -> forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k v
v IntMap v
lo
minSubsetSum
:: VG.Vector v Weight
=> v Weight
-> Weight
-> Maybe (Weight, VU.Vector Bool)
minSubsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
minSubsetSum v Integer
w Integer
l =
case forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
maxSubsetSum v Integer
w (Integer
wsum forall a. Num a => a -> a -> a
- Integer
l) of
Maybe (Integer, Vector Bool)
Nothing -> forall a. Maybe a
Nothing
Just (Integer
obj, Vector Bool
bs) -> forall a. a -> Maybe a
Just (Integer
wsum forall a. Num a => a -> a -> a
- Integer
obj, forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
VG.map Bool -> Bool
not Vector Bool
bs)
where
wsum :: Integer
wsum = forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum v Integer
w
subsetSum
:: VG.Vector v Weight
=> v Weight
-> Weight
-> Maybe (VU.Vector Bool)
subsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Vector Bool)
subsetSum v Integer
w Integer
c =
case forall (v :: * -> *).
Vector v Integer =>
(v Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeWeightsToPositive (v Integer
w,Integer
c) of
(Vector Integer
w1, Integer
c1, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1)
| Integer
c1 forall a. Ord a => a -> a -> Bool
< Integer
0 -> forall a. Maybe a
Nothing
| Bool
otherwise ->
case (Vector Integer, Integer)
-> (Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalize2 (Vector Integer
w1, Integer
c1) of
(Vector Integer
w2, Integer
c2, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2) -> do
(Vector Integer
w3, Integer
c3, (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3) <- (Vector Integer, Integer)
-> Maybe
(Vector Integer, Integer,
(Integer, Vector Bool) -> (Integer, Vector Bool))
normalizeGCDEq (Vector Integer
w2,Integer
c2)
let (Integer
obj, Vector Bool
sol) = Vector Integer -> Integer -> (Integer, Vector Bool)
maxSubsetSum' Vector Integer
w3 Integer
c3
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Integer
obj forall a. Eq a => a -> a -> Bool
== Integer
c3
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1 forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2 forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3 (Integer
obj, Vector Bool
sol)