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

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

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

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

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

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

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

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

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

  -- * Internal API
  , varBumpActivity
  , varDecayActivity
  ) where

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

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

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

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

newtype LitArray = LitArray (IOUArray Int PackedLit) deriving (LitArray -> LitArray -> Bool
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 :: Clause -> IO LitArray
newLitArray Clause
lits = do
  let size :: Int
size = forall (t :: * -> *) a. Foldable t => t a -> Int
length Clause
lits
  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM IOUArray Int PackedLit -> LitArray
LitArray forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (Int
0, Int
sizeforall a. Num a => a -> a -> a
-Int
1) (forall a b. (a -> b) -> [a] -> [b]
map Int -> PackedLit
packLit Clause
lits)

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

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

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

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

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

type Level = Int

levelRoot :: Level
levelRoot :: Int
levelRoot = Int
0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  -- ERWA / LRB

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

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

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

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

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

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

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

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

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

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

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

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

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

unassign :: Solver -> Var -> IO ()
unassign :: Solver -> Int -> IO ()
unassign Solver
solver !Int
v = forall a. HasCallStack => Bool -> a -> a
assert (Int -> Bool
validVar Int
v) forall a b. (a -> b) -> a -> b
$ do
  LBool
val <- Solver -> Int -> IO LBool
varValue Solver
solver Int
v
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val forall a. Eq a => a -> a -> Bool
== LBool
lUndef) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"unassign: should not happen"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  let loop :: [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [] [SomeConstraintHandler]
ret = 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 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
cforall 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 <- forall {b}.
[(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, Double))]
zs []

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

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

type VarActivity = Double

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  IORef Int
learntLim       <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined
  IORef Int
learntLimAdjCnt <- forall a. a -> IO (IORef a)
newIORef (-Int
1)
  IORef [(Int, Int)]
learntLimSeq    <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined

  IORef (Maybe (String -> IO ()))
logger <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  IORef TimeSpec
startWC    <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined
  IORef TimeSpec
lastStatWC <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined

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

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

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

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

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

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

  let solver :: Solver
solver =
        Solver
        { svOk :: IORef Bool
svOk = IORef Bool
ok
        , svVarQueue :: PriorityQueue
svVarQueue   = PriorityQueue
vqueue
        , svTrail :: UVec Int
svTrail      = UVec Int
trail
        , svTrailLimit :: UVec Int
svTrailLimit = UVec Int
trail_lim
        , svTrailNPropagated :: IOURef Int
svTrailNPropagated = IOURef Int
trail_nprop

        , svVarValue :: UVec Int8
svVarValue        = UVec Int8
varValue
        , svVarPolarity :: UVec Bool
svVarPolarity     = UVec Bool
varPolarity
        , svVarActivity :: UVec Double
svVarActivity     = UVec Double
varActivity
        , svVarTrailIndex :: UVec Int
svVarTrailIndex   = UVec Int
varTrailIndex
        , svVarLevel :: UVec Int
svVarLevel        = UVec Int
varLevel
        , svVarWatches :: Vec [SomeConstraintHandler]
svVarWatches      = Vec [SomeConstraintHandler]
varWatches
        , svVarOnUnassigned :: Vec [SomeConstraintHandler]
svVarOnUnassigned = Vec [SomeConstraintHandler]
varOnUnassigned
        , svVarReason :: Vec (Maybe SomeConstraintHandler)
svVarReason       = Vec (Maybe SomeConstraintHandler)
varReason
        , svVarEMAScaled :: UVec Double
svVarEMAScaled    = UVec Double
varEMAScaled
        , svVarWhenAssigned :: UVec Int
svVarWhenAssigned = UVec Int
varWhenAssigned
        , svVarParticipated :: UVec Int
svVarParticipated = UVec Int
varParticipated
        , svVarReasoned :: UVec Int
svVarReasoned     = UVec Int
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 (Int, [SomeConstraintHandler])
svLearntDB   = IORef (Int, [SomeConstraintHandler])
db2

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

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

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

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

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

        -- Working space
        , svCanceled :: IORef Bool
svCanceled        = IORef Bool
canceled
        , svAssumptions :: UVec Int
svAssumptions     = UVec Int
as
        , svLearntLim :: IORef Int
svLearntLim       = IORef Int
learntLim
        , svLearntLimAdjCnt :: IORef Int
svLearntLimAdjCnt = IORef Int
learntLimAdjCnt
        , svLearntLimSeq :: IORef [(Int, Int)]
svLearntLimSeq    = IORef [(Int, Int)]
learntLimSeq
        , svVarInc :: IOURef Double
svVarInc      = IOURef Double
varInc
        , svConstrInc :: IOURef Double
svConstrInc   = IOURef Double
constrInc
        , svSeen :: UVec Bool
svSeen = UVec Bool
seen
        , svPBLearnt :: IORef (Maybe (PBLinSum, Integer))
svPBLearnt = IORef (Maybe (PBLinSum, Integer))
pbLearnt

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      if Int
n' forall a. Ord a => a -> a -> Bool
<= Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else if Int
n' forall a. Ord a => a -> a -> Bool
> Int
len then Solver -> IO ()
markBad Solver
solver
      else if Int
n' forall a. Eq a => a -> a -> Bool
== Int
1 then forall (m :: * -> *) a. AddClause m a => a -> Clause -> m ()
addClause Solver
solver Clause
lits'
      else if Int
n' forall a. Eq a => a -> a -> Bool
== Int
len then do
        {- We do not call 'removeBackwardSubsumedBy' here,
           because subsumed constraints will be removed by 'simplify'. -}
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Clause
lits' forall a b. (a -> b) -> a -> b
$ \Int
l -> do
          Bool
ret <- Solver -> Int -> IO Bool
assign Solver
solver Int
l
          forall a. HasCallStack => Bool -> a -> a
assert Bool
ret forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just SomeConstraintHandler
_ -> Solver -> IO ()
markBad Solver
solver
      else do -- n' < len
        Solver -> (PBLinSum, Integer) -> IO ()
removeBackwardSubsumedBy Solver
solver ([(Integer
1,Int
lit) | Int
lit <- Clause
lits'], forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n')
        AtLeastHandler
c <- Clause -> Int -> Bool -> IO AtLeastHandler
newAtLeastHandler Clause
lits' Int
n' Bool
False
        forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver AtLeastHandler
c
        Bool
_ <- Solver -> AtLeastHandler -> IO Bool
basicAttachAtLeastHandler Solver
solver AtLeastHandler
c
        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
    Int
d <- Solver -> IO Int
getDecisionLevel Solver
solver
    forall a. HasCallStack => Bool -> a -> a
assert (Int
d forall a. Eq a => a -> a -> Bool
== Int
levelRoot) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

      case (PBLinSum, Integer) -> Maybe (Clause, Int)
pbToAtLeast (PBLinSum
ts',Integer
n') of
        Just (Clause
lhs',Int
rhs') -> forall (m :: * -> *) a.
AddCardinality m a =>
a -> Clause -> Int -> m ()
addAtLeast Solver
solver Clause
lhs' Int
rhs'
        Maybe (Clause, Int)
Nothing -> do
          let cs :: [Integer]
cs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst PBLinSum
ts'
              slack :: Integer
slack = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
cs forall a. Num a => a -> a -> a
- Integer
n'
          if Integer
n' forall a. Ord a => a -> a -> Bool
<= Integer
0 then forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else if Integer
slack forall a. Ord a => a -> a -> Bool
< Integer
0 then Solver -> IO ()
markBad Solver
solver
          else do
            Solver -> (PBLinSum, Integer) -> IO ()
removeBackwardSubsumedBy Solver
solver (PBLinSum
ts', Integer
n')
            (PBLinSum
ts'',Integer
n'') <- do
              Bool
b <- Config -> Bool
configEnablePBSplitClausePart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
              if Bool
b
              then Solver -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
pbSplitClausePart Solver
solver (PBLinSum
ts',Integer
n')
              else 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 = forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler SomeConstraintHandler
c
            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 -> 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) <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinExactly forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinExactly (Solver -> Int -> IO LBool
getLitFixed Solver
solver) (PBLinSum
ts,Integer
n)
    forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver PBLinSum
ts2 Integer
n2
    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 -> Int -> PBLinSum -> Integer -> IO ()
addPBAtLeastSoft Solver
solver Int
sel PBLinSum
lhs Integer
rhs = do
    (PBLinSum
lhs', Integer
rhs') <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinAtLeast forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinAtLeast (Solver -> Int -> IO LBool
getLitFixed Solver
solver) (PBLinSum
lhs,Integer
rhs)
    forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver ((Integer
rhs', Int -> Int
litNot Int
sel) forall a. a -> [a] -> [a]
: PBLinSum
lhs') Integer
rhs'

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

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

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

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

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

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

-- | Solve constraints under assuptions.
-- Returns 'True' if the problem is SATISFIABLE.
-- Returns 'False' if the problem is UNSATISFIABLE.
solveWith :: Solver
          -> [Lit]    -- ^ Assumptions
          -> IO Bool
solveWith :: Solver -> Clause -> IO Bool
solveWith Solver
solver Clause
ls = do
  forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO ()
Vec.clear (Solver -> UVec Int
svAssumptions Solver
solver)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec Int
svAssumptions Solver
solver)) Clause
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
  forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svAssumptionsImplications Solver
solver) LitSet
IS.empty

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

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

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

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Double
configRestartInc Config
config forall a. Ord a => a -> a -> Bool
> Double
1) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"RestartInc must be >1"
    let restartSeq :: Clause
restartSeq =
          if Config -> Int
configRestartFirst Config
config  forall a. Ord a => a -> a -> Bool
> Int
0
          then RestartStrategy -> Int -> Double -> Clause
mkRestartSeq (Config -> RestartStrategy
configRestartStrategy Config
config) (Config -> Int
configRestartFirst Config
config) (Config -> Double
configRestartInc Config
config)
          else forall a. a -> [a]
repeat Int
0

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

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

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

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

    Solver -> IO ()
printStatHeader Solver
solver

    TimeSpec
startCPU <- Clock -> IO TimeSpec
getTime Clock
ProcessCPUTime
    TimeSpec
startWC  <- Clock -> IO TimeSpec
getTime Clock
Monotonic
    forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef TimeSpec
svStartWC Solver
solver) TimeSpec
startWC
    Either (IO Bool) Bool
result <- forall {a}. Clause -> IO (Either a Bool)
loop Clause
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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configCheckModel Config
config) 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just TheorySolver
t -> TheorySolver -> IO ()
thConstructModel TheorySolver
t
      Either (IO Bool) Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Either (IO Bool) Bool
result of
      Right Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Either (IO Bool) Bool
_ -> Solver -> IO ()
saveAssumptionsImplications Solver
solver

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

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

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

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

instance Exception BudgetExceeded

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

instance Exception Canceled

data SearchResult
  = SRFinished Bool
  | SRRestart
  | SRBudgetExceeded
  | SRCanceled

search :: Solver -> Int -> IO () -> IO SearchResult
search :: Solver -> Int -> IO () -> IO SearchResult
search Solver
solver !Int
conflict_lim IO ()
onConflict = do
  IORef Int
conflictCounter <- forall a. a -> IO (IORef a)
newIORef Int
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 Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Int
conflictCounter SomeConstraintHandler
constr
          case Maybe SearchResult
ret of
            Just SearchResult
sr -> forall (m :: * -> *) a. Monad m => a -> m a
return SearchResult
sr
            Maybe SearchResult
Nothing -> IO SearchResult
loop
        Maybe SomeConstraintHandler
Nothing -> do
          Int
lv <- Solver -> IO Int
getDecisionLevel Solver
solver
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lv forall a. Eq a => a -> a -> Bool
== Int
levelRoot) forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
simplify Solver
solver
          IO ()
checkGC
          Maybe Int
r <- IO (Maybe Int)
pickAssumption
          case Maybe Int
r of
            Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
False)
            Just Int
lit
              | Int
lit forall a. Eq a => a -> a -> Bool
/= Int
litUndef -> Solver -> Int -> IO ()
decide Solver
solver Int
lit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO SearchResult
loop
              | Bool
otherwise -> do
                  Int
lit2 <- Solver -> IO Int
pickBranchLit Solver
solver
                  if Int
lit2 forall a. Eq a => a -> a -> Bool
== Int
litUndef
                    then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
True)
                    else Solver -> Int -> IO ()
decide Solver
solver Int
lit2 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
      Int
n <- Solver -> IO Int
getNLearntConstraints Solver
solver
      Int
m <- Solver -> IO Int
getNAssigned Solver
solver
      Int
learnt_lim <- forall a. IORef a -> IO a
readIORef (Solver -> IORef Int
svLearntLim Solver
solver)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
learnt_lim forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Num a => a -> a -> a
- Int
m forall a. Ord a => a -> a -> Bool
> Int
learnt_lim) forall a b. (a -> b) -> a -> b
$ do
        forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNLearntGC Solver
solver) (forall a. Num a => a -> a -> a
+Int
1)
        Solver -> IO ()
reduceDB Solver
solver

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

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

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

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

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

      forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svConfBudget Solver
solver) forall a b. (a -> b) -> a -> b
$ \Int
confBudget ->
        if Int
confBudget forall a. Ord a => a -> a -> Bool
> Int
0 then Int
confBudget forall a. Num a => a -> a -> a
- Int
1 else Int
confBudget
      Int
confBudget <- forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svConfBudget Solver
solver)

      Maybe (IO Bool)
terminateCallback' <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just IO Bool
terminateCallback -> do
          Bool
ret <- IO Bool
terminateCallback
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ret forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
True
      Bool
canceled <- forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svCanceled Solver
solver)

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

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

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

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

      case Clause
learntClause of
        [] -> forall a. HasCallStack => String -> a
error String
"search(LearningHybrid): should not happen"
        [Int
lit] -> do
          Bool
_ <- Solver -> Int -> IO Bool
assign Solver
solver Int
lit -- This should always succeed.
          forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Int
lit:Clause
_ -> do
          ClauseHandler
cl <- Clause -> Bool -> IO ClauseHandler
newClauseHandler Clause
learntClause Bool
True
          let constr2 :: SomeConstraintHandler
constr2 = forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
cl
          forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
constr2
          Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
cl
          forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
minLevel forall a. Eq a => a -> a -> Bool
== Int
clauseLevel) forall a b. (a -> b) -> a -> b
$ do
            Bool
_ <- Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
lit SomeConstraintHandler
constr2 -- This should always succeed.
            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 Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Int
conflictCounter SomeConstraintHandler
conflicted
          -- TODO: should also learn the PB constraint?
        Maybe SomeConstraintHandler
Nothing -> do
          case Maybe (PBLinSum, Integer)
pb of
            Maybe (PBLinSum, Integer)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (PBLinSum
lhs,Integer
rhs) -> do
              SomeConstraintHandler
h <- Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted Solver
solver PBLinSum
lhs Integer
rhs Bool
True
              case SomeConstraintHandler
h of
                CHClause ClauseHandler
_ -> do
                  {- We don't want to add additional clause,
                     since it would be subsumed by already added one. -}
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                SomeConstraintHandler
_ -> do
                  forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
h
                  Bool
ret2 <- Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
h
                  forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
h
                  if Bool
ret2 then
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  else
                    IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
handleConflict IORef Int
conflictCounter SomeConstraintHandler
h

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

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

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

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

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

-- | Simplify the constraint database according to the current top-level assigment.
simplify :: Solver -> IO ()
simplify :: Solver -> IO ()
simplify Solver
solver = do
  let loop :: [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [] [SomeConstraintHandler]
rs !t
n     = 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 <- 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
nforall a. Num a => a -> a -> a
+t
1)
        else [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
ys (SomeConstraintHandler
yforall a. a -> [a] -> [a]
:[SomeConstraintHandler]
rs) t
n

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

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

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

checkForwardSubsumption :: Solver -> Clause -> IO Bool
checkForwardSubsumption :: Solver -> Clause -> IO Bool
checkForwardSubsumption Solver
solver Clause
lits = do
  Bool
flag <- Config -> Bool
configEnableForwardSubsumptionRemoval 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
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    forall {c}. Bool -> IO c -> IO c
withEnablePhaseSaving Bool
False forall a b. (a -> b) -> a -> b
$ do
      forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
        (Solver -> IO ()
pushDecisionLevel Solver
solver)
        (Solver -> Int -> IO ()
backtrackTo Solver
solver Int
levelRoot) forall a b. (a -> b) -> a -> b
$ do
          Bool
b <- forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (\Int
lit -> Solver -> Int -> IO Bool
assign Solver
solver (Int -> Int
litNot Int
lit)) Clause
lits
          if Bool
b then
            forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Maybe a -> Bool
isJust (Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver)
          else do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode forall a b. (a -> b) -> a -> b
$ Solver -> String -> IO ()
log Solver
solver (String
"forward subsumption: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Clause
lits)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    withEnablePhaseSaving :: Bool -> IO c -> IO c
withEnablePhaseSaving Bool
flag IO c
m =
      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 } forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO c
m)

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

backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy :: Solver -> (PBLinSum, Integer) -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy Solver
solver pb :: (PBLinSum, Integer)
pb@(PBLinSum
lhs,Integer
_) = do
  [HashSet SomeConstraintHandler]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs forall a b. (a -> b) -> a -> b
$ \(Integer
_,Int
lit) -> do
    forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Int -> Int
litIndex Int
lit)
  case [HashSet SomeConstraintHandler]
xs of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HashSet a
HashSet.empty
    HashSet SomeConstraintHandler
s:[HashSet SomeConstraintHandler]
ss -> do
      let p :: a -> IO Bool
p a
c = do
            -- Note that @isPBRepresentable c@ is always True here,
            -- because only such constraints are added to occur list.
            -- See 'addToDB'.
            (PBLinSum, Integer)
pb2 <- forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinAtLeast (Solver -> Int -> IO LBool
getLitFixed Solver
solver) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. ConstraintHandler a => a -> IO (PBLinSum, Integer)
toPBLinAtLeast a
c
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (PBLinSum, Integer) -> (PBLinSum, Integer) -> Bool
pbLinSubsume (PBLinSum, Integer)
pb (PBLinSum, Integer)
pb2
      forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall a. ConstraintHandler a => a -> IO Bool
p
        forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HashSet.toList
        forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 | forall a. HashSet a -> Bool
HashSet.null HashSet SomeConstraintHandler
zs = 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     = 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 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
nforall a. Num a => a -> a -> a
+t
1)
        else [SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
cs (SomeConstraintHandler
cforall a. a -> [a] -> [a]
:[SomeConstraintHandler]
rs) t
n
  [SomeConstraintHandler]
xs <- forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  ([SomeConstraintHandler]
ys,Int
n) <- forall {t}.
Num t =>
[SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
xs [] (Int
0::Int)
  forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNRemovedConstr Solver
solver) (forall a. Num a => a -> a -> a
+Int
n)
  forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver) [SomeConstraintHandler]
ys

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

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

getConfig :: Solver -> IO Config
getConfig :: Solver -> IO Config
getConfig Solver
solver = forall a. IORef a -> IO a
readIORef 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
  forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Config
svConfig Solver
solver) Config
conf
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> BranchingStrategy
configBranchingStrategy Config
orig forall a. Eq a => a -> a -> Bool
/= Config -> BranchingStrategy
configBranchingStrategy Config
conf) 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 forall a b. (a -> b) -> a -> b
$ Config -> Config
f Config
config

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

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

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

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

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

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

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

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

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

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

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

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

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

deduce :: Solver -> IO (Maybe SomeConstraintHandler)
deduce :: Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Solver -> IO Bool
bcpIsEmpty Solver
solver
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty 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 Int
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Solver -> IO (Maybe Int)
bcpDequeue Solver
solver
      case Maybe Int
r of
        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Int
lit -> do
          Int -> ExceptT SomeConstraintHandler IO ()
processLit Int
lit
          Int -> ExceptT SomeConstraintHandler IO ()
processVar Int
lit
          ExceptT SomeConstraintHandler IO ()
loop

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

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

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

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

  IORef (LitSet, (PBLinSum, Integer))
pbConstrRef <- forall a. a -> IO (IORef a)
newIORef forall a. HasCallStack => a
undefined

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

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

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

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

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

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

  Solver -> Clause -> IO ()
incrementReasoned Solver
solver (LitSet -> Clause
IS.toList LitSet
lits2)

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

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

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

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

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

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

  let replay :: [(a, IntMap (t, LBool))] -> t -> m a
replay [] !t
_ = forall a. HasCallStack => String -> a
error String
"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 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [t
c | (Int
_,(t
c,LBool
val)) <- forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (t, LBool)
lv_lits, LBool
val forall a. Eq a => a -> a -> Bool
== LBool
lFalse]
        if t
slack_lv forall a. Ord a => a -> a -> Bool
< t
0 then
          forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- CONFLICT
        else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
_, IntMap (t, LBool)
lits2) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(t
c,LBool
_) -> t
c forall a. Ord a => a -> a -> Bool
> t
slack_lv) (forall a. IntMap a -> [a]
IM.elems IntMap (t, LBool)
lits2)) [(a, IntMap (t, LBool))]
lvs then
          forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- UNIT
        else
          [(a, IntMap (t, LBool))] -> t -> m a
replay [(a, IntMap (t, LBool))]
lvs t
slack_lv

  let initial_slack :: Integer
initial_slack = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (Integer
c,Int
_) <- PBLinSum
lhs] forall a. Num a => a -> a -> a
- Integer
rhs
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Integer
c,Int
_) -> Integer
c forall a. Ord a => a -> a -> Bool
> Integer
initial_slack) PBLinSum
lhs then
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  else do
    forall {t} {m :: * -> *} {a}.
(Ord t, Monad m, Num t) =>
[(a, IntMap (t, LBool))] -> t -> m a
replay (forall a. IntMap a -> [(Int, 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
  Int
ccmin <- Config -> Int
configCCMin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  if Int
ccmin forall a. Ord a => a -> a -> Bool
>= Int
2 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseRecursive Solver
solver LitSet
lits
  else if Int
ccmin forall a. Ord a => a -> a -> Bool
>= Int
1 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseLocal Solver
solver LitSet
lits
  else
    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 :: Clause
xs = LitSet -> Clause
IS.toAscList LitSet
lits
  Clause
ys <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Bool
isRedundant) Clause
xs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode forall a b. (a -> b) -> a -> b
$ do
    Solver -> String -> IO ()
log Solver
solver String
"minimizeConflictClauseLocal:"
    Solver -> String -> IO ()
log Solver
solver forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Clause
xs
    Solver -> String -> IO ()
log Solver
solver forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Clause
ys
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Clause -> LitSet
IS.fromAscList forall a b. (a -> b) -> a -> b
$ Clause
ys

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

    test :: Lit -> IO Bool
    test :: Int -> IO Bool
test Int
lit = do
      Int
lv <- Solver -> Int -> IO Int
litLevel Solver
solver Int
lit
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
lv forall a. Eq a => a -> a -> Bool
== Int
levelRoot Bool -> Bool -> Bool
|| Int
lit Int -> 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 :: Int -> IO Bool
isRedundant Int
lit = do
      Maybe SomeConstraintHandler
c <- Solver -> Int -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver (Int -> Int
litVar Int
lit)
      case Maybe SomeConstraintHandler
c of
        Maybe SomeConstraintHandler
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SomeConstraintHandler
c2 -> do
          Clause
ls <- forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
c2 (forall a. a -> Maybe a
Just (Int -> Int
litNot Int
lit))
          Clause -> LitSet -> IO Bool
go Clause
ls LitSet
IS.empty

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

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

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

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

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

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

pushDecisionLevel :: Solver -> IO ()
pushDecisionLevel :: Solver -> IO ()
pushDecisionLevel Solver
solver = do
  forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec Int
svTrailLimit Solver
solver) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> UVec Int
svTrail Solver
solver)
  Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> 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
  Int
n <- forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO e
Vec.unsafePop (Solver -> UVec Int
svTrailLimit Solver
solver)
  let loop :: IO ()
loop = do
        Int
m <- forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> UVec Int
svTrail Solver
solver)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
m forall a. Ord a => a -> a -> Bool
> Int
n) forall a b. (a -> b) -> a -> b
$ do
          Solver -> IO Int
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
t -> TheorySolver -> IO ()
thPopBacktrackPoint TheorySolver
t

-- | Revert to the state at given level
-- (keeping all assignment at @level@ but not beyond).
backtrackTo :: Solver -> Int -> IO ()
backtrackTo :: Solver -> Int -> IO ()
backtrackTo Solver
solver Int
level = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode forall a b. (a -> b) -> a -> b
$ Solver -> String -> IO ()
log Solver
solver forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"backtrackTo: %d" Int
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
_ -> do
      Int
n <- forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> UVec Int
svTrail Solver
solver)
      forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svTheoryChecked Solver
solver) Int
n
  where
    loop :: IO ()
    loop :: IO ()
loop = do
      Int
lv <- Solver -> IO Int
getDecisionLevel Solver
solver
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lv forall a. Ord a => a -> a -> Bool
> Int
level) 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
  Int
n <- Solver -> IO Int
getNVars Solver
solver
  (IOUArray Int Bool
marr::IOUArray Var Bool) <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n)
  forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
1 (forall a. Ord a => a -> a -> Bool
<=Int
n) (forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ \Int
v -> do
    LBool
val <- Solver -> Int -> IO LBool
varValue Solver
solver Int
v
    forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Int Bool
marr Int
v (forall a. HasCallStack => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val))
  Model
m <- forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze IOUArray Int Bool
marr
  forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe Model)
svModel Solver
solver) (forall a. a -> Maybe a
Just Model
m)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  showConstraintHandler :: a -> IO String

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

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

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

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

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

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

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

  isSatisfied :: Solver -> a -> IO Bool

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

  constrWeight :: Solver -> a -> IO Double
  constrWeight Solver
_ a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Double
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 = 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
  forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c
  Bool
b <- forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable SomeConstraintHandler
c
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b forall a b. (a -> b) -> a -> b
$ do
    (PBLinSum
lhs,Integer
_) <- forall a. ConstraintHandler a => a -> IO (PBLinSum, Integer)
toPBLinAtLeast SomeConstraintHandler
c
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PBLinSum
lhs forall a b. (a -> b) -> a -> b
$ \(Integer
_,Int
lit) -> do
      forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Int -> Int
litIndex Int
lit) (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete SomeConstraintHandler
c)

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

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

isLocked :: Solver -> SomeConstraintHandler -> IO Bool
isLocked :: Solver -> SomeConstraintHandler -> IO Bool
isLocked Solver
solver SomeConstraintHandler
c = 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
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 :: Int -> SomeConstraintHandler -> Int
hashWithSalt Int
s (CHClause ClauseHandler
c)    = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
0::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClauseHandler
c
  hashWithSalt Int
s (CHAtLeast AtLeastHandler
c)   = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` AtLeastHandler
c
  hashWithSalt Int
s (CHPBCounter PBHandlerCounter
c) = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
2::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` PBHandlerCounter
c
  hashWithSalt Int
s (CHPBPueblo PBHandlerPueblo
c)  = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
3::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` PBHandlerPueblo
c
  hashWithSalt Int
s (CHXORClause XORClauseHandler
c) = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
4::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` XORClauseHandler
c
  hashWithSalt Int
s (CHTheory TheoryHandler
c)    = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
5::Int) forall a. Hashable a => Int -> a -> Int
`hashWithSalt` TheoryHandler
c

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

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

  constrAttach :: Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)    = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrAttach Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = 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)    = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrDetach Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = 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)    = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this ClauseHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHAtLeast AtLeastHandler
c)   = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this AtLeastHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHPBCounter PBHandlerCounter
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerCounter
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHPBPueblo PBHandlerPueblo
c)  = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this PBHandlerPueblo
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHXORClause XORClauseHandler
c) = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this XORClauseHandler
c
  constrIsLocked Solver
solver SomeConstraintHandler
this (CHTheory TheoryHandler
c)    = forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this TheoryHandler
c

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode forall a b. (a -> b) -> a -> b
$ do
      Int
litn <- LitArray -> Int -> IO Int
readLitArray LitArray
a Int
n
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
litn forall a. Eq a => a -> a -> Bool
== Int
falsifiedLit) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"AtLeastHandler.constrPropagate: should not happen"

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

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

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

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

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

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

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

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

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

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

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

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

newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
ts Integer
degree Bool
learnt = do
  PBHandlerType
config <- Config -> PBHandlerType
configPBHandlerType 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
      forall (m :: * -> *) a. Monad m => a -> m a
return (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
      forall (m :: * -> *) a. Monad m => a -> m a
return (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 (PBLinSum, Integer) -> Maybe (Clause, Int)
pbToAtLeast (PBLinSum
lhs,Integer
rhs) of
    Maybe (Clause, Int)
Nothing -> Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
lhs Integer
rhs Bool
learnt
    Just (Clause
lhs2, Int
rhs2) -> do
      if Int
rhs2 forall a. Eq a => a -> a -> Bool
/= Int
1 then do
        AtLeastHandler
h <- Clause -> Int -> Bool -> IO AtLeastHandler
newAtLeastHandler Clause
lhs2 Int
rhs2 Bool
learnt
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler AtLeastHandler
h
      else do
        ClauseHandler
h <- Clause -> Bool -> IO ClauseHandler
newClauseHandler Clause
lhs2 Bool
learnt
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
h

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

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

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

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

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

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

instance Hashable PBHandlerCounter where
  hash :: PBHandlerCounter -> Int
hash = PBHandlerCounter -> Int
pbHash
  hashWithSalt :: Int -> PBHandlerCounter -> Int
hashWithSalt = forall a. Hashable a => Int -> a -> Int
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' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) PBLinSum
ts
      slack :: Integer
slack = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst PBLinSum
ts) forall a. Num a => a -> a -> a
- Integer
degree
      m :: LitMap Integer
m = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
l,Integer
c) | (Integer
c,Int
l) <- PBLinSum
ts]
  IORef Integer
s <- forall a. a -> IO (IORef a)
newIORef Integer
slack
  IORef Double
act <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then Double
0 else -Double
1)
  forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
-> Integer
-> LitMap Integer
-> Integer
-> IORef Integer
-> IORef Double
-> Int
-> PBHandlerCounter
PBHandlerCounter PBLinSum
ts' Integer
degree LitMap Integer
m Integer
slack IORef Integer
s IORef Double
act (forall a. Hashable a => a -> Int
hash (PBLinSum
ts,Integer
degree)))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    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 <- forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this2)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LitSet -> Clause
IS.toList LitSet
ws) forall a b. (a -> b) -> a -> b
$ \Int
l -> do
      Solver -> Int -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver Int
l SomeConstraintHandler
this

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

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

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

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

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

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

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

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

  constrWriteActivity :: PBHandlerPueblo -> Double -> IO ()
constrWriteActivity PBHandlerPueblo
this Double
aval = forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerPueblo -> IORef Double
puebloActivity PBHandlerPueblo
this) forall a b. (a -> b) -> a -> b
$! Double
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 forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this forall a. Ord a => a -> a -> Bool
<= Integer
watchsum then
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else if Integer
watchsum forall a. Ord a => a -> a -> Bool
< PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then do
    -- CONFLICT
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this
    -- UNIT PROPAGATION
    let f :: PBLinSum -> IO Bool
f [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        f ((Integer
c,Int
lit) : PBLinSum
ts) = do
          Integer
watchsum' <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this
          if Integer
watchsum' forall a. Num a => a -> a -> a
- Integer
c forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else do
            LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val forall a. Eq a => a -> a -> Bool
== LBool
lUndef) forall a b. (a -> b) -> a -> b
$ do
              Bool
b <- Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
lit SomeConstraintHandler
constr
              forall a. HasCallStack => Bool -> a -> a
assert Bool
b forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
            PBLinSum -> IO Bool
f PBLinSum
ts
    PBLinSum -> IO Bool
f 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      f (t :: (Integer, Int)
t@(Integer
_,Int
lit):PBLinSum
ts) = do
        Integer
watchSum <- PBHandlerPueblo -> IO Integer
puebloGetWatchSum PBHandlerPueblo
this
        if Integer
watchSum forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this then
          forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
          Bool
watched <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int
lit Int -> LitSet -> Bool
`IS.member`) forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val forall a. Eq a => a -> a -> Bool
/= LBool
lFalse Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
watched) forall a b. (a -> b) -> a -> b
$ do
            Solver
-> SomeConstraintHandler
-> PBHandlerPueblo
-> (Integer, Int)
-> IO ()
puebloWatch Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this (Integer, Int)
t
          PBLinSum -> IO ()
f PBLinSum
ts
  PBLinSum -> IO ()
f (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  toPBLinAtLeast :: XORClauseHandler -> IO (PBLinSum, Integer)
toPBLinAtLeast XORClauseHandler
_ = forall a. HasCallStack => String -> a
error String
"XORClauseHandler does not support toPBLinAtLeast"

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

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

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

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

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

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

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

  Maybe TheorySolver
m <- forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)
  case Maybe TheorySolver
m of
    Just TheorySolver
_ -> do
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"ToySolver.SAT.setTheory: cannot replace TheorySolver"
    Maybe TheorySolver
Nothing -> do
      forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver) (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 -> 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 = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe TheorySolver)
svTheorySolver Solver
solver)
  case Maybe TheorySolver
mt of
    Maybe TheorySolver
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just TheorySolver
t -> do
      Int
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> UVec Int
svTrail Solver
solver)
      let h :: SomeConstraintHandler
h = TheoryHandler -> SomeConstraintHandler
CHTheory TheoryHandler
TheoryHandler
          callback :: Int -> IO Bool
callback Int
l = Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
l SomeConstraintHandler
h
          loop :: Int -> ExceptT SomeConstraintHandler m ()
loop Int
i = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
< Int
n) forall a b. (a -> b) -> a -> b
$ do
              Int
l <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> UVec Int
svTrail Solver
solver) Int
i
              Bool
ok <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TheorySolver -> (Int -> IO Bool) -> Int -> IO Bool
thAssertLit TheorySolver
t Int -> IO Bool
callback Int
l
              if Bool
ok then
                Int -> ExceptT SomeConstraintHandler m ()
loop (Int
iforall a. Num a => a -> a -> a
+Int
1)
              else
                forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SomeConstraintHandler
h
      forall {m :: * -> *}.
MonadIO m =>
Int -> ExceptT SomeConstraintHandler m ()
loop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svTheoryChecked Solver
solver))
      Bool
b2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TheorySolver -> (Int -> IO Bool) -> IO Bool
thCheck TheorySolver
t Int -> IO Bool
callback
      if Bool
b2 then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svTheoryChecked Solver
solver) Int
n
      else
        forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SomeConstraintHandler
h

data TheoryHandler = TheoryHandler deriving (TheoryHandler -> TheoryHandler -> Bool
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 -> Int
hash TheoryHandler
_ = forall a. Hashable a => a -> Int
hash ()
  hashWithSalt :: Int -> TheoryHandler -> Int
hashWithSalt = forall a. Hashable a => Int -> a -> Int
defaultHashWithSalt

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

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

  constrAttach :: Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
constrAttach Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 = forall a. HasCallStack => String -> a
error String
"TheoryHandler.constrAttach"

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

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

  constrPropagate :: Solver -> SomeConstraintHandler -> TheoryHandler -> Int -> IO Bool
constrPropagate Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 Int
_falsifiedLit =  forall a. HasCallStack => String -> a
error String
"TheoryHandler.constrPropagate"

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

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

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

  toPBLinAtLeast :: TheoryHandler -> IO (PBLinSum, Integer)
toPBLinAtLeast TheoryHandler
_this = forall a. HasCallStack => String -> a
error String
"TheoryHandler.toPBLinAtLeast"

  isSatisfied :: Solver -> TheoryHandler -> IO Bool
isSatisfied Solver
_solver TheoryHandler
_this = forall a. HasCallStack => String -> a
error String
"TheoryHandler.isSatisfied"

  constrIsProtected :: Solver -> TheoryHandler -> IO Bool
constrIsProtected Solver
_solver TheoryHandler
_this = forall a. HasCallStack => String -> a
error String
"TheoryHandler.constrIsProtected"

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

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

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

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

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

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

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

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

{-
  Finite subsequences of the Luby-sequence:

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


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

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

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


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

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p = [a] -> m Bool
go
  where
    go :: [a] -> m Bool
go [] = 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 forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
p = [a] -> m Bool
go
  where
    go :: [a] -> m Bool
go [] = 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 forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else [a] -> m Bool
go [a]
xs

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

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

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

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

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

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

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

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

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

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

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