{-# 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
(
Solver
, newSolver
, newSolverWithConfig
, Var
, Lit
, literal
, litNot
, litVar
, litPolarity
, evalLit
, newVar
, newVars
, newVars_
, resizeVarCapacity
, AddClause (..)
, Clause
, evalClause
, PackedClause
, packClause
, unpackClause
, AddCardinality (..)
, AtLeast
, Exactly
, evalAtLeast
, evalExactly
, AddPBLin (..)
, PBLinTerm
, PBLinSum
, PBLinAtLeast
, PBLinExactly
, evalPBLinSum
, evalPBLinAtLeast
, evalPBLinExactly
, AddXORClause (..)
, XORClause
, evalXORClause
, setTheory
, solve
, solveWith
, BudgetExceeded (..)
, cancel
, Canceled (..)
, IModel (..)
, Model
, getModel
, getFailedAssumptions
, getAssumptionsImplications
, module ToySolver.SAT.Solver.CDCL.Config
, getConfig
, setConfig
, modifyConfig
, setVarPolarity
, setRandomGen
, getRandomGen
, setConfBudget
, setLogger
, clearLogger
, setTerminateCallback
, clearTerminateCallback
, setLearnCallback
, clearLearnCallback
, getNVars
, getNConstraints
, getNLearntConstraints
, getVarFixed
, getLitFixed
, getFixedLiterals
, 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)
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)
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
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
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
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
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)
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)
, Solver -> GenericVec IOUArray Int8
svVarValue :: !(Vec.UVec Int8)
, 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)
, Solver -> Vec [SomeConstraintHandler]
svVarWatches :: !(Vec.Vec [SomeConstraintHandler])
, Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned :: !(Vec.Vec [SomeConstraintHandler])
, Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason :: !(Vec.Vec (Maybe SomeConstraintHandler))
, Solver -> UVec VarActivity
svVarEMAScaled :: !(Vec.UVec Double)
, Solver -> GenericVec IOUArray Lit
svVarWhenAssigned :: !(Vec.UVec Int)
, Solver -> GenericVec IOUArray Lit
svVarParticipated :: !(Vec.UVec Int)
, Solver -> GenericVec IOUArray Lit
svVarReasoned :: !(Vec.UVec Int)
, 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]))
, Solver -> IORef (Maybe TheorySolver)
svTheorySolver :: !(IORef (Maybe TheorySolver))
, Solver -> IOURef Lit
svTheoryChecked :: !(IOURef Int)
, Solver -> IORef (Maybe Model)
svModel :: !(IORef (Maybe Model))
, Solver -> IORef LitSet
svFailedAssumptions :: !(IORef LitSet)
, Solver -> IORef LitSet
svAssumptionsImplications :: !(IORef LitSet)
, 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)
, 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 ())))
, Solver -> IORef (Maybe ([Char] -> IO ()))
svLogger :: !(IORef (Maybe (String -> IO ())))
, Solver -> IORef TimeSpec
svStartWC :: !(IORef TimeSpec)
, Solver -> IORef TimeSpec
svLastStatWC :: !(IORef TimeSpec)
, 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))
, Solver -> IOURef VarActivity
svVarInc :: !(IOURef Double)
, Solver -> IOURef VarActivity
svConstrInc :: !(IOURef Double)
, 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
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
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)
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)
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))
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]
:)
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]
: )
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))
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
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
$
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]
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)
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)
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
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
newSolver :: IO Solver
newSolver :: IO Solver
newSolver = Config -> IO Solver
newSolverWithConfig Config
forall a. Default a => a
def
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
, svTheorySolver :: IORef (Maybe TheorySolver)
svTheorySolver = IORef (Maybe TheorySolver)
tsolver
, svTheoryChecked :: IOURef Lit
svTheoryChecked = IOURef Lit
tchecked
, svModel :: IORef (Maybe Model)
svModel = IORef (Maybe Model)
m
, svFailedAssumptions :: IORef LitSet
svFailedAssumptions = IORef LitSet
failed
, svAssumptionsImplications :: IORef LitSet
svAssumptionsImplications = IORef LitSet
implied
, 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
, 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
, 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
, 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
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
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)
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
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
[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
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
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 ()
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
solveWith :: Solver
-> [Lit]
-> 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
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
[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
() -> 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
() -> 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
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
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 :: 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
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)
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)
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)
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
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
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)
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
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
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
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
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)
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)
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)
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
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)
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
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
!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
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
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
(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)
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
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
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
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
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
$
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 ()
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
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
constrPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool
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)
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
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
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
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
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
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
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
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
(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
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 (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
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)
constrAttach :: Solver -> SomeConstraintHandler -> AtLeastHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this AtLeastHandler
this2 = do
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
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
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_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
else 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
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
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(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
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
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
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]
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
[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
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
data PBHandlerCounter
= PBHandlerCounter
{ PBHandlerCounter -> PBLinSum
pbTerms :: !PBLinSum
, 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
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)
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
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
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
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)
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
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
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)
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
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
(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
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
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
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
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 ()
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
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..]
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
(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
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
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
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)
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