{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module ToySolver.SAT.Encoder.PB.Internal.BDD
( addPBLinAtLeastBDD
, encodePBLinAtLeastBDD
) where
import Control.Monad.State.Strict
import Control.Monad.Primitive
import Data.Ord
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified ToySolver.SAT.Types as SAT
import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin
addPBLinAtLeastBDD :: PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m ()
addPBLinAtLeastBDD :: forall (m :: * -> *).
PrimMonad m =>
Encoder m -> PBLinAtLeast -> m ()
addPBLinAtLeastBDD Encoder m
enc PBLinAtLeast
constr = do
Lit
l <- forall (m :: * -> *).
PrimMonad m =>
Encoder m -> PBLinAtLeast -> m Lit
encodePBLinAtLeastBDD Encoder m
enc PBLinAtLeast
constr
forall (m :: * -> *) a. AddClause m a => a -> Clause -> m ()
SAT.addClause Encoder m
enc [Lit
l]
encodePBLinAtLeastBDD :: forall m. PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m SAT.Lit
encodePBLinAtLeastBDD :: forall (m :: * -> *).
PrimMonad m =>
Encoder m -> PBLinAtLeast -> m Lit
encodePBLinAtLeastBDD Encoder m
enc ([PBLinTerm]
lhs,Integer
rhs) = do
let lhs' :: [PBLinTerm]
lhs' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)) [PBLinTerm]
lhs
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ do
let f :: SAT.PBLinSum -> Integer -> Integer -> StateT (Map (SAT.PBLinSum, Integer) SAT.Lit) m SAT.Lit
f :: [PBLinTerm]
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f [PBLinTerm]
xs Integer
rhs Integer
slack
| Integer
rhs forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Encoder m -> Clause -> m Lit
Tseitin.encodeConj Encoder m
enc []
| Integer
slack forall a. Ord a => a -> a -> Bool
< Integer
0 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PrimMonad m => Encoder m -> Clause -> m Lit
Tseitin.encodeDisj Encoder m
enc []
| Bool
otherwise = do
Map PBLinAtLeast Lit
m <- forall s (m :: * -> *). MonadState s m => m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([PBLinTerm]
xs,Integer
rhs) Map PBLinAtLeast Lit
m of
Just Lit
l -> forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l
Maybe Lit
Nothing -> do
case [PBLinTerm]
xs of
[] -> forall a. HasCallStack => [Char] -> a
error [Char]
"encodePBLinAtLeastBDD: should not happen"
[(Integer
_,Lit
l)] -> forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l
(Integer
c,Lit
l) : [PBLinTerm]
xs' -> do
Lit
thenLit <- [PBLinTerm]
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f [PBLinTerm]
xs' (Integer
rhs forall a. Num a => a -> a -> a
- Integer
c) Integer
slack
Lit
l2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PrimMonad m =>
Encoder m -> Polarity -> Clause -> m Lit
Tseitin.encodeConjWithPolarity Encoder m
enc Polarity
Tseitin.polarityPos [Lit
l, Lit
thenLit]
Lit
l3 <- if Integer
c forall a. Ord a => a -> a -> Bool
> Integer
slack then
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l2
else do
Lit
elseLit <- [PBLinTerm]
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f [PBLinTerm]
xs' Integer
rhs (Integer
slack forall a. Num a => a -> a -> a
- Integer
c)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PrimMonad m =>
Encoder m -> Polarity -> Clause -> m Lit
Tseitin.encodeDisjWithPolarity Encoder m
enc Polarity
Tseitin.polarityPos [Lit
l2, Lit
elseLit]
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ([PBLinTerm]
xs,Integer
rhs) Lit
l3)
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l3
[PBLinTerm]
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f [PBLinTerm]
lhs' Integer
rhs (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (Integer
c,Lit
_) <- [PBLinTerm]
lhs'] forall a. Num a => a -> a -> a
- Integer
rhs)