{-# 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 :: 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 [] -- true
          | 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 [] -- false
          | 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)