{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
#endif
#include "MachDeps.h"
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.SAT.Solver.CDCL
-- Copyright   :  (c) Masahiro Sakai 2012-2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- A CDCL SAT solver.
--
-- It follows the design of MiniSat and SAT4J.
--
-- See also:
--
-- * <http://hackage.haskell.org/package/funsat>
--
-- * <http://hackage.haskell.org/package/incremental-sat-solver>
--
-----------------------------------------------------------------------------
module ToySolver.SAT.Solver.CDCL
  (
  -- * The @Solver@ type
    Solver
  , newSolver
  , newSolverWithConfig

  -- * Basic data structures
  , Var
  , Lit
  , literal
  , litNot
  , litVar
  , litPolarity
  , evalLit

  -- * Problem specification
  , newVar
  , newVars
  , newVars_
  , resizeVarCapacity
  -- ** Clauses
  , AddClause (..)
  , Clause
  , evalClause
  , PackedClause
  , packClause
  , unpackClause
  -- ** Cardinality constraints
  , AddCardinality (..)
  , AtLeast
  , Exactly
  , evalAtLeast
  , evalExactly

  -- ** (Linear) pseudo-boolean constraints
  , AddPBLin (..)
  , PBLinTerm
  , PBLinSum
  , PBLinAtLeast
  , PBLinExactly
  , evalPBLinSum
  , evalPBLinAtLeast
  , evalPBLinExactly
  -- ** XOR clauses
  , AddXORClause (..)
  , XORClause
  , evalXORClause
  -- ** Theory
  , setTheory

  -- * Solving
  , solve
  , solveWith
  , BudgetExceeded (..)
  , cancel
  , Canceled (..)

  -- * Extract results
  , IModel (..)
  , Model
  , getModel
  , getFailedAssumptions
  , getAssumptionsImplications

  -- * Solver configulation
  , module ToySolver.SAT.Solver.CDCL.Config
  , getConfig
  , setConfig
  , modifyConfig
  , setVarPolarity
  , setRandomGen
  , getRandomGen
  , setConfBudget

  -- * Callbacks
  , setLogger
  , clearLogger
  , setTerminateCallback
  , clearTerminateCallback
  , setLearnCallback
  , clearLearnCallback

  -- * Read state
  , getNVars
  , getNConstraints
  , getNLearntConstraints
  , getVarFixed
  , getLitFixed
  , getFixedLiterals

  -- * Internal API
  , varBumpActivity
  , varDecayActivity
  ) where

import Prelude hiding (log)
import Control.Loop
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Control.Exception
import Data.Array.IO
import Data.Array.Unsafe (unsafeFreeze)
import Data.Array.Base (unsafeRead, unsafeWrite)
import Data.Bits (xor) -- for defining 'combine' function
import Data.Coerce
import Data.Default.Class
import Data.Either
import Data.Function (on)
import Data.Hashable
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.IORef
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import qualified Data.Set as Set
import ToySolver.Internal.Data.IOURef
import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ
import qualified ToySolver.Internal.Data.Vec as Vec
import Data.Typeable
import System.Clock
import qualified System.Random.MWC as Rand
import Text.Printf

#ifdef __GLASGOW_HASKELL__
import GHC.Types (IO (..))
import GHC.Exts hiding (Constraint)
#endif

import ToySolver.Data.LBool
import ToySolver.SAT.Solver.CDCL.Config
import ToySolver.SAT.Types
import ToySolver.SAT.TheorySolver
import ToySolver.Internal.Util (revMapM)

{--------------------------------------------------------------------
  LitArray
--------------------------------------------------------------------}

newtype LitArray = LitArray (IOUArray Int PackedLit) deriving (LitArray -> LitArray -> Bool
(LitArray -> LitArray -> Bool)
-> (LitArray -> LitArray -> Bool) -> Eq LitArray
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LitArray -> LitArray -> Bool
$c/= :: LitArray -> LitArray -> Bool
== :: LitArray -> LitArray -> Bool
$c== :: LitArray -> LitArray -> Bool
Eq)

newLitArray :: [Lit] -> IO LitArray
newLitArray :: [Lit] -> IO LitArray
newLitArray [Lit]
lits = do
  let size :: Lit
size = [Lit] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [Lit]
lits
  (IOUArray Lit PackedLit -> LitArray)
-> IO (IOUArray Lit PackedLit) -> IO LitArray
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM IOUArray Lit PackedLit -> LitArray
LitArray (IO (IOUArray Lit PackedLit) -> IO LitArray)
-> IO (IOUArray Lit PackedLit) -> IO LitArray
forall a b. (a -> b) -> a -> b
$ (Lit, Lit) -> [PackedLit] -> IO (IOUArray Lit PackedLit)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (Lit
0, Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) ((Lit -> PackedLit) -> [Lit] -> [PackedLit]
forall a b. (a -> b) -> [a] -> [b]
map Lit -> PackedLit
packLit [Lit]
lits)

readLitArray :: LitArray -> Int -> IO Lit
#if EXTRA_BOUNDS_CHECKING
readLitArray (LitArray a) i = liftM unpackLit $ readArray a i
#else
readLitArray :: LitArray -> Lit -> IO Lit
readLitArray (LitArray IOUArray Lit PackedLit
a) Lit
i = (PackedLit -> Lit) -> IO PackedLit -> IO Lit
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PackedLit -> Lit
unpackLit (IO PackedLit -> IO Lit) -> IO PackedLit -> IO Lit
forall a b. (a -> b) -> a -> b
$ IOUArray Lit PackedLit -> Lit -> IO PackedLit
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Lit -> m e
unsafeRead IOUArray Lit PackedLit
a Lit
i
#endif

writeLitArray :: LitArray -> Int -> Lit -> IO ()
#if EXTRA_BOUNDS_CHECKING
writeLitArray (LitArray a) i lit = writeArray a i (packLit lit)
#else
writeLitArray :: LitArray -> Lit -> Lit -> IO ()
writeLitArray (LitArray IOUArray Lit PackedLit
a) Lit
i Lit
lit = IOUArray Lit PackedLit -> Lit -> PackedLit -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Lit -> e -> m ()
unsafeWrite IOUArray Lit PackedLit
a Lit
i (Lit -> PackedLit
packLit Lit
lit)
#endif

getLits :: LitArray -> IO [Lit]
getLits :: LitArray -> IO [Lit]
getLits (LitArray IOUArray Lit PackedLit
a) = ([PackedLit] -> [Lit]) -> IO [PackedLit] -> IO [Lit]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((PackedLit -> Lit) -> [PackedLit] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map PackedLit -> Lit
unpackLit) (IO [PackedLit] -> IO [Lit]) -> IO [PackedLit] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ IOUArray Lit PackedLit -> IO [PackedLit]
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m [e]
getElems IOUArray Lit PackedLit
a

getLitArraySize :: LitArray -> IO Int
getLitArraySize :: LitArray -> IO Lit
getLitArraySize (LitArray IOUArray Lit PackedLit
a) = do
  (Lit
lb,Lit
ub) <- IOUArray Lit PackedLit -> IO (Lit, Lit)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOUArray Lit PackedLit
a
  Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
lb Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> IO Lit) -> Lit -> IO Lit
forall a b. (a -> b) -> a -> b
$! Lit
ubLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
lbLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1

{--------------------------------------------------------------------
  internal data structures
--------------------------------------------------------------------}

type Level = Int

levelRoot :: Level
levelRoot :: Lit
levelRoot = Lit
0

litIndex :: Lit -> Int
litIndex :: Lit -> Lit
litIndex Lit
l = Lit
2 Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
* (Lit -> Lit
litVar Lit
l Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ (if Lit -> Bool
litPolarity Lit
l then Lit
1 else Lit
0)

{-# INLINE varValue #-}
varValue :: Solver -> Var -> IO LBool
varValue :: Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v = (Int8 -> LBool) -> IO Int8 -> IO LBool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int8 -> LBool
coerce (IO Int8 -> IO LBool) -> IO Int8 -> IO LBool
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Int8 -> Lit -> IO Int8
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

{-# INLINE litValue #-}
litValue :: Solver -> Lit -> IO LBool
litValue :: Solver -> Lit -> IO LBool
litValue Solver
solver !Lit
l = do
  -- litVar による heap allocation を避けるために、
  -- litPolarityによる分岐後にvarValueを呼ぶ。
  if Lit -> Bool
litPolarity Lit
l then
    Solver -> Lit -> IO LBool
varValue Solver
solver Lit
l
  else do
    LBool
m <- Solver -> Lit -> IO LBool
varValue Solver
solver (Lit -> Lit
forall a. Num a => a -> a
negate Lit
l)
    LBool -> IO LBool
forall (m :: * -> *) a. Monad m => a -> m a
return (LBool -> IO LBool) -> LBool -> IO LBool
forall a b. (a -> b) -> a -> b
$! LBool -> LBool
lnot LBool
m

getVarFixed :: Solver -> Var -> IO LBool
getVarFixed :: Solver -> Lit -> IO LBool
getVarFixed Solver
solver !Lit
v = do
  Lit
lv <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
  if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot then
    Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
  else
    LBool -> IO LBool
forall (m :: * -> *) a. Monad m => a -> m a
return LBool
lUndef

getLitFixed :: Solver -> Lit -> IO LBool
getLitFixed :: Solver -> Lit -> IO LBool
getLitFixed Solver
solver !Lit
l = do
  -- litVar による heap allocation を避けるために、
  -- litPolarityによる分岐後にvarGetFixedを呼ぶ。
  if Lit -> Bool
litPolarity Lit
l then
    Solver -> Lit -> IO LBool
getVarFixed Solver
solver Lit
l
  else do
    LBool
m <- Solver -> Lit -> IO LBool
getVarFixed Solver
solver (Lit -> Lit
forall a. Num a => a -> a
negate Lit
l)
    LBool -> IO LBool
forall (m :: * -> *) a. Monad m => a -> m a
return (LBool -> IO LBool) -> LBool -> IO LBool
forall a b. (a -> b) -> a -> b
$! LBool -> LBool
lnot LBool
m

getNFixed :: Solver -> IO Int
getNFixed :: Solver -> IO Lit
getNFixed Solver
solver = do
  Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver
  if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot then
    GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  else
    GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver) Lit
0

-- | it returns a set of literals that are fixed without any assumptions.
getFixedLiterals :: Solver -> IO [Lit]
getFixedLiterals :: Solver -> IO [Lit]
getFixedLiterals Solver
solver = do
  Lit
n <- Solver -> IO Lit
getNFixed Solver
solver
  (Lit -> IO Lit) -> [Lit] -> IO [Lit]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
revMapM (GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)) [Lit
0..Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1]

varLevel :: Solver -> Var -> IO Level
varLevel :: Solver -> Lit -> IO Lit
varLevel Solver
solver !Lit
v = do
  LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char]
"ToySolver.SAT.varLevel: unassigned var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Lit -> [Char]
forall a. Show a => a -> [Char]
show Lit
v)
  GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

litLevel :: Solver -> Lit -> IO Level
litLevel :: Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
l = Solver -> Lit -> IO Lit
varLevel Solver
solver (Lit -> Lit
litVar Lit
l)

varReason :: Solver -> Var -> IO (Maybe SomeConstraintHandler)
varReason :: Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver !Lit
v = do
  LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char]
"ToySolver.SAT.varReason: unassigned var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Lit -> [Char]
forall a. Show a => a -> [Char]
show Lit
v)
  GenericVec IOArray (Maybe SomeConstraintHandler)
-> Lit -> IO (Maybe SomeConstraintHandler)
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

varAssignNo :: Solver -> Var -> IO Int
varAssignNo :: Solver -> Lit -> IO Lit
varAssignNo Solver
solver !Lit
v = do
  LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char]
"ToySolver.SAT.varAssignNo: unassigned var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Lit -> [Char]
forall a. Show a => a -> [Char]
show Lit
v)
  GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarTrailIndex Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

-- | Solver instance
data Solver
  = Solver
  { Solver -> IORef Bool
svOk           :: !(IORef Bool)

  , Solver -> PriorityQueue
svVarQueue     :: !PQ.PriorityQueue
  , Solver -> GenericVec IOUArray Lit
svTrail        :: !(Vec.UVec Lit)
  , Solver -> GenericVec IOUArray Lit
svTrailLimit   :: !(Vec.UVec Lit)
  , Solver -> IOURef Lit
svTrailNPropagated :: !(IOURef Int)

  -- variable information
  , Solver -> GenericVec IOUArray Int8
svVarValue      :: !(Vec.UVec Int8) -- should be 'Vec.UVec LBool' but it's difficult to define MArray instance
  , Solver -> UVec Bool
svVarPolarity   :: !(Vec.UVec Bool)
  , Solver -> UVec VarActivity
svVarActivity   :: !(Vec.UVec VarActivity)
  , Solver -> GenericVec IOUArray Lit
svVarTrailIndex :: !(Vec.UVec Int)
  , Solver -> GenericVec IOUArray Lit
svVarLevel      :: !(Vec.UVec Int)
  -- | will be invoked once when the variable is assigned
  , Solver -> Vec [SomeConstraintHandler]
svVarWatches      :: !(Vec.Vec [SomeConstraintHandler])
  , Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned :: !(Vec.Vec [SomeConstraintHandler])
  , Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason       :: !(Vec.Vec (Maybe SomeConstraintHandler))
  -- | exponential moving average estimate
  , Solver -> UVec VarActivity
svVarEMAScaled    :: !(Vec.UVec Double)
  -- | When v was last assigned
  , Solver -> GenericVec IOUArray Lit
svVarWhenAssigned :: !(Vec.UVec Int)
  -- | The number of learnt clauses v participated in generating since Assigned.
  , Solver -> GenericVec IOUArray Lit
svVarParticipated :: !(Vec.UVec Int)
  -- | The number of learnt clauses v reasoned in generating since Assigned.
  , Solver -> GenericVec IOUArray Lit
svVarReasoned     :: !(Vec.UVec Int)

  -- | will be invoked when this literal is falsified
  , Solver -> Vec [SomeConstraintHandler]
svLitWatches   :: !(Vec.Vec [SomeConstraintHandler])
  , Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList :: !(Vec.Vec (HashSet SomeConstraintHandler))

  , Solver -> IORef [SomeConstraintHandler]
svConstrDB     :: !(IORef [SomeConstraintHandler])
  , Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB     :: !(IORef (Int,[SomeConstraintHandler]))

  -- Theory
  , Solver -> IORef (Maybe TheorySolver)
svTheorySolver  :: !(IORef (Maybe TheorySolver))
  , Solver -> IOURef Lit
svTheoryChecked :: !(IOURef Int)

  -- Result
  , Solver -> IORef (Maybe Model)
svModel        :: !(IORef (Maybe Model))
  , Solver -> IORef LitSet
svFailedAssumptions :: !(IORef LitSet)
  , Solver -> IORef LitSet
svAssumptionsImplications :: !(IORef LitSet)

  -- Statistics
  , Solver -> IOURef Lit
svNDecision    :: !(IOURef Int)
  , Solver -> IOURef Lit
svNRandomDecision :: !(IOURef Int)
  , Solver -> IOURef Lit
svNConflict    :: !(IOURef Int)
  , Solver -> IOURef Lit
svNRestart     :: !(IOURef Int)
  , Solver -> IOURef Lit
svNLearntGC    :: !(IOURef Int)
  , Solver -> IOURef Lit
svNRemovedConstr :: !(IOURef Int)

  -- Configulation
  , Solver -> IORef Config
svConfig :: !(IORef Config)
  , Solver -> IORef GenIO
svRandomGen  :: !(IORef Rand.GenIO)
  , Solver -> IOURef Lit
svConfBudget :: !(IOURef Int)
  , Solver -> IORef (Maybe (IO Bool))
svTerminateCallback :: !(IORef (Maybe (IO Bool)))
  , Solver -> IORef (Maybe ([Lit] -> IO ()))
svLearnCallback :: !(IORef (Maybe (Clause -> IO ())))

  -- Logging
  , Solver -> IORef (Maybe ([Char] -> IO ()))
svLogger :: !(IORef (Maybe (String -> IO ())))
  , Solver -> IORef TimeSpec
svStartWC    :: !(IORef TimeSpec)
  , Solver -> IORef TimeSpec
svLastStatWC :: !(IORef TimeSpec)

  -- Working spaces
  , Solver -> IORef Bool
svCanceled        :: !(IORef Bool)
  , Solver -> GenericVec IOUArray Lit
svAssumptions     :: !(Vec.UVec Lit)
  , Solver -> IORef Lit
svLearntLim       :: !(IORef Int)
  , Solver -> IORef Lit
svLearntLimAdjCnt :: !(IORef Int)
  , Solver -> IORef [(Lit, Lit)]
svLearntLimSeq    :: !(IORef [(Int,Int)])
  , Solver -> UVec Bool
svSeen :: !(Vec.UVec Bool)
  , Solver -> IORef (Maybe PBLinAtLeast)
svPBLearnt :: !(IORef (Maybe PBLinAtLeast))

  -- | Amount to bump next variable with.
  , Solver -> IOURef VarActivity
svVarInc       :: !(IOURef Double)

  -- | Amount to bump next constraint with.
  , Solver -> IOURef VarActivity
svConstrInc    :: !(IOURef Double)

  -- ERWA / LRB

  -- | step-size parameter α
  , Solver -> IOURef VarActivity
svERWAStepSize :: !(IOURef Double)
  , Solver -> IOURef VarActivity
svEMAScale :: !(IOURef Double)
  , Solver -> IOURef Lit
svLearntCounter :: !(IOURef Int)
  }

markBad :: Solver -> IO ()
markBad :: Solver -> IO ()
markBad Solver
solver = do
  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svOk Solver
solver) Bool
False
  Solver -> IO ()
bcpClear Solver
solver

bcpDequeue :: Solver -> IO (Maybe Lit)
bcpDequeue :: Solver -> IO (Maybe Lit)
bcpDequeue Solver
solver = do
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  Lit
m <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svTrailNPropagated Solver
solver)
  if Lit
mLit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
n then
    Maybe Lit -> IO (Maybe Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Lit
forall a. Maybe a
Nothing
  else do
    -- m < n
    Lit
lit <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
m
    IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svTrailNPropagated Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
    Maybe Lit -> IO (Maybe Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
lit)

bcpIsEmpty :: Solver -> IO Bool
bcpIsEmpty :: Solver -> IO Bool
bcpIsEmpty Solver
solver = do
  Lit
p <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svTrailNPropagated Solver
solver)
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Lit
n Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
p

bcpCheckEmpty :: Solver -> IO ()
bcpCheckEmpty :: Solver -> IO ()
bcpCheckEmpty Solver
solver = do
  Bool
empty <- Solver -> IO Bool
bcpIsEmpty Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"BUG: BCP Queue should be empty at this point"

bcpClear :: Solver -> IO ()
bcpClear :: Solver -> IO ()
bcpClear Solver
solver = do
  Lit
m <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svTrailNPropagated Solver
solver) Lit
m

assignBy :: Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy :: Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
c = do
  Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver
  let !c2 :: Maybe SomeConstraintHandler
c2 = if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot
            then Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
            else SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just SomeConstraintHandler
c
  Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool
assign_ Solver
solver Lit
lit Maybe SomeConstraintHandler
c2

assign :: Solver -> Lit -> IO Bool
assign :: Solver -> Lit -> IO Bool
assign Solver
solver Lit
lit = Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool
assign_ Solver
solver Lit
lit Maybe SomeConstraintHandler
forall a. Maybe a
Nothing

assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool
assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool
assign_ Solver
solver !Lit
lit Maybe SomeConstraintHandler
reason = Bool -> IO Bool -> IO Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit -> Bool
validLit Lit
lit) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
  let val :: LBool
val = Bool -> LBool
liftBool (Lit -> Bool
litPolarity Lit
lit)

  LBool
val0 <- Solver -> Lit -> IO LBool
varValue Solver
solver (Lit -> Lit
litVar Lit
lit)
  if LBool
val0 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef then do
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val0
  else do
    Lit
idx <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
    Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver

    GenericVec IOUArray Int8 -> Lit -> Int8 -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (LBool -> Int8
coerce LBool
val)
    GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarTrailIndex Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
idx
    GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
lv
    GenericVec IOArray (Maybe SomeConstraintHandler)
-> Lit -> Maybe SomeConstraintHandler -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Maybe SomeConstraintHandler
reason
    GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarWhenAssigned Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svLearntCounter Solver
solver)
    GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarParticipated Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
0
    GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarReasoned Solver
solver) (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
0

    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
lit

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let r :: [Char]
r = case Maybe SomeConstraintHandler
reason of
                Maybe SomeConstraintHandler
Nothing -> [Char]
""
                Just SomeConstraintHandler
_ -> [Char]
" by propagation"
      [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> Lit -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"assign(level=%d): %d%s" Lit
lv Lit
lit [Char]
r

    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

unassign :: Solver -> Var -> IO ()
unassign :: Solver -> Lit -> IO ()
unassign Solver
solver !Lit
v = Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit -> Bool
validVar Lit
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"unassign: should not happen"

  Bool
flag <- Config -> Bool
configEnablePhaseSaving (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UVec Bool -> Lit -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svVarPolarity Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$! Maybe Bool -> Bool
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val)

  GenericVec IOUArray Int8 -> Lit -> Int8 -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (LBool -> Int8
coerce LBool
lUndef)
  GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarTrailIndex Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
forall a. Bounded a => a
maxBound
  GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Lit
forall a. Bounded a => a
maxBound
  GenericVec IOArray (Maybe SomeConstraintHandler)
-> Lit -> Maybe SomeConstraintHandler -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Maybe SomeConstraintHandler
forall a. Maybe a
Nothing

  -- ERWA / LRB computation
  Lit
interval <- do
    Lit
t2 <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svLearntCounter Solver
solver)
    Lit
t1 <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarWhenAssigned Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
    Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
t2 Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
t1)
  -- Interval = 0 is possible due to restarts.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
interval Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lit
participated <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarParticipated Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
    Lit
reasoned <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svVarReasoned Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
    VarActivity
alpha <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svERWAStepSize Solver
solver)
    let learningRate :: VarActivity
learningRate = Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
participated VarActivity -> VarActivity -> VarActivity
forall a. Fractional a => a -> a -> a
/ Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
interval
        reasonSideRate :: VarActivity
reasonSideRate = Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
reasoned VarActivity -> VarActivity -> VarActivity
forall a. Fractional a => a -> a -> a
/ Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
interval
    VarActivity
scale <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svEMAScale Solver
solver)
    -- ema := (1 - α)ema + α*r
    UVec VarActivity -> Lit -> (VarActivity -> VarActivity) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> UVec VarActivity
svVarEMAScaled Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (\VarActivity
orig -> (VarActivity
1 VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
- VarActivity
alpha) VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
orig VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
+ VarActivity
alpha VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
scale VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* (VarActivity
learningRate VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
+ VarActivity
reasonSideRate))
    -- If v is assigned by random decision, it's possible that v is still in the queue.
    PriorityQueue -> Lit -> IO ()
PQ.update (Solver -> PriorityQueue
svVarQueue Solver
solver) Lit
v

  let !l :: Lit
l = if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then Lit
v else -Lit
v
  [SomeConstraintHandler]
cs <- Vec [SomeConstraintHandler] -> Lit -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
  Vec [SomeConstraintHandler]
-> Lit -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) []
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
cs ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c ->
    Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c Lit
l

  PriorityQueue -> Lit -> IO ()
forall q (m :: * -> *) a. Enqueue q m a => q -> a -> m ()
PQ.enqueue (Solver -> PriorityQueue
svVarQueue Solver
solver) Lit
v

addOnUnassigned :: Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned :: Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
constr !Lit
l = do
  LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver (Lit -> Lit
litVar Lit
l)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"addOnUnassigned: should not happen"
  Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) (Lit -> Lit
litVar Lit
l Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (SomeConstraintHandler
constr SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:)

-- | Register the constraint to be notified when the literal becames false.
watchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver !Lit
lit SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) (Lit -> Lit
litIndex Lit
lit) (SomeConstraintHandler
c SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: )

-- | Register the constraint to be notified when the variable is assigned.
watchVar :: Solver -> Var -> SomeConstraintHandler -> IO ()
watchVar :: Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver !Lit
var SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) (Lit
var Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (SomeConstraintHandler
c SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:)

unwatchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver !Lit
lit SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) (Lit -> Lit
litIndex Lit
lit) (SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. Eq a => a -> [a] -> [a]
delete SomeConstraintHandler
c)

unwatchVar :: Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchVar :: Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchVar Solver
solver !Lit
var SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) (Lit
var Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. Eq a => a -> [a] -> [a]
delete SomeConstraintHandler
c)

addToDB :: ConstraintHandler c => Solver -> c -> IO ()
addToDB :: Solver -> c -> IO ()
addToDB Solver
solver c
c = do
  let c2 :: SomeConstraintHandler
c2 = c -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler c
c
  IORef [SomeConstraintHandler]
-> ([SomeConstraintHandler] -> [SomeConstraintHandler]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver) (SomeConstraintHandler
c2 SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: )
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char]
str <- c -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler c
c
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"constraint %s is added" [Char]
str

  Bool
b <- c -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable c
c
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (PBLinSum
lhs,Integer
_) <- c -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast c
c
    PBLinSum -> (PBLinTerm -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PBLinSum
lhs ((PBLinTerm -> IO ()) -> IO ()) -> (PBLinTerm -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Lit
lit) -> do
       Vec (HashSet SomeConstraintHandler)
-> Lit
-> (HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler)
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Lit -> Lit
litIndex Lit
lit) (SomeConstraintHandler
-> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert SomeConstraintHandler
c2)

addToLearntDB :: ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB :: Solver -> c -> IO ()
addToLearntDB Solver
solver c
c = do
  IORef (Lit, [SomeConstraintHandler])
-> ((Lit, [SomeConstraintHandler])
    -> (Lit, [SomeConstraintHandler]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver) (((Lit, [SomeConstraintHandler]) -> (Lit, [SomeConstraintHandler]))
 -> IO ())
-> ((Lit, [SomeConstraintHandler])
    -> (Lit, [SomeConstraintHandler]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Lit
n,[SomeConstraintHandler]
xs) -> (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1, c -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler c
c SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: [SomeConstraintHandler]
xs)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char]
str <- c -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler c
c
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"constraint %s is added" [Char]
str

reduceDB :: Solver -> IO ()
reduceDB :: Solver -> IO ()
reduceDB Solver
solver = do
  (Lit
_,[SomeConstraintHandler]
cs) <- IORef (Lit, [SomeConstraintHandler])
-> IO (Lit, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver)

  [(SomeConstraintHandler, (Bool, VarActivity))]
xs <- [SomeConstraintHandler]
-> (SomeConstraintHandler
    -> IO (SomeConstraintHandler, (Bool, VarActivity)))
-> IO [(SomeConstraintHandler, (Bool, VarActivity))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SomeConstraintHandler]
cs ((SomeConstraintHandler
  -> IO (SomeConstraintHandler, (Bool, VarActivity)))
 -> IO [(SomeConstraintHandler, (Bool, VarActivity))])
-> (SomeConstraintHandler
    -> IO (SomeConstraintHandler, (Bool, VarActivity)))
-> IO [(SomeConstraintHandler, (Bool, VarActivity))]
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    Bool
p <- Solver -> SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver SomeConstraintHandler
c
    VarActivity
w <- Solver -> SomeConstraintHandler -> IO VarActivity
forall a. ConstraintHandler a => Solver -> a -> IO VarActivity
constrWeight Solver
solver SomeConstraintHandler
c
    VarActivity
actval <- SomeConstraintHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity SomeConstraintHandler
c
    (SomeConstraintHandler, (Bool, VarActivity))
-> IO (SomeConstraintHandler, (Bool, VarActivity))
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler
c, (Bool
p, VarActivity
wVarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*VarActivity
actval))

  -- Note that False <= True
  let ys :: [(SomeConstraintHandler, (Bool, VarActivity))]
ys = ((SomeConstraintHandler, (Bool, VarActivity))
 -> (SomeConstraintHandler, (Bool, VarActivity)) -> Ordering)
-> [(SomeConstraintHandler, (Bool, VarActivity))]
-> [(SomeConstraintHandler, (Bool, VarActivity))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((SomeConstraintHandler, (Bool, VarActivity))
 -> (Bool, VarActivity))
-> (SomeConstraintHandler, (Bool, VarActivity))
-> (SomeConstraintHandler, (Bool, VarActivity))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SomeConstraintHandler, (Bool, VarActivity)) -> (Bool, VarActivity)
forall a b. (a, b) -> b
snd) [(SomeConstraintHandler, (Bool, VarActivity))]
xs
      ([(SomeConstraintHandler, (Bool, VarActivity))]
zs,[(SomeConstraintHandler, (Bool, VarActivity))]
ws) = Lit
-> [(SomeConstraintHandler, (Bool, VarActivity))]
-> ([(SomeConstraintHandler, (Bool, VarActivity))],
    [(SomeConstraintHandler, (Bool, VarActivity))])
forall a. Lit -> [a] -> ([a], [a])
splitAt ([(SomeConstraintHandler, (Bool, VarActivity))] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [(SomeConstraintHandler, (Bool, VarActivity))]
ys Lit -> Lit -> Lit
forall a. Integral a => a -> a -> a
`div` Lit
2) [(SomeConstraintHandler, (Bool, VarActivity))]
ys

  let loop :: [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [] [SomeConstraintHandler]
ret = [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeConstraintHandler]
ret
      loop ((SomeConstraintHandler
c,(Bool
isShort,b
_)) : [(SomeConstraintHandler, (Bool, b))]
rest) [SomeConstraintHandler]
ret = do
        Bool
flag <- if Bool
isShort
                then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Solver -> SomeConstraintHandler -> IO Bool
isLocked Solver
solver SomeConstraintHandler
c
        if Bool
flag then
          [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, b))]
rest (SomeConstraintHandler
cSomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:[SomeConstraintHandler]
ret)
        else do
          Solver -> SomeConstraintHandler -> IO ()
detach Solver
solver SomeConstraintHandler
c
          [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, b))]
rest [SomeConstraintHandler]
ret
  [SomeConstraintHandler]
zs2 <- [(SomeConstraintHandler, (Bool, VarActivity))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall b.
[(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, VarActivity))]
zs []

  let cs2 :: [SomeConstraintHandler]
cs2 = [SomeConstraintHandler]
zs2 [SomeConstraintHandler]
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. [a] -> [a] -> [a]
++ ((SomeConstraintHandler, (Bool, VarActivity))
 -> SomeConstraintHandler)
-> [(SomeConstraintHandler, (Bool, VarActivity))]
-> [SomeConstraintHandler]
forall a b. (a -> b) -> [a] -> [b]
map (SomeConstraintHandler, (Bool, VarActivity))
-> SomeConstraintHandler
forall a b. (a, b) -> a
fst [(SomeConstraintHandler, (Bool, VarActivity))]
ws
      n2 :: Lit
n2 = [SomeConstraintHandler] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [SomeConstraintHandler]
cs2

  -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2
  IORef (Lit, [SomeConstraintHandler])
-> (Lit, [SomeConstraintHandler]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver) (Lit
n2,[SomeConstraintHandler]
cs2)

type VarActivity = Double

varActivity :: Solver -> Var -> IO VarActivity
varActivity :: Solver -> Lit -> IO VarActivity
varActivity Solver
solver Lit
v = UVec VarActivity -> Lit -> IO VarActivity
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec VarActivity
svVarActivity Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

varDecayActivity :: Solver -> IO ()
varDecayActivity :: Solver -> IO ()
varDecayActivity Solver
solver = do
  VarActivity
d <- Config -> VarActivity
configVarDecay (Config -> VarActivity) -> IO Config -> IO VarActivity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  IOURef VarActivity -> (VarActivity -> VarActivity) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef VarActivity
svVarInc Solver
solver) (VarActivity
dVarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*)

varBumpActivity :: Solver -> Var -> IO ()
varBumpActivity :: Solver -> Lit -> IO ()
varBumpActivity Solver
solver !Lit
v = do
  VarActivity
inc <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svVarInc Solver
solver)
  UVec VarActivity -> Lit -> (VarActivity -> VarActivity) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> UVec VarActivity
svVarActivity Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
+VarActivity
inc)
  Config
conf <- Solver -> IO Config
getConfig Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> BranchingStrategy
configBranchingStrategy Config
conf BranchingStrategy -> BranchingStrategy -> Bool
forall a. Eq a => a -> a -> Bool
== BranchingStrategy
BranchingVSIDS) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    PriorityQueue -> Lit -> IO ()
PQ.update (Solver -> PriorityQueue
svVarQueue Solver
solver) Lit
v
  VarActivity
aval <- UVec VarActivity -> Lit -> IO VarActivity
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec VarActivity
svVarActivity Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
aval VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
1e20) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- Rescale
    Solver -> IO ()
varRescaleAllActivity Solver
solver

varRescaleAllActivity :: Solver -> IO ()
varRescaleAllActivity :: Solver -> IO ()
varRescaleAllActivity Solver
solver = do
  let a :: UVec VarActivity
a = Solver -> UVec VarActivity
svVarActivity Solver
solver
  Lit
n <- Solver -> IO Lit
getNVars Solver
solver
  Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
0 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i ->
    UVec VarActivity -> Lit -> (VarActivity -> VarActivity) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify UVec VarActivity
a Lit
i (VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
1e-20)
  IOURef VarActivity -> (VarActivity -> VarActivity) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef VarActivity
svVarInc Solver
solver) (VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
1e-20)

varEMAScaled :: Solver -> Var -> IO Double
varEMAScaled :: Solver -> Lit -> IO VarActivity
varEMAScaled Solver
solver Lit
v = UVec VarActivity -> Lit -> IO VarActivity
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec VarActivity
svVarEMAScaled Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)

varIncrementParticipated :: Solver -> Var -> IO ()
varIncrementParticipated :: Solver -> Lit -> IO ()
varIncrementParticipated Solver
solver Lit
v = GenericVec IOUArray Lit -> Lit -> (Lit -> Lit) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> GenericVec IOUArray Lit
svVarParticipated Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)

varIncrementReasoned :: Solver -> Var -> IO ()
varIncrementReasoned :: Solver -> Lit -> IO ()
varIncrementReasoned Solver
solver Lit
v = GenericVec IOUArray Lit -> Lit -> (Lit -> Lit) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> GenericVec IOUArray Lit
svVarReasoned Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)

varEMADecay :: Solver -> IO ()
varEMADecay :: Solver -> IO ()
varEMADecay Solver
solver = do
  Config
config <- Solver -> IO Config
getConfig Solver
solver

  VarActivity
alpha <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svERWAStepSize Solver
solver)
  let alphaMin :: VarActivity
alphaMin = Config -> VarActivity
configERWAStepSizeMin Config
config
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
alpha VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
alphaMin) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IOURef VarActivity -> VarActivity -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef VarActivity
svERWAStepSize Solver
solver) (VarActivity -> VarActivity -> VarActivity
forall a. Ord a => a -> a -> a
max VarActivity
alphaMin (VarActivity
alpha VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
- Config -> VarActivity
configERWAStepSizeDec Config
config))

  case Config -> BranchingStrategy
configBranchingStrategy Config
config of
    BranchingStrategy
BranchingLRB -> do
      IOURef VarActivity -> (VarActivity -> VarActivity) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef VarActivity
svEMAScale Solver
solver) (Config -> VarActivity
configEMADecay Config
config VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*)
      VarActivity
scale <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svEMAScale Solver
solver)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
scale VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
1e20) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Lit
n <- Solver -> IO Lit
getNVars Solver
solver
        let a :: UVec VarActivity
a = Solver -> UVec VarActivity
svVarEMAScaled Solver
solver
        Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
0 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i -> UVec VarActivity -> Lit -> (VarActivity -> VarActivity) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify UVec VarActivity
a Lit
i (VarActivity -> VarActivity -> VarActivity
forall a. Fractional a => a -> a -> a
/ VarActivity
scale)
        IOURef VarActivity -> VarActivity -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef VarActivity
svEMAScale Solver
solver) VarActivity
1.0
    BranchingStrategy
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

variables :: Solver -> IO [Var]
variables :: Solver -> IO [Lit]
variables Solver
solver = do
  Lit
n <- Solver -> IO Lit
getNVars Solver
solver
  [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit
1 .. Lit
n]

-- | number of variables of the problem.
getNVars :: Solver -> IO Int
getNVars :: Solver -> IO Lit
getNVars Solver
solver = GenericVec IOUArray Int8 -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver)

-- | number of assigned
getNAssigned :: Solver -> IO Int
getNAssigned :: Solver -> IO Lit
getNAssigned Solver
solver = GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)

-- | number of constraints.
getNConstraints :: Solver -> IO Int
getNConstraints :: Solver -> IO Lit
getNConstraints Solver
solver = do
  [SomeConstraintHandler]
xs <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> IO Lit) -> Lit -> IO Lit
forall a b. (a -> b) -> a -> b
$ [SomeConstraintHandler] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [SomeConstraintHandler]
xs

-- | number of learnt constrints.
getNLearntConstraints :: Solver -> IO Int
getNLearntConstraints :: Solver -> IO Lit
getNLearntConstraints Solver
solver = do
  (Lit
n,[SomeConstraintHandler]
_) <- IORef (Lit, [SomeConstraintHandler])
-> IO (Lit, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver)
  Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
n

learntConstraints :: Solver -> IO [SomeConstraintHandler]
learntConstraints :: Solver -> IO [SomeConstraintHandler]
learntConstraints Solver
solver = do
  (Lit
_,[SomeConstraintHandler]
cs) <- IORef (Lit, [SomeConstraintHandler])
-> IO (Lit, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver)
  [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeConstraintHandler]
cs

{--------------------------------------------------------------------
  Solver
--------------------------------------------------------------------}

-- | Create a new 'Solver' instance.
newSolver :: IO Solver
newSolver :: IO Solver
newSolver = Config -> IO Solver
newSolverWithConfig Config
forall a. Default a => a
def

-- | Create a new 'Solver' instance with a given configulation.
newSolverWithConfig :: Config -> IO Solver
newSolverWithConfig :: Config -> IO Solver
newSolverWithConfig Config
config = do
 rec
  IORef Bool
ok   <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
  GenericVec IOUArray Lit
trail <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
trail_lim <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  IOURef Lit
trail_nprop <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0

  GenericVec IOUArray Int8
varValue <- IO (GenericVec IOUArray Int8)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  UVec Bool
varPolarity <- IO (UVec Bool)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  UVec VarActivity
varActivity <- IO (UVec VarActivity)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
varTrailIndex <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
varLevel <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  Vec [SomeConstraintHandler]
varWatches <- IO (Vec [SomeConstraintHandler])
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  Vec [SomeConstraintHandler]
varOnUnassigned <- IO (Vec [SomeConstraintHandler])
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOArray (Maybe SomeConstraintHandler)
varReason <- IO (GenericVec IOArray (Maybe SomeConstraintHandler))
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  UVec VarActivity
varEMAScaled <- IO (UVec VarActivity)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
varWhenAssigned <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
varParticipated <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit
varReasoned <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  Vec [SomeConstraintHandler]
litWatches <- IO (Vec [SomeConstraintHandler])
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  Vec (HashSet SomeConstraintHandler)
litOccurList <- IO (Vec (HashSet SomeConstraintHandler))
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new

  PriorityQueue
vqueue <- (Lit -> Lit -> IO Bool) -> IO PriorityQueue
PQ.newPriorityQueueBy (Solver -> Lit -> Lit -> IO Bool
ltVar Solver
solver)
  IORef [SomeConstraintHandler]
db  <- [SomeConstraintHandler] -> IO (IORef [SomeConstraintHandler])
forall a. a -> IO (IORef a)
newIORef []
  IORef (Lit, [SomeConstraintHandler])
db2 <- (Lit, [SomeConstraintHandler])
-> IO (IORef (Lit, [SomeConstraintHandler]))
forall a. a -> IO (IORef a)
newIORef (Lit
0,[])
  GenericVec IOUArray Lit
as  <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  IORef (Maybe Model)
m   <- Maybe Model -> IO (IORef (Maybe Model))
forall a. a -> IO (IORef a)
newIORef Maybe Model
forall a. Maybe a
Nothing
  IORef Bool
canceled <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IOURef Lit
ndecision <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0
  IOURef Lit
nranddec  <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0
  IOURef Lit
nconflict <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0
  IOURef Lit
nrestart  <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0
  IOURef Lit
nlearntgc <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0
  IOURef Lit
nremoved  <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0

  IOURef VarActivity
constrInc   <- VarActivity -> IO (IOURef VarActivity)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef VarActivity
1
  IOURef VarActivity
varInc   <- VarActivity -> IO (IOURef VarActivity)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef VarActivity
1

  IORef Config
configRef <- Config -> IO (IORef Config)
forall a. a -> IO (IORef a)
newIORef Config
config

  IORef Lit
learntLim       <- Lit -> IO (IORef Lit)
forall a. a -> IO (IORef a)
newIORef Lit
forall a. (?callStack::CallStack) => a
undefined
  IORef Lit
learntLimAdjCnt <- Lit -> IO (IORef Lit)
forall a. a -> IO (IORef a)
newIORef (-Lit
1)
  IORef [(Lit, Lit)]
learntLimSeq    <- [(Lit, Lit)] -> IO (IORef [(Lit, Lit)])
forall a. a -> IO (IORef a)
newIORef [(Lit, Lit)]
forall a. (?callStack::CallStack) => a
undefined

  IORef (Maybe ([Char] -> IO ()))
logger <- Maybe ([Char] -> IO ()) -> IO (IORef (Maybe ([Char] -> IO ())))
forall a. a -> IO (IORef a)
newIORef Maybe ([Char] -> IO ())
forall a. Maybe a
Nothing
  IORef TimeSpec
startWC    <- TimeSpec -> IO (IORef TimeSpec)
forall a. a -> IO (IORef a)
newIORef TimeSpec
forall a. (?callStack::CallStack) => a
undefined
  IORef TimeSpec
lastStatWC <- TimeSpec -> IO (IORef TimeSpec)
forall a. a -> IO (IORef a)
newIORef TimeSpec
forall a. (?callStack::CallStack) => a
undefined

  IORef (Gen RealWorld)
randgen  <- Gen RealWorld -> IO (IORef (Gen RealWorld))
forall a. a -> IO (IORef a)
newIORef (Gen RealWorld -> IO (IORef (Gen RealWorld)))
-> IO (Gen RealWorld) -> IO (IORef (Gen RealWorld))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Gen RealWorld)
forall (m :: * -> *). PrimMonad m => m (Gen (PrimState m))
Rand.create

  IORef LitSet
failed <- LitSet -> IO (IORef LitSet)
forall a. a -> IO (IORef a)
newIORef LitSet
IS.empty
  IORef LitSet
implied <- LitSet -> IO (IORef LitSet)
forall a. a -> IO (IORef a)
newIORef LitSet
IS.empty

  IOURef Lit
confBudget <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef (-Lit
1)
  IORef (Maybe (IO Bool))
terminateCallback <- Maybe (IO Bool) -> IO (IORef (Maybe (IO Bool)))
forall a. a -> IO (IORef a)
newIORef Maybe (IO Bool)
forall a. Maybe a
Nothing
  IORef (Maybe ([Lit] -> IO ()))
learntCallback <- Maybe ([Lit] -> IO ()) -> IO (IORef (Maybe ([Lit] -> IO ())))
forall a. a -> IO (IORef a)
newIORef Maybe ([Lit] -> IO ())
forall a. Maybe a
Nothing

  IORef (Maybe TheorySolver)
tsolver <- Maybe TheorySolver -> IO (IORef (Maybe TheorySolver))
forall a. a -> IO (IORef a)
newIORef Maybe TheorySolver
forall a. Maybe a
Nothing
  IOURef Lit
tchecked <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0

  UVec Bool
seen <- IO (UVec Bool)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  IORef (Maybe PBLinAtLeast)
pbLearnt <- Maybe PBLinAtLeast -> IO (IORef (Maybe PBLinAtLeast))
forall a. a -> IO (IORef a)
newIORef Maybe PBLinAtLeast
forall a. Maybe a
Nothing

  IOURef VarActivity
alpha <- VarActivity -> IO (IOURef VarActivity)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef VarActivity
0.4
  IOURef VarActivity
emaScale <- VarActivity -> IO (IOURef VarActivity)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef VarActivity
1.0
  IOURef Lit
learntCounter <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0

  let solver :: Solver
solver =
        Solver :: IORef Bool
-> PriorityQueue
-> GenericVec IOUArray Lit
-> GenericVec IOUArray Lit
-> IOURef Lit
-> GenericVec IOUArray Int8
-> UVec Bool
-> UVec VarActivity
-> GenericVec IOUArray Lit
-> GenericVec IOUArray Lit
-> Vec [SomeConstraintHandler]
-> Vec [SomeConstraintHandler]
-> GenericVec IOArray (Maybe SomeConstraintHandler)
-> UVec VarActivity
-> GenericVec IOUArray Lit
-> GenericVec IOUArray Lit
-> GenericVec IOUArray Lit
-> Vec [SomeConstraintHandler]
-> Vec (HashSet SomeConstraintHandler)
-> IORef [SomeConstraintHandler]
-> IORef (Lit, [SomeConstraintHandler])
-> IORef (Maybe TheorySolver)
-> IOURef Lit
-> IORef (Maybe Model)
-> IORef LitSet
-> IORef LitSet
-> IOURef Lit
-> IOURef Lit
-> IOURef Lit
-> IOURef Lit
-> IOURef Lit
-> IOURef Lit
-> IORef Config
-> IORef GenIO
-> IOURef Lit
-> IORef (Maybe (IO Bool))
-> IORef (Maybe ([Lit] -> IO ()))
-> IORef (Maybe ([Char] -> IO ()))
-> IORef TimeSpec
-> IORef TimeSpec
-> IORef Bool
-> GenericVec IOUArray Lit
-> IORef Lit
-> IORef Lit
-> IORef [(Lit, Lit)]
-> UVec Bool
-> IORef (Maybe PBLinAtLeast)
-> IOURef VarActivity
-> IOURef VarActivity
-> IOURef VarActivity
-> IOURef VarActivity
-> IOURef Lit
-> Solver
Solver
        { svOk :: IORef Bool
svOk = IORef Bool
ok
        , svVarQueue :: PriorityQueue
svVarQueue   = PriorityQueue
vqueue
        , svTrail :: GenericVec IOUArray Lit
svTrail      = GenericVec IOUArray Lit
trail
        , svTrailLimit :: GenericVec IOUArray Lit
svTrailLimit = GenericVec IOUArray Lit
trail_lim
        , svTrailNPropagated :: IOURef Lit
svTrailNPropagated = IOURef Lit
trail_nprop

        , svVarValue :: GenericVec IOUArray Int8
svVarValue        = GenericVec IOUArray Int8
varValue
        , svVarPolarity :: UVec Bool
svVarPolarity     = UVec Bool
varPolarity
        , svVarActivity :: UVec VarActivity
svVarActivity     = UVec VarActivity
varActivity
        , svVarTrailIndex :: GenericVec IOUArray Lit
svVarTrailIndex   = GenericVec IOUArray Lit
varTrailIndex
        , svVarLevel :: GenericVec IOUArray Lit
svVarLevel        = GenericVec IOUArray Lit
varLevel
        , svVarWatches :: Vec [SomeConstraintHandler]
svVarWatches      = Vec [SomeConstraintHandler]
varWatches
        , svVarOnUnassigned :: Vec [SomeConstraintHandler]
svVarOnUnassigned = Vec [SomeConstraintHandler]
varOnUnassigned
        , svVarReason :: GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason       = GenericVec IOArray (Maybe SomeConstraintHandler)
varReason
        , svVarEMAScaled :: UVec VarActivity
svVarEMAScaled    = UVec VarActivity
varEMAScaled
        , svVarWhenAssigned :: GenericVec IOUArray Lit
svVarWhenAssigned = GenericVec IOUArray Lit
varWhenAssigned
        , svVarParticipated :: GenericVec IOUArray Lit
svVarParticipated = GenericVec IOUArray Lit
varParticipated
        , svVarReasoned :: GenericVec IOUArray Lit
svVarReasoned     = GenericVec IOUArray Lit
varReasoned
        , svLitWatches :: Vec [SomeConstraintHandler]
svLitWatches      = Vec [SomeConstraintHandler]
litWatches
        , svLitOccurList :: Vec (HashSet SomeConstraintHandler)
svLitOccurList    = Vec (HashSet SomeConstraintHandler)
litOccurList

        , svConstrDB :: IORef [SomeConstraintHandler]
svConstrDB   = IORef [SomeConstraintHandler]
db
        , svLearntDB :: IORef (Lit, [SomeConstraintHandler])
svLearntDB   = IORef (Lit, [SomeConstraintHandler])
db2

        -- Theory
        , svTheorySolver :: IORef (Maybe TheorySolver)
svTheorySolver  = IORef (Maybe TheorySolver)
tsolver
        , svTheoryChecked :: IOURef Lit
svTheoryChecked = IOURef Lit
tchecked

        -- Result
        , svModel :: IORef (Maybe Model)
svModel      = IORef (Maybe Model)
m
        , svFailedAssumptions :: IORef LitSet
svFailedAssumptions = IORef LitSet
failed
        , svAssumptionsImplications :: IORef LitSet
svAssumptionsImplications = IORef LitSet
implied

        -- Statistics
        , svNDecision :: IOURef Lit
svNDecision  = IOURef Lit
ndecision
        , svNRandomDecision :: IOURef Lit
svNRandomDecision = IOURef Lit
nranddec
        , svNConflict :: IOURef Lit
svNConflict  = IOURef Lit
nconflict
        , svNRestart :: IOURef Lit
svNRestart   = IOURef Lit
nrestart
        , svNLearntGC :: IOURef Lit
svNLearntGC  = IOURef Lit
nlearntgc
        , svNRemovedConstr :: IOURef Lit
svNRemovedConstr = IOURef Lit
nremoved

        -- Configulation
        , svConfig :: IORef Config
svConfig     = IORef Config
configRef
        , svRandomGen :: IORef GenIO
svRandomGen  = IORef (Gen RealWorld)
IORef GenIO
randgen
        , svConfBudget :: IOURef Lit
svConfBudget = IOURef Lit
confBudget
        , svTerminateCallback :: IORef (Maybe (IO Bool))
svTerminateCallback = IORef (Maybe (IO Bool))
terminateCallback
        , svLearnCallback :: IORef (Maybe ([Lit] -> IO ()))
svLearnCallback = IORef (Maybe ([Lit] -> IO ()))
learntCallback

        -- Logging
        , svLogger :: IORef (Maybe ([Char] -> IO ()))
svLogger = IORef (Maybe ([Char] -> IO ()))
logger
        , svStartWC :: IORef TimeSpec
svStartWC    = IORef TimeSpec
startWC
        , svLastStatWC :: IORef TimeSpec
svLastStatWC = IORef TimeSpec
lastStatWC

        -- Working space
        , svCanceled :: IORef Bool
svCanceled        = IORef Bool
canceled
        , svAssumptions :: GenericVec IOUArray Lit
svAssumptions     = GenericVec IOUArray Lit
as
        , svLearntLim :: IORef Lit
svLearntLim       = IORef Lit
learntLim
        , svLearntLimAdjCnt :: IORef Lit
svLearntLimAdjCnt = IORef Lit
learntLimAdjCnt
        , svLearntLimSeq :: IORef [(Lit, Lit)]
svLearntLimSeq    = IORef [(Lit, Lit)]
learntLimSeq
        , svVarInc :: IOURef VarActivity
svVarInc      = IOURef VarActivity
varInc
        , svConstrInc :: IOURef VarActivity
svConstrInc   = IOURef VarActivity
constrInc
        , svSeen :: UVec Bool
svSeen = UVec Bool
seen
        , svPBLearnt :: IORef (Maybe PBLinAtLeast)
svPBLearnt = IORef (Maybe PBLinAtLeast)
pbLearnt

        , svERWAStepSize :: IOURef VarActivity
svERWAStepSize = IOURef VarActivity
alpha
        , svEMAScale :: IOURef VarActivity
svEMAScale = IOURef VarActivity
emaScale
        , svLearntCounter :: IOURef Lit
svLearntCounter = IOURef Lit
learntCounter
        }
 Solver -> IO Solver
forall (m :: * -> *) a. Monad m => a -> m a
return Solver
solver

ltVar :: Solver -> Var -> Var -> IO Bool
ltVar :: Solver -> Lit -> Lit -> IO Bool
ltVar Solver
solver !Lit
v1 !Lit
v2 = do
  Config
conf <- Solver -> IO Config
getConfig Solver
solver
  case Config -> BranchingStrategy
configBranchingStrategy Config
conf of
    BranchingStrategy
BranchingVSIDS -> do
      VarActivity
a1 <- Solver -> Lit -> IO VarActivity
varActivity Solver
solver Lit
v1
      VarActivity
a2 <- Solver -> Lit -> IO VarActivity
varActivity Solver
solver Lit
v2
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! VarActivity
a1 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
a2
    BranchingStrategy
_ -> do -- BranchingERWA and BranchingLRB
      VarActivity
a1 <- Solver -> Lit -> IO VarActivity
varEMAScaled Solver
solver Lit
v1
      VarActivity
a2 <- Solver -> Lit -> IO VarActivity
varEMAScaled Solver
solver Lit
v1
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! VarActivity
a1 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
a2

{--------------------------------------------------------------------
  Problem specification
--------------------------------------------------------------------}

instance NewVar IO Solver where
  newVar :: Solver -> IO Var
  newVar :: Solver -> IO Lit
newVar Solver
solver = do
    Lit
n <- GenericVec IOUArray Int8 -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver)
#if SIZEOF_HSINT > 4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
n Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== PackedLit -> Lit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"cannot allocate more variables"
#endif
    let v :: Lit
v = Lit
n Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ Lit
1

    GenericVec IOUArray Int8 -> Int8 -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) (LBool -> Int8
coerce LBool
lUndef)
    UVec Bool -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec Bool
svVarPolarity Solver
solver) Bool
True
    UVec VarActivity -> VarActivity -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec VarActivity
svVarActivity Solver
solver) VarActivity
0
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svVarTrailIndex Solver
solver) Lit
forall a. Bounded a => a
maxBound
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) Lit
forall a. Bounded a => a
maxBound
    Vec [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) []
    Vec [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) []
    GenericVec IOArray (Maybe SomeConstraintHandler)
-> Maybe SomeConstraintHandler -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
    UVec VarActivity -> VarActivity -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec VarActivity
svVarEMAScaled Solver
solver) VarActivity
0
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svVarWhenAssigned Solver
solver) (-Lit
1)
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svVarParticipated Solver
solver) Lit
0
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svVarReasoned Solver
solver) Lit
0

    Vec [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) []
    Vec [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) []
    Vec (HashSet SomeConstraintHandler)
-> HashSet SomeConstraintHandler -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) HashSet SomeConstraintHandler
forall a. HashSet a
HashSet.empty
    Vec (HashSet SomeConstraintHandler)
-> HashSet SomeConstraintHandler -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) HashSet SomeConstraintHandler
forall a. HashSet a
HashSet.empty

    PriorityQueue -> Lit -> IO ()
forall q (m :: * -> *) a. Enqueue q m a => q -> a -> m ()
PQ.enqueue (Solver -> PriorityQueue
svVarQueue Solver
solver) Lit
v
    UVec Bool -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec Bool
svSeen Solver
solver) Bool
False
    Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
v

  newVars :: Solver -> Int -> IO [Var]
  newVars :: Solver -> Lit -> IO [Lit]
newVars Solver
solver Lit
n = do
    Lit
nv <- Solver -> IO Lit
getNVars Solver
solver
#if SIZEOF_HSINT > 4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
nv Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ Lit
n Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> PackedLit -> Lit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"cannot allocate more variables"
#endif
    Solver -> Lit -> IO ()
resizeVarCapacity Solver
solver (Lit
nvLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
n)
    Lit -> IO Lit -> IO [Lit]
forall (m :: * -> *) a. Applicative m => Lit -> m a -> m [a]
replicateM Lit
n (Solver -> IO Lit
forall (m :: * -> *) a. NewVar m a => a -> m Lit
newVar Solver
solver)

  newVars_ :: Solver -> Int -> IO ()
  newVars_ :: Solver -> Lit -> IO ()
newVars_ Solver
solver Lit
n = do
    Lit
nv <- Solver -> IO Lit
getNVars Solver
solver
#if SIZEOF_HSINT > 4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
nv Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ Lit
n Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> PackedLit -> Lit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"cannot allocate more variables"
#endif
    Solver -> Lit -> IO ()
resizeVarCapacity Solver
solver (Lit
nvLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
n)
    Lit -> IO Lit -> IO ()
forall (m :: * -> *) a. Applicative m => Lit -> m a -> m ()
replicateM_ Lit
n (Solver -> IO Lit
forall (m :: * -> *) a. NewVar m a => a -> m Lit
newVar Solver
solver)

-- |Pre-allocate internal buffer for @n@ variables.
resizeVarCapacity :: Solver -> Int -> IO ()
resizeVarCapacity :: Solver -> Lit -> IO ()
resizeVarCapacity Solver
solver Lit
n = do
  GenericVec IOUArray Int8 -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) Lit
n
  UVec Bool -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> UVec Bool
svVarPolarity Solver
solver) Lit
n
  UVec VarActivity -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> UVec VarActivity
svVarActivity Solver
solver) Lit
n
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svVarTrailIndex Solver
solver) Lit
n
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svVarLevel Solver
solver) Lit
n
  Vec [SomeConstraintHandler] -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Lit
n
  Vec [SomeConstraintHandler] -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) Lit
n
  GenericVec IOArray (Maybe SomeConstraintHandler) -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) Lit
n
  UVec VarActivity -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> UVec VarActivity
svVarEMAScaled Solver
solver) Lit
n
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svVarWhenAssigned Solver
solver) Lit
n
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svVarParticipated Solver
solver) Lit
n
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svVarReasoned Solver
solver) Lit
n
  Vec [SomeConstraintHandler] -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
*Lit
2)
  Vec (HashSet SomeConstraintHandler) -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
*Lit
2)
  UVec Bool -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> UVec Bool
svSeen Solver
solver) Lit
n
  PriorityQueue -> Lit -> IO ()
PQ.resizeHeapCapacity (Solver -> PriorityQueue
svVarQueue Solver
solver) Lit
n
  PriorityQueue -> Lit -> IO ()
PQ.resizeTableCapacity (Solver -> PriorityQueue
svVarQueue Solver
solver) (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)

instance AddClause IO Solver where
  addClause :: Solver -> Clause -> IO ()
  addClause :: Solver -> [Lit] -> IO ()
addClause Solver
solver [Lit]
lits = do
    Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
    Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe [Lit]
m <- (Lit -> IO LBool) -> [Lit] -> IO (Maybe [Lit])
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> [Lit] -> m (Maybe [Lit])
instantiateClause (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) [Lit]
lits
      case [Lit] -> Maybe [Lit]
normalizeClause ([Lit] -> Maybe [Lit]) -> Maybe [Lit] -> Maybe [Lit]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Lit]
m of
        Maybe [Lit]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [] -> Solver -> IO ()
markBad Solver
solver
        Just [Lit
lit] -> do
          {- We do not call 'removeBackwardSubsumedBy' here,
             because subsumed constraints will be removed by 'simplify'. -}
          Bool
ret <- Solver -> Lit -> IO Bool
assign Solver
solver Lit
lit
          Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
          case Maybe SomeConstraintHandler
ret2 of
            Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just SomeConstraintHandler
_ -> Solver -> IO ()
markBad Solver
solver
        Just [Lit]
lits2 -> do
          Bool
subsumed <- Solver -> [Lit] -> IO Bool
checkForwardSubsumption Solver
solver [Lit]
lits
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
subsumed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Solver -> PBLinAtLeast -> IO ()
removeBackwardSubsumedBy Solver
solver ([(Integer
1,Lit
lit) | Lit
lit <- [Lit]
lits2], Integer
1)
            ClauseHandler
clause <- [Lit] -> Bool -> IO ClauseHandler
newClauseHandler [Lit]
lits2 Bool
False
            Solver -> ClauseHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver ClauseHandler
clause
            Bool
_ <- Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
clause
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance AddCardinality IO Solver where
  addAtLeast :: Solver -> [Lit] -> Int -> IO ()
  addAtLeast :: Solver -> [Lit] -> Lit -> IO ()
addAtLeast Solver
solver [Lit]
lits Lit
n = do
    Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
    Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ([Lit]
lits',Lit
n') <- (([Lit], Lit) -> ([Lit], Lit))
-> IO ([Lit], Lit) -> IO ([Lit], Lit)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Lit], Lit) -> ([Lit], Lit)
normalizeAtLeast (IO ([Lit], Lit) -> IO ([Lit], Lit))
-> IO ([Lit], Lit) -> IO ([Lit], Lit)
forall a b. (a -> b) -> a -> b
$ (Lit -> IO LBool) -> ([Lit], Lit) -> IO ([Lit], Lit)
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> ([Lit], Lit) -> m ([Lit], Lit)
instantiateAtLeast (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) ([Lit]
lits,Lit
n)
      let len :: Lit
len = [Lit] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [Lit]
lits'

      if Lit
n' Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<= Lit
0 then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else if Lit
n' Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
len then Solver -> IO ()
markBad Solver
solver
      else if Lit
n' Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
1 then Solver -> [Lit] -> IO ()
forall (m :: * -> *) a. AddClause m a => a -> [Lit] -> m ()
addClause Solver
solver [Lit]
lits'
      else if Lit
n' Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
len then do
        {- We do not call 'removeBackwardSubsumedBy' here,
           because subsumed constraints will be removed by 'simplify'. -}
        [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit]
lits' ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
          Bool
ret <- Solver -> Lit -> IO Bool
assign Solver
solver Lit
l
          Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
        case Maybe SomeConstraintHandler
ret2 of
          Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just SomeConstraintHandler
_ -> Solver -> IO ()
markBad Solver
solver
      else do -- n' < len
        Solver -> PBLinAtLeast -> IO ()
removeBackwardSubsumedBy Solver
solver ([(Integer
1,Lit
lit) | Lit
lit <- [Lit]
lits'], Lit -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
n')
        AtLeastHandler
c <- [Lit] -> Lit -> Bool -> IO AtLeastHandler
newAtLeastHandler [Lit]
lits' Lit
n' Bool
False
        Solver -> AtLeastHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver AtLeastHandler
c
        Bool
_ <- Solver -> AtLeastHandler -> IO Bool
basicAttachAtLeastHandler Solver
solver AtLeastHandler
c
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance AddPBLin IO Solver where
  addPBAtLeast :: Solver -> PBLinSum -> Integer -> IO ()
  addPBAtLeast :: Solver -> PBLinSum -> Integer -> IO ()
addPBAtLeast Solver
solver PBLinSum
ts Integer
n = do
    Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
    Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (PBLinSum
ts',Integer
n') <- (PBLinAtLeast -> PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PBLinAtLeast -> PBLinAtLeast
normalizePBLinAtLeast (IO PBLinAtLeast -> IO PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall a b. (a -> b) -> a -> b
$ (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> PBLinAtLeast -> m PBLinAtLeast
instantiatePBLinAtLeast (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) (PBLinSum
ts,Integer
n)

      case PBLinAtLeast -> Maybe ([Lit], Lit)
pbToAtLeast (PBLinSum
ts',Integer
n') of
        Just ([Lit]
lhs',Lit
rhs') -> Solver -> [Lit] -> Lit -> IO ()
forall (m :: * -> *) a.
AddCardinality m a =>
a -> [Lit] -> Lit -> m ()
addAtLeast Solver
solver [Lit]
lhs' Lit
rhs'
        Maybe ([Lit], Lit)
Nothing -> do
          let cs :: [Integer]
cs = (PBLinTerm -> Integer) -> PBLinSum -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map PBLinTerm -> Integer
forall a b. (a, b) -> a
fst PBLinSum
ts'
              slack :: Integer
slack = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
cs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n'
          if Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else if Integer
slack Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Solver -> IO ()
markBad Solver
solver
          else do
            Solver -> PBLinAtLeast -> IO ()
removeBackwardSubsumedBy Solver
solver (PBLinSum
ts', Integer
n')
            (PBLinSum
ts'',Integer
n'') <- do
              Bool
b <- Config -> Bool
configEnablePBSplitClausePart (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
              if Bool
b
              then Solver -> PBLinAtLeast -> IO PBLinAtLeast
pbSplitClausePart Solver
solver (PBLinSum
ts',Integer
n')
              else PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
ts',Integer
n')

            SomeConstraintHandler
c <- Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
ts'' Integer
n'' Bool
False
            let constr :: SomeConstraintHandler
constr = SomeConstraintHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler SomeConstraintHandler
c
            Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver SomeConstraintHandler
constr
            Bool
ret <- Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
constr
            if Bool -> Bool
not Bool
ret then do
              Solver -> IO ()
markBad Solver
solver
            else do
              Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
              case Maybe SomeConstraintHandler
ret2 of
                Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just SomeConstraintHandler
_ -> Solver -> IO ()
markBad Solver
solver

  addPBExactly :: Solver -> PBLinSum -> Integer -> IO ()
  addPBExactly :: Solver -> PBLinSum -> Integer -> IO ()
addPBExactly Solver
solver PBLinSum
ts Integer
n = do
    (PBLinSum
ts2,Integer
n2) <- (PBLinAtLeast -> PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PBLinAtLeast -> PBLinAtLeast
normalizePBLinExactly (IO PBLinAtLeast -> IO PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall a b. (a -> b) -> a -> b
$ (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> PBLinAtLeast -> m PBLinAtLeast
instantiatePBLinExactly (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) (PBLinSum
ts,Integer
n)
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver PBLinSum
ts2 Integer
n2
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtMost Solver
solver PBLinSum
ts2 Integer
n2

  addPBAtLeastSoft :: Solver -> Lit -> PBLinSum -> Integer -> IO ()
  addPBAtLeastSoft :: Solver -> Lit -> PBLinSum -> Integer -> IO ()
addPBAtLeastSoft Solver
solver Lit
sel PBLinSum
lhs Integer
rhs = do
    (PBLinSum
lhs', Integer
rhs') <- (PBLinAtLeast -> PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PBLinAtLeast -> PBLinAtLeast
normalizePBLinAtLeast (IO PBLinAtLeast -> IO PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall a b. (a -> b) -> a -> b
$ (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> PBLinAtLeast -> m PBLinAtLeast
instantiatePBLinAtLeast (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) (PBLinSum
lhs,Integer
rhs)
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver ((Integer
rhs', Lit -> Lit
litNot Lit
sel) PBLinTerm -> PBLinSum -> PBLinSum
forall a. a -> [a] -> [a]
: PBLinSum
lhs') Integer
rhs'

  addPBExactlySoft :: Solver -> Lit -> PBLinSum -> Integer -> IO ()
  addPBExactlySoft :: Solver -> Lit -> PBLinSum -> Integer -> IO ()
addPBExactlySoft Solver
solver Lit
sel PBLinSum
lhs Integer
rhs = do
    (PBLinSum
lhs2, Integer
rhs2) <- (PBLinAtLeast -> PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PBLinAtLeast -> PBLinAtLeast
normalizePBLinExactly (IO PBLinAtLeast -> IO PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall a b. (a -> b) -> a -> b
$ (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> PBLinAtLeast -> m PBLinAtLeast
instantiatePBLinExactly (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) (PBLinSum
lhs,Integer
rhs)
    Solver -> Lit -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> Lit -> PBLinSum -> Integer -> m ()
addPBAtLeastSoft Solver
solver Lit
sel PBLinSum
lhs2 Integer
rhs2
    Solver -> Lit -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> Lit -> PBLinSum -> Integer -> m ()
addPBAtMostSoft Solver
solver Lit
sel PBLinSum
lhs2 Integer
rhs2

-- | See documentation of 'setPBSplitClausePart'.
pbSplitClausePart :: Solver -> PBLinAtLeast -> IO PBLinAtLeast
pbSplitClausePart :: Solver -> PBLinAtLeast -> IO PBLinAtLeast
pbSplitClausePart Solver
solver (PBLinSum
lhs,Integer
rhs) = do
  let (PBLinSum
ts1,PBLinSum
ts2) = (PBLinTerm -> Bool) -> PBLinSum -> (PBLinSum, PBLinSum)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Integer
c,Lit
_) -> Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
rhs) PBLinSum
lhs
  if PBLinSum -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length PBLinSum
ts1 Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
2 then
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
lhs,Integer
rhs)
  else do
    Lit
sel <- Solver -> IO Lit
forall (m :: * -> *) a. NewVar m a => a -> m Lit
newVar Solver
solver
    Solver -> [Lit] -> IO ()
forall (m :: * -> *) a. AddClause m a => a -> [Lit] -> m ()
addClause Solver
solver ([Lit] -> IO ()) -> [Lit] -> IO ()
forall a b. (a -> b) -> a -> b
$ -Lit
sel Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit
l | (Integer
_,Lit
l) <- PBLinSum
ts1]
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
rhs,Lit
sel) PBLinTerm -> PBLinSum -> PBLinSum
forall a. a -> [a] -> [a]
: PBLinSum
ts2, Integer
rhs)

instance AddXORClause IO Solver where
  addXORClause :: Solver -> [Lit] -> Bool -> IO ()
  addXORClause :: Solver -> [Lit] -> Bool -> IO ()
addXORClause Solver
solver [Lit]
lits Bool
rhs = do
    Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
    Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      XORClause
xcl <- (Lit -> IO LBool) -> XORClause -> IO XORClause
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> XORClause -> m XORClause
instantiateXORClause (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) ([Lit]
lits,Bool
rhs)
      case XORClause -> XORClause
normalizeXORClause XORClause
xcl of
        ([], Bool
True) -> Solver -> IO ()
markBad Solver
solver
        ([], Bool
False) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ([Lit
l], Bool
b) -> Solver -> [Lit] -> IO ()
forall (m :: * -> *) a. AddClause m a => a -> [Lit] -> m ()
addClause Solver
solver [if Bool
b then Lit
l else Lit -> Lit
litNot Lit
l]
        (Lit
l:[Lit]
ls, Bool
b) -> do
          XORClauseHandler
c <- [Lit] -> Bool -> IO XORClauseHandler
newXORClauseHandler ((if Bool
b then Lit
l else Lit -> Lit
litNot Lit
l) Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit]
ls) Bool
False
          Solver -> XORClauseHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver XORClauseHandler
c
          Bool
_ <- Solver -> XORClauseHandler -> IO Bool
basicAttachXORClauseHandler Solver
solver XORClauseHandler
c
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{--------------------------------------------------------------------
  Problem solving
--------------------------------------------------------------------}

-- | Solve constraints.
-- Returns 'True' if the problem is SATISFIABLE.
-- Returns 'False' if the problem is UNSATISFIABLE.
solve :: Solver -> IO Bool
solve :: Solver -> IO Bool
solve Solver
solver = do
  GenericVec IOUArray Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO ()
Vec.clear (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver)
  Solver -> IO Bool
solve_ Solver
solver

-- | Solve constraints under assuptions.
-- Returns 'True' if the problem is SATISFIABLE.
-- Returns 'False' if the problem is UNSATISFIABLE.
solveWith :: Solver
          -> [Lit]    -- ^ Assumptions
          -> IO Bool
solveWith :: Solver -> [Lit] -> IO Bool
solveWith Solver
solver [Lit]
ls = do
  GenericVec IOUArray Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO ()
Vec.clear (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver)
  (Lit -> IO ()) -> [Lit] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver)) [Lit]
ls
  Solver -> IO Bool
solve_ Solver
solver

solve_ :: Solver -> IO Bool
solve_ :: Solver -> IO Bool
solve_ Solver
solver = do
  Config
config <- Solver -> IO Config
getConfig Solver
solver
  IORef LitSet -> LitSet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svAssumptionsImplications Solver
solver) LitSet
IS.empty

  Solver -> [Char] -> IO ()
log Solver
solver [Char]
"Solving starts ..."
  Solver -> IO ()
resetStat Solver
solver
  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
False
  IORef (Maybe Model) -> Maybe Model -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe Model)
svModel Solver
solver) Maybe Model
forall a. Maybe a
Nothing
  IORef LitSet -> LitSet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svFailedAssumptions Solver
solver) LitSet
IS.empty

  Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
  if Bool -> Bool
not Bool
ok then
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
dumpVarActivity Solver
solver
    Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
    Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Lit
nv <- Solver -> IO Lit
getNVars Solver
solver
    GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
nv

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> VarActivity
configRestartInc Config
config VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"RestartInc must be >1"
    let restartSeq :: [Lit]
restartSeq =
          if Config -> Lit
configRestartFirst Config
config  Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0
          then RestartStrategy -> Lit -> VarActivity -> [Lit]
mkRestartSeq (Config -> RestartStrategy
configRestartStrategy Config
config) (Config -> Lit
configRestartFirst Config
config) (Config -> VarActivity
configRestartInc Config
config)
          else Lit -> [Lit]
forall a. a -> [a]
repeat Lit
0

    let learntSizeAdj :: IO ()
learntSizeAdj = do
          (Lit
size,Lit
adj) <- IORef [(Lit, Lit)] -> IO (Lit, Lit)
forall a. IORef [a] -> IO a
shift (Solver -> IORef [(Lit, Lit)]
svLearntLimSeq Solver
solver)
          IORef Lit -> Lit -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Lit
svLearntLim Solver
solver) Lit
size
          IORef Lit -> Lit -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Lit
svLearntLimAdjCnt Solver
solver) Lit
adj
        onConflict :: IO ()
onConflict = do
          Lit
cnt <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef (Solver -> IORef Lit
svLearntLimAdjCnt Solver
solver)
          if (Lit
cntLit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
0)
          then IO ()
learntSizeAdj
          else IORef Lit -> Lit -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Lit
svLearntLimAdjCnt Solver
solver) (Lit -> IO ()) -> Lit -> IO ()
forall a b. (a -> b) -> a -> b
$! Lit
cntLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1

    Lit
cnt <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef (Solver -> IORef Lit
svLearntLimAdjCnt Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
cnt Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== -Lit
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> VarActivity
configLearntSizeInc Config
config VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"LearntSizeInc must be >1"
      Lit
nc <- Solver -> IO Lit
getNConstraints Solver
solver
      let initialLearntLim :: Lit
initialLearntLim = if Config -> Lit
configLearntSizeFirst Config
config Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0 then Config -> Lit
configLearntSizeFirst Config
config else Lit -> Lit -> Lit
forall a. Ord a => a -> a -> a
max ((Lit
nc Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ Lit
nv) Lit -> Lit -> Lit
forall a. Integral a => a -> a -> a
`div` Lit
3) Lit
16
          learntSizeSeq :: [Lit]
learntSizeSeq    = (Lit -> Lit) -> Lit -> [Lit]
forall a. (a -> a) -> a -> [a]
iterate (VarActivity -> Lit
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (VarActivity -> Lit) -> (Lit -> VarActivity) -> Lit -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> VarActivity
configLearntSizeInc Config
config VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*) (VarActivity -> VarActivity)
-> (Lit -> VarActivity) -> Lit -> VarActivity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Lit
initialLearntLim
          learntSizeAdjSeq :: [Lit]
learntSizeAdjSeq = (Lit -> Lit) -> Lit -> [Lit]
forall a. (a -> a) -> a -> [a]
iterate (\Lit
x -> (Lit
x Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
* Lit
3) Lit -> Lit -> Lit
forall a. Integral a => a -> a -> a
`div` Lit
2) (Lit
100::Int)
      IORef [(Lit, Lit)] -> [(Lit, Lit)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef [(Lit, Lit)]
svLearntLimSeq Solver
solver) ([Lit] -> [Lit] -> [(Lit, Lit)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Lit]
learntSizeSeq [Lit]
learntSizeAdjSeq)
      IO ()
learntSizeAdj

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VarActivity
0 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> VarActivity
configERWAStepSizeFirst Config
config Bool -> Bool -> Bool
&& Config -> VarActivity
configERWAStepSizeFirst Config
config VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
<= VarActivity
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"ERWAStepSizeFirst must be in [0..1]"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VarActivity
0 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> VarActivity
configERWAStepSizeMin Config
config Bool -> Bool -> Bool
&& Config -> VarActivity
configERWAStepSizeFirst Config
config VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
<= VarActivity
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"ERWAStepSizeMin must be in [0..1]"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VarActivity
0 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> VarActivity
configERWAStepSizeDec Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"ERWAStepSizeDec must be >=0"
    IOURef VarActivity -> VarActivity -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef VarActivity
svERWAStepSize Solver
solver) (Config -> VarActivity
configERWAStepSizeFirst Config
config)

    let loop :: [Lit] -> IO (Either a Bool)
loop [] = [Char] -> IO (Either a Bool)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"solve_: should not happen"
        loop (Lit
conflict_lim:[Lit]
rs) = do
          Solver -> Bool -> IO ()
printStat Solver
solver Bool
True
          SearchResult
ret <- Solver -> Lit -> IO () -> IO SearchResult
search Solver
solver Lit
conflict_lim IO ()
onConflict
          case SearchResult
ret of
            SRFinished Bool
x -> Either a Bool -> IO (Either a Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either a Bool
forall a b. b -> Either a b
Right Bool
x
            SearchResult
SRBudgetExceeded -> Either a Bool -> IO (Either a Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ a -> Either a Bool
forall a b. a -> Either a b
Left (BudgetExceeded -> a
forall a e. Exception e => e -> a
throw BudgetExceeded
BudgetExceeded)
            SearchResult
SRCanceled -> Either a Bool -> IO (Either a Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ a -> Either a Bool
forall a b. a -> Either a b
Left (Canceled -> a
forall a e. Exception e => e -> a
throw Canceled
Canceled)
            SearchResult
SRRestart -> do
              IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNRestart Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
              Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
levelRoot
              [Lit] -> IO (Either a Bool)
loop [Lit]
rs

    Solver -> IO ()
printStatHeader Solver
solver

    TimeSpec
startCPU <- Clock -> IO TimeSpec
getTime Clock
ProcessCPUTime
    TimeSpec
startWC  <- Clock -> IO TimeSpec
getTime Clock
Monotonic
    IORef TimeSpec -> TimeSpec -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef TimeSpec
svStartWC Solver
solver) TimeSpec
startWC
    Either (IO Bool) Bool
result <- [Lit] -> IO (Either (IO Bool) Bool)
forall a. [Lit] -> IO (Either a Bool)
loop [Lit]
restartSeq
    TimeSpec
endCPU <- Clock -> IO TimeSpec
getTime Clock
ProcessCPUTime
    TimeSpec
endWC  <- Clock -> IO TimeSpec
getTime Clock
Monotonic

    case Either (IO Bool) Bool
result of
      Right Bool
True -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configCheckModel Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
checkSatisfied Solver
solver
        Solver -> IO ()
constructModel Solver
solver
        Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
        case Maybe TheorySolver
mt of
          Maybe TheorySolver
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just TheorySolver
t -> TheorySolver -> IO ()
thConstructModel TheorySolver
t
      Either (IO Bool) Bool
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Either (IO Bool) Bool
result of
      Right Bool
False -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Either (IO Bool) Bool
_ -> Solver -> IO ()
saveAssumptionsImplications Solver
solver

    Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
levelRoot

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
dumpVarActivity Solver
solver
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
dumpConstrActivity Solver
solver
    Solver -> Bool -> IO ()
printStat Solver
solver Bool
True
    let durationSecs :: TimeSpec -> TimeSpec -> Double
        durationSecs :: TimeSpec -> TimeSpec -> VarActivity
durationSecs TimeSpec
start TimeSpec
end = Integer -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs (TimeSpec
end TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
start)) VarActivity -> VarActivity -> VarActivity
forall a. Fractional a => a -> a -> a
/ VarActivity
10VarActivity -> Lit -> VarActivity
forall a b. (Num a, Integral b) => a -> b -> a
^(Lit
9::Int)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ())
-> (VarActivity -> [Char]) -> VarActivity -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#cpu_time = %.3fs") (TimeSpec -> TimeSpec -> VarActivity
durationSecs TimeSpec
startCPU TimeSpec
endCPU)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ())
-> (VarActivity -> [Char]) -> VarActivity -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#wall_clock_time = %.3fs") (TimeSpec -> TimeSpec -> VarActivity
durationSecs TimeSpec
startWC TimeSpec
endWC)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> (Lit -> [Char]) -> Lit -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#decision = %d") (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNDecision Solver
solver)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> (Lit -> [Char]) -> Lit -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#random_decision = %d") (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNRandomDecision Solver
solver)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> (Lit -> [Char]) -> Lit -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#conflict = %d") (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNConflict Solver
solver)
    (Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> (Lit -> [Char]) -> Lit -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#restart = %d")  (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNRestart Solver
solver)

    case Either (IO Bool) Bool
result of
      Right Bool
x  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
x
      Left IO Bool
m -> IO Bool
m

data BudgetExceeded = BudgetExceeded
  deriving (Lit -> BudgetExceeded -> [Char] -> [Char]
[BudgetExceeded] -> [Char] -> [Char]
BudgetExceeded -> [Char]
(Lit -> BudgetExceeded -> [Char] -> [Char])
-> (BudgetExceeded -> [Char])
-> ([BudgetExceeded] -> [Char] -> [Char])
-> Show BudgetExceeded
forall a.
(Lit -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [BudgetExceeded] -> [Char] -> [Char]
$cshowList :: [BudgetExceeded] -> [Char] -> [Char]
show :: BudgetExceeded -> [Char]
$cshow :: BudgetExceeded -> [Char]
showsPrec :: Lit -> BudgetExceeded -> [Char] -> [Char]
$cshowsPrec :: Lit -> BudgetExceeded -> [Char] -> [Char]
Show, Typeable)

instance Exception BudgetExceeded

data Canceled = Canceled
  deriving (Lit -> Canceled -> [Char] -> [Char]
[Canceled] -> [Char] -> [Char]
Canceled -> [Char]
(Lit -> Canceled -> [Char] -> [Char])
-> (Canceled -> [Char])
-> ([Canceled] -> [Char] -> [Char])
-> Show Canceled
forall a.
(Lit -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Canceled] -> [Char] -> [Char]
$cshowList :: [Canceled] -> [Char] -> [Char]
show :: Canceled -> [Char]
$cshow :: Canceled -> [Char]
showsPrec :: Lit -> Canceled -> [Char] -> [Char]
$cshowsPrec :: Lit -> Canceled -> [Char] -> [Char]
Show, Typeable)

instance Exception Canceled

data SearchResult
  = SRFinished Bool
  | SRRestart
  | SRBudgetExceeded
  | SRCanceled

search :: Solver -> Int -> IO () -> IO SearchResult
search :: Solver -> Lit -> IO () -> IO SearchResult
search Solver
solver !Lit
conflict_lim IO ()
onConflict = do
  IORef Lit
conflictCounter <- Lit -> IO (IORef Lit)
forall a. a -> IO (IORef a)
newIORef Lit
0
  let
    loop :: IO SearchResult
    loop :: IO SearchResult
loop = do
      Maybe SomeConstraintHandler
conflict <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
      case Maybe SomeConstraintHandler
conflict of
        Just SomeConstraintHandler
constr -> do
          Maybe SearchResult
ret <- IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Lit
conflictCounter SomeConstraintHandler
constr
          case Maybe SearchResult
ret of
            Just SearchResult
sr -> SearchResult -> IO SearchResult
forall (m :: * -> *) a. Monad m => a -> m a
return SearchResult
sr
            Maybe SearchResult
Nothing -> IO SearchResult
loop
        Maybe SomeConstraintHandler
Nothing -> do
          Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
simplify Solver
solver
          IO ()
checkGC
          Maybe Lit
r <- IO (Maybe Lit)
pickAssumption
          case Maybe Lit
r of
            Maybe Lit
Nothing -> SearchResult -> IO SearchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
False)
            Just Lit
lit
              | Lit
lit Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
/= Lit
litUndef -> Solver -> Lit -> IO ()
decide Solver
solver Lit
lit IO () -> IO SearchResult -> IO SearchResult
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO SearchResult
loop
              | Bool
otherwise -> do
                  Lit
lit2 <- Solver -> IO Lit
pickBranchLit Solver
solver
                  if Lit
lit2 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
litUndef
                    then SearchResult -> IO SearchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
True)
                    else Solver -> Lit -> IO ()
decide Solver
solver Lit
lit2 IO () -> IO SearchResult -> IO SearchResult
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO SearchResult
loop
  IO SearchResult
loop

  where
    checkGC :: IO ()
    checkGC :: IO ()
checkGC = do
      Lit
n <- Solver -> IO Lit
getNLearntConstraints Solver
solver
      Lit
m <- Solver -> IO Lit
getNAssigned Solver
solver
      Lit
learnt_lim <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef (Solver -> IORef Lit
svLearntLim Solver
solver)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
learnt_lim Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
0 Bool -> Bool -> Bool
&& Lit
n Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
m Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
learnt_lim) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNLearntGC Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
        Solver -> IO ()
reduceDB Solver
solver

    pickAssumption :: IO (Maybe Lit)
    pickAssumption :: IO (Maybe Lit)
pickAssumption = do
      Lit
s <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver)
      let go :: IO (Maybe Lit)
go = do
              Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
              if Bool -> Bool
not (Lit
d Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
s) then
                Maybe Lit -> IO (Maybe Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
litUndef)
              else do
                Lit
l <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver) Lit
d
                LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
                if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then do
                  -- dummy decision level
                  Solver -> IO ()
pushDecisionLevel Solver
solver
                  IO (Maybe Lit)
go
                else if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
                  -- conflict with assumption
                  [Lit]
core <- Solver -> Lit -> IO [Lit]
analyzeFinal Solver
solver Lit
l
                  IORef LitSet -> LitSet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svFailedAssumptions Solver
solver) ([Lit] -> LitSet
IS.fromList [Lit]
core)
                  Maybe Lit -> IO (Maybe Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Lit
forall a. Maybe a
Nothing
                else
                  Maybe Lit -> IO (Maybe Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
l)
      IO (Maybe Lit)
go

    handleConflict :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
    handleConflict :: IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Lit
conflictCounter SomeConstraintHandler
constr = do
      Solver -> IO ()
varEMADecay Solver
solver
      Solver -> IO ()
varDecayActivity Solver
solver
      Solver -> IO ()
constrDecayActivity Solver
solver
      IO ()
onConflict

      IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNConflict Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
      Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [Char]
str <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
constr
        [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"conflict(level=%d): %s" Lit
d [Char]
str

      IORef Lit -> (Lit -> Lit) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Lit
conflictCounter (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
      Lit
c <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef IORef Lit
conflictCounter

      IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svConfBudget Solver
solver) ((Lit -> Lit) -> IO ()) -> (Lit -> Lit) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
confBudget ->
        if Lit
confBudget Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0 then Lit
confBudget Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1 else Lit
confBudget
      Lit
confBudget <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svConfBudget Solver
solver)
      
      Maybe (IO Bool)
terminateCallback' <- IORef (Maybe (IO Bool)) -> IO (Maybe (IO Bool))
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe (IO Bool))
svTerminateCallback Solver
solver)
      case Maybe (IO Bool)
terminateCallback' of
        Maybe (IO Bool)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just IO Bool
terminateCallback -> do
          Bool
ret <- IO Bool
terminateCallback
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
True
      Bool
canceled <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svCanceled Solver
solver)

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
c Lit -> Lit -> Lit
forall a. Integral a => a -> a -> a
`mod` Lit
100 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Solver -> Bool -> IO ()
printStat Solver
solver Bool
False

      if Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot then do
        Solver -> [Lit] -> IO ()
callLearnCallback Solver
solver []
        Solver -> IO ()
markBad Solver
solver
        Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just (Bool -> SearchResult
SRFinished Bool
False)
      else if Lit
confBudgetLit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
0 then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRBudgetExceeded
      else if Bool
canceled then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRCanceled
      else if Lit
conflict_lim Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0 Bool -> Bool -> Bool
&& Lit
c Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
conflict_lim then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRRestart
      else do
        IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svLearntCounter Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
        Config
config <- Solver -> IO Config
getConfig Solver
solver
        case Config -> LearningStrategy
configLearningStrategy Config
config of
          LearningStrategy
LearningClause -> SomeConstraintHandler -> IO ()
learnClause SomeConstraintHandler
constr IO () -> IO (Maybe SearchResult) -> IO (Maybe SearchResult)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
          LearningStrategy
LearningHybrid -> IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
learnHybrid IORef Lit
conflictCounter SomeConstraintHandler
constr

    learnClause :: SomeConstraintHandler -> IO ()
    learnClause :: SomeConstraintHandler -> IO ()
learnClause SomeConstraintHandler
constr = do
      ([Lit]
learntClause, Lit
level) <- Solver -> SomeConstraintHandler -> IO ([Lit], Lit)
forall c. ConstraintHandler c => Solver -> c -> IO ([Lit], Lit)
analyzeConflict Solver
solver SomeConstraintHandler
constr
      Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
level
      case [Lit]
learntClause of
        [] -> [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"search(LearningClause): should not happen"
        [Lit
lit] -> do
          Bool
ret <- Solver -> Lit -> IO Bool
assign Solver
solver Lit
lit
          Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Lit
lit:[Lit]
_ -> do
          ClauseHandler
cl <- [Lit] -> Bool -> IO ClauseHandler
newClauseHandler [Lit]
learntClause Bool
True
          let constr2 :: SomeConstraintHandler
constr2 = ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
constr2
          Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
cl
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
constr2
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2

    learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
    learnHybrid :: IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
learnHybrid IORef Lit
conflictCounter SomeConstraintHandler
constr = do
      ([Lit]
learntClause, Lit
clauseLevel) <- Solver -> SomeConstraintHandler -> IO ([Lit], Lit)
forall c. ConstraintHandler c => Solver -> c -> IO ([Lit], Lit)
analyzeConflict Solver
solver SomeConstraintHandler
constr
      (Maybe PBLinAtLeast
pb, Lit
minLevel) <- do
        Maybe PBLinAtLeast
z <- IORef (Maybe PBLinAtLeast) -> IO (Maybe PBLinAtLeast)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe PBLinAtLeast)
svPBLearnt Solver
solver)
        case Maybe PBLinAtLeast
z of
          Maybe PBLinAtLeast
Nothing -> (Maybe PBLinAtLeast, Lit) -> IO (Maybe PBLinAtLeast, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PBLinAtLeast
z, Lit
clauseLevel)
          Just PBLinAtLeast
pb -> do
            Lit
pbLevel <- Solver -> PBLinAtLeast -> IO Lit
pbBacktrackLevel Solver
solver PBLinAtLeast
pb
            (Maybe PBLinAtLeast, Lit) -> IO (Maybe PBLinAtLeast, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PBLinAtLeast
z, Lit -> Lit -> Lit
forall a. Ord a => a -> a -> a
min Lit
clauseLevel Lit
pbLevel)
      Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
minLevel

      case [Lit]
learntClause of
        [] -> [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"search(LearningHybrid): should not happen"
        [Lit
lit] -> do
          Bool
_ <- Solver -> Lit -> IO Bool
assign Solver
solver Lit
lit -- This should always succeed.
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Lit
lit:[Lit]
_ -> do
          ClauseHandler
cl <- [Lit] -> Bool -> IO ClauseHandler
newClauseHandler [Lit]
learntClause Bool
True
          let constr2 :: SomeConstraintHandler
constr2 = ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
constr2
          Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
minLevel Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
clauseLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
_ <- Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
constr2 -- This should always succeed.
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      Maybe SomeConstraintHandler
ret <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
      case Maybe SomeConstraintHandler
ret of
        Just SomeConstraintHandler
conflicted -> do
          IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Lit
conflictCounter SomeConstraintHandler
conflicted
          -- TODO: should also learn the PB constraint?
        Maybe SomeConstraintHandler
Nothing -> do
          case Maybe PBLinAtLeast
pb of
            Maybe PBLinAtLeast
Nothing -> Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
            Just (PBLinSum
lhs,Integer
rhs) -> do
              SomeConstraintHandler
h <- Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted Solver
solver PBLinSum
lhs Integer
rhs Bool
True
              case SomeConstraintHandler
h of
                CHClause ClauseHandler
_ -> do
                  {- We don't want to add additional clause,
                     since it would be subsumed by already added one. -}
                  Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
                SomeConstraintHandler
_ -> do
                  Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
h
                  Bool
ret2 <- Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
h
                  Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
h
                  if Bool
ret2 then
                    Maybe SearchResult -> IO (Maybe SearchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
                  else
                    IORef Lit -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Lit
conflictCounter SomeConstraintHandler
h

-- | Cancel exectution of 'solve' or 'solveWith'.
--
-- This can be called from other threads.
cancel :: Solver -> IO ()
cancel :: Solver -> IO ()
cancel Solver
solver = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
True

-- | After 'solve' returns True, it returns an satisfying assignment.
getModel :: Solver -> IO Model
getModel :: Solver -> IO Model
getModel Solver
solver = do
  Maybe Model
m <- IORef (Maybe Model) -> IO (Maybe Model)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe Model)
svModel Solver
solver)
  Model -> IO Model
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Model -> Model
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust Maybe Model
m)

-- | After 'solveWith' returns False, it returns a set of assumptions
-- that leads to contradiction. In particular, if it returns an empty
-- set, the problem is unsatisiable without any assumptions.
getFailedAssumptions :: Solver -> IO LitSet
getFailedAssumptions :: Solver -> IO LitSet
getFailedAssumptions Solver
solver = IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (Solver -> IORef LitSet
svFailedAssumptions Solver
solver)

-- | __EXPERIMENTAL API__: After 'solveWith' returns True or failed with 'BudgetExceeded' exception,
-- it returns a set of literals that are implied by assumptions.
getAssumptionsImplications :: Solver -> IO LitSet
getAssumptionsImplications :: Solver -> IO LitSet
getAssumptionsImplications Solver
solver = IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (Solver -> IORef LitSet
svAssumptionsImplications Solver
solver)

{--------------------------------------------------------------------
  Simplification
--------------------------------------------------------------------}

-- | Simplify the constraint database according to the current top-level assigment.
simplify :: Solver -> IO ()
simplify :: Solver -> IO ()
simplify Solver
solver = do
  let loop :: [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [] [SomeConstraintHandler]
rs !t
n     = ([SomeConstraintHandler], t) -> IO ([SomeConstraintHandler], t)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SomeConstraintHandler]
rs,t
n)
      loop (SomeConstraintHandler
y:[SomeConstraintHandler]
ys) [SomeConstraintHandler]
rs !t
n = do
        Bool
b1 <- Solver -> SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver SomeConstraintHandler
y
        Bool
b2 <- Solver -> SomeConstraintHandler -> IO Bool
isLocked Solver
solver SomeConstraintHandler
y
        if Bool
b1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b2 then do
          Solver -> SomeConstraintHandler -> IO ()
detach Solver
solver SomeConstraintHandler
y
          [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
ys [SomeConstraintHandler]
rs (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
        else [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
ys (SomeConstraintHandler
ySomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:[SomeConstraintHandler]
rs) t
n

  -- simplify original constraint DB
  do
    [SomeConstraintHandler]
xs <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
    ([SomeConstraintHandler]
ys,Lit
n) <- [SomeConstraintHandler]
-> [SomeConstraintHandler]
-> Lit
-> IO ([SomeConstraintHandler], Lit)
forall t.
Num t =>
[SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
xs [] (Lit
0::Int)
    IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNRemovedConstr Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
n)
    IORef [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver) [SomeConstraintHandler]
ys

  -- simplify learnt constraint DB
  do
    (Lit
m,[SomeConstraintHandler]
xs) <- IORef (Lit, [SomeConstraintHandler])
-> IO (Lit, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver)
    ([SomeConstraintHandler]
ys,Lit
n) <- [SomeConstraintHandler]
-> [SomeConstraintHandler]
-> Lit
-> IO ([SomeConstraintHandler], Lit)
forall t.
Num t =>
[SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
xs [] (Lit
0::Int)
    IORef (Lit, [SomeConstraintHandler])
-> (Lit, [SomeConstraintHandler]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Lit, [SomeConstraintHandler])
svLearntDB Solver
solver) (Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
n, [SomeConstraintHandler]
ys)

{-
References:
L. Zhang, "On subsumption removal and On-the-Fly CNF simplification,"
Theory and Applications of Satisfiability Testing (2005), pp. 482-489.
-}

checkForwardSubsumption :: Solver -> Clause -> IO Bool
checkForwardSubsumption :: Solver -> [Lit] -> IO Bool
checkForwardSubsumption Solver
solver [Lit]
lits = do
  Bool
flag <- Config -> Bool
configEnableForwardSubsumptionRemoval (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  if Bool -> Bool
not Bool
flag then
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Bool -> IO Bool -> IO Bool
forall c. Bool -> IO c -> IO c
withEnablePhaseSaving Bool
False (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
      IO () -> IO () -> IO Bool -> IO Bool
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
        (Solver -> IO ()
pushDecisionLevel Solver
solver)
        (Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
levelRoot) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
          Bool
b <- (Lit -> IO Bool) -> [Lit] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (\Lit
lit -> Solver -> Lit -> IO Bool
assign Solver
solver (Lit -> Lit
litNot Lit
lit)) [Lit]
lits
          if Bool
b then
            (Maybe SomeConstraintHandler -> Bool)
-> IO (Maybe SomeConstraintHandler) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe SomeConstraintHandler -> Bool
forall a. Maybe a -> Bool
isJust (Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver)
          else do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> [Char] -> IO ()
log Solver
solver ([Char]
"forward subsumption: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
lits)
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    withEnablePhaseSaving :: Bool -> IO c -> IO c
withEnablePhaseSaving Bool
flag IO c
m =
      IO Config -> (Config -> IO ()) -> (Config -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (Solver -> IO Config
getConfig Solver
solver)
        (\Config
saved -> Solver -> (Config -> Config) -> IO ()
modifyConfig Solver
solver (\Config
config -> Config
config{ configEnablePhaseSaving :: Bool
configEnablePhaseSaving = Config -> Bool
configEnablePhaseSaving Config
saved }))
        (\Config
saved -> Solver -> Config -> IO ()
setConfig Solver
solver Config
saved{ configEnablePhaseSaving :: Bool
configEnablePhaseSaving = Bool
flag } IO () -> IO c -> IO c
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO c
m)

removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO ()
removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO ()
removeBackwardSubsumedBy Solver
solver PBLinAtLeast
pb = do
  Bool
flag <- Config -> Bool
configEnableBackwardSubsumptionRemoval (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    HashSet SomeConstraintHandler
xs <- Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy Solver
solver PBLinAtLeast
pb
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a. HashSet a -> [a]
HashSet.toList HashSet SomeConstraintHandler
xs) ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
        [Char]
s <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
c
        Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"backward subsumption: %s is subsumed by %s\n" [Char]
s (PBLinAtLeast -> [Char]
forall a. Show a => a -> [Char]
show PBLinAtLeast
pb))
    Solver -> HashSet SomeConstraintHandler -> IO ()
removeConstraintHandlers Solver
solver HashSet SomeConstraintHandler
xs

backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy Solver
solver pb :: PBLinAtLeast
pb@(PBLinSum
lhs,Integer
_) = do
  [HashSet SomeConstraintHandler]
xs <- PBLinSum
-> (PBLinTerm -> IO (HashSet SomeConstraintHandler))
-> IO [HashSet SomeConstraintHandler]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs ((PBLinTerm -> IO (HashSet SomeConstraintHandler))
 -> IO [HashSet SomeConstraintHandler])
-> (PBLinTerm -> IO (HashSet SomeConstraintHandler))
-> IO [HashSet SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Lit
lit) -> do
    Vec (HashSet SomeConstraintHandler)
-> Lit -> IO (HashSet SomeConstraintHandler)
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Lit -> Lit
litIndex Lit
lit)
  case [HashSet SomeConstraintHandler]
xs of
    [] -> HashSet SomeConstraintHandler -> IO (HashSet SomeConstraintHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return HashSet SomeConstraintHandler
forall a. HashSet a
HashSet.empty
    HashSet SomeConstraintHandler
s:[HashSet SomeConstraintHandler]
ss -> do
      let p :: a -> IO Bool
p a
c = do
            -- Note that @isPBRepresentable c@ is always True here,
            -- because only such constraints are added to occur list.
            -- See 'addToDB'.
            PBLinAtLeast
pb2 <- (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *).
Monad m =>
(Lit -> m LBool) -> PBLinAtLeast -> m PBLinAtLeast
instantiatePBLinAtLeast (Solver -> Lit -> IO LBool
getLitFixed Solver
solver) (PBLinAtLeast -> IO PBLinAtLeast)
-> IO PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast a
c
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ PBLinAtLeast -> PBLinAtLeast -> Bool
pbLinSubsume PBLinAtLeast
pb PBLinAtLeast
pb2
      ([SomeConstraintHandler] -> HashSet SomeConstraintHandler)
-> IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [SomeConstraintHandler] -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
        (IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler))
-> IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler)
forall a b. (a -> b) -> a -> b
$ (SomeConstraintHandler -> IO Bool)
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
p
        ([SomeConstraintHandler] -> IO [SomeConstraintHandler])
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a. HashSet a -> [a]
HashSet.toList
        (HashSet SomeConstraintHandler -> [SomeConstraintHandler])
-> HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ (HashSet SomeConstraintHandler
 -> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler)
-> HashSet SomeConstraintHandler
-> [HashSet SomeConstraintHandler]
-> HashSet SomeConstraintHandler
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashSet SomeConstraintHandler
-> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.intersection HashSet SomeConstraintHandler
s [HashSet SomeConstraintHandler]
ss

removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO ()
removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO ()
removeConstraintHandlers Solver
_ HashSet SomeConstraintHandler
zs | HashSet SomeConstraintHandler -> Bool
forall a. HashSet a -> Bool
HashSet.null HashSet SomeConstraintHandler
zs = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
removeConstraintHandlers Solver
solver HashSet SomeConstraintHandler
zs = do
  let loop :: [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [] [SomeConstraintHandler]
rs !t
n     = ([SomeConstraintHandler], t) -> IO ([SomeConstraintHandler], t)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SomeConstraintHandler]
rs,t
n)
      loop (SomeConstraintHandler
c:[SomeConstraintHandler]
cs) [SomeConstraintHandler]
rs !t
n = do
        if SomeConstraintHandler
c SomeConstraintHandler -> HashSet SomeConstraintHandler -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet SomeConstraintHandler
zs then do
          Solver -> SomeConstraintHandler -> IO ()
detach Solver
solver SomeConstraintHandler
c
          [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
cs [SomeConstraintHandler]
rs (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
        else [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
cs (SomeConstraintHandler
cSomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:[SomeConstraintHandler]
rs) t
n
  [SomeConstraintHandler]
xs <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  ([SomeConstraintHandler]
ys,Lit
n) <- [SomeConstraintHandler]
-> [SomeConstraintHandler]
-> Lit
-> IO ([SomeConstraintHandler], Lit)
forall t.
Num t =>
[SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
xs [] (Lit
0::Int)
  IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNRemovedConstr Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
n)
  IORef [SomeConstraintHandler] -> [SomeConstraintHandler] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver) [SomeConstraintHandler]
ys

{--------------------------------------------------------------------
  Parameter settings.
--------------------------------------------------------------------}

{--------------------------------------------------------------------
  Configulation
--------------------------------------------------------------------}

getConfig :: Solver -> IO Config
getConfig :: Solver -> IO Config
getConfig Solver
solver = IORef Config -> IO Config
forall a. IORef a -> IO a
readIORef (IORef Config -> IO Config) -> IORef Config -> IO Config
forall a b. (a -> b) -> a -> b
$ Solver -> IORef Config
svConfig Solver
solver

setConfig :: Solver -> Config -> IO ()
setConfig :: Solver -> Config -> IO ()
setConfig Solver
solver Config
conf = do
  Config
orig <- Solver -> IO Config
getConfig Solver
solver
  IORef Config -> Config -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Config
svConfig Solver
solver) Config
conf
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> BranchingStrategy
configBranchingStrategy Config
orig BranchingStrategy -> BranchingStrategy -> Bool
forall a. Eq a => a -> a -> Bool
/= Config -> BranchingStrategy
configBranchingStrategy Config
conf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    PriorityQueue -> IO ()
PQ.rebuild (Solver -> PriorityQueue
svVarQueue Solver
solver)

modifyConfig :: Solver -> (Config -> Config) -> IO ()
modifyConfig :: Solver -> (Config -> Config) -> IO ()
modifyConfig Solver
solver Config -> Config
f = do
  Config
config <- Solver -> IO Config
getConfig Solver
solver
  Solver -> Config -> IO ()
setConfig Solver
solver (Config -> IO ()) -> Config -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Config
f Config
config

-- | The default polarity of a variable.
setVarPolarity :: Solver -> Var -> Bool -> IO ()
setVarPolarity :: Solver -> Lit -> Bool -> IO ()
setVarPolarity Solver
solver Lit
v Bool
val = UVec Bool -> Lit -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svVarPolarity Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Bool
val

-- | Set random generator used by the random variable selection
setRandomGen :: Solver -> Rand.GenIO -> IO ()
setRandomGen :: Solver -> GenIO -> IO ()
setRandomGen Solver
solver = IORef (Gen RealWorld) -> Gen RealWorld -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef GenIO
svRandomGen Solver
solver)

-- | Get random generator used by the random variable selection
getRandomGen :: Solver -> IO Rand.GenIO
getRandomGen :: Solver -> IO GenIO
getRandomGen Solver
solver = IORef (Gen RealWorld) -> IO (Gen RealWorld)
forall a. IORef a -> IO a
readIORef (Solver -> IORef GenIO
svRandomGen Solver
solver)

setConfBudget :: Solver -> Maybe Int -> IO ()
setConfBudget :: Solver -> Maybe Lit -> IO ()
setConfBudget Solver
solver (Just Lit
b) | Lit
b Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
0 = IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svConfBudget Solver
solver) Lit
b
setConfBudget Solver
solver Maybe Lit
_ = IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svConfBudget Solver
solver) (-Lit
1)

-- | Set a callback function used to indicate a termination requirement to the solver.
--
-- The solver will periodically call this function and check its return value during
-- the search. If the callback function returns `True` the solver terminates and throws
-- 'Canceled' exception.
--
-- See also 'clearTerminateCallback' and
-- [IPASIR](https://github.com/biotomas/ipasir)'s @ipasir_set_terminate()@ function.
setTerminateCallback :: Solver -> IO Bool -> IO ()
setTerminateCallback :: Solver -> IO Bool -> IO ()
setTerminateCallback Solver
solver IO Bool
callback = IORef (Maybe (IO Bool)) -> Maybe (IO Bool) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (IO Bool))
svTerminateCallback Solver
solver) (IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just IO Bool
callback)

-- | Clear a callback function set by `setTerminateCallback`
clearTerminateCallback :: Solver -> IO ()
clearTerminateCallback :: Solver -> IO ()
clearTerminateCallback Solver
solver = IORef (Maybe (IO Bool)) -> Maybe (IO Bool) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (IO Bool))
svTerminateCallback Solver
solver) Maybe (IO Bool)
forall a. Maybe a
Nothing

-- | Set a callback function used to extract learned clauses from the solver.
-- The solver will call this function for each learned clause.
--
-- See also 'clearLearnCallback' and
-- [IPASIR](https://github.com/biotomas/ipasir)'s @ipasir_set_learn()@ function.
setLearnCallback :: Solver -> (Clause -> IO ()) -> IO ()
setLearnCallback :: Solver -> ([Lit] -> IO ()) -> IO ()
setLearnCallback Solver
solver [Lit] -> IO ()
callback = IORef (Maybe ([Lit] -> IO ())) -> Maybe ([Lit] -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe ([Lit] -> IO ()))
svLearnCallback Solver
solver) (([Lit] -> IO ()) -> Maybe ([Lit] -> IO ())
forall a. a -> Maybe a
Just [Lit] -> IO ()
callback)

-- | Clear a callback function set by `setLearnCallback`
clearLearnCallback :: Solver -> IO ()
clearLearnCallback :: Solver -> IO ()
clearLearnCallback Solver
solver = IORef (Maybe ([Lit] -> IO ())) -> Maybe ([Lit] -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe ([Lit] -> IO ()))
svLearnCallback Solver
solver) Maybe ([Lit] -> IO ())
forall a. Maybe a
Nothing

{--------------------------------------------------------------------
  API for implementation of @solve@
--------------------------------------------------------------------}

pickBranchLit :: Solver -> IO Lit
pickBranchLit :: Solver -> IO Lit
pickBranchLit !Solver
solver = do
  Gen RealWorld
gen <- IORef (Gen RealWorld) -> IO (Gen RealWorld)
forall a. IORef a -> IO a
readIORef (Solver -> IORef GenIO
svRandomGen Solver
solver)
  let vqueue :: PriorityQueue
vqueue = Solver -> PriorityQueue
svVarQueue Solver
solver
  !VarActivity
randfreq <- Config -> VarActivity
configRandomFreq (Config -> VarActivity) -> IO Config -> IO VarActivity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  !Lit
size <- PriorityQueue -> IO Lit
forall q (m :: * -> *). QueueSize q m => q -> m Lit
PQ.queueSize PriorityQueue
vqueue
  -- System.Random.random produces [0,1), but System.Random.MWC.uniform produces (0,1]
  !VarActivity
r <- (VarActivity -> VarActivity) -> IO VarActivity -> IO VarActivity
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (VarActivity
1 VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
-) (IO VarActivity -> IO VarActivity)
-> IO VarActivity -> IO VarActivity
forall a b. (a -> b) -> a -> b
$ GenIO -> IO VarActivity
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
Rand.uniform Gen RealWorld
GenIO
gen
  Lit
var <-
    if (VarActivity
r VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
< VarActivity
randfreq Bool -> Bool -> Bool
&& Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
2) then do
      IOUArray Lit Lit
a <- PriorityQueue -> IO (IOUArray Lit Lit)
PQ.getHeapArray PriorityQueue
vqueue
      Lit
i <- (Lit, Lit) -> GenIO -> IO Lit
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
Rand.uniformR (Lit
0, Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) Gen RealWorld
GenIO
gen
      Lit
var <- IOUArray Lit Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Lit Lit
a Lit
i
      LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
var
      if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then do
        IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNRandomDecision Solver
solver) (Lit
1Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+)
        Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
var
      else Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
litUndef
    else
      Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
litUndef

  -- Activity based decision
  let loop :: IO Var
      loop :: IO Lit
loop = do
        Maybe Lit
m <- PriorityQueue -> IO (Maybe Lit)
forall q (m :: * -> *) a. Dequeue q m a => q -> m (Maybe a)
PQ.dequeue PriorityQueue
vqueue
        case Maybe Lit
m of
          Maybe Lit
Nothing -> Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
litUndef
          Just Lit
var2 -> do
            LBool
val2 <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
var2
            if LBool
val2 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef
              then IO Lit
loop
              else Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
var2
  Lit
var2 <-
    if Lit
varLit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
litUndef
    then IO Lit
loop
    else Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
var

  if Lit
var2Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
litUndef then
    Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
litUndef
  else do
    -- TODO: random polarity
    Bool
p <- UVec Bool -> Lit -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svVarPolarity Solver
solver) (Lit
var2 Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
    Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> IO Lit) -> Lit -> IO Lit
forall a b. (a -> b) -> a -> b
$! Lit -> Bool -> Lit
literal Lit
var2 Bool
p

decide :: Solver -> Lit -> IO ()
decide :: Solver -> Lit -> IO ()
decide Solver
solver !Lit
lit = do
  IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Lit
svNDecision Solver
solver) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
  Solver -> IO ()
pushDecisionLevel Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"decide: should not happen"
  Solver -> Lit -> IO Bool
assign Solver
solver Lit
lit
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

deduce :: Solver -> IO (Maybe SomeConstraintHandler)
deduce :: Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver = (Either SomeConstraintHandler () -> Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((SomeConstraintHandler -> Maybe SomeConstraintHandler)
-> (() -> Maybe SomeConstraintHandler)
-> Either SomeConstraintHandler ()
-> Maybe SomeConstraintHandler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just (Maybe SomeConstraintHandler -> () -> Maybe SomeConstraintHandler
forall a b. a -> b -> a
const Maybe SomeConstraintHandler
forall a. Maybe a
Nothing)) (IO (Either SomeConstraintHandler ())
 -> IO (Maybe SomeConstraintHandler))
-> IO (Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
forall a b. (a -> b) -> a -> b
$ ExceptT SomeConstraintHandler IO ()
-> IO (Either SomeConstraintHandler ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SomeConstraintHandler IO ()
 -> IO (Either SomeConstraintHandler ()))
-> ExceptT SomeConstraintHandler IO ()
-> IO (Either SomeConstraintHandler ())
forall a b. (a -> b) -> a -> b
$ do
  let loop :: ExceptT SomeConstraintHandler IO ()
loop = do
        Solver -> ExceptT SomeConstraintHandler IO ()
deduceB Solver
solver
        Solver -> ExceptT SomeConstraintHandler IO ()
deduceT Solver
solver
        Bool
empty <- IO Bool -> ExceptT SomeConstraintHandler IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT SomeConstraintHandler IO Bool)
-> IO Bool -> ExceptT SomeConstraintHandler IO Bool
forall a b. (a -> b) -> a -> b
$ Solver -> IO Bool
bcpIsEmpty Solver
solver
        Bool
-> ExceptT SomeConstraintHandler IO ()
-> ExceptT SomeConstraintHandler IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty (ExceptT SomeConstraintHandler IO ()
 -> ExceptT SomeConstraintHandler IO ())
-> ExceptT SomeConstraintHandler IO ()
-> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT SomeConstraintHandler IO ()
loop
  ExceptT SomeConstraintHandler IO ()
loop

deduceB :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceB :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceB Solver
solver = ExceptT SomeConstraintHandler IO ()
loop
  where
    loop :: ExceptT SomeConstraintHandler IO ()
    loop :: ExceptT SomeConstraintHandler IO ()
loop = do
      Maybe Lit
r <- IO (Maybe Lit) -> ExceptT SomeConstraintHandler IO (Maybe Lit)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Lit) -> ExceptT SomeConstraintHandler IO (Maybe Lit))
-> IO (Maybe Lit) -> ExceptT SomeConstraintHandler IO (Maybe Lit)
forall a b. (a -> b) -> a -> b
$ Solver -> IO (Maybe Lit)
bcpDequeue Solver
solver
      case Maybe Lit
r of
        Maybe Lit
Nothing -> () -> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Lit
lit -> do
          Lit -> ExceptT SomeConstraintHandler IO ()
processLit Lit
lit
          Lit -> ExceptT SomeConstraintHandler IO ()
processVar Lit
lit
          ExceptT SomeConstraintHandler IO ()
loop

    processLit :: Lit -> ExceptT SomeConstraintHandler IO ()
    processLit :: Lit -> ExceptT SomeConstraintHandler IO ()
processLit !Lit
lit = IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SomeConstraintHandler ())
 -> ExceptT SomeConstraintHandler IO ())
-> IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe SomeConstraintHandler -> Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either SomeConstraintHandler ()
-> (SomeConstraintHandler -> Either SomeConstraintHandler ())
-> Maybe SomeConstraintHandler
-> Either SomeConstraintHandler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeConstraintHandler ()
forall a b. b -> Either a b
Right ()) SomeConstraintHandler -> Either SomeConstraintHandler ()
forall a b. a -> Either a b
Left) (IO (Maybe SomeConstraintHandler)
 -> IO (Either SomeConstraintHandler ()))
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall a b. (a -> b) -> a -> b
$ do
      let falsifiedLit :: Lit
falsifiedLit = Lit -> Lit
litNot Lit
lit
          a :: Vec [SomeConstraintHandler]
a = Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver
          idx :: Lit
idx = Lit -> Lit
litIndex Lit
falsifiedLit
      let loop2 :: [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [] = Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
          loop2 (SomeConstraintHandler
w:[SomeConstraintHandler]
ws) = do
            Bool
ok <- Solver -> SomeConstraintHandler -> Lit -> IO Bool
propagate Solver
solver SomeConstraintHandler
w Lit
falsifiedLit
            if Bool
ok then
              [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws
            else do
              Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify Vec [SomeConstraintHandler]
a Lit
idx ([SomeConstraintHandler]
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. [a] -> [a] -> [a]
++[SomeConstraintHandler]
ws)
              Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just SomeConstraintHandler
w)
      [SomeConstraintHandler]
ws <- Vec [SomeConstraintHandler] -> Lit -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead Vec [SomeConstraintHandler]
a Lit
idx
      Vec [SomeConstraintHandler]
-> Lit -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite Vec [SomeConstraintHandler]
a Lit
idx []
      [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws

    processVar :: Lit -> ExceptT SomeConstraintHandler IO ()
    processVar :: Lit -> ExceptT SomeConstraintHandler IO ()
processVar !Lit
lit = IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SomeConstraintHandler ())
 -> ExceptT SomeConstraintHandler IO ())
-> IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe SomeConstraintHandler -> Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either SomeConstraintHandler ()
-> (SomeConstraintHandler -> Either SomeConstraintHandler ())
-> Maybe SomeConstraintHandler
-> Either SomeConstraintHandler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeConstraintHandler ()
forall a b. b -> Either a b
Right ()) SomeConstraintHandler -> Either SomeConstraintHandler ()
forall a b. a -> Either a b
Left) (IO (Maybe SomeConstraintHandler)
 -> IO (Either SomeConstraintHandler ()))
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall a b. (a -> b) -> a -> b
$ do
      let falsifiedLit :: Lit
falsifiedLit = Lit -> Lit
litNot Lit
lit
          idx :: Lit
idx = Lit -> Lit
litVar Lit
lit Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1
      let loop2 :: [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [] = Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
          loop2 (SomeConstraintHandler
w:[SomeConstraintHandler]
ws) = do
            Bool
ok <- Solver -> SomeConstraintHandler -> Lit -> IO Bool
propagate Solver
solver SomeConstraintHandler
w Lit
falsifiedLit
            if Bool
ok
              then [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws
              else do
                Vec [SomeConstraintHandler]
-> Lit
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Lit
idx ([SomeConstraintHandler]
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. [a] -> [a] -> [a]
++[SomeConstraintHandler]
ws)
                Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just SomeConstraintHandler
w)
      [SomeConstraintHandler]
ws <- Vec [SomeConstraintHandler] -> Lit -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Lit
idx
      Vec [SomeConstraintHandler]
-> Lit -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Lit
idx []
      [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws

analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level)
analyzeConflict :: Solver -> c -> IO ([Lit], Lit)
analyzeConflict Solver
solver c
constr = do
  Config
config <- Solver -> IO Config
getConfig Solver
solver
  let isHybrid :: Bool
isHybrid = Config -> LearningStrategy
configLearningStrategy Config
config LearningStrategy -> LearningStrategy -> Bool
forall a. Eq a => a -> a -> Bool
== LearningStrategy
LearningHybrid

  Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
  (GenericVec IOUArray Lit
out :: Vec.UVec Lit) <- IO (GenericVec IOUArray Lit)
forall (a :: * -> * -> *) e. MArray a e IO => IO (GenericVec a e)
Vec.new
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push GenericVec IOUArray Lit
out Lit
0 -- (leave room for the asserting literal)
  (IOURef Lit
pathC :: IOURef Int) <- Lit -> IO (IOURef Lit)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Lit
0

  IORef (LitSet, PBLinAtLeast)
pbConstrRef <- (LitSet, PBLinAtLeast) -> IO (IORef (LitSet, PBLinAtLeast))
forall a. a -> IO (IORef a)
newIORef (LitSet, PBLinAtLeast)
forall a. (?callStack::CallStack) => a
undefined

  let f :: t Lit -> IO ()
f t Lit
lits = do
        t Lit -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t Lit
lits ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
lit -> do
          let !v :: Lit
v = Lit -> Lit
litVar Lit
lit
          Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
          Bool
b <- UVec Bool -> Lit -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svSeen Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& Lit
lv Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Solver -> Lit -> IO ()
varBumpActivity Solver
solver Lit
v
            Solver -> Lit -> IO ()
varIncrementParticipated Solver
solver Lit
v
            if Lit
lv Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
d then do
              UVec Bool -> Lit -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svSeen Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Bool
True
              IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef IOURef Lit
pathC (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
            else do
              GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push GenericVec IOUArray Lit
out Lit
lit

      processLitHybrid :: PBLinAtLeast -> a -> Lit -> IO [Lit] -> IO ()
processLitHybrid PBLinAtLeast
pb a
constr2 Lit
lit IO [Lit]
getLits = do
        PBLinAtLeast
pb2 <- do
          let clausePB :: IO PBLinAtLeast
clausePB = do
                [Lit]
lits <- IO [Lit]
getLits
                PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinAtLeast -> IO PBLinAtLeast)
-> PBLinAtLeast -> IO PBLinAtLeast
forall a b. (a -> b) -> a -> b
$ [Lit] -> PBLinAtLeast
clauseToPBLinAtLeast (Lit
lit Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit]
lits)
          Bool
b <- a -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable a
constr2
          if Bool -> Bool
not Bool
b then do
            IO PBLinAtLeast
clausePB
          else do
            PBLinAtLeast
pb2 <- a -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast a
constr2
            Bool
o <- Solver -> PBLinAtLeast -> IO Bool
pbOverSAT Solver
solver PBLinAtLeast
pb2
            if Bool
o then do
              IO PBLinAtLeast
clausePB
            else
              PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return PBLinAtLeast
pb2
        let pb3 :: PBLinAtLeast
pb3 = PBLinAtLeast -> PBLinAtLeast -> Lit -> PBLinAtLeast
cutResolve PBLinAtLeast
pb PBLinAtLeast
pb2 (Lit -> Lit
litVar Lit
lit)
            ls :: LitSet
ls = [Lit] -> LitSet
IS.fromList [Lit
l | (Integer
_,Lit
l) <- PBLinAtLeast -> PBLinSum
forall a b. (a, b) -> a
fst PBLinAtLeast
pb3]
        LitSet -> IO () -> IO ()
seq LitSet
ls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (LitSet, PBLinAtLeast) -> (LitSet, PBLinAtLeast) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (LitSet, PBLinAtLeast)
pbConstrRef (LitSet
ls, PBLinAtLeast
pb3)

      popUnseen :: IO ()
popUnseen = do
        Lit
l <- Solver -> IO Lit
peekTrail Solver
solver
        let !v :: Lit
v = Lit -> Lit
litVar Lit
l
        Bool
b <- UVec Bool -> Lit -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svSeen Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
        if Bool
b then do
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (ls, pb) <- IORef (LitSet, PBLinAtLeast) -> IO (LitSet, PBLinAtLeast)
forall a. IORef a -> IO a
readIORef IORef (LitSet, PBLinAtLeast)
pbConstrRef
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit -> Lit
litNot Lit
l Lit -> LitSet -> Bool
`IS.member` LitSet
ls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Just SomeConstraintHandler
constr2 <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver Lit
v
              PBLinAtLeast -> SomeConstraintHandler -> Lit -> IO [Lit] -> IO ()
forall a.
ConstraintHandler a =>
PBLinAtLeast -> a -> Lit -> IO [Lit] -> IO ()
processLitHybrid PBLinAtLeast
pb SomeConstraintHandler
constr2 Lit
l (Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
constr2 (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
l))
          Solver -> IO Lit
popTrail Solver
solver
          IO ()
popUnseen

      loop :: IO ()
loop = do
        IO ()
popUnseen
        Lit
l <- Solver -> IO Lit
peekTrail Solver
solver
        let !v :: Lit
v = Lit -> Lit
litVar Lit
l
        UVec Bool -> Lit -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svSeen Solver
solver) (Lit
v Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1) Bool
False
        IOURef Lit -> (Lit -> Lit) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef IOURef Lit
pathC (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
subtract Lit
1)
        Lit
c <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef IOURef Lit
pathC
        if Lit
c Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
0 then do
          Just SomeConstraintHandler
constr2 <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver Lit
v
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2
          [Lit]
lits <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
constr2 (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
l)
          [Lit] -> IO ()
forall (t :: * -> *). Foldable t => t Lit -> IO ()
f [Lit]
lits
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (ls, pb) <- IORef (LitSet, PBLinAtLeast) -> IO (LitSet, PBLinAtLeast)
forall a. IORef a -> IO a
readIORef IORef (LitSet, PBLinAtLeast)
pbConstrRef
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit -> Lit
litNot Lit
l Lit -> LitSet -> Bool
`IS.member` LitSet
ls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              PBLinAtLeast -> SomeConstraintHandler -> Lit -> IO [Lit] -> IO ()
forall a.
ConstraintHandler a =>
PBLinAtLeast -> a -> Lit -> IO [Lit] -> IO ()
processLitHybrid PBLinAtLeast
pb SomeConstraintHandler
constr2 Lit
l ([Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
lits)
          Solver -> IO Lit
popTrail Solver
solver
          IO ()
loop
        else do
          GenericVec IOUArray Lit -> Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> e -> IO ()
Vec.unsafeWrite GenericVec IOUArray Lit
out Lit
0 (Lit -> Lit
litNot Lit
l)

  Solver -> c -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver c
constr
  [Lit]
falsifiedLits <- Solver -> c -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver c
constr Maybe Lit
forall a. Maybe a
Nothing
  [Lit] -> IO ()
forall (t :: * -> *). Foldable t => t Lit -> IO ()
f [Lit]
falsifiedLits
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
     PBLinAtLeast
pb <- do
       Bool
b <- c -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable c
constr
       if Bool
b then
         c -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast c
constr
       else
         PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit] -> PBLinAtLeast
clauseToPBLinAtLeast [Lit]
falsifiedLits)
     let ls :: LitSet
ls = [Lit] -> LitSet
IS.fromList [Lit
l | (Integer
_,Lit
l) <- PBLinAtLeast -> PBLinSum
forall a b. (a, b) -> a
fst PBLinAtLeast
pb]
     LitSet -> IO () -> IO ()
seq LitSet
ls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (LitSet, PBLinAtLeast) -> (LitSet, PBLinAtLeast) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (LitSet, PBLinAtLeast)
pbConstrRef (LitSet
ls, PBLinAtLeast
pb)
  IO ()
loop
  LitSet
lits <- ([Lit] -> LitSet) -> IO [Lit] -> IO LitSet
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Lit] -> LitSet
IS.fromList (IO [Lit] -> IO LitSet) -> IO [Lit] -> IO LitSet
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Lit -> IO [Lit]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO [e]
Vec.getElems GenericVec IOUArray Lit
out

  LitSet
lits2 <- Solver -> LitSet -> IO LitSet
minimizeConflictClause Solver
solver LitSet
lits

  Solver -> [Lit] -> IO ()
incrementReasoned Solver
solver (LitSet -> [Lit]
IS.toList LitSet
lits2)

  [(Lit, Lit)]
xs <- ([(Lit, Lit)] -> [(Lit, Lit)])
-> IO [(Lit, Lit)] -> IO [(Lit, Lit)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> [(Lit, Lit)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd))) (IO [(Lit, Lit)] -> IO [(Lit, Lit)])
-> IO [(Lit, Lit)] -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$
    [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (LitSet -> [Lit]
IS.toList LitSet
lits2) ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
      Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
l
      (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (LitSet
_, PBLinAtLeast
pb) <- IORef (LitSet, PBLinAtLeast) -> IO (LitSet, PBLinAtLeast)
forall a. IORef a -> IO a
readIORef IORef (LitSet, PBLinAtLeast)
pbConstrRef
    case PBLinAtLeast -> Maybe [Lit]
pbToClause PBLinAtLeast
pb of
      Just [Lit]
_ -> IORef (Maybe PBLinAtLeast) -> Maybe PBLinAtLeast -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe PBLinAtLeast)
svPBLearnt Solver
solver) Maybe PBLinAtLeast
forall a. Maybe a
Nothing
      Maybe [Lit]
Nothing -> IORef (Maybe PBLinAtLeast) -> Maybe PBLinAtLeast -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe PBLinAtLeast)
svPBLearnt Solver
solver) (PBLinAtLeast -> Maybe PBLinAtLeast
forall a. a -> Maybe a
Just PBLinAtLeast
pb)

  let level :: Lit
level = case [(Lit, Lit)]
xs of
                [] -> [Char] -> Lit
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"analyzeConflict: should not happen"
                [(Lit, Lit)
_] -> Lit
levelRoot
                (Lit, Lit)
_:(Lit
_,Lit
lv):[(Lit, Lit)]
_ -> Lit
lv
      clause :: [Lit]
clause = ((Lit, Lit) -> Lit) -> [(Lit, Lit)] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (Lit, Lit) -> Lit
forall a b. (a, b) -> a
fst [(Lit, Lit)]
xs
  Solver -> [Lit] -> IO ()
callLearnCallback Solver
solver [Lit]
clause
  ([Lit], Lit) -> IO ([Lit], Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit]
clause, Lit
level)

-- { p } ∪ { pにfalseを割り当てる原因のassumption }
analyzeFinal :: Solver -> Lit -> IO [Lit]
analyzeFinal :: Solver -> Lit -> IO [Lit]
analyzeFinal Solver
solver Lit
p = do
  let go :: Int -> VarSet -> [Lit] -> IO [Lit]
      go :: Lit -> LitSet -> [Lit] -> IO [Lit]
go Lit
i LitSet
seen [Lit]
result
        | Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
0 = [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
result
        | Bool
otherwise = do
            Lit
l <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
i
            Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
l
            if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot then
              [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
result
            else if Lit -> Lit
litVar Lit
l Lit -> LitSet -> Bool
`IS.member` LitSet
seen then do
              Maybe SomeConstraintHandler
r <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
l)
              case Maybe SomeConstraintHandler
r of
                Maybe SomeConstraintHandler
Nothing -> do
                  let seen' :: LitSet
seen' = Lit -> LitSet -> LitSet
IS.delete (Lit -> Lit
litVar Lit
l) LitSet
seen
                  Lit -> LitSet -> [Lit] -> IO [Lit]
go (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) LitSet
seen' (Lit
l Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit]
result)
                Just SomeConstraintHandler
constr  -> do
                  [Lit]
c <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
constr (Lit -> Maybe Lit
forall a. a -> Maybe a
Just Lit
l)
                  let seen' :: LitSet
seen' = Lit -> LitSet -> LitSet
IS.delete (Lit -> Lit
litVar Lit
l) LitSet
seen LitSet -> LitSet -> LitSet
`IS.union` [Lit] -> LitSet
IS.fromList [Lit -> Lit
litVar Lit
l2 | Lit
l2 <- [Lit]
c]
                  Lit -> LitSet -> [Lit] -> IO [Lit]
go (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) LitSet
seen' [Lit]
result
            else
              Lit -> LitSet -> [Lit] -> IO [Lit]
go (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) LitSet
seen [Lit]
result
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  Lit -> LitSet -> [Lit] -> IO [Lit]
go (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) (Lit -> LitSet
IS.singleton (Lit -> Lit
litVar Lit
p)) [Lit
p]

callLearnCallback :: Solver -> Clause -> IO ()
callLearnCallback :: Solver -> [Lit] -> IO ()
callLearnCallback Solver
solver [Lit]
clause = do
  Maybe ([Lit] -> IO ())
cb <- IORef (Maybe ([Lit] -> IO ())) -> IO (Maybe ([Lit] -> IO ()))
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe ([Lit] -> IO ()))
svLearnCallback Solver
solver)
  case Maybe ([Lit] -> IO ())
cb of
    Maybe ([Lit] -> IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [Lit] -> IO ()
callback -> [Lit] -> IO ()
callback [Lit]
clause

pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level
pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Lit
pbBacktrackLevel Solver
_ ([], Integer
rhs) = Bool -> IO Lit -> IO Lit
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
rhs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO Lit -> IO Lit) -> IO Lit -> IO Lit
forall a b. (a -> b) -> a -> b
$ Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
levelRoot
pbBacktrackLevel Solver
solver (PBLinSum
lhs, Integer
rhs) = do
  IntMap (IntMap (Integer, LBool))
levelToLiterals <- ([IntMap (IntMap (Integer, LBool))]
 -> IntMap (IntMap (Integer, LBool)))
-> IO [IntMap (IntMap (Integer, LBool))]
-> IO (IntMap (IntMap (Integer, LBool)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((IntMap (Integer, LBool)
 -> IntMap (Integer, LBool) -> IntMap (Integer, LBool))
-> [IntMap (IntMap (Integer, LBool))]
-> IntMap (IntMap (Integer, LBool))
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IM.unionsWith IntMap (Integer, LBool)
-> IntMap (Integer, LBool) -> IntMap (Integer, LBool)
forall a. IntMap a -> IntMap a -> IntMap a
IM.union) (IO [IntMap (IntMap (Integer, LBool))]
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ PBLinSum
-> (PBLinTerm -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs ((PBLinTerm -> IO (IntMap (IntMap (Integer, LBool))))
 -> IO [IntMap (IntMap (Integer, LBool))])
-> (PBLinTerm -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
lit) -> do
    LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
    if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef then do
      Lit
level <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
      IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (Integer, LBool))
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ Lit -> IntMap (Integer, LBool) -> IntMap (IntMap (Integer, LBool))
forall a. Lit -> a -> IntMap a
IM.singleton Lit
level (Lit -> (Integer, LBool) -> IntMap (Integer, LBool)
forall a. Lit -> a -> IntMap a
IM.singleton Lit
lit (Integer
c,LBool
val))
    else
      IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (Integer, LBool))
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ Lit -> IntMap (Integer, LBool) -> IntMap (IntMap (Integer, LBool))
forall a. Lit -> a -> IntMap a
IM.singleton Lit
forall a. Bounded a => a
maxBound (Lit -> (Integer, LBool) -> IntMap (Integer, LBool)
forall a. Lit -> a -> IntMap a
IM.singleton Lit
lit (Integer
c,LBool
val))

  let replay :: [(a, IntMap (t, LBool))] -> t -> m a
replay [] !t
_ = [Char] -> m a
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"pbBacktrackLevel: should not happen"
      replay ((a
lv,IntMap (t, LBool)
lv_lits) : [(a, IntMap (t, LBool))]
lvs) !t
slack = do
        let slack_lv :: t
slack_lv = t
slack t -> t -> t
forall a. Num a => a -> a -> a
- [t] -> t
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [t
c | (Lit
_,(t
c,LBool
val)) <- IntMap (t, LBool) -> [(Lit, (t, LBool))]
forall a. IntMap a -> [(Lit, a)]
IM.toList IntMap (t, LBool)
lv_lits, LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse]
        if t
slack_lv t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 then
          a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- CONFLICT
        else if ((a, IntMap (t, LBool)) -> Bool)
-> [(a, IntMap (t, LBool))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
_, IntMap (t, LBool)
lits2) -> ((t, LBool) -> Bool) -> [(t, LBool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(t
c,LBool
_) -> t
c t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
slack_lv) (IntMap (t, LBool) -> [(t, LBool)]
forall a. IntMap a -> [a]
IM.elems IntMap (t, LBool)
lits2)) [(a, IntMap (t, LBool))]
lvs then
          a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- UNIT
        else
          [(a, IntMap (t, LBool))] -> t -> m a
replay [(a, IntMap (t, LBool))]
lvs t
slack_lv

  let initial_slack :: Integer
initial_slack = [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
  if (PBLinTerm -> Bool) -> PBLinSum -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Integer
c,Lit
_) -> Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
initial_slack) PBLinSum
lhs then
    Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
0
  else do
    [(Lit, IntMap (Integer, LBool))] -> Integer -> IO Lit
forall t (m :: * -> *) a.
(Ord t, Monad m, Num t) =>
[(a, IntMap (t, LBool))] -> t -> m a
replay (IntMap (IntMap (Integer, LBool))
-> [(Lit, IntMap (Integer, LBool))]
forall a. IntMap a -> [(Lit, a)]
IM.toList IntMap (IntMap (Integer, LBool))
levelToLiterals) Integer
initial_slack

minimizeConflictClause :: Solver -> LitSet -> IO LitSet
minimizeConflictClause :: Solver -> LitSet -> IO LitSet
minimizeConflictClause Solver
solver LitSet
lits = do
  Lit
ccmin <- Config -> Lit
configCCMin (Config -> Lit) -> IO Config -> IO Lit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  if Lit
ccmin Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
2 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseRecursive Solver
solver LitSet
lits
  else if Lit
ccmin Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
1 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseLocal Solver
solver LitSet
lits
  else
    LitSet -> IO LitSet
forall (m :: * -> *) a. Monad m => a -> m a
return LitSet
lits

minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet
minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet
minimizeConflictClauseLocal Solver
solver LitSet
lits = do
  let xs :: [Lit]
xs = LitSet -> [Lit]
IS.toAscList LitSet
lits
  [Lit]
ys <- (Lit -> IO Bool) -> [Lit] -> IO [Lit]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> (Lit -> IO Bool) -> Lit -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> IO Bool
isRedundant) [Lit]
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Solver -> [Char] -> IO ()
log Solver
solver [Char]
"minimizeConflictClauseLocal:"
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
xs
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
ys
  LitSet -> IO LitSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ [Lit] -> LitSet
IS.fromAscList ([Lit] -> LitSet) -> [Lit] -> LitSet
forall a b. (a -> b) -> a -> b
$ [Lit]
ys

  where
    isRedundant :: Lit -> IO Bool
    isRedundant :: Lit -> IO Bool
isRedundant Lit
lit = do
      Maybe SomeConstraintHandler
c <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
lit)
      case Maybe SomeConstraintHandler
c of
        Maybe SomeConstraintHandler
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SomeConstraintHandler
c2 -> do
          [Lit]
ls <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
c2 (Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Lit
litNot Lit
lit))
          (Lit -> IO Bool) -> [Lit] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Lit -> IO Bool
test [Lit]
ls

    test :: Lit -> IO Bool
    test :: Lit -> IO Bool
test Lit
lit = do
      Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot Bool -> Bool -> Bool
|| Lit
lit Lit -> LitSet -> Bool
`IS.member` LitSet
lits

minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet
minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet
minimizeConflictClauseRecursive Solver
solver LitSet
lits = do
  let
    isRedundant :: Lit -> IO Bool
    isRedundant :: Lit -> IO Bool
isRedundant Lit
lit = do
      Maybe SomeConstraintHandler
c <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
lit)
      case Maybe SomeConstraintHandler
c of
        Maybe SomeConstraintHandler
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SomeConstraintHandler
c2 -> do
          [Lit]
ls <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
c2 (Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Lit
litNot Lit
lit))
          [Lit] -> LitSet -> IO Bool
go [Lit]
ls LitSet
IS.empty

    go :: [Lit] -> IS.IntSet -> IO Bool
    go :: [Lit] -> LitSet -> IO Bool
go [] LitSet
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go (Lit
lit : [Lit]
ls) LitSet
seen = do
      Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
      if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot Bool -> Bool -> Bool
|| Lit
lit Lit -> LitSet -> Bool
`IS.member` LitSet
lits Bool -> Bool -> Bool
|| Lit
lit Lit -> LitSet -> Bool
`IS.member` LitSet
seen then
        [Lit] -> LitSet -> IO Bool
go [Lit]
ls LitSet
seen
      else do
        Maybe SomeConstraintHandler
c <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
lit)
        case Maybe SomeConstraintHandler
c of
          Maybe SomeConstraintHandler
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Just SomeConstraintHandler
c2 -> do
            [Lit]
ls2 <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver SomeConstraintHandler
c2 (Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Lit
litNot Lit
lit))
            [Lit] -> LitSet -> IO Bool
go ([Lit]
ls2 [Lit] -> [Lit] -> [Lit]
forall a. [a] -> [a] -> [a]
++ [Lit]
ls) (Lit -> LitSet -> LitSet
IS.insert Lit
lit LitSet
seen)

  let xs :: [Lit]
xs = LitSet -> [Lit]
IS.toAscList LitSet
lits
  [Lit]
ys <- (Lit -> IO Bool) -> [Lit] -> IO [Lit]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> (Lit -> IO Bool) -> Lit -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> IO Bool
isRedundant) [Lit]
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Solver -> [Char] -> IO ()
log Solver
solver [Char]
"minimizeConflictClauseRecursive:"
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
xs
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
ys
  LitSet -> IO LitSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ [Lit] -> LitSet
IS.fromAscList ([Lit] -> LitSet) -> [Lit] -> LitSet
forall a b. (a -> b) -> a -> b
$ [Lit]
ys

incrementReasoned :: Solver -> Clause -> IO ()
incrementReasoned :: Solver -> [Lit] -> IO ()
incrementReasoned Solver
solver [Lit]
ls = do
  let f :: LitSet -> Lit -> IO LitSet
f LitSet
reasonSided Lit
l = do
        Maybe SomeConstraintHandler
m <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
l)
        case Maybe SomeConstraintHandler
m of
          Maybe SomeConstraintHandler
Nothing -> LitSet -> IO LitSet
forall (m :: * -> *) a. Monad m => a -> m a
return LitSet
reasonSided
          Just SomeConstraintHandler
constr -> do
            LBool
v <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) IO ()
forall a. (?callStack::CallStack) => a
undefined
            [Lit]
xs <- Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver SomeConstraintHandler
constr (Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Lit
litNot Lit
l))
            LitSet -> IO LitSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ LitSet
reasonSided LitSet -> LitSet -> LitSet
`IS.union` [Lit] -> LitSet
IS.fromList ((Lit -> Lit) -> [Lit] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map Lit -> Lit
litVar [Lit]
xs)
  LitSet
reasonSided <- (LitSet -> Lit -> IO LitSet) -> LitSet -> [Lit] -> IO LitSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LitSet -> Lit -> IO LitSet
f LitSet
IS.empty [Lit]
ls
  (Lit -> IO ()) -> [Lit] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Solver -> Lit -> IO ()
varIncrementReasoned Solver
solver) (LitSet -> [Lit]
IS.toList LitSet
reasonSided)

peekTrail :: Solver -> IO Lit
peekTrail :: Solver -> IO Lit
peekTrail Solver
solver = do
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1)

popTrail :: Solver -> IO Lit
popTrail :: Solver -> IO Lit
popTrail Solver
solver = do
  Lit
l <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO e
Vec.unsafePop (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  Solver -> Lit -> IO ()
unassign Solver
solver (Lit -> Lit
litVar Lit
l)
  Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
l

getDecisionLevel ::Solver -> IO Int
getDecisionLevel :: Solver -> IO Lit
getDecisionLevel Solver
solver = GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver)

pushDecisionLevel :: Solver -> IO ()
pushDecisionLevel :: Solver -> IO ()
pushDecisionLevel Solver
solver = do
  GenericVec IOUArray Lit -> Lit -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver) (Lit -> IO ()) -> IO Lit -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
  Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
t -> TheorySolver -> IO ()
thPushBacktrackPoint TheorySolver
t

popDecisionLevel :: Solver -> IO ()
popDecisionLevel :: Solver -> IO ()
popDecisionLevel Solver
solver = do
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO e
Vec.unsafePop (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver)
  let loop :: IO ()
loop = do
        Lit
m <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
m Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Solver -> IO Lit
popTrail Solver
solver
          IO ()
loop
  IO ()
loop
  Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
t -> TheorySolver -> IO ()
thPopBacktrackPoint TheorySolver
t

-- | Revert to the state at given level
-- (keeping all assignment at @level@ but not beyond).
backtrackTo :: Solver -> Int -> IO ()
backtrackTo :: Solver -> Lit -> IO ()
backtrackTo Solver
solver Lit
level = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"backtrackTo: %d" Lit
level
  IO ()
loop
  Solver -> IO ()
bcpClear Solver
solver
  Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
_ -> do
      Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
      IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svTheoryChecked Solver
solver) Lit
n
  where
    loop :: IO ()
    loop :: IO ()
loop = do
      Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
lv Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Solver -> IO ()
popDecisionLevel Solver
solver
        IO ()
loop

constructModel :: Solver -> IO ()
constructModel :: Solver -> IO ()
constructModel Solver
solver = do
  Lit
n <- Solver -> IO Lit
getNVars Solver
solver
  (IOUArray Lit Bool
marr::IOUArray Var Bool) <- (Lit, Lit) -> IO (IOUArray Lit Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Lit
1,Lit
n)
  Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
1 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<=Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
v -> do
    LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
    IOUArray Lit Bool -> Lit -> Bool -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Lit Bool
marr Lit
v (Maybe Bool -> Bool
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val))
  Model
m <- IOUArray Lit Bool -> IO Model
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze IOUArray Lit Bool
marr
  IORef (Maybe Model) -> Maybe Model -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe Model)
svModel Solver
solver) (Model -> Maybe Model
forall a. a -> Maybe a
Just Model
m)

saveAssumptionsImplications :: Solver -> IO ()
saveAssumptionsImplications :: Solver -> IO ()
saveAssumptionsImplications Solver
solver = do
  Lit
n <- GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver)
  Lit
lv <- Solver -> IO Lit
getDecisionLevel Solver
solver

  Lit
lim_beg <-
    if Lit
lv Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
0 then
      Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
0
    else
      GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.read (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver) Lit
0
  Lit
lim_end <-
    if Lit
lv Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
n then
       GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.read (Solver -> GenericVec IOUArray Lit
svTrailLimit Solver
solver) Lit
n
    else
       GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)

  let ref :: IORef LitSet
ref = Solver -> IORef LitSet
svAssumptionsImplications Solver
solver
  [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit
lim_beg .. Lit
lim_endLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i -> do
    Lit
lit <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.read (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
i
    IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef LitSet
ref (Lit -> LitSet -> LitSet
IS.insert Lit
lit)
  [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit
0..Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i -> do
    Lit
lit <- GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.read (Solver -> GenericVec IOUArray Lit
svAssumptions Solver
solver) Lit
i
    IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef LitSet
ref (Lit -> LitSet -> LitSet
IS.delete Lit
lit)

constrDecayActivity :: Solver -> IO ()
constrDecayActivity :: Solver -> IO ()
constrDecayActivity Solver
solver = do
  VarActivity
d <- Config -> VarActivity
configConstrDecay (Config -> VarActivity) -> IO Config -> IO VarActivity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  IOURef VarActivity -> (VarActivity -> VarActivity) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef VarActivity
svConstrInc Solver
solver) (VarActivity
dVarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*)

constrBumpActivity :: ConstraintHandler a => Solver -> a -> IO ()
constrBumpActivity :: Solver -> a -> IO ()
constrBumpActivity Solver
solver a
this = do
  VarActivity
aval <- a -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity a
this
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
aval VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
>= VarActivity
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- learnt clause
    VarActivity
inc <- IOURef VarActivity -> IO VarActivity
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef VarActivity
svConstrInc Solver
solver)
    let aval2 :: VarActivity
aval2 = VarActivity
avalVarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
+VarActivity
inc
    a -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity a
this (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
aval2 VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
> VarActivity
1e20) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- Rescale
      Solver -> IO ()
constrRescaleAllActivity Solver
solver

constrRescaleAllActivity :: Solver -> IO ()
constrRescaleAllActivity :: Solver -> IO ()
constrRescaleAllActivity Solver
solver = do
  [SomeConstraintHandler]
xs <- Solver -> IO [SomeConstraintHandler]
learntConstraints Solver
solver
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
xs ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    VarActivity
aval <- SomeConstraintHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity SomeConstraintHandler
c
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VarActivity
aval VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
>= VarActivity
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      SomeConstraintHandler -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity SomeConstraintHandler
c (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! (VarActivity
aval VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
1e-20)
  IOURef VarActivity -> (VarActivity -> VarActivity) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef VarActivity
svConstrInc Solver
solver) (VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
1e-20)

resetStat :: Solver -> IO ()
resetStat :: Solver -> IO ()
resetStat Solver
solver = do
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svNDecision Solver
solver) Lit
0
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svNRandomDecision Solver
solver) Lit
0
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svNConflict Solver
solver) Lit
0
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svNRestart Solver
solver) Lit
0
  IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svNLearntGC Solver
solver) Lit
0

printStatHeader :: Solver -> IO ()
printStatHeader :: Solver -> IO ()
printStatHeader Solver
solver = do
  Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"============================[ Search Statistics ]============================"
  Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
" Time | Restart | Decision | Conflict |      LEARNT     | Fixed    | Removed "
  Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"      |         |          |          |    Limit     GC | Var      | Constra "
  Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"============================================================================="

printStat :: Solver -> Bool -> IO ()
printStat :: Solver -> Bool -> IO ()
printStat Solver
solver Bool
force = do
  TimeSpec
nowWC <- Clock -> IO TimeSpec
getTime Clock
Monotonic
  Bool
b <- if Bool
force
       then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else do
         TimeSpec
lastWC <- IORef TimeSpec -> IO TimeSpec
forall a. IORef a -> IO a
readIORef (Solver -> IORef TimeSpec
svLastStatWC Solver
solver)
         Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Int64
sec (TimeSpec
nowWC TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
lastWC) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
1
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TimeSpec
startWC   <- IORef TimeSpec -> IO TimeSpec
forall a. IORef a -> IO a
readIORef (Solver -> IORef TimeSpec
svStartWC Solver
solver)
    let tm :: [Char]
tm = TimeSpec -> [Char]
showTimeDiff (TimeSpec -> [Char]) -> TimeSpec -> [Char]
forall a b. (a -> b) -> a -> b
$ TimeSpec
nowWC TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
startWC
    Lit
restart   <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNRestart Solver
solver)
    Lit
dec       <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNDecision Solver
solver)
    Lit
conflict  <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNConflict Solver
solver)
    Lit
learntLim <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef (Solver -> IORef Lit
svLearntLim Solver
solver)
    Lit
learntGC  <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNLearntGC Solver
solver)
    Lit
fixed     <- Solver -> IO Lit
getNFixed Solver
solver
    Lit
removed   <- IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svNRemovedConstr Solver
solver)
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> [Char]
-> Lit
-> Lit
-> Lit
-> Lit
-> Lit
-> Lit
-> Lit
-> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s | %7d | %8d | %8d | %8d %6d | %8d | %8d"
      [Char]
tm Lit
restart Lit
dec Lit
conflict Lit
learntLim Lit
learntGC Lit
fixed Lit
removed
    IORef TimeSpec -> TimeSpec -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef TimeSpec
svLastStatWC Solver
solver) TimeSpec
nowWC

showTimeDiff :: TimeSpec -> String
showTimeDiff :: TimeSpec -> [Char]
showTimeDiff TimeSpec
t
  | Integer
si Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4.1fs" (Rational -> VarActivity
forall a. Fractional a => Rational -> a
fromRational Rational
s :: Double)
  | Integer
si Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9999 = [Char] -> Integer -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4ds" Integer
si
  | Integer
mi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4.1fm" (Rational -> VarActivity
forall a. Fractional a => Rational -> a
fromRational Rational
m :: Double)
  | Integer
mi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9999 = [Char] -> Integer -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4dm" Integer
mi
  | Integer
hi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4.1fs" (Rational -> VarActivity
forall a. Fractional a => Rational -> a
fromRational Rational
h :: Double)
  | Bool
otherwise  = [Char] -> Integer -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%4dh" Integer
hi
  where
    s :: Rational
    s :: Rational
s = Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs TimeSpec
t) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
10Rational -> Lit -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^(Lit
9::Int)

    si :: Integer
    si :: Integer
si = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Int64
sec TimeSpec
t)

    m :: Rational
    m :: Rational
m = Rational
s Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
60

    mi :: Integer
    mi :: Integer
mi = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
m

    h :: Rational
    h :: Rational
h = Rational
m Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
60

    hi :: Integer
    hi :: Integer
hi = Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
h

{--------------------------------------------------------------------
  constraint implementation
--------------------------------------------------------------------}

class (Eq a, Hashable a) => ConstraintHandler a where
  toConstraintHandler :: a -> SomeConstraintHandler

  showConstraintHandler :: a -> IO String

  constrAttach :: Solver -> SomeConstraintHandler -> a -> IO Bool

  constrDetach :: Solver -> SomeConstraintHandler -> a -> IO ()

  constrIsLocked :: Solver -> SomeConstraintHandler -> a -> IO Bool

  -- | invoked with the watched literal when the literal is falsified.
  -- 'watch' で 'toConstraint' を呼び出して heap allocation が発生するのを
  -- 避けるために、元の 'SomeConstraintHandler' も渡しておく。
  constrPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool

  -- | deduce a clause C∨l from the constraint and return C.
  -- C and l should be false and true respectively under the current
  -- assignment.
  constrReasonOf :: Solver -> a -> Maybe Lit -> IO Clause

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> a -> Lit -> IO ()

  isPBRepresentable :: a -> IO Bool
  toPBLinAtLeast :: a -> IO PBLinAtLeast

  isSatisfied :: Solver -> a -> IO Bool

  constrIsProtected :: Solver -> a -> IO Bool
  constrIsProtected Solver
_ a
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  constrWeight :: Solver -> a -> IO Double
  constrWeight Solver
_ a
_ = VarActivity -> IO VarActivity
forall (m :: * -> *) a. Monad m => a -> m a
return VarActivity
1.0

  constrReadActivity :: a -> IO Double

  constrWriteActivity :: a -> Double -> IO ()

attach :: Solver -> SomeConstraintHandler -> IO Bool
attach :: Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
c = Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c

detach :: Solver -> SomeConstraintHandler -> IO ()
detach :: Solver -> SomeConstraintHandler -> IO ()
detach Solver
solver SomeConstraintHandler
c = do
  Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c
  Bool
b <- SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable SomeConstraintHandler
c
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (PBLinSum
lhs,Integer
_) <- SomeConstraintHandler -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast SomeConstraintHandler
c
    PBLinSum -> (PBLinTerm -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PBLinSum
lhs ((PBLinTerm -> IO ()) -> IO ()) -> (PBLinTerm -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Lit
lit) -> do
      Vec (HashSet SomeConstraintHandler)
-> Lit
-> (HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler)
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Lit -> Lit
litIndex Lit
lit) (SomeConstraintHandler
-> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete SomeConstraintHandler
c)

-- | invoked with the watched literal when the literal is falsified.
propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool
propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool
propagate Solver
solver SomeConstraintHandler
c Lit
l = Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c Lit
l

-- | deduce a clause C∨l from the constraint and return C.
-- C and l should be false and true respectively under the current
-- assignment.
reasonOf :: ConstraintHandler a => Solver -> a -> Maybe Lit -> IO Clause
reasonOf :: Solver -> a -> Maybe Lit -> IO [Lit]
reasonOf Solver
solver a
c Maybe Lit
x = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    case Maybe Lit
x of
      Maybe Lit
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Lit
lit -> do
        LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
lTrue LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Char]
str <- a -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler a
c
          [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> Lit -> [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"reasonOf: value of literal %d should be True but %s (constrReasonOf %s %s)" Lit
lit (LBool -> [Char]
forall a. Show a => a -> [Char]
show LBool
val) [Char]
str (Maybe Lit -> [Char]
forall a. Show a => a -> [Char]
show Maybe Lit
x))
  [Lit]
cl <- Solver -> a -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver a
c Maybe Lit
x
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit]
cl ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
lit -> do
      LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
lFalse LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [Char]
str <- a -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler a
c
        [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> Lit -> [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"reasonOf: value of literal %d should be False but %s (constrReasonOf %s %s)" Lit
lit (LBool -> [Char]
forall a. Show a => a -> [Char]
show LBool
val) [Char]
str (Maybe Lit -> [Char]
forall a. Show a => a -> [Char]
show Maybe Lit
x))
  [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
cl

isLocked :: Solver -> SomeConstraintHandler -> IO Bool
isLocked :: Solver -> SomeConstraintHandler -> IO Bool
isLocked Solver
solver SomeConstraintHandler
c = Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c

data SomeConstraintHandler
  = CHClause !ClauseHandler
  | CHAtLeast !AtLeastHandler
  | CHPBCounter !PBHandlerCounter
  | CHPBPueblo !PBHandlerPueblo
  | CHXORClause !XORClauseHandler
  | CHTheory !TheoryHandler
  deriving SomeConstraintHandler -> SomeConstraintHandler -> Bool
(SomeConstraintHandler -> SomeConstraintHandler -> Bool)
-> (SomeConstraintHandler -> SomeConstraintHandler -> Bool)
-> Eq SomeConstraintHandler
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SomeConstraintHandler -> SomeConstraintHandler -> Bool
$c/= :: SomeConstraintHandler -> SomeConstraintHandler -> Bool
== :: SomeConstraintHandler -> SomeConstraintHandler -> Bool
$c== :: SomeConstraintHandler -> SomeConstraintHandler -> Bool
Eq

instance Hashable SomeConstraintHandler where
  hashWithSalt :: Lit -> SomeConstraintHandler -> Lit
hashWithSalt Lit
s (CHClause ClauseHandler
c)    = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
0::Int) Lit -> ClauseHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` ClauseHandler
c
  hashWithSalt Lit
s (CHAtLeast AtLeastHandler
c)   = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
1::Int) Lit -> AtLeastHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` AtLeastHandler
c
  hashWithSalt Lit
s (CHPBCounter PBHandlerCounter
c) = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
2::Int) Lit -> PBHandlerCounter -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` PBHandlerCounter
c
  hashWithSalt Lit
s (CHPBPueblo PBHandlerPueblo
c)  = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
3::Int) Lit -> PBHandlerPueblo -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` PBHandlerPueblo
c
  hashWithSalt Lit
s (CHXORClause XORClauseHandler
c) = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
4::Int) Lit -> XORClauseHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` XORClauseHandler
c
  hashWithSalt Lit
s (CHTheory TheoryHandler
c)    = Lit
s Lit -> Lit -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` (Lit
5::Int) Lit -> TheoryHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
`hashWithSalt` TheoryHandler
c

instance ConstraintHandler SomeConstraintHandler where
  toConstraintHandler :: SomeConstraintHandler -> SomeConstraintHandler
toConstraintHandler = SomeConstraintHandler -> SomeConstraintHandler
forall a. a -> a
id

  showConstraintHandler :: SomeConstraintHandler -> IO [Char]
showConstraintHandler (CHClause ClauseHandler
c)    = ClauseHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler ClauseHandler
c
  showConstraintHandler (CHAtLeast AtLeastHandler
c)   = AtLeastHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler AtLeastHandler
c
  showConstraintHandler (CHPBCounter PBHandlerCounter
c) = PBHandlerCounter -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler PBHandlerCounter
c
  showConstraintHandler (CHPBPueblo PBHandlerPueblo
c)  = PBHandlerPueblo -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler PBHandlerPueblo
c
  showConstraintHandler (CHXORClause XORClauseHandler
c) = XORClauseHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler XORClauseHandler
c
  showConstraintHandler (CHTheory TheoryHandler
c)    = TheoryHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler TheoryHandler
c

  constrAttach :: Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)    = Solver -> SomeConstraintHandler -> ClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = Solver -> SomeConstraintHandler -> AtLeastHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this TheoryHandler
c

  constrDetach :: Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)    = Solver -> SomeConstraintHandler -> ClauseHandler -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = Solver -> SomeConstraintHandler -> AtLeastHandler -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = Solver -> SomeConstraintHandler -> XORClauseHandler -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = Solver -> SomeConstraintHandler -> TheoryHandler -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this TheoryHandler
c

  constrIsLocked :: Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)    = Solver -> SomeConstraintHandler -> ClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = Solver -> SomeConstraintHandler -> AtLeastHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this TheoryHandler
c

  constrPropagate :: Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)  Lit
lit   = Solver -> SomeConstraintHandler -> ClauseHandler -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this ClauseHandler
c Lit
lit
  constrPropagate Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c) Lit
lit   = Solver -> SomeConstraintHandler -> AtLeastHandler -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this AtLeastHandler
c Lit
lit
  constrPropagate Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) Lit
lit = Solver
-> SomeConstraintHandler -> PBHandlerCounter -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this PBHandlerCounter
c Lit
lit
  constrPropagate Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c) Lit
lit  = Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c Lit
lit
  constrPropagate Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) Lit
lit = Solver
-> SomeConstraintHandler -> XORClauseHandler -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this XORClauseHandler
c Lit
lit
  constrPropagate Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c) Lit
lit    = Solver -> SomeConstraintHandler -> TheoryHandler -> Lit -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this TheoryHandler
c Lit
lit

  constrReasonOf :: Solver -> SomeConstraintHandler -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver (CHClause ClauseHandler
c)  Maybe Lit
l   = Solver -> ClauseHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver ClauseHandler
c Maybe Lit
l
  constrReasonOf Solver
solver (CHAtLeast AtLeastHandler
c) Maybe Lit
l   = Solver -> AtLeastHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver AtLeastHandler
c Maybe Lit
l
  constrReasonOf Solver
solver (CHPBCounter PBHandlerCounter
c) Maybe Lit
l = Solver -> PBHandlerCounter -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver PBHandlerCounter
c Maybe Lit
l
  constrReasonOf Solver
solver (CHPBPueblo PBHandlerPueblo
c) Maybe Lit
l  = Solver -> PBHandlerPueblo -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver PBHandlerPueblo
c Maybe Lit
l
  constrReasonOf Solver
solver (CHXORClause XORClauseHandler
c) Maybe Lit
l = Solver -> XORClauseHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver XORClauseHandler
c Maybe Lit
l
  constrReasonOf Solver
solver (CHTheory TheoryHandler
c) Maybe Lit
l    = Solver -> TheoryHandler -> Maybe Lit -> IO [Lit]
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver TheoryHandler
c Maybe Lit
l

  constrOnUnassigned :: Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)  Lit
l   = Solver -> SomeConstraintHandler -> ClauseHandler -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this ClauseHandler
c Lit
l
  constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c) Lit
l   = Solver -> SomeConstraintHandler -> AtLeastHandler -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this AtLeastHandler
c Lit
l
  constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) Lit
l = Solver -> SomeConstraintHandler -> PBHandlerCounter -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this PBHandlerCounter
c Lit
l
  constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c) Lit
l  = Solver -> SomeConstraintHandler -> PBHandlerPueblo -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c Lit
l
  constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) Lit
l = Solver -> SomeConstraintHandler -> XORClauseHandler -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this XORClauseHandler
c Lit
l
  constrOnUnassigned Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c) Lit
l    = Solver -> SomeConstraintHandler -> TheoryHandler -> Lit -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this TheoryHandler
c Lit
l

  isPBRepresentable :: SomeConstraintHandler -> IO Bool
isPBRepresentable (CHClause ClauseHandler
c)    = ClauseHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable ClauseHandler
c
  isPBRepresentable (CHAtLeast AtLeastHandler
c)   = AtLeastHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable AtLeastHandler
c
  isPBRepresentable (CHPBCounter PBHandlerCounter
c) = PBHandlerCounter -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable PBHandlerCounter
c
  isPBRepresentable (CHPBPueblo PBHandlerPueblo
c)  = PBHandlerPueblo -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable PBHandlerPueblo
c
  isPBRepresentable (CHXORClause XORClauseHandler
c) = XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable XORClauseHandler
c
  isPBRepresentable (CHTheory TheoryHandler
c)    = TheoryHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable TheoryHandler
c

  toPBLinAtLeast :: SomeConstraintHandler -> IO PBLinAtLeast
toPBLinAtLeast (CHClause ClauseHandler
c)    = ClauseHandler -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast ClauseHandler
c
  toPBLinAtLeast (CHAtLeast AtLeastHandler
c)   = AtLeastHandler -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast AtLeastHandler
c
  toPBLinAtLeast (CHPBCounter PBHandlerCounter
c) = PBHandlerCounter -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast PBHandlerCounter
c
  toPBLinAtLeast (CHPBPueblo PBHandlerPueblo
c)  = PBHandlerPueblo -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast PBHandlerPueblo
c
  toPBLinAtLeast (CHXORClause XORClauseHandler
c) = XORClauseHandler -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast XORClauseHandler
c
  toPBLinAtLeast (CHTheory TheoryHandler
c)    = TheoryHandler -> IO PBLinAtLeast
forall a. ConstraintHandler a => a -> IO PBLinAtLeast
toPBLinAtLeast TheoryHandler
c

  isSatisfied :: Solver -> SomeConstraintHandler -> IO Bool
isSatisfied Solver
solver (CHClause ClauseHandler
c)    = Solver -> ClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver ClauseHandler
c
  isSatisfied Solver
solver (CHAtLeast AtLeastHandler
c)   = Solver -> AtLeastHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver AtLeastHandler
c
  isSatisfied Solver
solver (CHPBCounter PBHandlerCounter
c) = Solver -> PBHandlerCounter -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver PBHandlerCounter
c
  isSatisfied Solver
solver (CHPBPueblo PBHandlerPueblo
c)  = Solver -> PBHandlerPueblo -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver PBHandlerPueblo
c
  isSatisfied Solver
solver (CHXORClause XORClauseHandler
c) = Solver -> XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver XORClauseHandler
c
  isSatisfied Solver
solver (CHTheory TheoryHandler
c)    = Solver -> TheoryHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver TheoryHandler
c

  constrIsProtected :: Solver -> SomeConstraintHandler -> IO Bool
constrIsProtected Solver
solver (CHClause ClauseHandler
c)    = Solver -> ClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver ClauseHandler
c
  constrIsProtected Solver
solver (CHAtLeast AtLeastHandler
c)   = Solver -> AtLeastHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver AtLeastHandler
c
  constrIsProtected Solver
solver (CHPBCounter PBHandlerCounter
c) = Solver -> PBHandlerCounter -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver PBHandlerCounter
c
  constrIsProtected Solver
solver (CHPBPueblo PBHandlerPueblo
c)  = Solver -> PBHandlerPueblo -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver PBHandlerPueblo
c
  constrIsProtected Solver
solver (CHXORClause XORClauseHandler
c) = Solver -> XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver XORClauseHandler
c
  constrIsProtected Solver
solver (CHTheory TheoryHandler
c)    = Solver -> TheoryHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
constrIsProtected Solver
solver TheoryHandler
c

  constrReadActivity :: SomeConstraintHandler -> IO VarActivity
constrReadActivity (CHClause ClauseHandler
c)    = ClauseHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity ClauseHandler
c
  constrReadActivity (CHAtLeast AtLeastHandler
c)   = AtLeastHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity AtLeastHandler
c
  constrReadActivity (CHPBCounter PBHandlerCounter
c) = PBHandlerCounter -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity PBHandlerCounter
c
  constrReadActivity (CHPBPueblo PBHandlerPueblo
c)  = PBHandlerPueblo -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity PBHandlerPueblo
c
  constrReadActivity (CHXORClause XORClauseHandler
c) = XORClauseHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity XORClauseHandler
c
  constrReadActivity (CHTheory TheoryHandler
c)    = TheoryHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity TheoryHandler
c

  constrWriteActivity :: SomeConstraintHandler -> VarActivity -> IO ()
constrWriteActivity (CHClause ClauseHandler
c)    VarActivity
aval = ClauseHandler -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity ClauseHandler
c VarActivity
aval
  constrWriteActivity (CHAtLeast AtLeastHandler
c)   VarActivity
aval = AtLeastHandler -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity AtLeastHandler
c VarActivity
aval
  constrWriteActivity (CHPBCounter PBHandlerCounter
c) VarActivity
aval = PBHandlerCounter -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity PBHandlerCounter
c VarActivity
aval
  constrWriteActivity (CHPBPueblo PBHandlerPueblo
c)  VarActivity
aval = PBHandlerPueblo -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity PBHandlerPueblo
c VarActivity
aval
  constrWriteActivity (CHXORClause XORClauseHandler
c) VarActivity
aval = XORClauseHandler -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity XORClauseHandler
c VarActivity
aval
  constrWriteActivity (CHTheory TheoryHandler
c)    VarActivity
aval = TheoryHandler -> VarActivity -> IO ()
forall a. ConstraintHandler a => a -> VarActivity -> IO ()
constrWriteActivity TheoryHandler
c VarActivity
aval

isReasonOf :: Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf :: Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
c Lit
lit = do
  LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
  if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Maybe SomeConstraintHandler
m <- Solver -> Lit -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Lit -> Lit
litVar Lit
lit)
    case Maybe SomeConstraintHandler
m of
      Maybe SomeConstraintHandler
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just SomeConstraintHandler
c2  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! SomeConstraintHandler
c SomeConstraintHandler -> SomeConstraintHandler -> Bool
forall a. Eq a => a -> a -> Bool
== SomeConstraintHandler
c2

-- To avoid heap-allocation Maybe value, it returns -1 when not found.
findForWatch :: Solver -> LitArray -> Int -> Int -> IO Int
#ifndef __GLASGOW_HASKELL__
findForWatch solver a beg end = go beg end
  where
    go :: Int -> Int -> IO Int
    go i end | i > end = return (-1)
    go i end = do
      val <- litValue s =<< readLitArray a i
      if val /= lFalse
        then return i
        else go (i+1) end
#else
{- We performed worker-wrapper transfomation manually, since the worker
   generated by GHC has type
   "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)",
   not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)".
   We want latter one to avoid heap-allocating Int value. -}
findForWatch :: Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver LitArray
a (I# Int#
beg) (I# Int#
end) = (State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit)
-> (State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
w ->
  case Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# Int#
beg Int#
end State# RealWorld
w of
    (# State# RealWorld
w2, Int#
ret #) -> (# State# RealWorld
w2, Int# -> Lit
I# Int#
ret #)
  where
    go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
    go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# Int#
i Int#
end' State# RealWorld
w | Int# -> Bool
isTrue# (Int#
i Int# -> Int# -> Int#
># Int#
end') = (# State# RealWorld
w, Int#
-1# #)
    go# Int#
i Int#
end' State# RealWorld
w =
      case IO LBool -> State# RealWorld -> (# State# RealWorld, LBool #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (Solver -> Lit -> IO LBool
litValue Solver
solver (Lit -> IO LBool) -> IO Lit -> IO LBool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LitArray -> Lit -> IO Lit
readLitArray LitArray
a (Int# -> Lit
I# Int#
i)) State# RealWorld
w of
        (# State# RealWorld
w2, LBool
val #) ->
          if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse
            then (# State# RealWorld
w2, Int#
i #)
            else Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# (Int#
i Int# -> Int# -> Int#
+# Int#
1#) Int#
end' State# RealWorld
w2

    unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO State# RealWorld -> (# State# RealWorld, a #)
f) = State# RealWorld -> (# State# RealWorld, a #)
f
#endif

-- To avoid heap-allocating Maybe value, it returns -1 when not found.
findForWatch2 :: Solver -> LitArray -> Int -> Int -> IO Int
#ifndef __GLASGOW_HASKELL__
findForWatch2 solver a beg end = go beg end
  where
    go :: Int -> Int -> IO Int
    go i end | i > end = return (-1)
    go i end = do
      val <- litValue s =<< readLitArray a i
      if val == lUndef
        then return i
        else go (i+1) end
#else
{- We performed worker-wrapper transfomation manually, since the worker
   generated by GHC has type
   "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)",
   not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)".
   We want latter one to avoid heap-allocating Int value. -}
findForWatch2 :: Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch2 Solver
solver LitArray
a (I# Int#
beg) (I# Int#
end) = (State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit)
-> (State# RealWorld -> (# State# RealWorld, Lit #)) -> IO Lit
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
w ->
  case Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# Int#
beg Int#
end State# RealWorld
w of
    (# State# RealWorld
w2, Int#
ret #) -> (# State# RealWorld
w2, Int# -> Lit
I# Int#
ret #)
  where
    go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
    go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# Int#
i Int#
end State# RealWorld
w | Int# -> Bool
isTrue# (Int#
i Int# -> Int# -> Int#
># Int#
end) = (# State# RealWorld
w, Int#
-1# #)
    go# Int#
i Int#
end State# RealWorld
w =
      case IO LBool -> State# RealWorld -> (# State# RealWorld, LBool #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (Solver -> Lit -> IO LBool
litValue Solver
solver (Lit -> IO LBool) -> IO Lit -> IO LBool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LitArray -> Lit -> IO Lit
readLitArray LitArray
a (Int# -> Lit
I# Int#
i)) State# RealWorld
w of
        (# State# RealWorld
w2, LBool
val #) ->
          if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef
            then (# State# RealWorld
w2, Int#
i #)
            else Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
go# (Int#
i Int# -> Int# -> Int#
+# Int#
1#) Int#
end State# RealWorld
w2

    unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO State# RealWorld -> (# State# RealWorld, a #)
f) = State# RealWorld -> (# State# RealWorld, a #)
f
#endif

{--------------------------------------------------------------------
  Clause
--------------------------------------------------------------------}

data ClauseHandler
  = ClauseHandler
  { ClauseHandler -> LitArray
claLits :: !LitArray
  , ClauseHandler -> IORef VarActivity
claActivity :: !(IORef Double)
  , ClauseHandler -> Lit
claHash :: !Int
  }

claGetSize :: ClauseHandler -> IO Int
claGetSize :: ClauseHandler -> IO Lit
claGetSize ClauseHandler
cla = LitArray -> IO Lit
getLitArraySize (ClauseHandler -> LitArray
claLits ClauseHandler
cla)

instance Eq ClauseHandler where
  == :: ClauseHandler -> ClauseHandler -> Bool
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (ClauseHandler -> LitArray)
-> ClauseHandler
-> ClauseHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClauseHandler -> LitArray
claLits

instance Hashable ClauseHandler where
  hash :: ClauseHandler -> Lit
hash = ClauseHandler -> Lit
claHash
  hashWithSalt :: Lit -> ClauseHandler -> Lit
hashWithSalt = Lit -> ClauseHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

newClauseHandler :: Clause -> Bool -> IO ClauseHandler
newClauseHandler :: [Lit] -> Bool -> IO ClauseHandler
newClauseHandler [Lit]
ls Bool
learnt = do
  LitArray
a <- [Lit] -> IO LitArray
newLitArray [Lit]
ls
  IORef VarActivity
act <- VarActivity -> IO (IORef VarActivity)
forall a. a -> IO (IORef a)
newIORef (VarActivity -> IO (IORef VarActivity))
-> VarActivity -> IO (IORef VarActivity)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then VarActivity
0 else -VarActivity
1)
  ClauseHandler -> IO ClauseHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> IORef VarActivity -> Lit -> ClauseHandler
ClauseHandler LitArray
a IORef VarActivity
act ([Lit] -> Lit
forall a. Hashable a => a -> Lit
hash [Lit]
ls))

instance ConstraintHandler ClauseHandler where
  toConstraintHandler :: ClauseHandler -> SomeConstraintHandler
toConstraintHandler = ClauseHandler -> SomeConstraintHandler
CHClause

  showConstraintHandler :: ClauseHandler -> IO [Char]
showConstraintHandler ClauseHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (ClauseHandler -> LitArray
claLits ClauseHandler
this)
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
lits)

  constrAttach :: Solver -> SomeConstraintHandler -> ClauseHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this ClauseHandler
this2 = do
    -- BCP Queue should be empty at this point.
    -- If not, duplicated propagation happens.
    Solver -> IO ()
bcpCheckEmpty Solver
solver

    Lit
size <- ClauseHandler -> IO Lit
claGetSize ClauseHandler
this2
    if Lit
size Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
0 then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Lit
size Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
1 then do
      Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
0
      Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit0 SomeConstraintHandler
this
    else do
      IORef Lit
ref <- Lit -> IO (IORef Lit)
forall a. a -> IO (IORef a)
newIORef Lit
1
      let f :: Lit -> IO Bool
f Lit
i = do
            Lit
lit_i <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
i
            LBool
val_i <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit_i
            if LBool
val_i LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse then
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do
              Lit
j <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef IORef Lit
ref
              Lit
k <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
j (Lit
size Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
              case Lit
k of
                -1 -> do
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Lit
_ -> do
                  Lit
lit_k <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
i Lit
lit_k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
k Lit
lit_i
                  IORef Lit -> Lit -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Lit
ref (Lit -> IO ()) -> Lit -> IO ()
forall a b. (a -> b) -> a -> b
$! (Lit
kLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

      Bool
b <- Lit -> IO Bool
f Lit
0
      if Bool
b then do
        Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
0
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit0 SomeConstraintHandler
this
        Bool
b2 <- Lit -> IO Bool
f Lit
1
        if Bool
b2 then do
          Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit1 SomeConstraintHandler
this
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do -- UNIT
          -- We need to watch the most recently falsified literal
          (Lit
i,Lit
_) <- ([(Lit, Lit)] -> (Lit, Lit)) -> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> (Lit, Lit)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd)) (IO [(Lit, Lit)] -> IO (Lit, Lit))
-> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
1..Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
            Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
l
            Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
            (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)
          Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
1
          Lit
liti <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
i
          LitArray -> Lit -> Lit -> IO ()
writeLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
1 Lit
liti
          LitArray -> Lit -> Lit -> IO ()
writeLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
i Lit
lit1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
liti SomeConstraintHandler
this
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit0 SomeConstraintHandler
this -- should always succeed
      else do -- CONFLICT
        [Lit]
ls <- ([(Lit, Lit)] -> [Lit]) -> IO [(Lit, Lit)] -> IO [Lit]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> Lit) -> [(Lit, Lit)] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (Lit, Lit) -> Lit
forall a b. (a, b) -> a
fst ([(Lit, Lit)] -> [Lit])
-> ([(Lit, Lit)] -> [(Lit, Lit)]) -> [(Lit, Lit)] -> [Lit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> [(Lit, Lit)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd))) (IO [(Lit, Lit)] -> IO [Lit]) -> IO [(Lit, Lit)] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
0..Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
          Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
l
          Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
          (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)
        [(Lit, Lit)] -> ((Lit, Lit) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Lit] -> [Lit] -> [(Lit, Lit)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Lit
0..] [Lit]
ls) (((Lit, Lit) -> IO ()) -> IO ()) -> ((Lit, Lit) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Lit
i,Lit
lit) -> do
          LitArray -> Lit -> Lit -> IO ()
writeLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
i Lit
lit
        Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
0
        Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
1
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit0 SomeConstraintHandler
this
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit1 SomeConstraintHandler
this
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  constrDetach :: Solver -> SomeConstraintHandler -> ClauseHandler -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this ClauseHandler
this2 = do
    Lit
size <- ClauseHandler -> IO Lit
claGetSize ClauseHandler
this2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
0
      Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
1
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Lit
lit0 SomeConstraintHandler
this
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Lit
lit1 SomeConstraintHandler
this

  constrIsLocked :: Solver -> SomeConstraintHandler -> ClauseHandler -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this ClauseHandler
this2 = do
    Lit
size <- ClauseHandler -> IO Lit
claGetSize ClauseHandler
this2
    if Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
2 then
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this2) Lit
0
      Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
lit

  constrPropagate :: Solver -> SomeConstraintHandler -> ClauseHandler -> Lit -> IO Bool
constrPropagate !Solver
solver SomeConstraintHandler
this ClauseHandler
this2 !Lit
falsifiedLit = do
    IO ()
preprocess

    !Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
    !LBool
val0 <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit0
    if LBool
val0 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
falsifiedLit SomeConstraintHandler
this
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      Lit
size <- ClauseHandler -> IO Lit
claGetSize ClauseHandler
this2
      Lit
i <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver LitArray
a Lit
2 (Lit
size Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
      case Lit
i of
        -1 -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             [Char]
str <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
this
             [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"constrPropagate: %s is unit" [Char]
str
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
falsifiedLit SomeConstraintHandler
this
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit0 SomeConstraintHandler
this
        Lit
_  -> do
          !Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
          !Lit
liti <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
1 Lit
liti
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
liti SomeConstraintHandler
this
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    where
      a :: LitArray
a = ClauseHandler -> LitArray
claLits ClauseHandler
this2

      preprocess :: IO ()
      preprocess :: IO ()
preprocess = do
        !Lit
l0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
        !Lit
l1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
        Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
l0Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
falsifiedLit Bool -> Bool -> Bool
|| Lit
l1Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
l0Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
0 Lit
l1
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
1 Lit
l0

  constrReasonOf :: Solver -> ClauseHandler -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
_ ClauseHandler
this Maybe Lit
l = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (ClauseHandler -> LitArray
claLits ClauseHandler
this)
    case Maybe Lit
l of
      Maybe Lit
Nothing -> [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
lits
      Just Lit
lit -> do
        Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
lit Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== [Lit] -> Lit
forall a. [a] -> a
head [Lit]
lits) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit] -> IO [Lit]) -> [Lit] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Lit]
forall a. [a] -> [a]
tail [Lit]
lits

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> ClauseHandler -> Lit -> IO ()
constrOnUnassigned Solver
_solver SomeConstraintHandler
_this ClauseHandler
_this2 Lit
_lit = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  isPBRepresentable :: ClauseHandler -> IO Bool
isPBRepresentable ClauseHandler
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  toPBLinAtLeast :: ClauseHandler -> IO PBLinAtLeast
toPBLinAtLeast ClauseHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (ClauseHandler -> LitArray
claLits ClauseHandler
this)
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Integer
1,Lit
l) | Lit
l <- [Lit]
lits], Integer
1)

  isSatisfied :: Solver -> ClauseHandler -> IO Bool
isSatisfied Solver
solver ClauseHandler
this = do
    Lit
n <- LitArray -> IO Lit
getLitArraySize (ClauseHandler -> LitArray
claLits ClauseHandler
this)
    (Either () () -> Bool) -> IO (Either () ()) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either () () -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either () ()) -> IO Bool) -> IO (Either () ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ExceptT () IO () -> IO (Either () ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () IO () -> IO (Either () ()))
-> ExceptT () IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$ Lit
-> (Lit -> Bool)
-> (Lit -> Lit)
-> (Lit -> ExceptT () IO ())
-> ExceptT () IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
0 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> ExceptT () IO ()) -> ExceptT () IO ())
-> (Lit -> ExceptT () IO ()) -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i -> do
      LBool
v <- IO LBool -> ExceptT () IO LBool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LBool -> ExceptT () IO LBool)
-> IO LBool -> ExceptT () IO LBool
forall a b. (a -> b) -> a -> b
$ Solver -> Lit -> IO LBool
litValue Solver
solver (Lit -> IO LBool) -> IO Lit -> IO LBool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LitArray -> Lit -> IO Lit
readLitArray (ClauseHandler -> LitArray
claLits ClauseHandler
this) Lit
i
      Bool -> ExceptT () IO () -> ExceptT () IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue) (ExceptT () IO () -> ExceptT () IO ())
-> ExceptT () IO () -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT () IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()

  constrIsProtected :: Solver -> ClauseHandler -> IO Bool
constrIsProtected Solver
_ ClauseHandler
this = do
    Lit
size <- ClauseHandler -> IO Lit
claGetSize ClauseHandler
this
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<= Lit
2

  constrReadActivity :: ClauseHandler -> IO VarActivity
constrReadActivity ClauseHandler
this = IORef VarActivity -> IO VarActivity
forall a. IORef a -> IO a
readIORef (ClauseHandler -> IORef VarActivity
claActivity ClauseHandler
this)

  constrWriteActivity :: ClauseHandler -> VarActivity -> IO ()
constrWriteActivity ClauseHandler
this VarActivity
aval = IORef VarActivity -> VarActivity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ClauseHandler -> IORef VarActivity
claActivity ClauseHandler
this) (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval

basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
this = do
  let constr :: SomeConstraintHandler
constr = ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
this
  [Lit]
lits <- LitArray -> IO [Lit]
getLits (ClauseHandler -> LitArray
claLits ClauseHandler
this)
  case [Lit]
lits of
    [] -> do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [Lit
l1] -> do
      Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l1 SomeConstraintHandler
constr
    Lit
l1:Lit
l2:[Lit]
_ -> do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
l1 SomeConstraintHandler
constr
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
l2 SomeConstraintHandler
constr
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

{--------------------------------------------------------------------
  Cardinality Constraint
--------------------------------------------------------------------}

data AtLeastHandler
  = AtLeastHandler
  { AtLeastHandler -> LitArray
atLeastLits :: !LitArray
  , AtLeastHandler -> Lit
atLeastNum :: !Int
  , AtLeastHandler -> IORef VarActivity
atLeastActivity :: !(IORef Double)
  , AtLeastHandler -> Lit
atLeastHash :: !Int
  }

instance Eq AtLeastHandler where
  == :: AtLeastHandler -> AtLeastHandler -> Bool
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (AtLeastHandler -> LitArray)
-> AtLeastHandler
-> AtLeastHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AtLeastHandler -> LitArray
atLeastLits

instance Hashable AtLeastHandler where
  hash :: AtLeastHandler -> Lit
hash = AtLeastHandler -> Lit
atLeastHash
  hashWithSalt :: Lit -> AtLeastHandler -> Lit
hashWithSalt = Lit -> AtLeastHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

newAtLeastHandler :: [Lit] -> Int -> Bool -> IO AtLeastHandler
newAtLeastHandler :: [Lit] -> Lit -> Bool -> IO AtLeastHandler
newAtLeastHandler [Lit]
ls Lit
n Bool
learnt = do
  LitArray
a <- [Lit] -> IO LitArray
newLitArray [Lit]
ls
  IORef VarActivity
act <- VarActivity -> IO (IORef VarActivity)
forall a. a -> IO (IORef a)
newIORef (VarActivity -> IO (IORef VarActivity))
-> VarActivity -> IO (IORef VarActivity)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then VarActivity
0 else -VarActivity
1)
  AtLeastHandler -> IO AtLeastHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> Lit -> IORef VarActivity -> Lit -> AtLeastHandler
AtLeastHandler LitArray
a Lit
n IORef VarActivity
act (([Lit], Lit) -> Lit
forall a. Hashable a => a -> Lit
hash ([Lit]
ls,Lit
n)))

instance ConstraintHandler AtLeastHandler where
  toConstraintHandler :: AtLeastHandler -> SomeConstraintHandler
toConstraintHandler = AtLeastHandler -> SomeConstraintHandler
CHAtLeast

  showConstraintHandler :: AtLeastHandler -> IO [Char]
showConstraintHandler AtLeastHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
lits [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" >= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Lit -> [Char]
forall a. Show a => a -> [Char]
show (AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this)

  -- FIXME: simplify implementation
  constrAttach :: Solver -> SomeConstraintHandler -> AtLeastHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this AtLeastHandler
this2 = do
    -- BCP Queue should be empty at this point.
    -- If not, duplicated propagation happens.
    Solver -> IO ()
bcpCheckEmpty Solver
solver

    let a :: LitArray
a = AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2
    Lit
m <- LitArray -> IO Lit
getLitArraySize LitArray
a
    let n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this2

    if Lit
m Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
n then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Lit
m Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
n then do
      let f :: Lit -> IO Bool
f Lit
i = do
            Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
            Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
this
      (Lit -> IO Bool) -> [Lit] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Lit -> IO Bool
f [Lit
0..Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1]
    else do -- m > n
      let f :: Lit -> Lit -> IO Bool
f !Lit
i !Lit
j
            | Lit
i Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
n = do
                -- NOT VIOLATED: n literals (0 .. n-1) are watched
                Lit
k <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver LitArray
a Lit
j (Lit
m Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
                if Lit
k Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
/= -Lit
1 then do
                  -- NOT UNIT
                  Lit
lit_n <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
n
                  Lit
lit_k <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
n Lit
lit_k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
k Lit
lit_n
                  Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit_k SomeConstraintHandler
this
                  -- n+1 literals (0 .. n) are watched.
                else do
                  -- UNIT
                  Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
0 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
                    Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
                    Bool
_ <- Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
this -- should always succeed
                    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  -- We need to watch the most recently falsified literal
                  (Lit
l,Lit
_) <- ([(Lit, Lit)] -> (Lit, Lit)) -> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> (Lit, Lit)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd)) (IO [(Lit, Lit)] -> IO (Lit, Lit))
-> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
n..Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
                    Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
                    Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"AtLeastHandler.attach: should not happen"
                    (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)
                  Lit
lit_n <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
n
                  Lit
lit_l <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
n Lit
lit_l
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
l Lit
lit_n
                  Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit_l SomeConstraintHandler
this
                  -- n+1 literals (0 .. n) are watched.
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            | Bool
otherwise = do
                Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
n Bool -> Bool -> Bool
&& Lit
n Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<= Lit
j) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Lit
lit_i <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
                LBool
val_i <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit_i
                if LBool
val_i LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse then do
                  Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit_i SomeConstraintHandler
this
                  Lit -> Lit -> IO Bool
f (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) Lit
j
                else do
                  Lit
k <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver LitArray
a Lit
j (Lit
m Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
                  if Lit
k Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
/= -Lit
1 then do
                    Lit
lit_k <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
k
                    LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit_k
                    LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
k Lit
lit_i
                    Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit_k SomeConstraintHandler
this
                    Lit -> Lit -> IO Bool
f (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) (Lit
kLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
                  else do
                    -- CONFLICT
                    -- We need to watch unassigned literals or most recently falsified literals.
                    do [(Lit, Lit)]
xs <- ([(Lit, Lit)] -> [(Lit, Lit)])
-> IO [(Lit, Lit)] -> IO [(Lit, Lit)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> [(Lit, Lit)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd))) (IO [(Lit, Lit)] -> IO [(Lit, Lit)])
-> IO [(Lit, Lit)] -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
i..Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
                         Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
                         LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
                         if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
                           Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
                           (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
lit, Lit
lv)
                         else do
                           (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
lit, Lit
forall a. Bounded a => a
maxBound)
                       [(Lit, (Lit, Lit))] -> ((Lit, (Lit, Lit)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Lit] -> [(Lit, Lit)] -> [(Lit, (Lit, Lit))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Lit
i..Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] [(Lit, Lit)]
xs) (((Lit, (Lit, Lit)) -> IO ()) -> IO ())
-> ((Lit, (Lit, Lit)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Lit
l,(Lit
lit,Lit
_lv)) -> do
                         LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
l Lit
lit
                    Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
i (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<=Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
                      Lit
lit_l <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
                      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit_l SomeConstraintHandler
this
                    -- n+1 literals (0 .. n) are watched.
                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Lit -> Lit -> IO Bool
f Lit
0 Lit
n

  constrDetach :: Solver -> SomeConstraintHandler -> AtLeastHandler -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this AtLeastHandler
this2 = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2)
    let n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Lit] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [Lit]
lits Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
0 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<=Lit
n) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
i -> do
        Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2) Lit
i
        Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Lit
lit SomeConstraintHandler
this

  constrIsLocked :: Solver -> SomeConstraintHandler -> AtLeastHandler -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this AtLeastHandler
this2 = do
    Lit
size <- LitArray -> IO Lit
getLitArraySize (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2)
    let n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this2
        loop :: Lit -> IO Bool
loop Lit
i
          | Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
> Lit
n = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          | Bool
otherwise = do
              Lit
l <- LitArray -> Lit -> IO Lit
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2) Lit
i
              Bool
b <- Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
l
              if Bool
b then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Lit -> IO Bool
loop (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
    if Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1 then
      Lit -> IO Bool
loop Lit
0
    else
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  constrPropagate :: Solver -> SomeConstraintHandler -> AtLeastHandler -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this AtLeastHandler
this2 Lit
falsifiedLit = do
    IO ()
preprocess

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lit
litn <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
n
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Lit
litn Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"AtLeastHandler.constrPropagate: should not happen"

    Lit
m <- LitArray -> IO Lit
getLitArraySize LitArray
a
    Lit
i <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch Solver
solver LitArray
a (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) (Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1)
    case Lit
i of
      -1 -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Char]
str <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
this
          [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"constrPropagate: %s is unit" [Char]
str
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
falsifiedLit SomeConstraintHandler
this
        let loop :: Int -> IO Bool
            loop :: Lit -> IO Bool
loop Lit
j
              | Lit
j Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
n = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
              | Bool
otherwise = do
                  Lit
litj <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
j
                  Bool
ret2 <- Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
litj SomeConstraintHandler
this
                  if Bool
ret2
                    then Lit -> IO Bool
loop (Lit
jLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
                    else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Lit -> IO Bool
loop Lit
0
      Lit
_ -> do
        Lit
liti <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
        Lit
litn <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
n
        LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
litn
        LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
n Lit
liti
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
liti SomeConstraintHandler
this
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    where
      a :: LitArray
a = AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this2
      n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this2

      preprocess :: IO ()
      preprocess :: IO ()
preprocess = Lit -> IO ()
loop Lit
0
        where
          loop :: Int -> IO ()
          loop :: Lit -> IO ()
loop Lit
i
            | Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
n = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise = do
              Lit
li <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
              if (Lit
li Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
/= Lit
falsifiedLit) then
                Lit -> IO ()
loop (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
              else do
                Lit
ln <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
n
                LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
n Lit
li
                LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
ln

  constrReasonOf :: Solver -> AtLeastHandler -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver AtLeastHandler
this Maybe Lit
concl = do
    Lit
m <- LitArray -> IO Lit
getLitArraySize (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
    let n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this
    [Lit]
falsifiedLits <- (Lit -> IO Lit) -> [Lit] -> IO [Lit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LitArray -> Lit -> IO Lit
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)) [Lit
n..Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] -- drop first n elements
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit]
falsifiedLits ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
lit -> do
        LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"AtLeastHandler.constrReasonOf: %d is %s (lFalse expected)" Lit
lit (LBool -> [Char]
forall a. Show a => a -> [Char]
show LBool
val)
    case Maybe Lit
concl of
      Maybe Lit
Nothing -> do
        let go :: Int -> IO Lit
            go :: Lit -> IO Lit
go Lit
i
              | Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
n = [Char] -> IO Lit
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> IO Lit) -> [Char] -> IO Lit
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"AtLeastHandler.constrReasonOf: cannot find falsified literal in first %d elements" Lit
n
              | Bool
otherwise = do
                  Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this) Lit
i
                  LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
                  if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse
                  then Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
lit
                  else Lit -> IO Lit
go (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
        Lit
lit <- Lit -> IO Lit
go Lit
0
        [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit] -> IO [Lit]) -> [Lit] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ Lit
lit Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit]
falsifiedLits
      Just Lit
lit -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Lit]
es <- LitArray -> IO [Lit]
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Lit
lit Lit -> [Lit] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Lit -> [Lit] -> [Lit]
forall a. Lit -> [a] -> [a]
take Lit
n [Lit]
es) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"AtLeastHandler.constrReasonOf: cannot find %d in first %d elements" Lit
n
        [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
falsifiedLits

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> AtLeastHandler -> Lit -> IO ()
constrOnUnassigned Solver
_solver SomeConstraintHandler
_this AtLeastHandler
_this2 Lit
_lit = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  isPBRepresentable :: AtLeastHandler -> IO Bool
isPBRepresentable AtLeastHandler
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  toPBLinAtLeast :: AtLeastHandler -> IO PBLinAtLeast
toPBLinAtLeast AtLeastHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Integer
1,Lit
l) | Lit
l <- [Lit]
lits], Lit -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this))

  isSatisfied :: Solver -> AtLeastHandler -> IO Bool
isSatisfied Solver
solver AtLeastHandler
this = do
    Lit
m <- LitArray -> IO Lit
getLitArraySize (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
    (Either () Lit -> Bool) -> IO (Either () Lit) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either () Lit -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either () Lit) -> IO Bool) -> IO (Either () Lit) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ExceptT () IO Lit -> IO (Either () Lit)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () IO Lit -> IO (Either () Lit))
-> ExceptT () IO Lit -> IO (Either () Lit)
forall a b. (a -> b) -> a -> b
$ Lit
-> Lit
-> Lit
-> (Lit -> Lit -> ExceptT () IO Lit)
-> ExceptT () IO Lit
forall a (m :: * -> *) b.
(Num a, Eq a, Monad m) =>
a -> a -> b -> (b -> a -> m b) -> m b
numLoopState Lit
0 (Lit
mLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1) Lit
0 ((Lit -> Lit -> ExceptT () IO Lit) -> ExceptT () IO Lit)
-> (Lit -> Lit -> ExceptT () IO Lit) -> ExceptT () IO Lit
forall a b. (a -> b) -> a -> b
$ \(!Lit
n) Lit
i -> do
      LBool
v <- IO LBool -> ExceptT () IO LBool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LBool -> ExceptT () IO LBool)
-> IO LBool -> ExceptT () IO LBool
forall a b. (a -> b) -> a -> b
$ Solver -> Lit -> IO LBool
litValue Solver
solver (Lit -> IO LBool) -> IO Lit -> IO LBool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LitArray -> Lit -> IO Lit
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this) Lit
i
      if LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lTrue then do
        Lit -> ExceptT () IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
n
      else do
        let n' :: Lit
n' = Lit
n Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+ Lit
1
        Bool -> ExceptT () IO () -> ExceptT () IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
n' Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this) (ExceptT () IO () -> ExceptT () IO ())
-> ExceptT () IO () -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT () IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()
        Lit -> ExceptT () IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return Lit
n'

  constrReadActivity :: AtLeastHandler -> IO VarActivity
constrReadActivity AtLeastHandler
this = IORef VarActivity -> IO VarActivity
forall a. IORef a -> IO a
readIORef (AtLeastHandler -> IORef VarActivity
atLeastActivity AtLeastHandler
this)

  constrWriteActivity :: AtLeastHandler -> VarActivity -> IO ()
constrWriteActivity AtLeastHandler
this VarActivity
aval = IORef VarActivity -> VarActivity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AtLeastHandler -> IORef VarActivity
atLeastActivity AtLeastHandler
this) (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval

basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool
basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool
basicAttachAtLeastHandler Solver
solver AtLeastHandler
this = do
  [Lit]
lits <- LitArray -> IO [Lit]
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
  let m :: Lit
m = [Lit] -> Lit
forall (t :: * -> *) a. Foldable t => t a -> Lit
length [Lit]
lits
      n :: Lit
n = AtLeastHandler -> Lit
atLeastNum AtLeastHandler
this
      constr :: SomeConstraintHandler
constr = AtLeastHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler AtLeastHandler
this
  if Lit
m Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
n then do
    Solver -> IO ()
markBad Solver
solver
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else if Lit
m Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
n then do
    (Lit -> IO Bool) -> [Lit] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (\Lit
l -> Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l SomeConstraintHandler
constr) [Lit]
lits
  else do -- m > n
    [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Lit -> [Lit] -> [Lit]
forall a. Lit -> [a] -> [a]
take (Lit
nLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) [Lit]
lits) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
l -> Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
l SomeConstraintHandler
constr
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

{--------------------------------------------------------------------
  Pseudo Boolean Constraint
--------------------------------------------------------------------}

newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
ts Integer
degree Bool
learnt = do
  PBHandlerType
config <- Config -> PBHandlerType
configPBHandlerType (Config -> PBHandlerType) -> IO Config -> IO PBHandlerType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  case PBHandlerType
config of
    PBHandlerType
PBHandlerTypeCounter -> do
      PBHandlerCounter
c <- PBLinSum -> Integer -> Bool -> IO PBHandlerCounter
newPBHandlerCounter PBLinSum
ts Integer
degree Bool
learnt
      SomeConstraintHandler -> IO SomeConstraintHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (PBHandlerCounter -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler PBHandlerCounter
c)
    PBHandlerType
PBHandlerTypePueblo -> do
      PBHandlerPueblo
c <- PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo
newPBHandlerPueblo PBLinSum
ts Integer
degree Bool
learnt
      SomeConstraintHandler -> IO SomeConstraintHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (PBHandlerPueblo -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler PBHandlerPueblo
c)

newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted Solver
solver PBLinSum
lhs Integer
rhs Bool
learnt = do
  case PBLinAtLeast -> Maybe ([Lit], Lit)
pbToAtLeast (PBLinSum
lhs,Integer
rhs) of
    Maybe ([Lit], Lit)
Nothing -> Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
lhs Integer
rhs Bool
learnt
    Just ([Lit]
lhs2, Lit
rhs2) -> do
      if Lit
rhs2 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
/= Lit
1 then do
        AtLeastHandler
h <- [Lit] -> Lit -> Bool -> IO AtLeastHandler
newAtLeastHandler [Lit]
lhs2 Lit
rhs2 Bool
learnt
        SomeConstraintHandler -> IO SomeConstraintHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> IO SomeConstraintHandler)
-> SomeConstraintHandler -> IO SomeConstraintHandler
forall a b. (a -> b) -> a -> b
$ AtLeastHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler AtLeastHandler
h
      else do
        ClauseHandler
h <- [Lit] -> Bool -> IO ClauseHandler
newClauseHandler [Lit]
lhs2 Bool
learnt
        SomeConstraintHandler -> IO SomeConstraintHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> IO SomeConstraintHandler)
-> SomeConstraintHandler -> IO SomeConstraintHandler
forall a b. (a -> b) -> a -> b
$ ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
h

pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool
pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool
pbOverSAT Solver
solver (PBLinSum
lhs, Integer
rhs) = do
  [Integer]
ss <- PBLinSum -> (PBLinTerm -> IO Integer) -> IO [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs ((PBLinTerm -> IO Integer) -> IO [Integer])
-> (PBLinTerm -> IO Integer) -> IO [Integer]
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
l) -> do
    LBool
v <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
    if LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse
      then Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
c
      else Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
ss Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
rhs

pbToAtLeast :: PBLinAtLeast -> Maybe AtLeast
pbToAtLeast :: PBLinAtLeast -> Maybe ([Lit], Lit)
pbToAtLeast (PBLinSum
lhs, Integer
rhs) = do
  let cs :: [Integer]
cs = [Integer
c | (Integer
c,Lit
_) <- PBLinSum
lhs]
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Set Integer -> Lit
forall a. Set a -> Lit
Set.size ([Integer] -> Set Integer
forall a. Ord a => [a] -> Set a
Set.fromList [Integer]
cs) Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
1
  let c :: Integer
c = [Integer] -> Integer
forall a. [a] -> a
head [Integer]
cs
  ([Lit], Lit) -> Maybe ([Lit], Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Lit], Lit) -> Maybe ([Lit], Lit))
-> ([Lit], Lit) -> Maybe ([Lit], Lit)
forall a b. (a -> b) -> a -> b
$ ((PBLinTerm -> Lit) -> PBLinSum -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map PBLinTerm -> Lit
forall a b. (a, b) -> b
snd PBLinSum
lhs, Integer -> Lit
forall a. Num a => Integer -> a
fromInteger ((Integer
rhsInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
cInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
c))

pbToClause :: PBLinAtLeast -> Maybe Clause
pbToClause :: PBLinAtLeast -> Maybe [Lit]
pbToClause PBLinAtLeast
pb = do
  ([Lit]
lhs, Lit
rhs) <- PBLinAtLeast -> Maybe ([Lit], Lit)
pbToAtLeast PBLinAtLeast
pb
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Lit
rhs Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
1
  [Lit] -> Maybe [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
lhs

{--------------------------------------------------------------------
  Pseudo Boolean Constraint (Counter)
--------------------------------------------------------------------}

data PBHandlerCounter
  = PBHandlerCounter
  { PBHandlerCounter -> PBLinSum
pbTerms    :: !PBLinSum -- sorted in the decending order on coefficients.
  , PBHandlerCounter -> Integer
pbDegree   :: !Integer
  , PBHandlerCounter -> LitMap Integer
pbCoeffMap :: !(LitMap Integer)
  , PBHandlerCounter -> Integer
pbMaxSlack :: !Integer
  , PBHandlerCounter -> IORef Integer
pbSlack    :: !(IORef Integer)
  , PBHandlerCounter -> IORef VarActivity
pbActivity :: !(IORef Double)
  , PBHandlerCounter -> Lit
pbHash     :: !Int
  }

instance Eq PBHandlerCounter where
  == :: PBHandlerCounter -> PBHandlerCounter -> Bool
(==) = IORef Integer -> IORef Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IORef Integer -> IORef Integer -> Bool)
-> (PBHandlerCounter -> IORef Integer)
-> PBHandlerCounter
-> PBHandlerCounter
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBHandlerCounter -> IORef Integer
pbSlack

instance Hashable PBHandlerCounter where
  hash :: PBHandlerCounter -> Lit
hash = PBHandlerCounter -> Lit
pbHash
  hashWithSalt :: Lit -> PBHandlerCounter -> Lit
hashWithSalt = Lit -> PBHandlerCounter -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter
newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter
newPBHandlerCounter PBLinSum
ts Integer
degree Bool
learnt = do
  let ts' :: PBLinSum
ts' = (PBLinTerm -> PBLinTerm -> Ordering) -> PBLinSum -> PBLinSum
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Integer -> Integer -> Ordering) -> Integer -> Integer -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> (PBLinTerm -> Integer) -> PBLinTerm -> PBLinTerm -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBLinTerm -> Integer
forall a b. (a, b) -> a
fst) PBLinSum
ts
      slack :: Integer
slack = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PBLinTerm -> Integer) -> PBLinSum -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map PBLinTerm -> Integer
forall a b. (a, b) -> a
fst PBLinSum
ts) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
degree
      m :: LitMap Integer
m = [(Lit, Integer)] -> LitMap Integer
forall a. [(Lit, a)] -> IntMap a
IM.fromList [(Lit
l,Integer
c) | (Integer
c,Lit
l) <- PBLinSum
ts]
  IORef Integer
s <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
slack
  IORef VarActivity
act <- VarActivity -> IO (IORef VarActivity)
forall a. a -> IO (IORef a)
newIORef (VarActivity -> IO (IORef VarActivity))
-> VarActivity -> IO (IORef VarActivity)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then VarActivity
0 else -VarActivity
1)
  PBHandlerCounter -> IO PBHandlerCounter
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
-> Integer
-> LitMap Integer
-> Integer
-> IORef Integer
-> IORef VarActivity
-> Lit
-> PBHandlerCounter
PBHandlerCounter PBLinSum
ts' Integer
degree LitMap Integer
m Integer
slack IORef Integer
s IORef VarActivity
act (PBLinAtLeast -> Lit
forall a. Hashable a => a -> Lit
hash (PBLinSum
ts,Integer
degree)))

instance ConstraintHandler PBHandlerCounter where
  toConstraintHandler :: PBHandlerCounter -> SomeConstraintHandler
toConstraintHandler = PBHandlerCounter -> SomeConstraintHandler
CHPBCounter

  showConstraintHandler :: PBHandlerCounter -> IO [Char]
showConstraintHandler PBHandlerCounter
this = do
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ PBLinSum -> [Char]
forall a. Show a => a -> [Char]
show (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" >= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (PBHandlerCounter -> Integer
pbDegree PBHandlerCounter
this)

  constrAttach :: Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerCounter
this2 = do
    -- BCP queue should be empty at this point.
    -- It is important for calculating slack.
    Solver -> IO ()
bcpCheckEmpty Solver
solver
    Integer
s <- ([Integer] -> Integer) -> IO [Integer] -> IO Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IO [Integer] -> IO Integer) -> IO [Integer] -> IO Integer
forall a b. (a -> b) -> a -> b
$ PBLinSum -> (PBLinTerm -> IO Integer) -> IO [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) ((PBLinTerm -> IO Integer) -> IO [Integer])
-> (PBLinTerm -> IO Integer) -> IO [Integer]
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
l) -> do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
l SomeConstraintHandler
this
      LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
      if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
        Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Lit
l
        Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
      else do
        Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
c
    let slack :: Integer
slack = Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- PBHandlerCounter -> Integer
pbDegree PBHandlerCounter
this2
    IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> IO ()) -> Integer -> IO ()
forall a b. (a -> b) -> a -> b
$! Integer
slack
    if Integer
slack Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      ((PBLinTerm -> IO Bool) -> PBLinSum -> IO Bool)
-> PBLinSum -> (PBLinTerm -> IO Bool) -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PBLinTerm -> IO Bool) -> PBLinSum -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) ((PBLinTerm -> IO Bool) -> IO Bool)
-> (PBLinTerm -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
l) -> do
        LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
        if Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
slack Bool -> Bool -> Bool
&& LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then do
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l SomeConstraintHandler
this
        else
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  constrDetach :: Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerCounter
this2 = do
    PBLinSum -> (PBLinTerm -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) ((PBLinTerm -> IO ()) -> IO ()) -> (PBLinTerm -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Lit
l) -> do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Lit
l SomeConstraintHandler
this

  constrIsLocked :: Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerCounter
this2 = do
    (PBLinTerm -> IO Bool) -> PBLinSum -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM (\(Integer
_,Lit
l) -> Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
l) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2)

  constrPropagate :: Solver
-> SomeConstraintHandler -> PBHandlerCounter -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this PBHandlerCounter
this2 Lit
falsifiedLit = do
    Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
falsifiedLit SomeConstraintHandler
this
    let c :: Integer
c = PBHandlerCounter -> LitMap Integer
pbCoeffMap PBHandlerCounter
this2 LitMap Integer -> Lit -> Integer
forall a. IntMap a -> Lit -> a
IM.! Lit
falsifiedLit
    IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
c)
    Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Lit
falsifiedLit
    Integer
s <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2)
    if Integer
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      PBLinSum -> (PBLinTerm -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((PBLinTerm -> Bool) -> PBLinSum -> PBLinSum
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Integer
c1,Lit
_) -> Integer
c1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
s) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2)) ((PBLinTerm -> IO ()) -> IO ()) -> (PBLinTerm -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Lit
l1) -> do
        LBool
v <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l1
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l1 SomeConstraintHandler
this
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  constrReasonOf :: Solver -> PBHandlerCounter -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver PBHandlerCounter
this Maybe Lit
l = do
    case Maybe Lit
l of
      Maybe Lit
Nothing -> do
        let p :: p -> m Bool
p p
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
forall (m :: * -> *) p. Monad m => p -> m Bool
p (PBHandlerCounter -> Integer
pbMaxSlack PBHandlerCounter
this) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this)
      Just Lit
lit -> do
        Lit
idx <- Solver -> Lit -> IO Lit
varAssignNo Solver
solver (Lit -> Lit
litVar Lit
lit)
        -- PB制約の場合には複数回unitになる可能性があり、
        -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要
        let p :: Lit -> IO Bool
p Lit
lit2 =do
              Lit
idx2 <- Solver -> Lit -> IO Lit
varAssignNo Solver
solver (Lit -> Lit
litVar Lit
lit2)
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Lit
idx2 Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
idx
        let c :: Integer
c = PBHandlerCounter -> LitMap Integer
pbCoeffMap PBHandlerCounter
this LitMap Integer -> Lit -> Integer
forall a. IntMap a -> Lit -> a
IM.! Lit
lit
        (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
p (PBHandlerCounter -> Integer
pbMaxSlack PBHandlerCounter
this Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this)
    where
      {-# INLINE f #-}
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
p Integer
s PBLinSum
xs = Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs []
        where
          go :: Integer -> PBLinSum -> [Lit] -> IO [Lit]
          go :: Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
_ [Lit]
ret | Integer
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
ret
          go Integer
_ [] [Lit]
_ = [Char] -> IO [Lit]
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"PBHandlerCounter.constrReasonOf: should not happen"
          go Integer
s ((Integer
c,Lit
lit):PBLinSum
xs) [Lit]
ret = do
            LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
            if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
              Bool
b <- Lit -> IO Bool
p Lit
lit
              if Bool
b
              then Integer -> PBLinSum -> [Lit] -> IO [Lit]
go (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) PBLinSum
xs (Lit
litLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
ret)
              else Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs [Lit]
ret
            else do
              Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs [Lit]
ret

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> PBHandlerCounter -> Lit -> IO ()
constrOnUnassigned Solver
_solver SomeConstraintHandler
_this PBHandlerCounter
this2 Lit
lit = do
    let c :: Integer
c = PBHandlerCounter -> LitMap Integer
pbCoeffMap PBHandlerCounter
this2 LitMap Integer -> Lit -> Integer
forall a. IntMap a -> Lit -> a
IM.! (- Lit
lit)
    IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
c)

  isPBRepresentable :: PBHandlerCounter -> IO Bool
isPBRepresentable PBHandlerCounter
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  toPBLinAtLeast :: PBHandlerCounter -> IO PBLinAtLeast
toPBLinAtLeast PBHandlerCounter
this = do
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this, PBHandlerCounter -> Integer
pbDegree PBHandlerCounter
this)

  isSatisfied :: Solver -> PBHandlerCounter -> IO Bool
isSatisfied Solver
solver PBHandlerCounter
this = do
    [Integer]
xs <- PBLinSum -> (PBLinTerm -> IO Integer) -> IO [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this) ((PBLinTerm -> IO Integer) -> IO [Integer])
-> (PBLinTerm -> IO Integer) -> IO [Integer]
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
l) -> do
      LBool
v <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
      if LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue
        then Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
c
        else Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
xs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerCounter -> Integer
pbDegree PBHandlerCounter
this

  constrWeight :: Solver -> PBHandlerCounter -> IO VarActivity
constrWeight Solver
_ PBHandlerCounter
_ = VarActivity -> IO VarActivity
forall (m :: * -> *) a. Monad m => a -> m a
return VarActivity
0.5

  constrReadActivity :: PBHandlerCounter -> IO VarActivity
constrReadActivity PBHandlerCounter
this = IORef VarActivity -> IO VarActivity
forall a. IORef a -> IO a
readIORef (PBHandlerCounter -> IORef VarActivity
pbActivity PBHandlerCounter
this)

  constrWriteActivity :: PBHandlerCounter -> VarActivity -> IO ()
constrWriteActivity PBHandlerCounter
this VarActivity
aval = IORef VarActivity -> VarActivity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerCounter -> IORef VarActivity
pbActivity PBHandlerCounter
this) (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval

{--------------------------------------------------------------------
  Pseudo Boolean Constraint (Pueblo)
--------------------------------------------------------------------}

data PBHandlerPueblo
  = PBHandlerPueblo
  { PBHandlerPueblo -> PBLinSum
puebloTerms     :: !PBLinSum
  , PBHandlerPueblo -> Integer
puebloDegree    :: !Integer
  , PBHandlerPueblo -> Integer
puebloMaxSlack  :: !Integer
  , PBHandlerPueblo -> IORef LitSet
puebloWatches   :: !(IORef LitSet)
  , PBHandlerPueblo -> IORef Integer
puebloWatchSum  :: !(IORef Integer)
  , PBHandlerPueblo -> IORef VarActivity
puebloActivity  :: !(IORef Double)
  , PBHandlerPueblo -> Lit
puebloHash      :: !Int
  }

instance Eq PBHandlerPueblo where
  == :: PBHandlerPueblo -> PBHandlerPueblo -> Bool
(==) = IORef Integer -> IORef Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IORef Integer -> IORef Integer -> Bool)
-> (PBHandlerPueblo -> IORef Integer)
-> PBHandlerPueblo
-> PBHandlerPueblo
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBHandlerPueblo -> IORef Integer
puebloWatchSum

instance Hashable PBHandlerPueblo where
  hash :: PBHandlerPueblo -> Lit
hash = PBHandlerPueblo -> Lit
puebloHash
  hashWithSalt :: Lit -> PBHandlerPueblo -> Lit
hashWithSalt = Lit -> PBHandlerPueblo -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

puebloAMax :: PBHandlerPueblo -> Integer
puebloAMax :: PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this =
  case PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this of
    (Integer
c,Lit
_):PBLinSum
_ -> Integer
c
    [] -> Integer
0 -- should not happen?

newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo
newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo
newPBHandlerPueblo PBLinSum
ts Integer
degree Bool
learnt = do
  let ts' :: PBLinSum
ts' = (PBLinTerm -> PBLinTerm -> Ordering) -> PBLinSum -> PBLinSum
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Integer -> Integer -> Ordering) -> Integer -> Integer -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> (PBLinTerm -> Integer) -> PBLinTerm -> PBLinTerm -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBLinTerm -> Integer
forall a b. (a, b) -> a
fst) PBLinSum
ts
      slack :: Integer
slack = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (Integer
c,Lit
_) <- PBLinSum
ts'] Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
degree
  IORef LitSet
ws   <- LitSet -> IO (IORef LitSet)
forall a. a -> IO (IORef a)
newIORef LitSet
IS.empty
  IORef Integer
wsum <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef VarActivity
act  <- VarActivity -> IO (IORef VarActivity)
forall a. a -> IO (IORef a)
newIORef (VarActivity -> IO (IORef VarActivity))
-> VarActivity -> IO (IORef VarActivity)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then VarActivity
0 else -VarActivity
1)
  PBHandlerPueblo -> IO PBHandlerPueblo
forall (m :: * -> *) a. Monad m => a -> m a
return (PBHandlerPueblo -> IO PBHandlerPueblo)
-> PBHandlerPueblo -> IO PBHandlerPueblo
forall a b. (a -> b) -> a -> b
$ PBLinSum
-> Integer
-> Integer
-> IORef LitSet
-> IORef Integer
-> IORef VarActivity
-> Lit
-> PBHandlerPueblo
PBHandlerPueblo PBLinSum
ts' Integer
degree Integer
slack IORef LitSet
ws IORef Integer
wsum IORef VarActivity
act (PBLinAtLeast -> Lit
forall a. Hashable a => a -> Lit
hash (PBLinSum
ts,Integer
degree))

puebloGetWatchSum :: PBHandlerPueblo -> IO Integer
puebloGetWatchSum :: PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
pb = IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef Integer
puebloWatchSum PBHandlerPueblo
pb)

puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloWatch :: Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloWatch Solver
solver SomeConstraintHandler
constr !PBHandlerPueblo
pb (Integer
c, Lit
lit) = do
  Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Lit
lit SomeConstraintHandler
constr
  IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
pb) (Lit -> LitSet -> LitSet
IS.insert Lit
lit)
  IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef Integer
puebloWatchSum PBHandlerPueblo
pb) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c)

puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloUnwatch Solver
_solver PBHandlerPueblo
pb (Integer
c, Lit
lit) = do
  IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
pb) (Lit -> LitSet -> LitSet
IS.delete Lit
lit)
  IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef Integer
puebloWatchSum PBHandlerPueblo
pb) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
c)

instance ConstraintHandler PBHandlerPueblo where
  toConstraintHandler :: PBHandlerPueblo -> SomeConstraintHandler
toConstraintHandler = PBHandlerPueblo -> SomeConstraintHandler
CHPBPueblo

  showConstraintHandler :: PBHandlerPueblo -> IO [Char]
showConstraintHandler PBHandlerPueblo
this = do
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ PBLinSum -> [Char]
forall a. Show a => a -> [Char]
show (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" >= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this)

  constrAttach :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 = do
    Solver -> IO ()
bcpCheckEmpty Solver
solver
    Bool
ret <- Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
puebloPropagate Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2

    -- register to watch recently falsified literals to recover
    -- "WatchSum >= puebloDegree this + puebloAMax this" when backtrack is performed.
    Integer
wsum <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
wsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let f :: IntMap (a, Lit) -> (a, Lit) -> IO (IntMap (a, Lit))
f IntMap (a, Lit)
m tm :: (a, Lit)
tm@(a
_,Lit
lit) = do
            LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
            if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
              Lit
idx <- Solver -> Lit -> IO Lit
varAssignNo Solver
solver (Lit -> Lit
litVar Lit
lit)
              IntMap (a, Lit) -> IO (IntMap (a, Lit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> (a, Lit) -> IntMap (a, Lit) -> IntMap (a, Lit)
forall a. Lit -> a -> IntMap a -> IntMap a
IM.insert Lit
idx (a, Lit)
tm IntMap (a, Lit)
m)
            else
              IntMap (a, Lit) -> IO (IntMap (a, Lit))
forall (m :: * -> *) a. Monad m => a -> m a
return IntMap (a, Lit)
m
      PBLinSum
xs <- (IntMap PBLinTerm -> PBLinSum)
-> IO (IntMap PBLinTerm) -> IO PBLinSum
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, PBLinTerm) -> PBLinTerm) -> [(Lit, PBLinTerm)] -> PBLinSum
forall a b. (a -> b) -> [a] -> [b]
map (Lit, PBLinTerm) -> PBLinTerm
forall a b. (a, b) -> b
snd ([(Lit, PBLinTerm)] -> PBLinSum)
-> (IntMap PBLinTerm -> [(Lit, PBLinTerm)])
-> IntMap PBLinTerm
-> PBLinSum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap PBLinTerm -> [(Lit, PBLinTerm)]
forall a. IntMap a -> [(Lit, a)]
IM.toDescList) (IO (IntMap PBLinTerm) -> IO PBLinSum)
-> IO (IntMap PBLinTerm) -> IO PBLinSum
forall a b. (a -> b) -> a -> b
$ (IntMap PBLinTerm -> PBLinTerm -> IO (IntMap PBLinTerm))
-> IntMap PBLinTerm -> PBLinSum -> IO (IntMap PBLinTerm)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM IntMap PBLinTerm -> PBLinTerm -> IO (IntMap PBLinTerm)
forall a. IntMap (a, Lit) -> (a, Lit) -> IO (IntMap (a, Lit))
f IntMap PBLinTerm
forall a. IntMap a
IM.empty (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this2)
      let g :: Integer -> PBLinSum -> IO ()
g !Integer
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          g !Integer
s ((Integer
c,Lit
l):PBLinSum
ts) = do
            Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Lit
l
            if Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2 then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else Integer -> PBLinSum -> IO ()
g (Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c) PBLinSum
ts
      Integer -> PBLinSum -> IO ()
g Integer
wsum PBLinSum
xs

    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ret

  constrDetach :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 = do
    LitSet
ws <- IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this2)
    [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LitSet -> [Lit]
IS.toList LitSet
ws) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Lit
l SomeConstraintHandler
this

  constrIsLocked :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 = do
    (PBLinTerm -> IO Bool) -> PBLinSum -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM (\(Integer
_,Lit
l) -> Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
l) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this2)

  constrPropagate :: Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> Lit -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 Lit
falsifiedLit = do
    let t :: PBLinTerm
t = Maybe PBLinTerm -> PBLinTerm
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe PBLinTerm -> PBLinTerm) -> Maybe PBLinTerm -> PBLinTerm
forall a b. (a -> b) -> a -> b
$ (PBLinTerm -> Bool) -> PBLinSum -> Maybe PBLinTerm
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Lit
l) -> Lit
lLit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
==Lit
falsifiedLit) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this2)
    Solver -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloUnwatch Solver
solver PBHandlerPueblo
this2 PBLinTerm
t
    Bool
ret <- Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
puebloPropagate Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2
    Integer
wsum <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
wsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Solver -> SomeConstraintHandler -> Lit -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Lit
falsifiedLit
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ret

  constrReasonOf :: Solver -> PBHandlerPueblo -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver PBHandlerPueblo
this Maybe Lit
l = do
    case Maybe Lit
l of
      Maybe Lit
Nothing -> do
        let p :: p -> m Bool
p p
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
forall (m :: * -> *) p. Monad m => p -> m Bool
p (PBHandlerPueblo -> Integer
puebloMaxSlack PBHandlerPueblo
this) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)
      Just Lit
lit -> do
        Lit
idx <- Solver -> Lit -> IO Lit
varAssignNo Solver
solver (Lit -> Lit
litVar Lit
lit)
        -- PB制約の場合には複数回unitになる可能性があり、
        -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要
        let p :: Lit -> IO Bool
p Lit
lit2 =do
              Lit
idx2 <- Solver -> Lit -> IO Lit
varAssignNo Solver
solver (Lit -> Lit
litVar Lit
lit2)
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Lit
idx2 Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
idx
        let c :: Integer
c = PBLinTerm -> Integer
forall a b. (a, b) -> a
fst (PBLinTerm -> Integer) -> PBLinTerm -> Integer
forall a b. (a -> b) -> a -> b
$ Maybe PBLinTerm -> PBLinTerm
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe PBLinTerm -> PBLinTerm) -> Maybe PBLinTerm -> PBLinTerm
forall a b. (a -> b) -> a -> b
$ (PBLinTerm -> Bool) -> PBLinSum -> Maybe PBLinTerm
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Lit
l) -> Lit
l Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
lit) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)
        (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
p (PBHandlerPueblo -> Integer
puebloMaxSlack PBHandlerPueblo
this Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)
    where
      {-# INLINE f #-}
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
f Lit -> IO Bool
p Integer
s PBLinSum
xs = Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs []
        where
          go :: Integer -> PBLinSum -> [Lit] -> IO [Lit]
          go :: Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
_ [Lit]
ret | Integer
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
ret
          go Integer
_ [] [Lit]
_ = [Char] -> IO [Lit]
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"PBHandlerPueblo.constrReasonOf: should not happen"
          go Integer
s ((Integer
c,Lit
lit):PBLinSum
xs) [Lit]
ret = do
            LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
            if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
              Bool
b <- Lit -> IO Bool
p Lit
lit
              if Bool
b
              then Integer -> PBLinSum -> [Lit] -> IO [Lit]
go (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) PBLinSum
xs (Lit
litLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
ret)
              else Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs [Lit]
ret
            else do
              Integer -> PBLinSum -> [Lit] -> IO [Lit]
go Integer
s PBLinSum
xs [Lit]
ret

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> Lit -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 Lit
lit = do
    let t :: PBLinTerm
t = Maybe PBLinTerm -> PBLinTerm
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe PBLinTerm -> PBLinTerm) -> Maybe PBLinTerm -> PBLinTerm
forall a b. (a -> b) -> a -> b
$ (PBLinTerm -> Bool) -> PBLinSum -> Maybe PBLinTerm
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Lit
l) -> Lit
l Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== - Lit
lit) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this2)
    Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloWatch Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 PBLinTerm
t

  isPBRepresentable :: PBHandlerPueblo -> IO Bool
isPBRepresentable PBHandlerPueblo
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  toPBLinAtLeast :: PBHandlerPueblo -> IO PBLinAtLeast
toPBLinAtLeast PBHandlerPueblo
this = do
    PBLinAtLeast -> IO PBLinAtLeast
forall (m :: * -> *) a. Monad m => a -> m a
return (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this, PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this)

  isSatisfied :: Solver -> PBHandlerPueblo -> IO Bool
isSatisfied Solver
solver PBHandlerPueblo
this = do
    [Integer]
xs <- PBLinSum -> (PBLinTerm -> IO Integer) -> IO [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this) ((PBLinTerm -> IO Integer) -> IO [Integer])
-> (PBLinTerm -> IO Integer) -> IO [Integer]
forall a b. (a -> b) -> a -> b
$ \(Integer
c,Lit
l) -> do
      LBool
v <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
l
      if LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue
        then Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
c
        else Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
xs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this

  constrWeight :: Solver -> PBHandlerPueblo -> IO VarActivity
constrWeight Solver
_ PBHandlerPueblo
_ = VarActivity -> IO VarActivity
forall (m :: * -> *) a. Monad m => a -> m a
return VarActivity
0.5

  constrReadActivity :: PBHandlerPueblo -> IO VarActivity
constrReadActivity PBHandlerPueblo
this = IORef VarActivity -> IO VarActivity
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef VarActivity
puebloActivity PBHandlerPueblo
this)

  constrWriteActivity :: PBHandlerPueblo -> VarActivity -> IO ()
constrWriteActivity PBHandlerPueblo
this VarActivity
aval = IORef VarActivity -> VarActivity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerPueblo -> IORef VarActivity
puebloActivity PBHandlerPueblo
this) (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval

puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool
puebloPropagate Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this = do
  Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
puebloUpdateWatchSum Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this
  Integer
watchsum <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this
  if PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
watchsum then
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else if Integer
watchsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then do
    -- CONFLICT
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this
    -- UNIT PROPAGATION
    let f :: PBLinSum -> IO Bool
f [] = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        f ((Integer
c,Lit
lit) : PBLinSum
ts) = do
          Integer
watchsum' <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this
          if Integer
watchsum' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else do
            LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Bool
b <- Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit SomeConstraintHandler
constr
              Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            PBLinSum -> IO Bool
f PBLinSum
ts
    PBLinSum -> IO Bool
f (PBLinSum -> IO Bool) -> PBLinSum -> IO Bool
forall a b. (a -> b) -> a -> b
$ PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this

puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
puebloUpdateWatchSum Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this = do
  let f :: PBLinSum -> IO ()
f [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      f (t :: PBLinTerm
t@(Integer
_,Lit
lit):PBLinSum
ts) = do
        Integer
watchSum <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this
        if Integer
watchSum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this then
          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          LBool
val <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit
          Bool
watched <- (LitSet -> Bool) -> IO LitSet -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Lit
lit Lit -> LitSet -> Bool
`IS.member`) (IO LitSet -> IO Bool) -> IO LitSet -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
watched) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloWatch Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this PBLinTerm
t
          PBLinSum -> IO ()
f PBLinSum
ts
  PBLinSum -> IO ()
f (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)

{--------------------------------------------------------------------
  XOR Clause
--------------------------------------------------------------------}

data XORClauseHandler
  = XORClauseHandler
  { XORClauseHandler -> LitArray
xorLits :: !LitArray
  , XORClauseHandler -> IORef VarActivity
xorActivity :: !(IORef Double)
  , XORClauseHandler -> Lit
xorHash :: !Int
  }

instance Eq XORClauseHandler where
  == :: XORClauseHandler -> XORClauseHandler -> Bool
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (XORClauseHandler -> LitArray)
-> XORClauseHandler
-> XORClauseHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` XORClauseHandler -> LitArray
xorLits

instance Hashable XORClauseHandler where
  hash :: XORClauseHandler -> Lit
hash = XORClauseHandler -> Lit
xorHash
  hashWithSalt :: Lit -> XORClauseHandler -> Lit
hashWithSalt = Lit -> XORClauseHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

newXORClauseHandler :: [Lit] -> Bool -> IO XORClauseHandler
newXORClauseHandler :: [Lit] -> Bool -> IO XORClauseHandler
newXORClauseHandler [Lit]
ls Bool
learnt = do
  LitArray
a <- [Lit] -> IO LitArray
newLitArray [Lit]
ls
  IORef VarActivity
act <- VarActivity -> IO (IORef VarActivity)
forall a. a -> IO (IORef a)
newIORef (VarActivity -> IO (IORef VarActivity))
-> VarActivity -> IO (IORef VarActivity)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then VarActivity
0 else -VarActivity
1)
  XORClauseHandler -> IO XORClauseHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> IORef VarActivity -> Lit -> XORClauseHandler
XORClauseHandler LitArray
a IORef VarActivity
act ([Lit] -> Lit
forall a. Hashable a => a -> Lit
hash [Lit]
ls))

instance ConstraintHandler XORClauseHandler where
  toConstraintHandler :: XORClauseHandler -> SomeConstraintHandler
toConstraintHandler = XORClauseHandler -> SomeConstraintHandler
CHXORClause

  showConstraintHandler :: XORClauseHandler -> IO [Char]
showConstraintHandler XORClauseHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this)
    [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"XOR " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Lit] -> [Char]
forall a. Show a => a -> [Char]
show [Lit]
lits)

  constrAttach :: Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 = do
    -- BCP Queue should be empty at this point.
    -- If not, duplicated propagation happens.
    Solver -> IO ()
bcpCheckEmpty Solver
solver

    let a :: LitArray
a = XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2
    Lit
size <- LitArray -> IO Lit
getLitArraySize LitArray
a

    if Lit
size Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
0 then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Lit
size Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
1 then do
      Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
      Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
lit0 SomeConstraintHandler
this
    else do
      IORef Lit
ref <- Lit -> IO (IORef Lit)
forall a. a -> IO (IORef a)
newIORef Lit
1
      let f :: Lit -> IO Bool
f Lit
i = do
            Lit
lit_i <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
            LBool
val_i <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit_i
            if LBool
val_i LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do
              Lit
j <- IORef Lit -> IO Lit
forall a. IORef a -> IO a
readIORef IORef Lit
ref
              Lit
k <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch2 Solver
solver LitArray
a Lit
j (Lit
size Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
              case Lit
k of
                -1 -> do
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Lit
_ -> do
                  Lit
lit_k <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit_k
                  LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
k Lit
lit_i
                  IORef Lit -> Lit -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Lit
ref (Lit -> IO ()) -> Lit -> IO ()
forall a b. (a -> b) -> a -> b
$! (Lit
kLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

      Bool
b <- Lit -> IO Bool
f Lit
0
      if Bool
b then do
        Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
lit0) SomeConstraintHandler
this
        Bool
b2 <- Lit -> IO Bool
f Lit
1
        if Bool
b2 then do
          Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
lit1) SomeConstraintHandler
this
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do -- UNIT
          -- We need to watch the most recently falsified literal
          (Lit
i,Lit
_) <- ([(Lit, Lit)] -> (Lit, Lit)) -> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> (Lit, Lit)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd)) (IO [(Lit, Lit)] -> IO (Lit, Lit))
-> IO [(Lit, Lit)] -> IO (Lit, Lit)
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
1..Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
            Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
            Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
            (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)
          Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
          Lit
liti <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
1 Lit
liti
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
liti) SomeConstraintHandler
this
          -- lit0 ⊕ y
          Bool
y <- do
            IORef Bool
ref' <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
            Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
1 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
size) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
j -> do
              Lit
lit_j <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
j
              LBool
val_j <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit_j
              IORef Bool -> (Bool -> Bool) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Bool
ref' (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Bool -> Bool
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val_j))
            IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref'
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver (if Bool
y then Lit -> Lit
litNot Lit
lit0 else Lit
lit0) SomeConstraintHandler
this -- should always succeed
      else do
        [Lit]
ls <- ([(Lit, Lit)] -> [Lit]) -> IO [(Lit, Lit)] -> IO [Lit]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Lit, Lit) -> Lit) -> [(Lit, Lit)] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (Lit, Lit) -> Lit
forall a b. (a, b) -> a
fst ([(Lit, Lit)] -> [Lit])
-> ([(Lit, Lit)] -> [(Lit, Lit)]) -> [(Lit, Lit)] -> [Lit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> [(Lit, Lit)] -> [(Lit, Lit)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Lit, Lit) -> (Lit, Lit) -> Ordering)
-> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Lit, Lit) -> Lit) -> (Lit, Lit) -> (Lit, Lit) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lit, Lit) -> Lit
forall a b. (a, b) -> b
snd))) (IO [(Lit, Lit)] -> IO [Lit]) -> IO [(Lit, Lit)] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ [Lit] -> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Lit
0..Lit
sizeLit -> Lit -> Lit
forall a. Num a => a -> a -> a
-Lit
1] ((Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)])
-> (Lit -> IO (Lit, Lit)) -> IO [(Lit, Lit)]
forall a b. (a -> b) -> a -> b
$ \Lit
l -> do
          Lit
lit <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
l
          Lit
lv <- Solver -> Lit -> IO Lit
litLevel Solver
solver Lit
lit
          (Lit, Lit) -> IO (Lit, Lit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
l,Lit
lv)
        [(Lit, Lit)] -> ((Lit, Lit) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Lit] -> [Lit] -> [(Lit, Lit)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Lit
0..] [Lit]
ls) (((Lit, Lit) -> IO ()) -> IO ()) -> ((Lit, Lit) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Lit
i,Lit
lit) -> do
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit
        Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
        Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
lit0) SomeConstraintHandler
this
        Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
lit1) SomeConstraintHandler
this
        Solver -> XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver XORClauseHandler
this2

  constrDetach :: Solver -> SomeConstraintHandler -> XORClauseHandler -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 = do
    Lit
size <- LitArray -> IO Lit
getLitArraySize (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
>= Lit
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2) Lit
0
      Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2) Lit
1
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchVar Solver
solver (Lit -> Lit
litVar Lit
lit0) SomeConstraintHandler
this
      Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchVar Solver
solver (Lit -> Lit
litVar Lit
lit1) SomeConstraintHandler
this

  constrIsLocked :: Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 = do
    Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2) Lit
0
    Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2) Lit
1
    Bool
b0 <- Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
lit0
    Bool
b1 <- Solver -> SomeConstraintHandler -> Lit -> IO Bool
isReasonOf Solver
solver SomeConstraintHandler
this Lit
lit1
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
b0 Bool -> Bool -> Bool
|| Bool
b1

  constrPropagate :: Solver
-> SomeConstraintHandler -> XORClauseHandler -> Lit -> IO Bool
constrPropagate !Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 !Lit
falsifiedLit = do
    Bool
b <- Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this XORClauseHandler
this2
    if Bool
b then
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      IO ()
preprocess

      !Lit
lit0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
      !Lit
size <- LitArray -> IO Lit
getLitArraySize (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2)
      Lit
i <- Solver -> LitArray -> Lit -> Lit -> IO Lit
findForWatch2 Solver
solver LitArray
a Lit
2 (Lit
size Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
- Lit
1)
      case Lit
i of
        -1 -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO [Char] -> IO ()
logIO Solver
solver (IO [Char] -> IO ()) -> IO [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             [Char]
str <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
this
             [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"constrPropagate: %s is unit" [Char]
str
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver Lit
v SomeConstraintHandler
this
          -- lit0 ⊕ y
          Bool
y <- do
            IORef Bool
ref <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
            Lit -> (Lit -> Bool) -> (Lit -> Lit) -> (Lit -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Lit
1 (Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<Lit
size) (Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1) ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
j -> do
              Lit
lit_j <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
j
              LBool
val_j <- Solver -> Lit -> IO LBool
litValue Solver
solver Lit
lit_j
              IORef Bool -> (Bool -> Bool) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Bool
ref (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Bool -> Bool
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val_j))
            IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref
          Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver (if Bool
y then Lit -> Lit
litNot Lit
lit0 else Lit
lit0) SomeConstraintHandler
this
        Lit
_  -> do
          !Lit
lit1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
          !Lit
liti <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
i
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
1 Lit
liti
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
i Lit
lit1
          Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
liti) SomeConstraintHandler
this
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    where
      v :: Lit
v = Lit -> Lit
litVar Lit
falsifiedLit
      a :: LitArray
a = XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2

      preprocess :: IO ()
      preprocess :: IO ()
preprocess = do
        !Lit
l0 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
0
        !Lit
l1 <- LitArray -> Lit -> IO Lit
readLitArray LitArray
a Lit
1
        Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit -> Lit
litVar Lit
l0 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
v Bool -> Bool -> Bool
|| Lit -> Lit
litVar Lit
l1 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit -> Lit
litVar Lit
l0 Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
0 Lit
l1
          LitArray -> Lit -> Lit -> IO ()
writeLitArray LitArray
a Lit
1 Lit
l0

  constrReasonOf :: Solver -> XORClauseHandler -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver XORClauseHandler
this Maybe Lit
l = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this)
    [Lit]
xs <-
      case Maybe Lit
l of
        Maybe Lit
Nothing -> (Lit -> IO Lit) -> [Lit] -> IO [Lit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Lit -> IO Lit
f [Lit]
lits
        Just Lit
lit -> do
         case [Lit]
lits of
           Lit
l1:[Lit]
ls -> do
             Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit -> Lit
litVar Lit
lit Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit -> Lit
litVar Lit
l1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             (Lit -> IO Lit) -> [Lit] -> IO [Lit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Lit -> IO Lit
f [Lit]
ls
           [Lit]
_ -> [Char] -> IO [Lit]
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"XORClauseHandler.constrReasonOf: should not happen"
    [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lit]
xs
    where
      f :: Lit -> IO Lit
      f :: Lit -> IO Lit
f Lit
lit = do
        let v :: Lit
v = Lit -> Lit
litVar Lit
lit
        LBool
val <- Solver -> Lit -> IO LBool
varValue Solver
solver Lit
v
        Lit -> IO Lit
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> IO Lit) -> Lit -> IO Lit
forall a b. (a -> b) -> a -> b
$ Lit -> Bool -> Lit
literal Lit
v (Bool -> Bool
not (Maybe Bool -> Bool
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val)))

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> XORClauseHandler -> Lit -> IO ()
constrOnUnassigned Solver
_solver SomeConstraintHandler
_this XORClauseHandler
_this2 Lit
_lit = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  isPBRepresentable :: XORClauseHandler -> IO Bool
isPBRepresentable XORClauseHandler
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  toPBLinAtLeast :: XORClauseHandler -> IO PBLinAtLeast
toPBLinAtLeast XORClauseHandler
_ = [Char] -> IO PBLinAtLeast
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"XORClauseHandler does not support toPBLinAtLeast"

  isSatisfied :: Solver -> XORClauseHandler -> IO Bool
isSatisfied Solver
solver XORClauseHandler
this = do
    [Lit]
lits <- LitArray -> IO [Lit]
getLits (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this)
    [LBool]
vals <- (Lit -> IO LBool) -> [Lit] -> IO [LBool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Solver -> Lit -> IO LBool
litValue Solver
solver) [Lit]
lits
    let f :: LBool -> LBool -> LBool
f LBool
x LBool
y
          | LBool
x LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef Bool -> Bool -> Bool
|| LBool
y LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef = LBool
lUndef
          | Bool
otherwise = Bool -> LBool
liftBool (LBool
x LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
y)
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (LBool -> LBool -> LBool) -> LBool -> [LBool] -> LBool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LBool -> LBool -> LBool
f LBool
lFalse [LBool]
vals LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue

  constrIsProtected :: Solver -> XORClauseHandler -> IO Bool
constrIsProtected Solver
_ XORClauseHandler
this = do
    Lit
size <- LitArray -> IO Lit
getLitArraySize (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this)
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Lit
size Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
<= Lit
2

  constrReadActivity :: XORClauseHandler -> IO VarActivity
constrReadActivity XORClauseHandler
this = IORef VarActivity -> IO VarActivity
forall a. IORef a -> IO a
readIORef (XORClauseHandler -> IORef VarActivity
xorActivity XORClauseHandler
this)

  constrWriteActivity :: XORClauseHandler -> VarActivity -> IO ()
constrWriteActivity XORClauseHandler
this VarActivity
aval = IORef VarActivity -> VarActivity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (XORClauseHandler -> IORef VarActivity
xorActivity XORClauseHandler
this) (VarActivity -> IO ()) -> VarActivity -> IO ()
forall a b. (a -> b) -> a -> b
$! VarActivity
aval

basicAttachXORClauseHandler :: Solver -> XORClauseHandler -> IO Bool
basicAttachXORClauseHandler :: Solver -> XORClauseHandler -> IO Bool
basicAttachXORClauseHandler Solver
solver XORClauseHandler
this = do
  [Lit]
lits <- LitArray -> IO [Lit]
getLits (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this)
  let constr :: SomeConstraintHandler
constr = XORClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler XORClauseHandler
this
  case [Lit]
lits of
    [] -> do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [Lit
l1] -> do
      Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l1 SomeConstraintHandler
constr
    Lit
l1:Lit
l2:[Lit]
_ -> do
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
l1) SomeConstraintHandler
constr
      Solver -> Lit -> SomeConstraintHandler -> IO ()
watchVar Solver
solver (Lit -> Lit
litVar Lit
l2) SomeConstraintHandler
constr
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

{--------------------------------------------------------------------
  Arbitrary Boolean Theory
--------------------------------------------------------------------}

setTheory :: Solver -> TheorySolver -> IO ()
setTheory :: Solver -> TheorySolver -> IO ()
setTheory Solver
solver TheorySolver
tsolver = do
  Lit
d <- Solver -> IO Lit
getDecisionLevel Solver
solver
  Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Lit
d Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Maybe TheorySolver
m <- IORef (Maybe TheorySolver) -> IO (Maybe TheorySolver)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)
  case Maybe TheorySolver
m of
    Just TheorySolver
_ -> do
      [Char] -> IO ()
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ToySolver.SAT.setTheory: cannot replace TheorySolver"
    Maybe TheorySolver
Nothing -> do
      IORef (Maybe TheorySolver) -> Maybe TheorySolver -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver) (TheorySolver -> Maybe TheorySolver
forall a. a -> Maybe a
Just TheorySolver
tsolver)
      Maybe SomeConstraintHandler
ret <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
      case Maybe SomeConstraintHandler
ret of
        Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just SomeConstraintHandler
_ -> Solver -> IO ()
markBad Solver
solver

getTheory :: Solver -> IO (Maybe TheorySolver)
getTheory :: Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver = IORef (Maybe TheorySolver) -> IO (Maybe TheorySolver)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)

deduceT :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceT :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceT Solver
solver = do
  Maybe TheorySolver
mt <- IO (Maybe TheorySolver)
-> ExceptT SomeConstraintHandler IO (Maybe TheorySolver)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TheorySolver)
 -> ExceptT SomeConstraintHandler IO (Maybe TheorySolver))
-> IO (Maybe TheorySolver)
-> ExceptT SomeConstraintHandler IO (Maybe TheorySolver)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe TheorySolver) -> IO (Maybe TheorySolver)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> () -> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
t -> do
      Lit
n <- IO Lit -> ExceptT SomeConstraintHandler IO Lit
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Lit -> ExceptT SomeConstraintHandler IO Lit)
-> IO Lit -> ExceptT SomeConstraintHandler IO Lit
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Lit -> IO Lit
forall (a :: * -> * -> *) e. GenericVec a e -> IO Lit
Vec.getSize (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver)
      let h :: SomeConstraintHandler
h = TheoryHandler -> SomeConstraintHandler
CHTheory TheoryHandler
TheoryHandler
          callback :: Lit -> IO Bool
callback Lit
l = Solver -> Lit -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Lit
l SomeConstraintHandler
h
          loop :: Lit -> ExceptT SomeConstraintHandler m ()
loop Lit
i = do
            Bool
-> ExceptT SomeConstraintHandler m ()
-> ExceptT SomeConstraintHandler m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lit
i Lit -> Lit -> Bool
forall a. Ord a => a -> a -> Bool
< Lit
n) (ExceptT SomeConstraintHandler m ()
 -> ExceptT SomeConstraintHandler m ())
-> ExceptT SomeConstraintHandler m ()
-> ExceptT SomeConstraintHandler m ()
forall a b. (a -> b) -> a -> b
$ do
              Lit
l <- IO Lit -> ExceptT SomeConstraintHandler m Lit
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Lit -> ExceptT SomeConstraintHandler m Lit)
-> IO Lit -> ExceptT SomeConstraintHandler m Lit
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Lit -> Lit -> IO Lit
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Lit -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Lit
svTrail Solver
solver) Lit
i
              Bool
ok <- IO Bool -> ExceptT SomeConstraintHandler m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT SomeConstraintHandler m Bool)
-> IO Bool -> ExceptT SomeConstraintHandler m Bool
forall a b. (a -> b) -> a -> b
$ TheorySolver -> (Lit -> IO Bool) -> Lit -> IO Bool
thAssertLit TheorySolver
t Lit -> IO Bool
callback Lit
l
              if Bool
ok then
                Lit -> ExceptT SomeConstraintHandler m ()
loop (Lit
iLit -> Lit -> Lit
forall a. Num a => a -> a -> a
+Lit
1)
              else
                SomeConstraintHandler -> ExceptT SomeConstraintHandler m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SomeConstraintHandler
h
      Lit -> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *).
MonadIO m =>
Lit -> ExceptT SomeConstraintHandler m ()
loop (Lit -> ExceptT SomeConstraintHandler IO ())
-> ExceptT SomeConstraintHandler IO Lit
-> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Lit -> ExceptT SomeConstraintHandler IO Lit
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IOURef Lit -> IO Lit
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Lit
svTheoryChecked Solver
solver))
      Bool
b2 <- IO Bool -> ExceptT SomeConstraintHandler IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT SomeConstraintHandler IO Bool)
-> IO Bool -> ExceptT SomeConstraintHandler IO Bool
forall a b. (a -> b) -> a -> b
$ TheorySolver -> (Lit -> IO Bool) -> IO Bool
thCheck TheorySolver
t Lit -> IO Bool
callback
      if Bool
b2 then do
        IO () -> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT SomeConstraintHandler IO ())
-> IO () -> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ IOURef Lit -> Lit -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Lit
svTheoryChecked Solver
solver) Lit
n
      else
        SomeConstraintHandler -> ExceptT SomeConstraintHandler IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SomeConstraintHandler
h

data TheoryHandler = TheoryHandler deriving (TheoryHandler -> TheoryHandler -> Bool
(TheoryHandler -> TheoryHandler -> Bool)
-> (TheoryHandler -> TheoryHandler -> Bool) -> Eq TheoryHandler
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TheoryHandler -> TheoryHandler -> Bool
$c/= :: TheoryHandler -> TheoryHandler -> Bool
== :: TheoryHandler -> TheoryHandler -> Bool
$c== :: TheoryHandler -> TheoryHandler -> Bool
Eq)

instance Hashable TheoryHandler where
  hash :: TheoryHandler -> Lit
hash TheoryHandler
_ = () -> Lit
forall a. Hashable a => a -> Lit
hash ()
  hashWithSalt :: Lit -> TheoryHandler -> Lit
hashWithSalt = Lit -> TheoryHandler -> Lit
forall a. Hashable a => Lit -> a -> Lit
defaultHashWithSalt

instance ConstraintHandler TheoryHandler where
  toConstraintHandler :: TheoryHandler -> SomeConstraintHandler
toConstraintHandler = TheoryHandler -> SomeConstraintHandler
CHTheory

  showConstraintHandler :: TheoryHandler -> IO [Char]
showConstraintHandler TheoryHandler
_this = [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"TheoryHandler"

  constrAttach :: Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
constrAttach Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 = [Char] -> IO Bool
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TheoryHandler.constrAttach"

  constrDetach :: Solver -> SomeConstraintHandler -> TheoryHandler -> IO ()
constrDetach Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  constrIsLocked :: Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
constrIsLocked Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  constrPropagate :: Solver -> SomeConstraintHandler -> TheoryHandler -> Lit -> IO Bool
constrPropagate Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 Lit
_falsifiedLit =  [Char] -> IO Bool
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TheoryHandler.constrPropagate"

  constrReasonOf :: Solver -> TheoryHandler -> Maybe Lit -> IO [Lit]
constrReasonOf Solver
solver TheoryHandler
_this Maybe Lit
l = do
    Just TheorySolver
t <- IORef (Maybe TheorySolver) -> IO (Maybe TheorySolver)
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)
    [Lit]
lits <- TheorySolver -> Maybe Lit -> IO [Lit]
thExplain TheorySolver
t Maybe Lit
l
    [Lit] -> IO [Lit]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Lit] -> IO [Lit]) -> [Lit] -> IO [Lit]
forall a b. (a -> b) -> a -> b
$ [-Lit
lit | Lit
lit <- [Lit]
lits]

  constrOnUnassigned :: Solver -> SomeConstraintHandler -> TheoryHandler -> Lit -> IO ()
constrOnUnassigned Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 Lit
_lit = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  isPBRepresentable :: TheoryHandler -> IO Bool
isPBRepresentable TheoryHandler
_this = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  toPBLinAtLeast :: TheoryHandler -> IO PBLinAtLeast
toPBLinAtLeast TheoryHandler
_this = [Char] -> IO PBLinAtLeast
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TheoryHandler.toPBLinAtLeast"

  isSatisfied :: Solver -> TheoryHandler -> IO Bool
isSatisfied Solver
_solver TheoryHandler
_this = [Char] -> IO Bool
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TheoryHandler.isSatisfied"

  constrIsProtected :: Solver -> TheoryHandler -> IO Bool
constrIsProtected Solver
_solver TheoryHandler
_this = [Char] -> IO Bool
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TheoryHandler.constrIsProtected"

  constrReadActivity :: TheoryHandler -> IO VarActivity
constrReadActivity TheoryHandler
_this = VarActivity -> IO VarActivity
forall (m :: * -> *) a. Monad m => a -> m a
return VarActivity
0

  constrWriteActivity :: TheoryHandler -> VarActivity -> IO ()
constrWriteActivity TheoryHandler
_this VarActivity
_aval = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{--------------------------------------------------------------------
  Restart strategy
--------------------------------------------------------------------}

mkRestartSeq :: RestartStrategy -> Int -> Double -> [Int]
mkRestartSeq :: RestartStrategy -> Lit -> VarActivity -> [Lit]
mkRestartSeq RestartStrategy
MiniSATRestarts = Lit -> VarActivity -> [Lit]
miniSatRestartSeq
mkRestartSeq RestartStrategy
ArminRestarts   = Lit -> VarActivity -> [Lit]
arminRestartSeq
mkRestartSeq RestartStrategy
LubyRestarts    = Lit -> VarActivity -> [Lit]
lubyRestartSeq

miniSatRestartSeq :: Int -> Double -> [Int]
miniSatRestartSeq :: Lit -> VarActivity -> [Lit]
miniSatRestartSeq Lit
start VarActivity
inc = (Lit -> Lit) -> Lit -> [Lit]
forall a. (a -> a) -> a -> [a]
iterate (VarActivity -> Lit
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (VarActivity -> Lit) -> (Lit -> VarActivity) -> Lit -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarActivity
inc VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*) (VarActivity -> VarActivity)
-> (Lit -> VarActivity) -> Lit -> VarActivity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Lit
start

{-
miniSatRestartSeq :: Int -> Double -> [Int]
miniSatRestartSeq start inc = map round $ iterate (inc*) (fromIntegral start)
-}

arminRestartSeq :: Int -> Double -> [Int]
arminRestartSeq :: Lit -> VarActivity -> [Lit]
arminRestartSeq Lit
start VarActivity
inc = VarActivity -> VarActivity -> [Lit]
forall a. Integral a => VarActivity -> VarActivity -> [a]
go (Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
start) (Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
start)
  where
    go :: VarActivity -> VarActivity -> [a]
go !VarActivity
inner !VarActivity
outer = VarActivity -> a
forall a b. (RealFrac a, Integral b) => a -> b
round VarActivity
inner a -> [a] -> [a]
forall a. a -> [a] -> [a]
: VarActivity -> VarActivity -> [a]
go VarActivity
inner' VarActivity
outer'
      where
        (VarActivity
inner',VarActivity
outer') =
          if VarActivity
inner VarActivity -> VarActivity -> Bool
forall a. Ord a => a -> a -> Bool
>= VarActivity
outer
          then (Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
start, VarActivity
outer VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
inc)
          else (VarActivity
inner VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
* VarActivity
inc, VarActivity
outer)

lubyRestartSeq :: Int -> Double -> [Int]
lubyRestartSeq :: Lit -> VarActivity -> [Lit]
lubyRestartSeq Lit
start VarActivity
inc = (Integer -> Lit) -> [Integer] -> [Lit]
forall a b. (a -> b) -> [a] -> [b]
map (VarActivity -> Lit
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (VarActivity -> Lit) -> (Integer -> VarActivity) -> Integer -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lit -> VarActivity
forall a b. (Integral a, Num b) => a -> b
fromIntegral Lit
start VarActivity -> VarActivity -> VarActivity
forall a. Num a => a -> a -> a
*) (VarActivity -> VarActivity)
-> (Integer -> VarActivity) -> Integer -> VarActivity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarActivity -> Integer -> VarActivity
luby VarActivity
inc) [Integer
0..]

{-
  Finite subsequences of the Luby-sequence:

  0: 1
  1: 1 1 2
  2: 1 1 2 1 1 2 4
  3: 1 1 2 1 1 2 4 1 1 2 1 1 2 4 8
  ...


-}
luby :: Double -> Integer -> Double
luby :: VarActivity -> Integer -> VarActivity
luby VarActivity
y Integer
x = Integer -> Integer -> Integer -> VarActivity
go2 Integer
size1 Integer
sequ1 Integer
x
  where
    -- Find the finite subsequence that contains index 'x', and the
    -- size of that subsequence:
    (Integer
size1, Integer
sequ1) = Integer -> Integer -> (Integer, Integer)
go Integer
1 Integer
0

    go :: Integer -> Integer -> (Integer, Integer)
    go :: Integer -> Integer -> (Integer, Integer)
go Integer
size Integer
sequ
      | Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1 = Integer -> Integer -> (Integer, Integer)
go (Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) (Integer
sequInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)
      | Bool
otherwise  = (Integer
size, Integer
sequ)

    go2 :: Integer -> Integer -> Integer -> Double
    go2 :: Integer -> Integer -> Integer -> VarActivity
go2 Integer
size Integer
sequ Integer
x2
      | Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
x2 = let size' :: Integer
size' = (Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2 in Integer -> Integer -> Integer -> VarActivity
go2 Integer
size' (Integer
sequ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) (Integer
x2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
size')
      | Bool
otherwise = VarActivity
y VarActivity -> Integer -> VarActivity
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
sequ


{--------------------------------------------------------------------
  utility
--------------------------------------------------------------------}

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p = [a] -> m Bool
go
  where
    go :: [a] -> m Bool
go [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go (a
x:[a]
xs) = do
      Bool
b <- a -> m Bool
p a
x
      if Bool
b
        then [a] -> m Bool
go [a]
xs
        else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM :: (a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
p = [a] -> m Bool
go
  where
    go :: [a] -> m Bool
go [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    go (a
x:[a]
xs) = do
      Bool
b <- a -> m Bool
p a
x
      if Bool
b
        then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else [a] -> m Bool
go [a]
xs

shift :: IORef [a] -> IO a
shift :: IORef [a] -> IO a
shift IORef [a]
ref = do
  (a
x:[a]
xs) <- IORef [a] -> IO [a]
forall a. IORef a -> IO a
readIORef IORef [a]
ref
  IORef [a] -> [a] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [a]
ref [a]
xs
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

defaultHashWithSalt :: Hashable a => Int -> a -> Int
defaultHashWithSalt :: Lit -> a -> Lit
defaultHashWithSalt Lit
salt a
x = Lit
salt Lit -> Lit -> Lit
`combine` a -> Lit
forall a. Hashable a => a -> Lit
hash a
x
  where
    combine :: Int -> Int -> Int
    combine :: Lit -> Lit -> Lit
combine Lit
h1 Lit
h2 = (Lit
h1 Lit -> Lit -> Lit
forall a. Num a => a -> a -> a
* Lit
16777619) Lit -> Lit -> Lit
forall a. Bits a => a -> a -> a
`xor` Lit
h2

{--------------------------------------------------------------------
  debug
--------------------------------------------------------------------}

debugMode :: Bool
debugMode :: Bool
debugMode = Bool
False

checkSatisfied :: Solver -> IO ()
checkSatisfied :: Solver -> IO ()
checkSatisfied Solver
solver = do
  [SomeConstraintHandler]
cls <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
cls ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    Bool
b <- Solver -> SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver SomeConstraintHandler
c
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char]
s <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
c
      Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"BUG: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is violated"

dumpVarActivity :: Solver -> IO ()
dumpVarActivity :: Solver -> IO ()
dumpVarActivity Solver
solver = do
  Solver -> [Char] -> IO ()
log Solver
solver [Char]
"Variable activity:"
  [Lit]
vs <- Solver -> IO [Lit]
variables Solver
solver
  [Lit] -> (Lit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Lit]
vs ((Lit -> IO ()) -> IO ()) -> (Lit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Lit
v -> do
    VarActivity
activity <- Solver -> Lit -> IO VarActivity
varActivity Solver
solver Lit
v
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"activity(%d) = %d" Lit
v VarActivity
activity

dumpConstrActivity :: Solver -> IO ()
dumpConstrActivity :: Solver -> IO ()
dumpConstrActivity Solver
solver = do
  Solver -> [Char] -> IO ()
log Solver
solver [Char]
"Learnt constraints activity:"
  [SomeConstraintHandler]
xs <- Solver -> IO [SomeConstraintHandler]
learntConstraints Solver
solver
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
xs ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    [Char]
s <- SomeConstraintHandler -> IO [Char]
forall a. ConstraintHandler a => a -> IO [Char]
showConstraintHandler SomeConstraintHandler
c
    VarActivity
aval <- SomeConstraintHandler -> IO VarActivity
forall a. ConstraintHandler a => a -> IO VarActivity
constrReadActivity SomeConstraintHandler
c
    Solver -> [Char] -> IO ()
log Solver
solver ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> VarActivity -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"activity(%s) = %f" [Char]
s VarActivity
aval

-- | set callback function for receiving messages.
setLogger :: Solver -> (String -> IO ()) -> IO ()
setLogger :: Solver -> ([Char] -> IO ()) -> IO ()
setLogger Solver
solver [Char] -> IO ()
logger = do
  IORef (Maybe ([Char] -> IO ())) -> Maybe ([Char] -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe ([Char] -> IO ()))
svLogger Solver
solver) (([Char] -> IO ()) -> Maybe ([Char] -> IO ())
forall a. a -> Maybe a
Just [Char] -> IO ()
logger)

-- | Clear logger function set by 'setLogger'.
clearLogger :: Solver -> IO ()
clearLogger :: Solver -> IO ()
clearLogger Solver
solver = do
  IORef (Maybe ([Char] -> IO ())) -> Maybe ([Char] -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe ([Char] -> IO ()))
svLogger Solver
solver) Maybe ([Char] -> IO ())
forall a. Maybe a
Nothing

log :: Solver -> String -> IO ()
log :: Solver -> [Char] -> IO ()
log Solver
solver [Char]
msg = Solver -> IO [Char] -> IO ()
logIO Solver
solver ([Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
msg)

logIO :: Solver -> IO String -> IO ()
logIO :: Solver -> IO [Char] -> IO ()
logIO Solver
solver IO [Char]
action = do
  Maybe ([Char] -> IO ())
m <- IORef (Maybe ([Char] -> IO ())) -> IO (Maybe ([Char] -> IO ()))
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe ([Char] -> IO ()))
svLogger Solver
solver)
  case Maybe ([Char] -> IO ())
m of
    Maybe ([Char] -> IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [Char] -> IO ()
logger -> IO [Char]
action IO [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO ()
logger