{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.SAT.Encoder.PB.Internal.BDD
-- Copyright   :  (c) Masahiro Sakai 2016
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- References:
--
-- * [ES06] N. Eén and N. Sörensson. Translating Pseudo-Boolean
--   Constraints into SAT. JSAT 2:1–26, 2006.
--
-----------------------------------------------------------------------------
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 :: Encoder m -> PBLinAtLeast -> m ()
addPBLinAtLeastBDD Encoder m
enc PBLinAtLeast
constr = do
  Lit
l <- Encoder m -> PBLinAtLeast -> m Lit
forall (m :: * -> *).
PrimMonad m =>
Encoder m -> PBLinAtLeast -> m Lit
encodePBLinAtLeastBDD Encoder m
enc PBLinAtLeast
constr
  Encoder m -> Clause -> m ()
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 :: Encoder m -> PBLinAtLeast -> m Lit
encodePBLinAtLeastBDD Encoder m
enc (PBLinSum
lhs,Integer
rhs) = do
  let lhs' :: PBLinSum
lhs' = ((Integer, Lit) -> (Integer, Lit) -> Ordering)
-> PBLinSum -> PBLinSum
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Integer, Lit) -> (Integer, Lit) -> Ordering)
-> (Integer, Lit) -> (Integer, Lit) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Integer, Lit) -> Integer)
-> (Integer, Lit) -> (Integer, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Integer, Lit) -> Integer
forall a b. (a, b) -> a
fst)) PBLinSum
lhs
  (StateT (Map PBLinAtLeast Lit) m Lit
 -> Map PBLinAtLeast Lit -> m Lit)
-> Map PBLinAtLeast Lit
-> StateT (Map PBLinAtLeast Lit) m Lit
-> m Lit
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map PBLinAtLeast Lit) m Lit
-> Map PBLinAtLeast Lit -> m Lit
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Map PBLinAtLeast Lit
forall k a. Map k a
Map.empty (StateT (Map PBLinAtLeast Lit) m Lit -> m Lit)
-> StateT (Map PBLinAtLeast Lit) m Lit -> m Lit
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 :: PBLinSum
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f PBLinSum
xs Integer
rhs Integer
slack
          | Integer
rhs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0  = m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Lit -> StateT (Map PBLinAtLeast Lit) m Lit)
-> m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall a b. (a -> b) -> a -> b
$ Encoder m -> Clause -> m Lit
forall (m :: * -> *). PrimMonad m => Encoder m -> Clause -> m Lit
Tseitin.encodeConj Encoder m
enc [] -- true
          | Integer
slack Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Lit -> StateT (Map PBLinAtLeast Lit) m Lit)
-> m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall a b. (a -> b) -> a -> b
$ Encoder m -> Clause -> m Lit
forall (m :: * -> *). PrimMonad m => Encoder m -> Clause -> m Lit
Tseitin.encodeDisj Encoder m
enc [] -- false
          | Bool
otherwise = do
              Map PBLinAtLeast Lit
m <- StateT (Map PBLinAtLeast Lit) m (Map PBLinAtLeast Lit)
forall s (m :: * -> *). MonadState s m => m s
get
              case PBLinAtLeast -> Map PBLinAtLeast Lit -> Maybe Lit
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PBLinSum
xs,Integer
rhs) Map PBLinAtLeast Lit
m of
                Just Lit
l -> Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l
                Maybe Lit
Nothing -> do
                  case PBLinSum
xs of
                    [] -> [Char] -> StateT (Map PBLinAtLeast Lit) m Lit
forall a. HasCallStack => [Char] -> a
error [Char]
"encodePBLinAtLeastBDD: should not happen"
                    [(Integer
_,Lit
l)] -> Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l
                    (Integer
c,Lit
l) : PBLinSum
xs' -> do
                      Lit
thenLit <- PBLinSum
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f PBLinSum
xs' (Integer
rhs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) Integer
slack
                      Lit
l2 <- m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Lit -> StateT (Map PBLinAtLeast Lit) m Lit)
-> m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall a b. (a -> b) -> a -> b
$ Encoder m -> Polarity -> Clause -> m Lit
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
slack then
                              Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l2
                            else do
                              Lit
elseLit <- PBLinSum
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f PBLinSum
xs' Integer
rhs (Integer
slack Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c)
                              m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Lit -> StateT (Map PBLinAtLeast Lit) m Lit)
-> m Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall a b. (a -> b) -> a -> b
$ Encoder m -> Polarity -> Clause -> m Lit
forall (m :: * -> *).
PrimMonad m =>
Encoder m -> Polarity -> Clause -> m Lit
Tseitin.encodeDisjWithPolarity Encoder m
enc Polarity
Tseitin.polarityPos [Lit
l2, Lit
elseLit]
                      (Map PBLinAtLeast Lit -> Map PBLinAtLeast Lit)
-> StateT (Map PBLinAtLeast Lit) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PBLinAtLeast -> Lit -> Map PBLinAtLeast Lit -> Map PBLinAtLeast Lit
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PBLinSum
xs,Integer
rhs) Lit
l3)
                      Lit -> StateT (Map PBLinAtLeast Lit) m Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l3
    PBLinSum
-> Integer -> Integer -> StateT (Map PBLinAtLeast Lit) m Lit
f PBLinSum
lhs' Integer
rhs ([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (Integer
c,Lit
_) <- PBLinSum
lhs'] Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
rhs)