{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Combinatorial.SubsetSum
-- Copyright   :  (c) Masahiro Sakai 2015
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- References
--
-- * D. Pisinger, "An exact algorithm for large multiple knapsack problems,"
--   European Journal of Operational Research, vol. 114, no. 3, pp. 528-541,
--   May 1999. DOI:10.1016/s0377-2217(98)00120-9
--   <http://www.sciencedirect.com/science/article/pii/S0377221798001209>
--   <http://www.diku.dk/~pisinger/95-6.ps>
--
-----------------------------------------------------------------------------
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

-- | Maximize Σ_{i=1}^n wi xi subject to Σ_{i=1}^n wi xi ≤ c and xi ∈ {0,1}.
--
-- Note: 0 (resp. 1) is identified with False (resp. True) in the assignment.
maxSubsetSum
  :: VG.Vector v Weight
  => v Weight -- ^ weights @[w1, w2 .. wn]@
  -> Weight -- ^ capacity @c@
  -> Maybe (Weight, VU.Vector Bool)
  -- ^
  -- * the objective value Σ_{i=1}^n wi xi, and
  --
  -- * the assignment @[x1, x2 .. xn]@, identifying 0 (resp. 1) with @False@ (resp. @True@).
maxSubsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
maxSubsetSum v Integer
w Integer
c =
  case (v Integer, Integer)
-> (Vector Integer, Integer,
    (Integer, Vector Bool) -> (Integer, Vector Bool))
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 -> Maybe (Integer, Vector Bool)
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) ->
                  (Integer, Vector Bool) -> Maybe (Integer, Vector Bool)
forall a. a -> Maybe a
Just ((Integer, Vector Bool) -> Maybe (Integer, Vector Bool))
-> (Integer, Vector Bool) -> Maybe (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1 ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2 ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3 ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
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)
  | (Integer -> Bool) -> v Integer -> Bool
forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
VG.all (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>=Integer
0) v Integer
w = (v Integer -> Vector Integer
forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
VG.convert v Integer
w, Integer
c, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. a -> a
id)
  | Bool
otherwise = (forall s.
 ST
   s
   (Vector Integer, Integer,
    (Integer, Vector Bool) -> (Integer, Vector Bool)))
-> (Vector Integer, Integer,
    (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a. (forall s. ST s a) -> a
runST ((forall s.
  ST
    s
    (Vector Integer, Integer,
     (Integer, Vector Bool) -> (Integer, Vector Bool)))
 -> (Vector Integer, Integer,
     (Integer, Vector Bool) -> (Integer, Vector Bool)))
-> (forall s.
    ST
      s
      (Vector Integer, Integer,
       (Integer, Vector Bool) -> (Integer, Vector Bool)))
-> (Vector Integer, Integer,
    (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a b. (a -> b) -> a -> b
$ do
      MVector (PrimState (ST s)) Integer
w2 <- Int -> ST s (MVector (PrimState (ST s)) Integer)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new (v Integer -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= v Integer -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length v Integer
w = Integer -> ST s Integer
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
offset
            | Bool
otherwise = do
                let wi :: Integer
wi = v Integer
w v Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
i
                if Integer
wi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then do
                  MVector (PrimState (ST s)) Integer -> Int -> Integer -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, 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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
wi)
                else do
                  MVector (PrimState (ST s)) Integer -> Int -> Integer -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, 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
iInt -> Int -> Int
forall 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' <- Mutable Vector (PrimState (ST s)) Integer -> ST s (Vector Integer)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
VG.unsafeFreeze Mutable Vector (PrimState (ST s)) Integer
MVector (PrimState (ST s)) Integer
w2
      let trans :: (Integer, Vector Bool) -> (Integer, Vector Bool)
trans (Integer
obj, Vector Bool
bs) = (Integer
obj Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
offset, Vector Bool
bs2)
            where
              bs2 :: Vector Bool
bs2 = (Int -> Bool -> Bool) -> Vector Bool -> Vector Bool
forall a b.
(Unbox a, Unbox b) =>
(Int -> a -> b) -> Vector a -> Vector b
VU.imap (\Int
i Bool
bi -> if v Integer
w v Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Bool -> Bool
not Bool
bi else Bool
bi) Vector Bool
bs
      (Vector Integer, Integer,
 (Integer, Vector Bool) -> (Integer, Vector Bool))
-> ST
     s
     (Vector Integer, Integer,
      (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Integer
w2', Integer
c Integer -> Integer -> Integer
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)
  | (Integer -> Bool) -> Vector Integer -> Bool
forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
VG.all (\Integer
wi -> Integer
0Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
wi Bool -> Bool -> Bool
&& Integer
wiInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<=Integer
c) Vector Integer
w = (Vector Integer
w, Integer
c, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. a -> a
id)
  | Bool
otherwise = ((Integer -> Bool) -> Vector Integer -> Vector Integer
forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> v a
VG.filter (\Integer
wi -> Integer
0Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
wi Bool -> Bool -> Bool
&& Integer
wiInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<=Integer
c) Vector Integer
w, Integer
c, (Integer, Vector Bool) -> (Integer, Vector Bool)
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 s. ST s (MVector s Bool)) -> Vector Bool
forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
VU.create ((forall s. ST s (MVector s Bool)) -> Vector Bool)
-> (forall s. ST s (MVector s Bool)) -> Vector Bool
forall a b. (a -> b) -> a -> b
$ do
          MVector (PrimState (ST s)) Bool
v <- Int -> ST s (MVector (PrimState (ST s)) Bool)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new (Vector Integer -> Int
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 =
                Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Vector Integer -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                  let wi :: Integer
wi = Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
i
                  if Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
wi Bool -> Bool -> Bool
&& Integer
wi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c then do
                    MVector (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, 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 v Bool -> Int -> Bool
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
j)
                    Int -> Int -> ST s ()
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                  else do
                    MVector (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, 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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j
          Int -> Int -> ST s ()
loop Int
0 Int
0
          MVector s Bool -> ST s (MVector s Bool)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Bool
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)
  | Vector Integer -> Bool
forall (v :: * -> *) a. Vector v a => v a -> Bool
VG.null Vector Integer
w Bool -> Bool -> Bool
|| Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = (Vector Integer
w, Integer
c, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. a -> a
id)
  | Bool
otherwise = ((Integer -> Integer) -> Vector Integer -> Vector Integer
forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
VG.map (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d) Vector Integer
w, Integer
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall {b}. (Integer, b) -> (Integer, b)
trans)
  where
    d :: Integer
d = (Integer -> Integer -> Integer) -> Vector Integer -> Integer
forall (v :: * -> *) a. Vector v a => (a -> a -> a) -> v a -> a
VG.foldl1' Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd Vector Integer
w
    trans :: (Integer, b) -> (Integer, b)
trans (Integer
obj, b
bs) = (Integer
obj Integer -> Integer -> Integer
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)
  | Vector Integer -> Bool
forall (v :: * -> *) a. Vector v a => v a -> Bool
VG.null Vector Integer
w Bool -> Bool -> Bool
|| Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = (Vector Integer, Integer,
 (Integer, Vector Bool) -> (Integer, Vector Bool))
-> Maybe
     (Vector Integer, Integer,
      (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a. a -> Maybe a
Just (Vector Integer
w, Integer
c, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. a -> a
id)
  | Integer
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = (Vector Integer, Integer,
 (Integer, Vector Bool) -> (Integer, Vector Bool))
-> Maybe
     (Vector Integer, Integer,
      (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a. a -> Maybe a
Just ((Integer -> Integer) -> Vector Integer -> Vector Integer
forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
VG.map (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d) Vector Integer
w, Integer
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d, (Integer, Vector Bool) -> (Integer, Vector Bool)
forall {b}. (Integer, b) -> (Integer, b)
trans)
  | Bool
otherwise = Maybe
  (Vector Integer, Integer,
   (Integer, Vector Bool) -> (Integer, Vector Bool))
forall a. Maybe a
Nothing
  where
    d :: Integer
d = (Integer -> Integer -> Integer) -> Vector Integer -> Integer
forall (v :: * -> *) a. Vector v a => (a -> a -> a) -> v a -> a
VG.foldl1' Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
gcd Vector Integer
w
    trans :: (Integer, b) -> (Integer, b)
trans (Integer
obj, b
bs) = (Integer
obj Integer -> Integer -> Integer
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c = (Integer
wsum, Int -> Bool -> Vector Bool
forall (v :: * -> *) a. Vector v a => Int -> a -> v a
VG.replicate (Vector Integer -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) Bool
True)
  | Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int) =
      Vector Int -> Int -> Integer -> (Integer, Vector Bool)
maxSubsetSumInt' (Int -> (Int -> Int) -> Vector Int
forall (v :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
VG.generate (Vector Integer -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length Vector Integer
w) (\Int
i -> Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
VG.! Int
i))) (Integer -> Int
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 = Vector Integer -> Integer
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 = Bool -> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. HasCallStack => Bool -> a -> a
assert (Integer
wbar Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
c) ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. HasCallStack => Bool -> a -> a
assert (Integer
wbar Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
b) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
c) ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Integer, Vector Bool)) -> (Integer, Vector Bool)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Integer, Vector Bool)) -> (Integer, Vector Bool))
-> (forall s. ST s (Integer, Vector Bool))
-> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ do
  STRef s (Integer, [Int], [Int])
objRef <- (Integer, [Int], [Int]) -> ST s (STRef s (Integer, [Int], [Int]))
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])]
_ = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            loop [(Integer, [Int])]
_ [] = () -> ST s ()
forall a. a -> ST s a
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
gobj Integer -> Integer -> Integer
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]
_) <- STRef s (Integer, [Int], [Int]) -> ST s (Integer, [Int], [Int])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Integer, [Int], [Int])
objRef
                  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
curr Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
gobj Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
fobj) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ STRef s (Integer, [Int], [Int])
-> (Integer, [Int], [Int]) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Integer, [Int], [Int])
objRef (Integer
gobj Integer -> Integer -> Integer
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 (Map Integer [Int] -> [(Integer, [Int])]
forall k a. Map k a -> [(k, a)]
Map.toDescList Map Integer [Int]
gs) (Map Integer [Int] -> [(Integer, [Int])]
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) <- STRef s (Integer, [Int], [Int]) -> ST s (Integer, [Int], [Int])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Integer, [Int], [Int])
objRef
        if Integer
obj Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
c Bool -> Bool -> Bool
|| (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) then do
          let sol :: v Bool
sol = (forall s. ST s (Mutable v s Bool)) -> v Bool
forall (v :: * -> *) a.
Vector v a =>
(forall s. ST s (Mutable v s a)) -> v a
VG.create ((forall s. ST s (Mutable v s Bool)) -> v Bool)
-> (forall s. ST s (Mutable v s Bool)) -> v Bool
forall a b. (a -> b) -> a -> b
$ do
                Mutable v s Bool
bs <- Int -> ST s (Mutable v (PrimState (ST s)) Bool)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new Int
n
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
True
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
b..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
False
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
fsol ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
True
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
gsol ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
False
                Mutable v s Bool -> ST s (Mutable v s Bool)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Mutable v s Bool
bs
          (Integer, v Bool) -> ST s (Integer, v Bool)
forall a. a -> ST s a
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
                -- Compute f_{t+1} from f_t
                let t' :: Int
t' = Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    wt' :: Integer
wt' = Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
t'
                    m :: Map Integer [Int]
m = (Integer -> Integer) -> Map Integer [Int] -> Map Integer [Int]
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
wt') (Map Integer [Int] -> Map Integer [Int])
-> Map Integer [Int] -> Map Integer [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int]) -> Map Integer [Int] -> Map Integer [Int]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int
t' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (Map Integer [Int] -> Map Integer [Int])
-> Map Integer [Int] -> Map Integer [Int]
forall a b. (a -> b) -> a -> b
$ Integer -> Map Integer [Int] -> Map Integer [Int]
forall k v. Ord k => k -> Map k v -> Map k v
splitLE (Integer
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
wt') Map Integer [Int]
ft
                    ft' :: Map Integer [Int]
ft' = Map Integer [Int]
ft Map Integer [Int] -> Map Integer [Int] -> Map Integer [Int]
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
                -- Compute g_{s-1} from g_s
                let s' :: Int
s' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    ws :: Integer
ws = Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
s'
                    m :: Map Integer [Int]
m = ([Int] -> [Int]) -> Map Integer [Int] -> Map Integer [Int]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int
s' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (Map Integer [Int] -> Map Integer [Int])
-> Map Integer [Int] -> Map Integer [Int]
forall a b. (a -> b) -> a -> b
$ Map Integer [Int] -> Map Integer [Int]
g_drop (Map Integer [Int] -> Map Integer [Int])
-> Map Integer [Int] -> Map Integer [Int]
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer) -> Map Integer [Int] -> Map Integer [Int]
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
ws) (Map Integer [Int] -> Map Integer [Int])
-> Map Integer [Int] -> Map Integer [Int]
forall a b. (a -> b) -> a -> b
$ Map Integer [Int]
gs
                    gs' :: Map Integer [Int]
gs' = Map Integer [Int]
gs Map Integer [Int] -> Map Integer [Int] -> Map Integer [Int]
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
            ST s (Integer, v Bool)
updateF
          else if Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall 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 -- f_{b-1}
      fb' :: Map Integer [Int]
      fb' :: Map Integer [Int]
fb' = Integer -> [Int] -> Map Integer [Int]
forall k a. k -> a -> Map k a
Map.singleton Integer
0 []
      -- g_{b}
      gb :: Map Integer [Int]
      gb :: Map Integer [Int]
gb = Integer -> [Int] -> Map Integer [Int]
forall k a. k -> a -> Map k a
Map.singleton Integer
wbar []
  Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, Vector Bool)
forall {v :: * -> *}.
Vector v Bool =>
Int
-> Int
-> Map Integer [Int]
-> Map Integer [Int]
-> Bool
-> ST s (Integer, v Bool)
loop Int
b (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Map Integer [Int]
gb Map Integer [Int]
fb' Bool
True

  where
    n :: Int
n = Vector Integer -> Int
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
c = Int
i
          | Bool
otherwise = Int -> Integer -> Int
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Vector Integer
w Vector Integer -> Int -> Integer
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))

    wbar :: Weight
    wbar :: Integer
wbar = Vector Integer -> Integer
forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum (Vector Integer -> Integer) -> Vector Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Integer -> Vector Integer
forall (v :: * -> *) a.
(HasCallStack, 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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
wbar

    min_g :: Weight
    min_g :: Integer
min_g = Integer
0 Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`max` (Integer
c Integer -> Integer -> Integer
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 Integer
-> Map Integer [Int]
-> (Map Integer [Int], Maybe [Int], Map Integer [Int])
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]
_) | Map Integer [Int] -> Bool
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) -> Integer -> [Int] -> Map Integer [Int] -> Map Integer [Int]
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 Map Integer [Int] -> (Integer, [Int])
forall k a. Map k a -> (k, a)
Map.findMax Map Integer [Int]
lo of
            (Integer
k,[Int]
v) -> Integer -> [Int] -> Map Integer [Int] -> Map Integer [Int]
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 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

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 = Bool -> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. HasCallStack => Bool -> a -> a
assert (Int
wbar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c) ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a. HasCallStack => Bool -> a -> a
assert (Int
wbar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Vector Int
w Vector Int -> Int -> Int
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
b) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
c) ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Integer, Vector Bool)) -> (Integer, Vector Bool)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Integer, Vector Bool)) -> (Integer, Vector Bool))
-> (forall s. ST s (Integer, Vector Bool))
-> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ do
  STRef s (Int, [Int], [Int])
objRef <- (Int, [Int], [Int]) -> ST s (STRef s (Int, [Int], [Int]))
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])]
_ = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            loop [(Int, [Int])]
_ [] = () -> ST s ()
forall a. a -> ST s a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
gobj Int -> Int -> Int
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]
_) <- STRef s (Int, [Int], [Int]) -> ST s (Int, [Int], [Int])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Int, [Int], [Int])
objRef
                  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
gobj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fobj) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ STRef s (Int, [Int], [Int]) -> (Int, [Int], [Int]) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Int, [Int], [Int])
objRef (Int
gobj Int -> Int -> Int
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 (IntMap [Int] -> [(Int, [Int])]
forall a. IntMap a -> [(Int, a)]
IntMap.toDescList IntMap [Int]
gs) (IntMap [Int] -> [(Int, [Int])]
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) <- STRef s (Int, [Int], [Int]) -> ST s (Int, [Int], [Int])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Int, [Int], [Int])
objRef
        if Int
obj Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c Bool -> Bool -> Bool
|| (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) then do
          let sol :: v Bool
sol = (forall s. ST s (Mutable v s Bool)) -> v Bool
forall (v :: * -> *) a.
Vector v a =>
(forall s. ST s (Mutable v s a)) -> v a
VG.create ((forall s. ST s (Mutable v s Bool)) -> v Bool)
-> (forall s. ST s (Mutable v s Bool)) -> v Bool
forall a b. (a -> b) -> a -> b
$ do
                Mutable v s Bool
bs <- Int -> ST s (Mutable v (PrimState (ST s)) Bool)
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
VM.new Int
n
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
True
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
b..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
False
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
fsol ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
True
                [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
gsol ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Mutable v (PrimState (ST s)) Bool -> Int -> Bool -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(HasCallStack, PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
VM.write Mutable v s Bool
Mutable v (PrimState (ST s)) Bool
bs Int
i Bool
False
                Mutable v s Bool -> ST s (Mutable v s Bool)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Mutable v s Bool
bs
          (a, v Bool) -> ST s (a, v Bool)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a
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
                -- Compute f_{t+1} from f_t
                let t' :: Int
t' = Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    wt' :: Int
wt' = Vector Int
w Vector Int -> Int -> Int
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
t'
                    m :: IntMap [Int]
m = (Int -> Int) -> IntMap [Int] -> IntMap [Int]
forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wt') (IntMap [Int] -> IntMap [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ ([Int] -> [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (Int
t' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (IntMap [Int] -> IntMap [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [Int] -> IntMap [Int]
forall v. Int -> IntMap v -> IntMap v
splitLE (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wt') IntMap [Int]
ft
                    ft' :: IntMap [Int]
ft' = IntMap [Int]
ft IntMap [Int] -> IntMap [Int] -> IntMap [Int]
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
                -- Compute g_{s-1} from g_s
                let s' :: Int
s' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    ws :: Int
ws = Vector Int
w Vector Int -> Int -> Int
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
s'
                    m :: IntMap [Int]
m = ([Int] -> [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (Int
s' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (IntMap [Int] -> IntMap [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ IntMap [Int] -> IntMap [Int]
g_drop (IntMap [Int] -> IntMap [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IntMap [Int] -> IntMap [Int]
forall a. (Int -> Int) -> IntMap a -> IntMap a
IntMap.mapKeysMonotonic (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
ws) (IntMap [Int] -> IntMap [Int]) -> IntMap [Int] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ IntMap [Int]
gs
                    gs' :: IntMap [Int]
gs' = IntMap [Int]
gs IntMap [Int] -> IntMap [Int] -> IntMap [Int]
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
            ST s (a, v Bool)
updateF
          else if Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall 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 -- f_{b-1}
      fb' :: IntMap [Int]
      fb' :: IntMap [Int]
fb' = Int -> [Int] -> IntMap [Int]
forall a. Int -> a -> IntMap a
IntMap.singleton Int
0 []
      -- g_{b}
      gb :: IntMap [Int]
      gb :: IntMap [Int]
gb = Int -> [Int] -> IntMap [Int]
forall a. Int -> a -> IntMap a
IntMap.singleton Int
wbar []
  Int
-> Int
-> IntMap [Int]
-> IntMap [Int]
-> Bool
-> ST s (Integer, Vector Bool)
forall {a} {v :: * -> *}.
(Num a, Vector v Bool) =>
Int
-> Int -> IntMap [Int] -> IntMap [Int] -> Bool -> ST s (a, v Bool)
loop Int
b (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) IntMap [Int]
gb IntMap [Int]
fb' Bool
True

  where
    n :: Int
n = Vector Int -> Int
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c = Int
i
          | Bool
otherwise = Int -> Integer -> Int
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int
w Vector Int -> Int -> Int
forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))

    wbar :: Int
    wbar :: Int
wbar = Vector Int -> Int
forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Int -> Vector Int
forall (v :: * -> *) a.
(HasCallStack, 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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wbar

    min_g :: Int
    min_g :: Int
min_g = if Integer
max_f Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c then Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
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 Int -> IntMap [Int] -> (IntMap [Int], Maybe [Int], IntMap [Int])
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]
_) | IntMap [Int] -> Bool
forall a. IntMap a -> Bool
IntMap.null IntMap [Int]
lo -> IntMap [Int]
g
        (IntMap [Int]
_, Just [Int]
v, IntMap [Int]
hi) -> Int -> [Int] -> IntMap [Int] -> IntMap [Int]
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 IntMap [Int] -> (Int, [Int])
forall a. IntMap a -> (Int, a)
IntMap.findMax IntMap [Int]
lo of
            (Int
k,[Int]
v) -> Int -> [Int] -> IntMap [Int] -> IntMap [Int]
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 Int -> IntMap v -> (IntMap v, Maybe v, IntMap v)
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
_) -> Int -> v -> IntMap v -> IntMap v
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k v
v IntMap v
lo

-- | Minimize Σ_{i=1}^n wi xi subject to Σ_{i=1}^n wi xi ≥ l and xi ∈ {0,1}.
--
-- Note: 0 (resp. 1) is identified with False (resp. True) in the assignment.
minSubsetSum
  :: VG.Vector v Weight
  => v Weight -- ^ weights @[w1, w2 .. wn]@
  -> Weight -- ^ @l@
  -> Maybe (Weight, VU.Vector Bool)
  -- ^
  -- * the objective value Σ_{i=1}^n wi xi, and
  --
  -- * the assignment @[x1, x2 .. xn]@, identifying 0 (resp. 1) with @False@ (resp. @True@).
minSubsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
minSubsetSum v Integer
w Integer
l =
  case v Integer -> Integer -> Maybe (Integer, Vector Bool)
forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Integer, Vector Bool)
maxSubsetSum v Integer
w (Integer
wsum Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
l) of
    Maybe (Integer, Vector Bool)
Nothing -> Maybe (Integer, Vector Bool)
forall a. Maybe a
Nothing
    Just (Integer
obj, Vector Bool
bs) -> (Integer, Vector Bool) -> Maybe (Integer, Vector Bool)
forall a. a -> Maybe a
Just (Integer
wsum Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
obj, (Bool -> Bool) -> Vector Bool -> Vector Bool
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 = v Integer -> Integer
forall (v :: * -> *) a. (Vector v a, Num a) => v a -> a
VG.sum v Integer
w

{-
minimize Σ wi xi = Σ wi (1 - ¬xi) = Σ wi - (Σ wi ¬xi)
subject to Σ wi xi ≥ n

maximize Σ wi ¬xi
subject to Σ wi ¬xi ≤ (Σ wi) - n

Σ wi xi ≥ n
Σ wi (1 - ¬xi) ≥ n
(Σ wi) - (Σ wi ¬xi) ≥ n
(Σ wi ¬xi) ≤ (Σ wi) - n
-}

-- | Solve Σ_{i=1}^n wi xi = c and xi ∈ {0,1}.
--
-- Note that this is different from usual definition of the subset sum problem,
-- as this definition allows all xi to be zero.
--
-- Note: 0 (resp. 1) is identified with False (resp. True) in the assignment.
subsetSum
  :: VG.Vector v Weight
  => v Weight -- ^ weights @[w1, w2 .. wn]@
  -> Weight -- ^ @l@
  -> Maybe (VU.Vector Bool)
  -- ^
  -- the assignment @[x1, x2 .. xn]@, identifying 0 (resp. 1) with @False@ (resp. @True@).
subsetSum :: forall (v :: * -> *).
Vector v Integer =>
v Integer -> Integer -> Maybe (Vector Bool)
subsetSum v Integer
w Integer
c =
  case (v Integer, Integer)
-> (Vector Integer, Integer,
    (Integer, Vector Bool) -> (Integer, Vector Bool))
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 -> Maybe (Vector Bool)
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
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Integer
obj Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
c3
              Vector Bool -> Maybe (Vector Bool)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Bool -> Maybe (Vector Bool))
-> Vector Bool -> Maybe (Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> Vector Bool
forall a b. (a, b) -> b
snd ((Integer, Vector Bool) -> Vector Bool)
-> (Integer, Vector Bool) -> Vector Bool
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans1 ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans2 ((Integer, Vector Bool) -> (Integer, Vector Bool))
-> (Integer, Vector Bool) -> (Integer, Vector Bool)
forall a b. (a -> b) -> a -> b
$ (Integer, Vector Bool) -> (Integer, Vector Bool)
trans3 (Integer
obj, Vector Bool
sol)