-- |-- Module : Data.Boolean.SatSolver-- Copyright : Sebastian Fischer-- License : BSD3-- -- Maintainer : Sebastian Fischer (sebf@informatik.uni-kiel.de)-- Stability : experimental-- Portability : portable-- -- This Haskell library provides an implementation of the-- Davis-Putnam-Logemann-Loveland algorithm-- (cf. <http://en.wikipedia.org/wiki/DPLL_algorithm>) for the boolean-- satisfiability problem. It not only allows to solve boolean-- formulas in one go but also to add constraints and query bindings-- of variables incrementally.-- -- The implementation is not sophisticated at all but uses the basic-- DPLL algorithm with unit propagation.-- moduleData.Boolean.SatSolver(Boolean(..),SatSolver,newSatSolver,isSolved,lookupVar,assertTrue,branchOnVar,selectBranchVar,solve,isSolvable)whereimportData.ListimportData.BooleanimportControl.Monad.WriterimportqualifiedData.IntMapasIM-- | A @SatSolver@ can be used to solve boolean formulas.-- dataSatSolver=SatSolver{clauses::CNF,bindings::IM.IntMapBool}derivingShow-- | A new SAT solver without stored constraints.-- newSatSolver::SatSolvernewSatSolver=SatSolver[]IM.empty-- | This predicate tells whether all constraints are solved.-- isSolved::SatSolver->BoolisSolved=null.clauses-- |-- We can lookup the binding of a variable according to the currently-- stored constraints. If the variable is unbound, the result is-- @Nothing@.-- lookupVar::Int->SatSolver->MaybeBoollookupVarname=IM.lookupname.bindings-- | -- We can assert boolean formulas to update a @SatSolver@. The-- assertion may fail if the resulting constraints are unsatisfiable.-- assertTrue::MonadPlusm=>Boolean->SatSolver->mSatSolverassertTrueformulasolver=simplify(solver{clauses=booleanToCNFformula++clausessolver})-- |-- This function guesses a value for the given variable, if it is-- currently unbound. As this is a non-deterministic operation, the-- resulting solvers are returned in an instance of @MonadPlus@.-- branchOnVar::MonadPlusm=>Int->SatSolver->mSatSolverbranchOnVarnamesolver=maybe(branchOnUnboundnamesolver)(const(returnsolver))(lookupVarnamesolver)-- |-- We select a variable from the shortest clause hoping to produce a-- unit clause.--selectBranchVar::SatSolver->IntselectBranchVar=literalVar.head.head.sortByshorter.clauses-- | -- This function guesses values for variables such that the stored-- constraints are satisfied. The result may be non-deterministic and-- is, hence, returned in an instance of @MonadPlus@.-- solve::MonadPlusm=>SatSolver->mSatSolversolvesolver|isSolvedsolver=returnsolver|otherwise=branchOnUnbound(selectBranchVarsolver)solver>>=solve-- |-- This predicate tells whether the stored constraints are-- solvable. Use with care! This might be an inefficient operation. It-- tries to find a solution using backtracking and returns @True@ if-- and only if that fails.-- isSolvable::SatSolver->BoolisSolvable=not.null.solve-- private helper functionsupdateSolver::MonadPlusm=>CNF->[(Int,Bool)]->SatSolver->mSatSolverupdateSolvercsbssolver=dobs'<-foldr(uncurryinsertBinding)(return(bindingssolver))bsreturn$solver{clauses=cs,bindings=bs'}insertBinding::MonadPlusm=>Int->Bool->m(IM.IntMapBool)->m(IM.IntMapBool)insertBindingnamenewValuebinds=dobs<-bindsmaybe(return(IM.insertnamenewValuebs))(\oldValue->doguard(oldValue==newValue);returnbs)(IM.lookupnamebs)simplify::MonadPlusm=>SatSolver->mSatSolversimplifysolver=do(cs,bs)<-runWriterT.simplifyClauses.clauses$solverupdateSolvercsbssolversimplifyClauses::MonadPlusm=>CNF->WriterT[(Int,Bool)]mCNFsimplifyClauses[]=return[]simplifyClausesallClauses=doletshortestClause=head.sortByshorter$allClausesguard(not(nullshortestClause))ifnull(tailshortestClause)thenpropagate(headshortestClause)allClauses>>=simplifyClauseselsereturnallClausespropagate::MonadPlusm=>Literal->CNF->WriterT[(Int,Bool)]mCNFpropagateliteralallClauses=dotell[(literalVarliteral,isPositiveLiteralliteral)]return(foldrprop[]allClauses)wherepropccs|literal`elem`c=cs|otherwise=filter(invLiteralliteral/=)c:csbranchOnUnbound::MonadPlusm=>Int->SatSolver->mSatSolverbranchOnUnboundnamesolver=guess(Posname)solver`mplus`guess(Negname)solverguess::MonadPlusm=>Literal->SatSolver->mSatSolverguessliteralsolver=do(cs,bs)<-runWriterT(propagateliteral(clausessolver)>>=simplifyClauses)updateSolvercsbssolvershorter::[a]->[a]->Orderingshorter[][]=EQshorter[]_=LTshorter_[]=GTshorter(_:xs)(_:ys)=shorterxsys