{-# 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
  -- ** Type-2 SOS constraints
  , addSOS2
  , evalSOS2
  -- ** 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)
#if !MIN_VERSION_hashable(1,4,3)
import Data.Bits (xor) -- for defining 'combine' function
#endif
import Data.Coerce
import Data.Default.Class
import Data.Either
import Data.Function (on)
import Data.Hashable
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.IORef
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import qualified Data.Set as Set
import ToySolver.Internal.Data.IOURef
import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ
import qualified ToySolver.Internal.Data.Vec as Vec
import Data.Typeable
import System.Clock
import qualified System.Random.MWC as Rand
import Text.Printf

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

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

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

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

newLitArray :: [Lit] -> IO LitArray
newLitArray :: Clause -> IO LitArray
newLitArray Clause
lits = do
  let size :: Int
size = Clause -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Clause
lits
  (IOUArray Int PackedLit -> LitArray)
-> IO (IOUArray Int PackedLit) -> IO LitArray
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM IOUArray Int PackedLit -> LitArray
LitArray (IO (IOUArray Int PackedLit) -> IO LitArray)
-> IO (IOUArray Int PackedLit) -> IO LitArray
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [PackedLit] -> IO (IOUArray Int PackedLit)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (Int
0, Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ((Int -> PackedLit) -> Clause -> [PackedLit]
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 = (PackedLit -> Int) -> IO PackedLit -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PackedLit -> Int
unpackLit (IO PackedLit -> IO Int) -> IO PackedLit -> IO Int
forall a b. (a -> b) -> a -> b
$ IOUArray Int PackedLit -> Int -> IO PackedLit
forall i. Ix i => IOUArray i PackedLit -> Int -> IO PackedLit
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 = IOUArray Int PackedLit -> Int -> PackedLit -> IO ()
forall i. Ix i => IOUArray i PackedLit -> Int -> PackedLit -> IO ()
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) = ([PackedLit] -> Clause) -> IO [PackedLit] -> IO Clause
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((PackedLit -> Int) -> [PackedLit] -> Clause
forall a b. (a -> b) -> [a] -> [b]
map PackedLit -> Int
unpackLit) (IO [PackedLit] -> IO Clause) -> IO [PackedLit] -> IO Clause
forall a b. (a -> b) -> a -> b
$ IOUArray Int PackedLit -> IO [PackedLit]
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) <- IOUArray Int PackedLit -> IO (Int, Int)
forall i. Ix i => IOUArray i PackedLit -> IO (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOUArray Int PackedLit
a
  Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
lb Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! Int
ubInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lbInt -> Int -> Int
forall 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int -> Int
litVar Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
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 = (Int8 -> LBool) -> IO Int8 -> IO LBool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int8 -> LBool
forall a b. Coercible a b => a -> b
coerce (IO Int8 -> IO LBool) -> IO Int8 -> IO LBool
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Int8 -> Int -> IO Int8
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) (Int
v Int -> Int -> Int
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 (Int -> Int
forall a. Num a => a -> a
negate Int
l)
    LBool -> IO LBool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LBool -> IO LBool) -> LBool -> IO LBool
forall a b. (a -> b) -> a -> b
$! LBool -> LBool
lnot LBool
m

getVarFixed :: Solver -> Var -> IO LBool
getVarFixed :: Solver -> Int -> IO LBool
getVarFixed Solver
solver !Int
v = do
  Int
lv <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarLevel Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  if Int
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot then
    Solver -> Int -> IO LBool
varValue Solver
solver Int
v
  else
    LBool -> IO LBool
forall a. a -> IO a
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 (Int -> Int
forall a. Num a => a -> a
negate Int
l)
    LBool -> IO LBool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LBool -> IO LBool) -> LBool -> IO LBool
forall a b. (a -> b) -> a -> b
$! LBool -> LBool
lnot LBool
m

getNFixed :: Solver -> IO Int
getNFixed :: Solver -> IO Int
getNFixed Solver
solver = do
  Int
lv <- Solver -> IO Int
getDecisionLevel Solver
solver
  if Int
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot then
    GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
  else
    GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray 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
  (Int -> IO Int) -> Clause -> IO Clause
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
revMapM (GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)) [Int
0..Int
nInt -> Int -> Int
forall 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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String
"ToySolver.SAT.varLevel: unassigned var " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v)
  GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarLevel Solver
solver) (Int
v Int -> Int -> Int
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String
"ToySolver.SAT.varReason: unassigned var " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v)
  GenericVec IOArray (Maybe SomeConstraintHandler)
-> Int -> IO (Maybe SomeConstraintHandler)
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) (Int
v Int -> Int -> Int
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String
"ToySolver.SAT.varAssignNo: unassigned var " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v)
  GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarTrailIndex Solver
solver) (Int
v Int -> Int -> Int
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 -> GenericVec IOUArray Int
svTrail        :: !(Vec.UVec Lit)
  , Solver -> GenericVec IOUArray Int
svTrailLimit   :: !(Vec.UVec Lit)
  , Solver -> IOURef Int
svTrailNPropagated :: !(IOURef Int)

  -- variable information
  , Solver -> GenericVec IOUArray Int8
svVarValue      :: !(Vec.UVec Int8) -- should be 'Vec.UVec LBool' but it's difficult to define MArray instance
  , Solver -> UVec Bool
svVarPolarity   :: !(Vec.UVec Bool)
  , Solver -> UVec Double
svVarActivity   :: !(Vec.UVec VarActivity)
  , Solver -> GenericVec IOUArray Int
svVarTrailIndex :: !(Vec.UVec Int)
  , Solver -> GenericVec IOUArray 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 -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason       :: !(Vec.Vec (Maybe SomeConstraintHandler))
  -- | exponential moving average estimate
  , Solver -> UVec Double
svVarEMAScaled    :: !(Vec.UVec Double)
  -- | When v was last assigned
  , Solver -> GenericVec IOUArray Int
svVarWhenAssigned :: !(Vec.UVec Int)
  -- | The number of learnt clauses v participated in generating since Assigned.
  , Solver -> GenericVec IOUArray Int
svVarParticipated :: !(Vec.UVec Int)
  -- | The number of learnt clauses v reasoned in generating since Assigned.
  , Solver -> GenericVec IOUArray 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 -> GenericVec IOUArray 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
  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svOk Solver
solver) Bool
False
  Solver -> IO ()
bcpClear Solver
solver

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

bcpIsEmpty :: Solver -> IO Bool
bcpIsEmpty :: Solver -> IO Bool
bcpIsEmpty Solver
solver = do
  Int
p <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svTrailNPropagated Solver
solver)
  Int
n <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Bool
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
empty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
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 <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
  IOURef Int -> Int -> IO ()
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot
            then Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
            else SomeConstraintHandler -> Maybe SomeConstraintHandler
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 Maybe SomeConstraintHandler
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 = Bool -> IO Bool -> IO Bool
forall a. HasCallStack => Bool -> a -> a
assert (Int -> Bool
validLit Int
lit) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef then do
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val0
  else do
    Int
idx <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
    Int
lv <- Solver -> IO Int
getDecisionLevel Solver
solver

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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
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"
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"assign(level=%d): %d%s" Int
lv Int
lit String
r

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

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

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

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

  -- ERWA / LRB computation
  Int
interval <- do
    Int
t2 <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svLearntCounter Solver
solver)
    Int
t1 <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarWhenAssigned Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
t2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t1)
  -- Interval = 0 is possible due to restarts.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
interval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Int
participated <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarParticipated Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Int
reasoned <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svVarReasoned Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Double
alpha <- IOURef Double -> IO Double
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Double
svERWAStepSize Solver
solver)
    let learningRate :: Double
learningRate = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
participated Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
interval
        reasonSideRate :: Double
reasonSideRate = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
reasoned Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
interval
    Double
scale <- IOURef Double -> IO Double
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Double
svEMAScale Solver
solver)
    -- ema := (1 - α)ema + α*r
    UVec Double -> Int -> (Double -> Double) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> UVec Double
svVarEMAScaled Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (\Double
orig -> (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
alpha) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
orig Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
learningRate Double -> Double -> Double
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then Int
v else -Int
v
  [SomeConstraintHandler]
cs <- Vec [SomeConstraintHandler] -> Int -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Vec [SomeConstraintHandler]
-> Int -> [SomeConstraintHandler] -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> e -> IO ()
Vec.unsafeWrite (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) []
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
cs ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c ->
    Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Int -> IO ()
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> Int -> IO ()
constrOnUnassigned Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c Int
l

  PriorityQueue -> Int -> IO ()
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)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"addOnUnassigned: should not happen"
  Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (SomeConstraintHandler
constr SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:)

-- | Register the constraint to be notified when the literal becames false.
watchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
watchLit :: Solver -> Int -> SomeConstraintHandler -> IO ()
watchLit Solver
solver !Int
lit SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
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 SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: )

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

unwatchLit :: Solver -> Lit -> SomeConstraintHandler -> IO ()
unwatchLit :: Solver -> Int -> SomeConstraintHandler -> IO ()
unwatchLit Solver
solver !Int
lit SomeConstraintHandler
c = Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
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
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
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 = Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) (Int
var Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
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 = c -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler c
c
  IORef [SomeConstraintHandler]
-> ([SomeConstraintHandler] -> [SomeConstraintHandler]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver) (SomeConstraintHandler
c2 SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: )
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
str <- c -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler c
c
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"constraint %s is added" String
str

  Bool
b <- c -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable c
c
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (PBLinSum
lhs,Integer
_) <- c -> IO (PBLinSum, Integer)
forall a. ConstraintHandler a => a -> IO (PBLinSum, Integer)
toPBLinAtLeast c
c
    PBLinSum -> ((Integer, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PBLinSum
lhs (((Integer, Int) -> IO ()) -> IO ())
-> ((Integer, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Int
lit) -> do
       Vec (HashSet SomeConstraintHandler)
-> Int
-> (HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler)
-> IO ()
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) (SomeConstraintHandler
-> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert SomeConstraintHandler
c2)

addToLearntDB :: ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB :: forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver c
c = do
  IORef (Int, [SomeConstraintHandler])
-> ((Int, [SomeConstraintHandler])
    -> (Int, [SomeConstraintHandler]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver) (((Int, [SomeConstraintHandler]) -> (Int, [SomeConstraintHandler]))
 -> IO ())
-> ((Int, [SomeConstraintHandler])
    -> (Int, [SomeConstraintHandler]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
n,[SomeConstraintHandler]
xs) -> (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, c -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler c
c SomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
: [SomeConstraintHandler]
xs)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
str <- c -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler c
c
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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) <- IORef (Int, [SomeConstraintHandler])
-> IO (Int, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver)

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

  -- Note that False <= True
  let ys :: [(SomeConstraintHandler, (Bool, Double))]
ys = ((SomeConstraintHandler, (Bool, Double))
 -> (SomeConstraintHandler, (Bool, Double)) -> Ordering)
-> [(SomeConstraintHandler, (Bool, Double))]
-> [(SomeConstraintHandler, (Bool, Double))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((SomeConstraintHandler, (Bool, Double)) -> (Bool, Double))
-> (SomeConstraintHandler, (Bool, Double))
-> (SomeConstraintHandler, (Bool, Double))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (SomeConstraintHandler, (Bool, Double)) -> (Bool, Double)
forall a b. (a, b) -> b
snd) [(SomeConstraintHandler, (Bool, Double))]
xs
      ([(SomeConstraintHandler, (Bool, Double))]
zs,[(SomeConstraintHandler, (Bool, Double))]
ws) = Int
-> [(SomeConstraintHandler, (Bool, Double))]
-> ([(SomeConstraintHandler, (Bool, Double))],
    [(SomeConstraintHandler, (Bool, Double))])
forall a. Int -> [a] -> ([a], [a])
splitAt ([(SomeConstraintHandler, (Bool, Double))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SomeConstraintHandler, (Bool, Double))]
ys Int -> Int -> Int
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 = [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeConstraintHandler]
ret
      loop ((SomeConstraintHandler
c,(Bool
isShort,b
_)) : [(SomeConstraintHandler, (Bool, b))]
rest) [SomeConstraintHandler]
ret = do
        Bool
flag <- if Bool
isShort
                then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Solver -> SomeConstraintHandler -> IO Bool
isLocked Solver
solver SomeConstraintHandler
c
        if Bool
flag then
          [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, b))]
rest (SomeConstraintHandler
cSomeConstraintHandler
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. a -> [a] -> [a]
:[SomeConstraintHandler]
ret)
        else do
          Solver -> SomeConstraintHandler -> IO ()
detach Solver
solver SomeConstraintHandler
c
          [(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, b))]
rest [SomeConstraintHandler]
ret
  [SomeConstraintHandler]
zs2 <- [(SomeConstraintHandler, (Bool, Double))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall {b}.
[(SomeConstraintHandler, (Bool, b))]
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
loop [(SomeConstraintHandler, (Bool, Double))]
zs []

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

  -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2
  IORef (Int, [SomeConstraintHandler])
-> (Int, [SomeConstraintHandler]) -> IO ()
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 = UVec Double -> Int -> IO Double
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> UVec Double
svVarActivity Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

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

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

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

varIncrementReasoned :: Solver -> Var -> IO ()
varIncrementReasoned :: Solver -> Int -> IO ()
varIncrementReasoned Solver
solver Int
v = GenericVec IOUArray Int -> Int -> (Int -> Int) -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> GenericVec IOUArray Int
svVarReasoned Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Int -> Int
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 <- IOURef Double -> IO Double
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
alpha Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
alphaMin) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IOURef Double -> Double -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Double
svERWAStepSize Solver
solver) (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
alphaMin (Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
- Config -> Double
configERWAStepSizeDec Config
config))

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

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

-- | number of constraints.
getNConstraints :: Solver -> IO Int
getNConstraints :: Solver -> IO Int
getNConstraints Solver
solver = do
  [SomeConstraintHandler]
xs <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [SomeConstraintHandler] -> Int
forall a. [a] -> Int
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]
_) <- IORef (Int, [SomeConstraintHandler])
-> IO (Int, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver)
  Int -> IO Int
forall a. a -> IO a
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) <- IORef (Int, [SomeConstraintHandler])
-> IO (Int, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver)
  [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [SomeConstraintHandler]
cs

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  IOURef Double
alpha <- Double -> IO (IOURef Double)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Double
0.4
  IOURef Double
emaScale <- Double -> IO (IOURef Double)
forall a. MArray IOUArray a IO => a -> IO (IOURef a)
newIOURef Double
1.0
  IOURef Int
learntCounter <- Int -> IO (IOURef Int)
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 :: GenericVec IOUArray Int
svTrail      = GenericVec IOUArray Int
trail
        , svTrailLimit :: GenericVec IOUArray Int
svTrailLimit = GenericVec IOUArray Int
trail_lim
        , svTrailNPropagated :: IOURef Int
svTrailNPropagated = IOURef Int
trail_nprop

        , svVarValue :: GenericVec IOUArray Int8
svVarValue        = GenericVec IOUArray Int8
varValue
        , svVarPolarity :: UVec Bool
svVarPolarity     = UVec Bool
varPolarity
        , svVarActivity :: UVec Double
svVarActivity     = UVec Double
varActivity
        , svVarTrailIndex :: GenericVec IOUArray Int
svVarTrailIndex   = GenericVec IOUArray Int
varTrailIndex
        , svVarLevel :: GenericVec IOUArray Int
svVarLevel        = GenericVec IOUArray Int
varLevel
        , svVarWatches :: Vec [SomeConstraintHandler]
svVarWatches      = Vec [SomeConstraintHandler]
varWatches
        , svVarOnUnassigned :: Vec [SomeConstraintHandler]
svVarOnUnassigned = Vec [SomeConstraintHandler]
varOnUnassigned
        , svVarReason :: GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason       = GenericVec IOArray (Maybe SomeConstraintHandler)
varReason
        , svVarEMAScaled :: UVec Double
svVarEMAScaled    = UVec Double
varEMAScaled
        , svVarWhenAssigned :: GenericVec IOUArray Int
svVarWhenAssigned = GenericVec IOUArray Int
varWhenAssigned
        , svVarParticipated :: GenericVec IOUArray Int
svVarParticipated = GenericVec IOUArray Int
varParticipated
        , svVarReasoned :: GenericVec IOUArray Int
svVarReasoned     = GenericVec IOUArray 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)
IORef GenIO
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 :: GenericVec IOUArray Int
svAssumptions     = GenericVec IOUArray 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
        }
 Solver -> IO Solver
forall a. a -> IO a
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
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Double
a1 Double -> Double -> Bool
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
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Double
a1 Double -> Double -> Bool
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 <- GenericVec IOUArray Int8 -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver)
#if SIZEOF_HSINT > 4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== PackedLit -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"cannot allocate more variables"
#endif
    let v :: Int
v = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

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

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

    PriorityQueue -> Int -> IO ()
forall q (m :: * -> *) a. Enqueue q m a => q -> a -> m ()
PQ.enqueue (Solver -> PriorityQueue
svVarQueue Solver
solver) Int
v
    UVec Bool -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> UVec Bool
svSeen Solver
solver) Bool
False
    Int -> IO Int
forall a. a -> IO a
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> PackedLit -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"cannot allocate more variables"
#endif
    Solver -> Int -> IO ()
resizeVarCapacity Solver
solver (Int
nvInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
    Int -> IO Int -> IO Clause
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Solver -> IO Int
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> PackedLit -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedLit
forall a. Bounded a => a
maxBound :: PackedLit)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"cannot allocate more variables"
#endif
    Solver -> Int -> IO ()
resizeVarCapacity Solver
solver (Int
nvInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
    Int -> IO Int -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n (Solver -> IO Int
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
  GenericVec IOUArray Int8 -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int8
svVarValue Solver
solver) Int
n
  UVec Bool -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> UVec Bool
svVarPolarity Solver
solver) Int
n
  UVec Double -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> UVec Double
svVarActivity Solver
solver) Int
n
  GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int
svVarTrailIndex Solver
solver) Int
n
  GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int
svVarLevel Solver
solver) Int
n
  Vec [SomeConstraintHandler] -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Int
n
  Vec [SomeConstraintHandler] -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svVarOnUnassigned Solver
solver) Int
n
  GenericVec IOArray (Maybe SomeConstraintHandler) -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOArray (Maybe SomeConstraintHandler)
svVarReason Solver
solver) Int
n
  UVec Double -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> UVec Double
svVarEMAScaled Solver
solver) Int
n
  GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int
svVarWhenAssigned Solver
solver) Int
n
  GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int
svVarParticipated Solver
solver) Int
n
  GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> GenericVec IOUArray Int
svVarReasoned Solver
solver) Int
n
  Vec [SomeConstraintHandler] -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> Vec [SomeConstraintHandler]
svLitWatches Solver
solver) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)
  Vec (HashSet SomeConstraintHandler) -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO ()
Vec.resizeCapacity (Solver -> Vec (HashSet SomeConstraintHandler)
svLitOccurList Solver
solver) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)
  UVec Bool -> Int -> IO ()
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
nInt -> Int -> Int
forall 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
    Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe Clause
m <- (Int -> IO LBool) -> Clause -> IO (Maybe Clause)
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 (Clause -> Maybe Clause) -> Maybe Clause -> Maybe Clause
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Clause
m of
        Maybe Clause
Nothing -> () -> IO ()
forall a. a -> IO a
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
          Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
          case Maybe SomeConstraintHandler
ret2 of
            Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall a. a -> IO a
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
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
subsumed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Solver -> (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
            Solver -> ClauseHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver ClauseHandler
clause
            Bool
_ <- Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
clause
            () -> IO ()
forall a. a -> IO a
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
    Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Clause
lits',Int
n') <- ((Clause, Int) -> (Clause, Int))
-> IO (Clause, Int) -> IO (Clause, Int)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Clause, Int) -> (Clause, Int)
normalizeAtLeast (IO (Clause, Int) -> IO (Clause, Int))
-> IO (Clause, Int) -> IO (Clause, Int)
forall a b. (a -> b) -> a -> b
$ (Int -> IO LBool) -> (Clause, Int) -> IO (Clause, Int)
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 = Clause -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Clause
lits'

      if Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else if Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len then Solver -> IO ()
markBad Solver
solver
      else if Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Solver -> Clause -> IO ()
forall (m :: * -> *) a. AddClause m a => a -> Clause -> m ()
addClause Solver
solver Clause
lits'
      else if Int
n' Int -> Int -> Bool
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'. -}
        Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Clause
lits' ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
l -> do
          Bool
ret <- Solver -> Int -> IO Bool
assign Solver
solver Int
l
          Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
        case Maybe SomeConstraintHandler
ret2 of
          Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall a. a -> IO a
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'], Int -> Integer
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
        Solver -> AtLeastHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver AtLeastHandler
c
        Bool
_ <- Solver -> AtLeastHandler -> IO Bool
basicAttachAtLeastHandler Solver
solver AtLeastHandler
c
        () -> IO ()
forall a. a -> IO a
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
    Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (PBLinSum
ts',Integer
n') <- ((PBLinSum, Integer) -> (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinAtLeast (IO (PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a b. (a -> b) -> a -> b
$ (Int -> IO LBool) -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
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') -> Solver -> Clause -> Int -> IO ()
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 = ((Integer, Int) -> Integer) -> PBLinSum -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Int) -> Integer
forall a b. (a, b) -> a
fst PBLinSum
ts'
              slack :: Integer
slack = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
cs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n'
          if Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else if Integer
slack Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Solver -> IO ()
markBad Solver
solver
          else do
            Solver -> (PBLinSum, Integer) -> IO ()
removeBackwardSubsumedBy Solver
solver (PBLinSum
ts', Integer
n')
            (PBLinSum
ts'',Integer
n'') <- do
              Bool
b <- Config -> Bool
configEnablePBSplitClausePart (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
              if Bool
b
              then Solver -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
pbSplitClausePart Solver
solver (PBLinSum
ts',Integer
n')
              else (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
ts',Integer
n')

            SomeConstraintHandler
c <- Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandler Solver
solver PBLinSum
ts'' Integer
n'' Bool
False
            let constr :: SomeConstraintHandler
constr = SomeConstraintHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler SomeConstraintHandler
c
            Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver SomeConstraintHandler
constr
            Bool
ret <- Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
constr
            if Bool -> Bool
not Bool
ret then do
              Solver -> IO ()
markBad Solver
solver
            else do
              Maybe SomeConstraintHandler
ret2 <- Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver
              case Maybe SomeConstraintHandler
ret2 of
                Maybe SomeConstraintHandler
Nothing -> () -> IO ()
forall a. a -> IO a
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) <- ((PBLinSum, Integer) -> (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinExactly (IO (PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a b. (a -> b) -> a -> b
$ (Int -> IO LBool) -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinExactly (Solver -> Int -> IO LBool
getLitFixed Solver
solver) (PBLinSum
ts,Integer
n)
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver PBLinSum
ts2 Integer
n2
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtMost Solver
solver PBLinSum
ts2 Integer
n2

  addPBAtLeastSoft :: Solver -> Lit -> PBLinSum -> Integer -> IO ()
  addPBAtLeastSoft :: Solver -> Int -> PBLinSum -> Integer -> IO ()
addPBAtLeastSoft Solver
solver Int
sel PBLinSum
lhs Integer
rhs = do
    (PBLinSum
lhs', Integer
rhs') <- ((PBLinSum, Integer) -> (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinAtLeast (IO (PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a b. (a -> b) -> a -> b
$ (Int -> IO LBool) -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinAtLeast (Solver -> Int -> IO LBool
getLitFixed Solver
solver) (PBLinSum
lhs,Integer
rhs)
    Solver -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> PBLinSum -> Integer -> m ()
addPBAtLeast Solver
solver ((Integer
rhs', Int -> Int
litNot Int
sel) (Integer, Int) -> PBLinSum -> PBLinSum
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) <- ((PBLinSum, Integer) -> (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PBLinSum, Integer) -> (PBLinSum, Integer)
normalizePBLinExactly (IO (PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a b. (a -> b) -> a -> b
$ (Int -> IO LBool) -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinExactly (Solver -> Int -> IO LBool
getLitFixed Solver
solver) (PBLinSum
lhs,Integer
rhs)
    Solver -> Int -> PBLinSum -> Integer -> IO ()
forall (m :: * -> *) a.
AddPBLin m a =>
a -> Int -> PBLinSum -> Integer -> m ()
addPBAtLeastSoft Solver
solver Int
sel PBLinSum
lhs2 Integer
rhs2
    Solver -> Int -> PBLinSum -> Integer -> IO ()
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) = ((Integer, Int) -> Bool) -> PBLinSum -> (PBLinSum, PBLinSum)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Integer
c,Int
_) -> Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
rhs) PBLinSum
lhs
  if PBLinSum -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PBLinSum
ts1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then
    (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PBLinSum
lhs,Integer
rhs)
  else do
    Int
sel <- Solver -> IO Int
forall (m :: * -> *) a. NewVar m a => a -> m Int
newVar Solver
solver
    Solver -> Clause -> IO ()
forall (m :: * -> *) a. AddClause m a => a -> Clause -> m ()
addClause Solver
solver (Clause -> IO ()) -> Clause -> IO ()
forall a b. (a -> b) -> a -> b
$ -Int
sel Int -> Clause -> Clause
forall a. a -> [a] -> [a]
: [Int
l | (Integer
_,Int
l) <- PBLinSum
ts1]
    (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
rhs,Int
sel) (Integer, Int) -> PBLinSum -> PBLinSum
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
    Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Bool
ok <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svOk Solver
solver)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      XORClause
xcl <- (Int -> IO LBool) -> XORClause -> IO XORClause
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) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ([Int
l], Bool
b) -> Solver -> Clause -> IO ()
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) Int -> Clause -> Clause
forall a. a -> [a] -> [a]
: Clause
ls) Bool
False
          Solver -> XORClauseHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToDB Solver
solver XORClauseHandler
c
          Bool
_ <- Solver -> XORClauseHandler -> IO Bool
basicAttachXORClauseHandler Solver
solver XORClauseHandler
c
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | Solve constraints.
-- Returns 'True' if the problem is SATISFIABLE.
-- Returns 'False' if the problem is UNSATISFIABLE.
solve :: Solver -> IO Bool
solve :: Solver -> IO Bool
solve Solver
solver = do
  GenericVec IOUArray Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO ()
Vec.clear (Solver -> GenericVec IOUArray 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
  GenericVec IOUArray Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO ()
Vec.clear (Solver -> GenericVec IOUArray Int
svAssumptions Solver
solver)
  (Int -> IO ()) -> Clause -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push (Solver -> GenericVec IOUArray 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
  IORef LitSet -> LitSet -> IO ()
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
  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
False
  IORef (Maybe Model) -> Maybe Model -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe Model)
svModel Solver
solver) Maybe Model
forall a. Maybe a
Nothing
  IORef LitSet -> LitSet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svFailedAssumptions Solver
solver) LitSet
IS.empty

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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Double
configRestartInc Config
config Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"RestartInc must be >1"
    let restartSeq :: Clause
restartSeq =
          if Config -> Int
configRestartFirst Config
config  Int -> Int -> Bool
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 Int -> Clause
forall a. a -> [a]
repeat Int
0

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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> Double
configERWAStepSizeFirst Config
config Bool -> Bool -> Bool
&& Config -> Double
configERWAStepSizeFirst Config
config Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"ERWAStepSizeFirst must be in [0..1]"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> Double
configERWAStepSizeMin Config
config Bool -> Bool -> Bool
&& Config -> Double
configERWAStepSizeFirst Config
config Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"ERWAStepSizeMin must be in [0..1]"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> Double
configERWAStepSizeDec Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall a. HasCallStack => String -> a
error String
"ERWAStepSizeDec must be >=0"
    IOURef Double -> Double -> IO ()
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 [] = String -> IO (Either a Bool)
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 -> Either a Bool -> IO (Either a Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either a Bool
forall a b. b -> Either a b
Right Bool
x
            SearchResult
SRBudgetExceeded -> Either a Bool -> IO (Either a Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ a -> Either a Bool
forall a b. a -> Either a b
Left (BudgetExceeded -> a
forall a e. Exception e => e -> a
throw BudgetExceeded
BudgetExceeded)
            SearchResult
SRCanceled -> Either a Bool -> IO (Either a Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a Bool -> IO (Either a Bool))
-> Either a Bool -> IO (Either a Bool)
forall a b. (a -> b) -> a -> b
$ a -> Either a Bool
forall a b. a -> Either a b
Left (Canceled -> a
forall a e. Exception e => e -> a
throw Canceled
Canceled)
            SearchResult
SRRestart -> do
              IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNRestart Solver
solver) (Int -> Int -> Int
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
    IORef TimeSpec -> TimeSpec -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef TimeSpec
svStartWC Solver
solver) TimeSpec
startWC
    Either (IO Bool) Bool
result <- Clause -> IO (Either (IO Bool) Bool)
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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configCheckModel Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
checkSatisfied Solver
solver
        Solver -> IO ()
constructModel Solver
solver
        Maybe TheorySolver
mt <- Solver -> IO (Maybe TheorySolver)
getTheory Solver
solver
        case Maybe TheorySolver
mt of
          Maybe TheorySolver
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just TheorySolver
t -> TheorySolver -> IO ()
thConstructModel TheorySolver
t
      Either (IO Bool) Bool
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Either (IO Bool) Bool
result of
      Right Bool
False -> () -> IO ()
forall a. a -> IO a
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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
dumpVarActivity Solver
solver
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO ()
dumpConstrActivity Solver
solver
    Solver -> Bool -> IO ()
printStat Solver
solver Bool
True
    let durationSecs :: TimeSpec -> TimeSpec -> Double
        durationSecs :: TimeSpec -> TimeSpec -> Double
durationSecs TimeSpec
start TimeSpec
end = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs (TimeSpec
end TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
start)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
9::Int)
    (Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> (Double -> String) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
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 (String -> IO ()) -> (Double -> String) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
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 (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"#decision = %d") (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNDecision Solver
solver)
    (Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"#random_decision = %d") (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNRandomDecision Solver
solver)
    (Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"#conflict = %d") (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNConflict Solver
solver)
    (Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"#restart = %d")  (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOURef Int -> IO Int
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  -> Bool -> IO Bool
forall a. a -> IO a
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
(Int -> BudgetExceeded -> String -> String)
-> (BudgetExceeded -> String)
-> ([BudgetExceeded] -> String -> String)
-> Show BudgetExceeded
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BudgetExceeded -> String -> String
showsPrec :: Int -> BudgetExceeded -> String -> String
$cshow :: BudgetExceeded -> String
show :: BudgetExceeded -> String
$cshowList :: [BudgetExceeded] -> String -> String
showList :: [BudgetExceeded] -> String -> String
Show, Typeable)

instance Exception BudgetExceeded

data Canceled = Canceled
  deriving (Int -> Canceled -> String -> String
[Canceled] -> String -> String
Canceled -> String
(Int -> Canceled -> String -> String)
-> (Canceled -> String)
-> ([Canceled] -> String -> String)
-> Show Canceled
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Canceled -> String -> String
showsPrec :: Int -> Canceled -> String -> String
$cshow :: Canceled -> String
show :: Canceled -> String
$cshowList :: [Canceled] -> String -> String
showList :: [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 <- Int -> IO (IORef Int)
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 -> SearchResult -> IO SearchResult
forall a. a -> IO a
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
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
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 -> SearchResult -> IO SearchResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
False)
            Just Int
lit
              | Int
lit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
litUndef -> Solver -> Int -> IO ()
decide Solver
solver Int
lit IO () -> IO SearchResult -> IO SearchResult
forall a b. IO a -> IO b -> IO b
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
litUndef
                    then SearchResult -> IO SearchResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SearchResult
SRFinished Bool
True)
                    else Solver -> Int -> IO ()
decide Solver
solver Int
lit2 IO () -> IO SearchResult -> IO SearchResult
forall a b. IO a -> IO b -> IO b
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 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Solver -> IORef Int
svLearntLim Solver
solver)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
learnt_lim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
learnt_lim) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNLearntGC Solver
solver) (Int -> Int -> Int
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 <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
s) then
                Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
litUndef)
              else do
                Int
l <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svAssumptions Solver
solver) Int
d
                LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
l
                if LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then do
                  -- dummy decision level
                  Solver -> IO ()
pushDecisionLevel Solver
solver
                  IO (Maybe Int)
go
                else if LBool
val LBool -> LBool -> Bool
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
                  IORef LitSet -> LitSet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef LitSet
svFailedAssumptions Solver
solver) (Clause -> LitSet
IS.fromList Clause
core)
                  Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
                else
                  Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
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

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

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

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

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

      Maybe (IO Bool)
terminateCallback' <- IORef (Maybe (IO Bool)) -> IO (Maybe (IO Bool))
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Maybe (IO Bool))
svTerminateCallback Solver
solver)
      case Maybe (IO Bool)
terminateCallback' of
        Maybe (IO Bool)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just IO Bool
terminateCallback -> do
          Bool
ret <- IO Bool
terminateCallback
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
True
      Bool
canceled <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Solver -> IORef Bool
svCanceled Solver
solver)

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

      if Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot then do
        Solver -> Clause -> IO ()
callLearnCallback Solver
solver []
        Solver -> IO ()
markBad Solver
solver
        Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just (Bool -> SearchResult
SRFinished Bool
False)
      else if Int
confBudgetInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRBudgetExceeded
      else if Bool
canceled then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRCanceled
      else if Int
conflict_lim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
conflict_lim then
        Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SearchResult -> IO (Maybe SearchResult))
-> Maybe SearchResult -> IO (Maybe SearchResult)
forall a b. (a -> b) -> a -> b
$ SearchResult -> Maybe SearchResult
forall a. a -> Maybe a
Just SearchResult
SRRestart
      else do
        IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svLearntCounter Solver
solver) (Int -> Int -> Int
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 IO () -> IO (Maybe SearchResult) -> IO (Maybe SearchResult)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
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) <- Solver -> SomeConstraintHandler -> IO (Clause, Int)
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
        [] -> String -> IO ()
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
          Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
ret (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          () -> IO ()
forall a. a -> IO a
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 = ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
constr2
          Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
cl
          Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
lit SomeConstraintHandler
constr2
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2

    learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
    learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)
learnHybrid IORef Int
conflictCounter SomeConstraintHandler
constr = do
      (Clause
learntClause, Int
clauseLevel) <- Solver -> SomeConstraintHandler -> IO (Clause, Int)
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 <- IORef (Maybe (PBLinSum, Integer)) -> IO (Maybe (PBLinSum, Integer))
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 -> (Maybe (PBLinSum, Integer), Int)
-> IO (Maybe (PBLinSum, Integer), Int)
forall a. a -> IO a
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
            (Maybe (PBLinSum, Integer), Int)
-> IO (Maybe (PBLinSum, Integer), Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (PBLinSum, Integer)
z, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
clauseLevel Int
pbLevel)
      Solver -> Int -> IO ()
backtrackTo Solver
solver Int
minLevel

      case Clause
learntClause of
        [] -> String -> IO ()
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.
          () -> IO ()
forall a. a -> IO a
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 = ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
constr2
          Solver -> ClauseHandler -> IO Bool
basicAttachClauseHandler Solver
solver ClauseHandler
cl
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
minLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
clauseLevel) (IO () -> IO ()) -> IO () -> IO ()
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.
            () -> IO ()
forall a. a -> IO a
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 -> Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
            Just (PBLinSum
lhs,Integer
rhs) -> do
              SomeConstraintHandler
h <- Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted Solver
solver PBLinSum
lhs Integer
rhs Bool
True
              case SomeConstraintHandler
h of
                CHClause ClauseHandler
_ -> do
                  {- We don't want to add additional clause,
                     since it would be subsumed by already added one. -}
                  Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
forall a. Maybe a
Nothing
                SomeConstraintHandler
_ -> do
                  Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
addToLearntDB Solver
solver SomeConstraintHandler
h
                  Bool
ret2 <- Solver -> SomeConstraintHandler -> IO Bool
attach Solver
solver SomeConstraintHandler
h
                  Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
h
                  if Bool
ret2 then
                    Maybe SearchResult -> IO (Maybe SearchResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SearchResult
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 = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef Bool
svCanceled Solver
solver) Bool
True

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

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

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

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

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

  -- simplify learnt constraint DB
  do
    (Int
m,[SomeConstraintHandler]
xs) <- IORef (Int, [SomeConstraintHandler])
-> IO (Int, [SomeConstraintHandler])
forall a. IORef a -> IO a
readIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver)
    ([SomeConstraintHandler]
ys,Int
n) <- [SomeConstraintHandler]
-> [SomeConstraintHandler]
-> Int
-> IO ([SomeConstraintHandler], Int)
forall {t}.
Num t =>
[SomeConstraintHandler]
-> [SomeConstraintHandler] -> t -> IO ([SomeConstraintHandler], t)
loop [SomeConstraintHandler]
xs [] (Int
0::Int)
    IORef (Int, [SomeConstraintHandler])
-> (Int, [SomeConstraintHandler]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Int, [SomeConstraintHandler])
svLearntDB Solver
solver) (Int
mInt -> Int -> Int
forall 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 (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  if Bool -> Bool
not Bool
flag then
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Bool -> IO Bool -> IO Bool
forall {c}. Bool -> IO c -> IO c
withEnablePhaseSaving Bool
False (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
      IO () -> IO () -> IO Bool -> IO Bool
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
        (Solver -> IO ()
pushDecisionLevel Solver
solver)
        (Solver -> Int -> IO ()
backtrackTo Solver
solver Int
levelRoot) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
          Bool
b <- (Int -> IO Bool) -> Clause -> IO Bool
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
            (Maybe SomeConstraintHandler -> Bool)
-> IO (Maybe SomeConstraintHandler) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe SomeConstraintHandler -> Bool
forall a. Maybe a -> Bool
isJust (Solver -> IO (Maybe SomeConstraintHandler)
deduce Solver
solver)
          else do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> String -> IO ()
log Solver
solver (String
"forward subsumption: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
forall a. Show a => a -> String
show Clause
lits)
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    withEnablePhaseSaving :: Bool -> IO c -> IO c
withEnablePhaseSaving Bool
flag IO c
m =
      IO Config -> (Config -> IO ()) -> (Config -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (Solver -> IO Config
getConfig Solver
solver)
        (\Config
saved -> Solver -> (Config -> Config) -> IO ()
modifyConfig Solver
solver (\Config
config -> Config
config{ configEnablePhaseSaving = configEnablePhaseSaving saved }))
        (\Config
saved -> Solver -> Config -> IO ()
setConfig Solver
solver Config
saved{ configEnablePhaseSaving = flag } IO () -> IO c -> IO c
forall a b. IO a -> IO b -> IO b
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 (Config -> Bool) -> IO Config -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    HashSet SomeConstraintHandler
xs <- Solver -> (PBLinSum, Integer) -> IO (HashSet SomeConstraintHandler)
backwardSubsumedBy Solver
solver (PBLinSum, Integer)
pb
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a. HashSet a -> [a]
HashSet.toList HashSet SomeConstraintHandler
xs) ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
        String
s <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
c
        Solver -> String -> IO ()
log Solver
solver (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"backward subsumption: %s is subsumed by %s\n" String
s ((PBLinSum, Integer) -> String
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 <- PBLinSum
-> ((Integer, Int) -> IO (HashSet SomeConstraintHandler))
-> IO [HashSet SomeConstraintHandler]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs (((Integer, Int) -> IO (HashSet SomeConstraintHandler))
 -> IO [HashSet SomeConstraintHandler])
-> ((Integer, Int) -> IO (HashSet SomeConstraintHandler))
-> IO [HashSet SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Int
lit) -> do
    Vec (HashSet SomeConstraintHandler)
-> Int -> IO (HashSet SomeConstraintHandler)
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
    [] -> HashSet SomeConstraintHandler -> IO (HashSet SomeConstraintHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HashSet SomeConstraintHandler
forall a. HashSet a
HashSet.empty
    HashSet SomeConstraintHandler
s:[HashSet SomeConstraintHandler]
ss -> do
      let p :: a -> IO Bool
p a
c = do
            -- Note that @isPBRepresentable c@ is always True here,
            -- because only such constraints are added to occur list.
            -- See 'addToDB'.
            (PBLinSum, Integer)
pb2 <- (Int -> IO LBool) -> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *).
Monad m =>
(Int -> m LBool) -> (PBLinSum, Integer) -> m (PBLinSum, Integer)
instantiatePBLinAtLeast (Solver -> Int -> IO LBool
getLitFixed Solver
solver) ((PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> IO (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> IO (PBLinSum, Integer)
forall a. ConstraintHandler a => a -> IO (PBLinSum, Integer)
toPBLinAtLeast a
c
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (PBLinSum, Integer) -> (PBLinSum, Integer) -> Bool
pbLinSubsume (PBLinSum, Integer)
pb (PBLinSum, Integer)
pb2
      ([SomeConstraintHandler] -> HashSet SomeConstraintHandler)
-> IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [SomeConstraintHandler] -> HashSet SomeConstraintHandler
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
        (IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler))
-> IO [SomeConstraintHandler] -> IO (HashSet SomeConstraintHandler)
forall a b. (a -> b) -> a -> b
$ (SomeConstraintHandler -> IO Bool)
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
p
        ([SomeConstraintHandler] -> IO [SomeConstraintHandler])
-> [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a. HashSet a -> [a]
HashSet.toList
        (HashSet SomeConstraintHandler -> [SomeConstraintHandler])
-> HashSet SomeConstraintHandler -> [SomeConstraintHandler]
forall a b. (a -> b) -> a -> b
$ (HashSet SomeConstraintHandler
 -> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler)
-> HashSet SomeConstraintHandler
-> [HashSet SomeConstraintHandler]
-> HashSet SomeConstraintHandler
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashSet SomeConstraintHandler
-> HashSet SomeConstraintHandler -> HashSet SomeConstraintHandler
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
HashSet.intersection HashSet SomeConstraintHandler
s [HashSet SomeConstraintHandler]
ss

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

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

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

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

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

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

-- | The default polarity of a variable.
setVarPolarity :: Solver -> Var -> Bool -> IO ()
setVarPolarity :: Solver -> Int -> Bool -> IO ()
setVarPolarity Solver
solver Int
v Bool
val = UVec Bool -> Int -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svVarPolarity Solver
solver) (Int
v Int -> Int -> Int
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 = IORef (Gen RealWorld) -> Gen RealWorld -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef GenIO
svRandomGen Solver
solver)

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

setConfBudget :: Solver -> Maybe Int -> IO ()
setConfBudget :: Solver -> Maybe Int -> IO ()
setConfBudget Solver
solver (Just Int
b) | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = IOURef Int -> Int -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svConfBudget Solver
solver) Int
b
setConfBudget Solver
solver Maybe Int
_ = IOURef Int -> Int -> IO ()
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 = IORef (Maybe (IO Bool)) -> Maybe (IO Bool) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (IO Bool))
svTerminateCallback Solver
solver) (IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just IO Bool
callback)

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

-- | Set a callback function used to extract learned clauses from the solver.
-- The solver will call this function for each learned clause.
--
-- See also 'clearLearnCallback' and
-- [IPASIR](https://github.com/biotomas/ipasir)'s @ipasir_set_learn()@ function.
setLearnCallback :: Solver -> (Clause -> IO ()) -> IO ()
setLearnCallback :: Solver -> (Clause -> IO ()) -> IO ()
setLearnCallback Solver
solver Clause -> IO ()
callback = IORef (Maybe (Clause -> IO ())) -> Maybe (Clause -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (Clause -> IO ()))
svLearnCallback Solver
solver) ((Clause -> IO ()) -> Maybe (Clause -> IO ())
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 = IORef (Maybe (Clause -> IO ())) -> Maybe (Clause -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (Clause -> IO ()))
svLearnCallback Solver
solver) Maybe (Clause -> IO ())
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 <- IORef (Gen RealWorld) -> IO (Gen RealWorld)
forall a. IORef a -> IO a
readIORef (Solver -> IORef GenIO
svRandomGen Solver
solver)
  let vqueue :: PriorityQueue
vqueue = Solver -> PriorityQueue
svVarQueue Solver
solver
  !Double
randfreq <- Config -> Double
configRandomFreq (Config -> Double) -> IO Config -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  !Int
size <- PriorityQueue -> IO Int
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 <- (Double -> Double) -> IO Double -> IO Double
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
-) (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Double
Rand.uniform Gen RealWorld
GenIO
gen
  Int
var <-
    if (Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
randfreq Bool -> Bool -> Bool
&& Int
size Int -> Int -> Bool
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 <- (Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
forall (m :: * -> *).
PrimMonad m =>
(Int, Int) -> Gen (PrimState m) -> m Int
Rand.uniformR (Int
0, Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Gen RealWorld
GenIO
gen
      Int
var <- IOUArray Int Int -> Int -> IO Int
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then do
        IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNRandomDecision Solver
solver) (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
var
      else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
litUndef
    else
      Int -> IO Int
forall a. a -> IO a
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 <- PriorityQueue -> IO (Maybe Int)
forall q (m :: * -> *) a. Dequeue q m a => q -> m (Maybe a)
PQ.dequeue PriorityQueue
vqueue
        case Maybe Int
m of
          Maybe Int
Nothing -> Int -> IO Int
forall a. a -> IO a
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef
              then IO Int
loop
              else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
var2
  Int
var2 <-
    if Int
varInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
litUndef
    then IO Int
loop
    else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
var

  if Int
var2Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
litUndef then
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
litUndef
  else do
    -- TODO: random polarity
    Bool
p <- UVec Bool -> Int -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svVarPolarity Solver
solver) (Int
var2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
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
  IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Int
svNDecision Solver
solver) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  Solver -> IO ()
pushDecisionLevel Solver
solver
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"decide: should not happen"
  Solver -> Int -> IO Bool
assign Solver
solver Int
lit
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

deduceB :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceB :: Solver -> ExceptT SomeConstraintHandler IO ()
deduceB Solver
solver = ExceptT SomeConstraintHandler IO ()
loop
  where
    loop :: ExceptT SomeConstraintHandler IO ()
    loop :: ExceptT SomeConstraintHandler IO ()
loop = do
      Maybe Int
r <- IO (Maybe Int) -> ExceptT SomeConstraintHandler IO (Maybe Int)
forall a. IO a -> ExceptT SomeConstraintHandler IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> ExceptT SomeConstraintHandler IO (Maybe Int))
-> IO (Maybe Int) -> ExceptT SomeConstraintHandler IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Solver -> IO (Maybe Int)
bcpDequeue Solver
solver
      case Maybe Int
r of
        Maybe Int
Nothing -> () -> ExceptT SomeConstraintHandler IO ()
forall a. a -> ExceptT SomeConstraintHandler IO a
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 = IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SomeConstraintHandler ())
 -> ExceptT SomeConstraintHandler IO ())
-> IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe SomeConstraintHandler -> Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either SomeConstraintHandler ()
-> (SomeConstraintHandler -> Either SomeConstraintHandler ())
-> Maybe SomeConstraintHandler
-> Either SomeConstraintHandler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeConstraintHandler ()
forall a b. b -> Either a b
Right ()) SomeConstraintHandler -> Either SomeConstraintHandler ()
forall a b. a -> Either a b
Left) (IO (Maybe SomeConstraintHandler)
 -> IO (Either SomeConstraintHandler ()))
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall a b. (a -> b) -> a -> b
$ do
      let falsifiedLit :: 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 [] = Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
          loop2 (SomeConstraintHandler
w:[SomeConstraintHandler]
ws) = do
            Bool
ok <- Solver -> SomeConstraintHandler -> Int -> IO Bool
propagate Solver
solver SomeConstraintHandler
w Int
falsifiedLit
            if Bool
ok then
              [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws
            else do
              Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify Vec [SomeConstraintHandler]
a Int
idx ([SomeConstraintHandler]
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. [a] -> [a] -> [a]
++[SomeConstraintHandler]
ws)
              Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just SomeConstraintHandler
w)
      [SomeConstraintHandler]
ws <- Vec [SomeConstraintHandler] -> Int -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead Vec [SomeConstraintHandler]
a Int
idx
      Vec [SomeConstraintHandler]
-> Int -> [SomeConstraintHandler] -> IO ()
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 = IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SomeConstraintHandler ())
 -> ExceptT SomeConstraintHandler IO ())
-> IO (Either SomeConstraintHandler ())
-> ExceptT SomeConstraintHandler IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe SomeConstraintHandler -> Either SomeConstraintHandler ())
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either SomeConstraintHandler ()
-> (SomeConstraintHandler -> Either SomeConstraintHandler ())
-> Maybe SomeConstraintHandler
-> Either SomeConstraintHandler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeConstraintHandler ()
forall a b. b -> Either a b
Right ()) SomeConstraintHandler -> Either SomeConstraintHandler ()
forall a b. a -> Either a b
Left) (IO (Maybe SomeConstraintHandler)
 -> IO (Either SomeConstraintHandler ()))
-> IO (Maybe SomeConstraintHandler)
-> IO (Either SomeConstraintHandler ())
forall a b. (a -> b) -> a -> b
$ do
      let falsifiedLit :: Int
falsifiedLit = Int -> Int
litNot Int
lit
          idx :: Int
idx = Int -> Int
litVar Int
lit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      let loop2 :: [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [] = Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeConstraintHandler
forall a. Maybe a
Nothing
          loop2 (SomeConstraintHandler
w:[SomeConstraintHandler]
ws) = do
            Bool
ok <- Solver -> SomeConstraintHandler -> Int -> IO Bool
propagate Solver
solver SomeConstraintHandler
w Int
falsifiedLit
            if Bool
ok
              then [SomeConstraintHandler] -> IO (Maybe SomeConstraintHandler)
loop2 [SomeConstraintHandler]
ws
              else do
                Vec [SomeConstraintHandler]
-> Int
-> ([SomeConstraintHandler] -> [SomeConstraintHandler])
-> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> (e -> e) -> IO ()
Vec.unsafeModify (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Int
idx ([SomeConstraintHandler]
-> [SomeConstraintHandler] -> [SomeConstraintHandler]
forall a. [a] -> [a] -> [a]
++[SomeConstraintHandler]
ws)
                Maybe SomeConstraintHandler -> IO (Maybe SomeConstraintHandler)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> Maybe SomeConstraintHandler
forall a. a -> Maybe a
Just SomeConstraintHandler
w)
      [SomeConstraintHandler]
ws <- Vec [SomeConstraintHandler] -> Int -> IO [SomeConstraintHandler]
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> Vec [SomeConstraintHandler]
svVarWatches Solver
solver) Int
idx
      Vec [SomeConstraintHandler]
-> Int -> [SomeConstraintHandler] -> IO ()
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 LearningStrategy -> LearningStrategy -> Bool
forall a. Eq a => a -> a -> Bool
== LearningStrategy
LearningHybrid

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

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

  let f :: t Int -> IO ()
f t Int
lits = do
        t Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t Int
lits ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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 <- UVec Bool -> Int -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svSeen Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& Int
lv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d then do
              UVec Bool -> Int -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svSeen Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool
True
              IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef IOURef Int
pathC (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            else do
              GenericVec IOUArray Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> e -> IO ()
Vec.push GenericVec IOUArray 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
                (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((PBLinSum, Integer) -> IO (PBLinSum, Integer))
-> (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a b. (a -> b) -> a -> b
$ Clause -> (PBLinSum, Integer)
clauseToPBLinAtLeast (Int
lit Int -> Clause -> Clause
forall a. a -> [a] -> [a]
: Clause
lits)
          Bool
b <- a -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable a
constr2
          if Bool -> Bool
not Bool
b then do
            IO (PBLinSum, Integer)
clausePB
          else do
            (PBLinSum, Integer)
pb2 <- a -> IO (PBLinSum, Integer)
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
              (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
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) <- (PBLinSum, Integer) -> PBLinSum
forall a b. (a, b) -> a
fst (PBLinSum, Integer)
pb3]
        LitSet -> IO () -> IO ()
forall a b. a -> b -> b
seq LitSet
ls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (LitSet, (PBLinSum, Integer))
-> (LitSet, (PBLinSum, Integer)) -> IO ()
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 <- UVec Bool -> Int -> IO Bool
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> UVec Bool
svSeen Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        if Bool
b then do
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (LitSet
ls, (PBLinSum, Integer)
pb) <- IORef (LitSet, (PBLinSum, Integer))
-> IO (LitSet, (PBLinSum, Integer))
forall a. IORef a -> IO a
readIORef IORef (LitSet, (PBLinSum, Integer))
pbConstrRef
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Int
litNot Int
l Int -> LitSet -> Bool
`IS.member` LitSet
ls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Just SomeConstraintHandler
constr2 <- Solver -> Int -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver Int
v
              (PBLinSum, Integer)
-> SomeConstraintHandler -> Int -> IO Clause -> IO ()
forall {a}.
ConstraintHandler a =>
(PBLinSum, Integer) -> a -> Int -> IO Clause -> IO ()
processLitHybrid (PBLinSum, Integer)
pb SomeConstraintHandler
constr2 Int
l (Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
constr2 (Int -> Maybe Int
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
        UVec Bool -> Int -> Bool -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> e -> IO ()
Vec.unsafeWrite (Solver -> UVec Bool
svSeen Solver
solver) (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool
False
        IOURef Int -> (Int -> Int) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef IOURef Int
pathC (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
        Int
c <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef IOURef Int
pathC
        if Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
          Just SomeConstraintHandler
constr2 <- Solver -> Int -> IO (Maybe SomeConstraintHandler)
varReason Solver
solver Int
v
          Solver -> SomeConstraintHandler -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver SomeConstraintHandler
constr2
          Clause
lits <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
constr2 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l)
          Clause -> IO ()
forall {t :: * -> *}. Foldable t => t Int -> IO ()
f Clause
lits
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (LitSet
ls, (PBLinSum, Integer)
pb) <- IORef (LitSet, (PBLinSum, Integer))
-> IO (LitSet, (PBLinSum, Integer))
forall a. IORef a -> IO a
readIORef IORef (LitSet, (PBLinSum, Integer))
pbConstrRef
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Int
litNot Int
l Int -> LitSet -> Bool
`IS.member` LitSet
ls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              (PBLinSum, Integer)
-> SomeConstraintHandler -> Int -> IO Clause -> IO ()
forall {a}.
ConstraintHandler a =>
(PBLinSum, Integer) -> a -> Int -> IO Clause -> IO ()
processLitHybrid (PBLinSum, Integer)
pb SomeConstraintHandler
constr2 Int
l (Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
lits)
          Solver -> IO Int
popTrail Solver
solver
          IO ()
loop
        else do
          GenericVec IOUArray Int -> Int -> Int -> IO ()
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> e -> IO ()
Vec.unsafeWrite GenericVec IOUArray Int
out Int
0 (Int -> Int
litNot Int
l)

  Solver -> c -> IO ()
forall c. ConstraintHandler c => Solver -> c -> IO ()
constrBumpActivity Solver
solver c
constr
  Clause
falsifiedLits <- Solver -> c -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver c
constr Maybe Int
forall a. Maybe a
Nothing
  Clause -> IO ()
forall {t :: * -> *}. Foldable t => t Int -> IO ()
f Clause
falsifiedLits
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHybrid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
     (PBLinSum, Integer)
pb <- do
       Bool
b <- c -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable c
constr
       if Bool
b then
         c -> IO (PBLinSum, Integer)
forall a. ConstraintHandler a => a -> IO (PBLinSum, Integer)
toPBLinAtLeast c
constr
       else
         (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
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) <- (PBLinSum, Integer) -> PBLinSum
forall a b. (a, b) -> a
fst (PBLinSum, Integer)
pb]
     LitSet -> IO () -> IO ()
forall a b. a -> b -> b
seq LitSet
ls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (LitSet, (PBLinSum, Integer))
-> (LitSet, (PBLinSum, Integer)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (LitSet, (PBLinSum, Integer))
pbConstrRef (LitSet
ls, (PBLinSum, Integer)
pb)
  IO ()
loop
  LitSet
lits <- (Clause -> LitSet) -> IO Clause -> IO LitSet
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Clause -> LitSet
IS.fromList (IO Clause -> IO LitSet) -> IO Clause -> IO LitSet
forall a b. (a -> b) -> a -> b
$ GenericVec IOUArray Int -> IO Clause
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> IO [e]
Vec.getElems GenericVec IOUArray 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 <- ([(Int, Int)] -> [(Int, Int)])
-> IO [(Int, Int)] -> IO [(Int, Int)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Int) -> (Int, Int) -> Ordering)
-> (Int, Int) -> (Int, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd))) (IO [(Int, Int)] -> IO [(Int, Int)])
-> IO [(Int, Int)] -> IO [(Int, Int)]
forall a b. (a -> b) -> a -> b
$
    Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (LitSet -> Clause
IS.toList LitSet
lits2) ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ \Int
l -> do
      Int
lv <- Solver -> Int -> IO Int
litLevel Solver
solver Int
l
      (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l,Int
lv)

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

  let level :: Int
level = case [(Int, Int)]
xs of
                [] -> String -> Int
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 = ((Int, Int) -> Int) -> [(Int, Int)] -> Clause
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
xs
  Solver -> Clause -> IO ()
callLearnCallback Solver
solver Clause
clause
  (Clause, Int) -> IO (Clause, Int)
forall a. a -> IO a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
result
        | Bool
otherwise = do
            Int
l <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svTrail Solver
solver) Int
i
            Int
lv <- Solver -> Int -> IO Int
litLevel Solver
solver Int
l
            if Int
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot then
              Clause -> IO Clause
forall a. a -> IO a
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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) LitSet
seen' (Int
l Int -> Clause -> Clause
forall a. a -> [a] -> [a]
: Clause
result)
                Just SomeConstraintHandler
constr  -> do
                  Clause
c <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
constr (Int -> Maybe Int
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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) LitSet
seen' Clause
result
            else
              Int -> LitSet -> Clause -> IO Clause
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) LitSet
seen Clause
result
  Int
n <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
  Int -> LitSet -> Clause -> IO Clause
go (Int
nInt -> Int -> Int
forall 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 <- IORef (Maybe (Clause -> IO ())) -> IO (Maybe (Clause -> IO ()))
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 -> () -> IO ()
forall a. a -> IO a
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) = Bool -> IO Int -> IO Int
forall a. HasCallStack => Bool -> a -> a
assert (Integer
rhs Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
levelRoot
pbBacktrackLevel Solver
solver (PBLinSum
lhs, Integer
rhs) = do
  IntMap (IntMap (Integer, LBool))
levelToLiterals <- ([IntMap (IntMap (Integer, LBool))]
 -> IntMap (IntMap (Integer, LBool)))
-> IO [IntMap (IntMap (Integer, LBool))]
-> IO (IntMap (IntMap (Integer, LBool)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((IntMap (Integer, LBool)
 -> IntMap (Integer, LBool) -> IntMap (Integer, LBool))
-> [IntMap (IntMap (Integer, LBool))]
-> IntMap (IntMap (Integer, LBool))
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IM.unionsWith IntMap (Integer, LBool)
-> IntMap (Integer, LBool) -> IntMap (Integer, LBool)
forall a. IntMap a -> IntMap a -> IntMap a
IM.union) (IO [IntMap (IntMap (Integer, LBool))]
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ PBLinSum
-> ((Integer, Int) -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM PBLinSum
lhs (((Integer, Int) -> IO (IntMap (IntMap (Integer, LBool))))
 -> IO [IntMap (IntMap (Integer, LBool))])
-> ((Integer, Int) -> IO (IntMap (IntMap (Integer, LBool))))
-> IO [IntMap (IntMap (Integer, LBool))]
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lUndef then do
      Int
level <- Solver -> Int -> IO Int
litLevel Solver
solver Int
lit
      IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (Integer, LBool))
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Integer, LBool) -> IntMap (IntMap (Integer, LBool))
forall a. Int -> a -> IntMap a
IM.singleton Int
level (Int -> (Integer, LBool) -> IntMap (Integer, LBool)
forall a. Int -> a -> IntMap a
IM.singleton Int
lit (Integer
c,LBool
val))
    else
      IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (Integer, LBool))
 -> IO (IntMap (IntMap (Integer, LBool))))
-> IntMap (IntMap (Integer, LBool))
-> IO (IntMap (IntMap (Integer, LBool)))
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Integer, LBool) -> IntMap (IntMap (Integer, LBool))
forall a. Int -> a -> IntMap a
IM.singleton Int
forall a. Bounded a => a
maxBound (Int -> (Integer, LBool) -> IntMap (Integer, LBool)
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
_ = String -> m a
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 t -> t -> t
forall a. Num a => a -> a -> a
- [t] -> t
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [t
c | (Int
_,(t
c,LBool
val)) <- IntMap (t, LBool) -> [(Int, (t, LBool))]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (t, LBool)
lv_lits, LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse]
        if t
slack_lv t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 then
          a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- CONFLICT
        else if ((a, IntMap (t, LBool)) -> Bool)
-> [(a, IntMap (t, LBool))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
_, IntMap (t, LBool)
lits2) -> ((t, LBool) -> Bool) -> [(t, LBool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(t
c,LBool
_) -> t
c t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
slack_lv) (IntMap (t, LBool) -> [(t, LBool)]
forall a. IntMap a -> [a]
IM.elems IntMap (t, LBool)
lits2)) [(a, IntMap (t, LBool))]
lvs then
          a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
lv -- UNIT
        else
          [(a, IntMap (t, LBool))] -> t -> m a
replay [(a, IntMap (t, LBool))]
lvs t
slack_lv

  let initial_slack :: Integer
initial_slack = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (Integer
c,Int
_) <- PBLinSum
lhs] Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
rhs
  if ((Integer, Int) -> Bool) -> PBLinSum -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Integer
c,Int
_) -> Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
initial_slack) PBLinSum
lhs then
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  else do
    [(Int, IntMap (Integer, LBool))] -> Integer -> IO Int
forall {t} {m :: * -> *} {a}.
(Ord t, Monad m, Num t) =>
[(a, IntMap (t, LBool))] -> t -> m a
replay (IntMap (IntMap (Integer, LBool))
-> [(Int, IntMap (Integer, LBool))]
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 (Config -> Int) -> IO Config -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  if Int
ccmin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseRecursive Solver
solver LitSet
lits
  else if Int
ccmin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 then
    Solver -> LitSet -> IO LitSet
minimizeConflictClauseLocal Solver
solver LitSet
lits
  else
    LitSet -> IO LitSet
forall a. a -> IO a
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 <- (Int -> IO Bool) -> Clause -> IO Clause
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> (Int -> IO Bool) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Bool
isRedundant) Clause
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Solver -> String -> IO ()
log Solver
solver String
"minimizeConflictClauseLocal:"
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
xs
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
ys
  LitSet -> IO LitSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ Clause -> LitSet
IS.fromAscList (Clause -> LitSet) -> Clause -> LitSet
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SomeConstraintHandler
c2 -> do
          Clause
ls <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
c2 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
litNot Int
lit))
          (Int -> IO Bool) -> Clause -> IO Bool
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
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
lv Int -> Int -> Bool
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SomeConstraintHandler
c2 -> do
          Clause
ls <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
c2 (Int -> Maybe Int
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
_ = Bool -> IO Bool
forall a. a -> IO a
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 Int -> Int -> Bool
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Just SomeConstraintHandler
c2 -> do
            Clause
ls2 <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
reasonOf Solver
solver SomeConstraintHandler
c2 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
litNot Int
lit))
            Clause -> LitSet -> IO Bool
go (Clause
ls2 Clause -> Clause -> Clause
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 <- (Int -> IO Bool) -> Clause -> IO Clause
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> (Int -> IO Bool) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Bool
isRedundant) Clause
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Solver -> String -> IO ()
log Solver
solver String
"minimizeConflictClauseRecursive:"
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
xs
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
ys
  LitSet -> IO LitSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ Clause -> LitSet
IS.fromAscList (Clause -> LitSet) -> Clause -> LitSet
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 -> LitSet -> IO LitSet
forall a. a -> IO a
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) IO ()
forall a. HasCallStack => a
undefined
            Clause
xs <- Solver -> SomeConstraintHandler -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
constrReasonOf Solver
solver SomeConstraintHandler
constr (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
litNot Int
l))
            LitSet -> IO LitSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitSet -> IO LitSet) -> LitSet -> IO LitSet
forall a b. (a -> b) -> a -> b
$ LitSet
reasonSided LitSet -> LitSet -> LitSet
`IS.union` Clause -> LitSet
IS.fromList ((Int -> Int) -> Clause -> Clause
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
litVar Clause
xs)
  LitSet
reasonSided <- (LitSet -> Int -> IO LitSet) -> LitSet -> Clause -> IO LitSet
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
  (Int -> IO ()) -> Clause -> IO ()
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 <- GenericVec IOUArray Int -> IO Int
forall (a :: * -> * -> *) e. GenericVec a e -> IO Int
Vec.getSize (Solver -> GenericVec IOUArray Int
svTrail Solver
solver)
  GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.unsafeRead (Solver -> GenericVec IOUArray Int
svTrail Solver
solver) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

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

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

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

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

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

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

  let ref :: IORef LitSet
ref = Solver -> IORef LitSet
svAssumptionsImplications Solver
solver
  Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
lim_beg .. Int
lim_endInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Int
lit <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.read (Solver -> GenericVec IOUArray Int
svTrail Solver
solver) Int
i
    IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef LitSet
ref (Int -> LitSet -> LitSet
IS.insert Int
lit)
  Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    Int
lit <- GenericVec IOUArray Int -> Int -> IO Int
forall (a :: * -> * -> *) e.
MArray a e IO =>
GenericVec a e -> Int -> IO e
Vec.read (Solver -> GenericVec IOUArray Int
svAssumptions Solver
solver) Int
i
    IORef LitSet -> (LitSet -> LitSet) -> IO ()
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 (Config -> Double) -> IO Config -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver -> IO Config
getConfig Solver
solver
  IOURef Double -> (Double -> Double) -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> (a -> a) -> IO ()
modifyIOURef (Solver -> IOURef Double
svConstrInc Solver
solver) (Double
dDouble -> Double -> Double
forall 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 <- a -> IO Double
forall a. ConstraintHandler a => a -> IO Double
constrReadActivity a
this
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
aval Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- learnt clause
    Double
inc <- IOURef Double -> IO Double
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Double
svConstrInc Solver
solver)
    let aval2 :: Double
aval2 = Double
avalDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
inc
    a -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity a
this (Double -> IO ()) -> Double -> IO ()
forall a b. (a -> b) -> a -> b
$! Double
aval2
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
aval2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e20) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- Rescale
      Solver -> IO ()
constrRescaleAllActivity Solver
solver

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

resetStat :: Solver -> IO ()
resetStat :: Solver -> IO ()
resetStat Solver
solver = do
  IOURef Int -> Int -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svNDecision Solver
solver) Int
0
  IOURef Int -> Int -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svNRandomDecision Solver
solver) Int
0
  IOURef Int -> Int -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svNConflict Solver
solver) Int
0
  IOURef Int -> Int -> IO ()
forall a. MArray IOUArray a IO => IOURef a -> a -> IO ()
writeIOURef (Solver -> IOURef Int
svNRestart Solver
solver) Int
0
  IOURef Int -> Int -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"============================[ Search Statistics ]============================"
  Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" Time | Restart | Decision | Conflict |      LEARNT     | Fixed    | Removed "
  Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"      |         |          |          |    Limit     GC | Var      | Constra "
  Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
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 Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else do
         TimeSpec
lastWC <- IORef TimeSpec -> IO TimeSpec
forall a. IORef a -> IO a
readIORef (Solver -> IORef TimeSpec
svLastStatWC Solver
solver)
         Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Int64
sec (TimeSpec
nowWC TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
lastWC) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
1
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TimeSpec
startWC   <- IORef TimeSpec -> IO TimeSpec
forall a. IORef a -> IO a
readIORef (Solver -> IORef TimeSpec
svStartWC Solver
solver)
    let tm :: String
tm = TimeSpec -> String
showTimeDiff (TimeSpec -> String) -> TimeSpec -> String
forall a b. (a -> b) -> a -> b
$ TimeSpec
nowWC TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
startWC
    Int
restart   <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNRestart Solver
solver)
    Int
dec       <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNDecision Solver
solver)
    Int
conflict  <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNConflict Solver
solver)
    Int
learntLim <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Solver -> IORef Int
svLearntLim Solver
solver)
    Int
learntGC  <- IOURef Int -> IO Int
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   <- IOURef Int -> IO Int
forall a. MArray IOUArray a IO => IOURef a -> IO a
readIOURef (Solver -> IOURef Int
svNRemovedConstr Solver
solver)
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
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
    IORef TimeSpec -> TimeSpec -> IO ()
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%4.1fs" (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
s :: Double)
  | Integer
si Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9999 = String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%4ds" Integer
si
  | Integer
mi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%4.1fm" (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
m :: Double)
  | Integer
mi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9999 = String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%4dm" Integer
mi
  | Integer
hi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<  Integer
100  = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%4.1fs" (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
h :: Double)
  | Bool
otherwise  = String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%4dh" Integer
hi
  where
    s :: Rational
    s :: Rational
s = Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs TimeSpec
t) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
10Rational -> Int -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
9::Int)

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

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

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

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

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

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

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

  showConstraintHandler :: a -> IO String

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

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

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

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

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

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

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

  isSatisfied :: Solver -> a -> IO Bool

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

  constrWeight :: Solver -> a -> IO Double
  constrWeight Solver
_ a
_ = Double -> IO Double
forall a. a -> IO 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 = Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrAttach Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c

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

-- | invoked with the watched literal when the literal is falsified.
propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool
propagate :: Solver -> SomeConstraintHandler -> Int -> IO Bool
propagate Solver
solver SomeConstraintHandler
c Int
l = Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Int -> IO Bool
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    case Maybe Int
x of
      Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Int
lit -> do
        LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
lTrue LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String
str <- a -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler a
c
          String -> IO ()
forall a. HasCallStack => String -> a
error (String -> Int -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"reasonOf: value of literal %d should be True but %s (constrReasonOf %s %s)" Int
lit (LBool -> String
forall a. Show a => a -> String
show LBool
val) String
str (Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
x))
  Clause
cl <- Solver -> a -> Maybe Int -> IO Clause
forall a.
ConstraintHandler a =>
Solver -> a -> Maybe Int -> IO Clause
constrReasonOf Solver
solver a
c Maybe Int
x
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Clause
cl ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
lit -> do
      LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
lFalse LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
val) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String
str <- a -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler a
c
        String -> IO ()
forall a. HasCallStack => String -> a
error (String -> Int -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"reasonOf: value of literal %d should be False but %s (constrReasonOf %s %s)" Int
lit (LBool -> String
forall a. Show a => a -> String
show LBool
val) String
str (Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
x))
  Clause -> IO Clause
forall a. a -> IO a
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 = Solver -> SomeConstraintHandler -> SomeConstraintHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
c SomeConstraintHandler
c

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

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

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

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

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

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

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

  constrPropagate :: Solver
-> SomeConstraintHandler -> SomeConstraintHandler -> Int -> IO Bool
constrPropagate Solver
solver SomeConstraintHandler
this (CHClause ClauseHandler
c)  Int
lit   = Solver -> SomeConstraintHandler -> ClauseHandler -> Int -> IO Bool
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   = Solver -> SomeConstraintHandler -> AtLeastHandler -> Int -> IO Bool
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 = Solver
-> SomeConstraintHandler -> PBHandlerCounter -> Int -> IO Bool
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  = Solver
-> SomeConstraintHandler -> PBHandlerPueblo -> Int -> IO Bool
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 = Solver
-> SomeConstraintHandler -> XORClauseHandler -> Int -> IO Bool
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    = Solver -> SomeConstraintHandler -> TheoryHandler -> Int -> IO Bool
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   = Solver -> ClauseHandler -> Maybe Int -> IO Clause
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   = Solver -> AtLeastHandler -> Maybe Int -> IO Clause
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 = Solver -> PBHandlerCounter -> Maybe Int -> IO Clause
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  = Solver -> PBHandlerPueblo -> Maybe Int -> IO Clause
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 = Solver -> XORClauseHandler -> Maybe Int -> IO Clause
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    = Solver -> TheoryHandler -> Maybe Int -> IO Clause
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   = Solver -> SomeConstraintHandler -> ClauseHandler -> Int -> IO ()
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   = Solver -> SomeConstraintHandler -> AtLeastHandler -> Int -> IO ()
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 = Solver -> SomeConstraintHandler -> PBHandlerCounter -> Int -> IO ()
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  = Solver -> SomeConstraintHandler -> PBHandlerPueblo -> Int -> IO ()
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 = Solver -> SomeConstraintHandler -> XORClauseHandler -> Int -> IO ()
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    = Solver -> SomeConstraintHandler -> TheoryHandler -> Int -> IO ()
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)    = ClauseHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable ClauseHandler
c
  isPBRepresentable (CHAtLeast AtLeastHandler
c)   = AtLeastHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable AtLeastHandler
c
  isPBRepresentable (CHPBCounter PBHandlerCounter
c) = PBHandlerCounter -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable PBHandlerCounter
c
  isPBRepresentable (CHPBPueblo PBHandlerPueblo
c)  = PBHandlerPueblo -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable PBHandlerPueblo
c
  isPBRepresentable (CHXORClause XORClauseHandler
c) = XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable XORClauseHandler
c
  isPBRepresentable (CHTheory TheoryHandler
c)    = TheoryHandler -> IO Bool
forall a. ConstraintHandler a => a -> IO Bool
isPBRepresentable TheoryHandler
c

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

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

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

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

  constrWriteActivity :: SomeConstraintHandler -> Double -> IO ()
constrWriteActivity (CHClause ClauseHandler
c)    Double
aval = ClauseHandler -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity ClauseHandler
c Double
aval
  constrWriteActivity (CHAtLeast AtLeastHandler
c)   Double
aval = AtLeastHandler -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity AtLeastHandler
c Double
aval
  constrWriteActivity (CHPBCounter PBHandlerCounter
c) Double
aval = PBHandlerCounter -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity PBHandlerCounter
c Double
aval
  constrWriteActivity (CHPBPueblo PBHandlerPueblo
c)  Double
aval = PBHandlerPueblo -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity PBHandlerPueblo
c Double
aval
  constrWriteActivity (CHXORClause XORClauseHandler
c) Double
aval = XORClauseHandler -> Double -> IO ()
forall a. ConstraintHandler a => a -> Double -> IO ()
constrWriteActivity XORClauseHandler
c Double
aval
  constrWriteActivity (CHTheory TheoryHandler
c)    Double
aval = TheoryHandler -> Double -> IO ()
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then
    Bool -> IO Bool
forall a. a -> IO a
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just SomeConstraintHandler
c2  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! SomeConstraintHandler
c SomeConstraintHandler -> SomeConstraintHandler -> Bool
forall a. Eq a => a -> a -> Bool
== SomeConstraintHandler
c2

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

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

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

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

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

data ClauseHandler
  = ClauseHandler
  { ClauseHandler -> LitArray
claLits :: !LitArray
  , ClauseHandler -> IORef 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
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (ClauseHandler -> LitArray)
-> ClauseHandler
-> ClauseHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClauseHandler -> LitArray
claLits

instance Hashable ClauseHandler where
  hash :: ClauseHandler -> Int
hash = ClauseHandler -> Int
claHash
  hashWithSalt :: Int -> ClauseHandler -> Int
hashWithSalt = Int -> ClauseHandler -> Int
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 <- Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then Double
0 else -Double
1)
  ClauseHandler -> IO ClauseHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> IORef Double -> Int -> ClauseHandler
ClauseHandler LitArray
a IORef Double
act (Clause -> Int
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)
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Int
size Int -> Int -> Bool
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 <- Int -> IO (IORef Int)
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse then
              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do
              Int
j <- IORef Int -> IO Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              case Int
k of
                -1 -> do
                  Bool -> IO Bool
forall a. a -> IO a
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
                  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                  Bool -> IO Bool
forall a. a -> IO a
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
          Bool -> IO Bool
forall a. a -> IO a
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
_) <- ([(Int, Int)] -> (Int, Int)) -> IO [(Int, Int)] -> IO (Int, Int)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd)) (IO [(Int, Int)] -> IO (Int, Int))
-> IO [(Int, Int)] -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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
            (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
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 <- ([(Int, Int)] -> Clause) -> IO [(Int, Int)] -> IO Clause
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> Int) -> [(Int, Int)] -> Clause
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst ([(Int, Int)] -> Clause)
-> ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Int) -> (Int, Int) -> Ordering)
-> (Int, Int) -> (Int, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd))) (IO [(Int, Int)] -> IO Clause) -> IO [(Int, Int)] -> IO Clause
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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
          (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l,Int
lv)
        [(Int, Int)] -> ((Int, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Clause -> Clause -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] Clause
ls) (((Int, Int) -> IO ()) -> IO ()) -> ((Int, Int) -> IO ()) -> IO ()
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
        Bool -> IO Bool
forall a. a -> IO a
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then
      Bool -> IO Bool
forall a. a -> IO a
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue then do
      Solver -> Int -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Int
falsifiedLit SomeConstraintHandler
this
      Bool -> IO Bool
forall a. a -> IO a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      case Int
i of
        -1 -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             String
str <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
this
             String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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
          Bool -> IO Bool
forall a. a -> IO a
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
        Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
l0Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
falsifiedLit Bool -> Bool -> Bool
|| Int
l1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l0Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
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 -> Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
lits
      Just Int
lit -> do
        Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
lit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Clause -> Int
forall a. HasCallStack => [a] -> a
head Clause
lits) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> IO Clause) -> Clause -> IO Clause
forall a b. (a -> b) -> a -> b
$ Clause -> Clause
forall a. HasCallStack => [a] -> [a]
tail Clause
lits

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

  isPBRepresentable :: ClauseHandler -> IO Bool
isPBRepresentable ClauseHandler
_ = Bool -> IO Bool
forall a. a -> IO a
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)
    (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
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)
    (Either () () -> Bool) -> IO (Either () ()) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either () () -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either () ()) -> IO Bool) -> IO (Either () ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ExceptT () IO () -> IO (Either () ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () IO () -> IO (Either () ()))
-> ExceptT () IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$ Int
-> (Int -> Bool)
-> (Int -> Int)
-> (Int -> ExceptT () IO ())
-> ExceptT () IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
0 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> ExceptT () IO ()) -> ExceptT () IO ())
-> (Int -> ExceptT () IO ()) -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
      LBool
v <- IO LBool -> ExceptT () IO LBool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LBool -> ExceptT () IO LBool)
-> IO LBool -> ExceptT () IO LBool
forall a b. (a -> b) -> a -> b
$ Solver -> Int -> IO LBool
litValue Solver
solver (Int -> IO LBool) -> IO Int -> IO LBool
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
      Bool -> ExceptT () IO () -> ExceptT () IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lTrue) (ExceptT () IO () -> ExceptT () IO ())
-> ExceptT () IO () -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT () IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()

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

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

  constrWriteActivity :: ClauseHandler -> Double -> IO ()
constrWriteActivity ClauseHandler
this Double
aval = IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ClauseHandler -> IORef Double
claActivity ClauseHandler
this) (Double -> IO ()) -> Double -> IO ()
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 = ClauseHandler -> SomeConstraintHandler
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
      Bool -> IO Bool
forall a. a -> IO a
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
      Bool -> IO Bool
forall a. a -> IO a
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
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (AtLeastHandler -> LitArray)
-> AtLeastHandler
-> AtLeastHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AtLeastHandler -> LitArray
atLeastLits

instance Hashable AtLeastHandler where
  hash :: AtLeastHandler -> Int
hash = AtLeastHandler -> Int
atLeastHash
  hashWithSalt :: Int -> AtLeastHandler -> Int
hashWithSalt = Int -> AtLeastHandler -> Int
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 <- Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then Double
0 else -Double
1)
  AtLeastHandler -> IO AtLeastHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> Int -> IORef Double -> Int -> AtLeastHandler
AtLeastHandler LitArray
a Int
n IORef Double
act ((Clause, Int) -> Int
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)
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
lits String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Int
m Int -> Int -> Bool
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
      (Int -> IO Bool) -> Clause -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Int -> IO Bool
f [Int
0..Int
nInt -> Int -> Int
forall 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 Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                if Int
k Int -> Int -> Bool
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
                  Int -> (Int -> Bool) -> (Int -> Int) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
0 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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
                    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  -- We need to watch the most recently falsified literal
                  (Int
l,Int
_) <- ([(Int, Int)] -> (Int, Int)) -> IO [(Int, Int)] -> IO (Int, Int)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd)) (IO [(Int, Int)] -> IO (Int, Int))
-> IO [(Int, Int)] -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
n..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"AtLeastHandler.attach: should not happen"
                    (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
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.
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            | Bool
otherwise = do
                Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
j) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 LBool -> LBool -> Bool
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
iInt -> Int -> Int
forall 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  if Int
k Int -> Int -> Bool
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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
kInt -> Int -> Int
forall 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 <- ([(Int, Int)] -> [(Int, Int)])
-> IO [(Int, Int)] -> IO [(Int, Int)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Int) -> (Int, Int) -> Ordering)
-> (Int, Int) -> (Int, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd))) (IO [(Int, Int)] -> IO [(Int, Int)])
-> IO [(Int, Int)] -> IO [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
i..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
                           Int
lv <- Solver -> Int -> IO Int
litLevel Solver
solver Int
lit
                           (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
lit, Int
lv)
                         else do
                           (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
lit, Int
forall a. Bounded a => a
maxBound)
                       [(Int, (Int, Int))] -> ((Int, (Int, Int)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Clause -> [(Int, Int)] -> [(Int, (Int, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] [(Int, Int)]
xs) (((Int, (Int, Int)) -> IO ()) -> IO ())
-> ((Int, (Int, Int)) -> IO ()) -> IO ()
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
                    Int -> (Int -> Bool) -> (Int -> Int) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
i (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
n) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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.
                    Bool -> IO Bool
forall a. a -> IO a
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Clause -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Clause
lits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> (Int -> Bool) -> (Int -> Int) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
0 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
n) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Bool -> IO Bool
forall a. a -> IO a
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 Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Int -> IO Bool
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 then
      Int -> IO Bool
loop Int
0
    else
      Bool -> IO Bool
forall a. a -> IO a
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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int
litn <- LitArray -> Int -> IO Int
readLitArray LitArray
a Int
n
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
litn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
falsifiedLit) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    case Int
i of
      -1 -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String
str <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
this
          String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Bool -> IO Bool
forall a. a -> IO a
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
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    else Bool -> IO Bool
forall a. a -> IO a
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
        Bool -> IO Bool
forall a. a -> IO a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = () -> IO ()
forall a. a -> IO a
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
falsifiedLit) then
                Int -> IO ()
loop (Int
iInt -> Int -> Int
forall 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 <- (Int -> IO Int) -> Clause -> IO Clause
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (LitArray -> Int -> IO Int
readLitArray (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)) [Int
n..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] -- drop first n elements
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Clause
falsifiedLits ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
lit -> do
        LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"AtLeastHandler.constrReasonOf: %d is %s (lFalse expected)" Int
lit (LBool -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = String -> IO Int
forall a. HasCallStack => String -> a
error (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse
                  then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lit
                  else Int -> IO Int
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        Int
lit <- Int -> IO Int
go Int
0
        Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> IO Clause) -> Clause -> IO Clause
forall a b. (a -> b) -> a -> b
$ Int
lit Int -> Clause -> Clause
forall a. a -> [a] -> [a]
: Clause
falsifiedLits
      Just Int
lit -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Clause
es <- LitArray -> IO Clause
getLits (AtLeastHandler -> LitArray
atLeastLits AtLeastHandler
this)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
lit Int -> Clause -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Int -> Clause -> Clause
forall a. Int -> [a] -> [a]
take Int
n Clause
es) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"AtLeastHandler.constrReasonOf: cannot find %d in first %d elements" Int
n
        Clause -> IO Clause
forall a. a -> IO a
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  isPBRepresentable :: AtLeastHandler -> IO Bool
isPBRepresentable AtLeastHandler
_ = Bool -> IO Bool
forall a. a -> IO a
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)
    (PBLinSum, Integer) -> IO (PBLinSum, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Integer
1,Int
l) | Int
l <- Clause
lits], Int -> Integer
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)
    (Either () Int -> Bool) -> IO (Either () Int) -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either () Int -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either () Int) -> IO Bool) -> IO (Either () Int) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ExceptT () IO Int -> IO (Either () Int)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () IO Int -> IO (Either () Int))
-> ExceptT () IO Int -> IO (Either () Int)
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Int
-> (Int -> Int -> ExceptT () IO Int)
-> ExceptT () IO Int
forall a (m :: * -> *) b.
(Num a, Eq a, Monad m) =>
a -> a -> b -> (b -> a -> m b) -> m b
numLoopState Int
0 (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
0 ((Int -> Int -> ExceptT () IO Int) -> ExceptT () IO Int)
-> (Int -> Int -> ExceptT () IO Int) -> ExceptT () IO Int
forall a b. (a -> b) -> a -> b
$ \(!Int
n) Int
i -> do
      LBool
v <- IO LBool -> ExceptT () IO LBool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LBool -> ExceptT () IO LBool)
-> IO LBool -> ExceptT () IO LBool
forall a b. (a -> b) -> a -> b
$ Solver -> Int -> IO LBool
litValue Solver
solver (Int -> IO LBool) -> IO Int -> IO LBool
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lTrue then do
        Int -> ExceptT () IO Int
forall a. a -> ExceptT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
      else do
        let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        Bool -> ExceptT () IO () -> ExceptT () IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= AtLeastHandler -> Int
atLeastNum AtLeastHandler
this) (ExceptT () IO () -> ExceptT () IO ())
-> ExceptT () IO () -> ExceptT () IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT () IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ()
        Int -> ExceptT () IO Int
forall a. a -> ExceptT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

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

  constrWriteActivity :: AtLeastHandler -> Double -> IO ()
constrWriteActivity AtLeastHandler
this Double
aval = IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AtLeastHandler -> IORef Double
atLeastActivity AtLeastHandler
this) (Double -> IO ()) -> Double -> IO ()
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 = Clause -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Clause
lits
      n :: Int
n = AtLeastHandler -> Int
atLeastNum AtLeastHandler
this
      constr :: SomeConstraintHandler
constr = AtLeastHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler AtLeastHandler
this
  if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then do
    Solver -> IO ()
markBad Solver
solver
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then do
    (Int -> IO Bool) -> Clause -> IO Bool
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
    Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> Clause -> Clause
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Clause
lits) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
l -> Solver -> Int -> SomeConstraintHandler -> IO ()
watchLit Solver
solver Int
l SomeConstraintHandler
constr
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

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

newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler
newPBHandlerPromoted Solver
solver PBLinSum
lhs Integer
rhs Bool
learnt = do
  case (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 Int -> Int -> Bool
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
        SomeConstraintHandler -> IO SomeConstraintHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> IO SomeConstraintHandler)
-> SomeConstraintHandler -> IO SomeConstraintHandler
forall a b. (a -> b) -> a -> b
$ AtLeastHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler AtLeastHandler
h
      else do
        ClauseHandler
h <- Clause -> Bool -> IO ClauseHandler
newClauseHandler Clause
lhs2 Bool
learnt
        SomeConstraintHandler -> IO SomeConstraintHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeConstraintHandler -> IO SomeConstraintHandler)
-> SomeConstraintHandler -> IO SomeConstraintHandler
forall a b. (a -> b) -> a -> b
$ ClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler ClauseHandler
h

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

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

pbToClause :: PBLinAtLeast -> Maybe Clause
pbToClause :: (PBLinSum, Integer) -> Maybe Clause
pbToClause (PBLinSum, Integer)
pb = do
  (Clause
lhs, Int
rhs) <- (PBLinSum, Integer) -> Maybe (Clause, Int)
pbToAtLeast (PBLinSum, Integer)
pb
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
rhs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  Clause -> Maybe Clause
forall a. a -> Maybe a
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
(==) = IORef Integer -> IORef Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IORef Integer -> IORef Integer -> Bool)
-> (PBHandlerCounter -> IORef Integer)
-> PBHandlerCounter
-> PBHandlerCounter
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBHandlerCounter -> IORef Integer
pbSlack

instance Hashable PBHandlerCounter where
  hash :: PBHandlerCounter -> Int
hash = PBHandlerCounter -> Int
pbHash
  hashWithSalt :: Int -> PBHandlerCounter -> Int
hashWithSalt = Int -> PBHandlerCounter -> Int
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' = ((Integer, Int) -> (Integer, Int) -> Ordering)
-> PBLinSum -> PBLinSum
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Integer -> Integer -> Ordering) -> Integer -> Integer -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, Int) -> Integer)
-> (Integer, Int)
-> (Integer, Int)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, Int) -> Integer
forall a b. (a, b) -> a
fst) PBLinSum
ts
      slack :: Integer
slack = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Integer, Int) -> Integer) -> PBLinSum -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Int) -> Integer
forall a b. (a, b) -> a
fst PBLinSum
ts) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
degree
      m :: LitMap Integer
m = [(Int, Integer)] -> LitMap Integer
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
l,Integer
c) | (Integer
c,Int
l) <- PBLinSum
ts]
  IORef Integer
s <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
slack
  IORef Double
act <- Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then Double
0 else -Double
1)
  PBHandlerCounter -> IO PBHandlerCounter
forall a. a -> IO a
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 ((PBLinSum, Integer) -> Int
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
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ PBLinSum -> String
forall a. Show a => a -> String
show (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
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 <- ([Integer] -> Integer) -> IO [Integer] -> IO Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IO [Integer] -> IO Integer) -> IO [Integer] -> IO Integer
forall a b. (a -> b) -> a -> b
$ PBLinSum -> ((Integer, Int) -> IO Integer) -> IO [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) (((Integer, Int) -> IO Integer) -> IO [Integer])
-> ((Integer, Int) -> IO Integer) -> IO [Integer]
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lFalse then do
        Solver -> SomeConstraintHandler -> Int -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Int
l
        Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
      else do
        Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
c
    let slack :: Integer
slack = Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- PBHandlerCounter -> Integer
pbDegree PBHandlerCounter
this2
    IORef Integer -> Integer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> IO ()) -> Integer -> IO ()
forall a b. (a -> b) -> a -> b
$! Integer
slack
    if Integer
slack Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      (((Integer, Int) -> IO Bool) -> PBLinSum -> IO Bool)
-> PBLinSum -> ((Integer, Int) -> IO Bool) -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Integer, Int) -> IO Bool) -> PBLinSum -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) (((Integer, Int) -> IO Bool) -> IO Bool)
-> ((Integer, Int) -> IO Bool) -> IO Bool
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
slack Bool -> Bool -> Bool
&& LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then do
          Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
l SomeConstraintHandler
this
        else
          Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  constrDetach :: Solver -> SomeConstraintHandler -> PBHandlerCounter -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerCounter
this2 = do
    PBLinSum -> ((Integer, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2) (((Integer, Int) -> IO ()) -> IO ())
-> ((Integer, Int) -> IO ()) -> IO ()
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
    ((Integer, Int) -> IO Bool) -> PBLinSum -> IO Bool
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 LitMap Integer -> Int -> Integer
forall a. IntMap a -> Int -> a
IM.! Int
falsifiedLit
    IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
c)
    Solver -> SomeConstraintHandler -> Int -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Int
falsifiedLit
    Integer
s <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2)
    if Integer
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      PBLinSum -> ((Integer, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (((Integer, Int) -> Bool) -> PBLinSum -> PBLinSum
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Integer
c1,Int
_) -> Integer
c1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
s) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this2)) (((Integer, Int) -> IO ()) -> IO ())
-> ((Integer, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
_,Int
l1) -> do
        LBool
v <- Solver -> Int -> IO LBool
litValue Solver
solver Int
l1
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
v LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
l1 SomeConstraintHandler
this
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool -> IO Bool
forall a. a -> IO a
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
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Int -> IO Bool) -> Integer -> PBLinSum -> IO Clause
f Int -> IO Bool
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)
              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
idx2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
idx
        let c :: Integer
c = PBHandlerCounter -> LitMap Integer
pbCoeffMap PBHandlerCounter
this LitMap Integer -> Int -> Integer
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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) (PBHandlerCounter -> PBLinSum
pbTerms PBHandlerCounter
this)
    where
      {-# INLINE f #-}
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
      f :: (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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
ret
          go Integer
_ [] Clause
_ = String -> IO 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 LBool -> LBool -> Bool
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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) PBLinSum
xs (Int
litInt -> Clause -> Clause
forall 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 LitMap Integer -> Int -> Integer
forall a. IntMap a -> Int -> a
IM.! (- Int
lit)
    IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerCounter -> IORef Integer
pbSlack PBHandlerCounter
this2) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
c)

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

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

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

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

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

  constrWriteActivity :: PBHandlerCounter -> Double -> IO ()
constrWriteActivity PBHandlerCounter
this Double
aval = IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerCounter -> IORef Double
pbActivity PBHandlerCounter
this) (Double -> IO ()) -> Double -> IO ()
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
(==) = IORef Integer -> IORef Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IORef Integer -> IORef Integer -> Bool)
-> (PBHandlerPueblo -> IORef Integer)
-> PBHandlerPueblo
-> PBHandlerPueblo
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PBHandlerPueblo -> IORef Integer
puebloWatchSum

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

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

puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO ()
puebloWatch :: Solver
-> SomeConstraintHandler
-> PBHandlerPueblo
-> (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
  IORef LitSet -> (LitSet -> LitSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
pb) (Int -> LitSet -> LitSet
IS.insert Int
lit)
  IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PBHandlerPueblo -> IORef Integer
puebloWatchSum PBHandlerPueblo
pb) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c)

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

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

  showConstraintHandler :: PBHandlerPueblo -> IO String
showConstraintHandler PBHandlerPueblo
this = do
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ PBLinSum -> String
forall a. Show a => a -> String
show (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
wsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let f :: IntMap (a, 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 LBool -> LBool -> Bool
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)
              IntMap (a, Int) -> IO (IntMap (a, Int))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> (a, Int) -> IntMap (a, Int) -> IntMap (a, Int)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
idx (a, Int)
tm IntMap (a, Int)
m)
            else
              IntMap (a, Int) -> IO (IntMap (a, Int))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IntMap (a, Int)
m
      PBLinSum
xs <- (IntMap (Integer, Int) -> PBLinSum)
-> IO (IntMap (Integer, Int)) -> IO PBLinSum
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, (Integer, Int)) -> (Integer, Int))
-> [(Int, (Integer, Int))] -> PBLinSum
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Integer, Int)) -> (Integer, Int)
forall a b. (a, b) -> b
snd ([(Int, (Integer, Int))] -> PBLinSum)
-> (IntMap (Integer, Int) -> [(Int, (Integer, Int))])
-> IntMap (Integer, Int)
-> PBLinSum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Integer, Int) -> [(Int, (Integer, Int))]
forall a. IntMap a -> [(Int, a)]
IM.toDescList) (IO (IntMap (Integer, Int)) -> IO PBLinSum)
-> IO (IntMap (Integer, Int)) -> IO PBLinSum
forall a b. (a -> b) -> a -> b
$ (IntMap (Integer, Int)
 -> (Integer, Int) -> IO (IntMap (Integer, Int)))
-> IntMap (Integer, Int) -> PBLinSum -> IO (IntMap (Integer, Int))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM IntMap (Integer, Int)
-> (Integer, Int) -> IO (IntMap (Integer, Int))
forall {a}. IntMap (a, Int) -> (a, Int) -> IO (IntMap (a, Int))
f IntMap (Integer, Int)
forall a. IntMap a
IM.empty (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this2)
      let g :: Integer -> PBLinSum -> IO ()
g !Integer
_ [] = () -> IO ()
forall a. a -> IO a
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
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else Integer -> PBLinSum -> IO ()
g (Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
c) PBLinSum
ts
      Integer -> PBLinSum -> IO ()
g Integer
wsum PBLinSum
xs

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

  constrDetach :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this PBHandlerPueblo
this2 = do
    LitSet
ws <- IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this2)
    Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LitSet -> Clause
IS.toList LitSet
ws) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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
    ((Integer, Int) -> IO Bool) -> PBLinSum -> IO Bool
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 = Maybe (Integer, Int) -> (Integer, Int)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Integer, Int) -> (Integer, Int))
-> Maybe (Integer, Int) -> (Integer, Int)
forall a b. (a -> b) -> a -> b
$ ((Integer, Int) -> Bool) -> PBLinSum -> Maybe (Integer, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Int
l) -> Int
lInt -> Int -> Bool
forall 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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
wsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Solver -> SomeConstraintHandler -> Int -> IO ()
addOnUnassigned Solver
solver SomeConstraintHandler
this Int
falsifiedLit
    Bool -> IO Bool
forall a. a -> IO a
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
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Int -> IO Bool) -> Integer -> PBLinSum -> IO Clause
f Int -> IO Bool
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)
              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int
idx2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
idx
        let c :: Integer
c = (Integer, Int) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Int) -> Integer) -> (Integer, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Maybe (Integer, Int) -> (Integer, Int)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Integer, Int) -> (Integer, Int))
-> Maybe (Integer, Int) -> (Integer, Int)
forall a b. (a -> b) -> a -> b
$ ((Integer, Int) -> Bool) -> PBLinSum -> Maybe (Integer, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Int
l) -> Int
l Int -> Int -> Bool
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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) (PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this)
    where
      {-# INLINE f #-}
      f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit]
      f :: (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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
ret
          go Integer
_ [] Clause
_ = String -> IO 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 LBool -> LBool -> Bool
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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c) PBLinSum
xs (Int
litInt -> Clause -> Clause
forall 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 = Maybe (Integer, Int) -> (Integer, Int)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Integer, Int) -> (Integer, Int))
-> Maybe (Integer, Int) -> (Integer, Int)
forall a b. (a -> b) -> a -> b
$ ((Integer, Int) -> Bool) -> PBLinSum -> Maybe (Integer, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Integer
_,Int
l) -> Int
l Int -> Int -> Bool
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
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

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

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

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

  constrWriteActivity :: PBHandlerPueblo -> Double -> IO ()
constrWriteActivity PBHandlerPueblo
this Double
aval = IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PBHandlerPueblo -> IORef Double
puebloActivity PBHandlerPueblo
this) (Double -> IO ()) -> Double -> IO ()
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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
watchsum then
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else if Integer
watchsum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then do
    -- CONFLICT
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this
    -- UNIT PROPAGATION
    let f :: PBLinSum -> IO Bool
f [] = Bool -> IO Bool
forall a. a -> IO a
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' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this then
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else do
            LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Bool
b <- Solver -> Int -> SomeConstraintHandler -> IO Bool
assignBy Solver
solver Int
lit SomeConstraintHandler
constr
              Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            PBLinSum -> IO Bool
f PBLinSum
ts
    PBLinSum -> IO Bool
f (PBLinSum -> IO Bool) -> PBLinSum -> IO Bool
forall a b. (a -> b) -> a -> b
$ PBHandlerPueblo -> PBLinSum
puebloTerms PBHandlerPueblo
this

puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO ()
puebloUpdateWatchSum Solver
solver SomeConstraintHandler
constr PBHandlerPueblo
this = do
  let f :: PBLinSum -> IO ()
f [] = () -> IO ()
forall a. a -> IO a
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PBHandlerPueblo -> Integer
puebloDegree PBHandlerPueblo
this Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PBHandlerPueblo -> Integer
puebloAMax PBHandlerPueblo
this then
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          LBool
val <- Solver -> Int -> IO LBool
litValue Solver
solver Int
lit
          Bool
watched <- (LitSet -> Bool) -> IO LitSet -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int
lit Int -> LitSet -> Bool
`IS.member`) (IO LitSet -> IO Bool) -> IO LitSet -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef LitSet -> IO LitSet
forall a. IORef a -> IO a
readIORef (PBHandlerPueblo -> IORef LitSet
puebloWatches PBHandlerPueblo
this)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBool
val LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
lFalse Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
watched) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Solver
-> SomeConstraintHandler
-> PBHandlerPueblo
-> (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
(==) = LitArray -> LitArray -> Bool
forall a. Eq a => a -> a -> Bool
(==) (LitArray -> LitArray -> Bool)
-> (XORClauseHandler -> LitArray)
-> XORClauseHandler
-> XORClauseHandler
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` XORClauseHandler -> LitArray
xorLits

instance Hashable XORClauseHandler where
  hash :: XORClauseHandler -> Int
hash = XORClauseHandler -> Int
xorHash
  hashWithSalt :: Int -> XORClauseHandler -> Int
hashWithSalt = Int -> XORClauseHandler -> Int
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 <- Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$! (if Bool
learnt then Double
0 else -Double
1)
  XORClauseHandler -> IO XORClauseHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LitArray -> IORef Double -> Int -> XORClauseHandler
XORClauseHandler LitArray
a IORef Double
act (Clause -> Int
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)
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"XOR " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Clause -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if Int
size Int -> Int -> Bool
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 <- Int -> IO (IORef Int)
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 LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef then
              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do
              Int
j <- IORef Int -> IO Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              case Int
k of
                -1 -> do
                  Bool -> IO Bool
forall a. a -> IO a
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
                  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                  Bool -> IO Bool
forall a. a -> IO a
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
          Bool -> IO Bool
forall a. a -> IO a
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
_) <- ([(Int, Int)] -> (Int, Int)) -> IO [(Int, Int)] -> IO (Int, Int)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd)) (IO [(Int, Int)] -> IO (Int, Int))
-> IO [(Int, Int)] -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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
            (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
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' <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
            Int -> (Int -> Bool) -> (Int -> Int) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
1 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
size) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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
              IORef Bool -> (Bool -> Bool) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Bool
ref' (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val_j))
            IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref'
          Solver -> 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 <- ([(Int, Int)] -> Clause) -> IO [(Int, Int)] -> IO Clause
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int, Int) -> Int) -> [(Int, Int)] -> Clause
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst ([(Int, Int)] -> Clause)
-> ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Int) -> (Int, Int) -> Ordering)
-> (Int, Int) -> (Int, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd))) (IO [(Int, Int)] -> IO Clause) -> IO [(Int, Int)] -> IO Clause
forall a b. (a -> b) -> a -> b
$ Clause -> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO (Int, Int)) -> IO [(Int, Int)])
-> (Int -> IO (Int, Int)) -> IO [(Int, Int)]
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
          (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l,Int
lv)
        [(Int, Int)] -> ((Int, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Clause -> Clause -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] Clause
ls) (((Int, Int) -> IO ()) -> IO ()) -> ((Int, Int) -> IO ()) -> IO ()
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
        Solver -> XORClauseHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver XORClauseHandler
this2

  constrDetach :: Solver -> SomeConstraintHandler -> XORClauseHandler -> IO ()
constrDetach Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 = do
    Int
size <- LitArray -> IO Int
getLitArraySize (XORClauseHandler -> LitArray
xorLits XORClauseHandler
this2)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
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
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
b0 Bool -> Bool -> Bool
|| Bool
b1

  constrPropagate :: Solver
-> SomeConstraintHandler -> XORClauseHandler -> Int -> IO Bool
constrPropagate !Solver
solver SomeConstraintHandler
this XORClauseHandler
this2 !Int
falsifiedLit = do
    Bool
b <- Solver -> SomeConstraintHandler -> XORClauseHandler -> IO Bool
forall a.
ConstraintHandler a =>
Solver -> SomeConstraintHandler -> a -> IO Bool
constrIsLocked Solver
solver SomeConstraintHandler
this XORClauseHandler
this2
    if Bool
b then
      Bool -> IO Bool
forall a. a -> IO a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      case Int
i of
        -1 -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Solver -> IO String -> IO ()
logIO Solver
solver (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             String
str <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
this
             String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
            Int -> (Int -> Bool) -> (Int -> Int) -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
forLoop Int
1 (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
size) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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
              IORef Bool -> (Bool -> Bool) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Bool
ref (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (LBool -> Maybe Bool
unliftBool LBool
val_j))
            IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref
          Solver -> 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
          Bool -> IO Bool
forall a. a -> IO a
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
        Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int -> Int
litVar Int
l0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v Bool -> Bool -> Bool
|| Int -> Int
litVar Int
l1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Int
litVar Int
l0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v) (IO () -> IO ()) -> IO () -> IO ()
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 -> (Int -> IO Int) -> Clause -> IO Clause
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> IO Int
f Clause
lits
        Just Int
lit -> do
         case Clause
lits of
           Int
l1:Clause
ls -> do
             Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int -> Int
litVar Int
lit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int
litVar Int
l1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             (Int -> IO Int) -> Clause -> IO Clause
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> IO Int
f Clause
ls
           Clause
_ -> String -> IO Clause
forall a. HasCallStack => String -> a
error String
"XORClauseHandler.constrReasonOf: should not happen"
    Clause -> IO Clause
forall a. a -> IO a
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
        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> Int
literal Int
v (Bool -> Bool
not (Maybe Bool -> Bool
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

  toPBLinAtLeast :: XORClauseHandler -> IO (PBLinSum, Integer)
toPBLinAtLeast XORClauseHandler
_ = String -> IO (PBLinSum, Integer)
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 <- (Int -> IO LBool) -> Clause -> IO [LBool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Solver -> Int -> IO LBool
litValue Solver
solver) Clause
lits
    let f :: LBool -> LBool -> LBool
f LBool
x LBool
y
          | LBool
x LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef Bool -> Bool -> Bool
|| LBool
y LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
== LBool
lUndef = LBool
lUndef
          | Bool
otherwise = Bool -> LBool
liftBool (LBool
x LBool -> LBool -> Bool
forall a. Eq a => a -> a -> Bool
/= LBool
y)
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (LBool -> LBool -> LBool) -> LBool -> [LBool] -> LBool
forall b a. (b -> a -> b) -> 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 LBool -> LBool -> Bool
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)
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2

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

  constrWriteActivity :: XORClauseHandler -> Double -> IO ()
constrWriteActivity XORClauseHandler
this Double
aval = IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (XORClauseHandler -> IORef Double
xorActivity XORClauseHandler
this) (Double -> IO ()) -> Double -> IO ()
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 = XORClauseHandler -> SomeConstraintHandler
forall a. ConstraintHandler a => a -> SomeConstraintHandler
toConstraintHandler XORClauseHandler
this
  case Clause
lits of
    [] -> do
      Solver -> IO ()
markBad Solver
solver
      Bool -> IO Bool
forall a. a -> IO a
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
      Bool -> IO Bool
forall a. a -> IO a
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
  Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
levelRoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

instance Hashable TheoryHandler where
  hash :: TheoryHandler -> Int
hash TheoryHandler
_ = () -> Int
forall a. Hashable a => a -> Int
hash ()
  hashWithSalt :: Int -> TheoryHandler -> Int
hashWithSalt = Int -> TheoryHandler -> Int
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 = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"TheoryHandler"

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

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

  constrIsLocked :: Solver -> SomeConstraintHandler -> TheoryHandler -> IO Bool
constrIsLocked Solver
_solver SomeConstraintHandler
_this TheoryHandler
_this2 = Bool -> IO Bool
forall a. a -> IO a
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 =  String -> IO Bool
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 <- IORef (Maybe TheorySolver) -> IO (Maybe TheorySolver)
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
    Clause -> IO Clause
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> IO Clause) -> Clause -> IO Clause
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

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

  constrWriteActivity :: TheoryHandler -> Double -> IO ()
constrWriteActivity TheoryHandler
_this Double
_aval = () -> IO ()
forall a. a -> IO a
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 = (Int -> Int) -> Int -> Clause
forall a. (a -> a) -> a -> [a]
iterate (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
inc Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
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 = Double -> Double -> Clause
forall {a}. Integral a => Double -> Double -> [a]
go (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start)
  where
    go :: Double -> Double -> [a]
go !Double
inner !Double
outer = Double -> a
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
inner a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Double -> Double -> [a]
go Double
inner' Double
outer'
      where
        (Double
inner',Double
outer') =
          if Double
inner Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
outer
          then (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start, Double
outer Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
inc)
          else (Double
inner Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
inc, Double
outer)

lubyRestartSeq :: Int -> Double -> [Int]
lubyRestartSeq :: Int -> Double -> Clause
lubyRestartSeq Int
start Double
inc = (Integer -> Int) -> [Integer] -> Clause
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> (Integer -> Double) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start Double -> Double -> Double
forall a. Num a => a -> a -> a
*) (Double -> Double) -> (Integer -> Double) -> Integer -> Double
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1 = Integer -> Integer -> (Integer, Integer)
go (Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) (Integer
sequInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)
      | Bool
otherwise  = (Integer
size, Integer
sequ)

    go2 :: Integer -> Integer -> Integer -> Double
    go2 :: Integer -> Integer -> Integer -> Double
go2 Integer
size Integer
sequ Integer
x2
      | Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
x2 = let size' :: Integer
size' = (Integer
sizeInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2 in Integer -> Integer -> Integer -> Double
go2 Integer
size' (Integer
sequ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) (Integer
x2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
size')
      | Bool
otherwise = Double
y Double -> Integer -> Double
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 [] = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go (a
x:[a]
xs) = do
      Bool
b <- a -> m Bool
p a
x
      if Bool
b
        then [a] -> m Bool
go [a]
xs
        else Bool -> m Bool
forall a. a -> m a
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 [] = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    go (a
x:[a]
xs) = do
      Bool
b <- a -> m Bool
p a
x
      if Bool
b
        then Bool -> m Bool
forall a. a -> m a
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) <- IORef [a] -> IO [a]
forall a. IORef a -> IO a
readIORef IORef [a]
ref
  IORef [a] -> [a] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [a]
ref [a]
xs
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

#if !MIN_VERSION_hashable(1,4,3)

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

#endif

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

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

checkSatisfied :: Solver -> IO ()
checkSatisfied :: Solver -> IO ()
checkSatisfied Solver
solver = do
  [SomeConstraintHandler]
cls <- IORef [SomeConstraintHandler] -> IO [SomeConstraintHandler]
forall a. IORef a -> IO a
readIORef (Solver -> IORef [SomeConstraintHandler]
svConstrDB Solver
solver)
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
cls ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    Bool
b <- Solver -> SomeConstraintHandler -> IO Bool
forall a. ConstraintHandler a => Solver -> a -> IO Bool
isSatisfied Solver
solver SomeConstraintHandler
c
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String
s <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
c
      Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"BUG: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
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
  Clause -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Clause
vs ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> Double -> String
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
  [SomeConstraintHandler]
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeConstraintHandler]
xs ((SomeConstraintHandler -> IO ()) -> IO ())
-> (SomeConstraintHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeConstraintHandler
c -> do
    String
s <- SomeConstraintHandler -> IO String
forall a. ConstraintHandler a => a -> IO String
showConstraintHandler SomeConstraintHandler
c
    Double
aval <- SomeConstraintHandler -> IO Double
forall a. ConstraintHandler a => a -> IO Double
constrReadActivity SomeConstraintHandler
c
    Solver -> String -> IO ()
log Solver
solver (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Double -> String
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
  IORef (Maybe (String -> IO ())) -> Maybe (String -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (String -> IO ()))
svLogger Solver
solver) ((String -> IO ()) -> Maybe (String -> IO ())
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
  IORef (Maybe (String -> IO ())) -> Maybe (String -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Solver -> IORef (Maybe (String -> IO ()))
svLogger Solver
solver) Maybe (String -> IO ())
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 (String -> IO String
forall a. a -> IO a
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 <- IORef (Maybe (String -> IO ())) -> IO (Maybe (String -> IO ()))
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String -> IO ()
logger -> IO String
action IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
logger