packages feed

toysolver 0.5.0 → 0.6.0

raw patch · 146 files changed

+9402/−4639 lines, 146 filesdep +ansi-wl-pprintdep +bytestring-encodingdep +case-insensitivedep −prettyclassdep ~basedep ~bytestringdep ~clocknew-component:exe:probsat

Dependencies added: ansi-wl-pprint, bytestring-encoding, case-insensitive, optparse-applicative, pretty, zlib

Dependencies removed: prettyclass

Dependency ranges changed: base, bytestring, clock, criterion, hashable, haskeline, lattices, logic-TPTP, megaparsec, mwc-random, tasty-hunit, tasty-quickcheck

Files

CHANGELOG.markdown view
@@ -1,3 +1,30 @@+0.6.0+-----+* new solvers:+  * `ToySolver.SAT.SLS.ProbSAT` and sample `probsat` program+* new converters:+  * `ToySolver.Converter.NAESAT`+  * `ToySolver.Converter.SAT2MaxCut`+  * `ToySolver.Converter.SAT2MaxSAT`: SAT and 3-SAT to Max-2-SAT converter+  * `ToySolver.Converter.QBF2IPC`+  * `ToySolver.Converter.QUBO`: QUBO↔IsingModel converter+* new file format API:+  * merge `ToySolver.Text.MaxSAT`, `ToySolver.Text.GCNF`, `ToySolver.Text.QDimacs`, and `ToySolver.Text.CNF`+    info `ToySolver.FileFormat` and `ToySolver.FileFormat.CNF`+  * allow reading/writing `gzip`ped CNF/WCNF/GCNF/QDimacs/LP/MPS files+* rename modules:+  *	`ToySolver.Arith.Simplex2` to `ToySolver.Arith.Simplex`+  * `ToySolver.Arith.MIPSolver2` to `ToySolver.Arith.MIP`+  * `ToySolver.Data.Var` to `ToySolver.Data.IntVar`+* `ToySolver.SAT`:+  * add `cancel` function for interruption+  * introduce `PackedClause` type+* `ToySolver.Arith.Simplex`+  * introduce `Config` data type+  * implement bound tightening+* switch from `System.Console.GetOpt` to `optparse-applicative`+* stop supporting GHC-7.8+ 0.5.0 ----- * new solvers:
README.md view
@@ -1,9 +1,13 @@ toysolver ========= -[![Join the chat at https://gitter.im/msakai/toysolver](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/msakai/toysolver?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)+[![Join the chat at https://gitter.im/msakai/toysolver](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/msakai/toysolver) -[![Build Status](https://secure.travis-ci.org/msakai/toysolver.png?branch=master)](http://travis-ci.org/msakai/toysolver) [![Build status](https://ci.appveyor.com/api/projects/status/w7g615sp8ysiqk7w/branch/master?svg=true)](https://ci.appveyor.com/project/msakai/toysolver/branch/master) [![Coverage Status](https://coveralls.io/repos/msakai/toysolver/badge.svg)](https://coveralls.io/r/msakai/toysolver) [![Hackage](https://img.shields.io/hackage/v/toysolver.svg)](https://hackage.haskell.org/package/toysolver)+[![Build Status (Travis CI)](https://secure.travis-ci.org/msakai/toysolver.svg?branch=master)](http://travis-ci.org/msakai/toysolver)+[![Build Status (AppVeyor)](https://ci.appveyor.com/api/projects/status/w7g615sp8ysiqk7w/branch/master?svg=true)](https://ci.appveyor.com/project/msakai/toysolver/branch/master)+[![Coverage Status](https://coveralls.io/repos/msakai/toysolver/badge.svg)](https://coveralls.io/r/msakai/toysolver)+[![Hackage](https://img.shields.io/hackage/v/toysolver.svg)](https://hackage.haskell.org/package/toysolver)+[![License](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause)  It provides solver implementations of various problems including SAT, SMT, Max-SAT, PBS (Pseudo Boolean Satisfaction), PBO (Pseudo Boolean Optimization), MILP (Mixed Integer Linear Programming) and non-linear real arithmetic. @@ -122,9 +126,3 @@  * [ersatz-toysat](http://hackage.haskell.org/package/ersatz-toysat) -  toysat backend driver for [ersatz](http://hackage.haskell.org/package/ersatz) * [satchmo-toysat](http://hackage.haskell.org/package/satchmo-toysat) - toysat backend driver for [satchmo](http://hackage.haskell.org/package/satchmo)--TODO-------* Local search-
app/maxsatverify.hs view
@@ -6,7 +6,7 @@ import Data.IORef import System.Environment import Text.Printf-import qualified ToySolver.Text.MaxSAT as MaxSAT+import qualified ToySolver.FileFormat.CNF as CNF import ToySolver.SAT.Types import ToySolver.Internal.Util (setEncodingChar8) @@ -17,20 +17,20 @@ #endif    [problemFile, modelFile] <- getArgs-  Right wcnf <- MaxSAT.parseFile problemFile+  wcnf <- CNF.readFile problemFile   model <- liftM readModel (readFile modelFile)   costRef <- newIORef 0-  forM_ (MaxSAT.clauses wcnf) $ \(w,c) ->+  forM_ (CNF.wcnfClauses wcnf) $ \(w,c) ->     unless (eval model c) $-      if w == MaxSAT.topCost wcnf+      if w == CNF.wcnfTopCost wcnf       then printf "violated hard constraint: %s\n" (show c)       else do         tc <- readIORef costRef         writeIORef costRef $! tc + w   printf "total cost = %d\n" =<< readIORef costRef -eval :: Model -> Clause -> Bool-eval m lits = or [evalLit m lit | lit <- lits]+eval :: Model -> PackedClause -> Bool+eval m lits = or [evalLit m lit | lit <- unpackClause lits]  readModel :: String -> Model readModel s = array (1, maximum (0 : map fst ls2)) ls2
app/pbverify.hs view
@@ -6,7 +6,7 @@ import System.Environment import Text.Printf import qualified Data.PseudoBoolean as PBFile-import qualified Data.PseudoBoolean.Attoparsec as PBFileAttoparsec+import qualified ToySolver.FileFormat as FF import ToySolver.SAT.Types import ToySolver.Internal.Util (setEncodingChar8) @@ -17,7 +17,7 @@ #endif    [problemFile, modelFile] <- getArgs-  Right formula <- PBFileAttoparsec.parseOPBFile problemFile+  formula <- FF.readFile problemFile   model <- liftM readModel (readFile modelFile)   forM_ (PBFile.pbConstraints formula) $ \c ->     unless (eval model c) $
app/pigeonhole.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module Main where +import qualified Data.ByteString.Builder as ByteStringBuilder import Data.List import qualified Data.Map as Map import Data.Map (Map)@@ -8,6 +9,7 @@ import System.Exit import System.IO import Data.PseudoBoolean as PBFile+import qualified ToySolver.FileFormat as FF import ToySolver.Internal.Util (setEncodingChar8)  pigeonHole :: Integer -> Integer -> Formula@@ -41,7 +43,7 @@   case xs of     [p,h] -> do       let opb = pigeonHole (read p) (read h)-      hPutOPB stdout opb+      ByteStringBuilder.hPutBuilder stdout $ FF.render opb     _ -> do       hPutStrLn stderr "Usage: pigeonhole number_of_pigeons number_of_holes"       exitFailure
app/toyconvert.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- |@@ -8,111 +9,194 @@ --  -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  experimental--- Portability :  non-portable (CPP)+-- Portability :  non-portable -- -----------------------------------------------------------------------------  module Main where  import Control.Applicative+import Control.Monad import qualified Data.ByteString.Builder as ByteStringBuilder import Data.Char import Data.Default.Class-import Data.Maybe import qualified Data.Foldable as F+import Data.Maybe+import Data.Monoid import Data.Scientific (Scientific) import qualified Data.Text.Lazy.Builder as TextBuilder import qualified Data.Text.Lazy.IO as TLIO import qualified Data.Traversable as T import qualified Data.Version as V-import System.Environment+import Options.Applicative import System.IO import System.Exit import System.FilePath-import System.Console.GetOpt+import Text.PrettyPrint.ANSI.Leijen ((<+>))+import qualified Text.PrettyPrint.ANSI.Leijen as PP  import qualified Data.PseudoBoolean as PBFile-import qualified Data.PseudoBoolean.Attoparsec as PBFileAttoparsec  import qualified ToySolver.Data.MIP as MIP-import qualified ToySolver.Text.GCNF as GCNF-import qualified ToySolver.Text.MaxSAT as MaxSAT-import qualified ToySolver.Text.CNF as CNF+import ToySolver.Converter import ToySolver.Converter.ObjType-import qualified ToySolver.Converter.SAT2PB as SAT2PB-import qualified ToySolver.Converter.GCNF2MaxSAT as GCNF2MaxSAT-import qualified ToySolver.Converter.MIP2PB as MIP2PB import qualified ToySolver.Converter.MIP2SMT as MIP2SMT-import qualified ToySolver.Converter.MaxSAT2WBO as MaxSAT2WBO-import qualified ToySolver.Converter.PB2IP as PB2IP-import qualified ToySolver.Converter.PBLinearization as PBLinearization-import qualified ToySolver.Converter.PB2LSP as PB2LSP-import qualified ToySolver.Converter.PB2WBO as PB2WBO import qualified ToySolver.Converter.PBSetObj as PBSetObj-import qualified ToySolver.Converter.PB2SMP as PB2SMP-import qualified ToySolver.Converter.PB2SAT as PB2SAT-import qualified ToySolver.Converter.SAT2KSAT as SAT2KSAT-import qualified ToySolver.Converter.WBO2PB as WBO2PB-import qualified ToySolver.Converter.WBO2MaxSAT as WBO2MaxSAT+import qualified ToySolver.FileFormat as FF+import qualified ToySolver.QUBO as QUBO import ToySolver.Version import ToySolver.Internal.Util (setEncodingChar8) -data Flag-  = Help-  | Version-  | Output String-  | AsMaxSAT-  | ObjType ObjType-  | IndicatorConstraint-  | SMTSetLogic String-  | SMTOptimize-  | SMTNoCheck-  | SMTNoProduceModel-  | Yices2-  | Linearization-  | LinearizationUsingPB-  | KSat !Int-  | FileEncoding String-  | RemoveUserCuts-  deriving Eq+data Options = Options+  { optInput  :: FilePath+  , optOutput :: Maybe FilePath+  , optAsMaxSAT :: Bool+  , optObjType :: ObjType+  , optIndicatorConstraint :: Bool+  , optSMTSetLogic :: Maybe String+  , optSMTOptimize :: Bool+  , optSMTNoCheck :: Bool+  , optSMTNoProduceModel :: Bool+  , optYices2 :: Bool+  , optLinearization :: Bool+  , optLinearizationUsingPB :: Bool+  , optKSat :: Maybe Int+  , optFileEncoding :: Maybe String+  , optRemoveUserCuts :: Bool+  } deriving (Eq, Show) -options :: [OptDescr Flag]-options =-    [ Option ['h'] ["help"] (NoArg Help) "show help"-    , Option ['v'] ["version"] (NoArg Version)         "show version number"-    , Option ['o'] [] (ReqArg Output "FILE") "output filename"-    , Option []    ["maxsat"]  (NoArg AsMaxSAT)  "treat *.cnf file as MAX-SAT problem"-    , Option []    ["obj"] (ReqArg (ObjType . parseObjType) "STRING") "objective function for SAT/PBS: none (default), max-one, max-zero"-    , Option []    ["indicator"] (NoArg IndicatorConstraint) "use indicator constraints in output LP file"-    , Option []    ["smt-set-logic"] (ReqArg SMTSetLogic "STRING")　"output \"(set-logic STRING)\""-    , Option []    ["smt-optimize"] (NoArg SMTOptimize)   "output optimiality condition which uses quantifiers"-    , Option []    ["smt-no-check"] (NoArg SMTNoCheck)    "do not output \"(check)\""-    , Option []    ["smt-no-produce-model"] (NoArg SMTNoProduceModel) "do not output \"(set-option :produce-models true)\""    -    , Option []    ["yices2"] (NoArg Yices2) "output for yices2 rather than yices1"-    , Option []    ["linearize"] (NoArg Linearization) "linearize nonlinear pseudo-boolean constraints"-    , Option []    ["linearizer-pb"] (NoArg LinearizationUsingPB) "Use PB constraint in linearization"-    , Option []    ["ksat"] (ReqArg (KSat . read) "NUMBER") "generate k-SAT formula when outputing .cnf file"-    , Option []    ["encoding"] (ReqArg FileEncoding "<ENCODING>") "file encoding for LP/MPS files"-    , Option []    ["remove-usercuts"] (NoArg RemoveUserCuts) "remove user-defined cuts from LP/MPS files"-    ]+optionsParser :: Parser Options+optionsParser = Options+  <$> fileInput+  <*> outputOption+  <*> maxsatOption+  <*> objOption+  <*> indicatorConstraintOption+  <*> smtSetLogicOption+  <*> smtOptimizeOption+  <*> smtNoCheckOption+  <*> smtNoProduceModelOption+  <*> yices2Option+  <*> linearizationOption+  <*> linearizationPBOption+  <*> kSATOption+  <*> encodingOption+  <*> removeUserCutsOption   where-    parseObjType s =-      case map toLower s of-        "none"     -> ObjNone-        "max-one"  -> ObjMaxOne-        "max-zero" -> ObjMaxZero-        _          -> error ("unknown obj: " ++ s)+    fileInput :: Parser FilePath+    fileInput = argument str (metavar "FILE") -header :: String-header = unlines-  [ "Usage:"-  , "    toyconvert -o <outputfile> <inputfile>"-  , ""-  , "Supported formats:"-  , "    input: .cnf .wcnf .opb .wbo .gcnf .lp .mps"-  , "    output: .cnf .wcnf .opb .wbo .lsp .lp .mps .smp .smt2 .ys"-  , ""-  , "Options:"+    outputOption :: Parser (Maybe FilePath)+    outputOption = optional $ strOption+      $  long "output"+      <> short 'o'+      <> metavar "FILE"+      <> help "output filename"++    maxsatOption :: Parser Bool+    maxsatOption = switch+      $  long "maxsat"+      <> help "treat *.cnf file as MAX-SAT problem"++    objOption :: Parser ObjType+    objOption = option parseObjType+      $  long "obj"+      <> metavar "STR"+      <> help "objective function for SAT/PBS: none (default), max-one, max-zero"+      <> value ObjNone+      <> showDefaultWith showObjType+      where+        showObjType :: ObjType -> String+        showObjType ObjNone    = "none"+        showObjType ObjMaxOne  = "max-one"+        showObjType ObjMaxZero = "max-zero"++        parseObjType :: ReadM ObjType+        parseObjType = eitherReader $ \s ->+          case map toLower s of+            "none"     -> return ObjNone+            "max-one"  -> return ObjMaxOne+            "max-zero" -> return ObjMaxZero+            _          -> Left ("unknown obj: " ++ s)++    indicatorConstraintOption :: Parser Bool+    indicatorConstraintOption = switch+      $  long "indicator"+      <> help "use indicator constraints in output LP file"++    smtSetLogicOption :: Parser (Maybe String)+    smtSetLogicOption = optional $ strOption+      $  long "smt-set-logic"+      <> metavar "STR"+      <> help "output \"(set-logic STR)\""++    smtOptimizeOption :: Parser Bool+    smtOptimizeOption = switch+      $  long "smt-optimize"+      <> help "output optimiality condition which uses quantifiers"++    smtNoCheckOption :: Parser Bool+    smtNoCheckOption = switch+      $  long "smt-no-check"+      <> help "do not output \"(check)\""++    smtNoProduceModelOption :: Parser Bool+    smtNoProduceModelOption = switch+      $  long "smt-no-produce-model"+      <> help "do not output \"(set-option :produce-models true)\""++    yices2Option :: Parser Bool+    yices2Option = switch+      $  long "yices2"+      <> help "output for yices2 rather than yices1"++    linearizationOption :: Parser Bool+    linearizationOption = switch+      $  long "linearize"+      <> help "linearize nonlinear pseudo-boolean constraints"++    linearizationPBOption :: Parser Bool+    linearizationPBOption = switch+      $  long "linearizer-pb"+      <> help "Use PB constraint in linearization"++    kSATOption :: Parser (Maybe Int)+    kSATOption = optional $ option auto+      $  long "ksat"+      <> metavar "INT"+      <> help "generate k-SAT formula when outputing .cnf file"++    encodingOption :: Parser (Maybe String)+    encodingOption = optional $ strOption+      $  long "encoding"+      <> metavar "ENCODING"+      <> help "file encoding for LP/MPS files"++    removeUserCutsOption :: Parser Bool+    removeUserCutsOption = switch+      $  long "remove-usercuts"+      <> help "remove user-defined cuts from LP/MPS files"++parserInfo :: ParserInfo Options+parserInfo = info (helper <*> versionOption <*> optionsParser)+  $  fullDesc+  <> header "toyconvert - converter between various kind of problem files"+  <> footerDoc (Just supportedFormatsDoc)+  where+    versionOption :: Parser (a -> a)+    versionOption = infoOption (V.showVersion version)+      $  hidden+      <> long "version"+      <> help "Show version"++supportedFormatsDoc :: PP.Doc+supportedFormatsDoc =+  PP.vsep+  [ PP.text "Supported formats:"+  , PP.indent 2 $ PP.vsep+      [ PP.text "input:"  <+> (PP.align $ PP.fillSep $ map PP.text $ words ".cnf .wcnf .opb .wbo .gcnf .lp .mps .qubo")+      , PP.text "output:" <+> (PP.align $ PP.fillSep $ map PP.text $ words ".cnf .wcnf .opb .wbo .lsp .lp .mps .smp .smt2 .ys .qubo")+      ]   ]  data Problem@@ -120,89 +204,80 @@   | ProbWBO PBFile.SoftFormula   | ProbMIP (MIP.Problem Scientific) -readProblem :: [Flag] -> String -> IO Problem+readProblem :: Options -> String -> IO Problem readProblem o fname = do-  enc <- T.mapM mkTextEncoding $ last $ Nothing : [Just s | FileEncoding s <- o]-  case map toLower (takeExtension fname) of+  enc <- T.mapM mkTextEncoding (optFileEncoding o)+  case getExt fname of     ".cnf"-      | AsMaxSAT `elem` o -> readWCNF+      | optAsMaxSAT o ->+          liftM (ProbWBO . fst . maxsat2wbo) $ FF.readFile fname       | otherwise -> do-          ret <- CNF.parseFile fname-          case ret of-            Left err  -> hPrint stderr err >> exitFailure-            Right cnf -> return $ ProbOPB $ SAT2PB.convert cnf-    ".wcnf" -> readWCNF-    ".opb"  -> do-      ret <- PBFileAttoparsec.parseOPBFile fname-      case ret of-        Left err -> hPutStrLn stderr err >> exitFailure-        Right opb -> return $ ProbOPB opb-    ".wbo"  -> do-      ret <- PBFileAttoparsec.parseWBOFile fname-      case ret of-        Left err -> hPutStrLn stderr err >> exitFailure-        Right wbo -> return $ ProbWBO wbo-    ".gcnf" -> do-      ret <- GCNF.parseFile fname-      case ret of-        Left err -> hPutStrLn stderr err >> exitFailure-        Right gcnf -> return $ ProbWBO $ MaxSAT2WBO.convert $ GCNF2MaxSAT.convert gcnf+          liftM (ProbOPB . fst . sat2pb) $ FF.readFile fname+    ".wcnf" ->+      liftM (ProbWBO . fst . maxsat2wbo) $ FF.readFile fname+    ".opb"  -> liftM ProbOPB $ FF.readFile fname+    ".wbo"  -> liftM ProbWBO $ FF.readFile fname+    ".gcnf" ->+      liftM (ProbWBO . fst . maxsat2wbo . fst . gcnf2maxsat) $ FF.readFile fname     ".lp"   -> ProbMIP <$> MIP.readLPFile def{ MIP.optFileEncoding = enc } fname     ".mps"  -> ProbMIP <$> MIP.readMPSFile def{ MIP.optFileEncoding = enc } fname+    ".qubo" -> do+      (qubo :: QUBO.Problem Scientific) <- FF.readFile fname+      return $ ProbOPB $ fst $ qubo2pb qubo     ext ->       error $ "unknown file extension: " ++ show ext-  where    -    readWCNF = do-      ret <- MaxSAT.parseFile fname-      case ret of-        Left err -> hPutStrLn stderr err >> exitFailure-        Right wcnf -> return $ ProbWBO $ MaxSAT2WBO.convert $ wcnf -transformProblem :: [Flag] -> Problem -> Problem+getExt :: String -> String+getExt name | (base, ext) <- splitExtension name =+  case map toLower ext of+#ifdef WITH_ZLIB+    ".gz" -> getExt base+#endif+    s -> s++transformProblem :: Options -> Problem -> Problem transformProblem o = transformObj o . transformPBLinearization o . transformMIPRemoveUserCuts o -transformObj :: [Flag] -> Problem -> Problem+transformObj :: Options -> Problem -> Problem transformObj o problem =   case problem of-    ProbOPB opb | isNothing (PBFile.pbObjectiveFunction opb) -> ProbOPB $ PBSetObj.setObj objType opb+    ProbOPB opb | isNothing (PBFile.pbObjectiveFunction opb) -> ProbOPB $ PBSetObj.setObj (optObjType o) opb     _ -> problem-  where-    objType = last (ObjNone : [t | ObjType t <- o]) -transformPBLinearization :: [Flag] -> Problem -> Problem+transformPBLinearization :: Options -> Problem -> Problem transformPBLinearization o problem-  | Linearization `elem` o =+  | optLinearization o =       case problem of-        ProbOPB opb -> ProbOPB $ PBLinearization.linearize    opb (LinearizationUsingPB `elem` o)-        ProbWBO wbo -> ProbWBO $ PBLinearization.linearizeWBO wbo (LinearizationUsingPB `elem` o)+        ProbOPB opb -> ProbOPB $ fst $ linearizePB  opb (optLinearizationUsingPB o)+        ProbWBO wbo -> ProbWBO $ fst $ linearizeWBO wbo (optLinearizationUsingPB o)         ProbMIP mip -> ProbMIP mip   | otherwise = problem -transformMIPRemoveUserCuts :: [Flag] -> Problem -> Problem+transformMIPRemoveUserCuts :: Options -> Problem -> Problem transformMIPRemoveUserCuts o problem-  | RemoveUserCuts `elem` o =+  | optRemoveUserCuts o =       case problem of         ProbMIP mip -> ProbMIP $ mip{ MIP.userCuts = [] }         _ -> problem   | otherwise = problem -writeProblem :: [Flag] -> Problem -> IO ()+writeProblem :: Options -> Problem -> IO () writeProblem o problem = do-  enc <- T.mapM mkTextEncoding $ last $ Nothing : [Just s | FileEncoding s <- o]+  enc <- T.mapM mkTextEncoding (optFileEncoding o)   let mip2smtOpt =         def-        { MIP2SMT.optSetLogic     = listToMaybe [logic | SMTSetLogic logic <- o]-        , MIP2SMT.optCheckSAT     = not (SMTNoCheck `elem` o)-        , MIP2SMT.optProduceModel = not (SMTNoProduceModel `elem` o)-        , MIP2SMT.optOptimize     = SMTOptimize `elem` o+        { MIP2SMT.optSetLogic     = optSMTSetLogic o+        , MIP2SMT.optCheckSAT     = not (optSMTNoCheck o)+        , MIP2SMT.optProduceModel = not (optSMTNoProduceModel o)+        , MIP2SMT.optOptimize     = optSMTOptimize o         }-  case head ([Just fname | Output fname <- o] ++ [Nothing]) of+  case optOutput o of     Nothing -> do       hSetBinaryMode stdout True       hSetBuffering stdout (BlockBuffering Nothing)       case problem of-        ProbOPB opb -> PBFile.hPutOPB stdout opb-        ProbWBO wbo -> PBFile.hPutWBO stdout wbo+        ProbOPB opb -> ByteStringBuilder.hPutBuilder stdout $ FF.render opb+        ProbWBO wbo -> ByteStringBuilder.hPutBuilder stdout $ FF.render wbo         ProbMIP mip -> do           case MIP.toLPString def mip of             Left err -> hPutStrLn stderr ("conversion failure: " ++ err) >> exitFailure@@ -213,46 +288,46 @@       let opb = case problem of                   ProbOPB opb -> opb                   ProbWBO wbo ->-                    case WBO2PB.convert wbo of-                      (opb, _, _)-                        | Linearization `elem` o ->+                    case wbo2pb wbo of+                      (opb, _)+                        | optLinearization o ->                             -- WBO->OPB conversion may have introduced non-linearity-                            PBLinearization.linearize opb (LinearizationUsingPB `elem` o)+                            fst $ linearizePB opb (optLinearizationUsingPB o)                         | otherwise -> opb                   ProbMIP mip ->-                    case MIP2PB.convert (fmap toRational mip) of+                    case mip2pb (fmap toRational mip) of                       Left err -> error err-                      Right (opb, _, _) -> opb+                      Right (opb, _) -> opb           wbo = case problem of-                  ProbOPB opb -> PB2WBO.convert opb+                  ProbOPB opb -> fst $ pb2wbo opb                   ProbWBO wbo -> wbo-                  ProbMIP _   -> PB2WBO.convert opb+                  ProbMIP _   -> fst $ pb2wbo opb           lp  = case problem of                   ProbOPB opb ->-                    case PB2IP.convert opb of-                      (ip, _, _) -> fmap fromInteger ip+                    case pb2ip opb of+                      (ip, _) -> fmap fromInteger ip                   ProbWBO wbo ->-                    case PB2IP.convertWBO (IndicatorConstraint `elem` o) wbo of-                      (ip, _, _) -> fmap fromInteger ip+                    case wbo2ip (optIndicatorConstraint o) wbo of+                      (ip, _) -> fmap fromInteger ip                   ProbMIP mip -> mip           lsp = case problem of-                  ProbOPB opb -> PB2LSP.convert opb-                  ProbWBO wbo -> PB2LSP.convertWBO wbo-                  ProbMIP _   -> PB2LSP.convert opb-      case map toLower (takeExtension fname) of-        ".opb" -> PBFile.writeOPBFile fname opb-        ".wbo" -> PBFile.writeWBOFile fname wbo+                  ProbOPB opb -> pb2lsp opb+                  ProbWBO wbo -> wbo2lsp wbo+                  ProbMIP _   -> pb2lsp opb+      case getExt fname of+        ".opb" -> FF.writeFile fname $ normalizePB opb+        ".wbo" -> FF.writeFile fname $ normalizeWBO wbo         ".cnf" ->-          case PB2SAT.convert opb of-            (cnf, _, _) ->-              case head ([Just k | KSat k <- o] ++ [Nothing]) of-                Nothing -> CNF.writeFile fname cnf+          case pb2sat opb of+            (cnf, _) ->+              case optKSat o of+                Nothing -> FF.writeFile fname cnf                 Just k ->-                  let (cnf2, _, _) = SAT2KSAT.convert k cnf-                  in CNF.writeFile fname cnf2+                  let (cnf2, _) = sat2ksat k cnf+                  in FF.writeFile fname cnf2         ".wcnf" ->-          case WBO2MaxSAT.convert wbo of-            (wcnf, _, _) -> MaxSAT.writeFile fname wcnf+          case wbo2maxsat wbo of+            (wcnf, _) -> FF.writeFile fname wcnf         ".lsp" ->           withBinaryFile fname WriteMode $ \h ->             ByteStringBuilder.hPutBuilder h lsp@@ -260,36 +335,31 @@         ".mps" -> MIP.writeMPSFile def{ MIP.optFileEncoding = enc } fname lp         ".smp" -> do           withBinaryFile fname WriteMode $ \h ->-            ByteStringBuilder.hPutBuilder h (PB2SMP.convert False opb)+            ByteStringBuilder.hPutBuilder h (pb2smp False opb)         ".smt2" -> do           withFile fname WriteMode $ \h -> do             F.mapM_ (hSetEncoding h) enc             TLIO.hPutStr h $ TextBuilder.toLazyText $-              MIP2SMT.convert mip2smtOpt (fmap toRational lp)+              MIP2SMT.mip2smt mip2smtOpt (fmap toRational lp)         ".ys" -> do-          let lang = MIP2SMT.YICES (if Yices2 `elem` o then MIP2SMT.Yices2 else MIP2SMT.Yices1)+          let lang = MIP2SMT.YICES (if optYices2 o then MIP2SMT.Yices2 else MIP2SMT.Yices1)           withFile fname WriteMode $ \h -> do             F.mapM_ (hSetEncoding h) enc             TLIO.hPutStr h $ TextBuilder.toLazyText $-              MIP2SMT.convert mip2smtOpt{ MIP2SMT.optLanguage = lang } (fmap toRational lp)+              MIP2SMT.mip2smt mip2smtOpt{ MIP2SMT.optLanguage = lang } (fmap toRational lp)+        ".qubo" ->+          case pb2qubo opb of+            ((qubo, _th), _) -> FF.writeFile fname (fmap (fromInteger :: Integer -> Scientific) qubo)         ext -> do           error $ "unknown file extension: " ++ show ext-          + main :: IO () main = do #ifdef FORCE_CHAR8   setEncodingChar8 #endif -  args <- getArgs-  case getOpt Permute options args of-    (o,_,[])-      | Help `elem` o    -> putStrLn (usageInfo header options)-      | Version `elem` o -> putStrLn (V.showVersion version)-    (o,[fname],[]) -> do-      prob <- readProblem o fname-      let prob2 = transformProblem o prob-      writeProblem o prob2-    (_,_,errs) -> do-      hPutStrLn stderr $ concat errs ++ usageInfo header options-      exitFailure+  opt <- execParser parserInfo+  prob <- readProblem opt (optInput opt)+  let prob2 = transformProblem opt prob+  writeProblem opt prob2
app/toyfmf.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP, TypeFamilies, OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -22,23 +23,41 @@ import Data.Ratio import Data.String import qualified Data.Text as Text-import System.Environment-import System.IO+import Options.Applicative import qualified Codec.TPTP as TPTP import ToySolver.Data.Boolean import qualified ToySolver.EUF.FiniteModelFinder as MF import ToySolver.Internal.Util (setEncodingChar8) +data Options+  = Options+  { optInput :: FilePath+  , optSize :: Int+  }++optionsParser :: Parser Options+optionsParser = Options+  <$> fileInput+  <*> sizeInput+  where+    fileInput :: Parser FilePath+    fileInput = argument str $ metavar "FILE.tptp"++    sizeInput :: Parser Int+    sizeInput = argument auto $ metavar "SIZE"++parserInfo :: ParserInfo Options+parserInfo = info (helper <*> optionsParser)+  $  fullDesc+  <> header "toyfmf - a finite model finder"+ main :: IO () main = do #ifdef FORCE_CHAR8   setEncodingChar8 #endif--  args <- getArgs-  case args of-    [fpath, size] -> solve fpath (read size)-    _ -> hPutStrLn stderr "Usage: toyfmf <file.tptp> <size>"+  opt <- execParser parserInfo+  solve (optInput opt) (optSize opt)  solve :: FilePath -> Int -> IO () solve _ size | size <= 0 = error "<size> should be >=1"@@ -46,7 +65,7 @@   inputs <- TPTP.parseFile fpath   let fs = translateProblem inputs -  ref <- newIORef 0+  ref <- newIORef (0::Int)   let skolem name _ = do         n <- readIORef ref         let fsym = intern $ unintern name <> "#" <> fromString (show n)@@ -75,7 +94,7 @@   case i of     TPTP.Comment _ -> []     TPTP.Include _ _ -> error "\"include\" is not supported yet "-    TPTP.AFormula{ TPTP.name = _, TPTP.role = role, TPTP.formula = formula, TPTP.annotations = _ } ->+    TPTP.AFormula{ TPTP.name = _, TPTP.role = _, TPTP.formula = formula, TPTP.annotations = _ } ->       return $ translateFormula formula  translateFormula :: TPTP.Formula -> MF.Formula
app/toyqbf.hs view
@@ -16,107 +16,87 @@  import Control.Monad import Data.Char-import Data.Default.Class import qualified Data.IntSet as IntSet import Data.List+import Data.Monoid import Data.Ord import Data.Version-import System.Console.GetOpt-import System.Environment+import Options.Applicative import System.Exit import System.IO  import ToySolver.Data.Boolean import qualified ToySolver.Data.BoolExpr as BoolExpr+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.QBF as QBF-import qualified ToySolver.Text.QDimacs as QDimacs import ToySolver.Internal.Util (setEncodingChar8) import ToySolver.Version -data Mode-  = ModeHelp-  | ModeVersion-  deriving (Eq, Ord, Bounded, Enum)- data Options   = Options-  { optMode :: Maybe Mode-  , optAlgorithm :: String+  { optAlgorithm :: String+  , optInput :: FilePath   } -instance Default Options where-  def =-    Options-    { optMode = Nothing-    , optAlgorithm = "cegar-incremental"-    }+optionsParser :: Parser Options+optionsParser = Options+  <$> algorithmOption+  <*> fileInput+  where+    fileInput :: Parser FilePath+    fileInput = argument str (metavar "FILE") -options :: [OptDescr (Options -> Options)]-options =-    [ Option ['h'] ["help"]   (NoArg (\opt -> opt{ optMode = Just ModeHelp   })) "show help"-    , Option [] ["version"]   (NoArg (\opt -> opt{ optMode = Just ModeVersion})) "show version"-    , Option [] ["algorithm"]-        (ReqArg (\val opt -> opt{ optAlgorithm = val }) "<str>")-        "Algorithm: naive, cegar, cegar-incremental (default)"-    ]+    algorithmOption :: Parser String+    algorithmOption = strOption+      $  long "algorithm"+      <> metavar "STR"+      <> help "Algorithm: naive, cegar, cegar-incremental, qe"+      <> value "cegar-incremental"+      <> showDefaultWith id +parserInfo :: ParserInfo Options+parserInfo = info (helper <*> versionOption <*> optionsParser)+  $  fullDesc+  <> header "toyqbf - an QBF solver"+  where+    versionOption :: Parser (a -> a)+    versionOption = infoOption (showVersion version)+      $  hidden+      <> long "version"+      <> help "Show version"+ main :: IO () main = do #ifdef FORCE_CHAR8   setEncodingChar8 #endif--  args <- getArgs-  case getOpt Permute options args of-    (_,_,errs@(_:_)) -> do-      mapM_ putStrLn errs-      exitFailure--    (o,args2,[]) -> do-      let opt = foldl (flip id) def o-      case optMode opt of-        Just ModeHelp -> showHelp stdout-        Just ModeVersion -> hPutStrLn stdout (showVersion version)-        Nothing -> do-          case args2 of-            [fname] -> do-              ret <- QDimacs.parseFile fname-              case ret of-                Left err -> hPutStrLn stderr err >> exitFailure-                Right qdimacs -> do-                  let nv = QDimacs.numVars qdimacs-                      nc = QDimacs.numClauses qdimacs-                      prefix' = QBF.quantifyFreeVariables nv [(q, IntSet.fromList xs) | (q,xs) <- QDimacs.prefix qdimacs]-                      matrix' = andB [orB [if lit > 0 then BoolExpr.Atom lit else notB (BoolExpr.Atom (abs lit)) | lit <- clause] | clause <- QDimacs.matrix qdimacs]-                  (ans, certificate) <--                    case map toLower (optAlgorithm opt) of-                      "naive" -> QBF.solveNaive nv prefix' matrix'-                      "cegar" -> QBF.solveCEGAR nv prefix' matrix'-                      "cegar-incremental" -> QBF.solveCEGARIncremental nv prefix' matrix'-                      _ -> do-                        putStrLn $ "c unknown --algorithm option: " ++ show (optAlgorithm opt)-                        putStrLn $ "s cnf 0 " ++ show nv ++ " " ++ show nc-                        exitFailure-                  putStrLn $ "s cnf " ++ (if ans then "1" else "-1") ++ " " ++ show nv ++ " " ++ show nc-                  case certificate of-                    Nothing -> return ()-                    Just lits -> do-                      forM_ (sortBy (comparing abs) (IntSet.toList lits)) $ \lit -> do-                        putStrLn ("V " ++ show lit)-                  if ans then-                    exitWith (ExitFailure 10)-                  else-                    exitWith (ExitFailure 20)-            _ -> showHelp stderr >> exitFailure--showHelp :: Handle -> IO ()-showHelp h = hPutStrLn h (usageInfo header options)+  opt <- execParser parserInfo -header :: String-header = unlines-  [ "Usage:"-  , "  toyqbf [OPTION]... [file.qdimacs]"-  , "  toyqbf [OPTION]... [file.cnf]"-  , ""-  , "Options:"-  ]+  ret <- CNF.parseFile (optInput opt)+  case ret of+    Left err -> hPutStrLn stderr err >> exitFailure+    Right qdimacs -> do+      let nv = CNF.qdimacsNumVars qdimacs+          nc = CNF.qdimacsNumClauses qdimacs+          prefix' = QBF.quantifyFreeVariables nv [(q, IntSet.fromList xs) | (q,xs) <- CNF.qdimacsPrefix qdimacs]+          matrix' = andB [orB [if lit > 0 then BoolExpr.Atom lit else notB (BoolExpr.Atom (abs lit)) | lit <- CNF.unpackClause clause] | clause <- CNF.qdimacsMatrix qdimacs]+      (ans, certificate) <-+        case map toLower (optAlgorithm opt) of+          "naive" -> QBF.solveNaive nv prefix' matrix'+          "cegar" -> QBF.solveCEGAR nv prefix' matrix'+          "cegar-incremental" -> QBF.solveCEGARIncremental nv prefix' matrix'+          "qe" -> QBF.solveQE nv prefix' matrix'+          _ -> do+            putStrLn $ "c unknown --algorithm option: " ++ show (optAlgorithm opt)+            putStrLn $ "s cnf 0 " ++ show nv ++ " " ++ show nc+            exitFailure+      putStrLn $ "s cnf " ++ (if ans then "1" else "0") ++ " " ++ show nv ++ " " ++ show nc+      case certificate of+        Nothing -> return ()+        Just lits -> do+          forM_ (sortBy (comparing abs) (IntSet.toList lits)) $ \lit -> do+            putStrLn ("V " ++ show lit)+      if ans then+        exitWith (ExitFailure 10)+      else+        exitWith (ExitFailure 20)
app/toysat/UBCSAT.hs view
@@ -31,14 +31,14 @@ import Text.Megaparsec.String #endif +import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.Text.MaxSAT as MaxSAT  data Options   = Options   { optCommand :: FilePath   , optTempDir :: Maybe FilePath-  , optProblem :: MaxSAT.WCNF+  , optProblem :: CNF.WCNF   , optProblemFile :: Maybe FilePath   , optVarInit :: [SAT.Lit]   }@@ -48,11 +48,11 @@         { optCommand = "ubcsat"         , optTempDir = Nothing         , optProblem =-            MaxSAT.WCNF-            { MaxSAT.numVars    = 0-            , MaxSAT.numClauses = 0-            , MaxSAT.topCost    = 1-            , MaxSAT.clauses    = []+            CNF.WCNF+            { CNF.wcnfNumVars    = 0+            , CNF.wcnfNumClauses = 0+            , CNF.wcnfTopCost    = 1+            , CNF.wcnfClauses    = []             }         , optProblemFile   = Nothing         , optVarInit = []@@ -64,7 +64,7 @@   case ret of     Nothing -> return Nothing     Just (obj,_) ->-      if obj < MaxSAT.topCost (optProblem opt) then+      if obj < CNF.wcnfTopCost (optProblem opt) then         return ret       else         return Nothing@@ -97,10 +97,8 @@     Just fname -> f fname     Nothing -> do       withTempFile dir ".wcnf" $ \fname h -> do-        hSetBinaryMode h True-        hSetBuffering h (BlockBuffering Nothing)-        MaxSAT.hPutWCNF h (optProblem opt)         hClose h+        CNF.writeFile fname (optProblem opt)         f fname  ubcsat' :: Options -> FilePath -> Maybe FilePath -> IO [(Integer, SAT.Model)]@@ -111,7 +109,7 @@         [ "-alg", "irots"         , "-seed", "0"         , "-runs", "10"-        , "-cutoff", show (MaxSAT.numVars wcnf * 50)+        , "-cutoff", show (CNF.wcnfNumVars wcnf * 50)         , "-timeout", show (10 :: Int)         , "-gtimeout", show (30 :: Int)         , "-solve"@@ -132,7 +130,7 @@       return []     Right s -> do       forM_ (lines s) $ \l -> putStr "c " >> putStrLn l-      return $ scanSolutions (MaxSAT.numVars wcnf) s+      return $ scanSolutions (CNF.wcnfNumVars wcnf) s  scanSolutions :: Int -> String -> [(Integer, SAT.Model)] scanSolutions nv s = rights $ map (parse (solution nv) "") $ lines s
app/toysat/toysat.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE ScopedTypeVariables, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} ----------------------------------------------------------------------------- -- |@@ -16,7 +18,6 @@  module Main where -import Control.Applicative ((<$>)) import Control.Concurrent (getNumCapabilities) import Control.Concurrent.Timeout import Control.Monad@@ -36,42 +37,35 @@ import Data.IORef import Data.List import Data.Maybe+import Data.Monoid import Data.Ord-import Data.Word import qualified Data.Vector.Unboxed as V import Data.Version import Data.Scientific as Scientific import Data.Time+import Options.Applicative hiding (info)+import qualified Options.Applicative import System.IO-import System.Environment import System.Exit #if !MIN_VERSION_time(1,5,0) import System.Locale (defaultTimeLocale) #endif import System.Clock-import System.Console.GetOpt import System.FilePath import qualified System.Info as SysInfo import qualified System.Random.MWC as Rand import Text.Printf #ifdef __GLASGOW_HASKELL__ import GHC.Environment (getFullArgs)-#endif-#if defined(__GLASGOW_HASKELL__) import qualified GHC.Stats as Stats #endif  import qualified Data.PseudoBoolean as PBFile-import qualified Data.PseudoBoolean.Attoparsec as PBFileAttoparsec import qualified ToySolver.Data.MIP as MIP import qualified ToySolver.Data.MIP.Solution.Gurobi as GurobiSol-import qualified ToySolver.Converter.GCNF2MaxSAT as GCNF2MaxSAT-import qualified ToySolver.Converter.MaxSAT2WBO as MaxSAT2WBO-import qualified ToySolver.Converter.MIP2PB as MIP2PB-import qualified ToySolver.Converter.PB2SAT as PB2SAT-import qualified ToySolver.Converter.PB2WBO as PB2WBO-import qualified ToySolver.Converter.WBO2MaxSAT as WBO2MaxSAT-import qualified ToySolver.Converter.WBO2PB as WBO2PB+import ToySolver.Converter+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.FileFormat as FF import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.PBO as PBO@@ -82,9 +76,6 @@ import qualified ToySolver.SAT.MUS as MUS import qualified ToySolver.SAT.MUS.Enum as MUSEnum import ToySolver.SAT.Printer-import qualified ToySolver.Text.CNF as CNF-import qualified ToySolver.Text.MaxSAT as MaxSAT-import qualified ToySolver.Text.GCNF as GCNF import ToySolver.Version import ToySolver.Internal.Util (showRational, setEncodingChar8) @@ -92,11 +83,13 @@  -- ------------------------------------------------------------------------ -data Mode = ModeHelp | ModeVersion | ModeSAT | ModeMUS | ModePB | ModeWBO | ModeMaxSAT | ModeMIP+data Mode = ModeSAT | ModeMUS | ModeAllMUS | ModePB | ModeWBO | ModeMaxSAT | ModeMIP+  deriving (Eq, Ord, Enum, Bounded)  data Options   = Options-  { optMode          :: Maybe Mode+  { optInput         :: String+  , optMode          :: Maybe Mode   , optSATConfig     :: SAT.Config   , optRandomSeed    :: Maybe Rand.Seed   , optLinearizerPB  :: Bool@@ -104,7 +97,6 @@   , optObjFunVarsHeuristics :: Bool   , optLocalSearchInitial   :: Bool   , optMUSMethod :: MUS.Method-  , optAllMUSes :: Bool   , optAllMUSMethod :: MUSEnum.Method   , optPrintRational :: Bool   , optTimeout :: Integer@@ -118,7 +110,8 @@ instance Default Options where   def =     Options-    { optMode          = Nothing+    { optInput         = "" -- XXX+    , optMode          = Nothing     , optSATConfig     = def     , optRandomSeed    = Nothing     , optLinearizerPB  = False@@ -126,7 +119,6 @@     , optObjFunVarsHeuristics = PBO.defaultEnableObjFunVarsHeuristics     , optLocalSearchInitial   = False     , optMUSMethod = MUS.optMethod def-    , optAllMUSes = False     , optAllMUSMethod = MUSEnum.optMethod def     , optPrintRational = False     , optTimeout = 0@@ -137,176 +129,296 @@     , optFileEncoding = Nothing     } -options :: [OptDescr (Options -> Options)]-options =-    [ Option ['h'] ["help"]   (NoArg (\opt -> opt{ optMode = Just ModeHelp   })) "show help"-    , Option [] ["version"]   (NoArg (\opt -> opt{ optMode = Just ModeVersion})) "show version"+optionsParser :: Parser Options+optionsParser = Options+  <$> fileInput+  <*> modeOption+  <*> satConfigParser+  <*> randomSeedOption+  <*> linearizerPBOption+  <*> optMethodOption+  <*> objFunVarsHeuristicsOption+  <*> localSearchInitialOption+  <*> musMethodOption+  <*> allMUSMethodOption+  <*> printRationalOption+  <*> timeoutOption+  <*> writeFileOption+  <*> ubcsatOption+  <*> initSPOption+  <*> tempDirOption+  <*> fileEncodingOption+  where+    fileInput :: Parser String+    fileInput = strArgument $ metavar "(FILE|-)" -    , Option []    ["sat"]    (NoArg (\opt -> opt{ optMode = Just ModeSAT    })) "solve boolean satisfiability problem in .cnf file (default)"-    , Option []    ["mus"]    (NoArg (\opt -> opt{ optMode = Just ModeMUS    })) "solve minimally unsatisfiable subset problem in .gcnf or .cnf file"-    , Option []    ["pb"]     (NoArg (\opt -> opt{ optMode = Just ModePB     })) "solve pseudo boolean problem in .opb file"-    , Option []    ["wbo"]    (NoArg (\opt -> opt{ optMode = Just ModeWBO    })) "solve weighted boolean optimization problem in .wbo file"-    , Option []    ["maxsat"] (NoArg (\opt -> opt{ optMode = Just ModeMaxSAT })) "solve MaxSAT problem in .cnf or .wcnf file"-    , Option []    ["lp"]     (NoArg (\opt -> opt{ optMode = Just ModeMIP    })) "solve bounded integer programming problem in .lp or .mps file"+    modeOption :: Parser (Maybe Mode)+    -- modeOption = liftA msum $ T.sequenceA $ map optional $+    modeOption = optional $ foldr (<|>) empty+      [ flag' ModeSAT    $ long "sat"     <> help "solve boolean satisfiability problem in .cnf file"+      , flag' ModeMUS    $ long "mus"     <> help "solve minimally unsatisfiable subset problem in .gcnf or .cnf file"+      , flag' ModeAllMUS $ long "all-mus" <> help "enumerate minimally unsatisfiable subset of .gcnf or .cnf file"+      , flag' ModePB     $ long "pb"      <> help "solve pseudo boolean problem in .opb file"+      , flag' ModeWBO    $ long "wbo"     <> help "solve weighted boolean optimization problem in .wbo file"+      , flag' ModeMaxSAT $ long "maxsat"  <> help "solve MaxSAT problem in .cnf or .wcnf file"+      , flag' ModeMIP    $ long "lp"      <> help "solve LP/MIP problem in .lp or .mps file"+      ] -    , Option [] ["restart"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configRestartStrategy = parseRestartStrategy val } }) "<str>")-        ("Restart startegy: " ++ intercalate ", "-         [ SAT.showRestartStrategy s ++ (if SAT.configRestartStrategy (optSATConfig def) == s then " (default)" else "")-         | s <- [minBound .. maxBound] ])-    , Option [] ["restart-first"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configRestartFirst = read val } }) "<int>")-        (printf "The initial restart limit. (default %d)" (SAT.configRestartFirst def))-    , Option [] ["restart-inc"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configRestartInc = read val } }) "<real>")-        (printf "The factor with which the restart limit is multiplied in each restart. (default %f)" (SAT.configRestartInc def))-    , Option [] ["learning"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configLearningStrategy = parseLearningStrategy val } }) "<str>")-        ("Leaning scheme: " ++ intercalate ", "-         [ SAT.showLearningStrategy s ++ (if SAT.configLearningStrategy (optSATConfig def) == s then " (default)" else "")-         | s <- [minBound .. maxBound] ])-    , Option [] ["learnt-size-first"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configLearntSizeFirst = read val } }) "<int>")-        "The initial limit for learnt clauses."-    , Option [] ["learnt-size-inc"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configLearntSizeInc = read val } }) "<real>")-        (printf "The limit for learnt clauses is multiplied with this factor periodically. (default %f)" (SAT.configLearntSizeInc def))-    , Option [] ["branch"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configBranchingStrategy = parseBranchingStrategy val } }) "<str>")-        ("Branching startegy: " ++ intercalate ", "-         [ SAT.showBranchingStrategy s ++ (if SAT.configBranchingStrategy (optSATConfig def) == s then " (default)" else "")-         | s <- [minBound .. maxBound] ])-    , Option [] ["erwa-alpha-first"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configERWAStepSizeFirst = read val } }) "<real>")-        (printf "step-size alpha in ERWA and LRB branching heuristic is initialized with this value. (default %f)" (SAT.configERWAStepSizeFirst def))-    , Option [] ["erwa-alpha-dec"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configERWAStepSizeDec = read val } }) "<real>")-        (printf "step-size alpha in ERWA and LRB branching heuristic is decreased by this value after each conflict. (default %f)" (SAT.configERWAStepSizeDec def))-    , Option [] ["erwa-alpha-min"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configERWAStepSizeMin = read val } }) "<real>")-        (printf "step-size alpha in ERWA and LRB branching heuristic is decreased until it reach the value. (default %f)" (SAT.configERWAStepSizeMin def))-    , Option [] ["ema-decay"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEMADecay = read val } }) "<real>")-        (printf "inverse of the variable EMA decay factor used by LRB branching heuristic. (default %f)" (SAT.configEMADecay def))-    , Option [] ["ccmin"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configCCMin = read val } }) "<int>")-        (printf "Conflict clause minimization (0=none, 1=local, 2=recursive; default %d)" (SAT.configCCMin def))-    , Option [] ["enable-phase-saving"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnablePhaseSaving = True } }))-        ("Enable phase saving" ++ (if SAT.configEnablePhaseSaving def then " (default)" else ""))-    , Option [] ["disable-phase-saving"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnablePhaseSaving = False } }))-        ("Disable phase saving" ++ (if SAT.configEnablePhaseSaving def then "" else " (default)"))-    , Option [] ["enable-forward-subsumption-removal"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnableForwardSubsumptionRemoval = True } }))-        ("Enable forward subumption removal (clauses only)" ++ (if SAT.configEnableForwardSubsumptionRemoval def then " (default)" else ""))-    , Option [] ["disable-forward-subsumption-removal"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnableForwardSubsumptionRemoval = False } }))-        ("Disable forward subsumption removal (clauses only)" ++ (if SAT.configEnableForwardSubsumptionRemoval def then "" else " (default)"))-    , Option [] ["enable-backward-subsumption-removal"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnableBackwardSubsumptionRemoval = True } }))-        ("Enable backward subsumption removal." ++ (if SAT.configEnableBackwardSubsumptionRemoval def then " (default)" else ""))-    , Option [] ["disable-backward-subsumption-removal"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnableBackwardSubsumptionRemoval = False } }))-        ("Disable backward subsumption removal." ++ (if SAT.configEnableBackwardSubsumptionRemoval def then "" else " (default)"))+    randomSeedOption = optional $ fmap (Rand.toSeed . V.fromList . map read . words) $ strOption+      $  long "random-seed"+      <> long "random-gen"+      <> metavar "\"INT ..\""+      <> help "random seed used by the random variable selection" -    , Option [] ["random-freq"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configRandomFreq = read val } }) "<0..1>")-        (printf "The frequency with which the decision heuristic tries to choose a random variable (default %f)" (SAT.configRandomFreq def))-    , Option [] ["random-seed"]-        (ReqArg (\val opt -> opt{ optRandomSeed = Just (Rand.toSeed (V.singleton (read val) :: V.Vector Word32)) }) "<int>")-        "random seed used by the random variable selection"-    , Option [] ["random-gen"]-        (ReqArg (\val opt -> opt{ optRandomSeed = Just (Rand.toSeed (V.fromList (map read $ words $ val) :: V.Vector Word32)) }) "<str>")-        "another way of specifying random seed used by the random variable selection"+    linearizerPBOption = switch+      $  long "linearizer-pb"+      <> help "Use PB constraint in linearization." -    , Option [] ["init-sp"]-        (NoArg (\opt -> opt{ optInitSP = True }))-        "Use survey propation to compute initial polarity (when possible)"+    optMethodOption = option (maybeReader PBO.parseMethod)+      $  long "opt-method"+      <> metavar "STR"+      <> help ("Optimization method: " ++ intercalate ", " [PBO.showMethod m | m <- [minBound..maxBound]])+      <> value (optOptMethod def)+      <> showDefaultWith PBO.showMethod -    , Option [] ["linearizer-pb"]-        (NoArg (\opt -> opt{ optLinearizerPB = True }))-        "Use PB constraint in linearization."+    objFunVarsHeuristicsOption =+          flag' True+            (  long "objfun-heuristics"+            <> help ("Enable heuristics for polarity/activity of variables in objective function" +++                     (if PBO.defaultEnableObjFunVarsHeuristics then " (default)" else "")))+      <|> flag' False+            (  long "no-objfun-heuristics"+            <> help ("Disable heuristics for polarity/activity of variables in objective function" +++                     (if PBO.defaultEnableObjFunVarsHeuristics then "" else " (default)")))+      <|> pure PBO.defaultEnableObjFunVarsHeuristics -    , Option [] ["pb-handler"]-        (ReqArg (\val opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configPBHandlerType = parsePBHandler val } }) "<str>")-        ("PB constraint handler: " ++ intercalate ", "-         [ SAT.showPBHandlerType h ++ (if SAT.configPBHandlerType (optSATConfig def) == h then " (default)" else "")-         | h <- [minBound .. maxBound] ])-    , Option [] ["pb-split-clause-part"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnablePBSplitClausePart = True } }))-        ("Split clause part of PB constraints." ++ (if SAT.configEnablePBSplitClausePart def then " (default)" else ""))-    , Option [] ["no-pb-split-clause-part"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configEnablePBSplitClausePart = False } }))-        ("Do not split clause part of PB constraints." ++ (if SAT.configEnablePBSplitClausePart def then "" else " (default)"))+    localSearchInitialOption = switch+      $  long "ls-initial"+      <> help "Use local search (currently UBCSAT) for finding initial solution" -    , Option [] ["opt-method"]-        (ReqArg (\val opt -> opt{ optOptMethod = parseOptMethod val }) "<str>")-        ("Optimization method: " ++ intercalate ", "-         [PBO.showMethod m ++ (if optOptMethod def == m then " (default)" else "") | m <- [minBound .. maxBound]])-    , Option [] ["objfun-heuristics"]-        (NoArg (\opt -> opt{ optObjFunVarsHeuristics = True }))-        "Enable heuristics for polarity/activity of variables in objective function (default)"-    , Option [] ["no-objfun-heuristics"]-        (NoArg (\opt -> opt{ optObjFunVarsHeuristics = False }))-        "Disable heuristics for polarity/activity of variables in objective function"-    , Option [] ["ls-initial"]-        (NoArg (\opt -> opt{ optLocalSearchInitial = True }))-        "Use local search (currently UBCSAT) for finding initial solution"+    musMethodOption = option (maybeReader MUS.parseMethod)+      $  long "mus-method"+      <> metavar "STR"+      <> help ("MUS computation method: " ++ intercalate ", " [MUS.showMethod m | m <- [minBound..maxBound]])+      <> value (optMUSMethod def)+      <> showDefaultWith MUS.showMethod -    , Option [] ["all-mus"]-        (NoArg (\opt -> opt{ optMode = Just ModeMUS, optAllMUSes = True }))-        "enumerate all MUSes"-    , Option [] ["mus-method"]-        (ReqArg (\val opt -> opt{ optMUSMethod = parseMUSMethod val }) "<str>")-        ("MUS computation method: " ++ intercalate ", "-         [MUS.showMethod m ++ (if optMUSMethod def == m then " (default)" else "") | m <- [minBound .. maxBound]])-    , Option [] ["all-mus-method"]-        (ReqArg (\val opt -> opt{ optAllMUSMethod = parseAllMUSMethod val }) "<str>")-        ("MUS enumeration method: " ++ intercalate ", "-         [MUSEnum.showMethod m ++ (if optAllMUSMethod def == m then " (default)" else "") | m <- [minBound .. maxBound]])+    allMUSMethodOption = option (maybeReader MUSEnum.parseMethod)+      $  long "all-mus-method"+      <> metavar "STR"+      <> help (("MUS enumeration method: " ++ intercalate ", " [MUSEnum.showMethod m | m <- [minBound..maxBound]]))+      <> value (optAllMUSMethod def)+      <> showDefaultWith MUSEnum.showMethod -    , Option [] ["print-rational"]-        (NoArg (\opt -> opt{ optPrintRational = True }))-        "print rational numbers instead of decimals"-    , Option ['w'] []-        (ReqArg (\val opt -> opt{ optWriteFile = Just val }) "<filename>")-        "write model to filename in Gurobi .sol format"+    printRationalOption = switch+      $  long "print-rational"+      <> help "print rational numbers instead of decimals" -    , Option [] ["check-model"]-        (NoArg (\opt -> opt{ optSATConfig = (optSATConfig opt){ SAT.configCheckModel = True } }))-        "check model for debug"+    timeoutOption = option auto+      $  long "timeout"+      <> metavar "INT"+      <> help "Kill toysat after given number of seconds (0 means no limit)"+      <> value (optTimeout def)+      <> showDefault -    , Option [] ["timeout"]-        (ReqArg (\val opt -> opt{ optTimeout = read val }) "<int>")-        "Kill toysat after given number of seconds (default 0 (no limit))"+    writeFileOption = optional $ strOption+      $  short 'w'+      <> metavar "FILE"+      <> help "write model to filename in Gurobi .sol format" -    , Option [] ["with-ubcsat"]-        (ReqArg (\val opt -> opt{ optUBCSAT = val }) "<PATH>")-        "give the path to the UBCSAT command"-    , Option [] ["temp-dir"]-        (ReqArg (\val opt -> opt{ optTempDir = Just val }) "<PATH>")-        "temporary directory"+    ubcsatOption = strOption+      $  long "with-ubcsat"+      <> metavar "PATH"+      <> help "give the path to the UBCSAT command"+      <> value (optUBCSAT def) -    , Option [] ["encoding"]-        (ReqArg (\val opt -> opt{ optFileEncoding = Just val }) "<ENCODING>")-        "file encoding for LP/MPS files"-    ]+    initSPOption = switch+      $  long "init-sp"+      <> help "Use survey propation to compute initial polarity (when possible)"++    tempDirOption = optional $ strOption+      $  long "temp-dir"+      <> metavar "PATH"+      <> help "temporary directory"++    fileEncodingOption = optional $ strOption+      $  long "encoding"+      <> metavar "ENCODING"+      <> help "file encoding for LP/MPS files"+++satConfigParser :: Parser SAT.Config+satConfigParser = SAT.Config+  <$> restartOption+  <*> restartFirstOption+  <*> restartIncOption+  <*> learningOption+  <*> learntSizeFirstOption+  <*> learntSizeIncOption+  <*> ccMinOption+  <*> branchOption+  <*> eRWAStepSizeFirstOption+  <*> eRWAStepSizeDecOption+  <*> eRWAStepSizeMinOption+  <*> eMADecayOption+  <*> enablePhaseSavingOption+  <*> enableForwardSubsumptionRemovalOption+  <*> enableBackwardSubsumptionRemovalOption+  <*> randomFreqOption+  <*> pbHandlerTypeOption+  <*> enablePBSplitClausePartOption+  <*> checkModelOption+  <*> pure (SAT.configVarDecay def)+  <*> pure (SAT.configConstrDecay def)   where-    parseOptMethod s = fromMaybe (error (printf "unknown optimization method \"%s\"" s)) (PBO.parseMethod s)+    restartOption = option (maybeReader SAT.parseRestartStrategy)+      $  long "restart"+      <> metavar "STR"+      <> help ("Restart startegy: " ++ intercalate ", " [SAT.showRestartStrategy s | s <- [minBound..maxBound]])+      <> value (SAT.configRestartStrategy def)+      <> showDefaultWith SAT.showRestartStrategy+    restartFirstOption = option auto+      $  long "restart-first"+      <> metavar "INT"+      <> help "The initial restart limit."+      <> value (SAT.configRestartFirst def)+      <> showDefault+    restartIncOption = option auto+      $  long "restart-inc"+      <> metavar "REAL"+      <> help "The factor with which the restart limit is multiplied in each restart."+      <> value (SAT.configRestartInc def)+      <> showDefault -    parseMUSMethod s = fromMaybe (error (printf "unknown MUS finding method \"%s\"" s)) (MUS.parseMethod s)+    learningOption = option (maybeReader SAT.parseLearningStrategy)+      $  long "learning"+      <> metavar "STR"+      <> help ("Leaning scheme: " ++ intercalate ", " [SAT.showLearningStrategy s | s <- [minBound..maxBound]])+      <> value (SAT.configLearningStrategy def)+      <> showDefaultWith SAT.showLearningStrategy+    learntSizeFirstOption = option auto+      $  long "learnt-size-first"+      <> metavar "INT"+      <> help "The initial limit for learnt clauses."+      <> value (SAT.configLearntSizeFirst def)+      <> showDefault+    learntSizeIncOption = option auto+      $  long "learnt-size-inc"+      <> metavar "REAL"+      <> help "The limit for learnt clauses is multiplied with this factor periodically."+      <> value (SAT.configLearntSizeInc def)+      <> showDefault -    parseAllMUSMethod s = fromMaybe (error (printf "unknown MUS enumeration method \"%s\"" s)) (MUSEnum.parseMethod s)+    ccMinOption = option auto+      $  long "ccmin"+      <> metavar "INT"+      <> help "Conflict clause minimization: 0=none, 1=local, 2=recursive"+      <> value (SAT.configCCMin def)+      <> showDefault+    branchOption = option (maybeReader SAT.parseBranchingStrategy)+      $  long "branch"+      <> metavar "STR"+      <> help ("Branching startegy: " ++ intercalate ", " [SAT.showBranchingStrategy s | s <- [minBound..maxBound]])+      <> value (SAT.configBranchingStrategy def)+      <> showDefaultWith SAT.showBranchingStrategy -    parseRestartStrategy s = fromMaybe (error (printf "unknown restart strategy \"%s\"" s)) (SAT.parseRestartStrategy s)+    eRWAStepSizeFirstOption = option auto+      $  long "erwa-alpha-first"+      <> metavar "REAL"+      <> help "step-size alpha in ERWA and LRB branching heuristic is initialized with this value."+      <> value (SAT.configERWAStepSizeFirst def)+      <> showDefault+    eRWAStepSizeDecOption = option auto+      $  long "erwa-alpha-dec"+      <> metavar "REAL"+      <> help "step-size alpha in ERWA and LRB branching heuristic is decreased by this value after each conflict."+      <> value (SAT.configERWAStepSizeDec def)+      <> showDefault+    eRWAStepSizeMinOption = option auto+      $  long "erwa-alpha-min"+      <> metavar "REAL"+      <> help "step-size alpha in ERWA and LRB branching heuristic is decreased until it reach the value."+      <> value (SAT.configERWAStepSizeMin def)+      <> showDefault -    parseLearningStrategy s = fromMaybe (error (printf "unknown learning strategy \"%s\"" s)) (SAT.parseLearningStrategy s)+    eMADecayOption = option auto+      $  long "ema-decay"+      <> metavar "REAL"+      <> help "inverse of the variable EMA decay factor used by LRB branching heuristic."+      <> value (SAT.configEMADecay def)+      <> showDefault -    parseBranchingStrategy s = fromMaybe (error (printf "unknown branching strategy \"%s\"" s)) (SAT.parseBranchingStrategy s)+    enablePhaseSavingOption =+          flag' True  (long "enable-phase-saving"  <> help ("Enable phase saving"  ++ (if SAT.configEnablePhaseSaving def then " (default)" else "")))+      <|> flag' False (long "disable-phase-saving" <> help ("Disable phase saving" ++ (if SAT.configEnablePhaseSaving def then "" else " (default)")))+      <|> pure (SAT.configEnablePhaseSaving def) -    parsePBHandler s = fromMaybe (error (printf "unknown PB constraint handler \"%s\"" s)) (SAT.parsePBHandlerType s)+    enableForwardSubsumptionRemovalOption =+          flag' True+            (  long "enable-forward-subsumption-removal"+            <> help ("Enable forward subumption removal (clauses only)"  ++ (if SAT.configEnableForwardSubsumptionRemoval def then " (default)" else "")))+      <|> flag' False+            (  long "disable-forward-subsumption-removal"+            <> help ("Disable forward subumption removal (clauses only)" ++ (if SAT.configEnableForwardSubsumptionRemoval def then "" else " (default)")))+      <|> pure (SAT.configEnableForwardSubsumptionRemoval def)+    enableBackwardSubsumptionRemovalOption =+          flag' True+            (  long "enable-backward-subsumption-removal"+            <> help ("Enable backward subumption removal (clauses only)"  ++ (if SAT.configEnableBackwardSubsumptionRemoval def then " (default)" else "")))+      <|> flag' False+            (  long "disable-backward-subsumption-removal"+            <> help ("Disable backward subumption removal (clauses only)" ++ (if SAT.configEnableBackwardSubsumptionRemoval def then "" else " (default)")))+      <|> pure (SAT.configEnableBackwardSubsumptionRemoval def) +    randomFreqOption = option auto+      $  long "random-freq"+      <> metavar "0..1"+      <> help "The frequency with which the decision heuristic tries to choose a random variable"+      <> value (SAT.configRandomFreq def)+      <> showDefault++    pbHandlerTypeOption = option (maybeReader SAT.parsePBHandlerType)+      $  long "pb-handler"+      <> metavar "STR"+      <> help ("PB constraint handler: " ++ intercalate ", " [SAT.showPBHandlerType h | h <- [minBound..maxBound]])+      <> value (SAT.configPBHandlerType def)+      <> showDefaultWith SAT.showPBHandlerType++    enablePBSplitClausePartOption =+          flag' True+            (  long "pb-split-clause-part"+            <> help ("Split clause part of PB constraints." ++ (if SAT.configEnablePBSplitClausePart def then " (default)" else "")))+      <|> flag' False+            (  long "no-pb-split-clause-part"+            <> help ("Do not split clause part of PB constraints." ++ (if SAT.configEnablePBSplitClausePart def then "" else " (default)")))+      <|> pure (SAT.configEnablePBSplitClausePart def)++    checkModelOption = switch+      $  long "check-model"+      <> help "check model for debugging"++parserInfo :: ParserInfo Options+parserInfo = Options.Applicative.info (helper <*> versionOption <*> optionsParser)+  $  fullDesc+  <> header "toysat - a solver for SAT-related problems"+  where+    versionOption :: Parser (a -> a)+    versionOption = infoOption (showVersion version)+      $  hidden+      <> long "version"+      <> help "Show version"++#if !MIN_VERSION_optparse_applicative(0,13,0)++-- | Convert a function producing a 'Maybe' into a reader.+maybeReader :: (String -> Maybe a) -> ReadM a+maybeReader f = eitherReader $ \arg ->+  case f arg of+    Nothing -> Left $ "cannot parse value `" ++ arg ++ "'"+    Just a -> Right a++#endif+ main :: IO () main = do #ifdef FORCE_CHAR8@@ -315,65 +427,59 @@    startCPU <- getTime ProcessCPUTime   startWC  <- getTime Monotonic-  args <- getArgs-  case getOpt Permute options args of-    (_,_,errs@(_:_)) -> do-      mapM_ putStrLn errs-      exitFailure -    (o,args2,[]) -> do-      let opt = foldl (flip id) def o      -          mode =-            case optMode opt of-              Just m  -> m-              Nothing ->-                case args2 of-                  [] -> ModeHelp-                  fname : _ ->-                    case map toLower (takeExtension fname) of-                      ".cnf"  -> ModeSAT-                      ".gcnf" -> ModeMUS-                      ".opb"  -> ModePB-                      ".wbo"  -> ModeWBO-                      ".wcnf" -> ModeMaxSAT-                      ".lp"   -> ModeMIP-                      ".mps"  -> ModeMIP-                      _ -> ModeSAT+  opt <- execParser parserInfo+  let mode =+        case optMode opt of+          Just m  -> m+          Nothing ->+            case getExt (optInput opt) of+              ".cnf"  -> ModeSAT+              ".gcnf" -> ModeMUS+              ".opb"  -> ModePB+              ".wbo"  -> ModeWBO+              ".wcnf" -> ModeMaxSAT+              ".lp"   -> ModeMIP+              ".mps"  -> ModeMIP+              _ -> ModeSAT -      case mode of-        ModeHelp    -> showHelp stdout-        ModeVersion -> hPutStrLn stdout (showVersion version)-        _ -> do-          printSysInfo+  printSysInfo #ifdef __GLASGOW_HASKELL__-          fullArgs <- getFullArgs+  fullArgs <- getFullArgs #else-          let fullArgs = args+  let fullArgs = args #endif-          putCommentLine $ printf "command line = %s" (show fullArgs)+  putCommentLine $ printf "command line = %s" (show fullArgs) -          let timelim = optTimeout opt * 10^(6::Int)-    -          ret <- timeout (if timelim > 0 then timelim else (-1)) $ do-             solver <- newSolver opt-             case mode of-               ModeHelp    -> showHelp stdout-               ModeVersion -> hPutStrLn stdout (showVersion version)-               ModeSAT     -> mainSAT opt solver args2-               ModeMUS     -> mainMUS opt solver args2-               ModePB      -> mainPB opt solver args2-               ModeWBO     -> mainWBO opt solver args2-               ModeMaxSAT  -> mainMaxSAT opt solver args2-               ModeMIP     -> mainMIP opt solver args2-    -          when (isNothing ret) $ do-            putCommentLine "TIMEOUT"-          endCPU <- getTime ProcessCPUTime-          endWC  <- getTime Monotonic-          putCommentLine $ printf "total CPU time = %.3fs" (durationSecs startCPU endCPU)-          putCommentLine $ printf "total wall clock time = %.3fs" (durationSecs startWC endWC)-          printGCStat+  let timelim = optTimeout opt * 10^(6::Int)+  +  ret <- timeout (if timelim > 0 then timelim else (-1)) $ do+     solver <- newSolver opt+     case mode of+       ModeSAT     -> mainSAT opt solver+       ModeMUS     -> mainMUS opt solver+       ModeAllMUS  -> mainMUS opt solver+       ModePB      -> mainPB opt solver+       ModeWBO     -> mainWBO opt solver+       ModeMaxSAT  -> mainMaxSAT opt solver+       ModeMIP     -> mainMIP opt solver +  when (isNothing ret) $ do+    putCommentLine "TIMEOUT"+  endCPU <- getTime ProcessCPUTime+  endWC  <- getTime Monotonic+  putCommentLine $ printf "total CPU time = %.3fs" (durationSecs startCPU endCPU)+  putCommentLine $ printf "total wall clock time = %.3fs" (durationSecs startWC endWC)+  printGCStat++getExt :: String -> String+getExt name | (base, ext) <- splitExtension name =+  case map toLower ext of+#ifdef WITH_ZLIB+    ".gz" -> getExt base+#endif+    s -> s+ printGCStat :: IO () #if defined(__GLASGOW_HASKELL__) #if __GLASGOW_HASKELL__ >= 802@@ -444,22 +550,6 @@ printGCStat = return () #endif -showHelp :: Handle -> IO ()-showHelp h = hPutStrLn h (usageInfo header options)--header :: String-header = unlines-  [ "Usage:"-  , "  toysat [OPTION]... [file.cnf|-]"-  , "  toysat [OPTION]... --mus [file.gcnf|-]"-  , "  toysat [OPTION]... --pb [file.opb|-]"-  , "  toysat [OPTION]... --wbo [file.wbo|-]"-  , "  toysat [OPTION]... --maxsat [file.cnf|file.wcnf|-]"-  , "  toysat [OPTION]... --lp [file.lp|file.mps|-]"-  , ""-  , "Options:"-  ]- printSysInfo :: IO () printSysInfo = do   tm <- getZonedTime@@ -506,47 +596,46 @@  -- ------------------------------------------------------------------------ -mainSAT :: Options -> SAT.Solver -> [String] -> IO ()-mainSAT opt solver args = do-  ret <- case args of-           ["-"]   -> liftM CNF.parseByteString $ BS.hGetContents stdin-           [fname] -> CNF.parseFile fname-           _ -> showHelp stderr >> exitFailure+mainSAT :: Options -> SAT.Solver -> IO ()+mainSAT opt solver = do+  ret <- case optInput opt of+           "-"   -> liftM FF.parse $ BS.hGetContents stdin+           fname -> FF.parseFile fname   case ret of     Left err -> hPrint stderr err >> exitFailure     Right cnf -> do-      let fname = case args of-                    [fname] | or [".cnf" `isSuffixOf` map toLower fname] -> Just fname-                    _ -> Nothing+      let fname = if ".cnf" `isSuffixOf` map toLower (optInput opt)+                  then Just (optInput opt)+                  else Nothing       solveSAT opt solver cnf fname  solveSAT :: Options -> SAT.Solver -> CNF.CNF -> Maybe FilePath -> IO () solveSAT opt solver cnf cnfFileName = do-  putCommentLine $ printf "#vars %d" (CNF.numVars cnf)-  putCommentLine $ printf "#constraints %d" (CNF.numClauses cnf)-  SAT.newVars_ solver (CNF.numVars cnf)-  forM_ (CNF.clauses cnf) $ \clause ->-    SAT.addClause solver clause+  putCommentLine $ printf "#vars %d" (CNF.cnfNumVars cnf)+  putCommentLine $ printf "#constraints %d" (CNF.cnfNumClauses cnf)+  SAT.newVars_ solver (CNF.cnfNumVars cnf)+  forM_ (CNF.cnfClauses cnf) $ \clause ->+    SAT.addClause solver (SAT.unpackClause clause)    spHighlyBiased <-     if optInitSP opt then do-      initPolarityUsingSP solver (CNF.numVars cnf)-        (CNF.numVars cnf) [(1, clause) | clause <- CNF.clauses cnf]+      initPolarityUsingSP solver (CNF.cnfNumVars cnf)+        (CNF.cnfNumVars cnf) [(1, clause) | clause <- CNF.cnfClauses cnf]     else       return IntMap.empty    when (optLocalSearchInitial opt) $ do     fixed <- SAT.getFixedLiterals solver-    let var_init1 = IntMap.fromList [(abs lit, lit > 0) | lit <- fixed, abs lit <= CNF.numVars cnf]+    let var_init1 = IntMap.fromList [(abs lit, lit > 0) | lit <- fixed, abs lit <= CNF.cnfNumVars cnf]         var_init2 = IntMap.map (>0) spHighlyBiased         -- note that IntMap.union is left-biased.         var_init = [if b then v else -v | (v, b) <- IntMap.toList (var_init1 `IntMap.union` var_init2)]     let wcnf =-          MaxSAT.WCNF-          { MaxSAT.numVars = CNF.numVars cnf-          , MaxSAT.numClauses = CNF.numClauses cnf-          , MaxSAT.topCost = 1-          , MaxSAT.clauses = [(1, clause) | clause <- CNF.clauses cnf]+          CNF.WCNF+          { CNF.wcnfNumVars = CNF.cnfNumVars cnf+          , CNF.wcnfNumClauses = CNF.cnfNumClauses cnf+          , CNF.wcnfTopCost = 1+          , CNF.wcnfClauses = [(1, clause) | clause <- CNF.cnfClauses cnf]           }     let opt2 =           def@@ -567,15 +656,15 @@   putSLine $ if result then "SATISFIABLE" else "UNSATISFIABLE"   when result $ do     m <- SAT.getModel solver-    satPrintModel stdout m (CNF.numVars cnf)-    writeSOLFile opt m Nothing (CNF.numVars cnf)+    satPrintModel stdout m (CNF.cnfNumVars cnf)+    writeSOLFile opt m Nothing (CNF.cnfNumVars cnf) -initPolarityUsingSP :: SAT.Solver -> Int -> Int -> [(Double, SAT.Clause)] -> IO (IntMap Double)+initPolarityUsingSP :: SAT.Solver -> Int -> Int -> [(Double, SAT.PackedClause)] -> IO (IntMap Double) initPolarityUsingSP solver nvOrig nv clauses = do   n <- getNumCapabilities   putCommentLine $ "Running survey propgation using " ++ show n ++" threads ..."   startWC  <- getTime Monotonic-  sp <- SP.newSolver nv clauses  +  sp <- SP.newSolver nv clauses   SP.initializeRandom sp =<< SAT.getRandomGen solver   SP.setNThreads sp n   lits <- SAT.getFixedLiterals solver@@ -602,72 +691,71 @@  -- ------------------------------------------------------------------------ -mainMUS :: Options -> SAT.Solver -> [String] -> IO ()-mainMUS opt solver args = do-  gcnf <- case args of-           ["-"]   -> do+mainMUS :: Options -> SAT.Solver -> IO ()+mainMUS opt solver = do+  gcnf <- case optInput opt of+           "-"   -> do              s <- BS.hGetContents stdin-             case GCNF.parseByteString s of+             case FF.parse s of                Left err   -> hPutStrLn stderr err >> exitFailure                Right gcnf -> return gcnf-           [fname] -> do-             ret <- GCNF.parseFile fname+           fname -> do+             ret <- FF.parseFile fname              case ret of                Left err   -> hPutStrLn stderr err >> exitFailure                Right gcnf -> return gcnf-           _ -> showHelp stderr >> exitFailure   solveMUS opt solver gcnf -solveMUS :: Options -> SAT.Solver -> GCNF.GCNF -> IO ()+solveMUS :: Options -> SAT.Solver -> CNF.GCNF -> IO () solveMUS opt solver gcnf = do-  putCommentLine $ printf "#vars %d" (GCNF.numVars gcnf)-  putCommentLine $ printf "#constraints %d" (GCNF.numClauses gcnf)-  putCommentLine $ printf "#groups %d" (GCNF.lastGroupIndex gcnf)+  putCommentLine $ printf "#vars %d" (CNF.gcnfNumVars gcnf)+  putCommentLine $ printf "#constraints %d" (CNF.gcnfNumClauses gcnf)+  putCommentLine $ printf "#groups %d" (CNF.gcnfLastGroupIndex gcnf) -  SAT.resizeVarCapacity solver (GCNF.numVars gcnf + GCNF.lastGroupIndex gcnf)-  SAT.newVars_ solver (GCNF.numVars gcnf)+  SAT.resizeVarCapacity solver (CNF.gcnfNumVars gcnf + CNF.gcnfLastGroupIndex gcnf)+  SAT.newVars_ solver (CNF.gcnfNumVars gcnf) -  tbl <- forM [1 .. GCNF.lastGroupIndex gcnf] $ \i -> do+  tbl <- forM [1 .. CNF.gcnfLastGroupIndex gcnf] $ \i -> do     sel <- SAT.newVar solver     return (i, sel)   let idx2sel :: Array Int SAT.Var-      idx2sel = array (1, GCNF.lastGroupIndex gcnf) tbl+      idx2sel = array (1, CNF.gcnfLastGroupIndex gcnf) tbl       selrng  = if null tbl then (0,-1) else (snd $ head tbl, snd $ last tbl)       sel2idx :: Array SAT.Lit Int       sel2idx = array selrng [(sel, idx) | (idx, sel) <- tbl] -  (idx2clausesM :: IOArray Int [SAT.Clause]) <- newArray (1, GCNF.lastGroupIndex gcnf) []-  forM_ (GCNF.clauses gcnf) $ \(idx, clause) ->+  (idx2clausesM :: IOArray Int [SAT.PackedClause]) <- newArray (1, CNF.gcnfLastGroupIndex gcnf) []+  forM_ (CNF.gcnfClauses gcnf) $ \(idx, clause) ->     if idx==0-    then SAT.addClause solver clause+    then SAT.addClause solver (SAT.unpackClause clause)     else do-      SAT.addClause solver (- (idx2sel ! idx) : clause)+      SAT.addClause solver (- (idx2sel ! idx) : SAT.unpackClause clause)       cs <- readArray idx2clausesM idx       writeArray idx2clausesM idx (clause : cs)-  (idx2clauses :: Array Int [SAT.Clause]) <- freeze idx2clausesM+  (idx2clauses :: Array Int [SAT.PackedClause]) <- freeze idx2clausesM    when (optInitSP opt) $ do-    let wcnf = GCNF2MaxSAT.convert gcnf-    initPolarityUsingSP solver (GCNF.numVars gcnf)-      (MaxSAT.numVars wcnf) [(fromIntegral w, clause) | (w, clause) <- MaxSAT.clauses wcnf]+    let (wcnf, _) = gcnf2maxsat gcnf+    initPolarityUsingSP solver (CNF.gcnfNumVars gcnf)+      (CNF.wcnfNumVars wcnf) [(fromIntegral w, clause) | (w, clause) <- CNF.wcnfClauses wcnf]     return () -  result <- SAT.solveWith solver (map (idx2sel !) [1..GCNF.lastGroupIndex gcnf])+  result <- SAT.solveWith solver (map (idx2sel !) [1..CNF.gcnfLastGroupIndex gcnf])   putSLine $ if result then "SATISFIABLE" else "UNSATISFIABLE"   if result     then do       m <- SAT.getModel solver-      satPrintModel stdout m (GCNF.numVars gcnf)-      writeSOLFile opt m Nothing (GCNF.numVars gcnf)+      satPrintModel stdout m (CNF.gcnfNumVars gcnf)+      writeSOLFile opt m Nothing (CNF.gcnfNumVars gcnf)     else do-      if not (optAllMUSes opt)+      if optMode opt /= Just ModeAllMUS       then do           let opt2 = def                      { MUS.optMethod = optMUSMethod opt                      , MUS.optLogger = putCommentLine                      , MUS.optShowLit = \lit -> show (sel2idx ! lit)                      , MUS.optEvalConstr = \m sel ->-                         and [SAT.evalClause m c | c <- idx2clauses ! (sel2idx ! sel)]+                         and [SAT.evalClause m (SAT.unpackClause c) | c <- idx2clauses ! (sel2idx ! sel)]                      }           mus <- MUS.findMUSAssumptions solver opt2           let mus2 = sort $ map (sel2idx !) $ IntSet.toList mus@@ -680,7 +768,7 @@                      , MUSEnum.optLogger = putCommentLine                      , MUSEnum.optShowLit = \lit -> show (sel2idx ! lit)                      , MUSEnum.optEvalConstr = \m sel ->-                         and [SAT.evalClause m c | c <- idx2clauses ! (sel2idx ! sel)]+                         and [SAT.evalClause m (SAT.unpackClause c) | c <- idx2clauses ! (sel2idx ! sel)]                      , MUSEnum.optOnMCSFound = \mcs -> do                          i <- readIORef mcsCounter                          modifyIORef' mcsCounter (+1)@@ -698,12 +786,11 @@  -- ------------------------------------------------------------------------ -mainPB :: Options -> SAT.Solver -> [String] -> IO ()-mainPB opt solver args = do-  ret <- case args of-           ["-"]   -> liftM PBFileAttoparsec.parseOPBByteString $ BS.hGetContents stdin-           [fname] -> PBFileAttoparsec.parseOPBFile fname-           _ -> showHelp stderr >> exitFailure+mainPB :: Options -> SAT.Solver -> IO ()+mainPB opt solver = do+  ret <- case optInput opt of+           "-"   -> liftM FF.parse $ BS.hGetContents stdin+           fname -> FF.parseFile fname   case ret of     Left err -> hPutStrLn stderr err >> exitFailure     Right formula -> solvePB opt solver formula@@ -727,14 +814,15 @@    spHighlyBiased <-      if optInitSP opt then do-      let (cnf, _, _) = PB2SAT.convert formula-      initPolarityUsingSP solver nv (CNF.numVars cnf) [(1.0, clause) | clause <- CNF.clauses cnf]+      let (cnf, _) = pb2sat formula+      initPolarityUsingSP solver nv (CNF.cnfNumVars cnf) [(1.0, clause) | clause <- CNF.cnfClauses cnf]     else       return IntMap.empty    initialModel <-      if optLocalSearchInitial opt then do-      let (wcnf, _, mtrans) = WBO2MaxSAT.convert $ PB2WBO.convert formula+      let (wbo,  info1) = pb2wbo formula+          (wcnf, info2) = wbo2maxsat wbo       fixed <- filter (\lit -> abs lit <= nv) <$> SAT.getFixedLiterals solver       let var_init1 = IntMap.fromList [(abs lit, lit > 0) | lit <- fixed, abs lit <= nv]           var_init2 = IntMap.map (>0) spHighlyBiased@@ -751,10 +839,10 @@       case ret of         Nothing -> return Nothing         Just (obj,m) -> do-          let m2 = mtrans m+          let m2 = transformBackward info1 $ transformBackward info2 m           forM_ (assocs m2) $ \(v, val) -> do             SAT.setVarPolarity solver v val-          if obj < MaxSAT.topCost wcnf then+          if obj < CNF.wcnfTopCost wcnf then             return $ Just m2            else             return Nothing@@ -816,22 +904,23 @@  -- ------------------------------------------------------------------------ -mainWBO :: Options -> SAT.Solver -> [String] -> IO ()-mainWBO opt solver args = do-  ret <- case args of-           ["-"]   -> liftM PBFileAttoparsec.parseWBOByteString $ BS.hGetContents stdin-           [fname] -> PBFileAttoparsec.parseWBOFile fname-           _ -> showHelp stderr >> exitFailure+mainWBO :: Options -> SAT.Solver -> IO ()+mainWBO opt solver = do+  ret <- case optInput opt of+           "-"   -> liftM FF.parse $ BS.hGetContents stdin+           fname -> FF.parseFile fname   case ret of     Left err -> hPutStrLn stderr err >> exitFailure     Right formula -> solveWBO opt solver False formula  solveWBO :: Options -> SAT.Solver -> Bool -> PBFile.SoftFormula -> IO () solveWBO opt solver isMaxSat formula =-  solveWBO' opt solver isMaxSat formula (WBO2MaxSAT.convert formula) Nothing+  solveWBO' opt solver isMaxSat formula (wbo2maxsat formula) Nothing -solveWBO' :: Options -> SAT.Solver -> Bool -> PBFile.SoftFormula -> (MaxSAT.WCNF, SAT.Model -> SAT.Model, SAT.Model -> SAT.Model) -> Maybe FilePath -> IO ()-solveWBO' opt solver isMaxSat formula (wcnf, _, mtrans) wcnfFileName = do+solveWBO'+  :: (BackwardTransformer wbo2maxsat_info, Source wbo2maxsat_info ~ SAT.Model, Target wbo2maxsat_info ~ SAT.Model)+  => Options -> SAT.Solver -> Bool -> PBFile.SoftFormula -> (CNF.WCNF, wbo2maxsat_info) -> Maybe FilePath -> IO ()+solveWBO' opt solver isMaxSat formula (wcnf, wbo2maxsat_info) wcnfFileName = do   let nv = PBFile.wboNumVars formula       nc = PBFile.wboNumConstraints formula   putCommentLine $ printf "#vars %d" nv@@ -841,16 +930,16 @@   enc <- Tseitin.newEncoderWithPBLin solver   Tseitin.setUsePB enc (optLinearizerPB opt)   pbnlc <- PBNLC.newEncoder solver enc-  (obj, defsPB) <- WBO2PB.addWBO pbnlc formula+  (obj, defsPB) <- addWBO pbnlc formula   objLin <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityNeg obj    spHighlyBiased <-     if optInitSP opt then do-      initPolarityUsingSP solver nv (MaxSAT.numVars wcnf) [(fromIntegral w, c) | (w, c) <-  MaxSAT.clauses wcnf]+      initPolarityUsingSP solver nv (CNF.wcnfNumVars wcnf) [(fromIntegral w, c) | (w, c) <-  CNF.wcnfClauses wcnf]     else       return IntMap.empty -  initialModel <- liftM (fmap (mtrans . snd)) $+  initialModel <- liftM (fmap (transformBackward wbo2maxsat_info . snd)) $     if optLocalSearchInitial opt then do       fixed <- SAT.getFixedLiterals solver       let var_init1 = IntMap.fromList [(abs lit, lit > 0) | lit <- fixed, abs lit <= nv]@@ -921,31 +1010,32 @@  -- ------------------------------------------------------------------------ -mainMaxSAT :: Options -> SAT.Solver -> [String] -> IO ()-mainMaxSAT opt solver args = do-  ret <- case args of-           ["-"]   -> liftM MaxSAT.parseByteString BS.getContents-           [fname] -> MaxSAT.parseFile fname-           _ -> showHelp stderr  >> exitFailure+mainMaxSAT :: Options -> SAT.Solver -> IO ()+mainMaxSAT opt solver = do+  ret <- case optInput opt of+           "-"   -> liftM FF.parse BS.getContents+           fname -> FF.parseFile fname   case ret of     Left err -> hPutStrLn stderr err >> exitFailure     Right wcnf -> do-      let fname = case args of-                    [fname] | or [s `isSuffixOf` map toLower fname | s <- [".cnf", ".wcnf"]] -> Just fname-                    _ -> Nothing+      let fname = if or [s `isSuffixOf` map toLower (optInput opt) | s <- [".cnf", ".wcnf"]]+                  then Just (optInput opt)+                  else Nothing       solveMaxSAT opt solver wcnf fname -solveMaxSAT :: Options -> SAT.Solver -> MaxSAT.WCNF -> Maybe FilePath -> IO ()+solveMaxSAT :: Options -> SAT.Solver -> CNF.WCNF -> Maybe FilePath -> IO () solveMaxSAT opt solver wcnf wcnfFileName =-  solveWBO' opt solver True (MaxSAT2WBO.convert wcnf) (wcnf, id, id) wcnfFileName+  solveWBO' opt solver True wbo (wcnf, ReversedTransformer info) wcnfFileName+  where+    (wbo, info) = maxsat2wbo wcnf  -- ------------------------------------------------------------------------ -mainMIP :: Options -> SAT.Solver -> [String] -> IO ()-mainMIP opt solver args = do+mainMIP :: Options -> SAT.Solver -> IO ()+mainMIP opt solver = do   mip <--    case args of-      [fname@"-"]   -> do+    case optInput opt of+      fname@"-"   -> do         F.mapM_ (\s -> hSetEncoding stdin =<< mkTextEncoding s) (optFileEncoding opt)         s <- hGetContents stdin         case MIP.parseLPString def fname s of@@ -957,10 +1047,9 @@                 hPrint stderr err                 hPrint stderr err2                 exitFailure-      [fname] -> do+      fname -> do         enc <- T.mapM mkTextEncoding (optFileEncoding opt)         MIP.readFile def{ MIP.optFileEncoding = enc } fname-      _ -> showHelp stderr >> exitFailure   solveMIP opt solver (fmap toRational mip)  solveMIP :: Options -> SAT.Solver -> MIP.Problem Rational -> IO ()@@ -968,18 +1057,18 @@   enc <- Tseitin.newEncoderWithPBLin solver   Tseitin.setUsePB enc (optLinearizerPB opt)   pbnlc <- PBNLC.newEncoder solver enc-  ret <- MIP2PB.addMIP pbnlc mip+  ret <- addMIP pbnlc mip   case ret of     Left msg -> do       putCommentLine msg       putSLine "UNKNOWN"       exitFailure-    Right (obj, otrans, mtrans) -> do+    Right (obj, info) -> do       (linObj, linObjOffset) <- Integer.linearize pbnlc obj -      let transformObjVal :: Integer -> Rational-          transformObjVal val = otrans (val + linObjOffset)-  +      let transformObjValBackward :: Integer -> Rational+          transformObjValBackward val = transformObjValueBackward info (val + linObjOffset)+           printModel :: Map MIP.Var Integer -> IO ()           printModel m = do             forM_ (Map.toList m) $ \(v, val) -> do@@ -1001,7 +1090,7 @@       pbo <- PBO.newOptimizer solver linObj       setupOptimizer pbo opt       PBO.setOnUpdateBestSolution pbo $ \_ val -> do-        putOLine $ showRational (optPrintRational opt) (transformObjVal val)+        putOLine $ showRational (optPrintRational opt) (transformObjValBackward val)          finally (PBO.optimize pbo) $ do         ret <- PBO.getBestSolution pbo@@ -1016,8 +1105,8 @@             if b               then putSLine "OPTIMUM FOUND"               else putSLine "SATISFIABLE"-            let m2   = mtrans m-                val2 = transformObjVal val+            let m2   = transformBackward info m+                val2 = transformObjValBackward val             printModel m2             writeSol m2 val2
app/toysmt/ToySolver/SMT/SMTLIB2Solver.hs view
@@ -74,7 +74,6 @@   , echo   ) where -import Control.Applicative import qualified Control.Exception as E import Control.Monad import Data.Interned (unintern)
app/toysmt/toysmt.hs view
@@ -13,19 +13,19 @@ ----------------------------------------------------------------------------- module Main where -import Control.Applicative ((<*))+import Control.Applicative import Control.Monad import Control.Monad.Trans-import Data.Default.Class+import Data.Monoid import Data.Version-import System.Console.GetOpt+import Options.Applicative hiding (Parser)+import qualified Options.Applicative as Opt #ifdef USE_HASKELINE_PACKAGE import qualified System.Console.Haskeline as Haskeline #endif-import System.Environment import System.Exit import System.IO-import Text.Parsec+import Text.Parsec hiding (many) import Text.Parsec.String  import Smtlib.Parsers.CommandsParsers@@ -42,51 +42,49 @@  data Options   = Options-  { optMode :: Maybe Mode-  , optInteractive :: Bool+  { optInteractive :: Bool+  , optFiles :: [FilePath]   } -instance Default Options where-  def =-    Options-    { optMode = Nothing-    , optInteractive = False -    }+optionsParser :: Opt.Parser Options+optionsParser = Options+  <$> interactiveOption+  <*> fileArgs+  where+    interactiveOption :: Opt.Parser Bool+    interactiveOption = switch+      $  long "interactive"+      <> help "force interactive mode" -options :: [OptDescr (Options -> Options)]-options =-    [ Option ['h'] ["help"]   (NoArg (\opt -> opt{ optMode = Just ModeHelp   })) "show help"-    , Option [] ["version"]   (NoArg (\opt -> opt{ optMode = Just ModeVersion})) "show version"-    , Option [] ["interactive"] (NoArg (\opt -> opt{ optMode = Just ModeInteractive })) "force interactive mode"-    ]+    fileArgs :: Opt.Parser [FilePath]+    fileArgs = many $ strArgument $ metavar "FILE" +parserInfo :: ParserInfo Options+parserInfo = info (helper <*> versionOption <*> optionsParser)+  $  fullDesc+  <> header "toysmt - a SMT solver"+  where+    versionOption :: Opt.Parser (a -> a)+    versionOption = infoOption (showVersion version)+      $  hidden+      <> long "version"+      <> help "Show version"+ main :: IO () main = do #ifdef FORCE_CHAR8   setEncodingChar8 #endif--  args <- getArgs-  case getOpt Permute options args of-    (_,_,errs@(_:_)) -> do-      mapM_ putStrLn errs-      exitFailure--    (o,args2,[]) -> do-      let opt = foldl (flip id) def o-      case optMode opt of-        Just ModeHelp -> showHelp stdout-        Just ModeVersion -> hPutStrLn stdout (showVersion version)-        Just ModeInteractive -> do-          solver <- newSolver-          mapM_ (loadFile solver) args2-          repl solver          -        Nothing -> do-          solver <- newSolver-          if null args2 then-            repl solver-          else-            mapM_ (loadFile solver) args2+  opt <- execParser parserInfo+  solver <- newSolver+  if optInteractive opt then do+    mapM_ (loadFile solver) (optFiles opt)+    repl solver        +  else do+    if null (optFiles opt) then+      repl solver+    else+      mapM_ (loadFile solver) (optFiles opt)  loadFile :: Solver -> FilePath -> IO () loadFile solver fname = do@@ -135,14 +133,3 @@           lift $ execCommand solver cmd  #endif--showHelp :: Handle -> IO ()-showHelp h = hPutStrLn h (usageInfo header options)--header :: String-header = unlines-  [ "Usage:"-  , "  toysmt [OPTION]... [file.smt2]"-  , ""-  , "Options:"-  ]
app/toysolver.hs view
@@ -21,6 +21,7 @@ import Data.Default.Class import Data.List import Data.Maybe+import Data.Monoid import Data.Ratio import Data.Scientific (Scientific) import qualified Data.Scientific as Scientific@@ -32,6 +33,7 @@ import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Traversable as T+import Options.Applicative hiding (Const) import System.Exit import System.Environment import System.FilePath@@ -41,8 +43,6 @@ import GHC.Conc (getNumProcessors, setNumCapabilities)  import Data.OptDir-import qualified Data.PseudoBoolean as PBFile-import qualified Data.PseudoBoolean.Attoparsec as PBFileAttoparsec  import ToySolver.Data.OrdRel import ToySolver.Data.FOL.Arith as FOL@@ -59,11 +59,8 @@ import qualified ToySolver.Arith.MIP as MIPSolver import qualified ToySolver.Arith.CAD as CAD import qualified ToySolver.Arith.ContiTraverso as ContiTraverso-import qualified ToySolver.Text.CNF as CNF-import qualified ToySolver.Text.MaxSAT as MaxSAT-import qualified ToySolver.Converter.SAT2IP as SAT2IP-import qualified ToySolver.Converter.PB2IP as PB2IP-import qualified ToySolver.Converter.MaxSAT2IP as MaxSAT2IP+import qualified ToySolver.FileFormat as FF+import ToySolver.Converter import ToySolver.SAT.Printer import qualified ToySolver.SAT.Types as SAT import ToySolver.Version@@ -72,54 +69,133 @@ -- ---------------------------------------------------------------------------  data Mode = ModeSAT | ModePB | ModeWBO | ModeMaxSAT | ModeMIP-  deriving (Eq, Ord)+  deriving (Eq, Ord, Show) -data Flag-    = Help-    | Version-    | Solver String-    | PrintRational-    | WriteFile !FilePath-    | NoMIP-    | PivotStrategy String-    | NThread !Int-    | OmegaReal String-    | Mode !Mode-    | FileEncoding String-    deriving Eq+data Options = Options+  { optInput :: FilePath+  , optMode :: Maybe Mode+  , optSolver :: String+  , optPrintRational :: Bool+  , optWriteFile :: Maybe FilePath+  , optNoMIP :: Bool+  , optPivotStrategy :: Simplex.PivotStrategy -- String+  , optBoundTightening :: Bool+  , optNThread :: Int+  , optOmegaReal :: String+  , optFileEncoding :: Maybe String+  } deriving (Eq, Show) -options :: [OptDescr Flag]-options =-    [ Option ['h'] ["help"]    (NoArg Help)            "show help"-    , Option ['v'] ["version"] (NoArg Version)         "show version number"-    , Option [] ["solver"] (ReqArg Solver "SOLVER")    "mip (default), omega-test, cooper, cad, old-mip, ct"-    , Option [] ["print-rational"] (NoArg PrintRational) "print rational numbers instead of decimals"-    , Option ['w'] [] (ReqArg WriteFile "<filename>")  "write solution to filename in Gurobi .sol format"+optionsParser :: Parser Options+optionsParser = Options+  <$> fileInput+  <*> modeOption+  <*> solverOption+  <*> printRationalOption+  <*> writeFileOption+  <*> noMIPOption+  <*> pivotStrategyOption+  <*> boundTighteningOption+  <*> nThreadOption+  <*> omegaRealOption+  <*> fileEncodingOption+  where+    fileInput :: Parser FilePath+    fileInput = argument str (metavar "FILE") -    , Option [] ["pivot-strategy"] (ReqArg PivotStrategy "[bland-rule|largest-coefficient]") "pivot strategy for simplex (default: bland-rule)"-    , Option [] ["threads"] (ReqArg (NThread . read) "INTEGER") "number of threads to use"+    modeOption :: Parser (Maybe Mode)+    modeOption = optional $+          flag' ModeSAT    (long "sat"    <> help "solve boolean satisfiability problem in .cnf file")+      <|> flag' ModePB     (long "pb"     <> help "solve pseudo boolean problem in .opb file")+      <|> flag' ModeWBO    (long "wbo"    <> help "solve weighted boolean optimization problem in .wbo file")+      <|> flag' ModeMaxSAT (long "maxsat" <> help "solve MaxSAT problem in .cnf or .wcnf file")+      <|> flag' ModeMIP    (long "lp"     <> help "solve LP/MIP problem in .lp or .mps file") -    , Option [] ["omega-real"] (ReqArg OmegaReal "SOLVER") "fourier-motzkin (default), virtual-substitution (or vs), cad, simplex, none"+    solverOption :: Parser String+    solverOption = strOption+      $  long "solver"+      <> metavar "SOLVER"+      <> help "Solver algorithm: mip, omega-test, cooper, cad, old-mip, ct"+      <> value "mip"+      <> showDefaultWith id -    , Option []    ["sat"]    (NoArg (Mode ModeSAT))    "solve boolean satisfiability problem in .cnf file"-    , Option []    ["pb"]     (NoArg (Mode ModePB))     "solve pseudo boolean problem in .opb file"-    , Option []    ["wbo"]    (NoArg (Mode ModeWBO))    "solve weighted boolean optimization problem in .wbo file"-    , Option []    ["maxsat"] (NoArg (Mode ModeMaxSAT)) "solve MaxSAT problem in .cnf or .wcnf file"-    , Option []    ["lp"]     (NoArg (Mode ModeMIP))    "solve LP/MIP problem in .lp or .mps file (default)"+    printRationalOption :: Parser Bool+    printRationalOption = switch+      $  long "print-rational"+      <> help "print rational numbers instead of decimals" -    , Option [] ["nomip"] (NoArg NoMIP)                 "consider all integer variables as continuous"+    writeFileOption :: Parser (Maybe FilePath)+    writeFileOption = optional $ strOption+      $  short 'w'+      <> metavar "FILE"+      <> help "write solution to filename in Gurobi .sol format" -    , Option [] ["encoding"] (ReqArg FileEncoding "<ENCODING>") "file encoding for LP/MPS files"-    ]+    noMIPOption :: Parser Bool+    noMIPOption = switch+      $  long "nomip"+      <> help "consider all integer variables as continuous" -header :: String-header = "Usage: toysolver [OPTION]... file"+    pivotStrategyOption :: Parser Simplex.PivotStrategy+    pivotStrategyOption = option (maybeReader Simplex.parsePivotStrategy)+      $  long "pivot-strategy"+      <> metavar "NAME"+      <> help ("pivot strategy for simplex: " ++ intercalate ", " [Simplex.showPivotStrategy ps | ps <- [minBound..maxBound]])+      <> value (Simplex.configPivotStrategy def)+      <> showDefaultWith Simplex.showPivotStrategy +    boundTighteningOption :: Parser Bool+    boundTighteningOption =  switch+      $  long "bound-tightening"+      <> help "enable bound tightening in simplex algorithm"++    nThreadOption :: Parser Int+    nThreadOption = option auto+      $  long "threads"+      <> metavar "INT"+      <> help "number of threads to use (0: auto)"+      <> value 0+      <> showDefault++    omegaRealOption :: Parser String+    omegaRealOption = strOption+      $  long "omega-real"+      <> metavar "SOLVER"+      <> help "fourier-motzkin, virtual-substitution (or vs), cad, simplex, none"+      <> value "fourier-motzkin"+      <> showDefaultWith id++    fileEncodingOption :: Parser (Maybe String)+    fileEncodingOption = optional $ strOption+      $  long "encoding"+      <> metavar "ENCODING"+      <> help "file encoding for LP/MPS files"++parserInfo :: ParserInfo Options+parserInfo = info (helper <*> versionOption <*> optionsParser)+  $  fullDesc+  <> header "toysolver - a solver for arithmetic problems"+  where+    versionOption :: Parser (a -> a)+    versionOption = infoOption (V.showVersion version)+      $  hidden+      <> long "version"+      <> help "Show version"++#if !MIN_VERSION_optparse_applicative(0,13,0)++-- | Convert a function producing a 'Maybe' into a reader.+maybeReader :: (String -> Maybe a) -> ReadM a+maybeReader f = eitherReader $ \arg ->+  case f arg of+    Nothing -> Left $ "cannot parse value `" ++ arg ++ "'"+    Just a -> Right a++#endif+ -- ---------------------------------------------------------------------------  run   :: String-  -> [Flag]+  -> Options   -> MIP.Problem Rational   -> (Map MIP.Var Rational -> IO ())   -> IO ()@@ -177,8 +253,8 @@         Just _ -> error "indicator constraint is not supported yet"      ivs-      | NoMIP `elem` opt = Set.empty-      | otherwise        = MIP.integerVariables mip+      | optNoMIP opt = Set.empty+      | otherwise    = MIP.integerVariables mip      vs2  = IntMap.keysSet varToName     ivs2 = IntSet.fromList . map (nameToVar Map.!) . Set.toList $ ivs@@ -211,7 +287,7 @@            }                     where              realSolver =-               case last ("fourier-motzkin" : [s | OmegaReal s <- opt]) of+               case optOmegaReal opt of                  "fourier-motzkin" -> OmegaTest.checkRealByFM                  "virtual-substitution" -> OmegaTest.checkRealByVS                  "vs"              -> OmegaTest.checkRealByVS@@ -246,14 +322,14 @@     solveByMIP2 = do       solver <- Simplex.newSolver -      let ps = last ("bland-rule" : [s | PivotStrategy s <- opt])-      case ps of-        "bland-rule"          -> Simplex.setPivotStrategy solver Simplex.PivotStrategyBlandRule-        "largest-coefficient" -> Simplex.setPivotStrategy solver Simplex.PivotStrategyLargestCoefficient-        _ -> error ("unknown pivot strategy \"" ++ ps ++ "\"")--      let nthreads = last (0 : [n | NThread n <- opt])+      let config =+            def+            { Simplex.configPivotStrategy = optPivotStrategy opt+            , Simplex.configEnableBoundTightening = optBoundTightening opt+            }+          nthreads = optNThread opt +      Simplex.setConfig solver config       Simplex.setLogger solver putCommentLine       Simplex.enableTimeRecording solver       replicateM (length vsAssoc) (Simplex.newVar solver) -- XXX@@ -355,7 +431,7 @@                   printModel m3      printRat :: Bool-    printRat = PrintRational `elem` opt+    printRat = optPrintRational opt      showValue :: Rational -> String     showValue = showRational printRat@@ -386,87 +462,52 @@  -- --------------------------------------------------------------------------- -getSolver :: [Flag] -> String-getSolver xs = last $ "mip" : [s | Solver s <- xs]- main :: IO () main = do #ifdef FORCE_CHAR8   setEncodingChar8 #endif -  args <- getArgs-  case getOpt Permute options args of-    (o,_,[])-      | Help `elem` o    -> putStrLn (usageInfo header options)-      | Version `elem` o -> putStrLn (V.showVersion version)-    (o,[fname],[]) -> do--      let mode =-            case reverse [m | Mode m <- o] of-              m:_ -> m-              [] ->-                case map toLower (takeExtension fname) of-                  ".cnf"  -> ModeSAT-                  ".opb"  -> ModePB-                  ".wbo"  -> ModeWBO-                  ".wcnf" -> ModeMaxSAT-                  ".lp"   -> ModeMIP-                  ".mps"  -> ModeMIP-                  _ -> ModeMIP+  o <- execParser parserInfo -      case mode of-        ModeSAT -> do-          ret <- CNF.parseFile fname-          case ret of-            Left err -> hPrint stderr err >> exitFailure-            Right cnf -> do-              let (mip,_,mtrans) = SAT2IP.convert cnf-              run (getSolver o) o (fmap fromInteger mip) $ \m -> do-                let m2 = mtrans m-                satPrintModel stdout m2 0-                writeSOLFileSAT o m2-        ModePB -> do-          ret <- PBFileAttoparsec.parseOPBFile fname-          case ret of-            Left err -> hPutStrLn stderr err >> exitFailure-            Right pb -> do-              let (mip,_,mtrans) = PB2IP.convert pb-              run (getSolver o) o (fmap fromInteger mip) $ \m -> do-                let m2 = mtrans m-                pbPrintModel stdout m2 0-                writeSOLFileSAT o m2-        ModeWBO -> do-          ret <- PBFileAttoparsec.parseWBOFile fname-          case ret of-            Left err -> hPutStrLn stderr err >> exitFailure-            Right wbo -> do-              let (mip,_,mtrans) = PB2IP.convertWBO False wbo-              run (getSolver o) o (fmap fromInteger mip) $ \m -> do-                let m2 = mtrans m-                pbPrintModel stdout m2 0-                writeSOLFileSAT o m2-        ModeMaxSAT -> do-          ret <- MaxSAT.parseFile fname-          case ret of-            Left err -> hPutStrLn stderr err >> exitFailure-            Right wcnf -> do-              let (mip,_,mtrans) = MaxSAT2IP.convert False wcnf-              run (getSolver o) o (fmap fromInteger mip) $ \m -> do-                let m2 = mtrans m-                maxsatPrintModel stdout m2 0-                writeSOLFileSAT o m2-        ModeMIP -> do-          enc <- T.mapM mkTextEncoding $ last $ Nothing : [Just s | FileEncoding s <- o]-          mip <- MIP.readFile def{ MIP.optFileEncoding = enc } fname-          run (getSolver o) o (fmap toRational mip) $ \m -> do-            mipPrintModel stdout (PrintRational `elem` o) m-            writeSOLFileMIP o m-    (_,_,errs) ->-        hPutStrLn stderr $ concat errs ++ usageInfo header options+  case fromMaybe ModeMIP (optMode o) of+    ModeSAT -> do+      cnf <- FF.readFile (optInput o)+      let (mip,info) = sat2ip cnf+      run (optSolver o) o (fmap fromInteger mip) $ \m -> do+        let m2 = transformBackward info m+        satPrintModel stdout m2 0+        writeSOLFileSAT o m2+    ModePB -> do+      pb <- FF.readFile (optInput o)+      let (mip,info) = pb2ip pb+      run (optSolver o) o (fmap fromInteger mip) $ \m -> do+        let m2 = transformBackward info m+        pbPrintModel stdout m2 0+        writeSOLFileSAT o m2+    ModeWBO -> do+      wbo <- FF.readFile (optInput o)+      let (mip,info) = wbo2ip False wbo+      run (optSolver o) o (fmap fromInteger mip) $ \m -> do+        let m2 = transformBackward info m+        pbPrintModel stdout m2 0+        writeSOLFileSAT o m2+    ModeMaxSAT -> do+      wcnf <- FF.readFile (optInput o)+      let (mip,info) = maxsat2ip False wcnf+      run (optSolver o) o (fmap fromInteger mip) $ \m -> do+        let m2 = transformBackward info m+        maxsatPrintModel stdout m2 0+        writeSOLFileSAT o m2+    ModeMIP -> do+      enc <- T.mapM mkTextEncoding $ optFileEncoding o+      mip <- MIP.readFile def{ MIP.optFileEncoding = enc } (optInput o)+      run (optSolver o) o (fmap toRational mip) $ \m -> do+        mipPrintModel stdout (optPrintRational o) m+        writeSOLFileMIP o m  -- FIXME: 目的関数値を表示するように-writeSOLFileMIP :: [Flag] -> Map MIP.Var Rational -> IO ()+writeSOLFileMIP :: Options -> Map MIP.Var Rational -> IO () writeSOLFileMIP opt m = do   let sol = MIP.Solution             { MIP.solStatus = MIP.StatusUnknown@@ -476,7 +517,7 @@   writeSOLFileRaw opt sol  -- FIXME: 目的関数値を表示するように-writeSOLFileSAT :: [Flag] -> SAT.Model -> IO ()+writeSOLFileSAT :: Options -> SAT.Model -> IO () writeSOLFileSAT opt m = do   let sol = MIP.Solution             { MIP.solStatus = MIP.StatusUnknown@@ -485,7 +526,9 @@             }   writeSOLFileRaw opt sol -writeSOLFileRaw :: [Flag] -> MIP.Solution Scientific -> IO ()+writeSOLFileRaw :: Options -> MIP.Solution Scientific -> IO () writeSOLFileRaw opt sol = do-  forM_ [fname | WriteFile fname <- opt ] $ \fname -> do-    GurobiSol.writeFile fname sol+  case optWriteFile opt of+    Just fname -> GurobiSol.writeFile fname sol+    Nothing -> return ()+
benchmarks/BenchmarkSATLIB.hs view
@@ -6,18 +6,19 @@ import Text.Printf import Criterion.Main import qualified ToySolver.SAT as SAT-import qualified ToySolver.Text.CNF as CNF+import qualified ToySolver.FileFormat as FF+import qualified ToySolver.FileFormat.CNF as CNF  solve :: FilePath -> IO () solve fname = do-  ret <- CNF.parseFile fname+  ret <- FF.parseFile fname   case ret of     Left err  -> error $ show err     Right cnf -> do       solver <- SAT.newSolverWithConfig def{ SAT.configRandomFreq = 0 }-      _ <- replicateM (CNF.numVars cnf) (SAT.newVar solver)-      forM_ (CNF.clauses cnf) $ \clause ->-        SAT.addClause solver clause+      _ <- replicateM (CNF.cnfNumVars cnf) (SAT.newVar solver)+      forM_ (CNF.cnfClauses cnf) $ \clause ->+        SAT.addClause solver (SAT.unpackClause clause)       SAT.solve solver       return ()
+ misc/build_bdist_smtcomp.sh view
@@ -0,0 +1,26 @@+#!/bin/bash+export CABALVER=1.22+export GHCVER=7.10.3++sudo add-apt-repository -y ppa:hvr/ghc+sudo apt-get update++sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER+export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:~/.cabal/bin:$PATH++sudo apt-get install happy-1.19.4 alex-3.1.3+export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH++cabal sandbox init+cabal update+cabal install --only-dependencies+#cabal configure --disable-shared --ghc-options="-static -optl-static -optl-pthread"+cabal configure -fLinuxStatic -fForceChar8+cabal build++PKG=toysmt-smtcomp`date +%Y`-`date +%Y%m%d`-`git rev-parse --short HEAD`+rm -r $PKG+cp -a misc/smtcomp $PKG+cp dist/build/toysmt/toysmt $PKG/bin+cd $PKG+tar zcf ../$PKG.tar.gz . --owner=sakai --group=sakai
misc/maxsat/toysat/README.md view
@@ -23,4 +23,4 @@   Improvements to Core-Guided binary search for MaxSAT,   in Theory and Applications of Satisfiability Testing (SAT 2012),   pp. 284-297.-  <http://dx.doi.org/10.1007/978-3-642-31612-8_22>+  <https://doi.org/10.1007/978-3-642-31612-8_22>
misc/maxsat/toysat_ls/README.md view
@@ -26,9 +26,9 @@   Improvements to Core-Guided binary search for MaxSAT,   in Theory and Applications of Satisfiability Testing (SAT 2012),   pp. 284-297.-  <http://dx.doi.org/10.1007/978-3-642-31612-8_22>+  <https://doi.org/10.1007/978-3-642-31612-8_22>  * [2] D. Tompkins and H. Hoos, UBCSAT: An implementation and experimentation   environment for SLS algorithms for SAT and MAX-SAT, in Theory and Applications   of Satisfiability Testing (2004), Springer, 2005, pp. 306-320.-  <http://dx.doi.org/10.1007/11527695_24>+  <https://doi.org/10.1007/11527695_24>
misc/pb/README.md view
@@ -52,7 +52,7 @@   Improvements to Core-Guided binary search for MaxSAT,   in Theory and Applications of Satisfiability Testing (SAT 2012),   pp. 284-297.-  <http://dx.doi.org/10.1007/978-3-642-31612-8_22>+  <https://doi.org/10.1007/978-3-642-31612-8_22>  * [2] Masahiro Sakai. <https://github.com/msakai/toysolver>
misc/qbf/README.md view
@@ -30,5 +30,5 @@ * [1] Mikoláš Janota, William Klieber, Joao Marques-Silva, Edmund Clarke.   Solving QBF with Counterexample Guided Refinement.   In Theory and Applications of Satisfiability Testing (SAT 2012), pp. 114-128.-  <http://dx.doi.org/10.1007/978-3-642-31612-8_10>+  <https://doi.org/10.1007/978-3-642-31612-8_10>   <https://www.cs.cmu.edu/~wklieber/papers/qbf-cegar-sat-2012.pdf>
+ misc/smtcomp/bin/starexec_run_default view
@@ -0,0 +1,2 @@+#!/bin/sh+./toysmt "$1"
+ misc/smtcomp/starexec_description.txt view
@@ -0,0 +1,1 @@+A toylevel SMT solver for QFUFLRA and its sublogics
samples/programs/assign/assign.hs view
@@ -22,7 +22,6 @@ -} module Main where -import Control.Applicative import Control.Monad import Data.Attoparsec.ByteString.Char8 hiding (isSpace) import qualified Data.Attoparsec.ByteString.Lazy as AL
samples/programs/nonogram/nonogram.hs view
@@ -2,13 +2,11 @@ {-# OPTIONS_GHC -Wall #-} module Main where -import Control.Applicative import Control.Monad import Data.Array.IArray import Data.Array.Unboxed import Data.IORef import Data.List (group)-import Data.Map (Map) import qualified Data.Map as Map import System.Console.GetOpt import System.Environment@@ -141,7 +139,7 @@       m <- SAT.getModel solver       SAT.addClause solver [if val then -var else var | (var,val) <- assocs m]       let sol = amap (SAT.evalLit m) bs-      return (Just sol)         +      return (Just sol)  data Options   = Options
samples/programs/numberlink/numberlink.hs view
@@ -2,7 +2,6 @@ {-# OPTIONS_GHC -Wall #-} module Main where -import Control.Applicative hiding (many, optional) import Control.Monad import Data.Array.IArray import qualified Data.ByteString.Lazy.Char8 as BL@@ -21,6 +20,7 @@ import System.IO import Text.Parsec hiding (try) import qualified Text.Parsec.ByteString.Lazy as ParsecBL+import qualified ToySolver.FileFormat as FF import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.PBO as PBO import qualified ToySolver.SAT.Store.PB as PBStore@@ -466,7 +466,7 @@                     obj <- encodeObj store opt prob encoded                     return $ Just [(c,[v]) | (c,v) <- obj]               opb <- PBStore.getPBFormula store-              PB.writeOPBFile fname2 $ opb{ PB.pbObjectiveFunction = obj }+              FF.writeFile fname2 $ opb{ PB.pbObjectiveFunction = obj }         _ -> do           showHelp stderr
+ samples/programs/probsat/probsat.hs view
@@ -0,0 +1,177 @@+module Main where++import Control.Monad+import Data.Char+import Data.Default.Class+import Data.Monoid+import qualified Data.Vector.Unboxed as VU+import Options.Applicative+import System.Clock+import System.IO+import qualified System.Random.MWC as Rand+import Text.Printf++import qualified ToySolver.FileFormat as FF+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT.SLS.ProbSAT as ProbSAT+import ToySolver.SAT.Printer (maxsatPrintModel)++data Options = Options+  { optAlgorithm :: String+  , optFileName :: FilePath+  , optOptions :: ProbSAT.Options+  , optRandomSeed :: Maybe Rand.Seed+  , optProbSATFunc :: String+  , optProbSATCB :: Double+  , optProbSATCM :: Double+  , optWalkSATP :: Double+  } deriving (Eq, Show)++optionsParser :: Parser Options+optionsParser = Options+  <$> algOption+  <*> fileInput+  <*> solverOptions+  <*> randomSeedOption+  <*> func+  <*> cb+  <*> cm+  <*> p+  where+    fileInput :: Parser FilePath+    fileInput = argument str (metavar "FILE")++    algOption :: Parser String+    algOption = strOption+      $  long "alg"+      <> metavar "ALGORITHM"+      <> help "Algorithm: walksat, probsat"+      <> value "probsat"+      <> showDefaultWith id++    solverOptions :: Parser ProbSAT.Options+    solverOptions = ProbSAT.Options+      <$> targetOption+      <*> maxTriesOption+      <*> maxFlipsOption+      <*> pickClauseWeightedOption++    randomSeedOption :: Parser (Maybe Rand.Seed)+    randomSeedOption = optional $+      (fmap (Rand.toSeed . VU.fromList . map read . words)) $+      strOption $+        mconcat+        [ long "random-seed"+        , metavar "\"INT ..\""+        , help "random seed"+        ]++    targetOption :: Parser Integer+    targetOption = option auto+      $  long "target"+      <> help "target objective value"+      <> showDefault+      <> metavar "INT"+      <> value (ProbSAT.optTarget def)++    maxTriesOption :: Parser Int+    maxTriesOption = option auto+      $  long "max-tries"+      <> help "maximum number of tries"+      <> showDefault+      <> metavar "INT"+      <> value (ProbSAT.optMaxTries def)++    maxFlipsOption :: Parser Int+    maxFlipsOption = option auto+      $  long "max-flips"+      <> help "maximum number of flips per try"+      <> showDefault+      <> metavar "INT"+      <> value (ProbSAT.optMaxFlips def)++    pickClauseWeightedOption :: Parser Bool+    pickClauseWeightedOption = switch+      $  short 'w'+      <> long "weighted"+      <> help "enable weighted clause selection"+      <> showDefault++    func :: Parser String+    func = strOption+      $  long "probsat-func"+      <> help "function type: exp, poly"+      <> showDefaultWith id+      <> metavar "FUNC"+      <> value "exp"++    cb :: Parser Double+    cb = option auto+      $  long "probsat-cb"+      <> help "c_b parameter"+      <> showDefault+      <> metavar "REAL"+      <> value 3.6++    cm :: Parser Double+    cm = option auto+      $  long "probsat-cm"+      <> help "c_m parameter"+      <> showDefault+      <> metavar "REAL"+      <> value 0.5++    p :: Parser Double+    p = option auto+      $  long "walksat-p"+      <> help "p parameter"+      <> showDefault+      <> metavar "REAL"+      <> value 0.1++parserInfo :: ParserInfo Options+parserInfo = info (helper <*> optionsParser)+  $  fullDesc+  <> header "probsat - an example program of ToySolver.SAT.SLS.ProbSAT"++main :: IO ()+main = do+  opt <- execParser parserInfo+  wcnf <- FF.readFile (optFileName opt)+  solver <- ProbSAT.newSolverWeighted wcnf+  gen <-+    case optRandomSeed opt of+      Nothing -> Rand.createSystemRandom+      Just seed -> Rand.restore seed+  seed <- Rand.save gen+  putStrLn $ "c use --random-seed=" ++ show (unwords . map show . VU.toList . Rand.fromSeed $ seed) ++ " option to reproduce the execution"+  ProbSAT.setRandomGen solver gen+  let callbacks =+        def+        { ProbSAT.cbOnUpdateBestSolution = \_solver obj _sol -> printf "o %d\n" obj+        }+  case map toLower (optAlgorithm opt) of+    "walksat" -> do+      let p = optWalkSATP opt+      ProbSAT.walksat solver (optOptions opt) callbacks p+    "probsat" -> do+      let cb = optProbSATCB opt+          cm = optProbSATCM opt+      seq cb $ seq cm $ return ()+      case map toLower (optProbSATFunc opt) of+        "exp" -> do+          let f make break = cm**make / cb**break+          ProbSAT.probsat solver (optOptions opt) callbacks f+        "poly" -> do+          let eps = 1+              f make break = make**cm / (eps + break**cb)+          ProbSAT.probsat solver (optOptions opt) callbacks f+        _ -> error ("unknown function type: " ++ optProbSATFunc opt)+    _ -> error ("unknown algorithm name: " ++ optAlgorithm opt)+  (obj,sol) <- ProbSAT.getBestSolution solver+  stat <- ProbSAT.getStatistics solver+  printf "c TotalCPUTime = %fs\n" (fromIntegral (toNanoSecs (ProbSAT.statTotalCPUTime stat)) / 10^(9::Int) :: Double)+  printf "c FlipsPerSecond = %f\n" (ProbSAT.statFlipsPerSecond stat)+  when (obj == 0) $ do+    putStrLn "s OPTIMUM FOUND"+  maxsatPrintModel stdout sol (CNF.wcnfNumVars wcnf)
samples/programs/survey-propagation/survey-propagation.hs view
@@ -8,7 +8,8 @@ import System.Environment import System.Exit import System.IO-import qualified ToySolver.Text.MaxSAT as MaxSAT+import qualified ToySolver.FileFormat as FF+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.MessagePassing.SurveyPropagation as SP #ifdef ENABLE_OPENCL import Control.Parallel.OpenCL@@ -96,7 +97,7 @@     (o,[fname],_) -> do       let opt = foldl (flip id) def o       handle (\(e::SomeException) -> hPrint stderr e) $ do-        Right wcnf <- MaxSAT.parseFile fname+        wcnf <- FF.readFile fname  #ifdef ENABLE_OPENCL         if optOpenCL opt then do@@ -110,10 +111,10 @@               error ("platform " ++ name ++ " has only " ++ show (length devs) ++ " devices")           context <- clCreateContext [] [dev] print           solver <- SPCL.newSolver putStrLn context dev-            (MaxSAT.numVars wcnf) [(fromIntegral w, clause) | (w,clause) <- MaxSAT.clauses wcnf]+            (CNF.wcnfNumVars wcnf) [(fromIntegral w, clause) | (w,clause) <- CNF.wcnfClauses wcnf]           -- Rand.withSystemRandom $ SPCL.initializeRandom solver           print =<< SPCL.propagate solver-          forM_ [1 .. MaxSAT.numVars wcnf] $ \v -> do+          forM_ [1 .. CNF.wcnfNumVars wcnf] $ \v -> do             prob <- SPCL.getVarProb solver v             print (v,prob)           SPCL.deleteSolver solver@@ -123,11 +124,11 @@ #endif         else do           solver <- SP.newSolver-            (MaxSAT.numVars wcnf) [(fromIntegral w, clause) | (w,clause) <- MaxSAT.clauses wcnf]+            (CNF.wcnfNumVars wcnf) [(fromIntegral w, clause) | (w,clause) <- CNF.wcnfClauses wcnf]           SP.setNThreads solver (optNThreads opt)           -- Rand.withSystemRandom $ SP.initializeRandom solver           print =<< SP.propagate solver-          forM_ [1 .. MaxSAT.numVars wcnf] $ \v -> do+          forM_ [1 .. CNF.wcnfNumVars wcnf] $ \v -> do             prob <- SP.getVarProb solver v             print (v,prob)           SP.deleteSolver solver
src/ToySolver/Arith/ContiTraverso.hs view
@@ -13,7 +13,7 @@ -- * P. Conti and C. Traverso, "Buchberger algorithm and integer programming," --   Applied Algebra, Algebraic Algorithms and Error-Correcting Codes, --   Lecture Notes in Computer Science Volume 539, 1991, pp 130-139---   <http://dx.doi.org/10.1007/3-540-54522-0_102>+--   <https://doi.org/10.1007/3-540-54522-0_102> --   <http://posso.dm.unipi.it/users/traverso/conti-traverso-ip.ps> -- -- * IKEGAMI Daisuke, "数列と多項式の愛しい関係," 2011,
src/ToySolver/Arith/Cooper/Base.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Arith.Cooper.Base@@ -54,8 +56,8 @@ import Data.Maybe import qualified Data.IntMap as IM import qualified Data.IntSet as IS-import Data.Monoid import Data.Ratio+import qualified Data.Semigroup as Semigroup import Data.Set (Set) import qualified Data.Set as Set import Data.VectorSpace hiding (project)@@ -371,9 +373,15 @@  newtype LCM a = LCM{ getLCM :: a } +instance Integral a => Semigroup.Semigroup (LCM a) where+  LCM a <> LCM b = LCM $ lcm a b+  stimes = Semigroup.stimesIdempotent+ instance Integral a => Monoid (LCM a) where   mempty = LCM 1-  LCM a `mappend` LCM b = LCM $ lcm a b+#if !(MIN_VERSION_base(4,11,0))+  mappend = (Semigroup.<>)+#endif  checkedDiv :: Integer -> Integer -> Integer checkedDiv a b =
src/ToySolver/Arith/DifferenceLogic.hs view
@@ -61,13 +61,15 @@     d = bellmanFord lastInEdge g vs  -- M = {a−b ≤ 2, b−c ≤ 3, c−a ≤ −3}-test_sat = solve xs+_test_sat :: Either (HashSet Int) (HashMap Char Int)+_test_sat = solve xs   where     xs :: [(Int, SimpleAtom Char Int)]     xs = [(1, ('a' :- 'b' :<= 2)), (2, ('b' :- 'c' :<= 3)), (3, ('c' :- 'a' :<= -3))]  -- M = {a−b ≤ 2, b−c ≤ 3, c−a ≤ −7}-test_unsat = solve xs+_test_unsat :: Either (HashSet Int) (HashMap Char Int)+_test_unsat = solve xs   where     xs :: [(Int, SimpleAtom Char Int)]     xs = [(1, ('a' :- 'b' :<= 2)), (2, ('b' :- 'c' :<= 3)), (3, ('c' :- 'a' :<= -7))]
src/ToySolver/Arith/MIP.hs view
@@ -323,7 +323,7 @@         ret <- try $ restore loop         case ret of           Left e -> atomically (putTMVar ex e)-          Right _ -> return ()    +          Right _ -> return ()      let propagateException :: SomeException -> IO ()         propagateException e = do
src/ToySolver/Arith/OmegaTest/Base.hs view
@@ -288,7 +288,7 @@ pickupZ (Nothing,Nothing) = return 0 pickupZ (Just x, Nothing) = return x pickupZ (Nothing, Just x) = return x-pickupZ (Just x, Just y) = if x <= y then return x else mzero +pickupZ (Just x, Just y) = if x <= y then return x else mzero  -- ---------------------------------------------------------------------------
src/ToySolver/Arith/Simplex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, Rank2Types, TypeOperators, TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Arith.Simplex@@ -97,7 +98,13 @@   , clearLogger   , enableTimeRecording   , disableTimeRecording+  , Config (..)+  , setConfig+  , getConfig+  , modifyConfig   , PivotStrategy (..)+  , showPivotStrategy+  , parsePivotStrategy   , setPivotStrategy    -- * Debug@@ -108,9 +115,11 @@   ) where  import Prelude hiding (log)+import Control.Arrow ((***)) import Control.Exception import Control.Monad import Control.Monad.Primitive+import Data.Char import Data.Default.Class import Data.Ord import Data.List@@ -155,16 +164,15 @@   , svLB      :: !(MutVar (PrimState m) (IntMap (v, ConstrIDSet)))   , svUB      :: !(MutVar (PrimState m) (IntMap (v, ConstrIDSet)))   , svModel   :: !(MutVar (PrimState m) (IntMap v))-  , svExplanation :: !(MutVar (PrimState m) ConstrIDSet)+  , svExplanation :: !(MutVar (PrimState m) (Maybe ConstrIDSet))   , svVCnt    :: !(MutVar (PrimState m) Int)-  , svOk      :: !(MutVar (PrimState m) Bool)   , svOptDir  :: !(MutVar (PrimState m) OptDir)    , svDefDB  :: !(MutVar (PrimState m) (Map (LA.Expr Rational) Var))    , svLogger :: !(MutVar (PrimState m) (Maybe (String -> m ())))   , svRecTime :: !(MutVar (PrimState m) (Maybe (GenericSolverM m v -> (m :~> m))))-  , svPivotStrategy :: !(MutVar (PrimState m) PivotStrategy)+  , svConfig  :: !(MutVar (PrimState m) Config)   , svNPivot  :: !(MutVar (PrimState m) Int)    , svBacktrackPoints :: !(MutVar (PrimState m) [BacktrackPoint m v])@@ -186,12 +194,11 @@   m <- newMutVar (IntMap.singleton objVar zeroV)   e <- newMutVar mempty   v <- newMutVar 0-  ok <- newMutVar True   dir <- newMutVar OptMin   defs <- newMutVar Map.empty   logger <- newMutVar Nothing   rectm <- newMutVar Nothing-  pivot <- newMutVar PivotStrategyBlandRule+  config <- newMutVar def   npivot <- newMutVar 0   bps <- newMutVar []   return $@@ -202,13 +209,12 @@     , svModel   = m     , svExplanation = e     , svVCnt    = v-    , svOk      = ok     , svOptDir  = dir     , svDefDB   = defs     , svLogger  = logger     , svRecTime = rectm     , svNPivot  = npivot-    , svPivotStrategy = pivot+    , svConfig  = config     , svBacktrackPoints = bps     } @@ -220,12 +226,11 @@   m      <- newMutVar =<< readMutVar (svModel solver)   e      <- newMutVar =<< readMutVar (svExplanation solver)   v      <- newMutVar =<< readMutVar (svVCnt solver)-  ok     <- newMutVar =<< readMutVar (svOk solver)   dir    <- newMutVar =<< readMutVar (svOptDir solver)   defs   <- newMutVar =<< readMutVar (svDefDB solver)   logger <- newMutVar =<< readMutVar (svLogger solver)   rectm  <- newMutVar =<< readMutVar (svRecTime solver)-  pivot  <- newMutVar =<< readMutVar (svPivotStrategy solver)+  config <- newMutVar =<< readMutVar (svConfig solver)   npivot <- newMutVar =<< readMutVar (svNPivot solver)   bps    <- newMutVar =<< mapM cloneBacktrackPoint =<< readMutVar (svBacktrackPoints solver)   return $@@ -236,15 +241,14 @@     , svModel   = m     , svExplanation = e     , svVCnt    = v-    , svOk      = ok     , svOptDir  = dir     , svDefDB   = defs     , svLogger  = logger     , svRecTime = rectm     , svNPivot  = npivot-    , svPivotStrategy = pivot+    , svConfig  = config     , svBacktrackPoints = bps-    }  +    }  class (VectorSpace v, Scalar v ~ Rational, Ord v) => SolverValue v where   toValue :: Rational -> v@@ -285,6 +289,39 @@ boundExplanation :: SolverValue v => Bound v -> ConstrIDSet boundExplanation = maybe mempty snd +addBound :: SolverValue v => Bound v -> Bound v -> Bound v+addBound b1 b2 = do+  (a1,cs1) <- b1+  (a2,cs2) <- b2+  let a3 = a1 ^+^ a2+      cs3 = IntSet.union cs1 cs2+  seq a3 $ seq cs3 $ return (a3,cs3)++scaleBound :: SolverValue v => Scalar v -> Bound v -> Bound v+scaleBound c = fmap ((c *^) *** id)++data Config+  = Config+  { configPivotStrategy :: !PivotStrategy+  , configEnableBoundTightening :: !Bool+  } deriving (Show, Eq, Ord)++instance Default Config where+  def =+    Config+    { configPivotStrategy = PivotStrategyBlandRule+    , configEnableBoundTightening = False+    }++setConfig :: PrimMonad m => GenericSolverM m v -> Config -> m ()+setConfig solver config = writeMutVar (svConfig solver) config++getConfig :: PrimMonad m => GenericSolverM m v -> m Config+getConfig solver = readMutVar (svConfig solver)++modifyConfig :: PrimMonad m => GenericSolverM m v -> (Config -> Config) -> m ()+modifyConfig solver = modifyMutVar' (svConfig solver)+ {- Largest coefficient rule: original rule suggested by G. Dantzig. Largest increase rule: computationally more expensive in comparison with Largest coefficient, but locally maximizes the progress.@@ -297,10 +334,23 @@   = PivotStrategyBlandRule   | PivotStrategyLargestCoefficient --  | PivotStrategySteepestEdge-  deriving (Eq, Ord, Enum, Show, Read)+  deriving (Eq, Ord, Enum, Bounded, Show, Read) +showPivotStrategy :: PivotStrategy -> String+showPivotStrategy PivotStrategyBlandRule = "bland-rule"+showPivotStrategy PivotStrategyLargestCoefficient = "largest-coefficient"++parsePivotStrategy :: String -> Maybe PivotStrategy+parsePivotStrategy s =+  case map toLower s of+    "bland-rule" -> Just PivotStrategyBlandRule+    "largest-coefficient" -> Just PivotStrategyLargestCoefficient+    _ -> Nothing++{-# DEPRECATED nVars "Use setConfig instead" #-} setPivotStrategy :: PrimMonad m => GenericSolverM m v -> PivotStrategy -> m ()-setPivotStrategy solver ps = writeMutVar (svPivotStrategy solver) ps+setPivotStrategy solver ps = modifyConfig solver $ \config ->+  config{ configPivotStrategy = ps }  {--------------------------------------------------------------------   problem description@@ -341,7 +391,7 @@       writeMutVar (svUB solver) $ IntMap.mergeWithKey (\_ _curr saved -> saved) id (const IntMap.empty) ubs savedUBs        writeMutVar (svBacktrackPoints solver) bps'-      writeMutVar (svOk solver) True+      writeMutVar (svExplanation solver) Nothing  withBacktrackpoint :: PrimMonad m => GenericSolverM m v -> (BacktrackPoint m v -> m ()) -> m () withBacktrackpoint solver f = do@@ -438,7 +488,10 @@             Just 0 -> do               modifyMutVar (svLB solver) (IntMap.insert v (toValue 0, mempty))               modifyMutVar (svUB solver) (IntMap.insert v (toValue 0, mempty))-            _ -> return ()+            _ -> do+              config <- getConfig solver+              when (configEnableBoundTightening config) $ do+                tightenBounds solver v           return (v,op'',rhs'')   where     scale :: LA.Expr Rational -> (Rational, LA.Expr Rational)@@ -449,18 +502,20 @@         c2 = signum $ head ([c | (c,x) <- LA.terms e] ++ [1])               assertLower :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> v -> m ()-assertLower solver x l = assertLower' solver x l Nothing+assertLower solver x l = assertLB solver x (Just (l, IntSet.empty))  assertLower' :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> v -> Maybe ConstrID -> m ()-assertLower' solver x l cid = do-  let cidSet = IntSet.fromList $ maybeToList cid+assertLower' solver x l cid = assertLB solver x (Just (l, IntSet.fromList (maybeToList cid)))++assertLB :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> Bound v -> m ()+assertLB solver x Nothing = return ()+assertLB solver x (Just (l, cidSet)) = do   l0 <- getLB solver x   u0 <- getUB solver x   case (l0,u0) of      (Just (l0', _), _) | l <= l0' -> return ()     (_, Just (u0', cidSet2)) | u0' < l -> do-      writeMutVar (svExplanation solver) $ cidSet `IntSet.union` cidSet2-      markBad solver+      setExplanation solver $ cidSet `IntSet.union` cidSet2     _ -> do       bpSaveLB solver x       modifyMutVar (svLB solver) (IntMap.insert x (l, cidSet))@@ -470,18 +525,20 @@       checkNBFeasibility solver  assertUpper :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> v -> m ()-assertUpper solver x u = assertUpper' solver x u Nothing +assertUpper solver x u = assertUB solver x (Just (u, IntSet.empty))  assertUpper' :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> v -> Maybe ConstrID -> m ()-assertUpper' solver x u cid = do-  let cidSet = IntSet.fromList $ maybeToList cid+assertUpper' solver x u cid = assertUB solver x (Just (u, IntSet.fromList (maybeToList cid)))++assertUB :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> Bound v -> m ()+assertUB solver x Nothing = return ()+assertUB solver x (Just (u, cidSet)) = do   l0 <- getLB solver x   u0 <- getUB solver x   case (l0,u0) of     (_, Just (u0', _)) | u0' <= u -> return ()     (Just (l0', cidSet2), _) | u < l0' -> do-      writeMutVar (svExplanation solver) $ cidSet `IntSet.union` cidSet2-      markBad solver+      setExplanation solver $ cidSet `IntSet.union` cidSet2     _ -> do       bpSaveUB solver x       modifyMutVar (svUB solver) (IntMap.insert x (u, cidSet))@@ -502,7 +559,7 @@   modifyMutVar (svTableau solver) $ \t ->     IntMap.insert v (LA.applySubst t e) t   modifyMutVar (svModel solver) $ \m -> -    IntMap.insert v (LA.evalLinear m (toValue 1) e) m  +    IntMap.insert v (LA.evalLinear m (toValue 1) e) m  setOptDir :: PrimMonad m => GenericSolverM m v -> OptDir -> m () setOptDir solver dir = writeMutVar (svOptDir solver) dir@@ -567,7 +624,7 @@                        -- (aij < 0 and β(xj) < uj) or (aij > 0 and β(xj) > lj)                        canDecrease solver           xi_def <- getRow solver xi-          r <- liftM (fmap snd) $ findM q (LA.terms xi_def)              +          r <- liftM (fmap snd) $ findM q (LA.terms xi_def)           case r of             Nothing -> do               let c = if isLBViolated then li else ui@@ -582,21 +639,24 @@                     getLB solver xj                   else do                     getUB solver xj-              writeMutVar (svExplanation solver) core-              markBad solver+              setExplanation solver core               return False             Just xj -> do               pivotAndUpdate solver xi xj (fromJust $ boundValue $ if isLBViolated then li else ui)-              loop+              m <- readMutVar (svExplanation solver)+              if isJust m then+                return False+              else+                loop -  ok <- readMutVar (svOk solver)-  if not ok-  then return False-  else do-    log solver "check"-    result <- recordTime solver loop-    when result $ checkFeasibility solver-    return result+  m <- readMutVar (svExplanation solver)+  case m of+    Just _ -> return False+    Nothing -> do+      log solver "check"+      result <- recordTime solver loop+      when result $ checkFeasibility solver+      return result  selectViolatingBasicVariable :: forall m v. (PrimMonad m, SolverValue v) => GenericSolverM m v -> m (Maybe Var) selectViolatingBasicVariable solver = do@@ -610,8 +670,8 @@       return $ not (testLB li vi) || not (testUB ui vi)   vs <- basicVariables solver -  ps <- readMutVar (svPivotStrategy solver)-  case ps of+  config <- getConfig solver+  case configPivotStrategy config of     PivotStrategyBlandRule ->       findM p vs     PivotStrategyLargestCoefficient -> do@@ -628,6 +688,25 @@                 else return (xi, vi ^-^ fromJust (boundValue ui))           return $ Just $ fst $ maximumBy (comparing snd) xs2 +tightenBounds :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> m ()+tightenBounds solver x = do+  -- x must be basic variable+  defs <- readMutVar (svTableau solver)+  let x_def = defs IntMap.! x+      f (!lb,!ub) (c,xk) = do+        if LA.unitVar == xk then do+          return (addBound lb (Just (toValue c, IntSet.empty)), addBound ub (Just (toValue c, IntSet.empty)))+        else do+          lb_k <- getLB solver xk+          ub_k <- getUB solver xk+          if c > 0 then do+            return (addBound lb (scaleBound c lb_k), addBound ub (scaleBound c ub_k))+          else do+            return (addBound lb (scaleBound c ub_k), addBound ub (scaleBound c lb_k))+  (lb,ub) <- foldM f (Just (zeroV, IntSet.empty), Just (zeroV, IntSet.empty)) (LA.terms x_def)+  assertLB solver x lb+  assertUB solver x ub+ {--------------------------------------------------------------------   Optimization --------------------------------------------------------------------}@@ -685,9 +764,9 @@  selectEnteringVariable :: forall m v. (PrimMonad m, SolverValue v) => GenericSolverM m v -> m (Maybe (Rational, Var)) selectEnteringVariable solver = do-  ps <- readMutVar (svPivotStrategy solver)+  config <- getConfig solver   obj_def <- getRow solver objVar-  case ps of+  case configPivotStrategy config of     PivotStrategyBlandRule ->       findM canEnter (LA.terms obj_def)     PivotStrategyLargestCoefficient -> do@@ -817,21 +896,24 @@                         getLB solver xj                       else do                         getUB solver xj-                  writeMutVar (svExplanation solver) core-                  markBad solver+                  setExplanation solver core                   return Unsat                 Just xj -> do                   pivotAndUpdate solver xi xj (fromJust $ boundValue $ if isLBViolated then li else ui)-                  loop+                  m <- readMutVar (svExplanation solver)+                  if isJust m then+                    return Unsat+                  else+                    loop -  ok <- readMutVar (svOk solver)-  if not ok-  then return Unsat-  else do-    log solver "dual simplex"-    result <- recordTime solver loop-    when (result == Optimum) $ checkFeasibility solver-    return result+  m <- readMutVar (svExplanation solver)+  case m of+    Just _ -> return Unsat+    Nothing -> do+      log solver "dual simplex"+      result <- recordTime solver loop+      when (result == Optimum) $ checkFeasibility solver+      return result  dualRTest :: PrimMonad m => GenericSolverM m Rational -> LA.Expr Rational -> Bool -> m (Maybe Var) dualRTest solver row isLBViolated = do@@ -889,13 +971,17 @@     return (x,val)  getObjValue :: PrimMonad m => GenericSolverM m v -> m v-getObjValue solver = getValue solver objVar  +getObjValue solver = getValue solver objVar  type Model = IntMap Rational  explain :: PrimMonad m => GenericSolverM m v -> m ConstrIDSet-explain solver = readMutVar (svExplanation solver)-  +explain solver = do+  m <- readMutVar (svExplanation solver)+  case m of+    Nothing -> error "no explanation is available"+    Just cs -> return cs+ {--------------------------------------------------------------------   major function --------------------------------------------------------------------}@@ -947,6 +1033,10 @@    pivot solver xi xj +  config <- getConfig solver+  when (configEnableBoundTightening config) $ do+    tightenBounds solver xj+   -- log solver $ printf "after pivotAndUpdate x%d x%d (%s)" xi xj (show v)   -- dump solver @@ -987,8 +1077,12 @@   xi_def <- getRow solver xi   return $! LA.coeff xj xi_def -markBad :: PrimMonad m => GenericSolverM m v -> m ()-markBad solver = writeMutVar (svOk solver) False+setExplanation :: PrimMonad m => GenericSolverM m v -> ConstrIDSet -> m ()+setExplanation solver !cs = do+  m <- readMutVar (svExplanation solver)+  case m of+    Just _ -> return ()+    Nothing -> writeMutVar (svExplanation solver) (Just cs)  {--------------------------------------------------------------------   utility
src/ToySolver/Arith/Simplex/Textbook.hs view
@@ -163,7 +163,7 @@   and [IS.null (IM.keysSet m `IS.intersection` vs) | (m,_) <- IM.elems tbl']   where     tbl' = IM.delete objRowIndex tbl-    vs = IM.keysSet tbl' +    vs = IM.keysSet tbl'  isFeasible :: Real r => Tableau r -> Bool isFeasible tbl = @@ -179,7 +179,7 @@  isImproving :: Real r => OptDir -> Tableau r -> Tableau r -> Bool isImproving OptMin from to = currentObjValue to <= currentObjValue from -isImproving OptMax from to = currentObjValue to >= currentObjValue from +isImproving OptMax from to = currentObjValue to >= currentObjValue from  -- --------------------------------------------------------------------------- -- primal simplex
src/ToySolver/BitVector/Base.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}@@ -46,6 +47,7 @@ import qualified Data.Map as Map import Data.Monoid import Data.Ord+import qualified Data.Semigroup as Semigroup import qualified Data.Vector as V import qualified Data.Vector.Generic as VG import qualified Data.Vector.Unboxed as VU@@ -124,9 +126,14 @@   compare (BV bs1) (BV bs2) =     (comparing VG.length <> comparing VG.reverse) bs1 bs2 +instance Semigroup.Semigroup BV where+  BV hi <> BV lo = BV (lo <> hi)+ instance Monoid BV where   mempty = BV VG.empty-  mappend (BV hi) (BV lo) = BV (lo <> hi) +#if !(MIN_VERSION_base(4,11,0))+  mappend = (Semigroup.<>)+#endif  instance Show BV where   show bv = "0b" ++ [if b then '1' else '0' | b <- toDescBits bv]@@ -398,9 +405,14 @@   bvashr = EOp2 OpAShr   bvcomp = EOp2 OpComp +instance Semigroup.Semigroup Expr where+  (<>) = EOp2 OpConcat+ instance Monoid Expr where   mempty = EConst mempty-  mappend = EOp2 OpConcat+#if !(MIN_VERSION_base(4,11,0))+  mappend = (Semigroup.<>)+#endif  instance Bits Expr where   (.&.) = bvand
src/ToySolver/BitVector/Solver.hs view
@@ -28,7 +28,6 @@   ) where  import Prelude hiding (repeat)-import Control.Applicative hiding (Const (..)) import Control.Monad import qualified Data.Foldable as F import Data.IntMap (IntMap)@@ -39,7 +38,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe+#if !MIN_VERSION_base(4,11,0) import Data.Monoid+#endif import qualified Data.Vector.Generic as VG import qualified Data.Vector.Unboxed as VU import Data.Sequence (Seq)@@ -99,7 +100,7 @@   return $ Var{ varWidth = w, varId = v }  data NormalizedRel = NRSLt | NRULt | NREql-  deriving (Eq, Ord, Enum, Bounded, Show)  +  deriving (Eq, Ord, Enum, Bounded, Show)  data NormalizedAtom = NormalizedAtom NormalizedRel Expr Expr   deriving (Eq, Ord, Show)@@ -503,8 +504,8 @@  -- ------------------------------------------------------------------------ -test1 :: IO ()-test1 = do+_test1 :: IO ()+_test1 = do   solver <- newSolver   v1 <- newVar solver 8   v2 <- newVar solver 8@@ -513,8 +514,8 @@   m <- getModel solver   print m -test2 :: IO ()-test2 = do+_test2 :: IO ()+_test2 = do   solver <- newSolver   v1 <- newVar solver 8   v2 <- newVar solver 8
src/ToySolver/Combinatorial/HittingSet/FredmanKhachiyan1996.hs view
@@ -89,8 +89,8 @@     lhs = or [is `IntSet.isSubsetOf` xs | is <- Set.toList f]     rhs = or [xs `disjoint` js | js <- Set.toList g] -volume :: Set IntSet -> Set IntSet -> Int-volume f g = Set.size f * Set.size g+_volume :: Set IntSet -> Set IntSet -> Int+_volume f g = Set.size f * Set.size g  condition_1_1 :: Set IntSet -> Set IntSet -> Bool condition_1_1 f g = all (\is -> all (\js -> is `intersect` js) g) f
src/ToySolver/Combinatorial/HittingSet/GurvichKhachiyan1999.hs view
@@ -141,9 +141,9 @@ evalDNF :: Set IntSet -> IntSet -> Bool evalDNF dnf xs = or [is `IntSet.isSubsetOf` xs | is <- Set.toList dnf] -evalCNF :: Set IntSet -> IntSet -> Bool-evalCNF cnf xs = and [not $ IntSet.null $ is `IntSet.intersection` xs | is <- Set.toList cnf]- +_evalCNF :: Set IntSet -> IntSet -> Bool+_evalCNF cnf xs = and [not $ IntSet.null $ is `IntSet.intersection` xs | is <- Set.toList cnf]+  f, g :: Set IntSet f = Set.fromList $ map IntSet.fromList [[2,4,7], [7,8], [9]]
+ src/ToySolver/Converter.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+module ToySolver.Converter+  ( module ToySolver.Converter.Base+  , module ToySolver.Converter.GCNF2MaxSAT+  , module ToySolver.Converter.MIP2PB+  , module ToySolver.Converter.NAESAT+  , module ToySolver.Converter.PB+  , module ToySolver.Converter.PB2IP+  , module ToySolver.Converter.PB2LSP+  , module ToySolver.Converter.PB2SMP+  , module ToySolver.Converter.QBF2IPC+  , module ToySolver.Converter.QUBO+  , module ToySolver.Converter.SAT2KSAT+  , module ToySolver.Converter.SAT2MaxCut+  , module ToySolver.Converter.SAT2MaxSAT+  , module ToySolver.Converter.Tseitin+  ) where++import ToySolver.Converter.Base+import ToySolver.Converter.GCNF2MaxSAT+import ToySolver.Converter.MIP2PB+import ToySolver.Converter.NAESAT+import ToySolver.Converter.PB+import ToySolver.Converter.PB2IP+import ToySolver.Converter.PB2LSP+import ToySolver.Converter.PB2SMP+import ToySolver.Converter.QBF2IPC+import ToySolver.Converter.QUBO+import ToySolver.Converter.SAT2KSAT+import ToySolver.Converter.SAT2MaxCut+import ToySolver.Converter.SAT2MaxSAT+import ToySolver.Converter.Tseitin
+ src/ToySolver/Converter/Base.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.Base+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.Converter.Base+  ( Transformer (..)+  , ForwardTransformer (..)+  , BackwardTransformer (..)+  , ObjValueTransformer (..)+  , ObjValueForwardTransformer (..)+  , ObjValueBackwardTransformer (..)+  , ComposedTransformer (..)+  , IdentityTransformer (..)+  , ReversedTransformer (..)+  ) where+++class (Eq a, Show a) => Transformer a where+  type Source a+  type Target a++class Transformer a => ForwardTransformer a where+  transformForward :: a -> Source a -> Target a++class Transformer a => BackwardTransformer a where+  transformBackward :: a -> Target a -> Source a+++class ObjValueTransformer a where+  type SourceObjValue a+  type TargetObjValue a++class ObjValueTransformer a => ObjValueForwardTransformer a where+  transformObjValueForward :: a -> SourceObjValue a -> TargetObjValue a++class ObjValueTransformer a => ObjValueBackwardTransformer a where+  transformObjValueBackward :: a -> TargetObjValue a -> SourceObjValue a+++data ComposedTransformer a b = ComposedTransformer a b+  deriving (Eq, Show, Read)++instance (Transformer a, Transformer b, Target a ~ Source b) => Transformer (ComposedTransformer a b) where+  type Source (ComposedTransformer a b) = Source a+  type Target (ComposedTransformer a b) = Target b++instance (ForwardTransformer a, ForwardTransformer b, Target a ~ Source b)+  => ForwardTransformer (ComposedTransformer a b) where+  transformForward (ComposedTransformer a b) = transformForward b . transformForward a++instance (BackwardTransformer a, BackwardTransformer b, Target a ~ Source b)+  => BackwardTransformer (ComposedTransformer a b) where+  transformBackward (ComposedTransformer a b) = transformBackward a . transformBackward b+++instance (ObjValueTransformer a, ObjValueTransformer b, TargetObjValue a ~ SourceObjValue b)+  => ObjValueTransformer (ComposedTransformer a b) where+  type SourceObjValue (ComposedTransformer a b) = SourceObjValue a+  type TargetObjValue (ComposedTransformer a b) = TargetObjValue b++instance (ObjValueForwardTransformer a, ObjValueForwardTransformer b, TargetObjValue a ~ SourceObjValue b)+  => ObjValueForwardTransformer (ComposedTransformer a b) where+  transformObjValueForward (ComposedTransformer a b) = transformObjValueForward b . transformObjValueForward a++instance (ObjValueBackwardTransformer a, ObjValueBackwardTransformer b, TargetObjValue a ~ SourceObjValue b)+  => ObjValueBackwardTransformer (ComposedTransformer a b) where+  transformObjValueBackward (ComposedTransformer a b) = transformObjValueBackward a . transformObjValueBackward b++++data IdentityTransformer a = IdentityTransformer+  deriving (Eq, Show, Read)++instance Transformer (IdentityTransformer a) where+  type Source (IdentityTransformer a) = a+  type Target (IdentityTransformer a) = a++instance ForwardTransformer (IdentityTransformer a) where+  transformForward IdentityTransformer = id++instance BackwardTransformer (IdentityTransformer a) where+  transformBackward IdentityTransformer = id+++data ReversedTransformer t = ReversedTransformer t+  deriving (Eq, Show, Read)++instance Transformer t => Transformer (ReversedTransformer t) where+  type Source (ReversedTransformer t) = Target t+  type Target (ReversedTransformer t) = Source t++instance BackwardTransformer t => ForwardTransformer (ReversedTransformer t) where+  transformForward (ReversedTransformer t) = transformBackward t++instance ForwardTransformer t => BackwardTransformer (ReversedTransformer t) where+  transformBackward (ReversedTransformer t) = transformForward t++instance ObjValueTransformer t => ObjValueTransformer (ReversedTransformer t) where+  type SourceObjValue (ReversedTransformer t) = TargetObjValue t+  type TargetObjValue (ReversedTransformer t) = SourceObjValue t++instance ObjValueBackwardTransformer t => ObjValueForwardTransformer (ReversedTransformer t) where+  transformObjValueForward (ReversedTransformer t) = transformObjValueBackward t++instance ObjValueForwardTransformer t => ObjValueBackwardTransformer (ReversedTransformer t) where+  transformObjValueBackward (ReversedTransformer t) = transformObjValueForward t
src/ToySolver/Converter/GCNF2MaxSAT.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Converter.GCNF2MaxSAT@@ -7,31 +8,46 @@ --  -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  experimental--- Portability :  portable+-- Portability :  non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.GCNF2MaxSAT-  ( convert+  ( gcnf2maxsat+  , GCNF2MaxSATInfo (..)   ) where -import qualified ToySolver.Text.GCNF as GCNF-import qualified ToySolver.Text.MaxSAT as MaxSAT+import qualified Data.Vector.Generic as VG+import ToySolver.Converter.Base+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT.Types as SAT -convert :: GCNF.GCNF -> MaxSAT.WCNF-convert-  GCNF.GCNF-  { GCNF.numVars        = nv-  , GCNF.numClauses     = nc-  , GCNF.lastGroupIndex = lastg-  , GCNF.clauses        = cs+data GCNF2MaxSATInfo = GCNF2MaxSATInfo !Int+  deriving (Eq, Show, Read)++instance Transformer GCNF2MaxSATInfo where+  type Source GCNF2MaxSATInfo = SAT.Model+  type Target GCNF2MaxSATInfo = SAT.Model++instance BackwardTransformer GCNF2MaxSATInfo where+  transformBackward (GCNF2MaxSATInfo nv1) = SAT.restrictModel nv1++gcnf2maxsat :: CNF.GCNF -> (CNF.WCNF, GCNF2MaxSATInfo)+gcnf2maxsat+  CNF.GCNF+  { CNF.gcnfNumVars        = nv+  , CNF.gcnfNumClauses     = nc+  , CNF.gcnfLastGroupIndex = lastg+  , CNF.gcnfClauses        = cs   }   =-  MaxSAT.WCNF-  { MaxSAT.topCost = top-  , MaxSAT.clauses = [(top, if g==0 then c else -(nv+g) : c) | (g,c) <- cs] ++ [(1,[v]) | v <- [nv+1..nv+lastg]]-  , MaxSAT.numVars = nv + lastg-  , MaxSAT.numClauses = nc + lastg-  }+  ( CNF.WCNF+    { CNF.wcnfTopCost = top+    , CNF.wcnfClauses = [(top, if g==0 then c else VG.cons (-(nv+g)) c) | (g,c) <- cs] ++ [(1, SAT.packClause [v]) | v <- [nv+1..nv+lastg]]+    , CNF.wcnfNumVars = nv + lastg+    , CNF.wcnfNumClauses = nc + lastg+    }+  , GCNF2MaxSATInfo nv+  )   where-    top :: MaxSAT.Weight+    top :: CNF.Weight     top = fromIntegral (lastg + 1)
src/ToySolver/Converter/MIP2PB.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Converter.MIP2PB@@ -12,7 +13,8 @@ -- ----------------------------------------------------------------------------- module ToySolver.Converter.MIP2PB-  ( convert+  ( mip2pb+  , MIP2PBInfo (..)   , addMIP   ) where @@ -29,6 +31,7 @@ import Data.VectorSpace  import qualified Data.PseudoBoolean as PBFile+import ToySolver.Converter.Base import qualified ToySolver.Data.MIP as MIP import ToySolver.Data.OrdRel import qualified ToySolver.SAT.Types as SAT@@ -38,22 +41,42 @@  -- ----------------------------------------------------------------------------- -convert :: MIP.Problem Rational -> Either String (PBFile.Formula, Integer -> Rational, SAT.Model -> Map MIP.Var Integer)-convert mip = runST $ runExceptT $ m+mip2pb :: MIP.Problem Rational -> Either String (PBFile.Formula, MIP2PBInfo)+mip2pb mip = runST $ runExceptT $ m   where-    m :: ExceptT String (ST s) (PBFile.Formula, Integer -> Rational, SAT.Model -> Map MIP.Var Integer)+    m :: ExceptT String (ST s) (PBFile.Formula, MIP2PBInfo)     m = do       db <- lift $ newPBStore-      (Integer.Expr obj, otrans, mtrans) <- addMIP' db mip+      (Integer.Expr obj, info) <- addMIP' db mip       formula <- lift $ getPBFormula db-      return $ (formula{ PBFile.pbObjectiveFunction = Just obj }, otrans, mtrans)+      return $ (formula{ PBFile.pbObjectiveFunction = Just obj }, info) +data MIP2PBInfo = MIP2PBInfo (Map MIP.Var Integer.Expr) !Integer+  deriving (Eq, Show)++instance Transformer MIP2PBInfo where+  type Source MIP2PBInfo = Map MIP.Var Integer+  type Target MIP2PBInfo = SAT.Model++instance BackwardTransformer MIP2PBInfo where+  transformBackward (MIP2PBInfo vmap _d) m = fmap (Integer.eval m) vmap++instance ObjValueTransformer MIP2PBInfo where+  type SourceObjValue MIP2PBInfo = Rational+  type TargetObjValue MIP2PBInfo = Integer++instance ObjValueForwardTransformer MIP2PBInfo where+  transformObjValueForward (MIP2PBInfo _vmap d) val = asInteger (val * fromIntegral d)++instance ObjValueBackwardTransformer MIP2PBInfo where+  transformObjValueBackward (MIP2PBInfo _vmap d) val = fromIntegral val / fromIntegral d+ -- ----------------------------------------------------------------------------- -addMIP :: SAT.AddPBNL m enc => enc -> MIP.Problem Rational -> m (Either String (Integer.Expr, Integer -> Rational, SAT.Model -> Map MIP.Var Integer))+addMIP :: SAT.AddPBNL m enc => enc -> MIP.Problem Rational -> m (Either String (Integer.Expr, MIP2PBInfo)) addMIP enc mip = runExceptT $ addMIP' enc mip -addMIP' :: SAT.AddPBNL m enc => enc -> MIP.Problem Rational -> ExceptT String m (Integer.Expr, Integer -> Rational, SAT.Model -> Map MIP.Var Integer)+addMIP' :: SAT.AddPBNL m enc => enc -> MIP.Problem Rational -> ExceptT String m (Integer.Expr, MIP2PBInfo) addMIP' enc mip = do   if not (Set.null nivs) then do     throwE $ "cannot handle non-integer variables: " ++ intercalate ", " (map MIP.fromVar (Set.toList nivs))@@ -108,23 +131,12 @@             (if MIP.objDir obj == MIP.OptMin then 1 else -1)         obj2 = sumV [asInteger (r * fromIntegral d) *^ product [vmap Map.! v | v <- vs] | MIP.Term r vs <- MIP.terms (MIP.objExpr obj)] -    let transformObjVal :: Integer -> Rational-        transformObjVal val = fromIntegral val / fromIntegral d--        transformModel :: SAT.Model -> Map MIP.Var Integer-        transformModel m = Map.fromList-          [ (v, Integer.eval m (vmap Map.! v)) | v <- Set.toList ivs ]+    return (obj2, MIP2PBInfo vmap d) -    return (obj2, transformObjVal, transformModel)   where     ivs = MIP.integerVariables mip     nivs = MIP.variables mip `Set.difference` ivs -    asInteger :: Rational -> Integer-    asInteger r-      | denominator r /= 1 = error (show r ++ " is not integer")-      | otherwise = numerator r-     nonAdjacentPairs :: [a] -> [(a,a)]     nonAdjacentPairs (x1:x2:xs) = [(x1,x3) | x3 <- xs] ++ nonAdjacentPairs (x2:xs)     nonAdjacentPairs _ = []@@ -132,5 +144,12 @@     asBin :: Integer.Expr -> SAT.Lit     asBin (Integer.Expr [(1,[lit])]) = lit     asBin _ = error "asBin: failure"++-- -----------------------------------------------------------------------------++asInteger :: Rational -> Integer+asInteger r+  | denominator r /= 1 = error (show r ++ " is not integer")+  | otherwise = numerator r  -- -----------------------------------------------------------------------------
src/ToySolver/Converter/MIP2SMT.hs view
@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- module ToySolver.Converter.MIP2SMT-  ( convert+  ( mip2smt   , Options (..)   , Language (..)   , YicesVersion (..)@@ -312,8 +312,8 @@ nonAdjacentPairs (x1:x2:xs) = [(x1,x3) | x3 <- xs] ++ nonAdjacentPairs (x2:xs) nonAdjacentPairs _ = [] -convert :: Options -> MIP.Problem Rational -> Builder-convert opt mip =+mip2smt :: Options -> MIP.Problem Rational -> Builder+mip2smt opt mip =   mconcat $ map (<> B.singleton '\n') $     options ++ set_logic ++ defs ++ map (assert opt) (conditions opt False env mip)     ++ [ assert opt (optimality, Nothing) | optOptimize opt ]@@ -401,10 +401,10 @@ testFile :: FilePath -> IO () testFile fname = do   mip <- MIP.readLPFile def fname-  TLIO.putStrLn $ B.toLazyText $ convert def (fmap toRational mip)+  TLIO.putStrLn $ B.toLazyText $ mip2smt def (fmap toRational mip)  test :: IO ()-test = TLIO.putStrLn $ B.toLazyText $ convert def testdata+test = TLIO.putStrLn $ B.toLazyText $ mip2smt def testdata  testdata :: MIP.Problem Rational Right testdata = fmap (fmap toRational) $ MIP.parseLPString def "test" $ unlines
− src/ToySolver/Converter/MaxSAT2IP.hs 
@@ -1,25 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.MaxSAT2IP--- Copyright   :  (c) Masahiro Sakai 2011-2014--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable----------------------------------------------------------------------------------module ToySolver.Converter.MaxSAT2IP-  ( convert-  ) where--import Data.Map (Map)-import qualified ToySolver.Data.MIP as MIP-import qualified ToySolver.Text.MaxSAT as MaxSAT-import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.Converter.MaxSAT2WBO as MaxSAT2WBO-import qualified ToySolver.Converter.PB2IP as PB2IP--convert :: Bool -> MaxSAT.WCNF -> (MIP.Problem Integer, SAT.Model -> Map MIP.Var Rational, Map MIP.Var Rational -> SAT.Model)-convert useIndicator wcnf = PB2IP.convertWBO useIndicator (MaxSAT2WBO.convert wcnf)
− src/ToySolver/Converter/MaxSAT2WBO.hs 
@@ -1,40 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.MaxSAT2WBO--- Copyright   :  (c) Masahiro Sakai 2013--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable----------------------------------------------------------------------------------module ToySolver.Converter.MaxSAT2WBO-  ( convert-  ) where--import qualified Data.PseudoBoolean as PBFile-import qualified ToySolver.Text.MaxSAT as MaxSAT--convert :: MaxSAT.WCNF -> PBFile.SoftFormula-convert-  MaxSAT.WCNF-  { MaxSAT.topCost = top-  , MaxSAT.clauses = cs-  , MaxSAT.numVars = nv-  , MaxSAT.numClauses = nc-  } =-  PBFile.SoftFormula-  { PBFile.wboTopCost = Nothing-  , PBFile.wboConstraints = map f cs-  , PBFile.wboNumVars = nv-  , PBFile.wboNumConstraints = nc-  }-  where-    f (w,ls)-     | w>=top    = (Nothing, p) -- hard constraint-     | otherwise = (Just w, p)  -- soft constraint-     where-       p = ([(1,[l]) | l <- ls], PBFile.Ge, 1)-
+ src/ToySolver/Converter/NAESAT.hs view
@@ -0,0 +1,214 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.NAESAT+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-- Not-All-Equal SAT problems.+--+-----------------------------------------------------------------------------+module ToySolver.Converter.NAESAT+  (+  -- * Definition of NAE (Not-All-Equall) SAT problems.+    NAESAT+  , evalNAESAT+  , NAEClause+  , evalNAEClause++  -- * Conversion with SAT problem+  , SAT2NAESATInfo (..)+  , sat2naesat+  , NAESAT2SATInfo+  , naesat2sat++  -- * Conversion from general NAE-SAT to NAE-k-SAT+  , NAESAT2NAEKSATInfo (..)+  , naesat2naeksat++  -- ** NAE-SAT to MAX-2-SAT+  , NAESAT2Max2SATInfo+  , naesat2max2sat+  , NAE3SAT2Max2SATInfo+  , nae3sat2max2sat+  ) where++import Control.Monad.State.Strict+import Data.Array.Unboxed+import qualified Data.IntMap as IntMap+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU+import ToySolver.Converter.Base+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT.Types as SAT++type NAESAT = (Int, [NAEClause])++evalNAESAT :: SAT.IModel m => m -> NAESAT -> Bool+evalNAESAT m (_,cs) = all (evalNAEClause m) cs++type NAEClause = VU.Vector SAT.Lit++evalNAEClause :: SAT.IModel m => m -> NAEClause -> Bool+evalNAEClause m c =+  VG.any (SAT.evalLit m) c && VG.any (not . SAT.evalLit m) c++-- ------------------------------------------------------------------------++-- | Information of 'sat2naesat' conversion+newtype SAT2NAESATInfo = SAT2NAESATInfo SAT.Var+  deriving (Eq, Show, Read)++-- | Convert a CNF formula φ to an equisatifiable NAE-SAT formula ψ,+-- together with a 'SAT2NAESATInfo'+sat2naesat :: CNF.CNF -> (NAESAT, SAT2NAESATInfo)+sat2naesat cnf = (ret, SAT2NAESATInfo z)+  where+    z = CNF.cnfNumVars cnf + 1+    ret =+      ( CNF.cnfNumVars cnf + 1+      , [VG.snoc clause z | clause <- CNF.cnfClauses cnf]+      )++instance Transformer SAT2NAESATInfo where+  type Source SAT2NAESATInfo = SAT.Model+  type Target SAT2NAESATInfo = SAT.Model++instance ForwardTransformer SAT2NAESATInfo where+  transformForward (SAT2NAESATInfo z) m = array (1,z) $ (z,False) : assocs m++instance BackwardTransformer SAT2NAESATInfo where+  transformBackward (SAT2NAESATInfo z) m = +    SAT.restrictModel (z - 1) $+      if SAT.evalVar m z then amap not m else m++-- | Information of 'naesat2sat' conversion+type NAESAT2SATInfo = IdentityTransformer SAT.Model++-- | Convert a NAE-SAT formula φ to an equisatifiable CNF formula ψ,+-- together with a 'NAESAT2SATInfo'+naesat2sat :: NAESAT -> (CNF.CNF, NAESAT2SATInfo)+naesat2sat (n,cs) =+  ( CNF.CNF+    { CNF.cnfNumVars = n+    , CNF.cnfNumClauses = length cs * 2+    , CNF.cnfClauses = concat [[c, VG.map negate c] | c <- cs]+    }+  , IdentityTransformer+  )++-- ------------------------------------------------------------------------++-- Information of 'naesat2naeksta' conversion+data NAESAT2NAEKSATInfo = NAESAT2NAEKSATInfo !Int !Int [(SAT.Var, NAEClause, NAEClause)]+  deriving (Eq, Show, Read)++naesat2naeksat :: Int -> NAESAT -> (NAESAT, NAESAT2NAEKSATInfo)+naesat2naeksat k _ | k < 3 = error "naesat2naeksat: k must be >=3"+naesat2naeksat k (n,cs) = ((n', cs'), NAESAT2NAEKSATInfo n n' (reverse table))+  where+    (cs',(n',table)) = flip runState (n,[]) $ do+      liftM concat $ forM cs $ \c -> do+        let go c' r =+              if VG.length c' <= k then do+                return  $ reverse (c' : r)+              else do+                let (cs1, cs2) = VG.splitAt (k - 1) c'+                (i, tbl) <- get+                let w = i+1+                seq w $ put (w, (w,cs1,cs2) : tbl)+                go (VG.cons (-w) cs2) (VG.snoc cs1 w : r)+        go c []++instance Transformer NAESAT2NAEKSATInfo where+  type Source NAESAT2NAEKSATInfo = SAT.Model+  type Target NAESAT2NAEKSATInfo = SAT.Model++instance ForwardTransformer NAESAT2NAEKSATInfo where+  transformForward (NAESAT2NAEKSATInfo _n1 n2 table) m =+    array (1,n2) (go (IntMap.fromList (assocs m)) table)+    where+      go im [] = IntMap.toList im+      go im ((w,cs1,cs2) : tbl) = go (IntMap.insert w val im) tbl+        where+          ev x+            | x > 0     = im IntMap.! x+            | otherwise = not $ im IntMap.! (- x)+          needTrue  = VG.all ev cs2 || VG.all (not . ev) cs1+          needFalse = VG.all ev cs1 || VG.all (not . ev) cs2+          val+            | needTrue && needFalse = True -- error "naesat2naeksat_forward: invalid model"+            | needTrue  = True+            | needFalse = False+            | otherwise = False++instance BackwardTransformer NAESAT2NAEKSATInfo where+  transformBackward (NAESAT2NAEKSATInfo n1 _n2 _table) = SAT.restrictModel n1++-- ------------------------------------------------------------------------++type NAESAT2Max2SATInfo = ComposedTransformer NAESAT2NAEKSATInfo NAE3SAT2Max2SATInfo++naesat2max2sat :: NAESAT -> ((CNF.WCNF, Integer), NAESAT2Max2SATInfo)+naesat2max2sat x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = naesat2naeksat 3 x+    (x2, info2) = nae3sat2max2sat x1++-- ------------------------------------------------------------------------++type NAE3SAT2Max2SATInfo = IdentityTransformer SAT.Model++-- Original nae-sat problem is satisfiable iff MAX-2-SAT problem has solution with cost <=threshold.+nae3sat2max2sat :: NAESAT -> ((CNF.WCNF, Integer), NAE3SAT2Max2SATInfo)+nae3sat2max2sat (n,cs)+  | any (\c -> VG.length c < 2) cs =+      ( ( CNF.WCNF+          { CNF.wcnfTopCost = 2+          , CNF.wcnfNumVars = n+          , CNF.wcnfClauses = [(1, SAT.packClause [])]+          , CNF.wcnfNumClauses = 1+          }+        , 0+        )+      , IdentityTransformer+      )+  | otherwise =+      ( ( CNF.WCNF+          { CNF.wcnfTopCost = fromIntegral nc' + 1+          , CNF.wcnfNumVars = n+          , CNF.wcnfClauses = cs'+          , CNF.wcnfNumClauses = nc'+          }+        , t+        )+      , IdentityTransformer+      )+  where+    nc' = length cs'+    (cs', t) = foldl f ([],0) cs+      where+        f :: ([CNF.WeightedClause], Integer) -> VU.Vector SAT.Lit -> ([CNF.WeightedClause], Integer)+        f (cs, !t) c =+          case SAT.unpackClause c of+            []  -> error "nae3sat2max2sat: should not happen"+            [_] -> error "nae3sat2max2sat: should not happen"+            [_,_] ->+                ( [(1, c), (1, VG.map negate c)] ++ cs+                , t+                )+            [l0,l1,l2] ->+                ( concat [[(1, SAT.packClause [a,b]), (1, SAT.packClause [-a,-b])] | (a,b) <- [(l0,l1),(l1,l2),(l2,l0)]] ++ cs+                , t + 1+                )+            _ -> error "nae3sat2max2sat: cannot handle nae-clause of size >3"++-- ------------------------------------------------------------------------+
src/ToySolver/Converter/ObjType.hs view
@@ -15,4 +15,4 @@   ) where  data ObjType = ObjNone | ObjMaxOne | ObjMaxZero-  deriving Eq+  deriving (Eq, Ord, Enum, Bounded, Show)
+ src/ToySolver/Converter/PB.hs view
@@ -0,0 +1,674 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.PB+-- Copyright   :  (c) Masahiro Sakai 2013,2016-2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.Converter.PB+  ( module ToySolver.Converter.Base+  , module ToySolver.Converter.Tseitin++  -- * Normalization of PB/WBO problems+  , normalizePB+  , normalizeWBO++  -- * Linealization of PB/WBO problems+  , linearizePB+  , linearizeWBO+  , PBLinearizeInfo++  -- * Quadratization of PB problems+  , quadratizePB+  , quadratizePB'+  , PBQuadratizeInfo++  -- * Converting inequality constraints into equality constraints+  , inequalitiesToEqualitiesPB+  , PBInequalitiesToEqualitiesInfo++  -- * Converting constraints into penalty terms in objective function+  , unconstrainPB+  , PBUnconstrainInfo++  -- * PB↔WBO conversion+  , pb2wbo+  , PB2WBOInfo+  , wbo2pb+  , WBO2PBInfo (..)+  , addWBO++  -- * SAT↔PB conversion+  , sat2pb+  , SAT2PBInfo+  , pb2sat+  , PB2SATInfo++  -- * MaxSAT↔WBO conversion+  , maxsat2wbo+  , MaxSAT2WBOInfo+  , wbo2maxsat+  , WBO2MaxSATInfo++  -- * PB→QUBO conversion+  , pb2qubo'+  , PB2QUBOInfo'+  ) where++import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Array.IArray+import Data.Bits+import qualified Data.Foldable as F+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif+import Data.Primitive.MutVar+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.PseudoBoolean as PBFile++import ToySolver.Converter.Base+import qualified ToySolver.Converter.PB.Internal.Product as Product+import ToySolver.Converter.Tseitin+import ToySolver.Data.BoolExpr+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import qualified ToySolver.SAT.Encoder.PB as PB+import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC+import ToySolver.SAT.Store.CNF+import ToySolver.SAT.Store.PB++-- -----------------------------------------------------------------------------++-- XXX: we do not normalize objective function, because normalization might+-- introduce constant terms, but OPB file format does not allow constant terms.+--+-- Options:+-- (1) not normalize objective function (current implementation),+-- (2) normalize and simply delete constant terms (in pseudo-boolean package?),+-- (3) normalize and introduce dummy variable to make constant terms+--     into non-constant terms (in pseudo-boolean package?).+normalizePB :: PBFile.Formula -> PBFile.Formula+normalizePB formula =+  formula+  { PBFile.pbConstraints =+      map normalizePBConstraint (PBFile.pbConstraints formula)+  }++normalizeWBO :: PBFile.SoftFormula -> PBFile.SoftFormula+normalizeWBO formula =+  formula+  { PBFile.wboConstraints =+      map (\(w,constr) -> (w, normalizePBConstraint constr)) (PBFile.wboConstraints formula)+  }++normalizePBConstraint :: PBFile.Constraint -> PBFile.Constraint+normalizePBConstraint (lhs,op,rhs) =+  case mapAccumL h 0 lhs of+    (offset, lhs') -> (lhs', op, rhs - offset)+  where+    h s (w,[x]) | x < 0 = (s+w, (-w,[-x]))+    h s t = (s,t)++-- -----------------------------------------------------------------------------++type PBLinearizeInfo = TseitinInfo++linearizePB :: PBFile.Formula -> Bool -> (PBFile.Formula, PBLinearizeInfo)+linearizePB formula usePB = runST $ do+  db <- newPBStore+  SAT.newVars_ db (PBFile.pbNumVars formula)+  tseitin <-  Tseitin.newEncoderWithPBLin db+  Tseitin.setUsePB tseitin usePB+  pbnlc <- PBNLC.newEncoder db tseitin+  cs' <- forM (PBFile.pbConstraints formula) $ \(lhs,op,rhs) -> do+    let p = case op of+              PBFile.Ge -> Tseitin.polarityPos+              PBFile.Eq -> Tseitin.polarityBoth+    lhs' <- PBNLC.linearizePBSumWithPolarity pbnlc p lhs+    return ([(c,[l]) | (c,l) <- lhs'],op,rhs)+  obj' <-+    case PBFile.pbObjectiveFunction formula of+      Nothing -> return Nothing+      Just obj -> do+        obj' <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityNeg obj+        return $ Just [(c, [l]) | (c,l) <- obj']+  formula' <- getPBFormula db+  defs <- Tseitin.getDefinitions tseitin+  return $+    ( formula'+      { PBFile.pbObjectiveFunction = obj'+      , PBFile.pbConstraints = cs' ++ PBFile.pbConstraints formula'+      , PBFile.pbNumConstraints = PBFile.pbNumConstraints formula + PBFile.pbNumConstraints formula'+      }+    , TseitinInfo (PBFile.pbNumVars formula) (PBFile.pbNumVars formula') defs+    )++-- -----------------------------------------------------------------------------++linearizeWBO :: PBFile.SoftFormula -> Bool -> (PBFile.SoftFormula, PBLinearizeInfo)+linearizeWBO formula usePB = runST $ do+  db <- newPBStore+  SAT.newVars_ db (PBFile.wboNumVars formula)+  tseitin <-  Tseitin.newEncoderWithPBLin db+  Tseitin.setUsePB tseitin usePB+  pbnlc <- PBNLC.newEncoder db tseitin+  cs' <- forM (PBFile.wboConstraints formula) $ \(cost,(lhs,op,rhs)) -> do+    let p = case op of+              PBFile.Ge -> Tseitin.polarityPos+              PBFile.Eq -> Tseitin.polarityBoth+    lhs' <- PBNLC.linearizePBSumWithPolarity pbnlc p lhs+    return (cost,([(c,[l]) | (c,l) <- lhs'],op,rhs))+  formula' <- getPBFormula db+  defs <- Tseitin.getDefinitions tseitin+  return $+    ( PBFile.SoftFormula+      { PBFile.wboTopCost = PBFile.wboTopCost formula+      , PBFile.wboConstraints = cs' ++ [(Nothing, constr) | constr <- PBFile.pbConstraints formula']+      , PBFile.wboNumVars = PBFile.pbNumVars formula'+      , PBFile.wboNumConstraints = PBFile.wboNumConstraints formula + PBFile.pbNumConstraints formula'+      }+    , TseitinInfo (PBFile.wboNumVars formula) (PBFile.pbNumVars formula') defs+    )++-- -----------------------------------------------------------------------------++-- | Quandratize PBO/PBS problem without introducing additional constraints.+quadratizePB :: PBFile.Formula -> ((PBFile.Formula, Integer), PBQuadratizeInfo)+quadratizePB formula = quadratizePB' (formula, SAT.pbUpperBound obj)+  where+    obj = fromMaybe [] $ PBFile.pbObjectiveFunction formula++-- | Quandratize PBO/PBS problem without introducing additional constraints.+quadratizePB' :: (PBFile.Formula, Integer) -> ((PBFile.Formula, Integer), PBQuadratizeInfo)+quadratizePB' (formula, maxObj) =+  ( ( PBFile.Formula+      { PBFile.pbObjectiveFunction = Just $ conv obj ++ penalty+      , PBFile.pbConstraints = [(conv lhs, op, rhs) | (lhs,op,rhs) <- PBFile.pbConstraints formula]+      , PBFile.pbNumVars = nv2+      , PBFile.pbNumConstraints = PBFile.pbNumConstraints formula+      }+    , maxObj+    )+  , PBQuadratizeInfo $ TseitinInfo nv1 nv2 [(v, And [Atom l1, Atom l2]) | (v, (l1,l2)) <- prodDefs]+  )+  where+    nv1 = PBFile.pbNumVars formula+    nv2 = PBFile.pbNumVars formula + Set.size termsToReplace++    degGe3Terms :: Set IntSet+    degGe3Terms = collectDegGe3Terms formula+ +    m :: Map IntSet (IntSet,IntSet)+    m = Product.decomposeToBinaryProducts degGe3Terms++    termsToReplace :: Set IntSet+    termsToReplace = go ts0 Set.empty+      where+        ts0 = concat [[t1,t2] | t <- Set.toList degGe3Terms, let (t1,t2) = m Map.! t]+        go [] !ret = ret+        go (t : ts) !ret+          | IntSet.size t < 2  = go ts ret+          | t `Set.member` ret = go ts ret+          | otherwise =+              case Map.lookup t m of+                Nothing -> error "quadratizePB.termsToReplace: should not happen"+                Just (t1,t2) -> go (t1 : t2 : ts) (Set.insert t ret)++    fromV :: IntMap IntSet+    toV :: Map IntSet Int+    (fromV, toV) = (IntMap.fromList l, Map.fromList [(s,v) | (v,s) <- l])+      where+        l = zip [PBFile.pbNumVars formula + 1 ..] (Set.toList termsToReplace)++    prodDefs :: [(SAT.Var, (SAT.Var, SAT.Var))]+    prodDefs = [(v, (f t1, f t2)) | (v,t) <- IntMap.toList fromV, let (t1,t2) = m Map.! t]+      where+        f t+          | IntSet.size t == 1 = head (IntSet.toList t)+          | otherwise = +               case Map.lookup t toV of+                 Nothing -> error "quadratizePB.prodDefs: should not happen"+                 Just v -> v++    obj :: PBFile.Sum+    obj = fromMaybe [] $ PBFile.pbObjectiveFunction formula++    minObj :: Integer+    minObj = SAT.pbLowerBound obj++    penalty :: PBFile.Sum+    penalty = [(w * w2, ts) | (w,ts) <- concat [p x y z | (z,(x,y)) <- prodDefs]]+      where+        -- The penalty function P(x,y,z) = xy − 2xz − 2yz + 3z is such that+        -- P(x,y,z)=0 when z⇔xy and P(x,y,z)>0 when z⇎xy.+        p x y z = [(1,[x,y]), (-2,[x,z]), (-2,[y,z]), (3,[z])]+        w2 = max (maxObj - minObj) 0 + 1++    conv :: PBFile.Sum -> PBFile.Sum+    conv s = [(w, f t) | (w,t) <- s]+      where+        f t =+          case Map.lookup t' toV of+            Just v  -> [v]+            Nothing+              | IntSet.size t' >= 3 -> map g [t1, t2]+              | otherwise -> t+          where+            t' = IntSet.fromList t+            (t1, t2) = m Map.! t'+        g t+          | IntSet.size t == 1 = head $ IntSet.toList t+          | otherwise = toV Map.! t+++collectDegGe3Terms :: PBFile.Formula -> Set IntSet+collectDegGe3Terms formula = Set.fromList [t' | t <- terms, let t' = IntSet.fromList t, IntSet.size t' >= 3]+  where+    sums = maybeToList (PBFile.pbObjectiveFunction formula) +++           [lhs | (lhs,_,_) <- PBFile.pbConstraints formula]+    terms = [t | s <- sums, (_,t) <- s]++newtype PBQuadratizeInfo = PBQuadratizeInfo TseitinInfo+  deriving (Eq, Show)++instance Transformer PBQuadratizeInfo where+  type Source PBQuadratizeInfo = SAT.Model+  type Target PBQuadratizeInfo = SAT.Model++instance ForwardTransformer PBQuadratizeInfo where+  transformForward (PBQuadratizeInfo info) = transformForward info++instance BackwardTransformer PBQuadratizeInfo where+  transformBackward (PBQuadratizeInfo info) = transformBackward info++instance ObjValueTransformer PBQuadratizeInfo where+  type SourceObjValue PBQuadratizeInfo = Integer+  type TargetObjValue PBQuadratizeInfo = Integer++instance ObjValueForwardTransformer PBQuadratizeInfo where+  transformObjValueForward _ = id++instance ObjValueBackwardTransformer PBQuadratizeInfo where+  transformObjValueBackward _ = id++-- -----------------------------------------------------------------------------++-- | Convert inequality constraints into equality constraints by introducing surpass variables.+inequalitiesToEqualitiesPB :: PBFile.Formula -> (PBFile.Formula, PBInequalitiesToEqualitiesInfo)+inequalitiesToEqualitiesPB formula = runST $ do+  db <- newPBStore+  SAT.newVars_ db (PBFile.pbNumVars formula)++  defs <- liftM catMaybes $ forM (PBFile.pbConstraints formula) $ \constr -> do+    case constr of+      (lhs, PBFile.Eq, rhs) -> do+        SAT.addPBNLExactly db lhs rhs+        return Nothing+      (lhs, PBFile.Ge, rhs) -> do+        case asClause (lhs,rhs) of+          Just clause -> do+            SAT.addPBNLExactly db [(1, [- l | l <- clause])] 0+            return Nothing+          Nothing -> do+            let maxSurpass = max (SAT.pbUpperBound lhs - rhs) 0+                maxSurpassNBits = head [i | i <- [0..], maxSurpass < bit i]+            vs <- SAT.newVars db maxSurpassNBits+            SAT.addPBNLExactly db (lhs ++ [(-c,[x]) | (c,x) <- zip (iterate (*2) 1) vs]) rhs+            if maxSurpassNBits > 0 then do+              return $ Just (lhs, rhs, vs)+            else+              return Nothing++  formula' <- getPBFormula db+  return+    ( formula'{ PBFile.pbObjectiveFunction = PBFile.pbObjectiveFunction formula }+    , PBInequalitiesToEqualitiesInfo (PBFile.pbNumVars formula) (PBFile.pbNumVars formula') defs+    )+  where+    asLinSum :: SAT.PBSum -> Maybe (SAT.PBLinSum, Integer)+    asLinSum s = do+      ret <- forM s $ \(c, ls) -> do+        case ls of+          [] -> return (Nothing, c)+          [l] -> return (Just (c,l), 0)+          _ -> mzero+      return (catMaybes (map fst ret), sum (map snd ret))++    asClause :: (SAT.PBSum, Integer) -> Maybe SAT.Clause+    asClause (lhs, rhs) = do+      (lhs', off) <- asLinSum lhs+      let rhs' = rhs - off+      case SAT.normalizePBLinAtLeast (lhs', rhs') of+        (lhs'', 1) | all (\(c,_) -> c == 1) lhs'' -> return (map snd lhs'')+        _ -> mzero++data PBInequalitiesToEqualitiesInfo+  = PBInequalitiesToEqualitiesInfo !Int !Int [(PBFile.Sum, Integer, [SAT.Var])]+  deriving (Eq, Show)++instance Transformer PBInequalitiesToEqualitiesInfo where+  type Source PBInequalitiesToEqualitiesInfo = SAT.Model+  type Target PBInequalitiesToEqualitiesInfo = SAT.Model++instance ForwardTransformer PBInequalitiesToEqualitiesInfo where+  transformForward (PBInequalitiesToEqualitiesInfo _nv1 nv2 defs) m =+    array (1, nv2) $ assocs m ++ [(v, testBit n i) | (lhs, rhs, vs) <- defs, let n = SAT.evalPBSum m lhs - rhs, (i,v) <- zip [0..] vs]++instance BackwardTransformer PBInequalitiesToEqualitiesInfo where+  transformBackward (PBInequalitiesToEqualitiesInfo nv1 _nv2 _defs) = SAT.restrictModel nv1++instance ObjValueTransformer PBInequalitiesToEqualitiesInfo where+  type SourceObjValue PBInequalitiesToEqualitiesInfo = Integer+  type TargetObjValue PBInequalitiesToEqualitiesInfo = Integer++instance ObjValueForwardTransformer PBInequalitiesToEqualitiesInfo where+  transformObjValueForward _ = id++instance ObjValueBackwardTransformer PBInequalitiesToEqualitiesInfo where+  transformObjValueBackward _ = id++-- -----------------------------------------------------------------------------++unconstrainPB :: PBFile.Formula -> ((PBFile.Formula, Integer), PBUnconstrainInfo)+unconstrainPB formula = (unconstrainPB' formula', PBUnconstrainInfo info)+  where+    (formula', info) = inequalitiesToEqualitiesPB formula++newtype PBUnconstrainInfo = PBUnconstrainInfo PBInequalitiesToEqualitiesInfo+  deriving (Eq, Show)++instance Transformer PBUnconstrainInfo where+  -- type Source PBUnconstrainInfo = Source PBInequalitiesToEqualitiesInfo+  type Source PBUnconstrainInfo = SAT.Model+  -- type Target PBUnconstrainInfo = Target PBInequalitiesToEqualitiesInfo+  type Target PBUnconstrainInfo = SAT.Model++instance ForwardTransformer PBUnconstrainInfo where+  transformForward (PBUnconstrainInfo info) = transformForward info++instance BackwardTransformer PBUnconstrainInfo where+  transformBackward (PBUnconstrainInfo info) = transformBackward info++instance ObjValueTransformer PBUnconstrainInfo where+  -- type SourceObjValue PBUnconstrainInfo = SourceObjValue PBInequalitiesToEqualitiesInfo+  type SourceObjValue PBUnconstrainInfo = Integer+  -- type TargetObjValue PBUnconstrainInfo = TargetObjValue PBInequalitiesToEqualitiesInfo+  type TargetObjValue PBUnconstrainInfo = Integer++instance ObjValueForwardTransformer PBUnconstrainInfo where+  transformObjValueForward (PBUnconstrainInfo info) = transformObjValueForward info++instance ObjValueBackwardTransformer PBUnconstrainInfo where+  transformObjValueBackward (PBUnconstrainInfo info) = transformObjValueBackward info++unconstrainPB' :: PBFile.Formula -> (PBFile.Formula, Integer)+unconstrainPB' formula =+  ( formula+    { PBFile.pbObjectiveFunction = Just $ obj1 ++ obj2+    , PBFile.pbConstraints = []+    , PBFile.pbNumConstraints = 0+    }+  , obj1ub+  )+  where+    obj1 = fromMaybe [] (PBFile.pbObjectiveFunction formula)+    obj1ub = SAT.pbUpperBound obj1+    obj1lb = SAT.pbLowerBound obj1+    p = obj1ub - obj1lb + 1+    obj2 = [(p*c, IntSet.toList ls) | (ls, c) <- Map.toList obj2', c /= 0]+    obj2' = Map.unionsWith (+) [sq ((-rhs, []) : lhs) | (lhs, PBFile.Eq, rhs) <- PBFile.pbConstraints formula]+    sq ts = Map.fromListWith (+) $ do+              (c1,ls1) <- ts+              (c2,ls2) <- ts+              let ls3 = IntSet.fromList ls1 `IntSet.union` IntSet.fromList ls2+              guard $ not $ isFalse ls3+              return (ls3, c1*c2)+    isFalse ls = not $ IntSet.null $ ls `IntSet.intersection` IntSet.map negate ls++-- -----------------------------------------------------------------------------++pb2qubo' :: PBFile.Formula -> ((PBFile.Formula, Integer), PB2QUBOInfo')+pb2qubo' formula = ((formula2, th2), ComposedTransformer info1 info2)+  where+    ((formula1, th1), info1) = unconstrainPB formula+    ((formula2, th2), info2) = quadratizePB' (formula1, th1)++type PB2QUBOInfo' = ComposedTransformer PBUnconstrainInfo PBQuadratizeInfo++-- -----------------------------------------------------------------------------++type PB2WBOInfo = IdentityTransformer SAT.Model++pb2wbo :: PBFile.Formula -> (PBFile.SoftFormula, PB2WBOInfo)+pb2wbo formula+  = ( PBFile.SoftFormula+      { PBFile.wboTopCost = Nothing+      , PBFile.wboConstraints = cs1 ++ cs2+      , PBFile.wboNumVars = PBFile.pbNumVars formula+      , PBFile.wboNumConstraints = PBFile.pbNumConstraints formula + length cs2+      }+    , IdentityTransformer+    )+  where+    cs1 = [(Nothing, c) | c <- PBFile.pbConstraints formula]+    cs2 = case PBFile.pbObjectiveFunction formula of+            Nothing -> []+            Just e  ->+              [ if w >= 0+                then (Just w,       ([(-1,ls)], PBFile.Ge, 0))+                else (Just (abs w), ([(1,ls)],  PBFile.Ge, 1))+              | (w,ls) <- e+              ]++wbo2pb :: PBFile.SoftFormula -> (PBFile.Formula, WBO2PBInfo)+wbo2pb wbo = runST $ do+  let nv = PBFile.wboNumVars wbo+  db <- newPBStore+  (obj, defs) <- addWBO db wbo +  formula <- getPBFormula db+  return+    ( formula{ PBFile.pbObjectiveFunction = Just obj }+    , WBO2PBInfo nv (PBFile.pbNumVars formula) defs+    )++data WBO2PBInfo = WBO2PBInfo !Int !Int [(SAT.Var, PBFile.Constraint)]+  deriving (Eq, Show)++instance Transformer WBO2PBInfo where+  type Source WBO2PBInfo = SAT.Model+  type Target WBO2PBInfo = SAT.Model++instance ForwardTransformer WBO2PBInfo where+  transformForward (WBO2PBInfo _nv1 nv2 defs) m =+    array (1, nv2) $ assocs m ++ [(v, SAT.evalPBConstraint m constr) | (v, constr) <- defs]++instance BackwardTransformer WBO2PBInfo where+  transformBackward (WBO2PBInfo nv1 _nv2 _defs) = SAT.restrictModel nv1++addWBO :: (PrimMonad m, SAT.AddPBNL m enc) => enc -> PBFile.SoftFormula -> m (SAT.PBSum, [(SAT.Var, PBFile.Constraint)])+addWBO db wbo = do+  SAT.newVars_ db $ PBFile.wboNumVars wbo++  objRef <- newMutVar []+  defsRef <- newMutVar []+  forM_ (PBFile.wboConstraints wbo) $ \(cost, constr@(lhs,op,rhs)) -> do+    case cost of+      Nothing -> do+        case op of+          PBFile.Ge -> SAT.addPBNLAtLeast db lhs rhs+          PBFile.Eq -> SAT.addPBNLExactly db lhs rhs+      Just w -> do+        case op of+          PBFile.Ge -> do+            case lhs of+              [(1,ls)] | rhs == 1 -> do+                -- ∧L ≥ 1 ⇔ ∧L+                -- obj += w * (1 - ∧L)+                modifyMutVar objRef (\obj -> (w,[]) : (-w,ls) : obj)+              [(-1,ls)] | rhs == 0 -> do+                -- -1*∧L ≥ 0 ⇔ (1 - ∧L) ≥ 1 ⇔ ￢∧L+                -- obj += w * ∧L+                modifyMutVar objRef ((w,ls) :)+              _ | and [c==1 && length ls == 1 | (c,ls) <- lhs] && rhs == 1 -> do+                -- ∑L ≥ 1 ⇔ ∨L ⇔ ￢∧￢L+                -- obj += w * ∧￢L+                modifyMutVar objRef ((w, [-l | (_,[l]) <- lhs]) :)+              _ -> do+                sel <- SAT.newVar db+                SAT.addPBNLAtLeastSoft db sel lhs rhs+                modifyMutVar objRef ((w,[-sel]) :)+                modifyMutVar defsRef ((sel,constr) :)+          PBFile.Eq -> do+            sel <- SAT.newVar db+            SAT.addPBNLExactlySoft db sel lhs rhs+            modifyMutVar objRef ((w,[-sel]) :)+            modifyMutVar defsRef ((sel,constr) :)+  obj <- liftM reverse $ readMutVar objRef+  defs <- liftM reverse $ readMutVar defsRef++  case PBFile.wboTopCost wbo of+    Nothing -> return ()+    Just t -> SAT.addPBNLAtMost db obj (t - 1)++  return (obj, defs)++-- -----------------------------------------------------------------------------++type SAT2PBInfo = IdentityTransformer SAT.Model++sat2pb :: CNF.CNF -> (PBFile.Formula, SAT2PBInfo)+sat2pb cnf+  = ( PBFile.Formula+      { PBFile.pbObjectiveFunction = Nothing+      , PBFile.pbConstraints = map f (CNF.cnfClauses cnf)+      , PBFile.pbNumVars = CNF.cnfNumVars cnf+      , PBFile.pbNumConstraints = CNF.cnfNumClauses cnf+      }+    , IdentityTransformer+    )+  where+    f clause = ([(1,[l]) | l <- SAT.unpackClause clause], PBFile.Ge, 1)++type PB2SATInfo = TseitinInfo++-- | Convert a pseudo boolean formula φ to a equisatisfiable CNF formula ψ+-- together with two functions f and g such that:+--+-- * if M ⊨ φ then f(M) ⊨ ψ+--+-- * if M ⊨ ψ then g(M) ⊨ φ+-- +pb2sat :: PBFile.Formula -> (CNF.CNF, PB2SATInfo)+pb2sat formula = runST $ do+  db <- newCNFStore+  let nv1 = PBFile.pbNumVars formula+  SAT.newVars_ db nv1+  tseitin <-  Tseitin.newEncoder db+  pb <- PB.newEncoder tseitin+  pbnlc <- PBNLC.newEncoder pb tseitin+  forM_ (PBFile.pbConstraints formula) $ \(lhs,op,rhs) -> do+    case op of+      PBFile.Ge -> SAT.addPBNLAtLeast pbnlc lhs rhs+      PBFile.Eq -> SAT.addPBNLExactly pbnlc lhs rhs+  cnf <- getCNFFormula db+  defs <- Tseitin.getDefinitions tseitin+  return (cnf, TseitinInfo nv1 (CNF.cnfNumVars cnf) defs)++-- -----------------------------------------------------------------------------++type MaxSAT2WBOInfo = IdentityTransformer SAT.Model++maxsat2wbo :: CNF.WCNF -> (PBFile.SoftFormula, MaxSAT2WBOInfo)+maxsat2wbo+  CNF.WCNF+  { CNF.wcnfTopCost = top+  , CNF.wcnfClauses = cs+  , CNF.wcnfNumVars = nv+  , CNF.wcnfNumClauses = nc+  } =+  ( PBFile.SoftFormula+    { PBFile.wboTopCost = Nothing+    , PBFile.wboConstraints = map f cs+    , PBFile.wboNumVars = nv+    , PBFile.wboNumConstraints = nc+    }+  , IdentityTransformer+  )+  where+    f (w,c)+     | w>=top    = (Nothing, p) -- hard constraint+     | otherwise = (Just w, p)  -- soft constraint+     where+       p = ([(1,[l]) | l <- SAT.unpackClause c], PBFile.Ge, 1)++type WBO2MaxSATInfo = TseitinInfo++wbo2maxsat :: PBFile.SoftFormula -> (CNF.WCNF, WBO2MaxSATInfo)+wbo2maxsat formula = runST $ do+  db <- newCNFStore+  SAT.newVars_ db (PBFile.wboNumVars formula)+  tseitin <-  Tseitin.newEncoder db+  pb <- PB.newEncoder tseitin+  pbnlc <- PBNLC.newEncoder pb tseitin++  softClauses <- liftM mconcat $ forM (PBFile.wboConstraints formula) $ \(cost, (lhs,op,rhs)) -> do+    case cost of+      Nothing ->+        case op of+          PBFile.Ge -> SAT.addPBNLAtLeast pbnlc lhs rhs >> return mempty+          PBFile.Eq -> SAT.addPBNLExactly pbnlc lhs rhs >> return mempty+      Just c -> do+        case op of+          PBFile.Ge -> do+            lhs2 <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityPos lhs+            let (lhs3,rhs3) = SAT.normalizePBLinAtLeast (lhs2,rhs)+            if rhs3==1 && and [c==1 | (c,_) <- lhs3] then+              return $ Seq.singleton (c, SAT.packClause [l | (_,l) <- lhs3])+            else do+              lit <- PB.encodePBLinAtLeast pb (lhs3,rhs3)+              return $ Seq.singleton (c, SAT.packClause [lit])+          PBFile.Eq -> do+            lhs2 <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityBoth lhs+            lit1 <- PB.encodePBLinAtLeast pb (lhs2, rhs)+            lit2 <- PB.encodePBLinAtLeast pb ([(-c, l) | (c,l) <- lhs2], negate rhs)+            lit <- Tseitin.encodeConjWithPolarity tseitin Tseitin.polarityPos [lit1,lit2]+            return $ Seq.singleton (c, SAT.packClause [lit])++  case PBFile.wboTopCost formula of+    Nothing -> return ()+    Just top -> SAT.addPBNLAtMost pbnlc [(c, [-l | l <- SAT.unpackClause clause]) | (c,clause) <- F.toList softClauses] (top - 1)++  let top = F.sum (fst <$> softClauses) + 1+  cnf <- getCNFFormula db+  let cs = softClauses <> Seq.fromList [(top, clause) | clause <- CNF.cnfClauses cnf]+  let wcnf = CNF.WCNF+             { CNF.wcnfNumVars = CNF.cnfNumVars cnf+             , CNF.wcnfNumClauses = Seq.length cs+             , CNF.wcnfTopCost = top+             , CNF.wcnfClauses = F.toList cs+             }+  defs <- Tseitin.getDefinitions tseitin+  return (wcnf, TseitinInfo (PBFile.wboNumVars formula) (CNF.cnfNumVars cnf) defs)++-- -----------------------------------------------------------------------------
+ src/ToySolver/Converter/PB/Internal/LargestIntersectionFinder.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS -Wall #-}+module ToySolver.Converter.PB.Internal.LargestIntersectionFinder+  ( Table+  , empty+  , fromSet+  , fromList+  , toSet+  , toList+  , insert+  , findLargestIntersectionSet+  ) where++import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List hiding (insert)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Monoid+import Data.Ord+import Data.Set (Set)+import qualified Data.Set as Set++data Table+  = Table+  { numSets   :: !Int+  , toSetId   :: Map IntSet SetId+  , fromSetId :: IntMap IntSet+  , invMember :: IntMap (IntMap Count) -- e ↦ {s ↦ 1 | e∈s}+  }+  deriving (Show)++type SetId = Int+type Count = Int++empty :: Table+empty =+  Table+  { numSets   = 0+  , toSetId   = Map.empty+  , fromSetId = IntMap.empty+  , invMember = IntMap.empty+  }++fromList :: [IntSet] -> Table+fromList = fromSet . Set.fromList++fromSet :: Set IntSet -> Table+fromSet ss =+  Table+  { numSets   = Set.size ss+  , toSetId   = Map.fromList [(s,i) | (i,s) <- l]+  , fromSetId = IntMap.fromList l+  , invMember =+      IntMap.unionsWith IntMap.union+        [ IntMap.fromAscList [(e, IntMap.singleton i 1) | e <- IntSet.toAscList s]+        | (i,s) <- l+        ]+  }+  where+    l = zip [0..] (Set.toList ss)++toSet :: Table -> Set IntSet+toSet = Map.keysSet . toSetId++toList :: Table -> [IntSet]+toList = Set.toList . toSet++insert :: IntSet -> Table -> Table+insert s t+  | s `Map.member` toSetId t = t+  | otherwise =+      t+      { numSets = n + 1+      , toSetId = Map.insert s n (toSetId t)+      , fromSetId = IntMap.insert n s (fromSetId t)+      , invMember =+          IntMap.unionWith IntMap.union+            (IntMap.fromAscList [(e, IntMap.singleton n 1) | e <- IntSet.toAscList s])+            (invMember t)+      }+  where+    n = numSets t++-- | Given a set S and a family of sets U, find a T∈S such that S∩T has maximum cardinality.+-- In case of tie, smaller T is preferred.+findLargestIntersectionSet :: IntSet -> Table -> Maybe IntSet+findLargestIntersectionSet s t+  | IntMap.null m =+      if IntSet.empty `Map.member` toSetId t+      then Just IntSet.empty+      else Nothing+  | otherwise = Just $! fromSetId t IntMap.! n+  where+    m :: IntMap Count+    m = IntMap.unionsWith (+) [IntMap.findWithDefault IntMap.empty e (invMember t) | e <- IntSet.toList s]+    (n,_,_) = maximumBy (comparing (\(_,c,_) -> c) <> flip (comparing (\(_,_,size) -> size))) $+                [(i, c, IntSet.size (fromSetId t IntMap.! i)) | (i,c) <- IntMap.toList m]
+ src/ToySolver/Converter/PB/Internal/Product.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -Wall #-}+module ToySolver.Converter.PB.Internal.Product+  ( decomposeToBinaryProducts+  ) where++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List hiding (insert)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Ord+import Data.Set (Set)+import qualified Data.Set as Set++import qualified ToySolver.Converter.PB.Internal.LargestIntersectionFinder as LargestIntersectionFinder++decomposeToBinaryProducts :: Set IntSet -> Map IntSet (IntSet,IntSet)+decomposeToBinaryProducts = decompose2 . decompose1++decompose1 :: Set IntSet -> Map IntSet (Maybe (IntSet,IntSet))+decompose1 ss = snd $ foldl' (flip f) (LargestIntersectionFinder.empty, Map.empty) ss'+  where+    ss' = map fst $ sortBy (comparing snd) [(s, IntSet.size s) | s <- Set.toList ss]++    f :: IntSet+      -> (LargestIntersectionFinder.Table, Map IntSet (Maybe (IntSet,IntSet)))+      -> (LargestIntersectionFinder.Table, Map IntSet (Maybe (IntSet,IntSet)))+    f s (t,r) | IntSet.size s < 2 || s `Map.member` r = (t,r)+    f s (t,r) =+      case LargestIntersectionFinder.findLargestIntersectionSet s t of+        Nothing ->+          ( LargestIntersectionFinder.insert s t+          , Map.insert s Nothing r+          )+        Just s0 ->+          let s1 = s `IntSet.intersection` s0+              s2 = s IntSet.\\ s1+           in if IntSet.size s1 < 2 && IntSet.size s2 < 2 then+                ( LargestIntersectionFinder.insert s t+                , Map.insert s Nothing r+                )+              else if IntSet.null s2 then -- i.e. s⊆s0+                case Map.lookup s0 r of+                  Nothing -> error "should not happen"+                  Just Nothing -> +                    let s3 = s0 IntSet.\\ s+                     in ( LargestIntersectionFinder.insert s3 $ LargestIntersectionFinder.insert s t+                        , -- union is left-biased+                          Map.insert s0 (Just (s, s3)) $+                            Map.union r (Map.fromList $ filter (\(s',_) -> IntSet.size s' >= 2) [(s, Nothing), (s3, Nothing)])+                        )+                  Just _ ->+                    ( LargestIntersectionFinder.insert s t+                    , Map.union r (Map.singleton s Nothing)+                    )+              else+                case f s2 (f s1 (t,r))  of+                   (t',r') ->+                     ( LargestIntersectionFinder.insert s t'+                     , Map.insert s (Just (s1,s2)) r'+                     )++decompose2 :: Map IntSet (Maybe (IntSet,IntSet)) -> Map IntSet (IntSet,IntSet)+decompose2 m = Map.fromList $ do+  (s,d) <- Map.toList m+  case d of+    Just (s1,s2) -> return (s, (s1,s2))+    Nothing -> f (IntSet.toList s) (IntSet.size s)+  where+    f s n+      | n < 2  = []+      | n == 2 = return (IntSet.fromList s, (IntSet.singleton (s !! 0), IntSet.singleton (s !! 1)))+      | otherwise =+          case splitAt (n `div` 2) s  of+            (s1, s2) -> (IntSet.fromList s, (IntSet.fromList s1, IntSet.fromList s2)) : f s1 (n `div` 2) ++ f s2 (n - (n `div` 2))
src/ToySolver/Converter/PB2IP.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Converter.PB2IP@@ -7,12 +8,19 @@ --  -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  experimental--- Portability :  portable+-- Portability :  non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.PB2IP-  ( convert-  , convertWBO+  ( pb2ip+  , PB2IPInfo+  , wbo2ip+  , WBO2IPInfo++  , sat2ip+  , SAT2IPInfo+  , maxsat2ip+  , MaxSAT2IPInfo     ) where  import Data.Array.IArray@@ -22,12 +30,31 @@ import qualified Data.Map as Map  import qualified Data.PseudoBoolean as PBFile+import ToySolver.Converter.Base+import ToySolver.Converter.PB import qualified ToySolver.Data.MIP as MIP import ToySolver.Data.MIP ((.==.), (.<=.), (.>=.))+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT -convert :: PBFile.Formula -> (MIP.Problem Integer, SAT.Model -> Map MIP.Var Rational, Map MIP.Var Rational -> SAT.Model)-convert formula = (mip, mforth, mtrans (PBFile.pbNumVars formula))+-- -----------------------------------------------------------------------------++newtype PB2IPInfo = PB2IPInfo Int+  deriving (Eq, Show, Read)++instance Transformer PB2IPInfo where+  type Source PB2IPInfo = SAT.Model+  type Target PB2IPInfo = Map MIP.Var Rational++instance ForwardTransformer PB2IPInfo where+  transformForward _ m =+    Map.fromList [(convVar v, if val then 1 else 0) | (v,val) <- assocs m]++instance BackwardTransformer PB2IPInfo where+  transformBackward (PB2IPInfo nv) = mtrans nv++pb2ip :: PBFile.Formula -> (MIP.Problem Integer, PB2IPInfo)+pb2ip formula = (mip, PB2IPInfo (PBFile.pbNumVars formula))   where     mip = def       { MIP.objectiveFunction = obj2@@ -51,8 +78,6 @@         PBFile.Ge -> def{ MIP.constrExpr = lhs2, MIP.constrLB = MIP.Finite rhs2 }         PBFile.Eq -> def{ MIP.constrExpr = lhs2, MIP.constrLB = MIP.Finite rhs2, MIP.constrUB = MIP.Finite rhs2 } -    mforth :: SAT.Model -> Map MIP.Var Rational-    mforth m = Map.fromList [(convVar v, if val then 1 else 0) | (v,val) <- assocs m]  convExpr :: PBFile.Sum -> MIP.Expr Integer convExpr s = sum [product (fromIntegral w : map f tm) | (w,tm) <- s]@@ -65,8 +90,26 @@ convVar :: PBFile.Var -> MIP.Var convVar x = MIP.toVar ("x" ++ show x) -convertWBO :: Bool -> PBFile.SoftFormula -> (MIP.Problem Integer, SAT.Model -> Map MIP.Var Rational, Map MIP.Var Rational -> SAT.Model)-convertWBO useIndicator formula = (mip, mforth, mtrans (PBFile.wboNumVars formula))+-- -----------------------------------------------------------------------------++data WBO2IPInfo = WBO2IPInfo !Int [(MIP.Var, PBFile.SoftConstraint)]+  deriving (Eq, Show)++instance Transformer WBO2IPInfo where+  type Source WBO2IPInfo = SAT.Model+  type Target WBO2IPInfo = Map MIP.Var Rational++instance ForwardTransformer WBO2IPInfo where+  transformForward (WBO2IPInfo _nv relaxVariables) m = Map.union m1 m2+      where+        m1 = Map.fromList $ [(convVar v, if val then 1 else 0) | (v,val) <- assocs m]+        m2 = Map.fromList $ [(v, if SAT.evalPBConstraint m c then 0 else 1) | (v, (Just _, c)) <- relaxVariables]++instance BackwardTransformer WBO2IPInfo where+  transformBackward (WBO2IPInfo nv _relaxVariables) = mtrans nv++wbo2ip :: Bool -> PBFile.SoftFormula -> (MIP.Problem Integer, WBO2IPInfo)+wbo2ip useIndicator formula = (mip, WBO2IPInfo (PBFile.wboNumVars formula) relaxVariables)   where     mip = def       { MIP.objectiveFunction = obj2@@ -118,12 +161,6 @@                  c2 = lhsLE .<=. MIP.constExpr rhsLE              [ (ts, c1), ([], c2) ] -    mforth :: SAT.Model -> Map MIP.Var Rational-    mforth m = Map.union m1 m2-      where-        m1 = Map.fromList $ [(convVar v, if val then 1 else 0) | (v,val) <- assocs m]-        m2 = Map.fromList $ [(v, if SAT.evalPBConstraint m c then 0 else 1) | (v, (Just _, c)) <- relaxVariables]- splitConst :: MIP.Expr Integer -> (MIP.Expr Integer, Integer) splitConst e = (e2, c)   where@@ -151,3 +188,23 @@               1  -> True               v0 -> error (show v0 ++ " is neither 0 nor 1")     ]++-- -----------------------------------------------------------------------------++type SAT2IPInfo = ComposedTransformer SAT2PBInfo PB2IPInfo++sat2ip :: CNF.CNF -> (MIP.Problem Integer, SAT2IPInfo)+sat2ip cnf = (ip, ComposedTransformer info1 info2)+  where+    (pb,info1) = sat2pb cnf+    (ip,info2) = pb2ip pb++type MaxSAT2IPInfo = ComposedTransformer MaxSAT2WBOInfo WBO2IPInfo++maxsat2ip :: Bool -> CNF.WCNF -> (MIP.Problem Integer, MaxSAT2IPInfo)+maxsat2ip useIndicator wcnf = (ip, ComposedTransformer info1 info2)+  where+    (wbo, info1) = maxsat2wbo wcnf+    (ip, info2) = wbo2ip useIndicator wbo++-- -----------------------------------------------------------------------------
src/ToySolver/Converter/PB2LSP.hs view
@@ -12,8 +12,8 @@ -- ----------------------------------------------------------------------------- module ToySolver.Converter.PB2LSP-  ( convert-  , convertWBO+  ( pb2lsp+  , wbo2lsp   ) where  import Data.ByteString.Builder@@ -21,8 +21,8 @@ import Data.Monoid import qualified Data.PseudoBoolean as PBFile -convert :: PBFile.Formula -> Builder-convert formula =+pb2lsp :: PBFile.Formula -> Builder+pb2lsp formula =   byteString "function model() {\n" <>   decls <>   constrs <>@@ -45,8 +45,8 @@         Just obj' -> byteString "  minimize " <> showSum obj' <> ";\n"         Nothing -> mempty -convertWBO :: PBFile.SoftFormula -> Builder-convertWBO softFormula =+wbo2lsp :: PBFile.SoftFormula -> Builder+wbo2lsp softFormula =   byteString "function model() {\n" <>   decls <>   constrs <>
− src/ToySolver/Converter/PB2SAT.hs 
@@ -1,60 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.PB2SAT--- Copyright   :  (c) Masahiro Sakai 2016--- License     :  BSD-style------ Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  non-portable (FlexibleContexts, MultiParamTypeClasses)----------------------------------------------------------------------------------module ToySolver.Converter.PB2SAT (convert) where--import Control.Monad-import Control.Monad.ST-import Data.Array.IArray-import qualified Data.PseudoBoolean as PBFile--import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin-import qualified ToySolver.SAT.Encoder.PB as PB-import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC-import ToySolver.SAT.Store.CNF-import qualified ToySolver.Text.CNF as CNF---- | Convert a pseudo boolean formula φ to a equisatisfiable CNF formula ψ--- together with two functions f and g such that:------ * if M ⊨ φ then f(M) ⊨ ψ------ * if M ⊨ ψ then g(M) ⊨ φ--- -convert :: PBFile.Formula -> (CNF.CNF, SAT.Model -> SAT.Model, SAT.Model -> SAT.Model)-convert formula = runST $ do-  db <- newCNFStore-  let nv1 = PBFile.pbNumVars formula-  SAT.newVars_ db nv1-  tseitin <-  Tseitin.newEncoder db-  pb <- PB.newEncoder tseitin-  pbnlc <- PBNLC.newEncoder pb tseitin-  forM_ (PBFile.pbConstraints formula) $ \(lhs,op,rhs) -> do-    case op of-      PBFile.Ge -> SAT.addPBNLAtLeast pbnlc lhs rhs-      PBFile.Eq -> SAT.addPBNLExactly pbnlc lhs rhs-  cnf <- getCNFFormula db--  defs <- Tseitin.getDefinitions tseitin-  let extendModel :: SAT.Model -> SAT.Model-      extendModel m = array (1, CNF.numVars cnf) (assocs a)-        where-          -- Use BOXED array to tie the knot-          a :: Array SAT.Var Bool-          a = array (1, CNF.numVars cnf) $-                assocs m ++ [(v, Tseitin.evalFormula a phi) | (v, phi) <- defs]--  return (cnf, extendModel, SAT.restrictModel nv1)---- -----------------------------------------------------------------------------
src/ToySolver/Converter/PB2SMP.hs view
@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- module ToySolver.Converter.PB2SMP-  ( convert+  ( pb2smp   ) where  import Data.ByteString.Builder@@ -20,8 +20,8 @@ import Data.Monoid import qualified Data.PseudoBoolean as PBFile -convert :: Bool -> PBFile.Formula -> Builder-convert isUnix formula =+pb2smp :: Bool -> PBFile.Formula -> Builder+pb2smp isUnix formula =   header <>   decls <>   char7 '\n' <>
− src/ToySolver/Converter/PB2WBO.hs 
@@ -1,39 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.PB2WBO--- Copyright   :  (c) Masahiro Sakai 2013--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable------ References:------ * Improving Unsatisfiability-based Algorithms for Boolean Optimization---   <http://sat.inesc-id.pt/~ruben/talks/sat10-talk.pdf>----------------------------------------------------------------------------------module ToySolver.Converter.PB2WBO (convert) where--import qualified Data.PseudoBoolean as PBFile--convert :: PBFile.Formula -> PBFile.SoftFormula-convert formula-  = PBFile.SoftFormula-  { PBFile.wboTopCost = Nothing-  , PBFile.wboConstraints = cs1 ++ cs2-  , PBFile.wboNumVars = PBFile.pbNumVars formula-  , PBFile.wboNumConstraints = PBFile.pbNumConstraints formula + length cs2-  }-  where-    cs1 = [(Nothing, c) | c <- PBFile.pbConstraints formula]-    cs2 = case PBFile.pbObjectiveFunction formula of-            Nothing -> []-            Just e  ->-              [ if w >= 0-                then (Just w,       ([(-1,ls)], PBFile.Ge, 0))-                else (Just (abs w), ([(1,ls)],  PBFile.Ge, 1))-              | (w,ls) <- e-              ]
− src/ToySolver/Converter/PBLinearization.hs 
@@ -1,77 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.PBLinearization--- Copyright   :  (c) Masahiro Sakai 2016--- License     :  BSD-style------ Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable----------------------------------------------------------------------------------module ToySolver.Converter.PBLinearization-  ( linearize-  , linearizeWBO-  ) where--import Control.Monad-import Control.Monad.ST-import qualified Data.PseudoBoolean as PBFile--import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin-import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC-import ToySolver.SAT.Store.PB--linearize :: PBFile.Formula -> Bool -> PBFile.Formula-linearize formula usePB = runST $ do-  db <- newPBStore-  SAT.newVars_ db (PBFile.pbNumVars formula)-  tseitin <-  Tseitin.newEncoderWithPBLin db-  Tseitin.setUsePB tseitin usePB-  pbnlc <- PBNLC.newEncoder db tseitin-  cs' <- forM (PBFile.pbConstraints formula) $ \(lhs,op,rhs) -> do-    let p = case op of-              PBFile.Ge -> Tseitin.polarityPos-              PBFile.Eq -> Tseitin.polarityBoth-    lhs' <- PBNLC.linearizePBSumWithPolarity pbnlc p lhs-    return ([(c,[l]) | (c,l) <- lhs'],op,rhs)-  obj' <--    case PBFile.pbObjectiveFunction formula of-      Nothing -> return Nothing-      Just obj -> do-        obj' <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityNeg obj-        return $ Just [(c, [l]) | (c,l) <- obj']-  formula' <- getPBFormula db-  return $-    formula'-    { PBFile.pbObjectiveFunction = obj'-    , PBFile.pbConstraints = cs' ++ PBFile.pbConstraints formula'-    , PBFile.pbNumConstraints = PBFile.pbNumConstraints formula + PBFile.pbNumConstraints formula'-    }--linearizeWBO :: PBFile.SoftFormula -> Bool -> PBFile.SoftFormula-linearizeWBO formula usePB = runST $ do-  db <- newPBStore-  SAT.newVars_ db (PBFile.wboNumVars formula)-  tseitin <-  Tseitin.newEncoderWithPBLin db-  Tseitin.setUsePB tseitin usePB-  pbnlc <- PBNLC.newEncoder db tseitin-  cs' <- forM (PBFile.wboConstraints formula) $ \(cost,(lhs,op,rhs)) -> do-    let p = case op of-              PBFile.Ge -> Tseitin.polarityPos-              PBFile.Eq -> Tseitin.polarityBoth-    lhs' <- PBNLC.linearizePBSumWithPolarity pbnlc p lhs-    return (cost,([(c,[l]) | (c,l) <- lhs'],op,rhs))-  formula' <- getPBFormula db-  return $-    PBFile.SoftFormula-    { PBFile.wboTopCost = PBFile.wboTopCost formula-    , PBFile.wboConstraints = cs' ++ [(Nothing, constr) | constr <- PBFile.pbConstraints formula']-    , PBFile.wboNumVars = PBFile.pbNumVars formula'-    , PBFile.wboNumConstraints = PBFile.wboNumConstraints formula + PBFile.pbNumConstraints formula'-    }---- -----------------------------------------------------------------------------
+ src/ToySolver/Converter/QBF2IPC.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.QBF2IPC+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- References:+--+-- * Morten Heine B. Sørensen, and Pawel Urzyczyn. Lectures on the Curry-Howard+--   Isomorphism. http://disi.unitn.it/~bernardi/RSISE11/Papers/curry-howard.pdf+--+-----------------------------------------------------------------------------+module ToySolver.Converter.QBF2IPC+  ( qbf2ipc+  ) where++import qualified Data.IntSet as IntSet++import ToySolver.Data.Boolean+import ToySolver.Data.BoolExpr (BoolExpr)+import qualified ToySolver.Data.BoolExpr as BoolExpr+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.QBF as QBF+import qualified ToySolver.SAT.Types as SAT+++qbf2ipc :: CNF.QDimacs -> (Int, [BoolExpr SAT.Var], BoolExpr SAT.Var)+qbf2ipc qdimacs = (nv2, lhs, rhs)+  where+    nv = CNF.qdimacsNumVars qdimacs+    nc = CNF.qdimacsNumClauses qdimacs++    prefix = [(q,a) | (q,as) <- qs, a <- IntSet.toList as]+      where+        qs = QBF.quantifyFreeVariables nv [(q, IntSet.fromList as) | (q,as) <- CNF.qdimacsPrefix qdimacs]++    nv2 = nv -- positive literal+        + nv -- negative literal+        + nc -- clause+        + 1  -- conjunction+        + nv -- quantified formula+    alpha_xp x = x+    alpha_xn x = nv + x+    alpha_l l  = BoolExpr.Atom $ if l > 0 then alpha_xp l else alpha_xn (- l)+    alpha_c i  = BoolExpr.Atom $ nv + nv + (1 + i)+    alpha_mat  = BoolExpr.Atom $ nv + nv + nc + 1+    alpha_qf i = BoolExpr.Atom $ nv + nv + nc + 1 + (1 + i)++    lhs =+      snd (f (zip [0..] prefix)) +++      [foldr (.=>.) alpha_mat [alpha_c i | (i,_) <- zip [0..] (CNF.qdimacsMatrix qdimacs)]] +++      concat [[alpha_l l .=>. alpha_c i | l <- SAT.unpackClause c] | (i, c) <- zip [0..] (CNF.qdimacsMatrix qdimacs)]+      where+        f [] = (alpha_mat, [])+        f ((i,(QBF.E,x)) : qs) =+         case f qs of+           (alpha_body, ret) -> (alpha_qf i, [(alpha_l x .=>. alpha_body) .=>. alpha_qf i, (alpha_l (- x) .=>. alpha_body) .=>. alpha_qf i] ++ ret)+        f ((i,(QBF.A,x)) : qs) =+         case f qs of+           (alpha_body, ret) -> (alpha_qf i, [(alpha_l x .=>. alpha_body) .=>. (alpha_l (- x) .=>. alpha_body) .=>. alpha_qf i] ++ ret)++    rhs = alpha_qf 0
+ src/ToySolver/Converter/QUBO.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.QUBO+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-----------------------------------------------------------------------------+module ToySolver.Converter.QUBO+  ( qubo2pb+  , QUBO2PBInfo (..)++  , pb2qubo+  , PB2QUBOInfo++  , pbAsQUBO+  , PBAsQUBOInfo (..)++  , qubo2ising+  , QUBO2IsingInfo (..)++  , ising2qubo+  , Ising2QUBOInfo (..)+  ) where++import Control.Monad+import Control.Monad.State+import Data.Array.Unboxed+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.List+import Data.Maybe+import qualified Data.PseudoBoolean as PBFile+import Data.Ratio+import ToySolver.Converter.Base+import ToySolver.Converter.PB (pb2qubo', PB2QUBOInfo')+import qualified ToySolver.QUBO as QUBO+import qualified ToySolver.SAT.Types as SAT++-- -----------------------------------------------------------------------------++qubo2pb :: Real a => QUBO.Problem a -> (PBFile.Formula, QUBO2PBInfo a)+qubo2pb prob =+  ( PBFile.Formula+    { PBFile.pbObjectiveFunction = Just $+        [ (c, if x1==x2 then [x1+1] else [x1+1, x2+1])+        | (x1, row) <- IntMap.toList m2+        , (x2, c) <- IntMap.toList row+        ]+    , PBFile.pbConstraints = []+    , PBFile.pbNumVars = QUBO.quboNumVars prob+    , PBFile.pbNumConstraints = 0+    }+  , QUBO2PBInfo d+  )+  where+    m1 = fmap (fmap toRational) $ QUBO.quboMatrix prob+    d = foldl' lcm 1 [denominator c | row <- IntMap.elems m1, c <- IntMap.elems row, c /= 0]+    m2 = fmap (fmap (\c -> numerator c * (d ` div` denominator c))) m1++newtype QUBO2PBInfo a = QUBO2PBInfo Integer+  deriving (Eq, Show, Read)++instance (Eq a, Show a, Read a) => Transformer (QUBO2PBInfo a) where+  type Source (QUBO2PBInfo a) = QUBO.Solution+  type Target (QUBO2PBInfo a) = SAT.Model++instance (Eq a, Show a, Read a) => ForwardTransformer (QUBO2PBInfo a) where+  transformForward (QUBO2PBInfo _) sol = ixmap (lb+1,ub+1) (subtract 1) sol+    where+      (lb,ub) = bounds sol++instance (Eq a, Show a, Read a) => BackwardTransformer (QUBO2PBInfo a) where+  transformBackward (QUBO2PBInfo _) m = ixmap (lb-1,ub-1) (+1) m+    where+      (lb,ub) = bounds m++instance (Eq a, Show a, Read a) => ObjValueTransformer (QUBO2PBInfo a) where+  type SourceObjValue (QUBO2PBInfo a) = a+  type TargetObjValue (QUBO2PBInfo a) = Integer++instance (Eq a, Show a, Read a, Real a) => ObjValueForwardTransformer (QUBO2PBInfo a) where+  transformObjValueForward (QUBO2PBInfo d) obj = round (toRational obj) * d++instance (Eq a, Show a, Read a, Num a) => ObjValueBackwardTransformer (QUBO2PBInfo a) where+  transformObjValueBackward (QUBO2PBInfo d) obj = fromInteger $ (obj + d - 1) `div` d++-- -----------------------------------------------------------------------------++pbAsQUBO :: forall a. Real a => PBFile.Formula -> Maybe (QUBO.Problem a, PBAsQUBOInfo a)+pbAsQUBO formula = do+  (prob, offset) <- runStateT body 0+  return $ (prob, PBAsQUBOInfo offset)+  where+    body :: StateT Integer Maybe (QUBO.Problem a)+    body = do+      guard $ null (PBFile.pbConstraints formula)+      let f :: PBFile.WeightedTerm -> StateT Integer Maybe [(Integer, Int, Int)]+          f (c,[]) = modify (+c) >> return []+          f (c,[x]) = return [(c,x,x)]+          f (c,[x1,x2]) = return [(c,x1,x2)]+          f _ = mzero+      xs <- mapM f $ SAT.removeNegationFromPBSum $ fromMaybe [] $ PBFile.pbObjectiveFunction formula+      return $+        QUBO.Problem+        { QUBO.quboNumVars = PBFile.pbNumVars formula+        , QUBO.quboMatrix = mkMat $+            [ (x1', x2', fromInteger c)+            | (c,x1,x2) <- concat xs, let x1' = min x1 x2 - 1, let x2' = max x1 x2 - 1+            ]+        }++data PBAsQUBOInfo a = PBAsQUBOInfo !Integer+  deriving (Eq, Show, Read)++instance Transformer (PBAsQUBOInfo a) where+  type Source (PBAsQUBOInfo a) = SAT.Model+  type Target (PBAsQUBOInfo a) = QUBO.Solution++instance ForwardTransformer (PBAsQUBOInfo a) where+  transformForward (PBAsQUBOInfo _offset) m = ixmap (lb-1,ub-1) (+1) m+    where+      (lb,ub) = bounds m++instance BackwardTransformer (PBAsQUBOInfo a) where+  transformBackward (PBAsQUBOInfo _offset) sol = ixmap (lb+1,ub+1) (subtract 1) sol+    where+      (lb,ub) = bounds sol++instance ObjValueTransformer (PBAsQUBOInfo a) where+  type SourceObjValue (PBAsQUBOInfo a) = Integer+  type TargetObjValue (PBAsQUBOInfo a) = a++instance Num a => ObjValueForwardTransformer (PBAsQUBOInfo a) where+  transformObjValueForward (PBAsQUBOInfo offset) obj = fromInteger (obj - offset)++instance Real a => ObjValueBackwardTransformer (PBAsQUBOInfo a) where+  transformObjValueBackward (PBAsQUBOInfo offset) obj = round (toRational obj) + offset++-- -----------------------------------------------------------------------------++pb2qubo :: Real a => PBFile.Formula -> ((QUBO.Problem a, a), PB2QUBOInfo a)+pb2qubo formula = ((qubo, fromInteger (th - offset)), ComposedTransformer info1 info2)+  where+    ((qubo', th), info1) = pb2qubo' formula+    Just (qubo, info2@(PBAsQUBOInfo offset)) = pbAsQUBO qubo'++type PB2QUBOInfo a = ComposedTransformer PB2QUBOInfo' (PBAsQUBOInfo a)++-- -----------------------------------------------------------------------------++qubo2ising :: (Eq a, Show a, Fractional a) => QUBO.Problem a -> (QUBO.IsingModel a, QUBO2IsingInfo a)+qubo2ising QUBO.Problem{ QUBO.quboNumVars = n, QUBO.quboMatrix = qq } =+  ( QUBO.IsingModel+    { QUBO.isingNumVars = n+    , QUBO.isingInteraction = normalizeMat $ jj'+    , QUBO.isingExternalMagneticField = normalizeVec h'+    }+  , QUBO2IsingInfo c'+  )+  where+    {-+       Let xi = (si + 1)/2.++       Then,+         Qij xi xj+       = Qij (si + 1)/2 (sj + 1)/2+       = 1/4 Qij (si sj + si + sj + 1).++       Also,+         Qii xi xi+       = Qii (si + 1)/2 (si + 1)/2+       = 1/4 Qii (si si + 2 si + 1)+       = 1/4 Qii (2 si + 2).+    -}+    (jj', h', c') = foldl' f (IntMap.empty, IntMap.empty, 0) $ do+      (i, row)  <- IntMap.toList qq+      (j, q_ij) <- IntMap.toList row+      if i /= j then+        return+          ( IntMap.singleton (min i j) $ IntMap.singleton (max i j) (q_ij / 4)+          , IntMap.fromList [(i, q_ij / 4), (j, q_ij / 4)]+          , q_ij / 4+          )+      else+        return+          ( IntMap.empty+          , IntMap.singleton i (q_ij / 2)+          , q_ij / 2+          )++    f (jj1, h1, c1) (jj2, h2, c2) =+      ( IntMap.unionWith (IntMap.unionWith (+)) jj1 jj2+      , IntMap.unionWith (+) h1 h2+      , c1+c2+      )++data QUBO2IsingInfo a = QUBO2IsingInfo a+  deriving (Eq, Show, Read)++instance (Eq a, Show a) => Transformer (QUBO2IsingInfo a) where+  type Source (QUBO2IsingInfo a) = QUBO.Solution+  type Target (QUBO2IsingInfo a) = QUBO.Solution++instance (Eq a, Show a) => ForwardTransformer (QUBO2IsingInfo a) where+  transformForward _ sol = sol++instance (Eq a, Show a) => BackwardTransformer (QUBO2IsingInfo a) where+  transformBackward _ sol = sol++instance ObjValueTransformer (QUBO2IsingInfo a) where+  type SourceObjValue (QUBO2IsingInfo a) = a+  type TargetObjValue (QUBO2IsingInfo a) = a++instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (QUBO2IsingInfo a) where+  transformObjValueForward (QUBO2IsingInfo offset) obj = obj - offset++instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (QUBO2IsingInfo a) where+  transformObjValueBackward (QUBO2IsingInfo offset) obj = obj + offset++-- -----------------------------------------------------------------------------++ising2qubo :: (Eq a, Num a) => QUBO.IsingModel a -> (QUBO.Problem a, Ising2QUBOInfo a)+ising2qubo QUBO.IsingModel{ QUBO.isingNumVars = n, QUBO.isingInteraction = jj, QUBO.isingExternalMagneticField = h } =+  ( QUBO.Problem+    { QUBO.quboNumVars = n+    , QUBO.quboMatrix = mkMat m+    }+  , Ising2QUBOInfo offset+  )+  where+    {-+       Let si = 2 xi - 1++       Then,+         Jij si sj+       = Jij (2 xi - 1) (2 xj - 1)+       = Jij (4 xi xj - 2 xi - 2 xj + 1)+       = 4 Jij xi xj - 2 Jij xi    - 2 Jij xj    + Jij+       = 4 Jij xi xj - 2 Jij xi xi - 2 Jij xj xj + Jij++         hi si+       = hi (2 xi - 1)+       = 2 hi xi - hi+       = 2 hi xi xi - hi+    -}+    m =+      concat+      [ [(i, j, 4 * jj_ij), (i, i,  - 2 * jj_ij), (j, j,  - 2 * jj_ij)]+      | (i, row) <- IntMap.toList jj, (j, jj_ij) <- IntMap.toList row+      ] +++      [ (i, i,  2 * hi) | (i, hi) <- IntMap.toList h ]+    offset =+        sum [jj_ij | row <- IntMap.elems jj, jj_ij <- IntMap.elems row]+      - sum (IntMap.elems h)++data Ising2QUBOInfo a = Ising2QUBOInfo a+  deriving (Eq, Show, Read)++instance (Eq a, Show a) => Transformer (Ising2QUBOInfo a) where+  type Source (Ising2QUBOInfo a) = QUBO.Solution+  type Target (Ising2QUBOInfo a) = QUBO.Solution++instance (Eq a, Show a) => ForwardTransformer (Ising2QUBOInfo a) where+  transformForward _ sol = sol++instance (Eq a, Show a) => BackwardTransformer (Ising2QUBOInfo a) where+  transformBackward _ sol = sol++instance (Eq a, Show a) => ObjValueTransformer (Ising2QUBOInfo a) where+  type SourceObjValue (Ising2QUBOInfo a) = a+  type TargetObjValue (Ising2QUBOInfo a) = a++instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (Ising2QUBOInfo a) where+  transformObjValueForward (Ising2QUBOInfo offset) obj = obj - offset++instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (Ising2QUBOInfo a) where+  transformObjValueBackward (Ising2QUBOInfo offset) obj = obj + offset++-- -----------------------------------------------------------------------------++mkMat :: (Eq a, Num a) => [(Int,Int,a)] -> IntMap (IntMap a)+mkMat m = normalizeMat $+  IntMap.unionsWith (IntMap.unionWith (+)) $+  [IntMap.singleton i (IntMap.singleton j qij) | (i,j,qij) <- m]++normalizeMat :: (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)+normalizeMat = IntMap.mapMaybe ((\m -> if IntMap.null m then Nothing else Just m) . normalizeVec)++normalizeVec :: (Eq a, Num a) => IntMap a -> IntMap a+normalizeVec = IntMap.filter (/=0)
− src/ToySolver/Converter/SAT2IP.hs 
@@ -1,26 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.SAT2IP--- Copyright   :  (c) Masahiro Sakai 2011-2014--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable----------------------------------------------------------------------------------module ToySolver.Converter.SAT2IP-  ( convert-  ) where--import Data.Map (Map)--import qualified ToySolver.Data.MIP as MIP-import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.Converter.PB2IP as PB2IP-import qualified ToySolver.Converter.SAT2PB as SAT2PB-import qualified ToySolver.Text.CNF as CNF--convert :: CNF.CNF -> (MIP.Problem Integer, SAT.Model -> Map MIP.Var Rational, Map MIP.Var Rational -> SAT.Model)-convert cnf = PB2IP.convert (SAT2PB.convert cnf)
src/ToySolver/Converter/SAT2KSAT.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Converter.SAT2KSAT@@ -8,10 +10,13 @@ -- -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  experimental--- Portability :  non-portable (FlexibleContexts, MultiParamTypeClasses)+-- Portability :  non-portable -- ------------------------------------------------------------------------------module ToySolver.Converter.SAT2KSAT (convert) where+module ToySolver.Converter.SAT2KSAT+  ( sat2ksat+  , SAT2KSATInfo (..)+  ) where  import Control.Monad import Control.Monad.ST@@ -22,18 +27,20 @@ import qualified Data.Sequence as Seq import Data.STRef +import ToySolver.Converter.Base+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT import ToySolver.SAT.Store.CNF-import qualified ToySolver.Text.CNF as CNF -convert :: Int -> CNF.CNF -> (CNF.CNF, SAT.Model -> SAT.Model, SAT.Model -> SAT.Model)-convert k _ | k < 3 = error "ToySolver.Converter.SAT2KSAT.convert: k must be >=3"-convert k cnf = runST $ do-  let nv1 = CNF.numVars cnf++sat2ksat :: Int -> CNF.CNF -> (CNF.CNF, SAT2KSATInfo)+sat2ksat k _ | k < 3 = error "ToySolver.Converter.SAT2KSAT.sat2ksat: k must be >=3"+sat2ksat k cnf = runST $ do+  let nv1 = CNF.cnfNumVars cnf   db <- newCNFStore   defsRef <- newSTRef Seq.empty-  SAT.newVars_ db (CNF.numVars cnf)-  forM_ (CNF.clauses cnf) $ \clause -> do+  SAT.newVars_ db nv1+  forM_ (CNF.cnfClauses cnf) $ \clause -> do     let loop lits = do           if Seq.length lits <= k then             SAT.addClause db (toList lits)@@ -44,27 +51,35 @@                 SAT.addClause db (toList (lits1 |> (-v)))                 modifySTRef' defsRef (|> (v, toList lits1))                 loop (v <| lits2)-    loop $ Seq.fromList clause-    +    loop $ Seq.fromList $ SAT.unpackClause clause       cnf2 <- getCNFFormula db-   defs <- readSTRef defsRef+  return (cnf2, SAT2KSATInfo nv1 (CNF.cnfNumVars cnf2) defs) -  let extendModel :: SAT.Model -> SAT.Model-      extendModel m = runSTUArray $ do-        m2 <- newArray_ (1,CNF.numVars cnf2)-        forM_ [1..nv1] $ \v -> do-          writeArray m2 v (SAT.evalVar m v)-        forM_ (toList defs) $ \(v, clause) -> do-          let f lit =-                if lit > 0 then-                  readArray m2 lit-                else-                  liftM not (readArray m2 (- lit))-          val <- liftM or (mapM f clause)-          writeArray m2 v val-        return m2 -  return (cnf2, extendModel, SAT.restrictModel nv1)+data SAT2KSATInfo = SAT2KSATInfo !Int !Int (Seq.Seq (SAT.Var, [SAT.Lit]))+  deriving (Eq, Show, Read)++instance Transformer SAT2KSATInfo where+  type Source SAT2KSATInfo = SAT.Model+  type Target SAT2KSATInfo = SAT.Model++instance ForwardTransformer SAT2KSATInfo where+  transformForward (SAT2KSATInfo nv1 nv2 defs) m = runSTUArray $ do+    m2 <- newArray_ (1,nv2)+    forM_ [1..nv1] $ \v -> do+      writeArray m2 v (SAT.evalVar m v)+    forM_ (toList defs) $ \(v, clause) -> do+      let f lit =+            if lit > 0 then+              readArray m2 lit+            else+              liftM not (readArray m2 (- lit))+      val <- liftM or (mapM f clause)+      writeArray m2 v val+    return m2++instance BackwardTransformer SAT2KSATInfo where+  transformBackward (SAT2KSATInfo nv1 _nv2 _defs) = SAT.restrictModel nv1  -- -----------------------------------------------------------------------------
+ src/ToySolver/Converter/SAT2MaxCut.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.SAT2MaxCut+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-- http://www.cs.cornell.edu/courses/cs4820/2014sp/notes/reduction-maxcut.pdf+--+-----------------------------------------------------------------------------+module ToySolver.Converter.SAT2MaxCut+  (+  -- * SAT to MaxCut conversion+    SAT2MaxCutInfo+  , sat2maxcut++  -- * Low-level conversion++  -- ** NAE-SAT to MaxCut+  , NAESAT2MaxCutInfo+  , naesat2maxcut++  -- ** NAE-3-SAT to MaxCut+  , NAE3SAT2MaxCutInfo (..)+  , nae3sat2maxcut+  ) where++import Data.Array.Unboxed+import qualified Data.IntSet as IntSet+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU++import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.MaxCut as MaxCut+import qualified ToySolver.SAT.Types as SAT+import ToySolver.Converter.Base+import ToySolver.Converter.NAESAT (NAESAT)+import qualified ToySolver.Converter.NAESAT as NAESAT++-- ------------------------------------------------------------------------++type SAT2MaxCutInfo = ComposedTransformer NAESAT.SAT2NAESATInfo NAESAT2MaxCutInfo++sat2maxcut :: CNF.CNF -> ((MaxCut.Problem Integer, Integer), SAT2MaxCutInfo)+sat2maxcut x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = NAESAT.sat2naesat x+    (x2, info2) = naesat2maxcut x1++-- ------------------------------------------------------------------------++type NAESAT2MaxCutInfo = ComposedTransformer NAESAT.NAESAT2NAEKSATInfo NAE3SAT2MaxCutInfo++naesat2maxcut :: NAESAT -> ((MaxCut.Problem Integer, Integer), NAESAT2MaxCutInfo)+naesat2maxcut x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = NAESAT.naesat2naeksat 3 x+    (x2, info2) = nae3sat2maxcut x1++-- ------------------------------------------------------------------------++data NAE3SAT2MaxCutInfo = NAE3SAT2MaxCutInfo+  deriving (Eq, Show, Read)++-- Original nae-sat problem is satisfiable iff Max-Cut problem has solution with >=threshold.+nae3sat2maxcut :: NAESAT -> ((MaxCut.Problem Integer, Integer), NAE3SAT2MaxCutInfo)+nae3sat2maxcut (n,cs)+  | any (\c -> VG.length c < 2) cs' =+      ( (MaxCut.fromEdges (n*2) [], 1)+      , NAE3SAT2MaxCutInfo+      )+  | otherwise =+      ( ( MaxCut.fromEdges (n*2) (variableEdges ++ clauseEdges)+        , bigM * fromIntegral n + clauseEdgesObjMax+        )+      , NAE3SAT2MaxCutInfo+      )+  where+    cs' = map (VG.fromList . IntSet.toList . IntSet.fromList . VG.toList) cs++    bigM = clauseEdgesObjMax + 1++    (clauseEdges, clauseEdgesObjMax) = foldl f ([],0) cs'+      where+        f :: ([(Int,Int,Integer)], Integer) -> VU.Vector SAT.Lit -> ([(Int,Int,Integer)], Integer)+        f (clauseEdges', !clauseEdgesObjMax') c =+          case map encodeLit (VG.toList c) of+            []  -> error "nae3sat2maxcut: should not happen"+            [_] -> error "nae3sat2maxcut: should not happen"+            [v0,v1]    -> ([(v0, v1, 1)] ++ clauseEdges', clauseEdgesObjMax' + 1)+            [v0,v1,v2] -> ([(v0, v1, 1), (v1, v2, 1), (v2, v0, 1)] ++ clauseEdges', clauseEdgesObjMax' + 2)+            _ -> error "nae3sat2maxcut: cannot handle nae-clause of size >3"++    variableEdges = [(encodeLit v, encodeLit (-v), bigM) | v <- [1..n]]++instance Transformer NAE3SAT2MaxCutInfo where+  type Source NAE3SAT2MaxCutInfo = SAT.Model+  type Target NAE3SAT2MaxCutInfo = MaxCut.Solution++instance ForwardTransformer NAE3SAT2MaxCutInfo where+  transformForward _ m = array (0,2*n-1) $ do+    v <- [1..n]+    let val = SAT.evalVar m v+    [(encodeLit v, val), (encodeLit (-v), not val)]+    where+      (_,n) = bounds m++instance BackwardTransformer NAE3SAT2MaxCutInfo where+  transformBackward _ sol = array (1,n) [(v, sol ! encodeLit v) | v <- [1..n]]+    where+      (_,n') = bounds sol+      n = (n'+1) `div` 2++-- ------------------------------------------------------------------------++encodeLit :: SAT.Lit -> Int+encodeLit l =+  if l > 0+  then (l-1)*2+  else (-l-1)*2+1++-- ------------------------------------------------------------------------
+ src/ToySolver/Converter/SAT2MaxSAT.hs view
@@ -0,0 +1,281 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.SAT2MaxSAT+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-- References:+--+-- * M. R. Garey, D. S. Johnson, and L. Stockmeyer. Some simplified NP-complete+--   problems. In STOC ’74: Proceedings of the sixth annual ACM symposium on Theory+--   of computing, pages 47–63, New York, NY, USA, 1974.+--   https://dl.acm.org/citation.cfm?doid=800119.803884+--   https://www.sciencedirect.com/science/article/pii/0304397576900591+--+-----------------------------------------------------------------------------+module ToySolver.Converter.SAT2MaxSAT+  (+  -- * SAT to Max-2-SAT conversion+    SATToMaxSAT2Info+  , satToMaxSAT2++  -- * Max-2-SAT to simple Max-Cut conversion+  , MaxSAT2ToSimpleMaxCutInfo+  , maxSAT2ToSimpleMaxCut++  -- * SAT to simple Max-Cut conversion+  , SATToSimpleMaxCutInfo+  , satToSimpleMaxCut++  -- * Low-level conversion++  -- ** 3-SAT to Max-2-SAT conversion+  , SAT3ToMaxSAT2Info (..)+  , sat3ToMaxSAT2++  -- ** Max-2-SAT to SimpleMaxSAT2 conversion+  , SimpleMaxSAT2+  , SimplifyMaxSAT2Info (..)+  , simplifyMaxSAT2++  -- ** SimpleMaxSAT2 to simple Max-Cut conversion+  , SimpleMaxSAT2ToSimpleMaxCutInfo (..)+  , simpleMaxSAT2ToSimpleMaxCut+  ) where++import Control.Monad+import Data.Array.MArray+import Data.Array.ST+import Data.Array.Unboxed+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import Data.List+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Converter.Base+import ToySolver.Converter.SAT2KSAT+import qualified ToySolver.MaxCut as MaxCut+import qualified ToySolver.SAT.Types as SAT++-- ------------------------------------------------------------------------++type SATToMaxSAT2Info = ComposedTransformer SAT2KSATInfo SAT3ToMaxSAT2Info++satToMaxSAT2 :: CNF.CNF -> ((CNF.WCNF, Integer), SATToMaxSAT2Info)+satToMaxSAT2 x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = sat2ksat 3 x+    (x2, info2) = sat3ToMaxSAT2 x1+++sat3ToMaxSAT2 :: CNF.CNF -> ((CNF.WCNF, Integer), SAT3ToMaxSAT2Info)+sat3ToMaxSAT2 cnf =+  case foldl' f (CNF.cnfNumVars cnf, 0, [], [], 0) (CNF.cnfClauses cnf) of+    (!nv, !nc, !cs, ds, !t) ->+      ( ( CNF.WCNF+          { CNF.wcnfNumVars = nv+          , CNF.wcnfNumClauses = nc+          , CNF.wcnfTopCost = fromIntegral $ nc + 1+          , CNF.wcnfClauses = reverse cs+          }+        , t+        )+      , SAT3ToMaxSAT2Info (CNF.cnfNumVars cnf) nv (IntMap.fromList ds)+      )+  where+    f :: (Int, Int, [CNF.WeightedClause], [(SAT.Var,(SAT.Lit,SAT.Lit,SAT.Lit))], Integer)+      -> SAT.PackedClause+      -> (Int, Int, [CNF.WeightedClause], [(SAT.Var,(SAT.Lit,SAT.Lit,SAT.Lit))], Integer)+    f (!nv, !nc, cs, ds, t) clause =+      case SAT.unpackClause clause of+        []       -> (nv, nc+1, (1,clause) : cs, ds, t)+        [_a]     -> (nv, nc+1, (1,clause) : cs, ds, t)+        [_a, _b] -> (nv, nc+1, (1,clause) : cs, ds, t)+        [a, b, c] ->+          let d = nv+1+              cs2 = [[a], [b], [c], [d], [-a,-b], [-a,-c], [-b,-c], [a,-d], [b,-d], [c,-d]]+          in (nv+1, nc + length cs2, map (\clause' -> (1, SAT.packClause clause')) cs2 ++ cs, (d, (a,b,c)) : ds, t + 3)+        _ -> error "not a 3-SAT instance"++data SAT3ToMaxSAT2Info = SAT3ToMaxSAT2Info !Int !Int (IntMap (SAT.Lit,SAT.Lit,SAT.Lit))+  deriving (Eq, Show, Read)++instance Transformer SAT3ToMaxSAT2Info where+  type Source SAT3ToMaxSAT2Info = SAT.Model+  type Target SAT3ToMaxSAT2Info = SAT.Model++instance ForwardTransformer SAT3ToMaxSAT2Info where+  transformForward (SAT3ToMaxSAT2Info nv1 nv2 ds) m = runSTUArray $ do+    m2 <- newArray_ (1,nv2)+    forM_ [1..nv1] $ \v -> do+      writeArray m2 v (SAT.evalVar m v)+    forM_ (IntMap.toList ds) $ \(d, (a,b,c)) -> do+      let n :: Int+          n = sum [1 | l <- [a,b,c], SAT.evalLit m l]+      writeArray m2 d $+        case n of+          1 -> False+          2 -> False -- True is also OK+          3 -> True+          _ -> False -- precondition is violated+    return m2++instance BackwardTransformer SAT3ToMaxSAT2Info where+  transformBackward (SAT3ToMaxSAT2Info nv1 _nv2 _ds) = SAT.restrictModel nv1++-- ------------------------------------------------------------------------++type MaxSAT2ToSimpleMaxCutInfo = ComposedTransformer SimplifyMaxSAT2Info SimpleMaxSAT2ToSimpleMaxCutInfo++maxSAT2ToSimpleMaxCut :: (CNF.WCNF, Integer) -> ((MaxCut.Problem Integer, Integer), MaxSAT2ToSimpleMaxCutInfo)+maxSAT2ToSimpleMaxCut x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = simplifyMaxSAT2 x+    (x2, info2) = simpleMaxSAT2ToSimpleMaxCut x1++-- ------------------------------------------------------------------------++type SimpleMaxSAT2 = (Int, Set (Int, Int), Integer)++simplifyMaxSAT2 :: (CNF.WCNF, Integer) -> (SimpleMaxSAT2, SimplifyMaxSAT2Info)+simplifyMaxSAT2 (wcnf, threshold) =+  case foldl' f (nv1, Set.empty, IntMap.empty, threshold) (CNF.wcnfClauses wcnf) of+    (nv2, cs, defs, threshold2) -> ((nv2, cs, threshold2), SimplifyMaxSAT2Info nv1 nv2 defs)+  where+    nv1 = CNF.wcnfNumVars wcnf+    f r@(nv, cs, defs, t) (w, clause) =+      case SAT.unpackClause clause of+        []    -> (nv, cs, defs, t-w)+        [a]   -> applyN w (insert (a,a)) r+        [a,b] -> applyN w (insert (min a b, max a b)) r+        _ -> error "should not happen"+    insert c@(a,b) (nv,cs,defs,t)+      | c `Set.member` cs = (v, Set.insert (a,v) $ Set.insert (b,-v) cs, IntMap.insert v (a,b) defs, t)+      | otherwise         = (nv, Set.insert c cs, defs, t)+      where+        v = nv + 1++applyN :: Integral n => n -> (a -> a) -> (a -> a)+applyN n f = appEndo $ mconcat $ genericReplicate n (Endo f)++data SimplifyMaxSAT2Info+  = SimplifyMaxSAT2Info !Int !Int (IntMap (SAT.Lit, SAT.Lit))+  deriving (Eq, Show, Read)++instance Transformer SimplifyMaxSAT2Info where+  type Source SimplifyMaxSAT2Info = SAT.Model+  type Target SimplifyMaxSAT2Info = SAT.Model++instance ForwardTransformer SimplifyMaxSAT2Info where+  transformForward (SimplifyMaxSAT2Info _nv1 nv2 defs) m =+    array (1,nv2) $ assocs m ++ [(v, if SAT.evalLit m a then False else True) | (v,(a,_b)) <- IntMap.toList defs]++instance BackwardTransformer SimplifyMaxSAT2Info where+  transformBackward (SimplifyMaxSAT2Info nv1 _nv2 _defs) m = SAT.restrictModel nv1 m++-- ------------------------------------------------------------------------++simpleMaxSAT2ToSimpleMaxCut+  :: SimpleMaxSAT2+  -> ( (MaxCut.Problem Integer, Integer)+     , SimpleMaxSAT2ToSimpleMaxCutInfo+     )+simpleMaxSAT2ToSimpleMaxCut (n, cs, threshold) =+  ( ( MaxCut.fromEdges numNodes [(a,b,1) | (a,b) <- (basicFramework ++ additionalEdges)]+    , w+    )+  , SimpleMaxSAT2ToSimpleMaxCutInfo n p+  )+  where+    p = Set.size cs+    (numNodes, tt, ff, t, f ,xp, xn, l) = simpleMaxSAT2ToSimpleMaxCutNodes n p++    basicFramework =+      [(tt i, ff j)   | i <- [0..3*p], j <- [0..3*p]] +++      [(t i j, f i j) | i <- [1..n],   j <- [0..3*p]] +++      [(xp i,  f i j) | i <- [1..n],   j <- [0..3*p]] +++      [(xn i,  t i j) | i <- [1..n],   j <- [0..3*p]]+    sizeOfBasicFramework = (3*p+1)^(2::Int) + 3 * n*(3*p+1)++    additionalEdges =+      [ (l a, l b) | (a,b) <- Set.toList cs, a /= b ] +++      [ (l a, ff (2*i-1)) | (i, (a,_b)) <- zip [1..] (Set.toList cs) ] +++      [ (l b, ff (2*i  )) | (i, (_a,b)) <- zip [1..] (Set.toList cs) ]++    k = fromIntegral (Set.size cs) - threshold+    w = fromIntegral sizeOfBasicFramework + 2*k+++simpleMaxSAT2ToSimpleMaxCutNodes+  :: Int -> Int+  -> ( Int+     , Int -> Int+     , Int -> Int+     , SAT.Var -> Int -> Int+     , SAT.Var -> Int -> Int+     , SAT.Var -> Int+     , SAT.Var -> Int+     , SAT.Lit -> Int+     )+simpleMaxSAT2ToSimpleMaxCutNodes n p = (numNodes, tt, ff, t, f ,xp, xn, l)+  where+    numNodes = (3*p+1) + (3*p+1) + n*(3*p+1) + n*(3*p+1) + n + n+    tt i  =                                                 i+    ff i  = (3*p+1) +                                       i+    t i j = (3*p+1) + (3*p+1) +                             (i-1)*(3*p+1) + j+    f i j = (3*p+1) + (3*p+1) + n*(3*p+1) +                 (i-1)*(3*p+1) + j+    xp i  = (3*p+1) + (3*p+1) + n*(3*p+1) + n*(3*p+1) +     (i-1)+    xn i  = (3*p+1) + (3*p+1) + n*(3*p+1) + n*(3*p+1) + n + (i-1)+    l x   = if x > 0 then xp x else xn (- x)+++data SimpleMaxSAT2ToSimpleMaxCutInfo+  = SimpleMaxSAT2ToSimpleMaxCutInfo !Int !Int+  deriving (Eq, Show, Read)++instance Transformer SimpleMaxSAT2ToSimpleMaxCutInfo where+  type Source SimpleMaxSAT2ToSimpleMaxCutInfo = SAT.Model+  type Target SimpleMaxSAT2ToSimpleMaxCutInfo = MaxCut.Solution++instance ForwardTransformer SimpleMaxSAT2ToSimpleMaxCutInfo where+  transformForward (SimpleMaxSAT2ToSimpleMaxCutInfo n p) m =+    array (0,numNodes-1) [(v, not (v `IntSet.member` s1)) | v <- [0..numNodes-1]]+    where+      (numNodes, _tt, ff, t, f ,xp, xn, _l) = simpleMaxSAT2ToSimpleMaxCutNodes n p+      s1 = IntSet.fromList $+           [ff i  | i <- [0..3*p]] +++           [xp i  | i <- [1..n], not (SAT.evalVar m i)] +++           [t i j | i <- [1..n], not (SAT.evalVar m i), j <- [0..3*p]] +++           [xn i  | i <- [1..n], SAT.evalVar m i] +++           [f i j | i <- [1..n], SAT.evalVar m i, j <- [0..3*p]]++instance BackwardTransformer SimpleMaxSAT2ToSimpleMaxCutInfo where+  transformBackward (SimpleMaxSAT2ToSimpleMaxCutInfo n p) sol+    | p == 0    = array (1,n) [(i, False) | i <- [1..n]]+    | otherwise = array (1,n) [(i, (sol ! xp i) == b) | i <- [1..n]]+    where+      (_numNodes, _tt, ff, _t, _f ,xp, _xn, _l) = simpleMaxSAT2ToSimpleMaxCutNodes n p+      b = not (sol ! ff 0)++-- ------------------------------------------------------------------------++type SATToSimpleMaxCutInfo = ComposedTransformer SATToMaxSAT2Info MaxSAT2ToSimpleMaxCutInfo++satToSimpleMaxCut :: CNF.CNF -> ((MaxCut.Problem Integer, Integer), SATToSimpleMaxCutInfo)+satToSimpleMaxCut x = (x2, (ComposedTransformer info1 info2))+  where+    (x1, info1) = satToMaxSAT2 x+    (x2, info2) = maxSAT2ToSimpleMaxCut x1++-- ------------------------------------------------------------------------+
− src/ToySolver/Converter/SAT2PB.hs 
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.SAT2PB--- Copyright   :  (c) Masahiro Sakai 2013--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  portable----------------------------------------------------------------------------------module ToySolver.Converter.SAT2PB-  ( convert-  ) where--import qualified Data.PseudoBoolean as PBFile-import qualified ToySolver.Text.CNF as CNF--convert :: CNF.CNF -> PBFile.Formula-convert cnf-  = PBFile.Formula-  { PBFile.pbObjectiveFunction = Nothing-  , PBFile.pbConstraints = map f (CNF.clauses cnf)-  , PBFile.pbNumVars = CNF.numVars cnf-  , PBFile.pbNumConstraints = CNF.numClauses cnf-  }-  where-    f clause = ([(1,[l]) | l <- clause], PBFile.Ge, 1)
+ src/ToySolver/Converter/Tseitin.hs view
@@ -0,0 +1,42 @@++{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Converter.Tseitin+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.Converter.Tseitin+  ( TseitinInfo (..)+  ) where++import Data.Array.IArray+import ToySolver.Converter.Base+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin++data TseitinInfo = TseitinInfo !Int !Int [(SAT.Var, Tseitin.Formula)]+  deriving (Eq, Show, Read)++instance Transformer TseitinInfo where+  type Source TseitinInfo = SAT.Model+  type Target TseitinInfo = SAT.Model++instance ForwardTransformer TseitinInfo where+  transformForward (TseitinInfo _nv1 nv2 defs) m = array (1, nv2) (assocs a)+    where+      -- Use BOXED array to tie the knot+      a :: Array SAT.Var Bool+      a = array (1, nv2) $+            assocs m ++ [(v, Tseitin.evalFormula a phi) | (v, phi) <- defs]++instance BackwardTransformer TseitinInfo where+  transformBackward (TseitinInfo nv1 _nv2 _defs) = SAT.restrictModel nv1++-- -----------------------------------------------------------------------------
− src/ToySolver/Converter/WBO2MaxSAT.hs 
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.WBO2MaxSAT--- Copyright   :  (c) Masahiro Sakai 2016--- License     :  BSD-style------ Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  non-portable (FlexibleContexts, MultiParamTypeClasses)----------------------------------------------------------------------------------module ToySolver.Converter.WBO2MaxSAT (convert) where--import Control.Applicative-import Control.Monad-import Control.Monad.ST-import Data.Array.IArray-import qualified Data.Foldable as F-import Data.Monoid-import qualified Data.Sequence as Seq-import qualified Data.PseudoBoolean as PBFile--import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin-import qualified ToySolver.SAT.Encoder.PB as PB-import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC-import ToySolver.SAT.Store.CNF-import qualified ToySolver.Text.MaxSAT as MaxSAT-import qualified ToySolver.Text.CNF as CNF--convert :: PBFile.SoftFormula -> (MaxSAT.WCNF, SAT.Model -> SAT.Model, SAT.Model -> SAT.Model)-convert formula = runST $ do-  db <- newCNFStore-  SAT.newVars_ db (PBFile.wboNumVars formula)-  tseitin <-  Tseitin.newEncoder db-  pb <- PB.newEncoder tseitin-  pbnlc <- PBNLC.newEncoder pb tseitin--  softClauses <- liftM mconcat $ forM (PBFile.wboConstraints formula) $ \(cost, (lhs,op,rhs)) -> do-    case cost of-      Nothing ->-        case op of-          PBFile.Ge -> SAT.addPBNLAtLeast pbnlc lhs rhs >> return mempty-          PBFile.Eq -> SAT.addPBNLExactly pbnlc lhs rhs >> return mempty-      Just c -> do-        case op of-          PBFile.Ge -> do-            lhs2 <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityPos lhs-            let (lhs3,rhs3) = SAT.normalizePBLinAtLeast (lhs2,rhs)-            if rhs3==1 && and [c==1 | (c,_) <- lhs3] then-              return $ Seq.singleton (c, [l | (_,l) <- lhs3])-            else do-              lit <- PB.encodePBLinAtLeast pb (lhs3,rhs3)-              return $ Seq.singleton (c, [lit])-          PBFile.Eq -> do-            lhs2 <- PBNLC.linearizePBSumWithPolarity pbnlc Tseitin.polarityBoth lhs-            lit1 <- PB.encodePBLinAtLeast pb (lhs2, rhs)-            lit2 <- PB.encodePBLinAtLeast pb ([(-c, l) | (c,l) <- lhs2], negate rhs)-            lit <- Tseitin.encodeConjWithPolarity tseitin Tseitin.polarityPos [lit1,lit2]-            return $ Seq.singleton (c, [lit])--  case PBFile.wboTopCost formula of-    Nothing -> return ()-    Just top -> SAT.addPBNLAtMost pbnlc [(c, [-l | l <- clause]) | (c,clause) <- F.toList softClauses] (top - 1)--  let top = F.sum (fst <$> softClauses) + 1-  cnf <- getCNFFormula db-  let cs = softClauses <> Seq.fromList [(top, clause) | clause <- CNF.clauses cnf]-  let wcnf = MaxSAT.WCNF-             { MaxSAT.numVars = CNF.numVars cnf-             , MaxSAT.numClauses = Seq.length cs-             , MaxSAT.topCost = top-             , MaxSAT.clauses = F.toList cs-             }--  defs <- Tseitin.getDefinitions tseitin-  let extendModel :: SAT.Model -> SAT.Model-      extendModel m = array (1, CNF.numVars cnf) (assocs a)-        where-          -- Use BOXED array to tie the knot-          a :: Array SAT.Var Bool-          a = array (1, CNF.numVars cnf) $-                assocs m ++ [(v, Tseitin.evalFormula a phi) | (v, phi) <- defs]--  return (wcnf, extendModel, SAT.restrictModel (PBFile.wboNumVars formula))---- -----------------------------------------------------------------------------
− src/ToySolver/Converter/WBO2PB.hs 
@@ -1,93 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Converter.WBO2PB--- Copyright   :  (c) Masahiro Sakai 2013,2016--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  experimental--- Portability :  non-portable (MultiParamTypeClasses)----------------------------------------------------------------------------------module ToySolver.Converter.WBO2PB-  ( convert-  , addWBO-  ) where--import Control.Monad-import Control.Monad.Primitive-import Control.Monad.ST-import Data.Array.IArray-import Data.Primitive.MutVar-import qualified ToySolver.SAT.Types as SAT-import ToySolver.SAT.Store.PB-import qualified Data.PseudoBoolean as PBFile--convert :: PBFile.SoftFormula -> (PBFile.Formula, SAT.Model -> SAT.Model, SAT.Model -> SAT.Model)-convert wbo = runST $ do-  let nv = PBFile.wboNumVars wbo-  db <- newPBStore-  (obj, defs) <- addWBO db wbo -  formula <- getPBFormula db--  let mforth :: SAT.Model -> SAT.Model-      mforth m = array (1, PBFile.pbNumVars formula) $ assocs m ++ [(v, SAT.evalPBConstraint m constr) | (v, constr) <- defs]--      mback :: SAT.Model -> SAT.Model-      mback = SAT.restrictModel nv--  return-    ( formula{ PBFile.pbObjectiveFunction = Just obj }-    , mforth-    , mback-    )---addWBO :: (PrimMonad m, SAT.AddPBNL m enc) => enc -> PBFile.SoftFormula -> m (SAT.PBSum, [(SAT.Var, PBFile.Constraint)])-addWBO db wbo = do-  SAT.newVars_ db $ PBFile.wboNumVars wbo--  objRef <- newMutVar []-  defsRef <- newMutVar []-  forM_ (PBFile.wboConstraints wbo) $ \(cost, constr@(lhs,op,rhs)) -> do-    case cost of-      Nothing -> do-        case op of-          PBFile.Ge -> SAT.addPBNLAtLeast db lhs rhs-          PBFile.Eq -> SAT.addPBNLExactly db lhs rhs-      Just w -> do-        case op of-          PBFile.Ge -> do-            case lhs of-              [(1,ls)] | rhs == 1 -> do-                -- ∧L ≥ 1 ⇔ ∧L-                -- obj += w * (1 - ∧L)-                modifyMutVar objRef (\obj -> (w,[]) : (-w,ls) : obj)-              [(-1,ls)] | rhs == 0 -> do-                -- -1*∧L ≥ 0 ⇔ (1 - ∧L) ≥ 1 ⇔ ￢∧L-                -- obj += w * ∧L-                modifyMutVar objRef ((w,ls) :)-              _ | and [c==1 && length ls == 1 | (c,ls) <- lhs] && rhs == 1 -> do-                -- ∑L ≥ 1 ⇔ ∨L ⇔ ￢∧￢L-                -- obj += w * ∧￢L-                modifyMutVar objRef ((w, [-l | (_,[l]) <- lhs]) :)-              _ -> do-                sel <- SAT.newVar db-                SAT.addPBNLAtLeastSoft db sel lhs rhs-                modifyMutVar objRef ((w,[-sel]) :)-                modifyMutVar defsRef ((sel,constr) :)-          PBFile.Eq -> do-            sel <- SAT.newVar db-            SAT.addPBNLExactlySoft db sel lhs rhs-            modifyMutVar objRef ((w,[-sel]) :)-            modifyMutVar defsRef ((sel,constr) :)-  obj <- liftM reverse $ readMutVar objRef-  defs <- liftM reverse $ readMutVar defsRef--  case PBFile.wboTopCost wbo of-    Nothing -> return ()-    Just t -> SAT.addPBNLAtMost db obj (t - 1)--  return (obj, defs)
src/ToySolver/Data/AlgebraicNumber/Real.hs view
@@ -53,7 +53,7 @@ import Data.Ratio import qualified Data.Set as Set import qualified Text.PrettyPrint.HughesPJClass as PP-import Text.PrettyPrint.HughesPJClass (Doc, PrettyLevel, Pretty (..), prettyParen)+import Text.PrettyPrint.HughesPJClass (Doc, PrettyLevel, Pretty (..), maybeParens)  import Data.Interval (Interval, Extended (..), (<=..<), (<..<=), (<..<), (<!), (>!)) import qualified Data.Interval as Interval@@ -418,7 +418,7 @@  instance Pretty AReal where   pPrintPrec lv prec r =-    prettyParen (prec > appPrec) $+    maybeParens (prec > appPrec) $       PP.hsep [PP.text "RealRoot", pPrintPrec lv (appPrec+1) p, PP.int (rootIndex r)]     where       p = minimalPolynomial r
src/ToySolver/Data/AlgebraicNumber/Root.hs view
@@ -88,7 +88,7 @@     f_a_b = f (P.var a) (P.var b)      gbase :: [Polynomial k Var]-    gbase = [ P.subst p1 (\X -> P.var a), P.subst p2 (\X -> P.var b) ]              +    gbase = [ P.subst p1 (\X -> P.var a), P.subst p2 (\X -> P.var b) ]  -- | Given a polynomial P and polynomials {P1,…,Pn} over K, -- findPoly P [P1..Pn] computes a non-zero polynomial Q such that Q[P] = 0 modulo {P1,…,Pn}.
src/ToySolver/Data/BoolExpr.hs view
@@ -23,11 +23,9 @@   , simplify   ) where -import Control.Applicative import Control.DeepSeq import Control.Monad import Data.Data-import Data.Foldable hiding (fold, concat, any) import Data.Hashable import Data.Traversable import ToySolver.Data.Boolean@@ -150,7 +148,7 @@   ite (Simplify c) (Simplify t) (Simplify e)     | isTrue c  = Simplify t     | isFalse c = Simplify e-    | otherwise = Simplify (ITE c t e)  +    | otherwise = Simplify (ITE c t e)  instance Boolean (Simplify a) where   Simplify x .=>. Simplify y
src/ToySolver/Data/Boolean.hs view
@@ -27,7 +27,8 @@  infixr 3 .&&. infixr 2 .||.-infix 1 .=>., .<=>.+infixr 1 .=>.+infix 1 .<=>.  class MonotoneBoolean a where   true, false :: a
src/ToySolver/Data/Delta.hs view
@@ -17,7 +17,7 @@ --   \"/A Fast Linear-Arithmetic Solver for DPLL(T)/\", --   Computer Aided Verification In Computer Aided Verification, Vol. 4144 --   (2006), pp. 81-94.---   <http://dx.doi.org/10.1007/11817963_11>+--   <https://doi.org/10.1007/11817963_11> --   <http://yices.csl.sri.com/cav06.pdf> -- -----------------------------------------------------------------------------
src/ToySolver/Data/FOL/Arith.hs view
@@ -25,7 +25,7 @@   , evalAtom    -- * Arithmetic formula-  , module ToySolver.Data.FOL.Formula  +  , module ToySolver.Data.FOL.Formula    -- * Misc   , SatResult (..)
src/ToySolver/Data/LA.hs view
@@ -32,7 +32,7 @@   , coeff   , lookupCoeff   , extract-  , extractMaybe  +  , extractMaybe    -- ** Operations   , mapCoeff@@ -215,7 +215,7 @@ --   lookupCoeff v e == fmap fst (extractMaybe v e) -- @ lookupCoeff :: Num r => Var -> Expr r -> Maybe r-lookupCoeff v (Expr m) = IntMap.lookup v m  +lookupCoeff v (Expr m) = IntMap.lookup v m  -- | @extract v e@ returns @(c, e')@ such that @e == c *^ v ^+^ e'@ extract :: Num r => Var -> Expr r -> (r, Expr r)
src/ToySolver/Data/MIP.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Data.MIP@@ -25,7 +26,7 @@   , writeMPSFile   , toLPString   , toMPSString-  , ParseError (..)+  , ParseError   ) where  import Prelude hiding (readFile, writeFile)@@ -34,81 +35,128 @@ import Data.Scientific (Scientific) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TLIO-#if MIN_VERSION_megaparsec(6,0,0)-import Data.Void-#endif-import System.FilePath (takeExtension)+import System.FilePath (takeExtension, splitExtension) import System.IO hiding (readFile, writeFile)-import Text.Megaparsec  import ToySolver.Data.MIP.Base+import ToySolver.Data.MIP.FileUtils (ParseError) import qualified ToySolver.Data.MIP.LPFile as LPFile import qualified ToySolver.Data.MIP.MPSFile as MPSFile +#ifdef WITH_ZLIB+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Lazy.Encoding (encode, decode)+import qualified Data.CaseInsensitive as CI+import GHC.IO.Encoding (getLocaleEncoding)+#endif+ -- | Parse .lp or .mps file based on file extension readFile :: FileOptions -> FilePath -> IO (Problem Scientific) readFile opt fname =-  case map toLower (takeExtension fname) of+  case getExt fname of     ".lp"  -> readLPFile opt fname     ".mps" -> readMPSFile opt fname     ext -> ioError $ userError $ "unknown extension: " ++ ext  -- | Parse a file containing LP file data. readLPFile :: FileOptions -> FilePath -> IO (Problem Scientific)+#ifndef WITH_ZLIB readLPFile = LPFile.parseFile+#else+readLPFile opt fname = do+  s <- readTextFile opt fname+  let ret = LPFile.parseString opt fname s+  case ret of+    Left e -> throw e+    Right a -> return a+#endif  -- | Parse a file containing MPS file data. readMPSFile :: FileOptions -> FilePath -> IO (Problem Scientific)+#ifndef WITH_ZLIB readMPSFile = MPSFile.parseFile+#else+readMPSFile opt fname = do+  s <- readTextFile opt fname+  let ret = MPSFile.parseString opt fname s+  case ret of+    Left e -> throw e+    Right a -> return a+#endif --- | Parse a string containing LP file data.-#if MIN_VERSION_megaparsec(6,0,0)-parseLPString :: FileOptions -> String -> String -> Either (ParseError Char Void) (Problem Scientific)-#elif MIN_VERSION_megaparsec(5,0,0)-parseLPString :: FileOptions -> String -> String -> Either (ParseError Char Dec) (Problem Scientific)+readTextFile :: FileOptions -> FilePath -> IO TL.Text+#ifndef WITH_ZLIB+readTextFile opt fname = do+  h <- openFile fname ReadMode+  case MIP.optFileEncoding opt of+    Nothing -> return ()+    Just enc -> hSetEncoding h enc+  TLIO.hGetContents h #else-parseLPString :: FileOptions -> String -> String -> Either ParseError (Problem Scientific)+readTextFile opt fname = do+  enc <- case optFileEncoding opt of+         Nothing -> getLocaleEncoding+         Just enc -> return enc+  let f = if CI.mk (takeExtension fname) == ".gz" then GZip.decompress else id+  s <- BL.readFile fname+  return $ decode enc $ f s #endif++-- | Parse a string containing LP file data.+parseLPString :: FileOptions -> String -> String -> Either (ParseError String) (Problem Scientific) parseLPString = LPFile.parseString  -- | Parse a string containing MPS file data.-#if MIN_VERSION_megaparsec(6,0,0)-parseMPSString :: FileOptions -> String -> String -> Either (ParseError Char Void) (Problem Scientific)-#elif MIN_VERSION_megaparsec(5,0,0)-parseMPSString :: FileOptions -> String -> String -> Either (ParseError Char Dec) (Problem Scientific)-#else-parseMPSString :: FileOptions -> String -> String -> Either ParseError (Problem Scientific)-#endif+parseMPSString :: FileOptions -> String -> String -> Either (ParseError String) (Problem Scientific) parseMPSString = MPSFile.parseString  writeFile :: FileOptions -> FilePath -> Problem Scientific -> IO () writeFile opt fname prob =-  case map toLower (takeExtension fname) of+  case getExt fname of     ".lp"  -> writeLPFile opt fname prob     ".mps" -> writeMPSFile opt fname prob     ext -> ioError $ userError $ "unknown extension: " ++ ext +getExt :: String -> String+getExt name | (base, ext) <- splitExtension name =+  case map toLower ext of+#ifdef WITH_ZLIB+    ".gz" -> getExt base+#endif+    s -> s+ writeLPFile :: FileOptions -> FilePath -> Problem Scientific -> IO () writeLPFile opt fname prob =   case LPFile.render opt prob of     Left err -> ioError $ userError err-    Right s ->-      withFile fname WriteMode $ \h -> do-        case optFileEncoding opt of-          Nothing -> return ()-          Just enc -> hSetEncoding h enc-        TLIO.hPutStr h s+    Right s -> writeTextFile opt fname s  writeMPSFile :: FileOptions -> FilePath -> Problem Scientific -> IO () writeMPSFile opt fname prob =   case MPSFile.render opt prob of     Left err -> ioError $ userError err-    Right s ->-      withFile fname WriteMode $ \h -> do-        case optFileEncoding opt of-          Nothing -> return ()-          Just enc -> hSetEncoding h enc-        TLIO.hPutStr h s+    Right s -> writeTextFile opt fname s++writeTextFile :: FileOptions -> FilePath -> TL.Text -> IO ()+writeTextFile opt fname s = do+  let writeSimple = do+        withFile fname WriteMode $ \h -> do+          case optFileEncoding opt of+            Nothing -> return ()+            Just enc -> hSetEncoding h enc+          TLIO.hPutStr h s+#ifdef WITH_ZLIB+  if CI.mk (takeExtension fname) /= ".gz" then do+    writeSimple+  else do+    enc <- case optFileEncoding opt of+             Nothing -> getLocaleEncoding+             Just enc -> return enc+    BL.writeFile fname $ GZip.compress $ encode enc s+#else+  writeSimple+#endif  toLPString :: FileOptions -> Problem Scientific -> Either String TL.Text toLPString = LPFile.render
src/ToySolver/Data/MIP/Base.hs view
@@ -1,8 +1,9 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Data.MIP.Base--- Copyright   :  (c) Masahiro Sakai 2011-2014+-- Copyright   :  (c) Masahiro Sakai 2011-2019 -- License     :  BSD-style -- -- Maintainer  :  masahiro.sakai@gmail.com@@ -69,6 +70,7 @@   -- * Solutions   , Solution (..)   , Status (..)+  , meetStatus    -- * File I/O options   , FileOptions (..)@@ -78,7 +80,9 @@   , intersectBounds   ) where +#if !MIN_VERSION_lattices(2,0,0) import Algebra.Lattice+#endif import Algebra.PartialOrd import Control.Arrow ((***)) import Data.Default.Class@@ -351,27 +355,36 @@         , (StatusInfeasibleOrUnbounded, StatusInfeasible)         ] ++meetStatus :: Status -> Status -> Status+StatusUnknown `meetStatus` b = StatusUnknown+StatusFeasible `meetStatus` b+  | StatusFeasible `leq` b = StatusFeasible+  | otherwise = StatusUnknown+StatusOptimal `meetStatus` StatusOptimal = StatusOptimal+StatusOptimal `meetStatus` b+  | StatusFeasible `leq` b = StatusFeasible+  | otherwise = StatusUnknown+StatusInfeasibleOrUnbounded `meetStatus` b+  | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded+  | otherwise = StatusUnknown+StatusInfeasible `meetStatus` StatusInfeasible = StatusInfeasible+StatusInfeasible `meetStatus` b+  | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded+  | otherwise = StatusUnknown+StatusUnbounded `meetStatus` StatusUnbounded = StatusUnbounded+StatusUnbounded `meetStatus` b+  | StatusFeasible `leq` b = StatusFeasible+  | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded+  | otherwise = StatusUnknown++#if !MIN_VERSION_lattices(2,0,0)+ instance MeetSemiLattice Status where-  StatusUnknown `meet` b = StatusUnknown-  StatusFeasible `meet` b-    | StatusFeasible `leq` b = StatusFeasible-    | otherwise = StatusUnknown-  StatusOptimal `meet` StatusOptimal = StatusOptimal-  StatusOptimal `meet` b-    | StatusFeasible `leq` b = StatusFeasible-    | otherwise = StatusUnknown-  StatusInfeasibleOrUnbounded `meet` b-    | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded-    | otherwise = StatusUnknown-  StatusInfeasible `meet` StatusInfeasible = StatusInfeasible-  StatusInfeasible `meet` b-    | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded-    | otherwise = StatusUnknown-  StatusUnbounded `meet` StatusUnbounded = StatusUnbounded-  StatusUnbounded `meet` b-    | StatusFeasible `leq` b = StatusFeasible-    | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded-    | otherwise = StatusUnknown+  meet = meetStatus++#endif+  data Solution r   = Solution
+ src/ToySolver/Data/MIP/FileUtils.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Data.MIP.FileUtils+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module ToySolver.Data.MIP.FileUtils+  ( ParseError+  ) where++#if MIN_VERSION_megaparsec(6,0,0)+import Data.Void+#endif+import qualified Text.Megaparsec as MP++#if MIN_VERSION_megaparsec(7,0,0)+type ParseError s = MP.ParseErrorBundle s Void+#elif MIN_VERSION_megaparsec(6,0,0)+type ParseError s = MP.ParseError (MP.Token s) Void+#elif MIN_VERSION_megaparsec(5,0,0)+type ParseError s = MP.ParseError (MP.Token s) MP.Dec+#else+type ParseError s = MP.ParseError+#endif
src/ToySolver/Data/MIP/LPFile.hs view
@@ -30,12 +30,13 @@ module ToySolver.Data.MIP.LPFile   ( parseString   , parseFile+  , ParseError   , parser   , render   ) where -import Control.Applicative-import Control.Exception (throw)+import Control.Applicative hiding (many)+import Control.Exception (throwIO) import Control.Monad import Control.Monad.Writer import Control.Monad.ST@@ -62,21 +63,19 @@ import qualified Data.Text.Lazy.Builder.Scientific as B import qualified Data.Text.Lazy.IO as TLIO import Data.OptDir-#if MIN_VERSION_megaparsec(6,0,0)-import Data.Void-#endif import System.IO #if MIN_VERSION_megaparsec(6,0,0)-import Text.Megaparsec hiding (label, skipManyTill)+import Text.Megaparsec hiding (label, skipManyTill, ParseError) import Text.Megaparsec.Char hiding (string', char') import qualified Text.Megaparsec.Char.Lexer as P #else-import Text.Megaparsec hiding (label, string', char')+import Text.Megaparsec hiding (label, string', char', ParseError) import qualified Text.Megaparsec.Lexer as P import Text.Megaparsec.Prim (MonadParsec ()) #endif  import qualified ToySolver.Data.MIP.Base as MIP+import ToySolver.Data.MIP.FileUtils (ParseError) import ToySolver.Internal.Util (combineMaybe)  -- ---------------------------------------------------------------------------@@ -92,11 +91,11 @@ -- | Parse a string containing LP file data. -- The source name is only | used in error messages and may be the empty string. #if MIN_VERSION_megaparsec(6,0,0)-parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError Char Void) (MIP.Problem Scientific)+parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #elif MIN_VERSION_megaparsec(5,0,0)-parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError Char Dec) (MIP.Problem Scientific)+parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #else-parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either ParseError (MIP.Problem Scientific)+parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #endif parseString _ = parse (parser <* eof) @@ -109,16 +108,15 @@     Just enc -> hSetEncoding h enc   ret <- parse (parser <* eof) fname <$> TLIO.hGetContents h   case ret of-#if MIN_VERSION_megaparsec(6,0,0)-    Left e -> throw (e :: ParseError Char Void)-#elif MIN_VERSION_megaparsec(5,0,0)-    Left e -> throw (e :: ParseError Char Dec)-#else-    Left e -> throw (e :: ParseError)-#endif+    Left e -> throwIO (e :: ParseError TL.Text)     Right a -> return a  -- ---------------------------------------------------------------------------++#if MIN_VERSION_megaparsec(7,0,0)+anyChar :: C e s m => m Char+anyChar = anySingle+#endif  char' :: C e s m => Char -> m Char char' c = (char c <|> char (toUpper c)) <?> show c
src/ToySolver/Data/MIP/MPSFile.hs view
@@ -31,12 +31,13 @@ module ToySolver.Data.MIP.MPSFile   ( parseString   , parseFile+  , ParseError   , parser   , render   ) where  import Control.Applicative ((<$>), (<*))-import Control.Exception (throw)+import Control.Exception (throwIO) import Control.Monad import Control.Monad.Writer import Data.Default.Class@@ -55,24 +56,22 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.IO as TLIO-#if MIN_VERSION_megaparsec(6,0,0)-import Data.Void-#endif import System.IO #if MIN_VERSION_megaparsec(6,0,0)-import Text.Megaparsec+import Text.Megaparsec hiding  (ParseError) import Text.Megaparsec.Char hiding (string', newline) import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as Lexer #else import qualified Text.Megaparsec as P-import Text.Megaparsec hiding (string', newline)+import Text.Megaparsec hiding (string', newline, ParseError) import qualified Text.Megaparsec.Lexer as Lexer import Text.Megaparsec.Prim (MonadParsec ()) #endif  import Data.OptDir import qualified ToySolver.Data.MIP.Base as MIP+import ToySolver.Data.MIP.FileUtils (ParseError)  type Column = MIP.Var type Row = InternedText@@ -104,11 +103,11 @@ -- | Parse a string containing MPS file data. -- The source name is only | used in error messages and may be the empty string. #if MIN_VERSION_megaparsec(6,0,0)-parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError Char Void) (MIP.Problem Scientific)+parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #elif MIN_VERSION_megaparsec(5,0,0)-parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError Char Dec) (MIP.Problem Scientific)+parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #else-parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either ParseError (MIP.Problem Scientific)+parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) #endif parseString _ = parse (parser <* eof) @@ -121,16 +120,16 @@     Just enc -> hSetEncoding h enc   ret <- parse (parser <* eof) fname <$> TLIO.hGetContents h   case ret of-#if MIN_VERSION_megaparsec(6,0,0)-    Left e -> throw (e :: ParseError Char Void)-#elif MIN_VERSION_megaparsec(5,0,0)-    Left e -> throw (e :: ParseError Char Dec)-#else-    Left e -> throw (e :: ParseError)-#endif+    Left e -> throwIO (e :: ParseError TL.Text)     Right a -> return a  -- ---------------------------------------------------------------------------+++#if MIN_VERSION_megaparsec(7,0,0)+anyChar :: C e s m => m Char+anyChar = anySingle+#endif  space' :: C e s m => m Char space' = oneOf [' ', '\t']
src/ToySolver/Data/MIP/Solver/Glpsol.hs view
@@ -6,7 +6,6 @@   ) where  import Algebra.PartialOrd-import Control.Monad import Data.Default.Class import Data.IORef import qualified Data.Text.Lazy.IO as TLIO
src/ToySolver/Data/Polyhedron.hs view
@@ -64,7 +64,7 @@ instance Lattice Polyhedron  instance BoundedJoinSemiLattice Polyhedron where-  bottom = empty  +  bottom = empty  instance BoundedMeetSemiLattice Polyhedron where   top = univ
src/ToySolver/Data/Polynomial/Base.hs view
@@ -144,7 +144,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.VectorSpace import qualified Text.PrettyPrint.HughesPJClass as PP-import Text.PrettyPrint.HughesPJClass (Doc, PrettyLevel, Pretty (..), prettyParen)+import Text.PrettyPrint.HughesPJClass (Doc, PrettyLevel, Pretty (..), maybeParens)  infixl 7  `div`, `mod` @@ -333,7 +333,7 @@   cont p = foldl1' Prelude.gcd ns % foldl' Prelude.lcm 1 ds     where       ns = [abs (numerator c) | (c,_) <- terms p]-      ds = [denominator c     | (c,_) <- terms p]  +      ds = [denominator c     | (c,_) <- terms p]    pp p = mapCoeff (numerator . (/ c)) p     where@@ -522,12 +522,12 @@       [] -> PP.int 0       [t] -> pLeadingTerm prec t       t:ts ->-        prettyParen (prec > addPrec) $+        maybeParens (prec > addPrec) $           PP.hcat (pLeadingTerm addPrec t : map pTrailingTerm ts)     where       pLeadingTerm prec' (c,xs) =         if pOptIsNegativeCoeff opt c-        then prettyParen (prec' > addPrec) $+        then maybeParens (prec' > addPrec) $                PP.char '-' <> prettyPrintTerm opt lv (addPrec+1) (-c,xs)         else prettyPrintTerm opt lv prec' (c,xs) @@ -545,7 +545,7 @@     -- intentionally specify (appPrec+1) to parenthesize any composite expression   | len == 1 && c == 1 = pPow prec $ head (mindices xs)   | otherwise =-      prettyParen (prec > mulPrec) $+      maybeParens (prec > mulPrec) $         PP.hcat $ intersperse (PP.char '*') fs     where       len = Map.size $ mindicesMap xs@@ -554,7 +554,7 @@        pPow prec' (x,1) = pOptPrintVar opt lv prec' x       pPow prec' (x,n) =-        prettyParen (prec' > expPrec) $+        maybeParens (prec' > expPrec) $           pOptPrintVar opt lv (expPrec+1) x <> PP.char '^' <> PP.integer n  class PrettyCoeff a where@@ -570,7 +570,7 @@   pPrintCoeff lv p r     | denominator r == 1 = pPrintCoeff lv p (numerator r)     | otherwise = -        prettyParen (p > ratPrec) $+        maybeParens (p > ratPrec) $           pPrintCoeff lv (ratPrec+1) (numerator r) <>           PP.char '/' <>           pPrintCoeff lv (ratPrec+1) (denominator r)
src/ToySolver/Data/Polynomial/Factorization/Hensel/Internal.hs view
@@ -115,7 +115,7 @@     es  = map (g*) $ cabook_proposition_5_10 fs     c   = sum [ei `P.div` fi | (ei,fi) <- zip es fs]     es2 = case zipWith P.mod es fs of-            e2' : es2' -> e2' + c * head fs : es2'          +            e2' : es2' -> e2' + c * head fs : es2'      check :: [UPolynomial k] -> Bool     check es' =
src/ToySolver/EUF/CongruenceClosure.hs view
@@ -119,7 +119,6 @@  instance Semigroup Class where   xs <> ys = ClassUnion (classSize xs + classSize ys) xs ys-  stimes = stimesIdempotent  classSize :: Class -> Int classSize (ClassSingleton _) = 1
+ src/ToySolver/FileFormat.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.FileFormat+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.FileFormat+  ( module ToySolver.FileFormat.Base+  ) where++import qualified Data.PseudoBoolean as PBFile+import qualified Data.PseudoBoolean.Attoparsec as PBFileAttoparsec+import qualified Data.PseudoBoolean.ByteStringBuilder as PBFileBB+import ToySolver.FileFormat.Base+import ToySolver.FileFormat.CNF () -- importing instances+import ToySolver.QUBO () -- importing instances++instance FileFormat PBFile.Formula where+  parse = PBFileAttoparsec.parseOPBByteString+  render = PBFileBB.opbBuilder++instance FileFormat PBFile.SoftFormula where+  parse = PBFileAttoparsec.parseWBOByteString+  render = PBFileBB.wboBuilder
+ src/ToySolver/FileFormat/Base.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.FileFormat.Base+-- Copyright   :  (c) Masahiro Sakai 2016-2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.FileFormat.Base+  (+  -- * FileFormat class+    FileFormat (..)+  , ParseError (..)+  , parseFile+  , readFile+  , writeFile+  ) where++import Prelude hiding (readFile, writeFile)+import Control.Exception+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Builder+import Data.Typeable+import System.IO hiding (readFile, writeFile)++#ifdef WITH_ZLIB+import qualified Codec.Compression.GZip as GZip+import qualified Data.CaseInsensitive as CI+import System.FilePath+#endif++-- | A type class that abstracts file formats+class FileFormat a where+  -- | Parse a lazy byte string, and either returns error message or a parsed value+  parse :: BS.ByteString -> Either String a++  -- | Encode a value into 'Builder'+  render :: a -> Builder++-- | 'ParseError' represents a parse error and it wraps a error message.+data ParseError = ParseError String+  deriving (Show, Typeable)++instance Exception ParseError++-- | Parse a file but returns an error message when parsing fails.+parseFile :: (FileFormat a, MonadIO m) => FilePath -> m (Either String a)+parseFile filename = liftIO $ do+  s <- BS.readFile filename+#ifdef WITH_ZLIB+  let s2 = if CI.mk (takeExtension filename) == ".gz" then+             GZip.decompress s+           else+             s+#else+  let s2 = s+#endif+  return $ parse s2++-- | Parse a file. Similar to 'parseFile' but this function throws 'ParseError' when parsing fails.+readFile :: (FileFormat a, MonadIO m) => FilePath -> m a+readFile filename = liftIO $ do+  ret <- parseFile filename+  case ret of+    Left msg -> throwIO $ ParseError msg+    Right a -> return a++-- | Write a value into a file.+writeFile :: (FileFormat a, MonadIO m) => FilePath -> a -> m ()+writeFile filepath a = liftIO $ do+  withBinaryFile filepath WriteMode $ \h -> do+    hSetBuffering h (BlockBuffering Nothing)+#ifdef WITH_ZLIB+    if CI.mk (takeExtension filepath) == ".gz" then do+      BS.hPut h $ GZip.compress $ toLazyByteString $ render a+    else do+      hPutBuilder h (render a)+#else+    hPutBuilder h (render a)+#endif
+ src/ToySolver/FileFormat/CNF.hs view
@@ -0,0 +1,389 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.FileFormat.CNF+-- Copyright   :  (c) Masahiro Sakai 2016-2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-- Reader and Writer for DIMACS CNF and family of similar formats.+--+-----------------------------------------------------------------------------+module ToySolver.FileFormat.CNF+  (+  -- * FileFormat class+    module ToySolver.FileFormat.Base++  -- * CNF format+  , CNF (..)++  -- * WCNF format+  , WCNF (..)+  , WeightedClause+  , Weight++  -- * GCNF format+  , GCNF (..)+  , GroupIndex+  , GClause++  -- * QDIMACS format+  , QDimacs (..)+  , Quantifier (..)+  , QuantSet+  , Atom++  -- * Re-exports+  , Lit+  , Clause+  , PackedClause+  , packClause+  , unpackClause+  ) where++import Prelude hiding (readFile, writeFile)+import Control.DeepSeq+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Builder+import Data.Char+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++import ToySolver.FileFormat.Base+import qualified ToySolver.SAT.Types as SAT+import ToySolver.SAT.Types (Lit, Clause, PackedClause, packClause, unpackClause)++-- -------------------------------------------------------------------++-- | DIMACS CNF format+data CNF+  = CNF+  { cnfNumVars :: !Int+    -- ^ Number of variables+  , cnfNumClauses :: !Int+    -- ^ Number of clauses+  , cnfClauses :: [SAT.PackedClause]+    -- ^ Clauses+  }+  deriving (Eq, Ord, Show, Read)++instance FileFormat CNF where+  parse s =+    case BS.words l of+      (["p","cnf", nvar, nclause]) ->+        Right $+          CNF+          { cnfNumVars    = read $ BS.unpack nvar+          , cnfNumClauses = read $ BS.unpack nclause+          , cnfClauses    = map parseClauseBS ls+          }+      _ ->+        Left "cannot find cnf header"+    where+      l :: BS.ByteString+      ls :: [BS.ByteString]+      (l:ls) = filter (not . isCommentBS) (BS.lines s)++  render cnf = header <> mconcat (map f (cnfClauses cnf))+    where+      header = mconcat+        [ byteString "p cnf "+        , intDec (cnfNumVars cnf), char7 ' '+        , intDec (cnfNumClauses cnf), char7 '\n'+        ]+      f c = mconcat [intDec lit <> char7 ' '| lit <- SAT.unpackClause c] <> byteString "0\n"++readInts :: BS.ByteString -> [Int]+readInts s =+  case BS.readInt (BS.dropWhile isSpace s) of+    Just (0,_) -> []+    Just (z,s') -> z : readInts s'+    Nothing -> error "ToySolver.FileFormat.CNF.readInts: 0 is missing"++parseClauseBS :: BS.ByteString -> SAT.PackedClause+parseClauseBS = SAT.packClause . readInts++isCommentBS :: BS.ByteString -> Bool+isCommentBS s =+  case BS.uncons s of+    Just ('c',_) ->  True+    _ -> False++-- -------------------------------------------------------------------++-- | WCNF format for representing partial weighted Max-SAT problems.+--+-- This format is used for for MAX-SAT evaluations.+--+-- References:+--+-- * <http://maxsat.ia.udl.cat/requirements/>+data WCNF+  = WCNF+  { wcnfNumVars    :: !Int+    -- ^ Number of variables+  , wcnfNumClauses :: !Int+    -- ^ Number of (weighted) clauses+  , wcnfTopCost    :: !Weight+    -- ^ Hard clauses have weight equal or greater than "top". +    -- We assure that "top" is a weight always greater than the sum of the weights of violated soft clauses in the solution.+  , wcnfClauses    :: [WeightedClause]+    -- ^ Weighted clauses+  }+  deriving (Eq, Ord, Show, Read)++-- | Weighted clauses+type WeightedClause = (Weight, SAT.PackedClause)++-- | Weigths must be greater than or equal to 1, and smaller than 2^63.+type Weight = Integer++instance FileFormat WCNF where+  parse s =+    case BS.words l of+      (["p","wcnf", nvar, nclause, top]) ->+        Right $+          WCNF+          { wcnfNumVars    = read $ BS.unpack nvar+          , wcnfNumClauses = read $ BS.unpack nclause+          , wcnfTopCost    = read $ BS.unpack top+          , wcnfClauses    = map parseWCNFLineBS ls+          }+      (["p","wcnf", nvar, nclause]) ->+        Right $+          WCNF+          { wcnfNumVars    = read $ BS.unpack nvar+          , wcnfNumClauses = read $ BS.unpack nclause+            -- top must be greater than the sum of the weights of violated soft clauses.+          , wcnfTopCost    = fromInteger $ 2^(63::Int) - 1+          , wcnfClauses    = map parseWCNFLineBS ls+          }+      (["p","cnf", nvar, nclause]) ->+        Right $+          WCNF+          { wcnfNumVars    = read $ BS.unpack nvar+          , wcnfNumClauses = read $ BS.unpack nclause+            -- top must be greater than the sum of the weights of violated soft clauses.+          , wcnfTopCost    = fromInteger $ 2^(63::Int) - 1+          , wcnfClauses    = map ((\c -> seq c (1,c)) . parseClauseBS)  ls+          }+      _ ->+        Left "cannot find wcnf/cnf header"+    where+      l :: BS.ByteString+      ls :: [BS.ByteString]+      (l:ls) = filter (not . isCommentBS) (BS.lines s)++  render wcnf = header <> mconcat (map f (wcnfClauses wcnf))+    where+      header = mconcat+        [ byteString "p wcnf "+        , intDec (wcnfNumVars wcnf), char7 ' '+        , intDec (wcnfNumClauses wcnf), char7 ' '+        , integerDec (wcnfTopCost wcnf), char7 '\n'+        ]+      f (w,c) = integerDec w <> mconcat [char7 ' ' <> intDec lit | lit <- SAT.unpackClause c] <> byteString " 0\n"++parseWCNFLineBS :: BS.ByteString -> WeightedClause+parseWCNFLineBS s =+  case BS.readInteger (BS.dropWhile isSpace s) of+    Nothing -> error "ToySolver.FileFormat.CNF: no weight"+    Just (w, s') -> seq w $ seq xs $ (w, xs)+      where+        xs = parseClauseBS s'++-- -------------------------------------------------------------------++-- | Group oriented CNF Input Format+--+-- This format is used in Group oriented MUS track of the SAT Competition 2011.+--+-- References:+--+-- * <http://www.satcompetition.org/2011/rules.pdf>+data GCNF+  = GCNF+  { gcnfNumVars        :: !Int+    -- ^ Nubmer of variables+  , gcnfNumClauses     :: !Int+    -- ^ Number of clauses+  , gcnfLastGroupIndex :: !GroupIndex+    -- ^ The last index of a group in the file number of components contained in the file.+  , gcnfClauses        :: [GClause]+  }+  deriving (Eq, Ord, Show, Read)++-- | Component number between 0 and `gcnfLastGroupIndex`+type GroupIndex = Int++-- | Clause together with component number+type GClause = (GroupIndex, SAT.PackedClause)++instance FileFormat GCNF where+  parse s =+    case BS.words l of+      (["p","gcnf", nbvar', nbclauses', lastGroupIndex']) ->+        Right $+          GCNF+          { gcnfNumVars        = read $ BS.unpack nbvar'+          , gcnfNumClauses     = read $ BS.unpack nbclauses'+          , gcnfLastGroupIndex = read $ BS.unpack lastGroupIndex'+          , gcnfClauses        = map parseGCNFLineBS ls+          }+      (["p","cnf", nbvar', nbclause']) ->+        Right $+          GCNF+          { gcnfNumVars        = read $ BS.unpack nbvar'+          , gcnfNumClauses     = read $ BS.unpack nbclause'+          , gcnfLastGroupIndex = read $ BS.unpack nbclause'+          , gcnfClauses        = zip [1..] $ map parseClauseBS ls+          }+      _ ->+        Left "cannot find gcnf header"+    where+      l :: BS.ByteString+      ls :: [BS.ByteString]+      (l:ls) = filter (not . isCommentBS) (BS.lines s)++  render gcnf = header <> mconcat (map f (gcnfClauses gcnf))+    where+      header = mconcat+        [ byteString "p gcnf "+        , intDec (gcnfNumVars gcnf), char7 ' '+        , intDec (gcnfNumClauses gcnf), char7 ' '+        , intDec (gcnfLastGroupIndex gcnf), char7 '\n'+        ]+      f (idx,c) = char7 '{' <> intDec idx <> char7 '}' <>+                  mconcat [char7 ' ' <> intDec lit | lit <- SAT.unpackClause c] <>+                  byteString " 0\n"++parseGCNFLineBS :: BS.ByteString -> GClause+parseGCNFLineBS s+  | Just ('{', s1) <- BS.uncons (BS.dropWhile isSpace s)+  , Just (!idx,s2) <- BS.readInt s1+  , Just ('}', s3) <- BS.uncons s2 =+      let ys = parseClauseBS s3+      in seq ys $ (idx, ys)+  | otherwise = error "ToySolver.FileFormat.CNF: parse error"++-- -------------------------------------------------------------------++{-+http://www.qbflib.org/qdimacs.html++<input> ::= <preamble> <prefix> <matrix> EOF++<preamble> ::= [<comment_lines>] <problem_line>+<comment_lines> ::= <comment_line> <comment_lines> | <comment_line>+<comment_line> ::= c <text> EOL+<problem_line> ::= p cnf <pnum> <pnum> EOL++<prefix> ::= [<quant_sets>]+<quant_sets> ::= <quant_set> <quant_sets> | <quant_set>+<quant_set> ::= <quantifier> <atom_set> 0 EOL+<quantifier> ::= e | a+<atom_set> ::= <pnum> <atom_set> | <pnum>++<matrix> ::= <clause_list>+<clause_list> ::= <clause> <clause_list> | <clause>+<clause> ::= <literal> <clause> | <literal> 0 EOL+<literal> ::= <num>++<text> ::= {A sequence of non-special ASCII characters}+<num> ::= {A 32-bit signed integer different from 0}+<pnum> ::= {A 32-bit signed integer greater than 0}+-}++-- | QDIMACS format+--+-- Quantified boolean expression in prenex normal form,+-- consisting of a sequence of quantifiers ('qdimacsPrefix') and+-- a quantifier-free CNF part ('qdimacsMatrix').+--+-- References:+--+-- * QDIMACS standard Ver. 1.1+--   <http://www.qbflib.org/qdimacs.html>+data QDimacs+  = QDimacs+  { qdimacsNumVars :: !Int+    -- ^ Number of variables+  , qdimacsNumClauses :: !Int+    -- ^ Number of clauses+  , qdimacsPrefix :: [QuantSet]+    -- ^ Sequence of quantifiers+  , qdimacsMatrix :: [SAT.PackedClause]+    -- ^ Clauses+  }+  deriving (Eq, Ord, Show, Read)++-- | Quantifier+data Quantifier+  = E -- ^ existential quantifier (∃)+  | A -- ^ universal quantifier (∀)+  deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | Quantified set of variables+type QuantSet = (Quantifier, [Atom])++-- | Synonym of 'SAT.Var'+type Atom = SAT.Var++instance FileFormat QDimacs where+  parse = f . BS.lines+    where+      f [] = Left "ToySolver.FileFormat.CNF.parse: premature end of file"+      f (l : ls) =+        case BS.uncons l of+          Nothing -> Left "ToySolver.FileFormat.CNF.parse: no problem line"+          Just ('c', _) -> f ls+          Just ('p', s) ->+            case BS.words s of+              ["cnf", numVars', numClauses'] ->+                case parsePrefix ls of+                  (prefix', ls') -> Right $+                    QDimacs+                    { qdimacsNumVars = read $ BS.unpack numVars'+                    , qdimacsNumClauses = read $ BS.unpack numClauses'+                    , qdimacsPrefix = prefix'+                    , qdimacsMatrix = map parseClauseBS ls'+                    }+              _ -> Left "ToySolver.FileFormat.CNF.parse: invalid problem line"+          Just (c, _) -> Left ("ToySolver.FileFormat.CNF.parse: invalid prefix " ++ show c)++  render qdimacs = problem_line <> prefix' <> mconcat (map f (qdimacsMatrix qdimacs))+    where+      problem_line = mconcat+        [ byteString "p cnf "+        , intDec (qdimacsNumVars qdimacs), char7 ' '+        , intDec (qdimacsNumClauses qdimacs), char7 '\n'+        ]+      prefix' = mconcat+        [ char7 (if q == E then 'e' else 'a') <> mconcat [char7 ' ' <> intDec atom | atom <- atoms] <> byteString " 0\n"+        | (q, atoms) <- qdimacsPrefix qdimacs+        ]+      f c = mconcat [intDec lit <> char7 ' '| lit <- SAT.unpackClause c] <> byteString "0\n"++parsePrefix :: [BS.ByteString] -> ([QuantSet], [BS.ByteString])+parsePrefix = go []+  where+    go result [] = (reverse result, [])+    go result lls@(l : ls) =+      case BS.uncons l of+        Just (c,s)+          | c=='a' || c=='e' ->+              let atoms = readInts s+                  q = if c=='a' then A else E+              in seq q $ deepseq atoms $ go ((q, atoms) : result) ls+          | otherwise ->+              (reverse result, lls)+        _ -> error "ToySolver.FileFormat.CNF.parseProblem: invalid line"++-- -------------------------------------------------------------------
src/ToySolver/Graph/ShortestPath.hs view
@@ -36,6 +36,7 @@   , path   , firstOutEdge   , lastInEdge+  , cost    -- * Path data types   , Path (..)@@ -51,6 +52,7 @@   , pathVertexesBackward   , pathVertexesSeq   , pathFold+  , pathMin    -- * Shortest-path algorithms   , bellmanFord@@ -61,7 +63,6 @@   , bellmanFordDetectNegativeCycle   ) where -import Control.Applicative import Control.Monad import Control.Monad.ST import Control.Monad.Trans@@ -298,6 +299,7 @@     lift $ do       writeSTRef updatedRef HashSet.empty       forM_ (HashSet.toList us) $ \u -> do+        -- modifySTRef' updatedRef (HashSet.delete u) -- possible optimization         Just (Pair du a) <- H.lookup d u         forM_ (HashMap.lookupDefault [] u g) $ \(v, c, l) -> do           m <- H.lookup d v
src/ToySolver/Internal/Data/Vec.hs view
@@ -177,7 +177,7 @@ growTo :: A.MArray a e IO => GenericVec a e -> Int -> IO () growTo v !n = do   m <- getSize v-  when (m < n) $ resize v n  +  when (m < n) $ resize v n  {-# SPECIALIZE push :: Vec e -> e -> IO () #-} {-# SPECIALIZE push :: UVec Int -> Int -> IO () #-}
src/ToySolver/Internal/TextUtil.hs view
@@ -56,12 +56,7 @@     result = go 0 str      lim :: Word-#if !MIN_VERSION_base(4,6,1) && WORD_SIZE_IN_BITS == 32-    {- To avoid a bug of maxBound <https://ghc.haskell.org/trac/ghc/ticket/8072> -}-    lim = 0xFFFFFFFF `div` 10-#else     lim = maxBound `div` 10-#endif        go :: Integer -> [Char] -> Integer      go !r [] = r
+ src/ToySolver/MaxCut.hs view
@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.MaxCut+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module ToySolver.MaxCut+  ( Problem (..)+  , fromEdges+  , edges+  , buildDSDPMaxCutGraph+  , buildDSDPMaxCutGraph'+  , Solution+  , eval+  , evalEdge+  ) where++import Data.Array.Unboxed+import Data.ByteString.Builder+import Data.ByteString.Builder.Scientific+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Foldable as F+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Monoid+import Data.Scientific (Scientific)++data Problem a+  = Problem+  { numNodes :: !Int+    -- ^ Number of nodes N. Nodes are numbered from 0 to N-1.+  , numEdges :: !Int+    -- ^ Number of edges.+  , matrix :: IntMap (IntMap a)+    -- ^ Non-zero entries of symmetric weight matrix+  } deriving (Eq, Ord, Show)++instance Functor Problem where+  fmap f Problem{ numNodes = n, numEdges = m, matrix = mat } =+    Problem{ numNodes = n, numEdges = m, matrix = fmap (fmap f) mat }++fromEdges :: Num a => Int -> [(Int,Int,a)] -> Problem a+fromEdges n es = Problem n (length es) $ IntMap.unionsWith (IntMap.unionWith (+)) $+  [IntMap.fromList [(v1, IntMap.singleton v2 w), (v2, IntMap.singleton v1 w)] | (v1,v2,w) <- es]++edges :: Problem a -> [(Int,Int,a)]+edges prob = do+  (a,m) <- IntMap.toList $ matrix prob+  (b,w) <- IntMap.toList $ snd $ IntMap.split a m+  return (a,b,w)++buildDSDPMaxCutGraph :: Problem Scientific -> Builder+buildDSDPMaxCutGraph = buildDSDPMaxCutGraph' scientificBuilder++buildDSDPMaxCutGraph' :: (a -> Builder) -> Problem a -> Builder+buildDSDPMaxCutGraph' weightBuilder prob = header <> body+  where+    header = intDec (numNodes prob) <> char7 ' ' <> intDec (numEdges prob) <> char7 '\n'+    body = mconcat $ do+      (a,b,w) <- edges prob+      return $ intDec (a+1) <> char7 ' ' <> intDec (b+1) <> char7 ' ' <> weightBuilder w <> char7 '\n'++type Solution = UArray Int Bool++eval :: Num a => Solution -> Problem a -> a+eval sol prob = sum [w | (a,b,w) <- edges prob, sol ! a /= sol ! b]++evalEdge :: Num a => Solution -> (Int,Int,a) -> a+evalEdge sol (a,b,w) +  | sol ! a /= sol ! b = w+  | otherwise = 0
src/ToySolver/QBF.hs view
@@ -15,7 +15,7 @@ -- * Mikoláš Janota, William Klieber, Joao Marques-Silva, Edmund Clarke. --   Solving QBF with Counterexample Guided Refinement. --   In Theory and Applications of Satisfiability Testing (SAT 2012), pp. 114-128.---   <http://dx.doi.org/10.1007/978-3-642-31612-8_10>+--   <https://doi.org/10.1007/978-3-642-31612-8_10> --   <https://www.cs.cmu.edu/~wklieber/papers/qbf-cegar-sat-2012.pdf> -- -----------------------------------------------------------------------------@@ -29,6 +29,8 @@   , solveNaive   , solveCEGAR   , solveCEGARIncremental+  , solveQE+  , solveQE_CNF   ) where  import Control.Monad@@ -43,11 +45,14 @@ import ToySolver.Data.Boolean import ToySolver.Data.BoolExpr (BoolExpr) import qualified ToySolver.Data.BoolExpr as BoolExpr+import ToySolver.FileFormat.CNF (Quantifier (..))+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT as SAT import ToySolver.SAT.Types (LitSet, VarSet, VarMap) import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import ToySolver.SAT.Store.CNF -import ToySolver.Text.QDimacs (Quantifier (..))+import qualified ToySolver.SAT.ExistentialQuantification as QE  -- ---------------------------------------------------------------------------- @@ -346,7 +351,7 @@     end     -}     f :: Int -> LitSet -> Prefix -> Matrix -> IO (Maybe LitSet)-    f nv assumptions prefix matrix = do+    f nv _assumptions prefix matrix = do       solver <- SAT.newSolver       SAT.newVars_ solver nv       enc <- Tseitin.newEncoder solver@@ -360,14 +365,14 @@             return xs       let g :: Int -> LitSet -> Prefix -> Matrix -> IO (Maybe LitSet)           g _nv _assumptions [] _matrix = error "should not happen"-          g nv assumptions [(q,xs)] matrix = do+          g nv assumptions [(_q,xs)] matrix = do             ret <- SAT.solveWith solver (IntSet.toList assumptions)             if ret then do               m <- SAT.getModel solver               return $ Just $ IntSet.fromList [if SAT.evalLit m x then x else -x | x <- IntSet.toList xs]             else               return Nothing            -          g nv assumptions prefix@((q,xs) : prefix'@((_q2,_) : prefix'')) matrix = do+          g nv assumptions ((q,xs) : prefix'@((_q2,_) : prefix'')) matrix = do             let loop counterMoves = do                   let ys = [(nv, prefix'', reduct matrix nu) | nu <- counterMoves]                       (nv2, prefix2, matrix2) =@@ -388,17 +393,96 @@  -- ---------------------------------------------------------------------------- +data CNFOrDNF+  = CNF [LitSet]+  | DNF [LitSet]+  deriving (Show)++negateCNFOrDNF :: CNFOrDNF -> CNFOrDNF+negateCNFOrDNF (CNF xss) = DNF (map (IntSet.map negate) xss)+negateCNFOrDNF (DNF xss) = CNF (map (IntSet.map negate) xss)++toCNF :: Int -> CNFOrDNF -> CNF.CNF+toCNF nv (CNF clauses) = CNF.CNF nv (length clauses) (map (SAT.packClause . IntSet.toList) clauses)+toCNF nv (DNF [])    = CNF.CNF nv 1 [SAT.packClause []]+toCNF nv (DNF cubes) = CNF.CNF (nv + length cubes) (length cs) (map SAT.packClause cs)+  where+    zs = zip [nv+1..] cubes+    cs = map fst zs : [[-sel, lit] | (sel, cube) <- zs, lit <- IntSet.toList cube]++solveQE :: Int -> Prefix -> Matrix -> IO (Bool, Maybe LitSet)+solveQE nv prefix matrix = do+  store <- newCNFStore+  SAT.newVars_ store nv+  encoder <- Tseitin.newEncoder store+  Tseitin.addFormula encoder matrix+  cnf <- getCNFFormula store+  let prefix' =+        if CNF.cnfNumVars cnf > nv then+          prefix ++ [(E, IntSet.fromList [nv+1 .. CNF.cnfNumVars cnf])]+        else+          prefix+  (b, m) <- solveQE_CNF (CNF.cnfNumVars cnf) prefix' (map SAT.unpackClause (CNF.cnfClauses cnf))+  return (b, fmap (IntSet.filter (\lit -> abs lit <= nv)) m)++solveQE_CNF :: Int -> Prefix -> [SAT.Clause] -> IO (Bool, Maybe LitSet)+solveQE_CNF nv prefix matrix = g (normalizePrefix prefix) matrix+  where+    g :: Prefix -> [SAT.Clause] -> IO (Bool, Maybe LitSet)+    g ((E,xs) : prefix') matrix = do+      cnf <- liftM (toCNF nv) $ f prefix' matrix+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars cnf)+      forM_ (CNF.cnfClauses cnf) $ \clause -> do+        SAT.addClause solver (SAT.unpackClause clause)+      ret <- SAT.solve solver+      if ret then do+        m <- SAT.getModel solver+        return (True, Just $ IntSet.fromList [if SAT.evalLit m x then x else -x | x <- IntSet.toList xs])+      else do+        return (False, Nothing)+    g ((A,xs) : prefix') matrix = do+      cnf <- liftM (toCNF nv . negateCNFOrDNF) $ f prefix' matrix+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars cnf)+      forM_ (CNF.cnfClauses cnf) $ \clause -> do+        SAT.addClause solver (SAT.unpackClause clause)+      ret <- SAT.solve solver+      if ret then do+        m <- SAT.getModel solver+        return (False, Just $ IntSet.fromList [if SAT.evalLit m x then x else -x | x <- IntSet.toList xs])+      else do+        return (True, Nothing)+    g prefix matrix = do+      ret <- f prefix matrix+      case ret of+        CNF xs -> return (not (any IntSet.null xs), Nothing)+        DNF xs -> return (any IntSet.null xs, Nothing)++    f :: Prefix -> [SAT.Clause] -> IO CNFOrDNF+    f [] matrix = return $ CNF [IntSet.fromList clause | clause <- matrix]+    f ((E,xs) : prefix') matrix = do+      cnf <- liftM (toCNF nv) $ f prefix' matrix+      dnf <- QE.shortestImplicantsE (xs `IntSet.union` IntSet.fromList [nv+1 .. CNF.cnfNumVars cnf]) cnf+      return $ DNF dnf+    f ((A,xs) : prefix') matrix = do+      cnf <- liftM (toCNF nv . negateCNFOrDNF) $ f prefix' matrix+      dnf <- QE.shortestImplicantsE (xs `IntSet.union` IntSet.fromList [nv+1 .. CNF.cnfNumVars cnf]) cnf+      return $ negateCNFOrDNF $ DNF dnf++-- ----------------------------------------------------------------------------+ -- ∀y ∃x. x ∧ (y ∨ ¬x)-test = solveNaive 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x))+_test = solveNaive 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x))   where     x  = BoolExpr.Atom 1     y  = BoolExpr.Atom 2 -test' = solveCEGAR 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x))+_test' = solveCEGAR 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x))   where     x  = BoolExpr.Atom 1     y  = BoolExpr.Atom 2 -test1 = prenexAnd (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], notB (BoolExpr.Atom 1))+_test1 = prenexAnd (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], notB (BoolExpr.Atom 1)) -test2 = prenexOr (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1)+_test2 = prenexOr (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1)
+ src/ToySolver/QUBO.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.QUBO+-- Copyright   :  (c) Masahiro Sakai 2018+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-----------------------------------------------------------------------------+module ToySolver.QUBO+  ( -- * QUBO (quadratic unconstrained boolean optimization)+    Problem (..)+  , Solution+  , eval++    -- * Ising Model+  , IsingModel (..)+  , evalIsingModel+  ) where++import Control.Monad+import Data.Array.Unboxed+import Data.ByteString.Builder+import Data.ByteString.Builder.Scientific+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Monoid+import Data.Scientific+import ToySolver.FileFormat.Base++-- | QUBO (quadratic unconstrained boolean optimization) problem.+--+-- Minimize \(\sum_{i\le j} Q_{i,j} x_i x_j\) where \(x_i \in \{0,1\}\) for \(i \in \{0 \ldots N-1\}\).+--+-- In the `Solution` type. 0 and 1 are represented as @False@ and @True@ respectively.+data Problem a+  = Problem+  { quboNumVars :: !Int+    -- ^ Number of variables N. Variables are numbered from 0 to N-1.+  , quboMatrix :: IntMap (IntMap a)+    -- ^ Upper triangular matrix Q+  }+  deriving (Eq, Show)++instance Functor Problem where+  fmap f prob =+    Problem+    { quboNumVars = quboNumVars prob+    , quboMatrix = fmap (fmap f) (quboMatrix prob)+    }++parseProblem :: (BS.ByteString -> a) -> BS.ByteString -> Either String (Problem a)+parseProblem f s = +  case BS.words l of+    ["p", filetype, topology, maxNodes, _nNodes, _nCouplers] ->+      if filetype /= "qubo" then+        Left $ "unknown filetype: " ++ BS.unpack filetype+      else if topology /= "0" && topology /= "unconstrained" then+        Left $ "unknown topology: " ++ BS.unpack topology+      else+        Right $ Problem+        { quboNumVars = read (BS.unpack maxNodes)+        , quboMatrix =+            IntMap.unionsWith IntMap.union $ do+              l <- ls+              case BS.words l of+                [i, j, v] -> return $ IntMap.singleton (read (BS.unpack i)) $ IntMap.singleton (read (BS.unpack j)) $ f v+        }+  where+    (l:ls) = filter (not . isCommentBS) (BS.lines s)++    isCommentBS :: BS.ByteString -> Bool+    isCommentBS s =+      case BS.uncons s of+        Just ('c',_) ->  True+        _ -> False++renderProblem :: (a -> Builder) -> Problem a -> Builder+renderProblem f prob = header+    <> mconcat [ intDec i <> char7 ' ' <> intDec i <> char7 ' ' <> f val <> char7 '\n'+               | (i,val) <- IntMap.toList nodes+               ]+    <> mconcat [intDec i <> char7 ' ' <> intDec j <> char7 ' ' <> f val <> char7 '\n'+               | (i,row) <- IntMap.toList couplers, (j,val) <- IntMap.toList row+               ]+  where+    nodes = IntMap.mapMaybeWithKey IntMap.lookup (quboMatrix prob)+    nNodes = IntMap.size nodes+    couplers = IntMap.mapWithKey IntMap.delete (quboMatrix prob)+    nCouplers = sum [IntMap.size row | row <- IntMap.elems couplers]+    header = mconcat+      ["p qubo 0 "+      , intDec (quboNumVars prob), char7 ' '+      , intDec nNodes, char7 ' '+      , intDec nCouplers, char7 '\n'+      ]++instance FileFormat (Problem Scientific) where+  parse = parseProblem (read . BS.unpack)+  render = renderProblem scientificBuilder+++type Solution = UArray Int Bool++eval :: Num a => Solution -> Problem a -> a+eval sol prob = sum $ do+  (x1, row) <- IntMap.toList $ quboMatrix prob+  guard $ sol ! x1+  (x2, c) <- IntMap.toList row+  guard $ sol ! x2+  return c+++-- | Ising model.+--+-- Minimize \(\sum_{i<j} J_{i,j} \sigma_i \sigma_j + \sum_i h_i \sigma_i\) where \(\sigma_i \in \{-1,+1\}\) for \(i \in \{0 \ldots N-1\}\).+--+-- In the `Solution` type. -1 and +1 are represented as @False@ and @True@ respectively.+data IsingModel a+  = IsingModel+  { isingNumVars :: !Int+    -- ^ Number of variables N. Variables are numbered from 0 to N-1.+  , isingInteraction :: IntMap (IntMap a)+    -- ^ Interaction \(J_{i,j}\) with \(i < j\).+  , isingExternalMagneticField :: IntMap a+    -- ^ External magnetic field \(h_j\).+  }+  deriving (Eq, Show)++evalIsingModel :: Num a => Solution -> IsingModel a -> a+evalIsingModel sol m+  = sum [ jj_ij * sigma i *  sigma j+        | (i, row) <- IntMap.toList $ isingInteraction m, (j, jj_ij) <- IntMap.toList row+        ]+  + sum [ h_i * sigma i | (i, h_i) <- IntMap.toList $ isingExternalMagneticField m ]+  where+    sigma i = if sol ! i then 1 else -1
src/ToySolver/SAT.hs view
@@ -49,6 +49,9 @@   , AddClause (..)   , Clause   , evalClause+  , PackedClause+  , packClause+  , unpackClause   -- ** Cardinality constraints   , AddCardinality (..)   , AtLeast@@ -97,26 +100,6 @@   , getRandomGen   , setConfBudget -  -- ** Deprecated-  , setRestartStrategy-  , setRestartFirst-  , setRestartInc-  , setLearntSizeFirst-  , setLearntSizeInc-  , setCCMin-  , setLearningStrategy-  , setEnablePhaseSaving-  , getEnablePhaseSaving-  , setEnableForwardSubsumptionRemoval-  , getEnableForwardSubsumptionRemoval-  , setEnableBackwardSubsumptionRemoval-  , getEnableBackwardSubsumptionRemoval-  , setCheckModel-  , setRandomFreq-  , setPBHandlerType-  , setPBSplitClausePart-  , getPBSplitClausePart-   -- * Read state   , getNVars   , getNConstraints@@ -125,19 +108,12 @@   , getLitFixed   , getFixedLiterals -  -- * Read state (deprecated)-  , nVars-  , nAssigns-  , nConstraints-  , nLearnt  -   -- * Internal API   , varBumpActivity   , varDecayActivity   ) where  import Prelude hiding (log)-import Control.Applicative hiding (empty) import Control.Loop import Control.Monad import Control.Monad.IO.Class@@ -403,6 +379,8 @@   , svLearntLim       :: !(IORef Int)   , svLearntLimAdjCnt :: !(IORef Int)   , svLearntLimSeq    :: !(IORef [(Int,Int)])+  , svSeen :: !(Vec.UVec Bool)+  , svPBLearnt :: !(IORef (Maybe PBLinAtLeast))    -- | Amount to bump next variable with.   , svVarInc       :: !(IOURef Double)@@ -499,7 +477,7 @@   val <- readIORef (vdValue vd)   when (val == lUndef) $ error "unassign: should not happen" -  flag <- getEnablePhaseSaving solver+  flag <- configEnablePhaseSaving <$> getConfig solver   when flag $ writeIORef (vdPolarity vd) $! fromJust (unliftBool val)    writeIORef (vdValue vd) lUndef@@ -694,42 +672,22 @@ getNVars :: Solver -> IO Int getNVars solver = Vec.getSize (svVarData solver) -{-# DEPRECATED nVars "Use getNVars instead" #-}--- | number of variables of the problem.-nVars :: Solver -> IO Int-nVars = getNVars- -- | number of assigned  getNAssigned :: Solver -> IO Int getNAssigned solver = Vec.getSize (svTrail solver) -{-# DEPRECATED nAssigns "nAssigns is deprecated" #-}--- | number of assigned variables.-nAssigns :: Solver -> IO Int-nAssigns = getNAssigned- -- | number of constraints. getNConstraints :: Solver -> IO Int getNConstraints solver = do   xs <- readIORef (svConstrDB solver)   return $ length xs -{-# DEPRECATED nConstraints "Use getNConstraints instead" #-}--- | number of constraints.-nConstraints :: Solver -> IO Int-nConstraints = getNConstraints- -- | number of learnt constrints. getNLearntConstraints :: Solver -> IO Int getNLearntConstraints solver = do   (n,_) <- readIORef (svLearntDB solver)   return n -{-# DEPRECATED nLearnt "Use getNLearntConstraints instead" #-}--- | number of learnt constrints.-nLearnt :: Solver -> IO Int-nLearnt = getNLearntConstraints- learntConstraints :: Solver -> IO [SomeConstraintHandler] learntConstraints solver = do   (_,cs) <- readIORef (svLearntDB solver)@@ -788,6 +746,9 @@   tsolver <- newIORef Nothing   tchecked <- newIOURef 0 +  seen <- Vec.new+  pbLearnt <- newIORef Nothing+   alpha <- newIOURef 0.4   emaScale <- newIOURef 1.0   learntCounter <- newIOURef 0@@ -838,6 +799,8 @@         , svLearntLimSeq    = learntLimSeq         , svVarInc      = varInc         , svConstrInc   = constrInc+        , svSeen = seen+        , svPBLearnt = pbLearnt          , svERWAStepSize = alpha         , svEMAScale = emaScale@@ -870,6 +833,7 @@     vd <- newVarData     Vec.push (svVarData solver) vd     PQ.enqueue (svVarQueue solver) v+    Vec.push (svSeen solver) False     return v    newVars :: Solver -> Int -> IO [Var]@@ -888,6 +852,7 @@ resizeVarCapacity :: Solver -> Int -> IO () resizeVarCapacity solver n = do   Vec.resizeCapacity (svVarData solver) n+  Vec.resizeCapacity (svSeen solver) n   PQ.resizeHeapCapacity (svVarQueue solver) n   PQ.resizeTableCapacity (svVarQueue solver) (n+1) @@ -972,7 +937,7 @@           else do             removeBackwardSubsumedBy solver (ts', n')             (ts'',n'') <- do-              b <- getPBSplitClausePart solver+              b <- configEnablePBSplitClausePart <$> getConfig solver               if b               then pbSplitClausePart solver (ts',n')               else return (ts',n')@@ -1307,11 +1272,14 @@      learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult)     learnHybrid conflictCounter constr = do-      ((learntClause, clauseLevel), pb) <- analyzeConflictHybrid solver constr-      let minLevel =-            case pb of-              Nothing -> clauseLevel-              Just (_, pbLevel) -> min clauseLevel pbLevel+      (learntClause, clauseLevel) <- analyzeConflict solver constr+      (pb, minLevel) <- do+        z <- readIORef (svPBLearnt solver)+        case z of+          Nothing -> return (z, clauseLevel)+          Just pb -> do+            pbLevel <- pbBacktrackLevel solver pb+            return (z, min clauseLevel pbLevel)       backtrackTo solver minLevel        case learntClause of@@ -1337,7 +1305,7 @@         Nothing -> do           case pb of             Nothing -> return Nothing-            Just ((lhs,rhs), _pbLevel) -> do+            Just (lhs,rhs) -> do               h <- newPBHandlerPromoted solver lhs rhs True               case h of                 CHClause _ -> do@@ -1413,7 +1381,7 @@  checkForwardSubsumption :: Solver -> Clause -> IO Bool checkForwardSubsumption solver lits = do-  flag <- getEnableForwardSubsumptionRemoval solver+  flag <- configEnableForwardSubsumptionRemoval <$> getConfig solver   if not flag then     return False   else do@@ -1430,13 +1398,13 @@   where     withEnablePhaseSaving solver flag m =       bracket-        (getEnablePhaseSaving solver)-        (setEnablePhaseSaving solver)-        (\_ -> setEnablePhaseSaving solver flag >> m)+        (getConfig solver)+        (\saved -> modifyConfig solver (\config -> config{ configEnablePhaseSaving = configEnablePhaseSaving saved }))+        (\saved -> setConfig solver saved{ configEnablePhaseSaving = flag } >> m)  removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO () removeBackwardSubsumedBy solver pb = do-  flag <- getEnableBackwardSubsumptionRemoval solver+  flag <- configEnableBackwardSubsumptionRemoval <$> getConfig solver   when flag $ do     xs <- backwardSubsumedBy solver pb     when debugMode $ do@@ -1458,7 +1426,7 @@             -- because only such constraints are added to occur list.             -- See 'addToDB'.             pb2 <- instantiatePBLinAtLeast (getLitFixed solver) =<< toPBLinAtLeast c-            return $ pbSubsume pb pb2+            return $ pbLinSubsume pb pb2       liftM HashSet.fromList         $ filterM p         $ HashSet.toList@@ -1491,57 +1459,15 @@  setConfig :: Solver -> Config -> IO () setConfig solver conf = do-  orig <- readIORef $ svConfig solver+  orig <- getConfig solver   writeIORef (svConfig solver) conf   when (configBranchingStrategy orig /= configBranchingStrategy conf) $ do     PQ.rebuild (svVarQueue solver)  modifyConfig :: Solver -> (Config -> Config) -> IO ()-modifyConfig solver = modifyIORef' (svConfig solver)--{-# DEPRECATED setRestartStrategy "Use setConfig" #-}-setRestartStrategy :: Solver -> RestartStrategy -> IO ()-setRestartStrategy solver s = modifyIORef' (svConfig solver) $ \config -> config{ configRestartStrategy = s }---- | The initial restart limit. (default 100)--- Zero and negative values are used to disable restart.-{-# DEPRECATED setRestartFirst "Use setConfig" #-}-setRestartFirst :: Solver -> Int -> IO ()-setRestartFirst solver !n = modifyIORef' (svConfig solver) $ \config -> config{ configRestartFirst = n }---- | The factor with which the restart limit is multiplied in each restart. (default 1.5)--- --- This must be @>1@.-{-# DEPRECATED setRestartInc "Use setConfig" #-}-setRestartInc :: Solver -> Double -> IO ()-setRestartInc solver !r-  | r > 1 = modifyIORef' (svConfig solver) $ \config -> config{ configRestartInc = r }-  | otherwise = error "setRestartInc: RestartInc must be >1"--{-# DEPRECATED setLearningStrategy "Use setConfig" #-}-setLearningStrategy :: Solver -> LearningStrategy -> IO ()-setLearningStrategy solver l = modifyIORef' (svConfig solver) $ \config -> config{ configLearningStrategy = l }---- | The initial limit for learnt clauses.--- --- Negative value means computing default value from problem instance.-{-# DEPRECATED setLearntSizeFirst "Use setConfig" #-}-setLearntSizeFirst :: Solver -> Int -> IO ()-setLearntSizeFirst solver !x = modifyIORef' (svConfig solver) $ \config -> config{ configLearntSizeFirst = x }---- | The limit for learnt clauses is multiplied with this factor each restart. (default 1.1)--- --- This must be @>1@.-{-# DEPRECATED setLearntSizeInc "Use setConfig" #-}-setLearntSizeInc :: Solver -> Double -> IO ()-setLearntSizeInc solver !r-  | r > 1 = modifyIORef' (svConfig solver) $ \config -> config{ configLearntSizeInc = r }-  | otherwise = error "setLearntSizeInc: LearntSizeInc must be >1"---- | Controls conflict clause minimization (0=none, 1=basic, 2=deep)-{-# DEPRECATED setCCMin "Use setConfig" #-}-setCCMin :: Solver -> Int -> IO ()-setCCMin solver !v = modifyIORef' (svConfig solver) $ \config -> config{ configCCMin = v }+modifyConfig solver f = do+  config <- getConfig solver+  setConfig solver $ f config  -- | The default polarity of a variable. setVarPolarity :: Solver -> Var -> Bool -> IO ()@@ -1549,17 +1475,6 @@   vd <- varData solver v   writeIORef (vdPolarity vd) val -{-# DEPRECATED setCheckModel "Use setConfig" #-}-setCheckModel :: Solver -> Bool -> IO ()-setCheckModel solver flag = do-  modifyIORef' (svConfig solver) $ \config -> config{ configCheckModel = flag }---- | The frequency with which the decision heuristic tries to choose a random variable-{-# DEPRECATED setRandomFreq "Use setConfig" #-}-setRandomFreq :: Solver -> Double -> IO ()-setRandomFreq solver r =-  modifyIORef' (svConfig solver) $ \config -> config{ configRandomFreq = r }- -- | Set random generator used by the random variable selection setRandomGen :: Solver -> Rand.GenIO -> IO () setRandomGen solver = writeIORef (svRandomGen solver)@@ -1572,69 +1487,6 @@ setConfBudget solver (Just b) | b >= 0 = writeIOURef (svConfBudget solver) b setConfBudget solver _ = writeIOURef (svConfBudget solver) (-1) -{-# DEPRECATED setPBHandlerType "Use setConfig" #-}-setPBHandlerType :: Solver -> PBHandlerType -> IO ()-setPBHandlerType solver ht = do-  modifyIORef' (svConfig solver) $ \config -> config{ configPBHandlerType = ht }---- | Split PB-constraints into a PB part and a clause part.------ Example from minisat+ paper:------ * 4 x1 + 4 x2 + 4 x3 + 4 x4 + 2y1 + y2 + y3 ≥ 4--- --- would be split into------ * x1 + x2 + x3 + x4 + ¬z ≥ 1 (clause part)------ * 2 y1 + y2 + y3 + 4 z ≥ 4 (PB part)------ where z is a newly introduced variable, not present in any other constraint.--- --- Reference:--- --- * N. Eén and N. Sörensson. Translating Pseudo-Boolean Constraints into SAT. JSAT 2:1–26, 2006.----{-# DEPRECATED setPBSplitClausePart "Use setConfig" #-}-setPBSplitClausePart :: Solver -> Bool -> IO ()-setPBSplitClausePart solver b =-  modifyIORef' (svConfig solver) $ \config -> config{ configEnablePBSplitClausePart = b }---- | See documentation of 'setPBSplitClausePart'.-getPBSplitClausePart :: Solver -> IO Bool-getPBSplitClausePart solver =-  configEnablePBSplitClausePart <$> getConfig solver--{-# DEPRECATED setEnablePhaseSaving "Use setConfig" #-}-setEnablePhaseSaving :: Solver -> Bool -> IO ()-setEnablePhaseSaving solver flag = do-  modifyIORef' (svConfig solver) $ \config -> config{ configEnablePhaseSaving = flag }--{-# DEPRECATED getEnablePhaseSaving "Use getConfig" #-}-getEnablePhaseSaving :: Solver -> IO Bool-getEnablePhaseSaving solver = do-  configEnablePhaseSaving <$> getConfig solver--{-# DEPRECATED setEnableForwardSubsumptionRemoval "Use setConfig" #-}-setEnableForwardSubsumptionRemoval :: Solver -> Bool -> IO ()-setEnableForwardSubsumptionRemoval solver flag = do-  modifyIORef' (svConfig solver) $ \config -> config{ configEnableForwardSubsumptionRemoval = flag }--{-# DEPRECATED getEnableForwardSubsumptionRemoval "Use getConfig" #-}-getEnableForwardSubsumptionRemoval :: Solver -> IO Bool-getEnableForwardSubsumptionRemoval solver = do-  configEnableForwardSubsumptionRemoval <$> getConfig solver--{-# DEPRECATED setEnableBackwardSubsumptionRemoval "Use setConfig" #-}-setEnableBackwardSubsumptionRemoval :: Solver -> Bool -> IO ()-setEnableBackwardSubsumptionRemoval solver flag = do-  modifyIORef' (svConfig solver) $ \config -> config{ configEnableBackwardSubsumptionRemoval = flag }--{-# DEPRECATED getEnableBackwardSubsumptionRemoval "Use getConfig" #-}-getEnableBackwardSubsumptionRemoval :: Solver -> IO Bool-getEnableBackwardSubsumptionRemoval solver = do-  configEnableBackwardSubsumptionRemoval <$> getConfig solver- {--------------------------------------------------------------------   API for implementation of @solve@ --------------------------------------------------------------------}@@ -1753,55 +1605,99 @@  analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level) analyzeConflict solver constr = do+  config <- getConfig solver+  let isHybrid = configLearningStrategy config == LearningHybrid+   d <- getDecisionLevel solver+  (out :: Vec.UVec Lit) <- Vec.new+  Vec.push out 0 -- (leave room for the asserting literal)+  (pathC :: IOURef Int) <- newIOURef 0 -  let split :: [Lit] -> IO (LitSet, LitSet)-      split = go (IS.empty, IS.empty)-        where-          go (xs,ys) [] = return (xs,ys)-          go (xs,ys) (l:ls) = do-            lv <- litLevel solver l-            if lv == levelRoot then-              go (xs,ys) ls-            else if lv >= d then-              go (IS.insert l xs, ys) ls-            else-              go (xs, IS.insert l ys) ls+  pbConstrRef <- newIORef undefined -  let loop :: LitSet -> LitSet -> IO LitSet-      loop lits1 lits2-        | sz==1 = do-            return $ lits1 `IS.union` lits2-        | sz>=2 = do-            l <- peekTrail solver-            if litNot l `IS.notMember` lits1 then do-              popTrail solver-              loop lits1 lits2+  let f lits = do+        forM_ lits $ \lit -> do+          let !v = litVar lit+          lv <- litLevel solver lit+          b <- Vec.unsafeRead (svSeen solver) (v - 1)+          when (not b && lv > levelRoot) $ do+            varBumpActivity solver v+            varIncrementParticipated solver v+            if lv >= d then do+              Vec.unsafeWrite (svSeen solver) (v - 1) True+              modifyIOURef pathC (+1)             else do-              m <- varReason solver (litVar l)-              case m of-                Nothing -> error "analyzeConflict: should not happen"-                Just constr2 -> do-                  constrBumpActivity solver constr2-                  xs <- reasonOf solver constr2 (Just l)-                  forM_ xs $ \lit -> do-                     varBumpActivity solver (litVar lit)-                     varIncrementParticipated solver (litVar lit)-                  popTrail solver-                  (ys,zs) <- split xs-                  loop (IS.delete (litNot l) lits1 `IS.union` ys)-                       (lits2 `IS.union` zs)-        | otherwise = error "analyzeConflict: should not happen: reason of current level is empty"-        where-          sz = IS.size lits1+              Vec.push out lit +      processLitHybrid pb constr lit getLits = do+        pb2 <- do+          let clausePB = do+                lits <- getLits+                return $ clauseToPBLinAtLeast (lit : lits)+          b <- isPBRepresentable constr+          if not b then do+            clausePB+          else do+            pb2 <- toPBLinAtLeast constr+            o <- pbOverSAT solver pb2+            if o then do+              clausePB+            else+              return pb2+        let pb3 = cutResolve pb pb2 (litVar lit)+            ls = IS.fromList [l | (_,l) <- fst pb3]+        seq ls $ writeIORef pbConstrRef (ls, pb3)++      popUnseen = do+        l <- peekTrail solver+        let !v = litVar l+        b <- Vec.unsafeRead (svSeen solver) (v - 1)+        if b then do+          return ()+        else do+          when isHybrid $ do+            (ls, pb) <- readIORef pbConstrRef+            when (litNot l `IS.member` ls) $ do+              Just constr <- varReason solver v+              processLitHybrid pb constr l (reasonOf solver constr (Just l))+          popTrail solver+          popUnseen++      loop = do+        popUnseen+        l <- peekTrail solver+        let !v = litVar l+        Vec.unsafeWrite (svSeen solver) (v - 1) False+        modifyIOURef pathC (subtract 1)+        c <- readIOURef pathC+        if c > 0 then do+          Just constr <- varReason solver v+          constrBumpActivity solver constr+          lits <- reasonOf solver constr (Just l)+          f lits+          when isHybrid $ do+            (ls, pb) <- readIORef pbConstrRef+            when (litNot l `IS.member` ls) $ do+              processLitHybrid pb constr l (return lits)+          popTrail solver+          loop+        else do+          Vec.unsafeWrite out 0 (litNot l)+   constrBumpActivity solver constr-  conflictClause <- reasonOf solver constr Nothing-  forM_ conflictClause $ \lit -> do-    varBumpActivity solver (litVar lit)-    varIncrementParticipated solver (litVar lit)-  (ys,zs) <- split conflictClause-  lits <- loop ys zs+  falsifiedLits <- reasonOf solver constr Nothing+  f falsifiedLits+  when isHybrid $ do+     pb <- do+       b <- isPBRepresentable constr+       if b then+         toPBLinAtLeast constr+       else+         return (clauseToPBLinAtLeast falsifiedLits)+     let ls = IS.fromList [l | (_,l) <- fst pb]+     seq ls $ writeIORef pbConstrRef (ls, pb)+  loop+  lits <- liftM IS.fromList $ Vec.getElems out    lits2 <- minimizeConflictClause solver lits @@ -1812,6 +1708,12 @@       lv <- litLevel solver l       return (l,lv) +  when isHybrid $ do+    (_, pb) <- readIORef pbConstrRef+    case pbToClause pb of+      Just _ -> writeIORef (svPBLearnt solver) Nothing+      Nothing -> writeIORef (svPBLearnt solver) (Just pb)+   let level = case xs of                 [] -> error "analyzeConflict: should not happen"                 [_] -> levelRoot@@ -1844,103 +1746,6 @@   n <- Vec.getSize (svTrail solver)   go (n-1) (IS.singleton (litVar p)) [p] -analyzeConflictHybrid :: ConstraintHandler c => Solver -> c -> IO ((Clause, Level), Maybe (PBLinAtLeast, Level))-analyzeConflictHybrid solver constr = do-  d <- getDecisionLevel solver--  let split :: [Lit] -> IO (LitSet, LitSet)-      split = go (IS.empty, IS.empty)-        where-          go (xs,ys) [] = return (xs,ys)-          go (xs,ys) (l:ls) = do-            lv <- litLevel solver l-            if lv == levelRoot then-              go (xs,ys) ls-            else if lv >= d then-              go (IS.insert l xs, ys) ls-            else-              go (xs, IS.insert l ys) ls--  let loop :: LitSet -> LitSet -> PBLinAtLeast -> IO (LitSet, PBLinAtLeast)-      loop lits1 lits2 pb-        | sz==1 = do-            return $ (lits1 `IS.union` lits2, pb)-        | sz>=2 = do-            l <- peekTrail solver-            m <- varReason solver (litVar l)-            case m of-              Nothing -> error "analyzeConflictHybrid: should not happen"-              Just constr2 -> do-                xs <- reasonOf solver constr2 (Just l)-                (lits1',lits2') <--                  if litNot l `IS.notMember` lits1 then-                    return (lits1,lits2)-                  else do-                    constrBumpActivity solver constr2-                    forM_ xs $ \lit -> do-                      varBumpActivity solver (litVar lit)-                      varIncrementParticipated solver (litVar lit)-                    (ys,zs) <- split xs-                    return  (IS.delete (litNot l) lits1 `IS.union` ys, lits2 `IS.union` zs)--                pb' <- if any (\(_,l2) -> litNot l == l2) (fst pb)-                       then do-                         pb2 <- do-                           b <- isPBRepresentable constr2-                           if not b then do-                             return $ clauseToPBLinAtLeast (l:xs)-                           else do-                             pb2 <- toPBLinAtLeast constr2-                             o <- pbOverSAT solver pb2-                             if o then-                               return $ clauseToPBLinAtLeast (l:xs)-                             else-                               return pb2-                         return $ cutResolve pb pb2 (litVar l)-                       else return pb--                popTrail solver-                loop lits1' lits2' pb'--        | otherwise = error "analyzeConflictHybrid: should not happen: reason of current level is empty"-        where-          sz = IS.size lits1--  constrBumpActivity solver constr-  conflictClause <- reasonOf solver constr Nothing-  pbConfl <- do-    b <- isPBRepresentable constr-    if b then-      toPBLinAtLeast constr-    else-      return (clauseToPBLinAtLeast conflictClause)-  forM_ conflictClause $ \lit -> do-    varBumpActivity solver (litVar lit)-    varIncrementParticipated solver (litVar lit)-  (ys,zs) <- split conflictClause-  (lits, pb) <- loop ys zs pbConfl--  lits2 <- minimizeConflictClause solver lits--  incrementReasoned solver (IS.toList lits2)--  xs <- liftM (sortBy (flip (comparing snd))) $-    forM (IS.toList lits2) $ \l -> do-      lv <- litLevel solver l-      return (l,lv)--  let level = case xs of-                [] -> error "analyzeConflict: should not happen"-                [_] -> levelRoot-                _:(_,lv):_ -> lv--  case pbToClause pb of-    Nothing -> do  -      pblevel <- pbBacktrackLevel solver pb-      return ((map fst xs, level), Just (pb, pblevel))-    Just _ -> do-      return ((map fst xs, level), Nothing)- pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level pbBacktrackLevel _ ([], rhs) = assert (rhs > 0) $ return levelRoot pbBacktrackLevel solver (lhs, rhs) = do@@ -1963,7 +1768,10 @@           replay lvs slack_lv    let initial_slack = sum [c | (c,_) <- lhs] - rhs-  replay (IM.toList levelToLiterals) initial_slack+  if any (\(c,_) -> c > initial_slack) lhs then+    return 0+  else do+    replay (IM.toList levelToLiterals) initial_slack  minimizeConflictClause :: Solver -> LitSet -> IO LitSet minimizeConflictClause solver lits = do@@ -2138,7 +1946,7 @@     modifyIORef' ref (IS.insert lit)   forM_ [0..n-1] $ \i -> do     lit <- Vec.read (svAssumptions solver) i-    modifyIORef' ref (IS.delete lit)  +    modifyIORef' ref (IS.delete lit)  constrDecayActivity :: Solver -> IO () constrDecayActivity solver = do@@ -2458,11 +2266,7 @@     (# w2, ret #) -> (# w2, I# ret #)   where     go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)-#if __GLASGOW_HASKELL__ < 708-    go# i end w | i ># end = (# w, -1# #)-#else     go# i end w | isTrue# (i ># end) = (# w, -1# #)-#endif     go# i end w =       case unIO (litValue solver =<< unsafeRead a (I# i)) w of         (# w2, val #) ->@@ -2496,11 +2300,7 @@     (# w2, ret #) -> (# w2, I# ret #)   where     go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)-#if __GLASGOW_HASKELL__ < 708-    go# i end w | i ># end = (# w, -1# #)-#else     go# i end w | isTrue# (i ># end) = (# w, -1# #)-#endif     go# i end w =       case unIO (litValue solver =<< unsafeRead a (I# i)) w of         (# w2, val #) ->@@ -3031,7 +2831,7 @@  {--------------------------------------------------------------------   Pseudo Boolean Constraint (Counter)---------------------------------------------------------------------}   +--------------------------------------------------------------------}  data PBHandlerCounter   = PBHandlerCounter
src/ToySolver/SAT/Config.hs view
@@ -13,18 +13,6 @@   , PBHandlerType (..)   , showPBHandlerType   , parsePBHandlerType--  -- ** Deprecated-  , defaultRestartFirst-  , defaultRestartInc-  , defaultLearntSizeFirst-  , defaultLearntSizeInc-  , defaultCCMin-  , defaultEnablePhaseSaving-  , defaultEnableForwardSubsumptionRemoval-  , defaultEnableBackwardSubsumptionRemoval-  , defaultRandomFreq-  , defaultPBSplitClausePart   ) where  import Data.Char@@ -93,23 +81,23 @@   def =     Config     { configRestartStrategy = def-    , configRestartFirst = defaultRestartFirst-    , configRestartInc = defaultRestartInc+    , configRestartFirst = 100+    , configRestartInc = 1.5     , configLearningStrategy = def-    , configLearntSizeFirst = defaultLearntSizeFirst-    , configLearntSizeInc = defaultLearntSizeInc-    , configCCMin = defaultCCMin+    , configLearntSizeFirst = -1+    , configLearntSizeInc = 1.1+    , configCCMin = 2     , configBranchingStrategy = def     , configERWAStepSizeFirst = 0.4     , configERWAStepSizeDec = 10**(-6)     , configERWAStepSizeMin = 0.06     , configEMADecay = 1 / 0.95-    , configEnablePhaseSaving = defaultEnablePhaseSaving-    , configEnableForwardSubsumptionRemoval = defaultEnableForwardSubsumptionRemoval-    , configEnableBackwardSubsumptionRemoval = defaultEnableBackwardSubsumptionRemoval-    , configRandomFreq = defaultRandomFreq+    , configEnablePhaseSaving = True+    , configEnableForwardSubsumptionRemoval = False+    , configEnableBackwardSubsumptionRemoval = False+    , configRandomFreq = 0.005     , configPBHandlerType = def-    , configEnablePBSplitClausePart = defaultPBSplitClausePart+    , configEnablePBSplitClausePart = False     , configCheckModel = False     , configVarDecay = 1 / 0.95     , configConstrDecay = 1 / 0.999@@ -137,16 +125,6 @@     "luby" -> Just LubyRestarts     _ -> Nothing --- | default value for @RestartFirst@.-{-# DEPRECATED defaultRestartFirst "Use configRestartFirst def" #-}-defaultRestartFirst :: Int-defaultRestartFirst = 100---- | default value for @RestartInc@.-{-# DEPRECATED defaultRestartInc "Use configRestartInc def" #-}-defaultRestartInc :: Double-defaultRestartInc = 1.5- -- | Learning strategy. -- -- The default value can be obtained by 'def'.@@ -204,26 +182,6 @@     "lrb"   -> Just BranchingLRB     _ -> Nothing --- | default value for @LearntSizeFirst@.-{-# DEPRECATED defaultLearntSizeFirst "Use learntSizeFirst def" #-}-defaultLearntSizeFirst :: Int-defaultLearntSizeFirst = -1----- | default value for @LearntSizeInc@.-{-# DEPRECATED defaultLearntSizeInc "Use learntSizeInc def" #-}-defaultLearntSizeInc :: Double-defaultLearntSizeInc = 1.1---- | default value for @CCMin@.-{-# DEPRECATED defaultCCMin "Use ccMin def" #-}-defaultCCMin :: Int-defaultCCMin = 2--{-# DEPRECATED defaultRandomFreq "Use configRandomFreq def" #-}-defaultRandomFreq :: Double-defaultRandomFreq = 0.005- -- | Pseudo boolean constraint handler implimentation. -- -- The default value can be obtained by 'def'.@@ -243,20 +201,3 @@     "counter" -> Just PBHandlerTypeCounter     "pueblo" -> Just PBHandlerTypePueblo     _ -> Nothing---- | See documentation of 'setPBSplitClausePart'.-{-# DEPRECATED defaultPBSplitClausePart "Use configEnablePBSplitClausePart def" #-}-defaultPBSplitClausePart :: Bool-defaultPBSplitClausePart = False--{-# DEPRECATED defaultEnablePhaseSaving "Use configEnablePhaseSaving def" #-}-defaultEnablePhaseSaving :: Bool-defaultEnablePhaseSaving = True--{-# DEPRECATED defaultEnableForwardSubsumptionRemoval "Use configEnableForwardSubsumptionRemoval def" #-}-defaultEnableForwardSubsumptionRemoval :: Bool-defaultEnableForwardSubsumptionRemoval = False--{-# DEPRECATED defaultEnableBackwardSubsumptionRemoval "Use configEnableBackwardSubsumptionRemoval def" #-}-defaultEnableBackwardSubsumptionRemoval :: Bool-defaultEnableBackwardSubsumptionRemoval = False
+ src/ToySolver/SAT/Encoder/Cardinality.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.SAT.Encoder.Cardinality+-- Copyright   :  (c) Masahiro Sakai 2019+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.SAT.Encoder.Cardinality+  ( Encoder+  , Strategy (..)+  , newEncoder+  , newEncoderWithStrategy+  , encodeAtLeast+  ) where++import Control.Monad.Primitive+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import ToySolver.SAT.Encoder.Cardinality.Internal.Naive+import ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter++-- -------------------------------------------------------------------++data Encoder m = Encoder (Tseitin.Encoder m) Strategy++data Strategy+  = Naive+  | ParallelCounter+  deriving (Show, Eq, Ord, Enum, Bounded)++newEncoder :: Monad m => Tseitin.Encoder m -> m (Encoder m)+newEncoder tseitin = return $ Encoder tseitin ParallelCounter++newEncoderWithStrategy :: Monad m => Tseitin.Encoder m -> Strategy -> m (Encoder m)+newEncoderWithStrategy tseitin strategy = return (Encoder tseitin strategy)++-- getTseitinEncoder :: Encoder m -> Tseitin.Encoder m+-- getTseitinEncoder (Encoder tseitin _) = tseitin++instance Monad m => SAT.NewVar m (Encoder m) where+  newVar   (Encoder tseitin _) = SAT.newVar tseitin+  newVars  (Encoder tseitin _) = SAT.newVars tseitin+  newVars_ (Encoder tseitin _) = SAT.newVars_ tseitin++instance Monad m => SAT.AddClause m (Encoder m) where+  addClause (Encoder tseitin _) = SAT.addClause tseitin++instance PrimMonad m => SAT.AddCardinality m (Encoder m) where+  addAtLeast (Encoder tseitin strategy) lhs rhs+    | rhs <= 0  = return ()+    | otherwise =+        case strategy of+          Naive -> addAtLeastNaive tseitin (lhs,rhs)+          ParallelCounter -> addAtLeastParallelCounter tseitin (lhs,rhs)++encodeAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m SAT.Lit+encodeAtLeast (Encoder tseitin strategy) =+  case strategy of+    Naive -> encodeAtLeastNaive tseitin+    ParallelCounter -> encodeAtLeastParallelCounter tseitin
+ src/ToySolver/SAT/Encoder/Cardinality/Internal/Naive.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.SAT.Encoder.Cardinality.Internal.Naive+-- Copyright   :  (c) Masahiro Sakai 2019+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module ToySolver.SAT.Encoder.Cardinality.Internal.Naive+  ( addAtLeastNaive+  , encodeAtLeastNaive+  ) where++import Control.Monad.Primitive+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin++addAtLeastNaive :: PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m ()+addAtLeastNaive enc (lhs,rhs) = do+  let n = length lhs+  if n < rhs then do+    SAT.addClause enc []+  else do+    mapM_ (SAT.addClause enc) (comb (n - rhs + 1) lhs)++-- TODO: consider polarity+encodeAtLeastNaive :: PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastNaive enc (lhs,rhs) = do+  let n = length lhs+  if n < rhs then do+    Tseitin.encodeDisj enc []+  else do+    ls <- mapM (Tseitin.encodeDisj enc) (comb (n - rhs + 1) lhs)+    Tseitin.encodeConj enc ls++comb :: Int -> [a] -> [[a]]+comb 0 _ = [[]]+comb _ [] = []+comb n (x:xs) = map (x:) (comb (n-1) xs) ++ comb n xs
+ src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.SAT.Encoder.Cardinality.Internal+-- Copyright   :  (c) Masahiro Sakai 2019+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter+  ( addAtLeastParallelCounter+  , encodeAtLeastParallelCounter+  ) where++import Control.Monad.Primitive+import Control.Monad.State.Strict+import Data.Bits+import Data.Vector (Vector)+import qualified Data.Vector as V+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin++addAtLeastParallelCounter :: PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m ()+addAtLeastParallelCounter enc constr = do+  l <- encodeAtLeastParallelCounter enc constr+  SAT.addClause enc [l]++-- TODO: consider polarity+encodeAtLeastParallelCounter :: forall m. PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastParallelCounter enc (lhs,rhs) = do+  let rhs_bits = bits (fromIntegral rhs)+  (cnt, overflowBits) <- encodeSumParallelCounter enc (length rhs_bits) lhs+  isGE <- encodeGE enc cnt rhs_bits+  Tseitin.encodeDisj enc $ isGE : overflowBits+  where+    bits :: Integer -> [Bool]+    bits n = f n 0+      where+        f 0 !_ = []+        f n i = testBit n i : f (clearBit n i) (i+1)++encodeSumParallelCounter :: forall m. PrimMonad m => Tseitin.Encoder m -> Int -> [SAT.Lit] -> m ([SAT.Lit], [SAT.Lit])+encodeSumParallelCounter enc w lits = do+  let add :: [SAT.Lit] -> [SAT.Lit] -> SAT.Lit -> StateT [SAT.Lit] m [SAT.Lit]+      add = go 0 []+        where+          go :: Int -> [SAT.Lit] -> [SAT.Lit] -> [SAT.Lit] -> SAT.Lit -> StateT [SAT.Lit] m [SAT.Lit]+          go i ret _xs _ys c | i == w = do+            modify (c:)+            return $ reverse ret+          go _i ret [] [] c = return $ reverse (c : ret)+          go i ret (x : xs) (y : ys) c = do+            z <- lift $ Tseitin.encodeFASum enc x y c+            c' <- lift $ Tseitin.encodeFACarry enc x y c+            go (i+1) (z : ret) xs ys c'+          go _ _ _ _ _ = error "encodeSumParallelCounter: should not happen"++      f :: Vector SAT.Lit -> StateT [SAT.Lit] m [SAT.Lit]+      f xs+        | V.null xs = return []+        | otherwise = do+            let len2 = V.length xs `div` 2+            cnt1 <- f (V.slice 0 len2 xs)+            cnt2 <- f (V.slice len2 len2 xs)+            c <- if V.length xs `mod` 2 == 0 then+                   lift $ Tseitin.encodeDisj enc []+                 else+                   lift $ return $ xs V.! (V.length xs - 1)+            add cnt1 cnt2 c++  runStateT (f (V.fromList lits)) []++encodeGE :: forall m. PrimMonad m => Tseitin.Encoder m -> [SAT.Lit] -> [Bool] -> m SAT.Lit+encodeGE enc lhs rhs = do+  let f :: [SAT.Lit] -> [Bool] -> SAT.Lit -> m SAT.Lit+      f [] [] r = return r+      f [] (True  : _) _ = Tseitin.encodeDisj enc [] -- false+      f [] (False : bs) r = f [] bs r+      f (l : ls) (True  : bs) r = do+        f ls bs =<< Tseitin.encodeConj enc [l, r]+      f (l : ls) (False : bs) r = do+        f ls bs =<< Tseitin.encodeDisj enc [l, r]+      f (l : ls) [] r = do+        f ls [] =<< Tseitin.encodeDisj enc [l, r]+  t <- Tseitin.encodeConj enc [] -- true+  f lhs rhs t
src/ToySolver/SAT/Encoder/Integer.hs view
@@ -19,6 +19,7 @@ import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC  newtype Expr = Expr SAT.PBSum+  deriving (Eq, Show, Read)  newVar :: SAT.AddPBNL m enc => enc -> Integer -> Integer -> m Expr newVar enc lo hi
src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs view
@@ -24,6 +24,7 @@ import Control.Monad import Control.Monad.Primitive import Data.Bits+import Data.Maybe import Data.Primitive.MutVar import Data.Sequence (Seq) import qualified Data.Sequence as Seq@@ -103,19 +104,19 @@               b <- Tseitin.encodeDisj enc [] -- False               loop (i+1) (b : ret)             1 -> do-              Just b <- SQ.dequeue q+              b <- fromJust <$> SQ.dequeue q               loop (i+1) (b : ret)             2 -> do-              Just b1 <- SQ.dequeue q-              Just b2 <- SQ.dequeue q+              b1 <- fromJust <$> SQ.dequeue q+              b2 <- fromJust <$> SQ.dequeue q               s <- encodeHASum enc b1 b2               c <- encodeHACarry enc b1 b2               insert (i+1) c               loop (i+1) (s : ret)             _ -> do-              Just b1 <- SQ.dequeue q-              Just b2 <- SQ.dequeue q-              Just b3 <- SQ.dequeue q+              b1 <- fromJust <$> SQ.dequeue q+              b2 <- fromJust <$> SQ.dequeue q+              b3 <- fromJust <$> SQ.dequeue q               s <- Tseitin.encodeFASum enc b1 b2 b3               c <- Tseitin.encodeFACarry enc b1 b2 b3               insert i s
src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs view
@@ -49,6 +49,7 @@                 Just l -> return l                 Nothing -> do                   case xs of+                    [] -> error "encodePBLinAtLeastBDD: should not happen"                     [(_,l)] -> return l                     (c,l) : xs' -> do                       thenLit <- f xs' (rhs - c) slack
src/ToySolver/SAT/ExistentialQuantification.hs view
@@ -1,6 +1,6 @@ {-# Language BangPatterns #-} {-# OPTIONS_GHC -Wall #-}--- -------------------------------------------------------------------+---------------------------------------------------------------------- -- | -- Module      :  ToySolver.SAT.ExistentialQuantification -- Copyright   :  (c) Masahiro Sakai 2017@@ -18,21 +18,22 @@ --   pp. 191-207. --   <https://www.embedded.rwth-aachen.de/lib/exe/fetch.php?media=bib:bkk11a.pdf> ----- --------------------------------------------------------------------+---------------------------------------------------------------------- module ToySolver.SAT.ExistentialQuantification   ( project   , shortestImplicants+  , shortestImplicantsE+  , negateCNF   ) where -import Control.Applicative import Control.Monad import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.IORef+import qualified Data.Vector.Generic as VG+import ToySolver.FileFormat.CNF as CNF import ToySolver.SAT as SAT import ToySolver.SAT.Types as SAT-import ToySolver.Text.CNF as CNF  -- ------------------------------------------------------------------- @@ -42,7 +43,17 @@   , backwardMap :: SAT.VarMap SAT.Lit   } -dualRailEncoding :: SAT.VarSet -> CNF.CNF -> (CNF.CNF, Info)+-- | Given a set of variables \(X = \{x_1, \ldots, x_k\}\) and CNF formula \(\phi\), this function+--+-- * duplicates \(X\) with \(X^+ = \{x^+_1,\ldots,x^+_k\}\) and \(X^- = \{x^-_1,\ldots,x^-_k\}\),+--+-- * replaces positive literals \(x_i\) with \(x^+_i\), and negative literals \(\neg x_i\) with \(x^-_i\), and+--+-- * adds constraints \(\neg x^+_i \vee \neg x^-_i\).+dualRailEncoding+  :: SAT.VarSet -- ^ \(X\)+  -> CNF.CNF    -- ^ \(\phi\)+  -> (CNF.CNF, Info) dualRailEncoding vs cnf =   ( cnf'   , Info@@ -53,9 +64,9 @@   where     cnf' =       CNF.CNF-      { CNF.numVars = CNF.numVars cnf + IntSet.size vs-      , CNF.numClauses = CNF.numClauses cnf + IntSet.size vs-      , CNF.clauses = [ fmap f c | c <- CNF.clauses cnf ] ++ [[-xp,-xn] | (xp,xn) <- IntMap.elems forward]+      { CNF.cnfNumVars = CNF.cnfNumVars cnf + IntSet.size vs+      , CNF.cnfNumClauses = CNF.cnfNumClauses cnf + IntSet.size vs+      , CNF.cnfClauses = [ VG.map f c | c <- CNF.cnfClauses cnf ] ++ [SAT.packClause [-xp,-xn] | (xp,xn) <- IntMap.elems forward]       }     f x =       case IntMap.lookup (abs x) forward of@@ -64,7 +75,7 @@     forward =       IntMap.fromList       [ (x, (x,x'))-      | (x,x') <- zip (IntSet.toList vs) [CNF.numVars cnf + 1 ..]+      | (x,x') <- zip (IntSet.toList vs) [CNF.cnfNumVars cnf + 1 ..]       ]     backward = IntMap.fromList $ concat $       [ [(xp,x), (xn,-x)]@@ -92,12 +103,35 @@ blockingClause :: Info -> SAT.Model -> Clause blockingClause info m = [-y | y <- IntMap.keys (backwardMap info), SAT.evalLit m y] -shortestImplicants :: SAT.VarSet -> CNF.CNF -> IO [LitSet]-shortestImplicants vs formula = do-  let (tau_formula, info) = dualRailEncoding vs formula+{-# DEPRECATED shortestImplicants "Use shortestImplicantsE instead" #-} +-- | Given a set of variables \(X = \{x_1, \ldots, x_k\}\) and CNF formula \(\phi\),+-- this function computes shortest implicants of \(\phi\) in terms of \(X\).+-- Variables except \(X\) are treated as if they are existentially quantified.+--+-- Resulting shortest implicants form a DNF (disjunctive normal form) formula that is+-- equivalent to the original (existentially quantified) formula.+shortestImplicants+  :: SAT.VarSet  -- ^ \(X\)+  -> CNF.CNF     -- ^ \(\phi\)+  -> IO [LitSet]+shortestImplicants xs formula =+  shortestImplicantsE (IntSet.fromList [1 .. CNF.cnfNumVars formula] IntSet.\\ xs) formula++-- | Given a set of variables \(X = \{x_1, \ldots, x_k\}\) and CNF formula \(\phi\),+-- this function computes shortest implicants of \(\exists X. \phi\).+--+-- Resulting shortest implicants form a DNF (disjunctive normal form) formula that is+-- equivalent to the original formula \(\exists X. \phi\).+shortestImplicantsE+  :: SAT.VarSet  -- ^ \(X\)+  -> CNF.CNF     -- ^ \(\phi\)+  -> IO [LitSet]+shortestImplicantsE xs formula = do+  let (tau_formula, info) = dualRailEncoding (IntSet.fromList [1 .. CNF.cnfNumVars formula] IntSet.\\ xs) formula   solver <- SAT.newSolver-  SAT.newVars_ solver (CNF.numVars tau_formula)-  forM_ (CNF.clauses tau_formula) (addClause solver)+  SAT.newVars_ solver (CNF.cnfNumVars tau_formula)+  forM_ (CNF.cnfClauses tau_formula) $ \c -> do+    SAT.addClause solver (SAT.unpackClause c)    ref <- newIORef [] @@ -122,22 +156,42 @@   loop 0   reverse <$> readIORef ref -project :: SAT.VarSet -> CNF.CNF -> IO CNF.CNF+-- | Given a CNF formula \(\phi\), this function returns another CNF formula \(\psi\)+-- that is equivalent to \(\neg\phi\).+negateCNF+  :: CNF.CNF    -- ^ \(\phi\)+  -> IO CNF.CNF -- ^ \(\psi \equiv \neg\phi\)+negateCNF formula = do+  implicants <- shortestImplicantsE IntSet.empty formula+  return $+    CNF.CNF+    { CNF.cnfNumVars = CNF.cnfNumVars formula+    , CNF.cnfNumClauses = length implicants+    , CNF.cnfClauses = map (SAT.packClause . map negate . IntSet.toList) implicants+    }++-- | Given a set of variables \(X = \{x_1, \ldots, x_k\}\) and CNF formula \(\phi\),+-- this function computes a CNF formula \(\psi\) that is equivalent to \(\exists X. \phi\)+-- (i.e. \((\exists X. \phi) \leftrightarrow \psi\)).+project+  :: SAT.VarSet  -- ^ \(X\)+  -> CNF.CNF     -- ^ \(\phi\)+  -> IO CNF.CNF  -- ^ \(\psi\) project xs cnf = do-  let ys = IntSet.fromList [1 .. CNF.numVars cnf] IntSet.\\ xs+  let ys = IntSet.fromList [1 .. CNF.cnfNumVars cnf] IntSet.\\ xs       nv = if IntSet.null ys then 0 else IntSet.findMax ys-  implicants <- shortestImplicants ys cnf+  implicants <- shortestImplicantsE xs cnf   let cnf' =         CNF.CNF-        { CNF.numVars = nv-        , CNF.numClauses = length implicants-        , CNF.clauses = map (map negate . IntSet.toList) implicants+        { CNF.cnfNumVars = nv+        , CNF.cnfNumClauses = length implicants+        , CNF.cnfClauses = map (SAT.packClause . map negate . IntSet.toList) implicants         }-  negated_implicates <- shortestImplicants ys cnf'-  let implicates = map (map negate . IntSet.toList) negated_implicates+  negated_implicates <- shortestImplicantsE xs cnf'+  let implicates = map (SAT.packClause . map negate . IntSet.toList) negated_implicates   return $     CNF.CNF-    { CNF.numVars = nv-    , CNF.numClauses = length implicates-    , CNF.clauses = implicates+    { CNF.cnfNumVars = nv+    , CNF.cnfNumClauses = length implicates+    , CNF.cnfClauses = implicates     }
src/ToySolver/SAT/MessagePassing/SurveyPropagation.hs view
@@ -53,17 +53,14 @@   , printInfo   ) where -import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Loop import Control.Monad-import qualified Data.Array.IArray as A import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.IORef-import Data.Maybe (fromJust) import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Unboxed as VU@@ -108,10 +105,10 @@   , svNThreadsRef :: !(IORef Int)   } -newSolver :: Int -> [(Double, SAT.Clause)] -> IO Solver+newSolver :: Int -> [(Double, SAT.PackedClause)] -> IO Solver newSolver nv clauses = do   let num_clauses = length clauses-      num_edges = sum [length c | (_,c) <- clauses]+      num_edges = sum [VG.length c | (_,c) <- clauses]    varEdgesRef <- newIORef IntMap.empty   clauseEdgesM <- VGM.new num_clauses@@ -121,7 +118,7 @@    ref <- newIORef 0   forM_ (zip [0..] clauses) $ \(i,(_,c)) -> do-    es <- forM c $ \lit -> do+    es <- forM (SAT.unpackClause c) $ \lit -> do       e <- readIORef ref       modifyIORef' ref (+1)       modifyIORef' varEdgesRef (IntMap.insertWith IntSet.union (abs lit) (IntSet.singleton e))@@ -181,7 +178,7 @@   return solver  deleteSolver :: Solver -> IO ()-deleteSolver solver = return ()+deleteSolver _solver = return ()  initializeRandom :: Solver -> Rand.GenIO -> IO () initializeRandom solver gen = do
src/ToySolver/SAT/MessagePassing/SurveyPropagation/OpenCL.hs view
@@ -49,7 +49,6 @@   , unfixLit   ) where -import Control.Applicative ((<$>)) import Control.Exception import Control.Loop import Control.Monad@@ -102,13 +101,13 @@   , svIterLimRef :: !(IORef (Maybe Int))   } -newSolver :: (String -> IO ()) -> CLContext -> CLDeviceID -> Int -> [(Double, SAT.Clause)] -> IO Solver+newSolver :: (String -> IO ()) -> CLContext -> CLDeviceID -> Int -> [(Double, SAT.PackedClause)] -> IO Solver newSolver outputMessage context dev nv clauses = do   _ <- clRetainContext context   queue <- clCreateCommandQueue context dev []    let num_clauses = length clauses-      num_edges = sum [length c | (_,c) <- clauses]+      num_edges = sum [VG.length c | (_,c) <- clauses]    (varEdgesTmp :: VM.IOVector [(Int,Bool,Double)]) <- VGM.replicate nv []   clauseOffset <- VGM.new num_clauses@@ -117,8 +116,8 @@   ref <- newIORef 0   forM_ (zip [0..] clauses) $ \(i,(w,c)) -> do     VGM.write clauseOffset i =<< liftM fromIntegral (readIORef ref)-    VGM.write clauseLength i (fromIntegral (length c))-    forM_ c $ \lit -> do+    VGM.write clauseLength i (fromIntegral (VG.length c))+    forM_ (SAT.unpackClause c) $ \lit -> do       e <- readIORef ref       modifyIORef' ref (+1) #if MIN_VERSION_vector(0,11,0)
src/ToySolver/SAT/PBO.hs view
@@ -189,7 +189,7 @@         AdaptiveSearch -> do           lim <- getTrialLimitConf opt           adaptiveSearch cxt solver lim-        _              -> error "ToySolver.SAT.PBO.minimize: should not happen"  +        _              -> error "ToySolver.SAT.PBO.minimize: should not happen"  getMethod :: Optimizer -> IO Method getMethod opt = readIORef (optMethodRef opt)
src/ToySolver/SAT/PBO/BCD.hs view
@@ -20,7 +20,7 @@ --   Improvements to Core-Guided binary search for MaxSAT, --   in Theory and Applications of Satisfiability Testing (SAT 2012), --   pp. 284-297.---   <http://dx.doi.org/10.1007/978-3-642-31612-8_22>+--   <https://doi.org/10.1007/978-3-642-31612-8_22> --   <http://ulir.ul.ie/handle/10344/2771> --  -----------------------------------------------------------------------------
src/ToySolver/SAT/PBO/BCD2.hs view
@@ -21,7 +21,7 @@ --   Improvements to Core-Guided binary search for MaxSAT, --   in Theory and Applications of Satisfiability Testing (SAT 2012), --   pp. 284-297.---   <http://dx.doi.org/10.1007/978-3-642-31612-8_22>+--   <https://doi.org/10.1007/978-3-642-31612-8_22> --   <http://ulir.ul.ie/handle/10344/2771> --  -----------------------------------------------------------------------------@@ -89,7 +89,7 @@     SAT.addClause solver [-sel]  getCoreLB :: CoreInfo -> IO Integer-getCoreLB = readIORef . coreLBRef            +getCoreLB = readIORef . coreLBRef  solve :: C.Context cxt => cxt -> SAT.Solver -> Options -> IO () solve cxt solver opt = solveWBO (C.normalize cxt) solver opt@@ -107,12 +107,12 @@   nsatRef   <- newIORef 1   nunsatRef <- newIORef 1 -  lastUBRef <- newIORef $ SAT.pbUpperBound obj+  lastUBRef <- newIORef $ SAT.pbLinUpperBound obj    coresRef <- newIORef []   let getLB = do         xs <- readIORef coresRef-        foldM (\s core -> do{ v <- getCoreLB core; return $! s + v }) 0 xs        +        foldM (\s core -> do{ v <- getCoreLB core; return $! s + v }) 0 xs    deductedWeightRef <- newIORef weights   let deductWeight d core =@@ -169,7 +169,7 @@           lastModel <- atomically $ C.getBestModel cxt           sels <- liftM IntMap.fromList $ forM cores $ \core -> do                                         coreLB <- getCoreLB core-            let coreUB = SAT.pbUpperBound (coreCostFun core)+            let coreUB = SAT.pbLinUpperBound (coreCostFun core)             if coreUB < coreLB then do               -- Note: we have detected unsatisfiability               C.logMessage cxt $ printf "BCD2: coreLB (%d) exceeds coreUB (%d)" coreLB coreUB
src/ToySolver/SAT/PBO/Context.hs view
@@ -72,7 +72,7 @@   ret <- getBestValue ctx   case ret of     Just val -> return $ val - 1-    Nothing -> return $ SAT.pbUpperBound $ getObjectiveFunction ctx+    Nothing -> return $ SAT.pbLinUpperBound $ getObjectiveFunction ctx  setFinished :: Context a => a -> IO () setFinished cxt = do@@ -151,7 +151,7 @@ newSimpleContext2 obj obj2 = do   unsatRef <- newTVarIO False   bestsolRef <- newTVarIO Nothing-  lbRef <- newTVarIO $! SAT.pbLowerBound obj+  lbRef <- newTVarIO $! SAT.pbLinLowerBound obj    onUpdateBestSolRef <- newIORef $ \_ _ -> return ()   onUpdateLBRef <- newIORef $ \_ -> return ()@@ -172,7 +172,7 @@     }  setOnUpdateBestSolution :: SimpleContext -> (SAT.Model -> Integer -> IO ()) -> IO ()-setOnUpdateBestSolution sc h = writeIORef (scOnUpdateBestSolutionRef sc) h +setOnUpdateBestSolution sc h = writeIORef (scOnUpdateBestSolutionRef sc) h  setOnUpdateLowerBound :: SimpleContext -> (Integer -> IO ()) -> IO () setOnUpdateLowerBound sc h = writeIORef (scOnUpdateLowerBoundRef sc) h
src/ToySolver/SAT/PBO/MSU4.hs view
@@ -15,7 +15,7 @@ --   Algorithms for Maximum Satisfiability using Unsatisfiable Cores. --   In Design, Automation and Test in Europe, 2008 (DATE '08). March 2008. --   pp. 408-413, doi:10.1109/date.2008.4484715.---   <http://dx.doi.org/10.1109/date.2008.4484715>+--   <https://doi.org/10.1109/date.2008.4484715> --   <http://eprints.soton.ac.uk/265000/1/jpms-date08.pdf> --   <http://www.csi.ucd.ie/staff/jpms/talks/talksite/jpms-date08.pdf> --
src/ToySolver/SAT/PBO/UnsatBased.hs view
@@ -15,7 +15,7 @@ -- * Vasco Manquinho Ruben Martins Inês Lynce --   Improving Unsatisfiability-based Algorithms for Boolean Optimization. --   Theory and Applications of Satisfiability Testing – SAT 2010, pp 181-193.---   <http://dx.doi.org/10.1007/978-3-642-14186-7_16>+--   <https://doi.org/10.1007/978-3-642-14186-7_16> --   <http://sat.inesc-id.pt/~ruben/papers/manquinho-sat10.pdf> --   <http://sat.inesc-id.pt/~ruben/talks/sat10-talk.pdf> --
+ src/ToySolver/SAT/SLS/ProbSAT.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  ToySolver.SAT.SLS.ProbSAT+-- Copyright   :  (c) Masahiro Sakai 2017+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+--+-- References:+--+----------------------------------------------------------------------+module ToySolver.SAT.SLS.ProbSAT+  ( Solver+  , newSolver+  , newSolverWeighted+  , getNumVars+  , getRandomGen+  , setRandomGen+  , getBestSolution+  , getStatistics++  , Options (..)+  , Callbacks (..)+  , Statistics (..)++  , generateUniformRandomSolution++  , probsat+  , walksat+  ) where++import Prelude hiding (break)++import Control.Exception+import Control.Loop+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt)+import Data.Array.IArray+import Data.Array.IO+import Data.Array.Unboxed+import Data.Array.Unsafe+import Data.Bits+import Data.Default.Class+import qualified Data.Foldable as F+import Data.Int+import Data.IORef+import Data.Maybe+import Data.Sequence ((|>))+import qualified Data.Sequence as Seq+import Data.Typeable+import Data.Word+import System.Clock+import qualified System.Random.MWC as Rand+import qualified System.Random.MWC.Distributions as Rand+import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Internal.Data.IOURef+import qualified ToySolver.Internal.Data.Vec as Vec+import qualified ToySolver.SAT.Types as SAT++-- -------------------------------------------------------------------++data Solver+  = Solver+  { svClauses                :: !(Array ClauseId PackedClause)+  , svClauseWeights          :: !(Array ClauseId CNF.Weight)+  , svClauseWeightsF         :: !(UArray ClauseId Double)+  , svClauseNumTrueLits      :: !(IOUArray ClauseId Int32)+  , svClauseUnsatClauseIndex :: !(IOUArray ClauseId Int)+  , svUnsatClauses           :: !(Vec.UVec ClauseId)++  , svVarOccurs         :: !(Array SAT.Var (UArray Int ClauseId))+  , svVarOccursState    :: !(Array SAT.Var (IOUArray Int Bool))+  , svSolution          :: !(IOUArray SAT.Var Bool)++  , svObj               :: !(IORef CNF.Weight)++  , svRandomGen         :: !(IORef Rand.GenIO)+  , svBestSolution      :: !(IORef (CNF.Weight, SAT.Model))+  , svStatistics        :: !(IORef Statistics)+  }++type ClauseId = Int++type PackedClause = Array Int SAT.Lit++newSolver :: CNF.CNF -> IO Solver+newSolver cnf = do+  let wcnf =+        CNF.WCNF+        { CNF.wcnfNumVars    = CNF.cnfNumVars cnf+        , CNF.wcnfNumClauses = CNF.cnfNumClauses cnf+        , CNF.wcnfTopCost    = fromIntegral (CNF.cnfNumClauses cnf) + 1+        , CNF.wcnfClauses    = [(1,c) | c <- CNF.cnfClauses cnf]+        }+  newSolverWeighted wcnf++newSolverWeighted :: CNF.WCNF -> IO Solver+newSolverWeighted wcnf = do+  let m :: SAT.Var -> Bool+      m _ = False+      nv = CNF.wcnfNumVars wcnf++  objRef <- newIORef (0::Integer)++  cs <- liftM catMaybes $ forM (CNF.wcnfClauses wcnf) $ \(w,pc) -> do+    case SAT.normalizeClause (SAT.unpackClause pc) of+      Nothing -> return Nothing+      Just [] -> modifyIORef' objRef (w+) >> return Nothing+      Just c  -> do+        let c' = listArray (0, length c - 1) c+        seq c' $ return (Just (w,c'))+  let len = length cs+      clauses  = listArray (0, len - 1) (map snd cs)+      weights  :: Array ClauseId CNF.Weight+      weights  = listArray (0, len - 1) (map fst cs)+      weightsF :: UArray ClauseId Double+      weightsF = listArray (0, len - 1) (map (fromIntegral . fst) cs)++  (varOccurs' :: IOArray SAT.Var (Seq.Seq (Int, Bool))) <- newArray (1, nv) Seq.empty++  clauseNumTrueLits <- newArray (bounds clauses) 0+  clauseUnsatClauseIndex <- newArray (bounds clauses) (-1)+  unsatClauses <- Vec.new++  forAssocsM_ clauses $ \(c,clause) -> do+    let n = sum [1 | lit <- elems clause, SAT.evalLit m lit]+    writeArray clauseNumTrueLits c n+    when (n == 0) $ do+      i <- Vec.getSize unsatClauses+      writeArray clauseUnsatClauseIndex c i+      Vec.push unsatClauses c+      modifyIORef objRef ((weights ! c) +)+    forM_ (elems clause) $ \lit -> do+      let v = SAT.litVar lit+      let b = SAT.evalLit m lit+      seq b $ modifyArray varOccurs' v (|> (c,b))++  varOccurs <- do+    (arr::IOArray SAT.Var (UArray Int ClauseId)) <- newArray_ (1, nv)+    forM_ [1 .. nv] $ \v -> do+      s <- readArray varOccurs' v+      writeArray arr v $ listArray (0, Seq.length s - 1) (map fst (F.toList s))+    unsafeFreeze arr++  varOccursState <- do+    (arr::IOArray SAT.Var (IOUArray Int Bool)) <- newArray_ (1, nv)+    forM_ [1 .. nv] $ \v -> do+      s <- readArray varOccurs' v+      ss <- newArray_ (0, Seq.length s - 1)+      forM_ (zip [0..] (F.toList s)) $ \(j,a) -> writeArray ss j (snd a)+      writeArray arr v ss+    unsafeFreeze arr++  solution <- newListArray (1, nv) $ [SAT.evalVar m v | v <- [1..nv]]++  bestObj <- readIORef objRef+  bestSol <- freeze solution+  bestSolution <- newIORef (bestObj, bestSol)++  randGen <- newIORef =<< Rand.create++  stat <- newIORef def++  return $+    Solver+    { svClauses = clauses+    , svClauseWeights          = weights+    , svClauseWeightsF         = weightsF+    , svClauseNumTrueLits      = clauseNumTrueLits+    , svClauseUnsatClauseIndex = clauseUnsatClauseIndex+    , svUnsatClauses           = unsatClauses++    , svVarOccurs         = varOccurs+    , svVarOccursState    = varOccursState+    , svSolution          = solution++    , svObj = objRef++    , svRandomGen         = randGen+    , svBestSolution      = bestSolution+    , svStatistics        = stat+    }+++flipVar :: Solver -> SAT.Var -> IO ()+flipVar solver v = mask_ $ do+  let occurs = svVarOccurs solver ! v+      occursState = svVarOccursState solver ! v+  seq occurs $ seq occursState $ return ()+  modifyArray (svSolution solver) v not+  forAssocsM_ occurs $ \(j,!c) -> do+    b <- unsafeRead occursState j+    n <- unsafeRead (svClauseNumTrueLits solver) c+    unsafeWrite occursState j (not b)+    if b then do+      unsafeWrite (svClauseNumTrueLits solver) c (n-1)+      when (n==1) $ do+        i <- Vec.getSize (svUnsatClauses solver)+        Vec.push (svUnsatClauses solver) c+        unsafeWrite (svClauseUnsatClauseIndex solver) c i+        modifyIORef' (svObj solver) (+ unsafeAt (svClauseWeights solver) c)+    else do+      unsafeWrite (svClauseNumTrueLits solver) c (n+1)+      when (n==0) $ do+        s <- Vec.getSize (svUnsatClauses solver)+        i <- unsafeRead (svClauseUnsatClauseIndex solver) c+        unless (i == s-1) $ do+          let i2 = s-1+          c2 <- Vec.unsafeRead (svUnsatClauses solver) i2+          Vec.unsafeWrite (svUnsatClauses solver) i2 c+          Vec.unsafeWrite (svUnsatClauses solver) i c2+          unsafeWrite (svClauseUnsatClauseIndex solver) c2 i+        _ <- Vec.unsafePop (svUnsatClauses solver)+        modifyIORef' (svObj solver) (subtract (unsafeAt (svClauseWeights solver) c))+        return ()++setSolution :: SAT.IModel m => Solver -> m -> IO ()+setSolution solver m = do+  b <- getBounds (svSolution solver)+  forM_ (range b) $ \v -> do+    val <- readArray (svSolution solver) v+    let val' = SAT.evalVar m v+    unless (val == val') $ do+      flipVar solver v++getNumVars :: Solver -> IO Int+getNumVars solver = return $ rangeSize $ bounds (svVarOccurs solver)++getRandomGen :: Solver -> IO Rand.GenIO+getRandomGen solver = readIORef (svRandomGen solver)++setRandomGen :: Solver -> Rand.GenIO -> IO ()+setRandomGen solver gen = writeIORef (svRandomGen solver) gen++getBestSolution :: Solver -> IO (CNF.Weight, SAT.Model)+getBestSolution solver = readIORef (svBestSolution solver)++getStatistics :: Solver -> IO Statistics+getStatistics solver = readIORef (svStatistics solver)++{-# INLINE getMakeValue #-}+getMakeValue :: Solver -> SAT.Var -> IO Double+getMakeValue solver v = do+  let occurs = svVarOccurs solver ! v+      (lb,ub) = bounds occurs+  seq occurs $ seq lb $ seq ub $+    numLoopState lb ub 0 $ \ !r !i -> do+      let c = unsafeAt occurs i+      n <- unsafeRead (svClauseNumTrueLits solver) c+      return $! if n == 0 then (r + unsafeAt (svClauseWeightsF solver) c) else r++{-# INLINE getBreakValue #-}+getBreakValue :: Solver -> SAT.Var -> IO Double+getBreakValue solver v = do+  let occurs = svVarOccurs solver ! v+      occursState = svVarOccursState solver ! v+      (lb,ub) = bounds occurs+  seq occurs $ seq occursState $ seq lb $ seq ub $+    numLoopState lb ub 0 $ \ !r !i -> do+      b <- unsafeRead occursState i+      if b then do+        let c = unsafeAt occurs i+        n <- unsafeRead (svClauseNumTrueLits solver) c+        return $! if n==1 then (r + unsafeAt (svClauseWeightsF solver) c) else r+      else+        return r++-- -------------------------------------------------------------------++data Options+  = Options+  { optTarget   :: !CNF.Weight+  , optMaxTries :: !Int+  , optMaxFlips :: !Int+  , optPickClauseWeighted :: Bool+  }+  deriving (Eq, Show)++instance Default Options where+  def =+    Options+    { optTarget   = 0+    , optMaxTries = 1+    , optMaxFlips = 100000+    , optPickClauseWeighted = False+    }++data Callbacks+  = Callbacks+  { cbGenerateInitialSolution :: Solver -> IO SAT.Model+  , cbOnUpdateBestSolution :: Solver -> CNF.Weight -> SAT.Model -> IO ()+  }++instance Default Callbacks where+  def =+    Callbacks+    { cbGenerateInitialSolution = generateUniformRandomSolution+    , cbOnUpdateBestSolution = \_ _ _ -> return ()+    }++data Statistics+  = Statistics+  { statTotalCPUTime   :: !TimeSpec+  , statFlips          :: !Int+  , statFlipsPerSecond :: !Double+  }+  deriving (Eq, Show)++instance Default Statistics where+  def =+    Statistics+    { statTotalCPUTime = 0+    , statFlips = 0+    , statFlipsPerSecond = 0+    }++-- -------------------------------------------------------------------++generateUniformRandomSolution :: Solver -> IO SAT.Model+generateUniformRandomSolution solver = do+  gen <- getRandomGen solver+  n <- getNumVars solver+  (a :: IOUArray Int Bool) <- newArray_ (1,n)+  forM_ [1..n] $ \v -> do+    b <- Rand.uniform gen+    writeArray a v b+  unsafeFreeze a++checkCurrentSolution :: Solver -> Callbacks -> IO ()+checkCurrentSolution solver cb = do+  best <- readIORef (svBestSolution solver)+  obj <- readIORef (svObj solver)+  when (obj < fst best) $ do+    sol <- freeze (svSolution solver)+    writeIORef (svBestSolution solver) (obj, sol)+    cbOnUpdateBestSolution cb solver obj sol++pickClause :: Solver -> Options -> IO PackedClause+pickClause solver opt = do+  gen <- getRandomGen solver+  if optPickClauseWeighted opt then do+    obj <- readIORef (svObj solver)+    let f !j !x = do+          c <- Vec.read (svUnsatClauses solver) j+          let w = svClauseWeights solver ! c+          if x < w then+            return c+          else+            f (j + 1) (x - w)+    x <- rand obj gen+    c <- f 0 x+    return $ (svClauses solver ! c)+  else do+    s <- Vec.getSize (svUnsatClauses solver)+    j <- Rand.uniformR (0, s - 1) gen -- For integral types inclusive range is used+    liftM (svClauses solver !) $ Vec.read (svUnsatClauses solver) j++rand :: PrimMonad m => Integer -> Rand.Gen (PrimState m) -> m Integer+rand n gen+  | n <= toInteger (maxBound :: Word32) = liftM toInteger $ Rand.uniformR (0, fromIntegral n - 1 :: Word32) gen+  | otherwise = do+      a <- rand (n `shiftR` 32) gen+      (b::Word32) <- Rand.uniform gen+      return $ (a `shiftL` 32) .|. toInteger b++data Finished = Finished+  deriving (Show, Typeable)++instance Exception Finished++-- -------------------------------------------------------------------++probsat :: Solver -> Options -> Callbacks -> (Double -> Double -> Double) -> IO ()+probsat solver opt cb f = do+  gen <- getRandomGen solver+  let maxClauseLen =+        if rangeSize (bounds (svClauses solver)) == 0+        then 0+        else maximum $ map (rangeSize . bounds) $ elems (svClauses solver)+  (wbuf :: IOUArray Int Double) <- newArray_ (0, maxClauseLen-1)+  wsumRef <- newIOURef (0 :: Double)++  let pickVar :: PackedClause -> IO SAT.Var+      pickVar c = do+        writeIOURef wsumRef 0+        forAssocsM_ c $ \(k,lit) -> do+          let v = SAT.litVar lit+          m <- getMakeValue solver v+          b <- getBreakValue solver v+          let w = f m b+          writeArray wbuf k w+          modifyIOURef wsumRef (+w)+        wsum <- readIOURef wsumRef++        let go :: Int -> Double -> IO Int+            go !k !a = do+              if not (inRange (bounds c) k) then do+                return $! snd (bounds c)+              else do+                w <- readArray wbuf k+                if a <= w then+                  return k+                else+                  go (k + 1) (a - w)+        k <- go 0 =<< Rand.uniformR (0, wsum) gen+        return $! SAT.litVar (c ! k)++  startCPUTime <- getTime ProcessCPUTime+  flipsRef <- newIOURef (0::Int)++  -- It's faster to use Control.Exception than using Control.Monad.Except+  let body = do+        replicateM_ (optMaxTries opt) $ do+          sol <- cbGenerateInitialSolution cb solver+          setSolution solver sol+          checkCurrentSolution solver cb+          replicateM_ (optMaxFlips opt) $ do+            s <- Vec.getSize (svUnsatClauses solver)+            when (s == 0) $ throw Finished+            obj <- readIORef (svObj solver)+            when (obj <= optTarget opt) $ throw Finished+            c <- pickClause solver opt+            v <- pickVar c+            flipVar solver v+            modifyIOURef flipsRef inc+            checkCurrentSolution solver cb+  body `catch` (\(_::Finished) -> return ())++  endCPUTime <- getTime ProcessCPUTime+  flips <- readIOURef flipsRef+  let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime+      totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int)+  writeIORef (svStatistics solver) $+    Statistics+    { statTotalCPUTime = totalCPUTime+    , statFlips = flips+    , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec+    }++  return ()++++walksat :: Solver -> Options -> Callbacks -> Double -> IO ()+walksat solver opt cb p = do+  gen <- getRandomGen solver+  (buf :: Vec.UVec SAT.Var) <- Vec.new++  let pickVar :: PackedClause -> IO SAT.Var+      pickVar c = do+        Vec.clear buf+        let (lb,ub) = bounds c+        r <- runExceptT $ do+          _ <- numLoopState lb ub (1.0/0.0) $ \ !b0 !i -> do+            let v = SAT.litVar (c ! i)+            b <- lift $ getBreakValue solver v+            if b <= 0 then+              throwE v -- freebie move+            else if b < b0 then do+              lift $ Vec.clear buf >> Vec.push buf v+              return b+            else if b == b0 then do+              lift $ Vec.push buf v+              return b0+            else do+              return b0+          return ()+        case r of+          Left v -> return v+          Right _ -> do+            flag <- Rand.bernoulli p gen+            if flag then do+              -- random walk move+              i <- Rand.uniformR (lb,ub) gen+              return $! SAT.litVar (c ! i)+            else do+              -- greedy move+              s <- Vec.getSize buf+              if s == 1 then+                Vec.unsafeRead buf 0+              else do+                i <- Rand.uniformR (0, s - 1) gen+                Vec.unsafeRead buf i++  startCPUTime <- getTime ProcessCPUTime+  flipsRef <- newIOURef (0::Int)++  -- It's faster to use Control.Exception than using Control.Monad.Except+  let body = do+        replicateM_ (optMaxTries opt) $ do+          sol <- cbGenerateInitialSolution cb solver+          setSolution solver sol+          checkCurrentSolution solver cb+          replicateM_ (optMaxFlips opt) $ do+            s <- Vec.getSize (svUnsatClauses solver)+            when (s == 0) $ throw Finished+            obj <- readIORef (svObj solver)+            when (obj <= optTarget opt) $ throw Finished+            c <- pickClause solver opt+            v <- pickVar c+            flipVar solver v+            modifyIOURef flipsRef inc+            checkCurrentSolution solver cb+  body `catch` (\(_::Finished) -> return ())++  endCPUTime <- getTime ProcessCPUTime+  flips <- readIOURef flipsRef+  let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime+      totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int)+  writeIORef (svStatistics solver) $+    Statistics+    { statTotalCPUTime = totalCPUTime+    , statFlips = flips+    , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec+    }++  return ()++-- -------------------------------------------------------------------++{-# INLINE modifyArray #-}+modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()+modifyArray a i f = do+  e <- readArray a i+  writeArray a i (f e)++{-# INLINE forAssocsM_ #-}+forAssocsM_ :: (IArray a e, Monad m) => a Int e -> ((Int,e) -> m ()) -> m ()+forAssocsM_ a f = do+  let (lb,ub) = bounds a+  numLoop lb ub $ \i ->+    f (i, unsafeAt a i)++{-# INLINE inc #-}+inc :: Integral a => a -> a+inc a = a+1+             +-- -------------------------------------------------------------------
src/ToySolver/SAT/Store/CNF.hs view
@@ -22,10 +22,10 @@ import Data.Primitive.MutVar import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq+import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.Text.CNF as CNF -data CNFStore m = CNFStore (MutVar (PrimState m) Int) (MutVar (PrimState m) (Seq SAT.Clause))+data CNFStore m = CNFStore (MutVar (PrimState m) Int) (MutVar (PrimState m) (Seq SAT.PackedClause))  instance PrimMonad m => SAT.NewVar m (CNFStore m) where   newVar (CNFStore ref _) = do@@ -35,7 +35,9 @@ instance PrimMonad m => SAT.AddClause m (CNFStore m) where   addClause (CNFStore _ ref) clause =     case SAT.normalizeClause clause of-      Just clause' -> modifyMutVar' ref (|> clause')+      Just clause' -> do+        let clause'' = SAT.packClause clause'+        seq clause'' $ modifyMutVar' ref (|> clause'')       Nothing -> return ()  newCNFStore :: PrimMonad m => m (CNFStore m)@@ -50,7 +52,7 @@   cs <- readMutVar ref2   return $      CNF.CNF-     { CNF.numVars = nv-     , CNF.numClauses = Seq.length cs-     , CNF.clauses = F.toList cs+     { CNF.cnfNumVars = nv+     , CNF.cnfNumClauses = Seq.length cs+     , CNF.cnfClauses = F.toList cs      }
src/ToySolver/SAT/Types.hs view
@@ -32,6 +32,11 @@   , evalClause   , clauseToPBLinAtLeast +  -- * Packed Clause+  , PackedClause+  , packClause+  , unpackClause+   -- * Cardinality Constraint   , AtLeast   , Exactly@@ -56,15 +61,19 @@   , evalPBLinSum   , evalPBLinAtLeast   , evalPBLinExactly-  , pbLowerBound-  , pbUpperBound-  , pbSubsume-  , evalPBConstraint+  , pbLinLowerBound+  , pbLinUpperBound+  , pbLinSubsume    -- * Non-linear Pseudo Boolean constraint   , PBTerm   , PBSum   , evalPBSum+  , evalPBConstraint+  , evalPBFormula+  , pbLowerBound+  , pbUpperBound+  , removeNegationFromPBSum    -- * XOR Clause   , XORClause@@ -90,7 +99,11 @@ import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU import qualified Data.PseudoBoolean as PBFile import ToySolver.Data.LBool import qualified ToySolver.Combinatorial.SubsetSum as SubsetSum@@ -211,6 +224,14 @@ clauseToPBLinAtLeast :: Clause -> PBLinAtLeast clauseToPBLinAtLeast xs = ([(1,l) | l <- xs], 1) +type PackedClause = VU.Vector Lit++packClause :: Clause -> PackedClause+packClause = VU.fromList++unpackClause :: PackedClause -> Clause+unpackClause = VU.toList+ type AtLeast = ([Lit], Int) type Exactly = ([Lit], Int) @@ -395,15 +416,15 @@ evalPBLinExactly :: IModel m => m -> PBLinAtLeast -> Bool evalPBLinExactly m (lhs,rhs) = evalPBLinSum m lhs == rhs -pbLowerBound :: PBLinSum -> Integer-pbLowerBound xs = sum [if c < 0 then c else 0 | (c,_) <- xs]+pbLinLowerBound :: PBLinSum -> Integer+pbLinLowerBound xs = sum [if c < 0 then c else 0 | (c,_) <- xs] -pbUpperBound :: PBLinSum -> Integer-pbUpperBound xs = sum [if c > 0 then c else 0 | (c,_) <- xs]+pbLinUpperBound :: PBLinSum -> Integer+pbLinUpperBound xs = sum [if c > 0 then c else 0 | (c,_) <- xs]  -- (Σi ci li ≥ rhs1) subsumes (Σi di li ≥ rhs2) iff rhs1≥rhs2 and di≥ci for all i.-pbSubsume :: PBLinAtLeast -> PBLinAtLeast -> Bool-pbSubsume (lhs1,rhs1) (lhs2,rhs2) =+pbLinSubsume :: PBLinAtLeast -> PBLinAtLeast -> Bool+pbLinSubsume (lhs1,rhs1) (lhs2,rhs2) =   rhs1 >= rhs2 && and [di >= ci | (ci,li) <- lhs1, let di = IntMap.findWithDefault 0 li lhs2']   where     lhs2' = IntMap.fromList [(l,c) | (c,l) <- lhs2]@@ -420,6 +441,31 @@     op' = case op of             PBFile.Ge -> (>=)             PBFile.Eq -> (==)++evalPBFormula :: IModel m => m -> PBFile.Formula -> Maybe Integer+evalPBFormula m formula = do+  guard $ all (evalPBConstraint m) $ PBFile.pbConstraints formula+  return $ evalPBSum m $ fromMaybe [] $ PBFile.pbObjectiveFunction formula++pbLowerBound :: PBSum -> Integer+pbLowerBound xs = sum [c | (c,ls) <- xs, c < 0 || null ls]++pbUpperBound :: PBSum -> Integer+pbUpperBound xs = sum [c | (c,ls) <- xs, c > 0 || null ls]++removeNegationFromPBSum :: PBSum -> PBSum+removeNegationFromPBSum ts =+  [(c, IntSet.toList m) | (m, c) <- Map.toList $ Map.unionsWith (+) $ map f ts, c /= 0]+  where+    f :: PBTerm -> Map VarSet Integer+    f (c, ls) = IntSet.foldl' g (Map.singleton IntSet.empty c) (IntSet.fromList ls)++    g :: Map VarSet Integer -> Lit -> Map VarSet Integer+    g m l+      | l > 0     = Map.mapKeysWith (+) (IntSet.insert v) m+      | otherwise = Map.unionWith (+) m $ Map.fromListWith (+) [(IntSet.insert v xs, negate c) | (xs,c) <- Map.toList m]+      where+        v = litVar l  -- | XOR clause --
+ src/ToySolver/SDP.hs view
@@ -0,0 +1,196 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.SDP+-- Copyright   :  (c) Masahiro Sakai 2017+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  exprimental+-- Portability :  non-portable+--+-- References:+--+-- * Convert Semidefinite program forms - Mathematics Stack Exchange+--   <https://math.stackexchange.com/questions/732658/convert-semidefinite-program-forms>+--+-----------------------------------------------------------------------------++module ToySolver.SDP+  ( dualize+  , DualizeInfo (..)+  ) where++import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific)+import ToySolver.Converter.Base+import qualified ToySolver.Text.SDPFile as SDPFile++-- | Given a primal-dual pair (P), (D), it returns another primal-dual pair (P'), (D')+-- such that (P) is equivalent to (D') and (D) is equivalent to (P').+dualize :: SDPFile.Problem -> (SDPFile.Problem, DualizeInfo)+dualize origProb =+  ( SDPFile.Problem+    { SDPFile.blockStruct = blockStruct+    , SDPFile.costs = d+    , SDPFile.matrices = a0 : as+    }+  , DualizeInfo m (SDPFile.blockStruct origProb)+  )+  where+    {- original:+       (P)+           min Σ_i=1^m c_i x_i+           s.t.+             X = Σ_i=1^m F_i x_i - F_0+             X ⪰ 0+       (D)+           max F_0 • Y+           s.t.+             F_i • Y = c_i  for i ∈ {1,…,m}+             Y ⪰ 0+       where+         x : variable over R^m+         c ∈ R^m+         F_0, F_1, … , F_m ∈ R^(n × n)+    -}+    m :: Int+    m = SDPFile.mDim origProb+    c :: [Scientific]+    c = SDPFile.costs origProb+    f0 :: SDPFile.Matrix+    fs :: [SDPFile.Matrix]+    f0:fs = SDPFile.matrices origProb++    {- transformed+       (P')+           min d^T・z+           s.t.+             Z = Σ_i=1^n Σ_j=1^i A_ij z_ij - A_0+             Z ⪰ 0+       (D')+           max A_0 • W+           s.t.+             A_ij • W = d_ij  for i ∈ {1,…,n}, j ∈ {1,…,i}+             W ⪰ 0+       where+         z : variable over R^{n(n+1)/2}+         d_ij ∈ R  for i ∈ {1,…,n}, j ∈ {1,…,i}+         d_ij = - F0 [i,j]              if i=j+              = - (F0 [i,j] + F0 [j,i]) otherwise+         A_0  ∈ R^((2m+n)×(2m+n))+         A_0  = diag(-c, c, 0_{n×n})+         A_ij ∈ R^((2m+n)×(2m+n))  for i ∈ {1,…,n}, j ∈ {1,…,i}+         A_ij [   k,   k] = - (if i=j then F_k [i,j] else F_k [i,j] + F_k [j,i]) for k∈{1,…,m}+         A_ij [ m+k, m+k] =   (if i=j then F_k [i,j] else F_k [i,j] + F_k [j,i]) for k∈{1,…,m}+         A_ij [2m+i,2m+j] = 1+         A_ij [2m+j,2m+i] = 1+         A_ij [  _ ,  _ ] = 0++       correspondence:+         W = diag(x+, x-, X)+         Y [i,j] = z_ij if j≤i+                 = z_ji otherwise+         Z = diag(0, 0, Y)+    -}+    blockStruct :: [Int]+    blockStruct = [-m, -m] ++ SDPFile.blockStruct origProb+    a0 :: SDPFile.Matrix+    a0 =+      [ Map.fromList [((j,j), -cj) | (j,cj) <- zip [1..m] c, cj /= 0]+      , Map.fromList [((j,j),  cj) | (j,cj) <- zip [1..m] c, cj /= 0]+      ] +++      [ Map.empty | _ <- SDPFile.blockStruct origProb]+    as :: [SDPFile.Matrix]+    as =+      [ [ Map.fromList [ ((k,k), - (if i == j then v else 2*v))+                       | (k,fk) <- zip [1..m] fs, let v = SDPFile.blockElem i j (fk!!b), v /= 0]+        , Map.fromList [ ((k,k),   (if i == j then v else 2*v))+                       | (k,fk) <- zip [1..m] fs, let v = SDPFile.blockElem i j (fk!!b), v /= 0]+        ] +++        [ if b /= b2 then+            Map.empty+          else if i == j then+            Map.singleton (i,j) 1+          else+            Map.fromList [((i,j),1), ((j,i),1)]+        | (b2, _) <- zip [0..] (SDPFile.blockStruct origProb)+        ]+      | (b,block) <- zip [0..] (SDPFile.blockStruct origProb)+      , (i,j) <- blockIndexes block+      ]+    d =+      [ - (if i == j then v else 2*v)+      | (b,block) <- zip [0..] (SDPFile.blockStruct origProb)+      , (i,j) <- blockIndexes block+      , let v = SDPFile.blockElem i j (f0 !! b)+      ]++blockIndexes :: Int -> [(Int,Int)]+blockIndexes n = if n >= 0 then [(i,j) | i <- [1..n], j <- [1..i]] else [(i,i) | i <- [1..(-n)]]++blockIndexesLen :: Int -> Int+blockIndexesLen n = if n >= 0 then n*(n+1) `div` 2 else -n+++data DualizeInfo = DualizeInfo Int [Int]+  deriving (Eq, Show, Read)++instance Transformer DualizeInfo where+  type Source DualizeInfo = SDPFile.Solution+  type Target DualizeInfo = SDPFile.Solution++instance ForwardTransformer DualizeInfo where+  transformForward (DualizeInfo _origM origBlockStruct) +    SDPFile.Solution+    { SDPFile.primalVector = xV+    , SDPFile.primalMatrix = xM+    , SDPFile.dualMatrix   = yM+    } =+    SDPFile.Solution+    { SDPFile.primalVector = zV+    , SDPFile.primalMatrix = zM+    , SDPFile.dualMatrix   = wM+    }+    where+      zV = concat [[SDPFile.blockElem i j block | (i,j) <- blockIndexes b] | (b,block) <- zip origBlockStruct yM]+      zM = Map.empty : Map.empty : yM+      wM =+        [ Map.fromList $ zipWith (\i x -> ((i,i), if x >= 0 then   x else 0)) [1..] xV+        , Map.fromList $ zipWith (\i x -> ((i,i), if x <= 0 then  -x else 0)) [1..] xV+        ] ++ xM++instance BackwardTransformer DualizeInfo where+  transformBackward (DualizeInfo origM origBlockStruct)+    SDPFile.Solution+    { SDPFile.primalVector = zV+    , SDPFile.primalMatrix = _zM+    , SDPFile.dualMatrix   = wM+    } =+    case wM of+      (xps:xns:xM) ->+        SDPFile.Solution+        { SDPFile.primalVector = xV+        , SDPFile.primalMatrix = xM+        , SDPFile.dualMatrix   = yM+        }+        where+          xV = [SDPFile.blockElem i i xps - SDPFile.blockElem i i xns | i <- [1..origM]]+          yM = f origBlockStruct zV+            where+              f [] _ = []+              f (block : blocks) zV1 =+                case splitAt (blockIndexesLen block) zV1 of+                  (vals, zV2) -> symblock (zip (blockIndexes block) vals) : f blocks zV2+      _ -> error "ToySolver.SDP.transformSolutionBackward: invalid solution"++symblock :: [((Int,Int), Scientific)] -> SDPFile.Block+symblock es = Map.fromList $ do+  e@((i,j),x) <- es+  if x == 0 then+    []+  else if i == j then+    return e+  else+    [e, ((j,i),x)]
src/ToySolver/SMT.hs view
@@ -197,7 +197,7 @@   | Unsupported   deriving (Show, Typeable) -instance E.Exception Exception    +instance E.Exception Exception  data Solver   = Solver@@ -985,7 +985,7 @@ checkSATAssuming :: Solver -> [Expr] -> IO Bool checkSATAssuming solver xs = do   l <- getContextLit solver-  named <- readIORef (smtNamedAssertions solver) +  named <- readIORef (smtNamedAssertions solver)    ref <- newIORef IntMap.empty   ls <- forM xs $ \x -> do
src/ToySolver/Text/CNF.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-}+-- {-# LANGUAGE BangPatterns #-}+-- {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Text.CNF--- Copyright   :  (c) Masahiro Sakai 2016+-- Copyright   :  (c) Masahiro Sakai 2016-2018 -- License     :  BSD-style --  -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  provisional--- Portability :  non-portable (FlexibleContexts, OverloadedStrings)+-- Portability :  non-portable --+-- Reader and Writer for DIMACS CNF and family of similar formats.+-- ------------------------------------------------------------------------------module ToySolver.Text.CNF+module ToySolver.Text.CNF {-# DEPRECATED "Use ToySolver.FileFormat.CNF instead" #-}   (     CNF (..) @@ -25,80 +28,24 @@   , cnfBuilder   ) where -import Prelude hiding (writeFile)+import Prelude hiding (readFile, writeFile) import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Builder-import Data.Char-import Data.Monoid-import System.IO hiding (writeFile)--import qualified ToySolver.SAT.Types as SAT--data CNF-  = CNF-  { numVars :: !Int-  , numClauses :: !Int-  , clauses :: [SAT.Clause]-  }-  deriving (Show, Eq, Ord)+import System.IO hiding (readFile, writeFile) -parseFile :: FilePath -> IO (Either String CNF)-parseFile filename = do-  s <- BS.readFile filename-  return $ parseByteString s+import ToySolver.FileFormat.CNF +-- | Parse a CNF file but returns an error message when parsing fails.+{-# DEPRECATED parseByteString "Use FileFormat.parse instead" #-} parseByteString :: BS.ByteString -> Either String CNF-parseByteString s =-  case BS.words l of-    (["p","cnf", nvar, nclause]) ->-      Right $-        CNF-        { numVars    = read $ BS.unpack nvar-        , numClauses = read $ BS.unpack nclause-        , clauses    = map parseClauseBS ls-        }-    _ ->-      Left "cannot find cnf header"-  where-    l :: BS.ByteString-    ls :: [BS.ByteString]-    (l:ls) = filter (not . isCommentBS) (BS.lines s)--parseClauseBS :: BS.ByteString -> SAT.Clause-parseClauseBS s = seqList xs $ xs-  where-    xs = go s-    go s =-      case BS.readInt (BS.dropWhile isSpace s) of-        Nothing -> error "ToySolver.Text.MaxSAT: parse error"-        Just (0,_) -> []-        Just (i,s') -> i : go s'--isCommentBS :: BS.ByteString -> Bool-isCommentBS s =-  case BS.uncons s of-    Just ('c',_) ->  True-    _ -> False--seqList :: [a] -> b -> b-seqList [] b = b-seqList (x:xs) b = seq x $ seqList xs b--writeFile :: FilePath -> CNF -> IO ()-writeFile filepath cnf = do-  withBinaryFile filepath WriteMode $ \h -> do-    hSetBuffering h (BlockBuffering Nothing)-    hPutBuilder h (cnfBuilder cnf)+parseByteString = parse +-- | Encode a 'CNF' to a 'Builder'+{-# DEPRECATED cnfBuilder "Use FileFormat.render instead" #-} cnfBuilder :: CNF -> Builder-cnfBuilder cnf = header <> mconcat (map f (clauses cnf))-  where-    header = mconcat-      [ byteString "p cnf "-      , intDec (numVars cnf), char7 ' '-      , intDec (numClauses cnf), char7 '\n'-      ]-    f c = mconcat [intDec lit <> char7 ' '| lit <- c] <> byteString "0\n"+cnfBuilder = render +-- | Output a 'CNF' to a Handle.+{-# DEPRECATED hPutCNF "Use FileFormat.render instead" #-} hPutCNF :: Handle -> CNF -> IO () hPutCNF h cnf = hPutBuilder h (cnfBuilder cnf)
src/ToySolver/Text/GCNF.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- |@@ -8,15 +7,10 @@ --  -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  provisional--- Portability :  non-portable (OverloadedStrings)--- --- References:--- --- * <http://www.satcompetition.org/2011/rules.pdf>---+-- Portability :  portable -- ------------------------------------------------------------------------------module ToySolver.Text.GCNF+module ToySolver.Text.GCNF {-# DEPRECATED "Use ToySolver.FileFormat.CNF instead" #-}   (     GCNF (..)   , GroupIndex@@ -33,112 +27,22 @@   ) where  import Prelude hiding (writeFile)-import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Builder-import Data.Char-import Data.Monoid-import qualified ToySolver.SAT.Types as SAT+import qualified Data.ByteString.Lazy.Char8 as BL import System.IO hiding (writeFile)-import ToySolver.Internal.TextUtil--data GCNF-  = GCNF-  { numVars        :: !Int-  , numClauses     :: !Int-  , lastGroupIndex :: !GroupIndex-  , clauses        :: [GClause]-  }--type GroupIndex = Int--type GClause = (GroupIndex, SAT.Clause)---parseFile :: FilePath -> IO (Either String GCNF)-parseFile filename = do-  s <- BS.readFile filename-  return $ parseByteString s--parseByteString :: BS.ByteString -> Either String GCNF-parseByteString s =-  case BS.words l of-    (["p","gcnf", nbvar', nbclauses', lastGroupIndex']) ->-      Right $-        GCNF-        { numVars        = read $ BS.unpack nbvar'-        , numClauses     = read $ BS.unpack nbclauses'-        , lastGroupIndex = read $ BS.unpack lastGroupIndex'-        , clauses        = map parseLineBS ls-        }-    (["p","cnf", nbvar', nbclause']) ->-      Right $-        GCNF-        { numVars        = read $ BS.unpack nbvar'-        , numClauses     = read $ BS.unpack nbclause'-        , lastGroupIndex = read $ BS.unpack nbclause'-        , clauses        = zip [1..] $ map parseCNFLineBS ls-        }-    _ ->-      Left "cannot find gcnf header"-  where-    l :: BS.ByteString-    ls :: [BS.ByteString]-    (l:ls) = filter (not . isCommentBS) (BS.lines s)-    -parseLineBS :: BS.ByteString -> GClause-parseLineBS s =-  case BS.uncons (BS.dropWhile isSpace s) of-    Just ('{', s1) ->-      case BS.readInt s1 of-        Just (idx,s2) | Just ('}', s3) <- BS.uncons s2 -> -          let ys = parseClauseBS s3-          in seq idx $ seqList ys $ (idx, ys)-        _ -> error "ToySolver.Text.GCNF: parse error"-    _ -> error "ToySolver.Text.GCNF: parse error"--parseCNFLineBS :: BS.ByteString -> SAT.Clause-parseCNFLineBS s = seq xs $ seqList xs $ xs-  where-    xs = parseClauseBS s--parseClauseBS :: BS.ByteString -> SAT.Clause-parseClauseBS s = seqList xs $ xs-  where-    xs = go s-    go s =-      case BS.readInt (BS.dropWhile isSpace s) of-        Nothing -> error "ToySolver.Text.GCNF: parse error"-        Just (0,_) -> []-        Just (i,s') -> i : go s'--isCommentBS :: BS.ByteString -> Bool-isCommentBS s =-  case BS.uncons s of-    Just ('c',_) ->  True-    _ -> False--seqList :: [a] -> b -> b-seqList [] b = b-seqList (x:xs) b = seq x $ seqList xs b+import ToySolver.FileFormat.CNF -writeFile :: FilePath -> GCNF -> IO ()-writeFile filepath gcnf = do-  withBinaryFile filepath WriteMode $ \h -> do-    hSetBuffering h (BlockBuffering Nothing)-    hPutGCNF h gcnf+-- | Parse a GCNF file but returns an error message when parsing fails.+{-# DEPRECATED parseByteString "Use FileFormat.parse instead" #-}+parseByteString :: BL.ByteString -> Either String GCNF+parseByteString = parse +-- | Encode a 'GCNF' to a 'Builder'+{-# DEPRECATED gcnfBuilder "Use FileFormat.render instead" #-} gcnfBuilder :: GCNF -> Builder-gcnfBuilder gcnf = header <> mconcat (map f (clauses gcnf))-  where-    header = mconcat-      [ byteString "p gcnf "-      , intDec (numVars gcnf), char7 ' '-      , intDec (numClauses gcnf), char7 ' '-      , intDec (lastGroupIndex gcnf), char7 '\n'-      ]-    f (idx,c) = char7 '{' <> intDec idx <> char7 '}' <>-                mconcat [char7 ' ' <> intDec lit | lit <- c] <>-                byteString " 0\n"+gcnfBuilder = render +-- | Output a 'GCNF' to a Handle.+{-# DEPRECATED hPutGCNF "Use FileFormat.render instead" #-} hPutGCNF :: Handle -> GCNF -> IO () hPutGCNF h gcnf = hPutBuilder h (gcnfBuilder gcnf)
− src/ToySolver/Text/MaxSAT.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module      :  ToySolver.Text.MaxSAT--- Copyright   :  (c) Masahiro Sakai 2012--- License     :  BSD-style--- --- Maintainer  :  masahiro.sakai@gmail.com--- Stability   :  provisional--- Portability :  portable--- --- References:--- --- * <http://maxsat.ia.udl.cat/requirements/>----------------------------------------------------------------------------------module ToySolver.Text.MaxSAT-  (-    WCNF (..)-  , WeightedClause-  , Weight--  -- * Parsing .cnf/.wcnf files-  , parseFile-  , parseByteString--  -- * Generating .wcnf files-  , writeFile-  , hPutWCNF-  , wcnfBuilder-  ) where--import Prelude hiding (writeFile)-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Builder-import Data.Char-import Data.Monoid-import System.IO hiding (writeFile)--import qualified ToySolver.SAT.Types as SAT-import ToySolver.Internal.TextUtil--data WCNF-  = WCNF-  { numVars    :: !Int-  , numClauses :: !Int-  , topCost    :: !Weight-  , clauses    :: [WeightedClause]-  }--type WeightedClause = (Weight, SAT.Clause)---- | Weigths must be greater than or equal to 1, and smaller than 2^63.-type Weight = Integer--parseFile :: FilePath -> IO (Either String WCNF)-parseFile filename = do-  s <- BS.readFile filename-  return $ parseByteString s--parseByteString :: BS.ByteString -> Either String WCNF-parseByteString s =-  case BS.words l of-    (["p","wcnf", nvar, nclause, top]) ->-      Right $-        WCNF-        { numVars    = read $ BS.unpack nvar-        , numClauses = read $ BS.unpack nclause-        , topCost    = read $ BS.unpack top-        , clauses    = map parseWCNFLineBS ls-        }-    (["p","wcnf", nvar, nclause]) ->-      Right $-        WCNF-        { numVars    = read $ BS.unpack nvar-        , numClauses = read $ BS.unpack nclause-          -- top must be greater than the sum of the weights of violated soft clauses.-        , topCost    = fromInteger $ 2^(63::Int) - 1-        , clauses    = map parseWCNFLineBS ls-        }-    (["p","cnf", nvar, nclause]) ->-      Right $-        WCNF-        { numVars    = read $ BS.unpack nvar-        , numClauses = read $ BS.unpack nclause-          -- top must be greater than the sum of the weights of violated soft clauses.-        , topCost    = fromInteger $ 2^(63::Int) - 1-        , clauses    = map parseCNFLineBS ls-        }-    _ ->-      Left "cannot find wcnf/cnf header"-  where-    l :: BS.ByteString-    ls :: [BS.ByteString]-    (l:ls) = filter (not . isCommentBS) (BS.lines s)--parseWCNFLineBS :: BS.ByteString -> WeightedClause-parseWCNFLineBS s =-  case BS.readInteger (BS.dropWhile isSpace s) of-    Nothing -> error "ToySolver.Text.MaxSAT: no weight"-    Just (w, s') -> seq w $ seq xs $ (w, xs)-      where-        xs = parseClauseBS s'--parseCNFLineBS :: BS.ByteString -> WeightedClause-parseCNFLineBS s = seq xs $ (1, xs)-  where-    xs = parseClauseBS s--parseClauseBS :: BS.ByteString -> SAT.Clause-parseClauseBS s = seqList xs $ xs-  where-    xs = go s-    go s =-      case BS.readInt (BS.dropWhile isSpace s) of-        Nothing -> error "ToySolver.Text.MaxSAT: parse error"-        Just (0,_) -> []-        Just (i,s') -> i : go s'--isCommentBS :: BS.ByteString -> Bool-isCommentBS s =-  case BS.uncons s of-    Just ('c',_) ->  True-    _ -> False--seqList :: [a] -> b -> b-seqList [] b = b-seqList (x:xs) b = seq x $ seqList xs b--writeFile :: FilePath -> WCNF -> IO ()-writeFile filepath wcnf = do-  withBinaryFile filepath WriteMode $ \h -> do-    hSetBuffering h (BlockBuffering Nothing)-    hPutWCNF h wcnf--wcnfBuilder :: WCNF -> Builder-wcnfBuilder wcnf = header <> mconcat (map f (clauses wcnf))-  where-    header = mconcat-      [ byteString "p wcnf "-      , intDec (numVars wcnf), char7 ' '-      , intDec (numClauses wcnf), char7 ' '-      , integerDec (topCost wcnf), char7 '\n'-      ]-    f (w,c) = integerDec w <> mconcat [char7 ' ' <> intDec lit | lit <- c] <> byteString " 0\n"--hPutWCNF :: Handle -> WCNF -> IO ()-hPutWCNF h wcnf = hPutBuilder h (wcnfBuilder wcnf)
src/ToySolver/Text/QDimacs.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      :  ToySolver.Text.QDimacs@@ -10,122 +9,43 @@ -- Stability   :  provisional -- Portability :  portable ----- References:------ * QDIMACS standard Ver. 1.1---   <http://www.qbflib.org/qdimacs.html>--- ------------------------------------------------------------------------------module ToySolver.Text.QDimacs+module ToySolver.Text.QDimacs {-# DEPRECATED "Use ToySolver.FileFormat.CNF instead" #-}   ( QDimacs (..)   , Quantifier (..)   , QuantSet   , Atom   , Lit   , Clause+  , PackedClause+  , packClause+  , unpackClause   , parseFile   , parseByteString++  -- * Generating .qdimacs files+  , writeFile+  , hPutQDimacs+  , qdimacsBuilder   ) where -import Control.DeepSeq+import Prelude hiding (writeFile)+import Data.ByteString.Builder import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Char--{--http://www.qbflib.org/qdimacs.html--<input> ::= <preamble> <prefix> <matrix> EOF--<preamble> ::= [<comment_lines>] <problem_line>-<comment_lines> ::= <comment_line> <comment_lines> | <comment_line> -<comment_line> ::= c <text> EOL-<problem_line> ::= p cnf <pnum> <pnum> EOL--<prefix> ::= [<quant_sets>]-<quant_sets> ::= <quant_set> <quant_sets> | <quant_set>-<quant_set> ::= <quantifier> <atom_set> 0 EOL-<quantifier> ::= e | a-<atom_set> ::= <pnum> <atom_set> | <pnum>--<matrix> ::= <clause_list>-<clause_list> ::= <clause> <clause_list> | <clause> -<clause> ::= <literal> <clause> | <literal> 0 EOL-<literal> ::= <num>--<text> ::= {A sequence of non-special ASCII characters}-<num> ::= {A 32-bit signed integer different from 0}-<pnum> ::= {A 32-bit signed integer greater than 0}--}--data QDimacs-  = QDimacs-  { numVars :: !Int-  , numClauses :: !Int-  , prefix :: [QuantSet]-  , matrix :: [Clause]-  }-  deriving (Eq, Ord, Show, Read)--data Quantifier-  = E -- ^ existential quantifier-  | A -- ^ universal quantifier-  deriving (Eq, Ord, Show, Read, Enum, Bounded)--type QuantSet = (Quantifier, [Atom])--type Atom = Int -- better to use Int32?--type Lit = Int -- better to use Int32--type Clause = [Lit]--parseFile :: FilePath -> IO (Either String QDimacs)-parseFile filename = do-  s <- BL.readFile filename-  return $ parseByteString s--parseByteString :: BL.ByteString -> (Either String QDimacs)-parseByteString = f . BL.lines-  where-    f [] = Left "QDimacs.parseByteString: premature end of file"-    f (l : ls) =-      case BL.uncons l of-        Nothing -> Left "QDimacs.parseByteString: no problem line"-        Just ('c', _) -> f ls-        Just ('p', s) ->-          case BL.words s of-            ["cnf", numVars', numClauses'] ->-              case parsePrefix ls of-                (prefix', ls') -> Right $-                  QDimacs-                  { numVars = read $ BL.unpack numVars'-                  , numClauses = read $ BL.unpack numClauses'-                  , prefix = prefix'-                  , matrix = parseClauses ls'-                  }-            _ -> Left "QDimacs.parseByteString: invalid problem line"-        Just (c, _) -> Left ("QDimacs.parseByteString: invalid prefix " ++ show c)+import System.IO hiding (writeFile)+import ToySolver.FileFormat.CNF -parsePrefix :: [BL.ByteString] -> ([QuantSet], [BL.ByteString])-parsePrefix = go []-  where-    go result [] = (reverse result, [])-    go result lls@(l : ls) =-      case BL.uncons l of-        Just (c,s)-          | c=='a' || c=='e' ->-              let atoms = readInts s-                  q = if c=='a' then A else E-              in seq q $ deepseq atoms $ go ((q, atoms) : result) ls-          | otherwise ->-              (reverse result, lls)-        _ -> error "QDimacs.parseProblem: invalid line"+-- | Parse a QDimacs file but returns an error message when parsing fails.+{-# DEPRECATED parseByteString "Use FileFormat.parse instead" #-}+parseByteString :: BL.ByteString -> Either String QDimacs+parseByteString = parse -parseClauses :: [BL.ByteString] -> [Clause]-parseClauses = map readInts+-- | Encode a 'QDimacs' to a 'Builder'+{-# DEPRECATED qdimacsBuilder "Use FileFormat.render instead" #-}+qdimacsBuilder :: QDimacs -> Builder+qdimacsBuilder = render -readInts :: BL.ByteString -> [Int]-readInts s =-  case BL.readInt (BL.dropWhile isSpace s) of-    Just (z, s') -> if z == 0 then [] else z : readInts s'-    Nothing -> []+-- | Output a 'QDimacs' to a Handle.+{-# DEPRECATED hPutQDimacs "Use FileFormat.render instead" #-}+hPutQDimacs :: Handle -> QDimacs -> IO ()+hPutQDimacs h qdimacs = hPutBuilder h (qdimacsBuilder qdimacs)
src/ToySolver/Text/SDPFile.hs view
@@ -27,7 +27,15 @@   , mDim   , nBlock   , blockElem+    -- * The solution type+  , Solution (..)+  , evalPrimalObjective+  , evalDualObjective +    -- * File I/O+  , readDataFile+  , writeDataFile+     -- * Construction   , DenseMatrix   , DenseBlock@@ -36,23 +44,23 @@   , diagBlock        -- * Rendering-  , render-  , renderSparse+  , renderData+  , renderSparseData      -- * Parsing   , ParseError   , parseData-  , parseDataFile   , parseSparseData-  , parseSparseDataFile   ) where -import Control.Applicative ((<*))+import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy as BL import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Scientific as B+import Data.Char+import qualified Data.Foldable as F import Data.List (intersperse) import Data.Monoid import Data.Scientific (Scientific)@@ -62,11 +70,13 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap+import System.FilePath (takeExtension)+import System.IO import qualified Text.Megaparsec as MegaParsec #if MIN_VERSION_megaparsec(6,0,0) import Data.Word import Data.Void-import Text.Megaparsec hiding (ParseError)+import Text.Megaparsec hiding (ParseError, oneOf) import Text.Megaparsec.Byte hiding (oneOf) import qualified Text.Megaparsec.Byte as MegaParsec import qualified Text.Megaparsec.Byte.Lexer as Lexer@@ -77,8 +87,11 @@ import Text.Megaparsec.Prim (MonadParsec ()) #endif -#if MIN_VERSION_megaparsec(6,0,0)+#if MIN_VERSION_megaparsec(7,0,0) type C e s m = (MonadParsec e s m, Token s ~ Word8)+type ParseError = MegaParsec.ParseErrorBundle BL.ByteString Void+#elif MIN_VERSION_megaparsec(6,0,0)+type C e s m = (MonadParsec e s m, Token s ~ Word8) type ParseError = MegaParsec.ParseError Word8 Void #elif MIN_VERSION_megaparsec(5,0,0) type C e s m = (MonadParsec e s m, Token s ~ Char)@@ -88,6 +101,11 @@ type ParseError = MegaParsec.ParseError #endif +#if MIN_VERSION_megaparsec(7,0,0)+anyChar :: C e s m => m Word8+anyChar = anySingle+#endif+ -- --------------------------------------------------------------------------- -- problem description -- ---------------------------------------------------------------------------@@ -116,6 +134,26 @@ blockElem i j b = Map.findWithDefault 0 (i,j) b  -- ---------------------------------------------------------------------------+-- solution+-- ---------------------------------------------------------------------------++data Solution+  = Solution+  { primalVector :: [Scientific] -- ^ The primal variable vector x+  , primalMatrix :: Matrix -- ^ The primal variable matrix X+  , dualMatrix   :: Matrix -- ^ The dual variable matrix Y+  }+  deriving (Show, Ord, Eq)++evalPrimalObjective :: Problem -> Solution -> Scientific+evalPrimalObjective prob sol = sum $ zipWith (*) (costs prob) (primalVector sol)++evalDualObjective :: Problem -> Solution -> Scientific+evalDualObjective Problem{ matrices = [] } _ = error "evalDualObjective: invalid problem data"+evalDualObjective Problem{ matrices = f0:_ } sol =+  sum $ zipWith (\blk1 blk2 -> F.sum (Map.intersectionWith (*) blk1 blk2)) f0 (dualMatrix sol)++-- --------------------------------------------------------------------------- -- construction -- --------------------------------------------------------------------------- @@ -133,6 +171,31 @@ diagBlock xs = Map.fromList [((i,i),x) | (i,x) <- zip [1..] xs]  -- ---------------------------------------------------------------------------+-- File I/O+-- ---------------------------------------------------------------------------++-- | Parse a SDPA format file (.dat) or a SDPA sparse format file (.dat-s)..+readDataFile :: FilePath -> IO Problem+readDataFile fname = do+  p <- case map toLower (takeExtension fname) of+    ".dat" -> return pDataFile+    ".dat-s" -> return pSparseDataFile+    ext -> ioError $ userError $ "unknown extension: " ++ ext+  s <- BL.readFile fname+  case parse (p <* eof) fname s of+    Left e -> throw (e :: ParseError)+    Right prob -> return prob++writeDataFile :: FilePath -> Problem -> IO ()+writeDataFile fname prob = do+  isSparse <- case map toLower (takeExtension fname) of+    ".dat" -> return False+    ".dat-s" -> return True+    ext -> ioError $ userError $ "unknown extension: " ++ ext+  withBinaryFile fname WriteMode $ \h -> do+    B.hPutBuilder h $ renderImpl isSparse prob++-- --------------------------------------------------------------------------- -- parsing -- --------------------------------------------------------------------------- @@ -140,22 +203,10 @@ parseData :: String -> BL.ByteString -> Either ParseError Problem parseData = parse (pDataFile <* eof) --- | Parse a SDPA format file (.dat).-parseDataFile :: FilePath -> IO (Either ParseError Problem)-parseDataFile fname = do-  s <- BL.readFile fname-  return $! parse (pDataFile <* eof) fname s- -- | Parse a SDPA sparse format (.dat-s) string. parseSparseData :: String -> BL.ByteString -> Either ParseError Problem parseSparseData = parse (pSparseDataFile <* eof) --- | Parse a SDPA sparse format file (.dat-s).-parseSparseDataFile :: FilePath -> IO (Either ParseError Problem)-parseSparseDataFile fname = do-  s <- BL.readFile fname-  return $! parse (pSparseDataFile <* eof) fname s- pDataFile :: C e s m => m Problem pDataFile = do   _ <- many pComment@@ -293,11 +344,11 @@ -- rendering -- --------------------------------------------------------------------------- -render :: Problem -> Builder-render = renderImpl False+renderData :: Problem -> Builder+renderData = renderImpl False -renderSparse :: Problem -> Builder-renderSparse = renderImpl True+renderSparseData :: Problem -> Builder+renderSparseData = renderImpl True  renderImpl :: Bool -> Problem -> Builder renderImpl sparse prob = mconcat
+ src/ToySolver/Text/WCNF.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  ToySolver.Text.WCNF+-- Copyright   :  (c) Masahiro Sakai 2012+-- License     :  BSD-style+-- +-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module ToySolver.Text.WCNF {-# DEPRECATED "Use ToySolver.FileFormat.CNF instead" #-}+  (+    WCNF (..)+  , WeightedClause+  , Weight++  -- * Parsing .cnf/.wcnf files+  , parseFile+  , parseByteString++  -- * Generating .wcnf files+  , writeFile+  , hPutWCNF+  , wcnfBuilder+  ) where++import Prelude hiding (writeFile)+import Data.ByteString.Builder+import qualified Data.ByteString.Lazy.Char8 as BL+import System.IO hiding (writeFile)+import ToySolver.FileFormat.CNF++-- | Parse a WCNF file but returns an error message when parsing fails.+{-# DEPRECATED parseByteString "Use FileFormat.parse instead" #-}+parseByteString :: BL.ByteString -> Either String WCNF+parseByteString = parse++-- | Encode a 'WCNF' to a 'Builder'+{-# DEPRECATED wcnfBuilder "Use FileFormat.render instead" #-}+wcnfBuilder :: WCNF -> Builder+wcnfBuilder = render++-- | Output a 'WCNF' to a Handle.+{-# DEPRECATED hPutWCNF "Use FileFormat.render instead" #-}+hPutWCNF :: Handle -> WCNF -> IO ()+hPutWCNF h wcnf = hPutBuilder h (wcnfBuilder wcnf)
src/ToySolver/Version.hs view
@@ -21,6 +21,9 @@ #ifdef VERSION_OptDir   , ("OptDir", VERSION_OptDir) #endif+#ifdef VERSION_ansi_wl_pprint+  , ("ansi-wl-pprint", VERSION_ansi_wl_pprint)+#endif #ifdef VERSION_array   , ("array", VERSION_array) #endif@@ -36,6 +39,12 @@ #ifdef VERSION_bytestring_builder   , ("bytestring-builder", VERSION_bytestring_builder) #endif+#ifdef VERSION_bytestring_encoding+  , ("bytestring-encoding", VERSION_bytestring_encoding)+#endif+#ifdef VERSION_case_insensitive+  , ("case-insensitive", VERSION_case_insensitive)+#endif #ifdef VERSION_clock   , ("clock", VERSION_clock) #endif@@ -108,11 +117,14 @@ #ifdef VERSION_mwc_random   , ("mwc-random", VERSION_mwc_random) #endif+#ifdef VERSION_optparse_applicative+  , ("optparse-applicative", VERSION_optparse_applicative)+#endif #ifdef VERSION_parsec   , ("parsec", VERSION_parsec) #endif-#ifdef VERSION_prettyclass-  , ("prettyclass", VERSION_prettyclass)+#ifdef VERSION_pretty+  , ("pretty", VERSION_pretty) #endif #ifdef VERSION_primes   , ("primes", VERSION_primes)@@ -176,6 +188,9 @@ #endif #ifdef VERSION_xml_conduit   , ("xml-conduit", VERSION_xml_conduit)+#endif+#ifdef VERSION_zlib+  , ("zlib", VERSION_zlib) #endif   ]
src/ToySolver/Version/TH.hs view
@@ -9,7 +9,7 @@ import Control.Monad import Data.Time import System.Process-import Language.Haskell.TH    +import Language.Haskell.TH  getGitHash :: IO (Maybe String) getGitHash =@@ -26,4 +26,4 @@ compilationTimeQ :: ExpQ compilationTimeQ = do   tm <- runIO getCurrentTime-  [| read $(litE (stringL (show tm))) :: UTCTime |] +  [| read $(litE (stringL (show tm))) :: UTCTime |]
test/Test/Arith.hs view
@@ -142,8 +142,8 @@     y = LA.var 1     t1 = 11*^x ^+^ 13*^y     t2 = 7*^x ^-^ 9*^y-     + genLAExpr :: [Var] -> Gen (LA.Expr Rational) genLAExpr vs = do   size <- choose (0,3)@@ -412,9 +412,11 @@ prop_Simplex_backtrack = QM.monadicIO $ do    (vs,cs) <- QM.pick genQFLAConj    (vs2,cs2) <- QM.pick genQFLAConj+   config <- QM.pick arbitrary     join $ QM.run $ do      solver <- Simplex.newSolver+     Simplex.setConfig solver config      m <- liftM IM.fromList $ forM (IS.toList (vs `IS.union` vs2)) $ \v -> do        v2 <- Simplex.newVar solver        return (v, LA.var v2)@@ -435,9 +437,11 @@ prop_Simplex_explain :: Property prop_Simplex_explain = QM.monadicIO $ do    (vs,cs) <- QM.pick genQFLAConj+   config <- QM.pick arbitrary     let f p = QM.run $ do          solver <- Simplex.newSolver+         Simplex.setConfig solver config          m <- liftM IM.fromList $ forM (IS.toList vs) $ \v -> do            v2 <- Simplex.newVar solver            return (v, LA.var v2)@@ -459,6 +463,19 @@        forM_ (IS.toList e) $ \i -> do          ret3 <- f (`IS.member` (IS.delete i e))          QM.assert (isNothing ret3)++instance Arbitrary Simplex.Config where+  arbitrary = do+    ps <- arbitrary+    enableBoundTightening <- arbitrary+    return $+      Simplex.Config+      { Simplex.configPivotStrategy = ps+      , Simplex.configEnableBoundTightening = enableBoundTightening+      }++instance Arbitrary Simplex.PivotStrategy where+  arbitrary = arbitraryBoundedEnum  ------------------------------------------------------------------------
test/Test/BitVector.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-}@@ -9,10 +10,11 @@ import Test.Tasty.TH import qualified Test.QuickCheck.Monadic as QM -import Control.Applicative import Control.Monad-import Data.Monoid import Data.Maybe+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif  import ToySolver.Data.OrdRel import qualified ToySolver.BitVector as BV
test/Test/BoolExpr.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Test.BoolExpr (boolExprTestGroup) where -import Control.Applicative import Test.QuickCheck.Function import Test.Tasty import Test.Tasty.QuickCheck hiding ((.&&.), (.||.))
+ test/Test/CNF.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.CNF (cnfTestGroup) where++import Control.Monad+import Data.ByteString.Builder+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.TH+import qualified ToySolver.FileFormat.CNF as CNF++import Test.SAT.Utils++------------------------------------------------------------------------++prop_CNF_ReadWrite_Invariance :: Property+prop_CNF_ReadWrite_Invariance = forAll arbitraryCNF $ \cnf ->+  CNF.parse (toLazyByteString (CNF.render cnf)) == Right cnf++prop_GCNF_ReadWrite_Invariance :: Property+prop_GCNF_ReadWrite_Invariance = forAll arbitraryGCNF $ \gcnf ->+  CNF.parse (toLazyByteString (CNF.render gcnf)) == Right gcnf++prop_WCNF_ReadWrite_Invariance :: Property+prop_WCNF_ReadWrite_Invariance = forAll arbitraryWCNF $ \wcnf ->+  CNF.parse (toLazyByteString (CNF.render wcnf)) == Right wcnf++prop_QDimacs_ReadWrite_Invariance :: Property+prop_QDimacs_ReadWrite_Invariance = forAll arbitraryQDimacs $ \qdimacs ->+  CNF.parse (toLazyByteString (CNF.render qdimacs)) == Right qdimacs++prop_GCNF_from_CNF :: Property+prop_GCNF_from_CNF = forAll arbitraryCNF $ \cnf ->+  case CNF.parse (toLazyByteString (CNF.render cnf)) of+    Left _ -> False+    Right gcnf -> and+      [ CNF.gcnfNumVars gcnf == CNF.cnfNumVars cnf+      , CNF.gcnfNumClauses gcnf == CNF.cnfNumClauses cnf+      , CNF.gcnfLastGroupIndex gcnf == CNF.cnfNumClauses cnf+      , CNF.gcnfClauses gcnf == zip [1..] (CNF.cnfClauses cnf)+      ]++prop_WCNF_from_CNF :: Property+prop_WCNF_from_CNF = forAll arbitraryCNF $ \cnf ->+  case CNF.parse (toLazyByteString (CNF.render cnf)) of+    Left _ -> False+    Right wcnf -> and+      [ CNF.wcnfNumVars wcnf == CNF.cnfNumVars cnf+      , CNF.wcnfNumClauses wcnf == CNF.cnfNumClauses cnf+      , CNF.wcnfTopCost wcnf > fromIntegral (CNF.cnfNumClauses cnf)+      , CNF.wcnfClauses wcnf == map (\c -> (1,c)) (CNF.cnfClauses cnf)+      ]++prop_QDimacs_from_CNF :: Property+prop_QDimacs_from_CNF = forAll arbitraryCNF $ \cnf ->+  case CNF.parse (toLazyByteString (CNF.render cnf)) of+    Left _ -> False+    Right qdimacs -> and+      [ CNF.qdimacsNumVars qdimacs == CNF.cnfNumVars cnf+      , CNF.qdimacsNumClauses qdimacs == CNF.cnfNumClauses cnf+      , CNF.qdimacsPrefix qdimacs == []+      , CNF.qdimacsMatrix qdimacs == CNF.cnfClauses cnf+      ]++------------------------------------------------------------------------+-- Test harness++cnfTestGroup :: TestTree+cnfTestGroup = $(testGroupGenerator)
+ test/Test/Converter.hs view
@@ -0,0 +1,349 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.Converter (converterTestGroup) where++import Control.Monad+import Data.Array.IArray+import qualified Data.Foldable as F+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import qualified Data.Vector.Generic as VG++import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&&.), (.||.))+import Test.Tasty.TH+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Monadic as QM++import ToySolver.Converter+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.MaxCut as MaxCut+import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.Types as SAT++import qualified Data.PseudoBoolean as PBFile++import Test.SAT.Utils+++prop_sat2naesat_forward :: Property+prop_sat2naesat_forward = forAll arbitraryCNF $ \cnf ->+  let ret@(nae,info) = sat2naesat cnf+   in counterexample (show ret) $ +        forAllAssignments (CNF.cnfNumVars cnf) $ \m ->+          evalCNF m cnf === evalNAESAT (transformForward info m) nae++prop_sat2naesat_backward :: Property+prop_sat2naesat_backward = forAll arbitraryCNF $ \cnf ->+  let ret@(nae,info) = sat2naesat cnf+   in counterexample (show ret) $ +        forAllAssignments (fst nae) $ \m ->+          evalCNF (transformBackward info m) cnf === evalNAESAT m nae++prop_naesat2sat_forward :: Property+prop_naesat2sat_forward = forAll arbitraryNAESAT $ \nae ->+  let ret@(cnf,info) = naesat2sat nae+   in counterexample (show ret) $ +        forAllAssignments (fst nae) $ \m ->+          evalNAESAT m nae === evalCNF (transformForward info m) cnf++prop_naesat2sat_backward :: Property+prop_naesat2sat_backward = forAll arbitraryNAESAT $ \nae ->+  let ret@(cnf,info) = naesat2sat nae+   in counterexample (show ret) $+        forAllAssignments (CNF.cnfNumVars cnf) $ \m ->+          evalNAESAT (transformBackward info m) nae === evalCNF m cnf++prop_naesat2naeksat_forward :: Property+prop_naesat2naeksat_forward =+  forAll arbitraryNAESAT $ \nae ->+  forAll (choose (3,10)) $ \k ->+    let ret@(nae',info) = naesat2naeksat k nae+     in counterexample (show ret) $+          property (all (\c -> VG.length c <= k) (snd nae'))+          QC..&&.+          (forAllAssignments (fst nae) $ \m ->+             evalNAESAT m nae === evalNAESAT (transformForward info m) nae')++prop_naesat2naeksat_backward :: Property+prop_naesat2naeksat_backward =+  forAll arbitraryNAESAT $ \nae ->+  forAll (choose (3,10)) $ \k ->+    let ret@(nae',info) = naesat2naeksat k nae+     in counterexample (show ret) $+          forAll (arbitraryAssignment (fst nae')) $ \m ->+            evalNAESAT (transformBackward info m) nae || not (evalNAESAT m nae')++prop_naesat2maxcut_forward :: Property+prop_naesat2maxcut_forward =+  forAll arbitraryNAESAT $ \nae ->+    let ret@((maxcut, threshold), info) = naesat2maxcut nae+     in counterexample (show ret) $+          forAllAssignments (fst nae) $ \m ->+            evalNAESAT m nae === (MaxCut.eval (transformForward info m) maxcut >= threshold)++prop_naesat2max2sat_forward :: Property+prop_naesat2max2sat_forward =+  forAll arbitraryNAESAT $ \nae ->+    let ret@((wcnf, threshold), info) = naesat2max2sat nae+     in counterexample (show ret) $+          forAllAssignments (fst nae) $ \m ->+            case evalWCNF (transformForward info m) wcnf of+              Nothing -> property False+              Just v -> evalNAESAT m nae === (v <= threshold)++------------------------------------------------------------------------++prop_satToMaxSAT2_forward :: Property+prop_satToMaxSAT2_forward =+  forAll arbitraryCNF $ \cnf ->+    let ((wcnf, threshold), info) = satToMaxSAT2 cnf+    in and+       [ evalCNF m cnf == b2+       | m <- allAssignments (CNF.cnfNumVars cnf)+       , let m2 = transformForward info m+             b2 = case evalWCNF m2 wcnf of+                    Nothing -> False+                    Just v -> v <= threshold+       ]++prop_simplifyMaxSAT2_forward :: Property+prop_simplifyMaxSAT2_forward =+  forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->+    let r@((_n,cs,th2), info) = simplifyMaxSAT2 (wcnf, th1)+    in counterexample (show r) $ and+       [ b1 == b2+       | m1 <- allAssignments (CNF.wcnfNumVars wcnf)+       , let o1 = fromJust $ evalWCNF m1 wcnf+             b1 = o1 <= th1+             m2 = transformForward info m1+             o2 = fromIntegral $ length [()| (l1,l2) <- Set.toList cs, not (SAT.evalLit m2 l1), not (SAT.evalLit m2 l2)]+             b2 = o2 <= th2+       ]++prop_maxSAT2ToSimpleMaxCut_forward :: Property+prop_maxSAT2ToSimpleMaxCut_forward =+  forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->+    let r@((maxcut, th2), info) = maxSAT2ToSimpleMaxCut (wcnf, th1)+    in counterexample (show r) $ and+       [ b1 == b2+       | m <- allAssignments (CNF.wcnfNumVars wcnf)+       , let o1 = fromJust $ evalWCNF m wcnf+             b1 = o1 <= th1+             sol2 = transformForward info m+             o2 = MaxCut.eval sol2 maxcut+             b2 = o2 >= th2+       ]++------------------------------------------------------------------------++prop_pb2sat :: Property+prop_pb2sat = QM.monadicIO $ do+  pb@(nv,cs) <- QM.pick arbitraryPB+  let f (PBRelGE,lhs,rhs) = ([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs)+      f (PBRelLE,lhs,rhs) = ([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs)+      f (PBRelEQ,lhs,rhs) = ([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs)+  let opb = PBFile.Formula+            { PBFile.pbObjectiveFunction = Nothing+            , PBFile.pbNumVars = nv+            , PBFile.pbNumConstraints = length cs+            , PBFile.pbConstraints = map f cs+            }+  let (cnf, info) = pb2sat opb++  solver1 <- arbitrarySolver+  solver2 <- arbitrarySolver+  ret1 <- QM.run $ solvePB solver1 pb+  ret2 <- QM.run $ solveCNF solver2 cnf+  QM.assert $ isJust ret1 == isJust ret2+  case ret1 of+    Nothing -> return ()+    Just m1 -> do+      let m2 = transformForward info m1+      QM.assert $ bounds m2 == (1, CNF.cnfNumVars cnf)+      QM.assert $ evalCNF m2 cnf+  case ret2 of+    Nothing -> return ()+    Just m2 -> do+      let m1 = transformBackward info m2+      QM.assert $ bounds m1 == (1, nv)+      QM.assert $ evalPB m1 pb++prop_wbo2maxsat :: Property+prop_wbo2maxsat = QM.monadicIO $ do+  wbo1@(nv,cs,top) <- QM.pick arbitraryWBO+  let f (w,(PBRelGE,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs))+      f (w,(PBRelLE,lhs,rhs)) = (w,([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs))+      f (w,(PBRelEQ,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs))+  let wbo1' = PBFile.SoftFormula+            { PBFile.wboNumVars = nv+            , PBFile.wboNumConstraints = length cs+            , PBFile.wboConstraints = map f cs+            , PBFile.wboTopCost = top+            }+  let (wcnf, info) = wbo2maxsat wbo1'+      wbo2 = ( CNF.wcnfNumVars wcnf+             , [ ( if w == CNF.wcnfTopCost wcnf then Nothing else Just w+                 , (PBRelGE, [(1,l) | l <- SAT.unpackClause clause], 1)+                 )+               | (w,clause) <- CNF.wcnfClauses wcnf+               ]+             , Nothing+             )++  solver1 <- arbitrarySolver+  solver2 <- arbitrarySolver+  method <- QM.pick arbitrary+  ret1 <- QM.run $ optimizeWBO solver1 method wbo1+  ret2 <- QM.run $ optimizeWBO solver2 method wbo2+  QM.assert $ isJust ret1 == isJust ret2+  case ret1 of+    Nothing -> return ()+    Just (m1,val) -> do+      let m2 = transformForward info m1+      QM.assert $ bounds m2 == (1, CNF.wcnfNumVars wcnf)+      QM.assert $ evalWBO m2 wbo2 == Just val+  case ret2 of+    Nothing -> return ()+    Just (m2,val) -> do+      let m1 = transformBackward info m2+      QM.assert $ bounds m1 == (1, nv)+      QM.assert $ evalWBO m1 wbo1 == Just val++prop_wbo2pb :: Property+prop_wbo2pb = QM.monadicIO $ do+  wbo@(nv,cs,top) <- QM.pick arbitraryWBO+  let f (w,(PBRelGE,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs))+      f (w,(PBRelLE,lhs,rhs)) = (w,([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs))+      f (w,(PBRelEQ,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs))+  let wbo' = PBFile.SoftFormula+            { PBFile.wboNumVars = nv+            , PBFile.wboNumConstraints = length cs+            , PBFile.wboConstraints = map f cs+            , PBFile.wboTopCost = top+            }+  let (opb, info) = wbo2pb wbo'+      obj = fromMaybe [] $ PBFile.pbObjectiveFunction opb+      f (lhs, PBFile.Ge, rhs) = (PBRelGE, lhs, rhs)+      f (lhs, PBFile.Eq, rhs) = (PBRelEQ, lhs, rhs)+      cs2 = map f (PBFile.pbConstraints opb)+      pb = (PBFile.pbNumVars opb, obj, cs2)++  solver1 <- arbitrarySolver+  solver2 <- arbitrarySolver+  method <- QM.pick arbitrary+  ret1 <- QM.run $ optimizeWBO solver1 method wbo+  ret2 <- QM.run $ optimizePBNLC solver2 method pb+  QM.assert $ isJust ret1 == isJust ret2+  case ret1 of+    Nothing -> return ()+    Just (m1,val1) -> do+      let m2 = transformForward info m1+      QM.assert $ bounds m2 == (1, PBFile.pbNumVars opb)+      QM.assert $ evalPBNLC m2 (PBFile.pbNumVars opb, cs2)+      QM.assert $ SAT.evalPBSum m2 obj == val1+  case ret2 of+    Nothing -> return ()+    Just (m2,val2) -> do+      let m1 = transformBackward info m2+      QM.assert $ bounds m1 == (1,nv)+      QM.assert $ evalWBO m1 wbo == Just val2++prop_sat2ksat :: Property+prop_sat2ksat = QM.monadicIO $ do+  k <- QM.pick $ choose (3,10)++  cnf1 <- QM.pick arbitraryCNF+  let (cnf2, info) = sat2ksat k cnf1++  solver1 <- arbitrarySolver+  solver2 <- arbitrarySolver+  ret1 <- QM.run $ solveCNF solver1 cnf1+  ret2 <- QM.run $ solveCNF solver2 cnf2+  QM.assert $ isJust ret1 == isJust ret2+  case ret1 of+    Nothing -> return ()+    Just m1 -> do+      let m2 = transformForward info m1+      QM.assert $ bounds m2 == (1, CNF.cnfNumVars cnf2)+      QM.assert $ evalCNF m2 cnf2+  case ret2 of+    Nothing -> return ()+    Just m2 -> do+      let m1 = transformBackward info m2+      QM.assert $ bounds m1 == (1, CNF.cnfNumVars cnf1)+      QM.assert $ evalCNF m1 cnf1++prop_quadratizePB :: Property+prop_quadratizePB =+  forAll arbitraryPBFormula $ \pb ->+    let ((pb2,th), info) = quadratizePB pb+     in counterexample (show (pb2,th)) $+          conjoin+          [ property $ F.all (\t -> IntSet.size t <= 2) $ collectTerms pb2+          , property $ PBFile.pbNumConstraints pb === PBFile.pbNumConstraints pb2+          , forAll (arbitraryAssignment (PBFile.pbNumVars pb)) $ \m ->+              SAT.evalPBFormula m pb === eval2 (transformForward info m) (pb2,th)+          , forAll (arbitraryAssignment (PBFile.pbNumVars pb2)) $ \m ->+              case eval2 m (pb2,th) of+                Just o -> SAT.evalPBFormula (transformBackward info m) pb === Just o+                Nothing -> property True+          ]+  where        +    collectTerms :: PBFile.Formula -> Set IntSet+    collectTerms formula = Set.fromList [t' | t <- terms, let t' = IntSet.fromList t, IntSet.size t' >= 3]+      where+        sums = maybeToList (PBFile.pbObjectiveFunction formula) +++               [lhs | (lhs,_,_) <- PBFile.pbConstraints formula]+        terms = [t | s <- sums, (_,t) <- s]++    eval2 :: SAT.IModel m => m -> (PBFile.Formula, Integer) -> Maybe Integer+    eval2 m (pb,th) = do+      o <- SAT.evalPBFormula m pb+      guard $ o <= th+      return o++prop_inequalitiesToEqualitiesPB :: Property+prop_inequalitiesToEqualitiesPB = QM.monadicIO $ do+  pb@(nv,cs) <- QM.pick arbitraryPBNLC+  let f (PBRelGE,lhs,rhs) = ([(c,ls) | (c,ls) <- lhs], PBFile.Ge, rhs)+      f (PBRelLE,lhs,rhs) = ([(-c,ls) | (c,ls) <- lhs], PBFile.Ge, -rhs)+      f (PBRelEQ,lhs,rhs) = ([(c,ls) | (c,ls) <- lhs], PBFile.Eq, rhs)+  let opb = PBFile.Formula+            { PBFile.pbObjectiveFunction = Nothing+            , PBFile.pbNumVars = nv+            , PBFile.pbNumConstraints = length cs+            , PBFile.pbConstraints = map f cs+            }+  QM.monitor $ counterexample (show opb)+  let (opb2, info) = inequalitiesToEqualitiesPB opb+      pb2 = (PBFile.pbNumVars opb2, [(g op, lhs, rhs) | (lhs,op,rhs) <- PBFile.pbConstraints opb2])+      g PBFile.Ge = PBRelGE+      g PBFile.Eq = PBRelEQ+  QM.monitor $ counterexample (show opb2)++  solver1 <- arbitrarySolver+  solver2 <- arbitrarySolver+  ret1 <- QM.run $ solvePBNLC solver1 pb+  ret2 <- QM.run $ solvePBNLC solver2 pb2+  QM.assert $ isJust ret1 == isJust ret2+  case ret1 of+    Nothing -> return ()+    Just m1 -> do+      let m2 = transformForward info m1+      QM.assert $ bounds m2 == (1, PBFile.pbNumVars opb2)+      QM.assert $ evalPBNLC m2 pb2+  case ret2 of+    Nothing -> return ()+    Just m2 -> do+      let m1 = transformBackward info m2+      QM.assert $ bounds m1 == (1, nv)+      QM.assert $ evalPBNLC m1 pb+++converterTestGroup :: TestTree+converterTestGroup = $(testGroupGenerator)
test/Test/FiniteModelFinder.hs view
@@ -44,7 +44,7 @@ genLit' :: Sig -> [MF.Var] -> StateT Int Gen MF.Lit genLit' sig vs = do   atom <- genAtom' sig vs-  lift $ elements [MF.Pos atom, MF.Neg atom]  +  lift $ elements [MF.Pos atom, MF.Neg atom]  genClause' :: Sig -> [MF.Var] -> StateT Int Gen MF.Clause genClause' sig vs = do
test/Test/LPFile.hs view
@@ -17,7 +17,7 @@ case_test_qcp2      = checkFile "samples/lp/test-qcp2.lp" case_test_qp        = checkFile "samples/lp/test-qp.lp" case_empty_obj_1    = checkFile "samples/lp/empty_obj_1.lp"-case_empty_obj_2    = checkFile "samples/lp/empty_obj_2.lp"  +case_empty_obj_2    = checkFile "samples/lp/empty_obj_2.lp"  ------------------------------------------------------------------------ -- Sample data
test/Test/MIP.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,6 +13,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty.TH+import ToySolver.Data.MIP (meetStatus) import qualified ToySolver.Data.MIP as MIP import qualified ToySolver.Data.MIP.Solution.CBC as CBCSol import qualified ToySolver.Data.MIP.Solution.CPLEX as CPLEXSol@@ -36,22 +38,26 @@ prop_status_meet_idempotency :: Property prop_status_meet_idempotency =   forAll arbitrary $ \(x :: MIP.Status) ->-    x `meet` x == x+    x `meetStatus` x == x  prop_status_meet_comm :: Property prop_status_meet_comm =   forAll arbitrary $ \(x :: MIP.Status) y ->-    x `meet` y == y `meet` x+    x `meetStatus` y == y `meetStatus` x  prop_status_meet_assoc :: Property prop_status_meet_assoc =   forAll arbitrary $ \(x :: MIP.Status) y z ->-    (x `meet` y) `meet` z == x `meet` (y `meet` z)+    (x `meetStatus` y) `meetStatus` z == x `meetStatus` (y `meetStatus` z)  prop_status_meet_leq :: Property prop_status_meet_leq =   forAll arbitrary $ \(x :: MIP.Status) y ->+#if MIN_VERSION_lattices(2,0,0)+    (x == (x `meetStatus` y)) == x `leq` y+#else     x `meetLeq` y == x `leq` y+#endif  instance Arbitrary MIP.Status where   arbitrary = arbitraryBoundedEnum
+ test/Test/ProbSAT.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.ProbSAT (probSATTestGroup) where++import Control.Applicative+import Control.Monad+import Data.Array.IArray+import Data.Default.Class+import Data.Maybe+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM+import Test.QuickCheck.Modifiers+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.SLS.ProbSAT as ProbSAT++import Test.SAT.Utils+++prop_probSAT :: Property+prop_probSAT = QM.monadicIO $ do+  cnf <- QM.pick arbitraryCNF+  opt <- QM.pick $ do+    target <- choose (0, 10)+    maxTries <- choose (0, 10)+    maxFlips <- choose (0, 1000)+    return $+      def+      { ProbSAT.optTarget   = target+      , ProbSAT.optMaxTries = maxTries+      , ProbSAT.optMaxFlips = maxFlips+      }+  (obj,sol) <- QM.run $ do+    solver <- ProbSAT.newSolver cnf+    let cb = 3.6+        cm = 0.5+        f make break = cm**make / cb**break+    ProbSAT.probsat solver opt def f+    ProbSAT.getBestSolution solver+  QM.monitor (counterexample (show (obj,sol)))+  QM.assert (bounds sol == (1, CNF.cnfNumVars cnf))+  QM.assert (obj == fromIntegral (evalCNFCost sol cnf))++prop_probSAT_weighted :: Property+prop_probSAT_weighted = QM.monadicIO $ do+  wcnf <- QM.pick arbitraryWCNF+  opt <- QM.pick $ do+    target <- choose (0, 10)+    maxTries <- choose (0, 10)+    maxFlips <- choose (0, 1000)+    return $+      def+      { ProbSAT.optTarget   = target+      , ProbSAT.optMaxTries = maxTries+      , ProbSAT.optMaxFlips = maxFlips+      }+  (obj,sol) <- QM.run $ do+    solver <- ProbSAT.newSolverWeighted wcnf+    let cb = 3.6+        cm = 0.5+        f make break = cm**make / cb**break+    ProbSAT.probsat solver opt def f+    ProbSAT.getBestSolution solver+  QM.monitor (counterexample (show (obj,sol)))+  QM.assert (bounds sol == (1, CNF.wcnfNumVars wcnf))+  QM.assert (obj == evalWCNFCost sol wcnf)++case_probSAT_case1 :: Assertion+case_probSAT_case1 = do+  let cnf =+        CNF.CNF+        { CNF.cnfNumVars = 1+        , CNF.cnfNumClauses = 2+        , CNF.cnfClauses = map SAT.packClause+            [ [1,-1]+            , []+            ]+        }+  solver <- ProbSAT.newSolver cnf+  let opt =+        def+        { ProbSAT.optTarget   = 0+        , ProbSAT.optMaxTries = 1+        , ProbSAT.optMaxFlips = 10+        }+      cb = 3.6+      cm = 0.5+      f make break = cm**make / cb**break+  ProbSAT.probsat solver opt def f++------------------------------------------------------------------------+-- Test harness++probSATTestGroup :: TestTree+probSATTestGroup = $(testGroupGenerator)
test/Test/QBF.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Test.QBF (qbfTestGroup) where -import Control.Applicative((<$>)) import Control.Monad import qualified Data.IntSet as IntSet import Data.IntMap (IntMap)@@ -40,6 +39,15 @@     Just ls ->       QM.assert $ sat == evalQBFNaive' (IntMap.fromList [(abs lit, lit > 0) | lit <- IntSet.toList ls]) prefix' matrix +prop_solveQE :: Property+prop_solveQE = QM.monadicIO $ do+  (nv, prefix@(_ : prefix'), matrix) <- QM.pick arbitrarySmallQBF+  (sat, cert) <- QM.run $ QBF.solveQE nv prefix matrix+  QM.assert $ sat == evalQBFNaive prefix matrix+  case cert of+    Nothing -> return ()+    Just ls ->+      QM.assert $ sat == evalQBFNaive' (IntMap.fromList [(abs lit, lit > 0) | lit <- IntSet.toList ls]) prefix' matrix  {- If the innermost quantifier is a universal quantifier,
+ test/Test/QUBO.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.QUBO (quboTestGroup) where++import Control.Monad+import Data.Array.IArray+import Data.ByteString.Builder+import qualified Data.IntMap.Strict as IntMap+import Data.Maybe+import qualified Data.PseudoBoolean as PBFile+import Data.Scientific++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM++import ToySolver.Converter+import qualified ToySolver.FileFormat as FF+import qualified ToySolver.QUBO as QUBO+import ToySolver.Converter.QUBO+import qualified ToySolver.SAT.Types as SAT++import Test.SAT.Utils++------------------------------------------------------------------------++instance (Arbitrary a, Eq a, Num a) => Arbitrary (QUBO.Problem a) where+  arbitrary = do+    nv <- choose (1,10)+    m <- choose (0,nv*nv)+    jj <- liftM (f . IntMap.unionsWith (IntMap.unionWith (+))) $ replicateM m $ do+      i <- choose (0,nv-1)+      j <- choose (i,nv-1)+      jj_ij <- arbitrary+      return $ IntMap.singleton i $ IntMap.singleton j jj_ij+    return $+      QUBO.Problem+      { QUBO.quboNumVars = nv+      , QUBO.quboMatrix = jj+      }+    where+      f = IntMap.mapMaybe (g . IntMap.filter (/= 0))+      g m = if IntMap.null m then Nothing else Just m++arbitrarySolution :: Int -> Gen QUBO.Solution+arbitrarySolution nv =+  liftM (array (0,nv-1) . zip [0..]) $ replicateM nv arbitrary++instance (Arbitrary a, Eq a, Num a) => Arbitrary (QUBO.IsingModel a) where+  arbitrary = do+    nv <- choose (1,10)++    m <- choose (0,nv*nv)+    qq <- liftM (f . IntMap.unionsWith (IntMap.unionWith (+))) $ replicateM m $ do+      i <- choose (0,nv-1)+      j <- choose (i,nv-1)+      qq_ij <- arbitrary+      return $ IntMap.singleton i $ IntMap.singleton j qq_ij++    h <- liftM (\h -> IntMap.fromList [(i,hi)| (i, Just hi) <- zip [0..] h]) $ replicateM nv arbitrary++    return $+      QUBO.IsingModel+      { QUBO.isingNumVars = nv+      , QUBO.isingInteraction = qq+      , QUBO.isingExternalMagneticField = h+      }+    where+      f = IntMap.mapMaybe (g . IntMap.filter (/= 0))+      g m = if IntMap.null m then Nothing else Just m++------------------------------------------------------------------------++prop_QUBO_ReadWrite_Invariance :: Property+prop_QUBO_ReadWrite_Invariance = forAll g $ \qubo ->+  let s = toLazyByteString (FF.render qubo)+   in counterexample (show s) $ FF.parse s === Right qubo+  where+    g = do+      qubo <- arbitrary+      return $ fmap fromFloatDigits (qubo :: QUBO.Problem Double)++------------------------------------------------------------------------++prop_qubo2pb :: Property+prop_qubo2pb = forAll arbitrary $ \(qubo :: QUBO.Problem Integer) ->+  let (pbo,_) = qubo2pb qubo+   in Just qubo === fmap fst (pbAsQUBO pbo)++prop_pb2qubo :: Property+prop_pb2qubo = forAll arbitraryPBFormula $ \formula ->+  let ((qubo :: QUBO.Problem Integer, th), info) = pb2qubo formula+   in counterexample (show (qubo,th,info)) $+        conjoin+        [ forAll (arbitraryAssignment (PBFile.pbNumVars formula)) $ \m ->+            case SAT.evalPBFormula m formula of+              Nothing ->+                property (QUBO.eval (transformForward info m) qubo > th)+              Just o ->+                conjoin+                [ QUBO.eval (transformForward info m) qubo === transformObjValueForward info o+                , transformObjValueBackward info (transformObjValueForward info o) === o+                , property (transformObjValueForward info o <= th)+                ]+        , forAll (arbitrarySolution (QUBO.quboNumVars qubo)) $ \sol ->+            let o = QUBO.eval sol qubo+             in if (o <= th) then+                  (SAT.evalPBFormula (transformBackward info sol) formula === Just (transformObjValueBackward info o))+                  .&&.+                  transformObjValueForward info (transformObjValueBackward info o) === o+                else+                  property True+        ]++prop_qubo2ising :: Property+prop_qubo2ising = forAll arbitrary $ \(qubo :: QUBO.Problem Rational) ->+  let (ising, info) = qubo2ising qubo+   in counterexample (show ising) $+        forAll (arbitrarySolution (QUBO.quboNumVars qubo)) $ \sol ->+          transformObjValueForward info (QUBO.eval sol qubo) === QUBO.evalIsingModel sol ising++prop_ising2qubo :: Property+prop_ising2qubo = forAll arbitrary $ \(ising :: QUBO.IsingModel Integer) ->+  let (qubo, info) = ising2qubo ising+   in counterexample (show qubo) $+        forAll (arbitrarySolution (QUBO.isingNumVars ising)) $ \sol ->+          transformObjValueForward info (QUBO.evalIsingModel sol ising) === QUBO.eval sol qubo++------------------------------------------------------------------------+-- Test harness++quboTestGroup :: TestTree+quboTestGroup = $(testGroupGenerator)
test/Test/SAT.hs view
@@ -1,2039 +1,594 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}-module Test.SAT (satTestGroup) where--import Control.Monad-import Data.Array.IArray-import Data.Default.Class-import qualified Data.Foldable as F-import Data.IORef-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet-import qualified Data.Traversable as Traversable-import qualified Data.Vector as V-import qualified System.Random.MWC as Rand--import Test.Tasty-import Test.Tasty.QuickCheck hiding ((.&&.), (.||.))-import Test.Tasty.HUnit-import Test.Tasty.TH-import qualified Test.QuickCheck.Monadic as QM--import ToySolver.Data.LBool-import ToySolver.Data.BoolExpr-import ToySolver.Data.Boolean-import qualified ToySolver.SAT as SAT-import qualified ToySolver.SAT.Types as SAT-import ToySolver.SAT.TheorySolver-import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin-import qualified ToySolver.SAT.Encoder.PB as PB-import qualified ToySolver.SAT.Encoder.PB.Internal.Sorter as PBEncSorter-import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC-import qualified ToySolver.SAT.MUS as MUS-import qualified ToySolver.SAT.MUS.Enum as MUSEnum-import qualified ToySolver.SAT.PBO as PBO-import qualified ToySolver.SAT.Store.CNF as CNFStore-import qualified ToySolver.SAT.ExistentialQuantification as ExistentialQuantification--import qualified Data.PseudoBoolean as PBFile-import qualified ToySolver.Converter.PB2SAT as PB2SAT-import qualified ToySolver.Converter.WBO2MaxSAT as WBO2MaxSAT-import qualified ToySolver.Converter.WBO2PB as WBO2PB-import qualified ToySolver.Converter.SAT2KSAT as SAT2KSAT-import qualified ToySolver.Text.CNF as CNF-import qualified ToySolver.Text.MaxSAT as MaxSAT--import ToySolver.Data.OrdRel-import qualified ToySolver.Data.LA as LA-import qualified ToySolver.Arith.Simplex as Simplex-import qualified ToySolver.EUF.EUFSolver as EUF--allAssignments :: Int -> [SAT.Model]-allAssignments nv = [array (1,nv) (zip [1..nv] xs) | xs <- replicateM nv [True,False]]--prop_solveCNF :: Property-prop_solveCNF = QM.monadicIO $ do-  cnf <- QM.pick arbitraryCNF-  solver <- arbitrarySolver-  ret <- QM.run $ solveCNF solver cnf-  case ret of-    Just m -> QM.assert $ evalCNF m cnf-    Nothing -> do-      forM_ (allAssignments (CNF.numVars cnf)) $ \m -> do-        QM.assert $ not (evalCNF m cnf)--solveCNF :: SAT.Solver -> CNF.CNF -> IO (Maybe SAT.Model)-solveCNF solver cnf = do-  SAT.newVars_ solver (CNF.numVars cnf)-  forM_ (CNF.clauses cnf) $ \c -> SAT.addClause solver c-  ret <- SAT.solve solver-  if ret then do-    m <- SAT.getModel solver-    return (Just m)-  else do-    return Nothing--arbitraryCNF :: Gen CNF.CNF-arbitraryCNF = do-  nv <- choose (0,10)-  nc <- choose (0,50)-  cs <- replicateM nc $ do-    len <- choose (0,10)-    if nv == 0 then-      return []-    else-      replicateM len $ choose (-nv, nv) `suchThat` (/= 0)-  return $-    CNF.CNF-    { CNF.numVars = nv-    , CNF.numClauses = nc-    , CNF.clauses = cs-    }--evalCNF :: SAT.Model -> CNF.CNF -> Bool-evalCNF m cnf = all (SAT.evalClause m) (CNF.clauses cnf)---prop_solvePB :: Property-prop_solvePB = QM.monadicIO $ do-  prob@(nv,_) <- QM.pick arbitraryPB-  solver <- arbitrarySolver-  ret <- QM.run $ solvePB solver prob-  case ret of-    Just m -> QM.assert $ evalPB m prob-    Nothing -> do-      forM_ (allAssignments nv) $ \m -> do-        QM.assert $ not (evalPB m prob)--data PBRel = PBRelGE | PBRelEQ | PBRelLE deriving (Eq, Ord, Enum, Bounded, Show)--instance Arbitrary PBRel where-  arbitrary = arbitraryBoundedEnum  --evalPBRel :: Ord a => PBRel -> a -> a -> Bool-evalPBRel PBRelGE = (>=)-evalPBRel PBRelLE = (<=)-evalPBRel PBRelEQ = (==)--solvePB :: SAT.Solver -> (Int,[(PBRel,SAT.PBLinSum,Integer)]) -> IO (Maybe SAT.Model)-solvePB solver (nv,cs) = do-  SAT.newVars_ solver nv-  forM_ cs $ \(o,lhs,rhs) -> do-    case o of-      PBRelGE -> SAT.addPBAtLeast solver lhs rhs-      PBRelLE -> SAT.addPBAtMost solver lhs rhs-      PBRelEQ -> SAT.addPBExactly solver lhs rhs-  ret <- SAT.solve solver-  if ret then do-    m <- SAT.getModel solver-    return (Just m)-  else do-    return Nothing--arbitraryPB :: Gen (Int,[(PBRel,SAT.PBLinSum,Integer)])-arbitraryPB = do-  nv <- choose (0,10)-  nc <- choose (0,50)-  cs <- replicateM nc $ do-    rel <- arbitrary-    lhs <- arbitraryPBLinSum nv-    rhs <- arbitrary-    return $ (rel,lhs,rhs)-  return (nv, cs)--arbitraryPBLinSum :: Int -> Gen SAT.PBLinSum-arbitraryPBLinSum nv = do-  len <- choose (0,10)-  if nv == 0 then-    return []-  else-    replicateM len $ do-      l <- choose (-nv, nv) `suchThat` (/= 0)-      c <- arbitrary-      return (c,l)--evalPB :: SAT.Model -> (Int,[(PBRel,SAT.PBLinSum,Integer)]) -> Bool-evalPB m (_,cs) = all (\(o,lhs,rhs) -> evalPBRel o (SAT.evalPBLinSum m lhs) rhs) cs--prop_optimizePBO :: Property-prop_optimizePBO = QM.monadicIO $ do-  prob@(nv,_) <- QM.pick arbitraryPB-  obj <- QM.pick $ arbitraryPBLinSum nv-  solver <- arbitrarySolver-  opt <- arbitraryOptimizer solver obj-  ret <- QM.run $ optimizePBO solver opt prob-  case ret of-    Just (m, v) -> do-      QM.assert $ evalPB m prob-      QM.assert $ SAT.evalPBLinSum m obj == v-      forM_ (allAssignments nv) $ \m2 -> do-        QM.assert $ not (evalPB m2 prob) || SAT.evalPBLinSum m obj <= SAT.evalPBLinSum m2 obj-    Nothing -> do-      forM_ (allAssignments nv) $ \m -> do-        QM.assert $ not (evalPB m prob)-           -optimizePBO :: SAT.Solver -> PBO.Optimizer -> (Int,[(PBRel,SAT.PBLinSum,Integer)]) -> IO (Maybe (SAT.Model, Integer))-optimizePBO solver opt (nv,cs) = do-  SAT.newVars_ solver nv-  forM_ cs $ \(o,lhs,rhs) -> do-    case o of-      PBRelGE -> SAT.addPBAtLeast solver lhs rhs-      PBRelLE -> SAT.addPBAtMost solver lhs rhs-      PBRelEQ -> SAT.addPBExactly solver lhs rhs-  PBO.optimize opt-  PBO.getBestSolution opt--evalWBO :: SAT.Model -> (Int, [(Maybe Integer, (PBRel,SAT.PBLinSum,Integer))], Maybe Integer) -> Maybe Integer-evalWBO m (nv,cs,top) = do-  cost <- liftM sum $ forM cs $ \(w,(o,lhs,rhs)) -> do-    if evalPBRel o (SAT.evalPBLinSum m lhs) rhs then-      return 0-    else-      w-  case top of-    Just t -> guard (cost < t)-    Nothing -> return ()-  return cost--arbitraryWBO :: Gen (Int, [(Maybe Integer, (PBRel,SAT.PBLinSum,Integer))], Maybe Integer)-arbitraryWBO = do-  (nv,cs) <- arbitraryPB-  cs2 <- forM cs $ \c -> do-    b <- arbitrary-    cost <- if b then return Nothing-            else liftM (Just . (1+) . abs) arbitrary-    return (cost, c)-  b <- arbitrary-  top <- if b then return Nothing-         else liftM (Just . (1+) . abs) arbitrary-  return (nv,cs2,top)--optimizeWBO-  :: SAT.Solver-  -> PBO.Method-  -> (Int, [(Maybe Integer, (PBRel,SAT.PBLinSum,Integer))], Maybe Integer)-  -> IO (Maybe (SAT.Model, Integer))-optimizeWBO solver method (nv,cs,top) = do-  SAT.newVars_ solver nv-  obj <- liftM catMaybes $ forM cs $ \(cost, (o,lhs,rhs)) -> do-    case cost of-      Nothing -> do-        case o of-          PBRelGE -> SAT.addPBAtLeast solver lhs rhs-          PBRelLE -> SAT.addPBAtMost solver lhs rhs-          PBRelEQ -> SAT.addPBExactly solver lhs rhs-        return Nothing-      Just w -> do-        sel <- SAT.newVar solver-        case o of-          PBRelGE -> SAT.addPBAtLeastSoft solver sel lhs rhs-          PBRelLE -> SAT.addPBAtMostSoft solver sel lhs rhs-          PBRelEQ -> SAT.addPBExactlySoft solver sel lhs rhs-        return $ Just (w,-sel)-  case top of-    Nothing -> return ()-    Just c -> SAT.addPBAtMost solver obj (c-1)-  opt <- PBO.newOptimizer solver obj-  PBO.optimize opt-  liftM (fmap (\(m, val) -> (SAT.restrictModel nv m, val))) $ PBO.getBestSolution opt--prop_solvePBNLC :: Property-prop_solvePBNLC = QM.monadicIO $ do-  prob@(nv,_) <- QM.pick arbitraryPBNLC-  solver <- arbitrarySolver-  ret <- QM.run $ solvePBNLC solver prob-  case ret of-    Just m -> QM.assert $ evalPBNLC m prob-    Nothing -> do-      forM_ (allAssignments nv) $ \m -> do-        QM.assert $ not (evalPBNLC m prob)--solvePBNLC :: SAT.Solver -> (Int,[(PBRel,SAT.PBSum,Integer)]) -> IO (Maybe SAT.Model)-solvePBNLC solver (nv,cs) = do-  SAT.newVars_ solver nv-  enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver-  forM_ cs $ \(o,lhs,rhs) -> do-    case o of-      PBRelGE -> PBNLC.addPBNLAtLeast enc lhs rhs-      PBRelLE -> PBNLC.addPBNLAtMost enc lhs rhs-      PBRelEQ -> PBNLC.addPBNLExactly enc lhs rhs-  ret <- SAT.solve solver-  if ret then do-    m <- SAT.getModel solver-    return $ Just $ SAT.restrictModel nv m-  else do-    return Nothing--optimizePBNLC-  :: SAT.Solver-  -> PBO.Method-  -> (Int, SAT.PBSum, [(PBRel,SAT.PBSum,Integer)])-  -> IO (Maybe (SAT.Model, Integer))-optimizePBNLC solver method (nv,obj,cs) = do-  SAT.newVars_ solver nv-  enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver-  forM_ cs $ \(o,lhs,rhs) -> do-    case o of-      PBRelGE -> PBNLC.addPBNLAtLeast enc lhs rhs-      PBRelLE -> PBNLC.addPBNLAtMost enc lhs rhs-      PBRelEQ -> PBNLC.addPBNLExactly enc lhs rhs-  obj2 <- PBNLC.linearizePBSumWithPolarity enc Tseitin.polarityNeg obj-  opt <- PBO.newOptimizer2 solver obj2 (\m -> SAT.evalPBSum m obj)-  PBO.setMethod opt method-  PBO.optimize opt-  liftM (fmap (\(m, val) -> (SAT.restrictModel nv m, val))) $ PBO.getBestSolution opt--arbitraryPBNLC :: Gen (Int,[(PBRel,SAT.PBSum,Integer)])-arbitraryPBNLC = do-  nv <- choose (0,10)-  nc <- choose (0,50)-  cs <- replicateM nc $ do-    rel <- arbitrary-    len <- choose (0,10)-    lhs <--      if nv == 0 then-        return []-      else-        replicateM len $ do-          ls <- listOf $ choose (-nv, nv) `suchThat` (/= 0)-          c <- arbitrary-          return (c,ls)-    rhs <- arbitrary-    return $ (rel,lhs,rhs)-  return (nv, cs)--evalPBNLC :: SAT.Model -> (Int,[(PBRel,SAT.PBSum,Integer)]) -> Bool-evalPBNLC m (_,cs) = all (\(o,lhs,rhs) -> evalPBRel o (SAT.evalPBSum m lhs) rhs) cs---prop_solveXOR :: Property-prop_solveXOR = QM.monadicIO $ do-  prob@(nv,_) <- QM.pick arbitraryXOR-  solver <- arbitrarySolver-  ret <- QM.run $ solveXOR solver prob-  case ret of-    Just m -> QM.assert $ evalXOR m prob-    Nothing -> do-      forM_ (allAssignments nv) $ \m -> do-        QM.assert $ not (evalXOR m prob)--solveXOR :: SAT.Solver -> (Int,[SAT.XORClause]) -> IO (Maybe SAT.Model)-solveXOR solver (nv,cs) = do-  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }-  SAT.newVars_ solver nv-  forM_ cs $ \c -> SAT.addXORClause solver (fst c) (snd c)-  ret <- SAT.solve solver-  if ret then do-    m <- SAT.getModel solver-    return (Just m)-  else do-    return Nothing--arbitraryXOR :: Gen (Int,[SAT.XORClause])-arbitraryXOR = do-  nv <- choose (0,10)-  nc <- choose (0,50)-  cs <- replicateM nc $ do-    len <- choose (0,10)    -    lhs <--      if nv == 0 then-        return []-      else-        replicateM len $ choose (-nv, nv) `suchThat` (/= 0)-    rhs <- arbitrary-    return (lhs,rhs)-  return (nv, cs)--evalXOR :: SAT.Model -> (Int,[SAT.XORClause]) -> Bool-evalXOR m (_,cs) = all (SAT.evalXORClause m) cs---newTheorySolver :: CNF.CNF -> IO TheorySolver-newTheorySolver cnf = do-  let nv = CNF.numVars cnf-      cs = CNF.clauses cnf-  solver <- SAT.newSolver-  SAT.newVars_ solver nv-  forM_ cs $ \c -> SAT.addClause solver c-  -  ref <- newIORef []-  let tsolver =-        TheorySolver-        { thAssertLit = \_ l -> do-            if abs l > nv then-              return True-            else do-              m <- readIORef ref-              case m of-                [] -> SAT.addClause solver [l]-                xs : xss -> writeIORef ref ((l : xs) : xss)-              return True-        , thCheck = \_ -> do-            xs <- liftM concat $ readIORef ref-            SAT.solveWith solver xs-        , thExplain = \m -> do-            case m of-              Nothing -> SAT.getFailedAssumptions solver-              Just _ -> return []-        , thPushBacktrackPoint = modifyIORef ref ([] :)-        , thPopBacktrackPoint = modifyIORef ref tail-        , thConstructModel = return ()-        }-  return tsolver--prop_solveCNF_using_BooleanTheory :: Property-prop_solveCNF_using_BooleanTheory = QM.monadicIO $ do-  cnf <- QM.pick arbitraryCNF-  let nv = CNF.numVars cnf-      nc = CNF.numClauses cnf-      cs = CNF.clauses cnf-      cnf1 = cnf{ CNF.clauses = [c | (i,c) <- zip [0..] cs, i `mod` 2 == 0], CNF.numClauses = nc - (nc `div` 2) }-      cnf2 = cnf{ CNF.clauses = [c | (i,c) <- zip [0..] cs, i `mod` 2 /= 0], CNF.numClauses = nc `div` 2 }--  solver <- arbitrarySolver--  ret <- QM.run $ do-    SAT.newVars_ solver nv--    tsolver <- newTheorySolver cnf1-    SAT.setTheory solver tsolver--    forM_ (CNF.clauses cnf2) $ \c -> SAT.addClause solver c-    ret <- SAT.solve solver-    if ret then do-      m <- SAT.getModel solver-      return (Just m)-    else do-      return Nothing--  case ret of-    Just m -> QM.assert $ evalCNF m cnf-    Nothing -> do-      forM_ (allAssignments nv) $ \m -> do-        QM.assert $ not (evalCNF m cnf)--case_QF_LRA :: Assertion-case_QF_LRA = do-  satSolver <- SAT.newSolver-  lraSolver <- Simplex.newSolver--  tblRef <- newIORef $ Map.empty-  defsRef <- newIORef $ IntMap.empty-  let abstractLAAtom :: LA.Atom Rational -> IO SAT.Lit-      abstractLAAtom atom = do-        (v,op,rhs) <- Simplex.simplifyAtom lraSolver atom-        tbl <- readIORef tblRef-        (vLt, vEq, vGt) <--          case Map.lookup (v,rhs) tbl of-            Just (vLt, vEq, vGt) -> return (vLt, vEq, vGt)-            Nothing -> do-              vLt <- SAT.newVar satSolver-              vEq <- SAT.newVar satSolver-              vGt <- SAT.newVar satSolver-              SAT.addClause satSolver [vLt,vEq,vGt]-              SAT.addClause satSolver [-vLt, -vEq]-              SAT.addClause satSolver [-vLt, -vGt]                 -              SAT.addClause satSolver [-vEq, -vGt]-              writeIORef tblRef (Map.insert (v,rhs) (vLt, vEq, vGt) tbl)-              let xs = IntMap.fromList-                       [ (vEq,  LA.var v .==. LA.constant rhs)-                       , (vLt,  LA.var v .<.  LA.constant rhs)-                       , (vGt,  LA.var v .>.  LA.constant rhs)-                       , (-vLt, LA.var v .>=. LA.constant rhs)-                       , (-vGt, LA.var v .<=. LA.constant rhs)-                       ]-              modifyIORef defsRef (IntMap.union xs)-              return (vLt, vEq, vGt)-        case op of-          Lt  -> return vLt-          Gt  -> return vGt-          Eql -> return vEq-          Le  -> return (-vGt)-          Ge  -> return (-vLt)-          NEq -> return (-vEq)--      abstract :: BoolExpr (Either SAT.Lit (LA.Atom Rational)) -> IO (BoolExpr SAT.Lit)-      abstract = Traversable.mapM f-        where-          f (Left lit) = return lit-          f (Right atom) = abstractLAAtom atom--  let tsolver =-        TheorySolver-        { thAssertLit = \_ l -> do-            defs <- readIORef defsRef-            case IntMap.lookup l defs of-              Nothing -> return True-              Just atom -> do-                Simplex.assertAtomEx' lraSolver atom (Just l)-                return True-        , thCheck = \_ -> do-            Simplex.check lraSolver-        , thExplain = \m -> do-            case m of-              Nothing -> liftM IntSet.toList $ Simplex.explain lraSolver-              Just _ -> return []-        , thPushBacktrackPoint = do-            Simplex.pushBacktrackPoint lraSolver-        , thPopBacktrackPoint = do-            Simplex.popBacktrackPoint lraSolver-        , thConstructModel = do-            return ()-        }-  SAT.setTheory satSolver tsolver--  enc <- Tseitin.newEncoder satSolver-  let addFormula :: BoolExpr (Either SAT.Lit (LA.Atom Rational)) -> IO ()-      addFormula c = Tseitin.addFormula enc =<< abstract c--  a <- SAT.newVar satSolver-  x <- Simplex.newVar lraSolver-  y <- Simplex.newVar lraSolver--  let le1 = LA.fromTerms [(2,x), (1/3,y)] .<=. LA.constant (-4) -- 2 x + (1/3) y <= -4-      eq2 = LA.fromTerms [(1.5,x)] .==. LA.fromTerms [(-2,x)] -- 1.5 y = -2 x-      gt3 = LA.var x .>. LA.var y -- x > y-      lt4 = LA.fromTerms [(3,x)] .<. LA.fromTerms [(-1,LA.unitVar), (1/5,x), (1/5,y)] -- 3 x < -1 + (1/5) (x + y)--      c1, c2 :: BoolExpr (Either SAT.Lit (LA.Atom Rational))-      c1 = ite (Atom (Left a) :: BoolExpr (Either SAT.Lit (LA.Atom Rational))) (Atom $ Right le1) (Atom $ Right eq2)-      c2 = Atom (Right gt3) .||. (Atom (Left a) .<=>. Atom (Right lt4))--  addFormula c1-  addFormula c2--  ret <- SAT.solve satSolver-  ret @?= True--  m1 <- SAT.getModel satSolver-  m2 <- Simplex.getModel lraSolver-  defs <- readIORef defsRef-  let f (Left lit) = SAT.evalLit m1 lit-      f (Right atom) = LA.eval m2 atom-  fold f c1 @?= True-  fold f c2 @?= True---case_QF_EUF :: Assertion-case_QF_EUF = do-  satSolver <- SAT.newSolver-  eufSolver <- EUF.newSolver-  enc <- Tseitin.newEncoder satSolver-  -  tblRef <- newIORef (Map.empty :: Map (EUF.Term, EUF.Term) SAT.Var)-  defsRef <- newIORef (IntMap.empty :: IntMap (EUF.Term, EUF.Term))-  eufModelRef <- newIORef (undefined :: EUF.Model)- -  let abstractEUFAtom :: (EUF.Term, EUF.Term) -> IO SAT.Lit-      abstractEUFAtom (t1,t2) | t1 >= t2 = abstractEUFAtom (t2,t1)-      abstractEUFAtom (t1,t2) = do-        tbl <- readIORef tblRef-        case Map.lookup (t1,t2) tbl of-          Just v -> return v-          Nothing -> do-            v <- SAT.newVar satSolver-            writeIORef tblRef $! Map.insert (t1,t2) v tbl-            modifyIORef' defsRef $! IntMap.insert v (t1,t2)-            return v--      abstract :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term)) -> IO (BoolExpr SAT.Lit)-      abstract = Traversable.mapM f-        where-          f (Left lit) = return lit-          f (Right atom) = abstractEUFAtom atom--  let tsolver =-        TheorySolver-        { thAssertLit = \_ l -> do-            defs <- readIORef defsRef-            case IntMap.lookup (SAT.litVar l) defs of-              Nothing -> return True-              Just (t1,t2) -> do-                if SAT.litPolarity l then-                  EUF.assertEqual' eufSolver t1 t2 (Just l)-                else-                  EUF.assertNotEqual' eufSolver t1 t2 (Just l)-                return True-        , thCheck = \callback -> do-            b <- EUF.check eufSolver-            when b $ do-              defs <- readIORef defsRef-              forM_ (IntMap.toList defs) $ \(v, (t1, t2)) -> do-                b2 <- EUF.areEqual eufSolver t1 t2-                when b2 $ do-                  callback v-                  return ()-            return b            -        , thExplain = \m -> do-            case m of-              Nothing -> liftM IntSet.toList $ EUF.explain eufSolver Nothing-              Just v -> do-                defs <- readIORef defsRef-                case IntMap.lookup v defs of-                  Nothing -> error "should not happen"-                  Just (t1,t2) -> do-                    liftM IntSet.toList $ EUF.explain eufSolver (Just (t1,t2))-        , thPushBacktrackPoint = do-            EUF.pushBacktrackPoint eufSolver-        , thPopBacktrackPoint = do-            EUF.popBacktrackPoint eufSolver-        , thConstructModel = do-            writeIORef eufModelRef =<< EUF.getModel eufSolver-            return ()-        }-  SAT.setTheory satSolver tsolver--  true  <- EUF.newConst eufSolver-  false <- EUF.newConst eufSolver-  EUF.assertNotEqual eufSolver true false-  boolToTermRef <- newIORef (IntMap.empty :: IntMap EUF.Term)-  termToBoolRef <- newIORef (Map.empty :: Map EUF.Term SAT.Lit)--  let connectBoolTerm :: SAT.Lit -> EUF.Term -> IO ()-      connectBoolTerm lit t = do-        lit1 <- abstractEUFAtom (t, true)-        lit2 <- abstractEUFAtom (t, false)-        SAT.addClause satSolver [-lit, lit1]  --  lit  ->  lit1-        SAT.addClause satSolver [-lit1, lit]  --  lit1 ->  lit-        SAT.addClause satSolver [lit, lit2]   -- -lit  ->  lit2-        SAT.addClause satSolver [-lit2, -lit] --  lit2 -> -lit-        modifyIORef' boolToTermRef $ IntMap.insert lit t-        modifyIORef' termToBoolRef $ Map.insert t lit--      boolToTerm :: SAT.Lit -> IO EUF.Term-      boolToTerm lit = do-        tbl <- readIORef boolToTermRef-        case IntMap.lookup lit tbl of-          Just t -> return t-          Nothing -> do-            t <- EUF.newConst eufSolver-            connectBoolTerm lit t-            return t--      termToBool :: EUF.Term -> IO SAT.Lit-      termToBool t = do-        tbl <- readIORef termToBoolRef-        case Map.lookup t tbl of-          Just lit -> return lit-          Nothing -> do-            lit <- SAT.newVar satSolver-            connectBoolTerm lit t-            return lit--  let addFormula :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term)) -> IO ()-      addFormula c = Tseitin.addFormula enc =<< abstract c--  do-    x <- SAT.newVar satSolver-    x' <- boolToTerm x-    f <- EUF.newFun eufSolver-    fx <- termToBool (f x')-    ftt <- abstractEUFAtom (f true, true)-    ret <- SAT.solveWith satSolver [-fx, ftt]-    ret @?= True--    m1 <- SAT.getModel satSolver-    m2 <- readIORef eufModelRef-    let e (Left lit) = SAT.evalLit m1 lit-        e (Right (lhs,rhs)) = EUF.eval m2 lhs == EUF.eval m2 rhs-    fold e (notB (Atom (Left fx)) .||. (Atom (Right (f true, true)))) @?= True-    SAT.evalLit m1 x @?= False--    ret <- SAT.solveWith satSolver [-fx, ftt, x]-    ret @?= False--  do-    -- a : Bool-    -- f : U -> U-    -- x : U-    -- y : U-    -- (a or x=y)-    -- f x /= f y-    a <- SAT.newVar satSolver-    f <- EUF.newFun eufSolver-    x <- EUF.newConst eufSolver-    y <- EUF.newConst eufSolver-    let c1, c2 :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term))-        c1 = Atom (Left a) .||. Atom (Right (x,y))-        c2 = notB $ Atom (Right (f x, f y))-    addFormula c1-    addFormula c2-    ret <- SAT.solve satSolver-    ret @?= True-    m1 <- SAT.getModel satSolver-    m2 <- readIORef eufModelRef-    let e (Left lit) = SAT.evalLit m1 lit-        e (Right (lhs,rhs)) = EUF.eval m2 lhs == EUF.eval m2 rhs-    fold e c1 @?= True-    fold e c2 @?= True--    ret <- SAT.solveWith satSolver [-a]-    ret @?= False---- should be SAT-case_solve_SAT :: Assertion-case_solve_SAT = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [x1, x2]  -- x1 or x2-  SAT.addClause solver [x1, -x2] -- x1 or not x2-  SAT.addClause solver [-x1, -x2] -- not x1 or not x2-  ret <- SAT.solve solver-  ret @?= True---- shuld be UNSAT-case_solve_UNSAT :: Assertion-case_solve_UNSAT = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [x1,  x2]  -- x1 or x2-  SAT.addClause solver [-x1, x2]  -- not x1 or x2-  SAT.addClause solver [x1,  -x2] -- x1 or not x2-  SAT.addClause solver [-x1, -x2] -- not x2 or not x2-  ret <- SAT.solve solver-  ret @?= False---- top level でいきなり矛盾-case_root_inconsistent :: Assertion-case_root_inconsistent = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  SAT.addClause solver [x1]-  SAT.addClause solver [-x1]-  ret <- SAT.solve solver -- unsat-  ret @?= False---- incremental に制約を追加-case_incremental_solving :: Assertion-case_incremental_solving = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [x1,  x2]  -- x1 or x2-  SAT.addClause solver [x1,  -x2] -- x1 or not x2-  SAT.addClause solver [-x1, -x2] -- not x1 or not x2-  ret <- SAT.solve solver -- sat-  ret @?= True--  SAT.addClause solver [-x1, x2]  -- not x1 or x2-  ret <- SAT.solve solver -- unsat-  ret @?= False---- 制約なし-case_empty_constraint :: Assertion-case_empty_constraint = do-  solver <- SAT.newSolver-  ret <- SAT.solve solver-  ret @?= True---- 空の節-case_empty_claue :: Assertion-case_empty_claue = do-  solver <- SAT.newSolver-  SAT.addClause solver []-  ret <- SAT.solve solver-  ret @?= False---- 自明に真な節-case_excluded_middle_claue :: Assertion-case_excluded_middle_claue = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  SAT.addClause solver [x1, -x1] -- x1 or not x1-  ret <- SAT.solve solver-  ret @?= True---- 冗長な節-case_redundant_clause :: Assertion-case_redundant_clause = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  SAT.addClause solver [x1,x1] -- x1 or x1-  ret <- SAT.solve solver-  ret @?= True--case_instantiateClause :: Assertion-case_instantiateClause = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [x1]-  SAT.addClause solver [x1,x2]-  SAT.addClause solver [-x1,x2]-  ret <- SAT.solve solver-  ret @?= True--case_instantiateAtLeast :: Assertion-case_instantiateAtLeast = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  x4 <- SAT.newVar solver-  SAT.addClause solver [x1]--  SAT.addAtLeast solver [x1,x2,x3,x4] 2-  ret <- SAT.solve solver-  ret @?= True--  SAT.addAtLeast solver [-x1,-x2,-x3,-x4] 2-  ret <- SAT.solve solver-  ret @?= True--case_inconsistent_AtLeast :: Assertion-case_inconsistent_AtLeast = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addAtLeast solver [x1,x2] 3-  ret <- SAT.solve solver -- unsat-  ret @?= False--case_trivial_AtLeast :: Assertion-case_trivial_AtLeast = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addAtLeast solver [x1,x2] 0-  ret <- SAT.solve solver-  ret @?= True--  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addAtLeast solver [x1,x2] (-1)-  ret <- SAT.solve solver-  ret @?= True--case_AtLeast_1 :: Assertion-case_AtLeast_1 = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  SAT.addAtLeast solver [x1,x2,x3] 2-  SAT.addAtLeast solver [-x1,-x2,-x3] 2-  ret <- SAT.solve solver -- unsat-  ret @?= False--case_AtLeast_2 :: Assertion-case_AtLeast_2 = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  x4 <- SAT.newVar solver-  SAT.addAtLeast solver [x1,x2,x3,x4] 2-  SAT.addClause solver [-x1,-x2]-  SAT.addClause solver [-x1,-x3]-  ret <- SAT.solve solver-  ret @?= True--case_AtLeast_3 :: Assertion-case_AtLeast_3 = do-  forM_ [(-1) .. 3] $ \n -> do-    solver <- SAT.newSolver-    x1 <- SAT.newVar solver-    x2 <- SAT.newVar solver-    SAT.addAtLeast solver [x1,x2] n-    ret <- SAT.solve solver-    assertEqual ("case_AtLeast3_" ++ show n) (n <= 2) ret---- from http://www.cril.univ-artois.fr/PB11/format.pdf-case_PB_sample1 :: Assertion-case_PB_sample1 = do-  solver <- SAT.newSolver--  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  x4 <- SAT.newVar solver-  x5 <- SAT.newVar solver--  SAT.addPBAtLeast solver [(1,x1),(4,x2),(-2,x5)] 2-  SAT.addPBAtLeast solver [(-1,x1),(4,x2),(-2,x5)] 3-  SAT.addPBAtLeast solver [(12345678901234567890,x4),(4,x3)] 10-  SAT.addPBExactly solver [(2,x2),(3,x4),(2,x1),(3,x5)] 5--  ret <- SAT.solve solver-  ret @?= True---- 一部の変数を否定に置き換えたもの-case_PB_sample1' :: Assertion-case_PB_sample1' = do-  solver <- SAT.newSolver--  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  x4 <- SAT.newVar solver-  x5 <- SAT.newVar solver--  SAT.addPBAtLeast solver [(1,x1),(4,-x2),(-2,x5)] 2-  SAT.addPBAtLeast solver [(-1,x1),(4,-x2),(-2,x5)] 3-  SAT.addPBAtLeast solver [(12345678901234567890,-x4),(4,x3)] 10-  SAT.addPBExactly solver [(2,-x2),(3,-x4),(2,x1),(3,x5)] 5--  ret <- SAT.solve solver-  ret @?= True---- いきなり矛盾したPB制約-case_root_inconsistent_PB :: Assertion-case_root_inconsistent_PB = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addPBAtLeast solver [(2,x1),(3,x2)] 6-  ret <- SAT.solve solver-  ret @?= False--case_pb_propagate :: Assertion-case_pb_propagate = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addPBAtLeast solver [(1,x1),(3,x2)] 3-  SAT.addClause solver [-x1]-  ret <- SAT.solve solver-  ret @?= True--case_solveWith_1 :: Assertion-case_solveWith_1 = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  SAT.addClause solver [x1, x2]       -- x1 or x2-  SAT.addClause solver [x1, -x2]      -- x1 or not x2-  SAT.addClause solver [-x1, -x2]     -- not x1 or not x2-  SAT.addClause solver [-x3, -x1, x2] -- not x3 or not x1 or x2--  ret <- SAT.solve solver -- sat-  ret @?= True--  ret <- SAT.solveWith solver [x3] -- unsat-  ret @?= False--  ret <- SAT.solve solver -- sat-  ret @?= True--case_solveWith_2 :: Assertion-case_solveWith_2 = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [-x1, x2] -- -x1 or x2-  SAT.addClause solver [x1]      -- x1--  ret <- SAT.solveWith solver [x2]-  ret @?= True--  ret <- SAT.solveWith solver [-x2]-  ret @?= False--case_getVarFixed :: Assertion-case_getVarFixed = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  SAT.addClause solver [x1,x2]--  ret <- SAT.getVarFixed solver x1-  ret @?= lUndef--  SAT.addClause solver [-x1]-  -  ret <- SAT.getVarFixed solver x1-  ret @?= lFalse--  ret <- SAT.getLitFixed solver (-x1)-  ret @?= lTrue--  ret <- SAT.getLitFixed solver x2-  ret @?= lTrue--case_getAssumptionsImplications_case1 :: Assertion-case_getAssumptionsImplications_case1 = do-  solver <- SAT.newSolver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  SAT.addClause solver [x1,x2,x3]--  SAT.addClause solver [-x1]-  ret <- SAT.solveWith solver [-x2]-  ret @?= True-  xs <- SAT.getAssumptionsImplications solver-  xs @?= [x3]--prop_getAssumptionsImplications :: Property-prop_getAssumptionsImplications = QM.monadicIO $ do-  cnf <- QM.pick arbitraryCNF-  solver <- arbitrarySolver-  ls <- QM.pick $ liftM concat $ mapM (\v -> elements [[],[-v],[v]]) [1..CNF.numVars cnf]-  ret <- QM.run $ do-    SAT.newVars_ solver (CNF.numVars cnf)-    forM_ (CNF.clauses cnf) $ \c -> SAT.addClause solver c-    SAT.solveWith solver ls-  when ret $ do-    xs <- QM.run $ SAT.getAssumptionsImplications solver-    forM_ xs $ \x -> do-      ret2 <- QM.run $ SAT.solveWith solver (-x : ls)-      QM.assert $ not ret2------------------------------------------------------------------------------ -4*(not x1) + 3*x1 + 10*(not x2)--- = -4*(1 - x1) + 3*x1 + 10*(not x2)--- = -4 + 4*x1 + 3*x1 + 10*(not x2)--- = 7*x1 + 10*(not x2) - 4-case_normalizePBLinSum_1 :: Assertion-case_normalizePBLinSum_1 = do-  sort e @?= sort [(7,x1),(10,-x2)]-  c @?= -4-  where-    x1 = 1-    x2 = 2-    (e,c) = SAT.normalizePBLinSum ([(-4,-x1),(3,x1),(10,-x2)], 0)--prop_normalizePBLinSum :: Property-prop_normalizePBLinSum = forAll g $ \(nv, (s,n)) ->-    let (s2,n2) = SAT.normalizePBLinSum (s,n)-    in flip all (allAssignments nv) $ \m ->-         SAT.evalPBLinSum m s + n == SAT.evalPBLinSum m s2 + n2-  where-    g :: Gen (Int, (SAT.PBLinSum, Integer))-    g = do-      nv <- choose (0, 10)-      s <- forM [1..nv] $ \x -> do-        c <- arbitrary-        p <- arbitrary-        return (c, SAT.literal x p)-      n <- arbitrary-      return (nv, (s,n))---- -4*(not x1) + 3*x1 + 10*(not x2) >= 3--- ⇔ -4*(1 - x1) + 3*x1 + 10*(not x2) >= 3--- ⇔ -4 + 4*x1 + 3*x1 + 10*(not x2) >= 3--- ⇔ 7*x1 + 10*(not x2) >= 7--- ⇔ 7*x1 + 7*(not x2) >= 7--- ⇔ x1 + (not x2) >= 1-case_normalizePBLinAtLeast_1 :: Assertion-case_normalizePBLinAtLeast_1 = (sort lhs, rhs) @?= (sort [(1,x1),(1,-x2)], 1)-  where-    x1 = 1-    x2 = 2-    (lhs,rhs) = SAT.normalizePBLinAtLeast ([(-4,-x1),(3,x1),(10,-x2)], 3)--prop_normalizePBLinAtLeast :: Property-prop_normalizePBLinAtLeast = forAll g $ \(nv, c) ->-    let c2 = SAT.normalizePBLinAtLeast c-    in flip all (allAssignments nv) $ \m ->-         SAT.evalPBLinAtLeast m c == SAT.evalPBLinAtLeast m c2-  where-    g :: Gen (Int, SAT.PBLinAtLeast)-    g = do-      nv <- choose (0, 10)-      lhs <- forM [1..nv] $ \x -> do-        c <- arbitrary-        p <- arbitrary-        return (c, SAT.literal x p)-      rhs <- arbitrary-      return (nv, (lhs,rhs))--case_normalizePBLinExactly_1 :: Assertion-case_normalizePBLinExactly_1 = (sort lhs, rhs) @?= ([], 1)-  where-    x1 = 1-    x2 = 2-    (lhs,rhs) = SAT.normalizePBLinExactly ([(6,x1),(4,x2)], 2)--case_normalizePBLinExactly_2 :: Assertion-case_normalizePBLinExactly_2 = (sort lhs, rhs) @?= ([], 1)-  where-    x1 = 1-    x2 = 2-    x3 = 3-    (lhs,rhs) = SAT.normalizePBLinExactly ([(2,x1),(2,x2),(2,x3)], 3)--prop_normalizePBLinExactly :: Property-prop_normalizePBLinExactly = forAll g $ \(nv, c) ->-    let c2 = SAT.normalizePBLinExactly c-    in flip all (allAssignments nv) $ \m ->-         SAT.evalPBLinExactly m c == SAT.evalPBLinExactly m c2-  where-    g :: Gen (Int, SAT.PBLinExactly)-    g = do-      nv <- choose (0, 10)-      lhs <- forM [1..nv] $ \x -> do-        c <- arbitrary-        p <- arbitrary-        return (c, SAT.literal x p)-      rhs <- arbitrary-      return (nv, (lhs,rhs))--prop_cutResolve :: Property-prop_cutResolve =-  forAll (choose (1, 10)) $ \nv ->-    forAll (g nv True) $ \c1 ->-      forAll (g nv False) $ \c2 ->-        let c3 = SAT.cutResolve c1 c2 1-        in flip all (allAssignments nv) $ \m ->-             not (SAT.evalPBLinExactly m c1 && SAT.evalPBLinExactly m c2) || SAT.evalPBLinExactly m c3-  where-    g :: Int -> Bool -> Gen SAT.PBLinExactly-    g nv b = do-      lhs <- forM [1..nv] $ \x -> do-        if x==1 then do-          c <- liftM ((1+) . abs) arbitrary-          return (c, SAT.literal x b)-        else do-          c <- arbitrary-          p <- arbitrary-          return (c, SAT.literal x p)-      rhs <- arbitrary-      return (lhs, rhs)--case_cutResolve_1 :: Assertion-case_cutResolve_1 = (sort lhs, rhs) @?= (sort [(1,x3),(1,x4)], 1)-  where-    x1 = 1-    x2 = 2-    x3 = 3-    x4 = 4-    pb1 = ([(1,x1), (1,x2), (1,x3)], 1)-    pb2 = ([(2,-x1), (2,-x2), (1,x4)], 3)-    (lhs,rhs) = SAT.cutResolve pb1 pb2 x1--case_cutResolve_2 :: Assertion-case_cutResolve_2 = (sort lhs, rhs) @?= (sort lhs2, rhs2)-  where-    x1 = 1-    x2 = 2-    x3 = 3-    x4 = 4-    pb1 = ([(3,x1), (2,-x2), (1,x3), (1,x4)], 3)-    pb2 = ([(1,-x3), (1,x4)], 1)-    (lhs,rhs) = SAT.cutResolve pb1 pb2 x3-    (lhs2,rhs2) = ([(2,x1),(1,-x2),(1,x4)],2) -- ([(3,x1),(2,-x2),(2,x4)], 3)--case_cardinalityReduction :: Assertion-case_cardinalityReduction = (sort lhs, rhs) @?= ([1,2,3,4,5],4)-  where-    (lhs, rhs) = SAT.cardinalityReduction ([(6,1),(5,2),(4,3),(3,4),(2,5),(1,6)], 17)--case_pbSubsume_clause :: Assertion-case_pbSubsume_clause = SAT.pbSubsume ([(1,1),(1,-3)],1) ([(1,1),(1,2),(1,-3),(1,4)],1) @?= True--case_pbSubsume_1 :: Assertion-case_pbSubsume_1 = SAT.pbSubsume ([(1,1),(1,2),(1,-3)],2) ([(1,1),(2,2),(1,-3),(1,4)],1) @?= True--case_pbSubsume_2 :: Assertion-case_pbSubsume_2 = SAT.pbSubsume ([(1,1),(1,2),(1,-3)],2) ([(1,1),(2,2),(1,-3),(1,4)],3) @?= False----------------------------------------------------------------------------case_normalizeXORClause_False =-  SAT.normalizeXORClause ([],True) @?= ([],True)--case_normalizeXORClause_True =-  SAT.normalizeXORClause ([],False) @?= ([],False)---- x ⊕ y ⊕ x = y-case_normalizeXORClause_case1 =-  SAT.normalizeXORClause ([1,2,1],True) @?= ([2],True)---- x ⊕ ¬x = x ⊕ x ⊕ 1 = 1-case_normalizeXORClause_case2 =-  SAT.normalizeXORClause ([1,-1],True) @?= ([],False)--prop_normalizeXORClause :: Property-prop_normalizeXORClause = forAll g $ \(nv, c) ->-    let c2 = SAT.normalizeXORClause c-    in flip all (allAssignments nv) $ \m ->-         SAT.evalXORClause m c == SAT.evalXORClause m c2-  where-    g :: Gen (Int, SAT.XORClause)-    g = do-      nv <- choose (0, 10)-      len <- choose (0, nv)-      lhs <- replicateM len $ choose (-nv, nv) `suchThat` (/= 0)-      rhs <- arbitrary-      return (nv, (lhs,rhs))--case_evalXORClause_case1 =-  SAT.evalXORClause (array (1,2) [(1,True),(2,True)] :: Array Int Bool) ([1,2], True) @?= False--case_evalXORClause_case2 =-  SAT.evalXORClause (array (1,2) [(1,False),(2,True)] :: Array Int Bool) ([1,2], True) @?= True--case_xor_case1 = do-  solver <- SAT.newSolver-  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  SAT.addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True-  SAT.addXORClause solver [x2, x3] True -- x2 ⊕ x3 = True-  SAT.addXORClause solver [x3, x1] True -- x3 ⊕ x1 = True-  ret <- SAT.solve solver-  ret @?= False--case_xor_case2 = do-  solver <- SAT.newSolver-  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  SAT.addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True-  SAT.addXORClause solver [x1, x3] True -- x1 ⊕ x3 = True-  SAT.addClause solver [x2]--  ret <- SAT.solve solver-  ret @?= True-  m <- SAT.getModel solver-  m ! x1 @?= False-  m ! x2 @?= True-  m ! x3 @?= True--case_xor_case3 = do-  solver <- SAT.newSolver-  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- SAT.newVar solver-  x4 <- SAT.newVar solver-  SAT.addXORClause solver [x1,x2,x3,x4] True-  SAT.addAtLeast solver [x1,x2,x3,x4] 2-  ret <- SAT.solve solver-  ret @?= True------------------------------------------------------------------------------ from "Pueblo: A Hybrid Pseudo-Boolean SAT Solver"--- clauseがunitになるレベルで、PB制約が違反状態のままという例。-case_hybridLearning_1 :: Assertion-case_hybridLearning_1 = do-  solver <- SAT.newSolver-  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] <- replicateM 11 (SAT.newVar solver)--  SAT.addClause solver [x11, x10, x9] -- C1-  SAT.addClause solver [x8, x7, x6]   -- C2-  SAT.addClause solver [x5, x4, x3]   -- C3-  SAT.addAtLeast solver [-x2, -x5, -x8, -x11] 3 -- C4-  SAT.addAtLeast solver [-x1, -x4, -x7, -x10] 3 -- C5--  replicateM 3 (SAT.varBumpActivity solver x3)-  SAT.setVarPolarity solver x3 False--  replicateM 2 (SAT.varBumpActivity solver x6)-  SAT.setVarPolarity solver x6 False--  replicateM 1 (SAT.varBumpActivity solver x9)-  SAT.setVarPolarity solver x9 False--  SAT.setVarPolarity solver x1 True--  SAT.modifyConfig solver $ \config -> config{ SAT.configLearningStrategy = SAT.LearningHybrid }-  ret <- SAT.solve solver-  ret @?= True---- from "Pueblo: A Hybrid Pseudo-Boolean SAT Solver"--- clauseがunitになるレベルで、PB制約が違反状態のままという例。--- さらに、学習したPB制約はunitにはならない。-case_hybridLearning_2 :: Assertion-case_hybridLearning_2 = do-  solver <- SAT.newSolver-  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12] <- replicateM 12 (SAT.newVar solver)--  SAT.addClause solver [x11, x10, x9] -- C1-  SAT.addClause solver [x8, x7, x6]   -- C2-  SAT.addClause solver [x5, x4, x3]   -- C3-  SAT.addAtLeast solver [-x2, -x5, -x8, -x11] 3 -- C4-  SAT.addAtLeast solver [-x1, -x4, -x7, -x10] 3 -- C5--  SAT.addClause solver [x12, -x3]-  SAT.addClause solver [x12, -x6]-  SAT.addClause solver [x12, -x9]--  SAT.varBumpActivity solver x12-  SAT.setVarPolarity solver x12 False--  SAT.modifyConfig solver $ \config -> config{ SAT.configLearningStrategy = SAT.LearningHybrid }-  ret <- SAT.solve solver-  ret @?= True---- regression test for the bug triggered by normalized-blast-floppy1-8.ucl.opb.bz2-case_addPBAtLeast_regression :: Assertion-case_addPBAtLeast_regression = do-  solver <- SAT.newSolver-  [x1,x2,x3,x4] <- replicateM 4 (SAT.newVar solver)-  SAT.addClause solver [-x1]-  SAT.addClause solver [-x2, -x3]-  SAT.addClause solver [-x2, -x4]-  SAT.addPBAtLeast solver [(1,x1),(2,x2),(1,x3),(1,x4)] 3-  ret <- SAT.solve solver-  ret @?= False----------------------------------------------------------------------------case_addFormula = do-  solver <- SAT.newSolver-  enc <- Tseitin.newEncoder solver--  [x1,x2,x3,x4,x5] <- replicateM 5 $ liftM Atom $ SAT.newVar solver-  Tseitin.addFormula enc $ orB [x1 .=>. x3 .&&. x4, x2 .=>. x3 .&&. x5]-  -- x6 = x3 ∧ x4-  -- x7 = x3 ∧ x5-  Tseitin.addFormula enc $ x1 .||. x2-  Tseitin.addFormula enc $ x4 .=>. notB x5-  ret <- SAT.solve solver-  ret @?= True--  Tseitin.addFormula enc $ x2 .<=>. x4-  ret <- SAT.solve solver-  ret @?= True--  Tseitin.addFormula enc $ x1 .<=>. x5-  ret <- SAT.solve solver-  ret @?= True--  Tseitin.addFormula enc $ notB x1 .=>. x3 .&&. x5-  ret <- SAT.solve solver-  ret @?= True--  Tseitin.addFormula enc $ notB x2 .=>. x3 .&&. x4-  ret <- SAT.solve solver-  ret @?= False--case_addFormula_Peirces_Law = do-  solver <- SAT.newSolver-  enc <- Tseitin.newEncoder solver-  [x1,x2] <- replicateM 2 $ liftM Atom $ SAT.newVar solver-  Tseitin.addFormula enc $ notB $ ((x1 .=>. x2) .=>. x1) .=>. x1-  ret <- SAT.solve solver-  ret @?= False--case_encodeConj = do-  solver <- SAT.newSolver-  enc <- Tseitin.newEncoder solver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- Tseitin.encodeConj enc [x1,x2]--  ret <- SAT.solveWith solver [x3]-  ret @?= True-  m <- SAT.getModel solver-  SAT.evalLit m x1 @?= True-  SAT.evalLit m x2 @?= True-  SAT.evalLit m x3 @?= True--  ret <- SAT.solveWith solver [-x3]-  ret @?= True-  m <- SAT.getModel solver-  (SAT.evalLit m x1 && SAT.evalLit m x2) @?= False-  SAT.evalLit m x3 @?= False--case_encodeDisj = do-  solver <- SAT.newSolver-  enc <- Tseitin.newEncoder solver-  x1 <- SAT.newVar solver-  x2 <- SAT.newVar solver-  x3 <- Tseitin.encodeDisj enc [x1,x2]--  ret <- SAT.solveWith solver [x3]-  ret @?= True-  m <- SAT.getModel solver-  (SAT.evalLit m x1 || SAT.evalLit m x2) @?= True-  SAT.evalLit m x3 @?= True--  ret <- SAT.solveWith solver [-x3]-  ret @?= True-  m <- SAT.getModel solver-  SAT.evalLit m x1 @?= False-  SAT.evalLit m x2 @?= False-  SAT.evalLit m x3 @?= False--case_evalFormula = do-  solver <- SAT.newSolver-  xs <- SAT.newVars solver 5-  let f = (x1 .=>. x3 .&&. x4) .||. (x2 .=>. x3 .&&. x5)-        where-          [x1,x2,x3,x4,x5] = map Atom xs-      g :: SAT.Model -> Bool-      g m = (not x1 || (x3 && x4)) || (not x2 || (x3 && x5))-        where-          [x1,x2,x3,x4,x5] = elems m-  forM_ (allAssignments 5) $ \m -> do-    Tseitin.evalFormula m f @?= g m--prop_PBEncoder_addPBAtLeast = QM.monadicIO $ do-  let nv = 4-  (lhs,rhs) <- QM.pick $ do-    lhs <- arbitraryPBLinSum nv-    rhs <- arbitrary-    return $ SAT.normalizePBLinAtLeast (lhs, rhs)-  strategy <- QM.pick arbitrary-  (cnf,defs) <- QM.run $ do-    db <- CNFStore.newCNFStore-    SAT.newVars_ db nv-    tseitin <- Tseitin.newEncoder db-    pb <- PB.newEncoderWithStrategy tseitin strategy-    SAT.addPBAtLeast pb lhs rhs-    cnf <- CNFStore.getCNFFormula db-    defs <- Tseitin.getDefinitions tseitin-    return (cnf, defs)-  forM_ (allAssignments 4) $ \m -> do-    let m2 :: Array SAT.Var Bool-        m2 = array (1, CNF.numVars cnf) $ assocs m ++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs]-        b1 = SAT.evalPBLinAtLeast m (lhs,rhs)-        b2 = evalCNF (array (bounds m2) (assocs m2)) cnf-    QM.assert $ b1 == b2--prop_PBEncoder_Sorter_genSorter :: [Int] -> Bool-prop_PBEncoder_Sorter_genSorter xs =-  V.toList (PBEncSorter.sortVector (V.fromList xs)) == sort xs--prop_PBEncoder_Sorter_decode_encode :: Property-prop_PBEncoder_Sorter_decode_encode =-  forAll arbitrary $ \base' ->-    forAll arbitrary $ \(NonNegative x) ->-      let base = [b | Positive b <- base']-      in PBEncSorter.isRepresentable base x-         ==>-         (PBEncSorter.decode base . PBEncSorter.encode base) x == x----------------------------------------------------------------------------findMUSAssumptions_case1 :: MUS.Method -> IO ()-findMUSAssumptions_case1 method = do-  solver <- SAT.newSolver-  [x1,x2,x3] <- SAT.newVars solver 3-  sels@[y1,y2,y3,y4,y5,y6] <- SAT.newVars solver 6-  SAT.addClause solver [-y1, x1]-  SAT.addClause solver [-y2, -x1]-  SAT.addClause solver [-y3, -x1, x2]-  SAT.addClause solver [-y4, -x2]-  SAT.addClause solver [-y5, -x1, x3]-  SAT.addClause solver [-y6, -x3]--  ret <- SAT.solveWith solver sels-  ret @?= False--  actual <- MUS.findMUSAssumptions solver def{ MUS.optMethod = method }-  let actual'  = IntSet.map (\x -> x-3) actual-      expected = map IntSet.fromList [[1, 2], [1, 3, 4], [1, 5, 6]]-  actual' `elem` expected @?= True--case_findMUSAssumptions_Deletion = findMUSAssumptions_case1 MUS.Deletion-case_findMUSAssumptions_Insertion = findMUSAssumptions_case1 MUS.Insertion-case_findMUSAssumptions_QuickXplain = findMUSAssumptions_case1 MUS.QuickXplain----------------------------------------------------------------------------{--c http://sun.iwu.edu/~mliffito/publications/jar_liffiton_CAMUS.pdf-c φ= (x1) ∧ (¬x1) ∧ (¬x1∨x2) ∧ (¬x2) ∧ (¬x1∨x3) ∧ (¬x3)-c MUSes(φ) = {{C1, C2}, {C1, C3, C4}, {C1, C5, C6}}-c MCSes(φ) = {{C1}, {C2, C3, C5}, {C2, C3, C6}, {C2, C4, C5}, {C2, C4, C6}}-p cnf 3 6-1 0--1 0--1 2 0--2 0--1 3 0--3 0--}--allMUSAssumptions_case1 :: MUSEnum.Method -> IO ()-allMUSAssumptions_case1 method = do-  solver <- SAT.newSolver-  [x1,x2,x3] <- SAT.newVars solver 3-  sels@[y1,y2,y3,y4,y5,y6] <- SAT.newVars solver 6-  SAT.addClause solver [-y1, x1]-  SAT.addClause solver [-y2, -x1]-  SAT.addClause solver [-y3, -x1, x2]-  SAT.addClause solver [-y4, -x2]-  SAT.addClause solver [-y5, -x1, x3]-  SAT.addClause solver [-y6, -x3]-  (muses, mcses) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = method }-  Set.fromList muses @?= Set.fromList (map (IntSet.fromList . map (+3)) [[1,2], [1,3,4], [1,5,6]])-  Set.fromList mcses @?= Set.fromList (map (IntSet.fromList . map (+3)) [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]])--case_allMUSAssumptions_CAMUS = allMUSAssumptions_case1 MUSEnum.CAMUS-case_allMUSAssumptions_DAA = allMUSAssumptions_case1 MUSEnum.DAA-case_allMUSAssumptions_MARCO = allMUSAssumptions_case1 MUSEnum.MARCO-case_allMUSAssumptions_GurvichKhachiyan1999 = allMUSAssumptions_case1 MUSEnum.GurvichKhachiyan1999--{--Boosting a Complete Technique to Find MSS and MUS thanks to a Local Search Oracle-http://www.cril.univ-artois.fr/~piette/IJCAI07_HYCAM.pdf-Example 3.-C0  : (d)-C1  : (b ∨ c)-C2  : (a ∨ b)-C3  : (a ∨ ¬c)-C4  : (¬b ∨ ¬e)-C5  : (¬a ∨ ¬b)-C6  : (a ∨ e)-C7  : (¬a ∨ ¬e)-C8  : (b ∨ e)-C9  : (¬a ∨ b ∨ ¬c)-C10 : (¬a ∨ b ∨ ¬d)-C11 : (a ∨ ¬b ∨ c)-C12 : (a ∨ ¬b ∨ ¬d)--}-allMUSAssumptions_case2 :: MUSEnum.Method -> IO ()-allMUSAssumptions_case2 method = do-  solver <- SAT.newSolver-  [a,b,c,d,e] <- SAT.newVars solver 5-  sels@[y0,y1,y2,y3,y4,y5,y6,y7,y8,y9,y10,y11,y12] <- SAT.newVars solver 13-  SAT.addClause solver [-y0, d]-  SAT.addClause solver [-y1, b, c]-  SAT.addClause solver [-y2, a, b]-  SAT.addClause solver [-y3, a, -c]-  SAT.addClause solver [-y4, -b, -e]-  SAT.addClause solver [-y5, -a, -b]-  SAT.addClause solver [-y6, a, e]-  SAT.addClause solver [-y7, -a, -e]-  SAT.addClause solver [-y8, b, e]-  SAT.addClause solver [-y9, -a, b, -c]-  SAT.addClause solver [-y10, -a, b, -d]-  SAT.addClause solver [-y11, a, -b, c]-  SAT.addClause solver [-y12, a, -b, -d]--  -- Only three of the MUSes (marked with asterisks) are on the paper.-  let cores =-        [ [y0,y1,y2,y5,y9,y12]-        , [y0,y1,y3,y4,y5,y6,y10]-        , [y0,y1,y3,y5,y7,y8,y12]-        , [y0,y1,y3,y5,y9,y12]-        , [y0,y1,y3,y5,y10,y11]-        , [y0,y1,y3,y5,y10,y12]-        , [y0,y2,y3,y5,y10,y11]-        , [y0,y2,y4,y5,y6,y10]-        , [y0,y2,y5,y7,y8,y12]-        , [y0,y2,y5,y10,y12]   -- (*)-        , [y1,y2,y4,y5,y6,y9]-        , [y1,y3,y4,y5,y6,y7,y8]-        , [y1,y3,y4,y5,y6,y9]-        , [y1,y3,y5,y7,y8,y11]-        , [y1,y3,y5,y9,y11]    -- (*)-        , [y2,y3,y5,y7,y8,y11]-        , [y2,y4,y5,y6,y7,y8]  -- (*)-        ]--  let remove1 :: [a] -> [[a]]-      remove1 [] = []-      remove1 (x:xs) = xs : [x : ys | ys <- remove1 xs]-  forM_ cores $ \core -> do-    ret <- SAT.solveWith solver core-    assertBool (show core ++ " should be a core") (not ret)-    forM (remove1 core) $ \xs -> do-      ret <- SAT.solveWith solver xs-      assertBool (show core ++ " should be satisfiable") ret--  (actual,_) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = method }-  let actual'   = Set.fromList actual-      expected' = Set.fromList $ map IntSet.fromList $ cores-  actual' @?= expected'--case_allMUSAssumptions_2_CAMUS = allMUSAssumptions_case2 MUSEnum.CAMUS-case_allMUSAssumptions_2_DAA = allMUSAssumptions_case2 MUSEnum.DAA-case_allMUSAssumptions_2_MARCO = allMUSAssumptions_case2 MUSEnum.MARCO-case_allMUSAssumptions_2_GurvichKhachiyan1999 = allMUSAssumptions_case2 MUSEnum.GurvichKhachiyan1999--case_allMUSAssumptions_2_HYCAM = do-  solver <- SAT.newSolver-  [a,b,c,d,e] <- SAT.newVars solver 5-  sels@[y0,y1,y2,y3,y4,y5,y6,y7,y8,y9,y10,y11,y12] <- SAT.newVars solver 13-  SAT.addClause solver [-y0, d]-  SAT.addClause solver [-y1, b, c]-  SAT.addClause solver [-y2, a, b]-  SAT.addClause solver [-y3, a, -c]-  SAT.addClause solver [-y4, -b, -e]-  SAT.addClause solver [-y5, -a, -b]-  SAT.addClause solver [-y6, a, e]-  SAT.addClause solver [-y7, -a, -e]-  SAT.addClause solver [-y8, b, e]-  SAT.addClause solver [-y9, -a, b, -c]-  SAT.addClause solver [-y10, -a, b, -d]-  SAT.addClause solver [-y11, a, -b, c]-  SAT.addClause solver [-y12, a, -b, -d]--  -- Only three of the MUSes (marked with asterisks) are on the paper.-  let cores =-        [ [y0,y1,y2,y5,y9,y12]-        , [y0,y1,y3,y4,y5,y6,y10]-        , [y0,y1,y3,y5,y7,y8,y12]-        , [y0,y1,y3,y5,y9,y12]-        , [y0,y1,y3,y5,y10,y11]-        , [y0,y1,y3,y5,y10,y12]-        , [y0,y2,y3,y5,y10,y11]-        , [y0,y2,y4,y5,y6,y10]-        , [y0,y2,y5,y7,y8,y12]-        , [y0,y2,y5,y10,y12]   -- (*)-        , [y1,y2,y4,y5,y6,y9]-        , [y1,y3,y4,y5,y6,y7,y8]-        , [y1,y3,y4,y5,y6,y9]-        , [y1,y3,y5,y7,y8,y11]-        , [y1,y3,y5,y9,y11]    -- (*)-        , [y2,y3,y5,y7,y8,y11]-        , [y2,y4,y5,y6,y7,y8]  -- (*)-        ]-      mcses =-        [ [y0,y1,y7]-        , [y0,y1,y8]-        , [y0,y3,y4]-        , [y0,y3,y6]-        , [y0,y4,y11]-        , [y0,y6,y11]-        , [y0,y7,y9]-        , [y0,y8,y9]-        , [y1,y2]-        , [y1,y7,y10]-        , [y1,y8,y10]-        , [y2,y3]-        , [y3,y4,y12]-        , [y3,y6,y12]-        , [y4,y11,y12]-        , [y5]-        , [y6,y11,y12]-        , [y7,y9,y10]-        , [y8,y9,y10]-        ]--  -- HYCAM paper wrongly treated {C3,C8,C10} as a candidate MCS (CoMSS).-  -- Its complement {C0,C1,C2,C4,C5,C6,C7,C9,C11,C12} is unsatisfiable-  -- and hence not MSS.-  ret <- SAT.solveWith solver [y0,y1,y2,y4,y5,y6,y7,y9,y11,y12]-  assertBool "failed to prove the bug of HYCAM paper" (not ret)-  -  let cand = map IntSet.fromList [[y5], [y3,y2], [y0,y1,y2]]-  (actual,_) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = MUSEnum.CAMUS, MUSEnum.optKnownCSes = cand }-  let actual'   = Set.fromList $ actual-      expected' = Set.fromList $ map IntSet.fromList cores-  actual' @?= expected'----------------------------------------------------------------------------prop_ExistentialQuantification :: Property-prop_ExistentialQuantification = QM.monadicIO $ do-  phi <- QM.pick arbitraryCNF-  xs <- QM.pick $ liftM IntSet.fromList $ sublistOf [1 .. CNF.numVars phi]-  let ys = IntSet.fromList [1 .. CNF.numVars phi] IntSet.\\ xs-  psi <- QM.run $ ExistentialQuantification.project xs phi-  forM_ (replicateM (IntSet.size ys) [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1, if IntSet.null ys then 0 else IntSet.findMax ys) (zip (IntSet.toList ys) bs)-    b1 <- QM.run $ do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars phi)-      forM_ (CNF.clauses phi) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- IntSet.toList ys]-    let b2 = evalCNF m psi-    QM.assert $ b1 == b2--brauer11_phi :: CNF.CNF-brauer11_phi =-  CNF.CNF-  { CNF.numVars = 13-  , CNF.numClauses = 23-  , CNF.clauses =-      [-      -- μ-        [-x2, -y2]-      , [-y2, -y1]-      , [-x4, -x6, y1]-      , [-x3, y4], [x3, -y4]-      , [-x4, y3], [x4, -y3]-      , [-x5, y6], [x5, -y6]-      , [-x6, y5], [x6, -y5]--      -- ξ-      , [-x13, x1]-      , [-x13, -x2]-      , [-x13, x3]-      , [-x13, -x4]-      , [-x13, x5]-      , [-x13, -x6]-      , [x13, x1]-      , [x13, -x2]-      , [x13, -x3]-      , [x13, x4]-      , [x13, -x5]-      , [x13, x6]-      ]-  }-  where-    [y1,y2,y3,y4,y5,y6] = [1..6]-    [x1,x2,x3,x4,x5,x6,x13] = [7..13]--{--ξ(m'1) = (¬y1 ∧ ¬y3 ∧ y4 ∧ ¬y5 ∧ y6)-ξ(m'2) = (y1 ∧ ¬y2 ∧ ¬y3 ∧ y4 ∧ ¬y5 ∧ y6)-ξ(m'3) = (y1 ∧ ¬y2 ∧ y3 ∧ ¬y4 ∧ y5 ∧ ¬y6)-ω = ¬(ξ(m'1) ∨ ξ(m'2) ∨ ξ(m'3))--}-brauer11_omega :: CNF.CNF-brauer11_omega =-  CNF.CNF-  { CNF.numVars = 6-  , CNF.numClauses = 3-  , CNF.clauses =-      [ [y1, y3, -y4, y5, -y6]-      , [-y1, y2, y3, -y4, y5, -y6]-      , [-y1, y2, -y3, y4, -y5, y6]-      ]-  }-  where-    [y1,y2,y3,y4,y5,y6] = [1..6]--case_ExistentialQuantification_project_phi :: Assertion-case_ExistentialQuantification_project_phi = do-  psi <- ExistentialQuantification.project (IntSet.fromList [7..13]) brauer11_phi-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,13) (zip [1..] bs)    -    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_phi)-      forM_ (CNF.clauses brauer11_phi) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = all (SAT.evalClause m) (CNF.clauses psi)-    (b1 == b2) @?= True--case_ExistentialQuantification_project_phi' :: Assertion-case_ExistentialQuantification_project_phi' = do-  let [y1,y2,y3,y4,y5,y6] = [1..6]-      psi = CNF.CNF-            { CNF.numVars = 6-            , CNF.numClauses = 8-            , CNF.clauses =-                [ [-y2, y6]-                , [-y3, -y6]-                , [y5, y6]-                , [y3, -y5]-                , [y4, -y6]-                , [y1, y6]-                , [-y1, -y2]-                , [-y4, y6]-                ]-            }-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,13) (zip [1..] bs)-    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_phi)-      forM_ (CNF.clauses brauer11_phi) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = all (SAT.evalClause m) (CNF.clauses psi)    -    (b1 == b2) @?= True--case_shortestImplicants_phi :: Assertion-case_shortestImplicants_phi = do-  xss <- ExistentialQuantification.shortestImplicants (IntSet.fromList [1..6]) brauer11_phi-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,6) (zip [1..] bs)-    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_phi)-      forM_ (CNF.clauses brauer11_phi) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss-    (b1 == b2) @?= True--case_shortestImplicants_phi' :: Assertion-case_shortestImplicants_phi' = do-  let [y1,y2,y3,y4,y5,y6] = [1..6]-      xss = map IntSet.fromList-            [ [-y1, -y3, y4, -y5, y6]-            , [y1, -y2, -y3, y4, -y5, y6]-            , [y1, -y2, y3, -y4, y5, -y6]-            ]-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,6) (zip [1..] bs)-    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_phi)-      forM_ (CNF.clauses brauer11_phi) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss-    (b1 == b2) @?= True--case_shortestImplicants_omega :: Assertion-case_shortestImplicants_omega = do-  xss <- ExistentialQuantification.shortestImplicants (IntSet.fromList [1..6]) brauer11_omega-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,6) (zip [1..] bs)-    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_omega)-      forM_ (CNF.clauses brauer11_omega) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss-    unless (b1 == b2) $ print m--case_shortestImplicants_omega' :: Assertion-case_shortestImplicants_omega' = do-  let [y1,y2,y3,y4,y5,y6] = [1..6]-      xss = map IntSet.fromList-              [ [y2, -y6]-              , [y3, y6]-              , [-y5, -y6]-              , [-y3, y5]-              , [-y4, y6]-              , [-y1, -y6]-              , [y1, y2]-              , [y4, -y6]-              ]-  forM_ (replicateM 6 [False,True]) $ \bs -> do-    let m :: SAT.Model-        m = array (1,6) (zip [1..] bs)-    b1 <- do-      solver <- SAT.newSolver-      SAT.newVars_ solver (CNF.numVars brauer11_omega)-      forM_ (CNF.clauses brauer11_omega) $ \c -> SAT.addClause solver c-      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]-    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss-    (b1 == b2) @?= True-----------------------------------------------------------------------------prop_pb2sat :: Property-prop_pb2sat = QM.monadicIO $ do-  pb@(nv,cs) <- QM.pick arbitraryPB-  let f (PBRelGE,lhs,rhs) = ([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs)-      f (PBRelLE,lhs,rhs) = ([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs)-      f (PBRelEQ,lhs,rhs) = ([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs)-  let opb = PBFile.Formula-            { PBFile.pbObjectiveFunction = Nothing-            , PBFile.pbNumVars = nv-            , PBFile.pbNumConstraints = length cs-            , PBFile.pbConstraints = map f cs-            }-  let (cnf, mforth, mback) = PB2SAT.convert opb--  solver1 <- arbitrarySolver-  solver2 <- arbitrarySolver-  ret1 <- QM.run $ solvePB solver1 pb-  ret2 <- QM.run $ solveCNF solver2 cnf-  QM.assert $ isJust ret1 == isJust ret2-  case ret1 of-    Nothing -> return ()-    Just m1 -> do-      let m2 = mforth m1-      QM.assert $ bounds m2 == (1, CNF.numVars cnf)-      QM.assert $ evalCNF m2 cnf-  case ret2 of-    Nothing -> return ()-    Just m2 -> do-      let m1 = mback m2-      QM.assert $ bounds m1 == (1, nv)-      QM.assert $ evalPB m1 pb--prop_wbo2maxsat :: Property-prop_wbo2maxsat = QM.monadicIO $ do-  wbo1@(nv,cs,top) <- QM.pick arbitraryWBO-  let f (w,(PBRelGE,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs))-      f (w,(PBRelLE,lhs,rhs)) = (w,([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs))-      f (w,(PBRelEQ,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs))-  let wbo1' = PBFile.SoftFormula-            { PBFile.wboNumVars = nv-            , PBFile.wboNumConstraints = length cs-            , PBFile.wboConstraints = map f cs-            , PBFile.wboTopCost = top-            }-  let (wcnf, mforth, mback) = WBO2MaxSAT.convert wbo1'-      wbo2 = ( MaxSAT.numVars wcnf-             , [ ( if w == MaxSAT.topCost wcnf then Nothing else Just w-                 , (PBRelGE, [(1,l) | l <- clause], 1)-                 )-               | (w,clause) <- MaxSAT.clauses wcnf-               ]-             , Nothing-             )--  solver1 <- arbitrarySolver-  solver2 <- arbitrarySolver-  method <- QM.pick arbitrary-  ret1 <- QM.run $ optimizeWBO solver1 method wbo1-  ret2 <- QM.run $ optimizeWBO solver2 method wbo2-  QM.assert $ isJust ret1 == isJust ret2-  case ret1 of-    Nothing -> return ()-    Just (m1,val) -> do-      let m2 = mforth m1-      QM.assert $ bounds m2 == (1, MaxSAT.numVars wcnf)-      QM.assert $ evalWBO m2 wbo2 == Just val-  case ret2 of-    Nothing -> return ()-    Just (m2,val) -> do-      let m1 = mback m2-      QM.assert $ bounds m1 == (1, nv)-      QM.assert $ evalWBO m1 wbo1 == Just val--prop_wbo2pb :: Property-prop_wbo2pb = QM.monadicIO $ do-  wbo@(nv,cs,top) <- QM.pick arbitraryWBO-  let f (w,(PBRelGE,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Ge, rhs))-      f (w,(PBRelLE,lhs,rhs)) = (w,([(-c,[l]) | (c,l) <- lhs], PBFile.Ge, -rhs))-      f (w,(PBRelEQ,lhs,rhs)) = (w,([(c,[l]) | (c,l) <- lhs], PBFile.Eq, rhs))-  let wbo' = PBFile.SoftFormula-            { PBFile.wboNumVars = nv-            , PBFile.wboNumConstraints = length cs-            , PBFile.wboConstraints = map f cs-            , PBFile.wboTopCost = top-            }-  let (opb, mforth, mback) = WBO2PB.convert wbo'-      obj = fromMaybe [] $ PBFile.pbObjectiveFunction opb-      f (lhs, PBFile.Ge, rhs) = (PBRelGE, lhs, rhs)-      f (lhs, PBFile.Eq, rhs) = (PBRelEQ, lhs, rhs)-      cs2 = map f (PBFile.pbConstraints opb)-      pb = (PBFile.pbNumVars opb, obj, cs2)--  solver1 <- arbitrarySolver-  solver2 <- arbitrarySolver-  method <- QM.pick arbitrary-  ret1 <- QM.run $ optimizeWBO solver1 method wbo-  ret2 <- QM.run $ optimizePBNLC solver2 method pb-  QM.assert $ isJust ret1 == isJust ret2-  case ret1 of-    Nothing -> return ()-    Just (m1,val1) -> do-      let m2 = mforth m1-      QM.assert $ bounds m2 == (1, PBFile.pbNumVars opb)-      QM.assert $ evalPBNLC m2 (PBFile.pbNumVars opb, cs2)-      QM.assert $ SAT.evalPBSum m2 obj == val1-  case ret2 of-    Nothing -> return ()-    Just (m2,val2) -> do-      let m1 = mback m2-      QM.assert $ bounds m1 == (1,nv)-      QM.assert $ evalWBO m1 wbo == Just val2--prop_sat2ksat :: Property-prop_sat2ksat = QM.monadicIO $ do-  k <- QM.pick $ choose (3,10)--  cnf1 <- QM.pick arbitraryCNF-  let (cnf2, mforth, mback) = SAT2KSAT.convert k cnf1--  solver1 <- arbitrarySolver-  solver2 <- arbitrarySolver-  ret1 <- QM.run $ solveCNF solver1 cnf1-  ret2 <- QM.run $ solveCNF solver2 cnf2-  QM.assert $ isJust ret1 == isJust ret2-  case ret1 of-    Nothing -> return ()-    Just m1 -> do-      let m2 = mforth m1-      QM.assert $ bounds m2 == (1, CNF.numVars cnf2)-      QM.assert $ evalCNF m2 cnf2-  case ret2 of-    Nothing -> return ()-    Just m2 -> do-      let m1 = mback m2-      QM.assert $ bounds m1 == (1, CNF.numVars cnf1)-      QM.assert $ evalCNF m1 cnf1----------------------------------------------------------------------------instance Arbitrary SAT.LearningStrategy where-  arbitrary = arbitraryBoundedEnum--instance Arbitrary SAT.RestartStrategy where-  arbitrary = arbitraryBoundedEnum--instance Arbitrary SAT.BranchingStrategy where-  arbitrary = arbitraryBoundedEnum--instance Arbitrary SAT.PBHandlerType where-  arbitrary = arbitraryBoundedEnum--instance Arbitrary SAT.Config where-  arbitrary = do-    restartStrategy <- arbitrary-    restartFirst <- arbitrary-    restartInc <- liftM ((1.01 +) . abs) arbitrary-    learningStrategy <- arbitrary-    learntSizeFirst <- arbitrary-    learntSizeInc <- liftM ((1.01 +) . abs) arbitrary-    branchingStrategy <- arbitrary-    erwaStepSizeFirst <- choose (0, 1)-    erwaStepSizeMin   <- choose (0, 1)-    erwaStepSizeDec   <- choose (0, 1)-    pbhandler <- arbitrary-    ccmin <- choose (0,2)-    phaseSaving <- arbitrary-    forwardSubsumptionRemoval <- arbitrary-    backwardSubsumptionRemoval <- arbitrary-    randomFreq <- choose (0,1)-    splitClausePart <- arbitrary-    return $ def-      { SAT.configRestartStrategy = restartStrategy-      , SAT.configRestartFirst = restartFirst-      , SAT.configRestartInc = restartInc-      , SAT.configLearningStrategy = learningStrategy-      , SAT.configLearntSizeFirst = learntSizeFirst-      , SAT.configLearntSizeInc = learntSizeInc-      , SAT.configPBHandlerType = pbhandler-      , SAT.configCCMin = ccmin-      , SAT.configBranchingStrategy = branchingStrategy-      , SAT.configERWAStepSizeFirst = erwaStepSizeFirst-      , SAT.configERWAStepSizeDec   = erwaStepSizeDec-      , SAT.configERWAStepSizeMin   = erwaStepSizeMin-      , SAT.configEnablePhaseSaving = phaseSaving-      , SAT.configEnableForwardSubsumptionRemoval = forwardSubsumptionRemoval-      , SAT.configEnableBackwardSubsumptionRemoval = backwardSubsumptionRemoval-      , SAT.configRandomFreq = randomFreq-      , SAT.configEnablePBSplitClausePart = splitClausePart-      }--arbitrarySolver :: QM.PropertyM IO SAT.Solver-arbitrarySolver = do-  seed <- QM.pick arbitrary-  config <- QM.pick arbitrary-  QM.run $ do-    solver <- SAT.newSolverWithConfig config{ SAT.configCheckModel = True }-    SAT.setRandomGen solver =<< Rand.initialize (V.singleton seed)-    return solver--arbitraryOptimizer :: SAT.Solver -> SAT.PBLinSum -> QM.PropertyM IO PBO.Optimizer-arbitraryOptimizer solver obj = do-  method <- QM.pick arbitrary-  QM.run $ do-    opt <- PBO.newOptimizer solver obj-    PBO.setMethod opt method-    return opt--instance Arbitrary PBO.Method where-  arbitrary = arbitraryBoundedEnum--instance Arbitrary PB.Strategy where-  arbitrary = arbitraryBoundedEnum---- -----------------------------------------------------------------------#if !MIN_VERSION_QuickCheck(2,8,0)-sublistOf :: [a] -> Gen [a]-sublistOf xs = filterM (\_ -> choose (False, True)) xs-#endif+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT (satTestGroup) where++import Control.Monad+import Data.Array.IArray+import Data.Default.Class+import qualified Data.Vector as V+import qualified System.Random.MWC as Rand++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM++import ToySolver.Data.LBool+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT as SAT++import Test.SAT.Utils++prop_solveCNF :: Property+prop_solveCNF = QM.monadicIO $ do+  cnf <- QM.pick arbitraryCNF+  solver <- arbitrarySolver+  ret <- QM.run $ solveCNF solver cnf+  case ret of+    Just m -> QM.assert $ evalCNF m cnf+    Nothing -> do+      forM_ (allAssignments (CNF.cnfNumVars cnf)) $ \m -> do+        QM.assert $ not (evalCNF m cnf)++prop_solvePB :: Property+prop_solvePB = QM.monadicIO $ do+  prob@(nv,_) <- QM.pick arbitraryPB+  solver <- arbitrarySolver+  ret <- QM.run $ solvePB solver prob+  case ret of+    Just m -> QM.assert $ evalPB m prob+    Nothing -> do+      forM_ (allAssignments nv) $ \m -> do+        QM.assert $ not (evalPB m prob)++prop_optimizePBO :: Property+prop_optimizePBO = QM.monadicIO $ do+  prob@(nv,_) <- QM.pick arbitraryPB+  obj <- QM.pick $ arbitraryPBLinSum nv+  solver <- arbitrarySolver+  opt <- arbitraryOptimizer solver obj+  ret <- QM.run $ optimizePBO solver opt prob+  case ret of+    Just (m, v) -> do+      QM.assert $ evalPB m prob+      QM.assert $ SAT.evalPBLinSum m obj == v+      forM_ (allAssignments nv) $ \m2 -> do+        QM.assert $ not (evalPB m2 prob) || SAT.evalPBLinSum m obj <= SAT.evalPBLinSum m2 obj+    Nothing -> do+      forM_ (allAssignments nv) $ \m -> do+        QM.assert $ not (evalPB m prob)++prop_solvePBNLC :: Property+prop_solvePBNLC = QM.monadicIO $ do+  prob@(nv,_) <- QM.pick arbitraryPBNLC+  solver <- arbitrarySolver+  ret <- QM.run $ solvePBNLC solver prob+  case ret of+    Just m -> QM.assert $ evalPBNLC m prob+    Nothing -> do+      forM_ (allAssignments nv) $ \m -> do+        QM.assert $ not (evalPBNLC m prob)+++prop_solveXOR :: Property+prop_solveXOR = QM.monadicIO $ do+  prob@(nv,_) <- QM.pick arbitraryXOR+  solver <- arbitrarySolver+  ret <- QM.run $ solveXOR solver prob+  case ret of+    Just m -> QM.assert $ evalXOR m prob+    Nothing -> do+      forM_ (allAssignments nv) $ \m -> do+        QM.assert $ not (evalXOR m prob)++solveXOR :: SAT.Solver -> (Int,[SAT.XORClause]) -> IO (Maybe SAT.Model)+solveXOR solver (nv,cs) = do+  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }+  SAT.newVars_ solver nv+  forM_ cs $ \c -> SAT.addXORClause solver (fst c) (snd c)+  ret <- SAT.solve solver+  if ret then do+    m <- SAT.getModel solver+    return (Just m)+  else do+    return Nothing++-- should be SAT+case_solve_SAT :: Assertion+case_solve_SAT = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [x1, x2]  -- x1 or x2+  SAT.addClause solver [x1, -x2] -- x1 or not x2+  SAT.addClause solver [-x1, -x2] -- not x1 or not x2+  ret <- SAT.solve solver+  ret @?= True++-- shuld be UNSAT+case_solve_UNSAT :: Assertion+case_solve_UNSAT = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [x1,  x2]  -- x1 or x2+  SAT.addClause solver [-x1, x2]  -- not x1 or x2+  SAT.addClause solver [x1,  -x2] -- x1 or not x2+  SAT.addClause solver [-x1, -x2] -- not x2 or not x2+  ret <- SAT.solve solver+  ret @?= False++-- top level でいきなり矛盾+case_root_inconsistent :: Assertion+case_root_inconsistent = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  SAT.addClause solver [x1]+  SAT.addClause solver [-x1]+  ret <- SAT.solve solver -- unsat+  ret @?= False++-- incremental に制約を追加+case_incremental_solving :: Assertion+case_incremental_solving = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [x1,  x2]  -- x1 or x2+  SAT.addClause solver [x1,  -x2] -- x1 or not x2+  SAT.addClause solver [-x1, -x2] -- not x1 or not x2+  ret <- SAT.solve solver -- sat+  ret @?= True++  SAT.addClause solver [-x1, x2]  -- not x1 or x2+  ret <- SAT.solve solver -- unsat+  ret @?= False++-- 制約なし+case_empty_constraint :: Assertion+case_empty_constraint = do+  solver <- SAT.newSolver+  ret <- SAT.solve solver+  ret @?= True++-- 空の節+case_empty_claue :: Assertion+case_empty_claue = do+  solver <- SAT.newSolver+  SAT.addClause solver []+  ret <- SAT.solve solver+  ret @?= False++-- 自明に真な節+case_excluded_middle_claue :: Assertion+case_excluded_middle_claue = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  SAT.addClause solver [x1, -x1] -- x1 or not x1+  ret <- SAT.solve solver+  ret @?= True++-- 冗長な節+case_redundant_clause :: Assertion+case_redundant_clause = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  SAT.addClause solver [x1,x1] -- x1 or x1+  ret <- SAT.solve solver+  ret @?= True++case_instantiateClause :: Assertion+case_instantiateClause = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [x1]+  SAT.addClause solver [x1,x2]+  SAT.addClause solver [-x1,x2]+  ret <- SAT.solve solver+  ret @?= True++case_instantiateAtLeast :: Assertion+case_instantiateAtLeast = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  x4 <- SAT.newVar solver+  SAT.addClause solver [x1]++  SAT.addAtLeast solver [x1,x2,x3,x4] 2+  ret <- SAT.solve solver+  ret @?= True++  SAT.addAtLeast solver [-x1,-x2,-x3,-x4] 2+  ret <- SAT.solve solver+  ret @?= True++case_inconsistent_AtLeast :: Assertion+case_inconsistent_AtLeast = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addAtLeast solver [x1,x2] 3+  ret <- SAT.solve solver -- unsat+  ret @?= False++case_trivial_AtLeast :: Assertion+case_trivial_AtLeast = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addAtLeast solver [x1,x2] 0+  ret <- SAT.solve solver+  ret @?= True++  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addAtLeast solver [x1,x2] (-1)+  ret <- SAT.solve solver+  ret @?= True++case_AtLeast_1 :: Assertion+case_AtLeast_1 = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  SAT.addAtLeast solver [x1,x2,x3] 2+  SAT.addAtLeast solver [-x1,-x2,-x3] 2+  ret <- SAT.solve solver -- unsat+  ret @?= False++case_AtLeast_2 :: Assertion+case_AtLeast_2 = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  x4 <- SAT.newVar solver+  SAT.addAtLeast solver [x1,x2,x3,x4] 2+  SAT.addClause solver [-x1,-x2]+  SAT.addClause solver [-x1,-x3]+  ret <- SAT.solve solver+  ret @?= True++case_AtLeast_3 :: Assertion+case_AtLeast_3 = do+  forM_ [(-1) .. 3] $ \n -> do+    solver <- SAT.newSolver+    x1 <- SAT.newVar solver+    x2 <- SAT.newVar solver+    SAT.addAtLeast solver [x1,x2] n+    ret <- SAT.solve solver+    assertEqual ("case_AtLeast3_" ++ show n) (n <= 2) ret++-- from http://www.cril.univ-artois.fr/PB11/format.pdf+case_PB_sample1 :: Assertion+case_PB_sample1 = do+  solver <- SAT.newSolver++  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  x4 <- SAT.newVar solver+  x5 <- SAT.newVar solver++  SAT.addPBAtLeast solver [(1,x1),(4,x2),(-2,x5)] 2+  SAT.addPBAtLeast solver [(-1,x1),(4,x2),(-2,x5)] 3+  SAT.addPBAtLeast solver [(12345678901234567890,x4),(4,x3)] 10+  SAT.addPBExactly solver [(2,x2),(3,x4),(2,x1),(3,x5)] 5++  ret <- SAT.solve solver+  ret @?= True++-- 一部の変数を否定に置き換えたもの+case_PB_sample1' :: Assertion+case_PB_sample1' = do+  solver <- SAT.newSolver++  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  x4 <- SAT.newVar solver+  x5 <- SAT.newVar solver++  SAT.addPBAtLeast solver [(1,x1),(4,-x2),(-2,x5)] 2+  SAT.addPBAtLeast solver [(-1,x1),(4,-x2),(-2,x5)] 3+  SAT.addPBAtLeast solver [(12345678901234567890,-x4),(4,x3)] 10+  SAT.addPBExactly solver [(2,-x2),(3,-x4),(2,x1),(3,x5)] 5++  ret <- SAT.solve solver+  ret @?= True++-- いきなり矛盾したPB制約+case_root_inconsistent_PB :: Assertion+case_root_inconsistent_PB = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addPBAtLeast solver [(2,x1),(3,x2)] 6+  ret <- SAT.solve solver+  ret @?= False++case_pb_propagate :: Assertion+case_pb_propagate = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addPBAtLeast solver [(1,x1),(3,x2)] 3+  SAT.addClause solver [-x1]+  ret <- SAT.solve solver+  ret @?= True++case_solveWith_1 :: Assertion+case_solveWith_1 = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  SAT.addClause solver [x1, x2]       -- x1 or x2+  SAT.addClause solver [x1, -x2]      -- x1 or not x2+  SAT.addClause solver [-x1, -x2]     -- not x1 or not x2+  SAT.addClause solver [-x3, -x1, x2] -- not x3 or not x1 or x2++  ret <- SAT.solve solver -- sat+  ret @?= True++  ret <- SAT.solveWith solver [x3] -- unsat+  ret @?= False++  ret <- SAT.solve solver -- sat+  ret @?= True++case_solveWith_2 :: Assertion+case_solveWith_2 = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [-x1, x2] -- -x1 or x2+  SAT.addClause solver [x1]      -- x1++  ret <- SAT.solveWith solver [x2]+  ret @?= True++  ret <- SAT.solveWith solver [-x2]+  ret @?= False++case_getVarFixed :: Assertion+case_getVarFixed = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  SAT.addClause solver [x1,x2]++  ret <- SAT.getVarFixed solver x1+  ret @?= lUndef++  SAT.addClause solver [-x1]+  +  ret <- SAT.getVarFixed solver x1+  ret @?= lFalse++  ret <- SAT.getLitFixed solver (-x1)+  ret @?= lTrue++  ret <- SAT.getLitFixed solver x2+  ret @?= lTrue++case_getAssumptionsImplications_case1 :: Assertion+case_getAssumptionsImplications_case1 = do+  solver <- SAT.newSolver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  SAT.addClause solver [x1,x2,x3]++  SAT.addClause solver [-x1]+  ret <- SAT.solveWith solver [-x2]+  ret @?= True+  xs <- SAT.getAssumptionsImplications solver+  xs @?= [x3]++prop_getAssumptionsImplications :: Property+prop_getAssumptionsImplications = QM.monadicIO $ do+  cnf <- QM.pick arbitraryCNF+  solver <- arbitrarySolver+  ls <- QM.pick $ liftM concat $ mapM (\v -> elements [[],[-v],[v]]) [1..CNF.cnfNumVars cnf]+  ret <- QM.run $ do+    SAT.newVars_ solver (CNF.cnfNumVars cnf)+    forM_ (CNF.cnfClauses cnf) $ \c -> SAT.addClause solver (SAT.unpackClause c)+    SAT.solveWith solver ls+  when ret $ do+    xs <- QM.run $ SAT.getAssumptionsImplications solver+    forM_ xs $ \x -> do+      ret2 <- QM.run $ SAT.solveWith solver (-x : ls)+      QM.assert $ not ret2++------------------------------------------------------------------------++case_xor_case1 :: Assertion+case_xor_case1 = do+  solver <- SAT.newSolver+  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  SAT.addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True+  SAT.addXORClause solver [x2, x3] True -- x2 ⊕ x3 = True+  SAT.addXORClause solver [x3, x1] True -- x3 ⊕ x1 = True+  ret <- SAT.solve solver+  ret @?= False++case_xor_case2 :: Assertion+case_xor_case2 = do+  solver <- SAT.newSolver+  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  SAT.addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True+  SAT.addXORClause solver [x1, x3] True -- x1 ⊕ x3 = True+  SAT.addClause solver [x2]++  ret <- SAT.solve solver+  ret @?= True+  m <- SAT.getModel solver+  m ! x1 @?= False+  m ! x2 @?= True+  m ! x3 @?= True++case_xor_case3 :: Assertion+case_xor_case3 = do+  solver <- SAT.newSolver+  SAT.modifyConfig solver $ \config -> config{ SAT.configCheckModel = True }+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- SAT.newVar solver+  x4 <- SAT.newVar solver+  SAT.addXORClause solver [x1,x2,x3,x4] True+  SAT.addAtLeast solver [x1,x2,x3,x4] 2+  ret <- SAT.solve solver+  ret @?= True++------------------------------------------------------------------------++-- from "Pueblo: A Hybrid Pseudo-Boolean SAT Solver"+-- clauseがunitになるレベルで、PB制約が違反状態のままという例。+case_hybridLearning_1 :: Assertion+case_hybridLearning_1 = do+  solver <- SAT.newSolver+  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] <- replicateM 11 (SAT.newVar solver)++  SAT.addClause solver [x11, x10, x9] -- C1+  SAT.addClause solver [x8, x7, x6]   -- C2+  SAT.addClause solver [x5, x4, x3]   -- C3+  SAT.addAtLeast solver [-x2, -x5, -x8, -x11] 3 -- C4+  SAT.addAtLeast solver [-x1, -x4, -x7, -x10] 3 -- C5++  replicateM_ 3 (SAT.varBumpActivity solver x3)+  SAT.setVarPolarity solver x3 False++  replicateM_ 2 (SAT.varBumpActivity solver x6)+  SAT.setVarPolarity solver x6 False++  replicateM_ 1 (SAT.varBumpActivity solver x9)+  SAT.setVarPolarity solver x9 False++  SAT.setVarPolarity solver x1 True++  SAT.modifyConfig solver $ \config -> config{ SAT.configLearningStrategy = SAT.LearningHybrid }+  ret <- SAT.solve solver+  ret @?= True++-- from "Pueblo: A Hybrid Pseudo-Boolean SAT Solver"+-- clauseがunitになるレベルで、PB制約が違反状態のままという例。+-- さらに、学習したPB制約はunitにはならない。+case_hybridLearning_2 :: Assertion+case_hybridLearning_2 = do+  solver <- SAT.newSolver+  [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12] <- replicateM 12 (SAT.newVar solver)++  SAT.addClause solver [x11, x10, x9] -- C1+  SAT.addClause solver [x8, x7, x6]   -- C2+  SAT.addClause solver [x5, x4, x3]   -- C3+  SAT.addAtLeast solver [-x2, -x5, -x8, -x11] 3 -- C4+  SAT.addAtLeast solver [-x1, -x4, -x7, -x10] 3 -- C5++  SAT.addClause solver [x12, -x3]+  SAT.addClause solver [x12, -x6]+  SAT.addClause solver [x12, -x9]++  SAT.varBumpActivity solver x12+  SAT.setVarPolarity solver x12 False++  SAT.modifyConfig solver $ \config -> config{ SAT.configLearningStrategy = SAT.LearningHybrid }+  ret <- SAT.solve solver+  ret @?= True++-- regression test for the bug triggered by normalized-blast-floppy1-8.ucl.opb.bz2+case_addPBAtLeast_regression :: Assertion+case_addPBAtLeast_regression = do+  solver <- SAT.newSolver+  [x1,x2,x3,x4] <- replicateM 4 (SAT.newVar solver)+  SAT.addClause solver [-x1]+  SAT.addClause solver [-x2, -x3]+  SAT.addClause solver [-x2, -x4]+  SAT.addPBAtLeast solver [(1,x1),(2,x2),(1,x3),(1,x4)] 3+  ret <- SAT.solve solver+  ret @?= False++-- https://github.com/msakai/toysolver/issues/22+case_issue22 :: Assertion+case_issue22 = do+  let config = def+        { SAT.configLearningStrategy = SAT.LearningHybrid+        , SAT.configCCMin = 2+        , SAT.configBranchingStrategy = SAT.BranchingLRB+        , SAT.configRandomFreq = 0.2816351099559239+        , SAT.configPBHandlerType = SAT.PBHandlerTypeCounter+        }+  solver <- SAT.newSolverWithConfig config+  _ <- SAT.newVars solver 14+  SAT.addClause solver [-7,-1]+  SAT.addClause solver [-9,-4]+  SAT.addClause solver [-9,1]+  SAT.addClause solver [-10,-1]+  SAT.addClause solver [-11,-1]+  SAT.addClause solver [-12,-4]+  SAT.addClause solver [-12,4]+  SAT.addClause solver [-13,-3]+  SAT.addClause solver [-13,-1]+  SAT.addClause solver [-13,3]+  SAT.addClause solver [-14,-1]+  SAT.addPBAtLeast solver [ (1,-14), (10,13), (7,12), (13,-11), (14,-10), (16,9), (8,8), (9,-7)]   38+  SAT.addPBAtLeast solver [(-1,-14),(-10,13),(-7,12),(-13,-11),(-14,-10),(-16,9),(-8,8),(-9,-7)] (-38)+  SAT.setRandomGen solver =<< Rand.initialize (V.singleton 71)+  _ <- SAT.solve solver+  return ()+{-+Scenario:+decide 4@1+deduce -12 by [-12,-4]+deduce -9 by [-9,-4]+decide 1@2+deduce -14 by [-14,-1]+deduce -13 by [-13,-1]+deduce -11 by [-11,-1]+deduce -10 by [-10,-1]+deduce -7 by [-7,-1]+deduce 8 by [(16,9),(14,-10),(13,-11),(10,13),(9,-7),(8,8),(7,12),(1,-14)] >= 38+conflict: [(16,-9),(14,10),(13,11),(10,-13),(9,7),(8,-8),(7,-12),(1,14)] >= 40+conflict analysis yields+  [-1,9,12] @1, and+  [(1,14),(2,-13),(1,12),(8,-9),(17,-1)],17) >= 17 @1 (but it should be @0)+backtrack to @1+deduce -1 by [-1,9,12]+decide 3@3+deduce -13 by [-13,-3]+deduce -10, -11, -7, 8 by [(16,9),(14,-10),(13,-11),(10,13),(9,-7),(8,8),(7,12),(1,-14)] >= 38+conflict [(16,-9),(14,10),(13,11),(10,-13),(9,7),(8,-8),(7,-12),(1,14)] >= 40+conflict analysis yields+  [13,9,12] @1 and+  [(1,14),(7,13),(7,12),(7,9)] >= 7 @1 (but it should be @0)+backtrack to @1+deduce 13 by [13,9,12]+deduce 3 by [3,-13]+conflict [-3,-13]+conflict analysis yields+  -13 @ 0+decide -7@1+decide -14@2+deduce -1 by [(17,-1),(8,-9),(2,-13),(1,14),(1,12)] >= 17+deduce -9 by [-9,1]+deduce 12 by [12,9,13]+deduce 4 by [4,-12]+conflict: [-4,-12]+conflict analysis yields [] and that causes error+-}  ------------------------------------------------------------------------ -- Test harness
+ test/Test/SAT/Encoder.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.Encoder (satEncoderTestGroup) where++import Control.Monad+import Data.Array.IArray+import Data.List+import Data.Maybe+import qualified Data.Vector as V++import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&&.), (.||.))+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM++import ToySolver.Data.BoolExpr+import ToySolver.Data.Boolean+import qualified ToySolver.FileFormat.CNF as CNF+import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import qualified ToySolver.SAT.Encoder.Cardinality as Cardinality+import qualified ToySolver.SAT.Encoder.PB as PB+import qualified ToySolver.SAT.Encoder.PB.Internal.Sorter as PBEncSorter+import qualified ToySolver.SAT.Store.CNF as CNFStore++import Test.SAT.Utils++case_addFormula :: Assertion+case_addFormula = do+  solver <- SAT.newSolver+  enc <- Tseitin.newEncoder solver++  [x1,x2,x3,x4,x5] <- replicateM 5 $ liftM Atom $ SAT.newVar solver+  Tseitin.addFormula enc $ orB [x1 .=>. x3 .&&. x4, x2 .=>. x3 .&&. x5]+  -- x6 = x3 ∧ x4+  -- x7 = x3 ∧ x5+  Tseitin.addFormula enc $ x1 .||. x2+  Tseitin.addFormula enc $ x4 .=>. notB x5+  ret <- SAT.solve solver+  ret @?= True++  Tseitin.addFormula enc $ x2 .<=>. x4+  ret <- SAT.solve solver+  ret @?= True++  Tseitin.addFormula enc $ x1 .<=>. x5+  ret <- SAT.solve solver+  ret @?= True++  Tseitin.addFormula enc $ notB x1 .=>. x3 .&&. x5+  ret <- SAT.solve solver+  ret @?= True++  Tseitin.addFormula enc $ notB x2 .=>. x3 .&&. x4+  ret <- SAT.solve solver+  ret @?= False++case_addFormula_Peirces_Law :: Assertion+case_addFormula_Peirces_Law = do+  solver <- SAT.newSolver+  enc <- Tseitin.newEncoder solver+  [x1,x2] <- replicateM 2 $ liftM Atom $ SAT.newVar solver+  Tseitin.addFormula enc $ notB $ ((x1 .=>. x2) .=>. x1) .=>. x1+  ret <- SAT.solve solver+  ret @?= False++case_encodeConj :: Assertion+case_encodeConj = do+  solver <- SAT.newSolver+  enc <- Tseitin.newEncoder solver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- Tseitin.encodeConj enc [x1,x2]++  ret <- SAT.solveWith solver [x3]+  ret @?= True+  m <- SAT.getModel solver+  SAT.evalLit m x1 @?= True+  SAT.evalLit m x2 @?= True+  SAT.evalLit m x3 @?= True++  ret <- SAT.solveWith solver [-x3]+  ret @?= True+  m <- SAT.getModel solver+  (SAT.evalLit m x1 && SAT.evalLit m x2) @?= False+  SAT.evalLit m x3 @?= False++case_encodeDisj :: Assertion+case_encodeDisj = do+  solver <- SAT.newSolver+  enc <- Tseitin.newEncoder solver+  x1 <- SAT.newVar solver+  x2 <- SAT.newVar solver+  x3 <- Tseitin.encodeDisj enc [x1,x2]++  ret <- SAT.solveWith solver [x3]+  ret @?= True+  m <- SAT.getModel solver+  (SAT.evalLit m x1 || SAT.evalLit m x2) @?= True+  SAT.evalLit m x3 @?= True++  ret <- SAT.solveWith solver [-x3]+  ret @?= True+  m <- SAT.getModel solver+  SAT.evalLit m x1 @?= False+  SAT.evalLit m x2 @?= False+  SAT.evalLit m x3 @?= False++case_evalFormula :: Assertion+case_evalFormula = do+  solver <- SAT.newSolver+  xs <- SAT.newVars solver 5+  let f = (x1 .=>. x3 .&&. x4) .||. (x2 .=>. x3 .&&. x5)+        where+          [x1,x2,x3,x4,x5] = map Atom xs+      g :: SAT.Model -> Bool+      g m = (not x1 || (x3 && x4)) || (not x2 || (x3 && x5))+        where+          [x1,x2,x3,x4,x5] = elems m+  forM_ (allAssignments 5) $ \m -> do+    Tseitin.evalFormula m f @?= g m++prop_PBEncoder_addPBAtLeast :: Property+prop_PBEncoder_addPBAtLeast = QM.monadicIO $ do+  let nv = 4+  (lhs,rhs) <- QM.pick $ do+    lhs <- arbitraryPBLinSum nv+    rhs <- arbitrary+    return $ SAT.normalizePBLinAtLeast (lhs, rhs)+  strategy <- QM.pick arbitrary+  (cnf,defs) <- QM.run $ do+    db <- CNFStore.newCNFStore+    SAT.newVars_ db nv+    tseitin <- Tseitin.newEncoder db+    pb <- PB.newEncoderWithStrategy tseitin strategy+    SAT.addPBAtLeast pb lhs rhs+    cnf <- CNFStore.getCNFFormula db+    defs <- Tseitin.getDefinitions tseitin+    return (cnf, defs)+  forM_ (allAssignments 4) $ \m -> do+    let m2 :: Array SAT.Var Bool+        m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs]+        b1 = SAT.evalPBLinAtLeast m (lhs,rhs)+        b2 = evalCNF (array (bounds m2) (assocs m2)) cnf+    QM.assert $ b1 == b2++prop_PBEncoder_Sorter_genSorter :: [Int] -> Bool+prop_PBEncoder_Sorter_genSorter xs =+  V.toList (PBEncSorter.sortVector (V.fromList xs)) == sort xs++prop_PBEncoder_Sorter_decode_encode :: Property+prop_PBEncoder_Sorter_decode_encode =+  forAll arbitrary $ \base' ->+    forAll arbitrary $ \(NonNegative x) ->+      let base = [b | Positive b <- base']+      in PBEncSorter.isRepresentable base x+         ==>+         (PBEncSorter.decode base . PBEncSorter.encode base) x == x++prop_CardinalityEncoder_addAtLeast :: Property+prop_CardinalityEncoder_addAtLeast = QM.monadicIO $ do+  let nv = 4+  (lhs,rhs) <- QM.pick $ do+    lhs <- liftM catMaybes $ forM [1..nv] $ \i -> do+      b <- arbitrary+      if b then+        Just <$> elements [i, -i]+      else+        return Nothing+    rhs <- choose (-1, nv+2)+    return $ (lhs, rhs)+  strategy <- QM.pick arbitrary+  (cnf,defs) <- QM.run $ do+    db <- CNFStore.newCNFStore+    SAT.newVars_ db nv+    tseitin <- Tseitin.newEncoder db+    card <- Cardinality.newEncoderWithStrategy tseitin strategy+    SAT.addAtLeast card lhs rhs+    cnf <- CNFStore.getCNFFormula db+    defs <- Tseitin.getDefinitions tseitin+    return (cnf, defs)+  forM_ (allAssignments nv) $ \m -> do+    let m2 :: Array SAT.Var Bool+        m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs]+        b1 = SAT.evalAtLeast m (lhs,rhs)+        b2 = evalCNF (array (bounds m2) (assocs m2)) cnf+    QM.assert $ b1 == b2++satEncoderTestGroup :: TestTree+satEncoderTestGroup = $(testGroupGenerator)
+ test/Test/SAT/ExistentialQuantification.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.ExistentialQuantification (satExistentialQuantificationTestGroup) where++import Control.Monad+import qualified Data.IntSet as IntSet++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM++import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.ExistentialQuantification as ExistentialQuantification+import qualified ToySolver.FileFormat.CNF as CNF++import Test.SAT.Utils++prop_ExistentialQuantification :: Property+prop_ExistentialQuantification = QM.monadicIO $ do+  phi <- QM.pick arbitraryCNF+  xs <- QM.pick $ liftM IntSet.fromList $ sublistOf [1 .. CNF.cnfNumVars phi]+  let ys = IntSet.fromList [1 .. CNF.cnfNumVars phi] IntSet.\\ xs+  psi <- QM.run $ ExistentialQuantification.project xs phi+  forM_ (allAssignments (if IntSet.null ys then 0 else IntSet.findMax ys)) $ \m -> do+    b1 <- QM.run $ do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars phi)+      forM_ (CNF.cnfClauses phi) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- IntSet.toList ys]+    let b2 = evalCNF m psi+    QM.assert $ b1 == b2++brauer11_phi :: CNF.CNF+brauer11_phi =+  CNF.CNF+  { CNF.cnfNumVars = 13+  , CNF.cnfNumClauses = 23+  , CNF.cnfClauses = fmap SAT.packClause+      [+      -- μ+        [-x2, -y2]+      , [-y2, -y1]+      , [-x4, -x6, y1]+      , [-x3, y4], [x3, -y4]+      , [-x4, y3], [x4, -y3]+      , [-x5, y6], [x5, -y6]+      , [-x6, y5], [x6, -y5]++      -- ξ+      , [-x13, x1]+      , [-x13, -x2]+      , [-x13, x3]+      , [-x13, -x4]+      , [-x13, x5]+      , [-x13, -x6]+      , [x13, x1]+      , [x13, -x2]+      , [x13, -x3]+      , [x13, x4]+      , [x13, -x5]+      , [x13, x6]+      ]+  }+  where+    [y1,y2,y3,y4,y5,y6] = [1..6]+    [x1,x2,x3,x4,x5,x6,x13] = [7..13]++{-+ξ(m'1) = (¬y1 ∧ ¬y3 ∧ y4 ∧ ¬y5 ∧ y6)+ξ(m'2) = (y1 ∧ ¬y2 ∧ ¬y3 ∧ y4 ∧ ¬y5 ∧ y6)+ξ(m'3) = (y1 ∧ ¬y2 ∧ y3 ∧ ¬y4 ∧ y5 ∧ ¬y6)+ω = ¬(ξ(m'1) ∨ ξ(m'2) ∨ ξ(m'3))+-}+brauer11_omega :: CNF.CNF+brauer11_omega =+  CNF.CNF+  { CNF.cnfNumVars = 6+  , CNF.cnfNumClauses = 3+  , CNF.cnfClauses = map SAT.packClause+      [ [y1, y3, -y4, y5, -y6]+      , [-y1, y2, y3, -y4, y5, -y6]+      , [-y1, y2, -y3, y4, -y5, y6]+      ]+  }+  where+    [y1,y2,y3,y4,y5,y6] = [1..6]++case_ExistentialQuantification_project_phi :: Assertion+case_ExistentialQuantification_project_phi = do+  psi <- ExistentialQuantification.project (IntSet.fromList [7..13]) brauer11_phi+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_phi)+      forM_ (CNF.cnfClauses brauer11_phi) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = all (SAT.evalClause m . SAT.unpackClause) (CNF.cnfClauses psi)+    (b1 == b2) @?= True++case_ExistentialQuantification_project_phi' :: Assertion+case_ExistentialQuantification_project_phi' = do+  let [y1,y2,y3,y4,y5,y6] = [1..6]+      psi = CNF.CNF+            { CNF.cnfNumVars = 6+            , CNF.cnfNumClauses = 8+            , CNF.cnfClauses = map SAT.packClause+                [ [-y2, y6]+                , [-y3, -y6]+                , [y5, y6]+                , [y3, -y5]+                , [y4, -y6]+                , [y1, y6]+                , [-y1, -y2]+                , [-y4, y6]+                ]+            }+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_phi)+      forM_ (CNF.cnfClauses brauer11_phi) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = all (SAT.evalClause m . SAT.unpackClause) (CNF.cnfClauses psi)    +    (b1 == b2) @?= True++case_shortestImplicantsE_phi :: Assertion+case_shortestImplicantsE_phi = do+  xss <- ExistentialQuantification.shortestImplicantsE (IntSet.fromList [7..13]) brauer11_phi+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_phi)+      forM_ (CNF.cnfClauses brauer11_phi) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss+    (b1 == b2) @?= True++case_shortestImplicantsE_phi' :: Assertion+case_shortestImplicantsE_phi' = do+  let [y1,y2,y3,y4,y5,y6] = [1..6]+      xss = map IntSet.fromList+            [ [-y1, -y3, y4, -y5, y6]+            , [y1, -y2, -y3, y4, -y5, y6]+            , [y1, -y2, y3, -y4, y5, -y6]+            ]+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_phi)+      forM_ (CNF.cnfClauses brauer11_phi) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss+    (b1 == b2) @?= True++case_shortestImplicantsE_omega :: Assertion+case_shortestImplicantsE_omega = do+  xss <- ExistentialQuantification.shortestImplicantsE IntSet.empty brauer11_omega+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_omega)+      forM_ (CNF.cnfClauses brauer11_omega) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss+    unless (b1 == b2) $ print m++case_shortestImplicantsE_omega' :: Assertion+case_shortestImplicantsE_omega' = do+  let [y1,y2,y3,y4,y5,y6] = [1..6]+      xss = map IntSet.fromList+              [ [y2, -y6]+              , [y3, y6]+              , [-y5, -y6]+              , [-y3, y5]+              , [-y4, y6]+              , [-y1, -y6]+              , [y1, y2]+              , [y4, -y6]+              ]+  forM_ (allAssignments 6) $ \m -> do+    b1 <- do+      solver <- SAT.newSolver+      SAT.newVars_ solver (CNF.cnfNumVars brauer11_omega)+      forM_ (CNF.cnfClauses brauer11_omega) $ \c -> SAT.addClause solver (SAT.unpackClause c)+      SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]]+    let b2 = any (all (SAT.evalLit m) . IntSet.toList) xss+    (b1 == b2) @?= True++prop_negateCNF :: Property+prop_negateCNF = QM.monadicIO $ do+  phi <- QM.pick arbitraryCNF+  psi <- QM.run $ ExistentialQuantification.negateCNF phi+  QM.monitor (counterexample $ show psi)+  forM_ (allAssignments (CNF.cnfNumVars phi)) $ \m -> do+    let b1 = evalCNF m phi+        b2 = evalCNF m psi+    unless (b1 /= b2) $ QM.monitor (counterexample $ show m)+    QM.assert $ b1 /= b2++satExistentialQuantificationTestGroup :: TestTree+satExistentialQuantificationTestGroup = $(testGroupGenerator)
+ test/Test/SAT/MUS.hs view
@@ -0,0 +1,254 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.MUS (satMUSTestGroup) where++import Control.Monad+import Data.Default.Class+import qualified Data.Set as Set+import qualified Data.IntSet as IntSet++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH++import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.MUS as MUS+import qualified ToySolver.SAT.MUS.Enum as MUSEnum++------------------------------------------------------------------------++findMUSAssumptions_case1 :: MUS.Method -> IO ()+findMUSAssumptions_case1 method = do+  solver <- SAT.newSolver+  [x1,x2,x3] <- SAT.newVars solver 3+  sels@[y1,y2,y3,y4,y5,y6] <- SAT.newVars solver 6+  SAT.addClause solver [-y1, x1]+  SAT.addClause solver [-y2, -x1]+  SAT.addClause solver [-y3, -x1, x2]+  SAT.addClause solver [-y4, -x2]+  SAT.addClause solver [-y5, -x1, x3]+  SAT.addClause solver [-y6, -x3]++  ret <- SAT.solveWith solver sels+  ret @?= False++  actual <- MUS.findMUSAssumptions solver def{ MUS.optMethod = method }+  let actual'  = IntSet.map (\x -> x-3) actual+      expected = map IntSet.fromList [[1, 2], [1, 3, 4], [1, 5, 6]]+  actual' `elem` expected @?= True++case_findMUSAssumptions_Deletion :: Assertion+case_findMUSAssumptions_Deletion = findMUSAssumptions_case1 MUS.Deletion++case_findMUSAssumptions_Insertion :: Assertion+case_findMUSAssumptions_Insertion = findMUSAssumptions_case1 MUS.Insertion++case_findMUSAssumptions_QuickXplain :: Assertion+case_findMUSAssumptions_QuickXplain = findMUSAssumptions_case1 MUS.QuickXplain++------------------------------------------------------------------------++{-+c http://sun.iwu.edu/~mliffito/publications/jar_liffiton_CAMUS.pdf+c φ= (x1) ∧ (¬x1) ∧ (¬x1∨x2) ∧ (¬x2) ∧ (¬x1∨x3) ∧ (¬x3)+c MUSes(φ) = {{C1, C2}, {C1, C3, C4}, {C1, C5, C6}}+c MCSes(φ) = {{C1}, {C2, C3, C5}, {C2, C3, C6}, {C2, C4, C5}, {C2, C4, C6}}+p cnf 3 6+1 0+-1 0+-1 2 0+-2 0+-1 3 0+-3 0+-}++allMUSAssumptions_case1 :: MUSEnum.Method -> IO ()+allMUSAssumptions_case1 method = do+  solver <- SAT.newSolver+  [x1,x2,x3] <- SAT.newVars solver 3+  sels@[y1,y2,y3,y4,y5,y6] <- SAT.newVars solver 6+  SAT.addClause solver [-y1, x1]+  SAT.addClause solver [-y2, -x1]+  SAT.addClause solver [-y3, -x1, x2]+  SAT.addClause solver [-y4, -x2]+  SAT.addClause solver [-y5, -x1, x3]+  SAT.addClause solver [-y6, -x3]+  (muses, mcses) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = method }+  Set.fromList muses @?= Set.fromList (map (IntSet.fromList . map (+3)) [[1,2], [1,3,4], [1,5,6]])+  Set.fromList mcses @?= Set.fromList (map (IntSet.fromList . map (+3)) [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]])++case_allMUSAssumptions_CAMUS :: Assertion+case_allMUSAssumptions_CAMUS = allMUSAssumptions_case1 MUSEnum.CAMUS++case_allMUSAssumptions_DAA :: Assertion+case_allMUSAssumptions_DAA = allMUSAssumptions_case1 MUSEnum.DAA++case_allMUSAssumptions_MARCO :: Assertion+case_allMUSAssumptions_MARCO = allMUSAssumptions_case1 MUSEnum.MARCO++case_allMUSAssumptions_GurvichKhachiyan1999 :: Assertion+case_allMUSAssumptions_GurvichKhachiyan1999 = allMUSAssumptions_case1 MUSEnum.GurvichKhachiyan1999++{-+Boosting a Complete Technique to Find MSS and MUS thanks to a Local Search Oracle+http://www.cril.univ-artois.fr/~piette/IJCAI07_HYCAM.pdf+Example 3.+C0  : (d)+C1  : (b ∨ c)+C2  : (a ∨ b)+C3  : (a ∨ ¬c)+C4  : (¬b ∨ ¬e)+C5  : (¬a ∨ ¬b)+C6  : (a ∨ e)+C7  : (¬a ∨ ¬e)+C8  : (b ∨ e)+C9  : (¬a ∨ b ∨ ¬c)+C10 : (¬a ∨ b ∨ ¬d)+C11 : (a ∨ ¬b ∨ c)+C12 : (a ∨ ¬b ∨ ¬d)+-}+allMUSAssumptions_case2 :: MUSEnum.Method -> IO ()+allMUSAssumptions_case2 method = do+  solver <- SAT.newSolver+  [a,b,c,d,e] <- SAT.newVars solver 5+  sels@[y0,y1,y2,y3,y4,y5,y6,y7,y8,y9,y10,y11,y12] <- SAT.newVars solver 13+  SAT.addClause solver [-y0, d]+  SAT.addClause solver [-y1, b, c]+  SAT.addClause solver [-y2, a, b]+  SAT.addClause solver [-y3, a, -c]+  SAT.addClause solver [-y4, -b, -e]+  SAT.addClause solver [-y5, -a, -b]+  SAT.addClause solver [-y6, a, e]+  SAT.addClause solver [-y7, -a, -e]+  SAT.addClause solver [-y8, b, e]+  SAT.addClause solver [-y9, -a, b, -c]+  SAT.addClause solver [-y10, -a, b, -d]+  SAT.addClause solver [-y11, a, -b, c]+  SAT.addClause solver [-y12, a, -b, -d]++  -- Only three of the MUSes (marked with asterisks) are on the paper.+  let cores =+        [ [y0,y1,y2,y5,y9,y12]+        , [y0,y1,y3,y4,y5,y6,y10]+        , [y0,y1,y3,y5,y7,y8,y12]+        , [y0,y1,y3,y5,y9,y12]+        , [y0,y1,y3,y5,y10,y11]+        , [y0,y1,y3,y5,y10,y12]+        , [y0,y2,y3,y5,y10,y11]+        , [y0,y2,y4,y5,y6,y10]+        , [y0,y2,y5,y7,y8,y12]+        , [y0,y2,y5,y10,y12]   -- (*)+        , [y1,y2,y4,y5,y6,y9]+        , [y1,y3,y4,y5,y6,y7,y8]+        , [y1,y3,y4,y5,y6,y9]+        , [y1,y3,y5,y7,y8,y11]+        , [y1,y3,y5,y9,y11]    -- (*)+        , [y2,y3,y5,y7,y8,y11]+        , [y2,y4,y5,y6,y7,y8]  -- (*)+        ]++  let remove1 :: [a] -> [[a]]+      remove1 [] = []+      remove1 (x:xs) = xs : [x : ys | ys <- remove1 xs]+  forM_ cores $ \core -> do+    ret <- SAT.solveWith solver core+    assertBool (show core ++ " should be a core") (not ret)+    forM (remove1 core) $ \xs -> do+      ret <- SAT.solveWith solver xs+      assertBool (show core ++ " should be satisfiable") ret++  (actual,_) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = method }+  let actual'   = Set.fromList actual+      expected' = Set.fromList $ map IntSet.fromList $ cores+  actual' @?= expected'++case_allMUSAssumptions_2_CAMUS :: Assertion+case_allMUSAssumptions_2_CAMUS = allMUSAssumptions_case2 MUSEnum.CAMUS++case_allMUSAssumptions_2_DAA :: Assertion+case_allMUSAssumptions_2_DAA = allMUSAssumptions_case2 MUSEnum.DAA++case_allMUSAssumptions_2_MARCO :: Assertion+case_allMUSAssumptions_2_MARCO = allMUSAssumptions_case2 MUSEnum.MARCO++case_allMUSAssumptions_2_GurvichKhachiyan1999 :: Assertion+case_allMUSAssumptions_2_GurvichKhachiyan1999 = allMUSAssumptions_case2 MUSEnum.GurvichKhachiyan1999++case_allMUSAssumptions_2_HYCAM :: Assertion+case_allMUSAssumptions_2_HYCAM = do+  solver <- SAT.newSolver+  [a,b,c,d,e] <- SAT.newVars solver 5+  sels@[y0,y1,y2,y3,y4,y5,y6,y7,y8,y9,y10,y11,y12] <- SAT.newVars solver 13+  SAT.addClause solver [-y0, d]+  SAT.addClause solver [-y1, b, c]+  SAT.addClause solver [-y2, a, b]+  SAT.addClause solver [-y3, a, -c]+  SAT.addClause solver [-y4, -b, -e]+  SAT.addClause solver [-y5, -a, -b]+  SAT.addClause solver [-y6, a, e]+  SAT.addClause solver [-y7, -a, -e]+  SAT.addClause solver [-y8, b, e]+  SAT.addClause solver [-y9, -a, b, -c]+  SAT.addClause solver [-y10, -a, b, -d]+  SAT.addClause solver [-y11, a, -b, c]+  SAT.addClause solver [-y12, a, -b, -d]++  -- Only three of the MUSes (marked with asterisks) are on the paper.+  let cores =+        [ [y0,y1,y2,y5,y9,y12]+        , [y0,y1,y3,y4,y5,y6,y10]+        , [y0,y1,y3,y5,y7,y8,y12]+        , [y0,y1,y3,y5,y9,y12]+        , [y0,y1,y3,y5,y10,y11]+        , [y0,y1,y3,y5,y10,y12]+        , [y0,y2,y3,y5,y10,y11]+        , [y0,y2,y4,y5,y6,y10]+        , [y0,y2,y5,y7,y8,y12]+        , [y0,y2,y5,y10,y12]   -- (*)+        , [y1,y2,y4,y5,y6,y9]+        , [y1,y3,y4,y5,y6,y7,y8]+        , [y1,y3,y4,y5,y6,y9]+        , [y1,y3,y5,y7,y8,y11]+        , [y1,y3,y5,y9,y11]    -- (*)+        , [y2,y3,y5,y7,y8,y11]+        , [y2,y4,y5,y6,y7,y8]  -- (*)+        ]+      mcses =+        [ [y0,y1,y7]+        , [y0,y1,y8]+        , [y0,y3,y4]+        , [y0,y3,y6]+        , [y0,y4,y11]+        , [y0,y6,y11]+        , [y0,y7,y9]+        , [y0,y8,y9]+        , [y1,y2]+        , [y1,y7,y10]+        , [y1,y8,y10]+        , [y2,y3]+        , [y3,y4,y12]+        , [y3,y6,y12]+        , [y4,y11,y12]+        , [y5]+        , [y6,y11,y12]+        , [y7,y9,y10]+        , [y8,y9,y10]+        ]++  -- HYCAM paper wrongly treated {C3,C8,C10} as a candidate MCS (CoMSS).+  -- Its complement {C0,C1,C2,C4,C5,C6,C7,C9,C11,C12} is unsatisfiable+  -- and hence not MSS.+  ret <- SAT.solveWith solver [y0,y1,y2,y4,y5,y6,y7,y9,y11,y12]+  assertBool "failed to prove the bug of HYCAM paper" (not ret)+  +  let cand = map IntSet.fromList [[y5], [y3,y2], [y0,y1,y2]]+  (actual,_) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = MUSEnum.CAMUS, MUSEnum.optKnownCSes = cand }+  let actual'   = Set.fromList $ actual+      expected' = Set.fromList $ map IntSet.fromList cores+  actual' @?= expected'++------------------------------------------------------------------------++satMUSTestGroup :: TestTree+satMUSTestGroup = $(testGroupGenerator)
+ test/Test/SAT/TheorySolver.hs view
@@ -0,0 +1,358 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.TheorySolver (satTheorySolverTestGroup) where++import Control.Monad+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Traversable as Traversable++import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&&.), (.||.))+import Test.Tasty.HUnit+import Test.Tasty.TH+import qualified Test.QuickCheck.Monadic as QM++import ToySolver.Data.BoolExpr+import ToySolver.Data.Boolean+import qualified ToySolver.SAT as SAT+import ToySolver.SAT.TheorySolver+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Data.OrdRel+import qualified ToySolver.Data.LA as LA+import qualified ToySolver.Arith.Simplex as Simplex+import qualified ToySolver.EUF.EUFSolver as EUF++import Test.SAT.Utils+++newTheorySolver :: CNF.CNF -> IO TheorySolver+newTheorySolver cnf = do+  let nv = CNF.cnfNumVars cnf+      cs = CNF.cnfClauses cnf+  solver <- SAT.newSolver+  SAT.newVars_ solver nv+  forM_ cs $ \c -> SAT.addClause solver (SAT.unpackClause c)+  +  ref <- newIORef []+  let tsolver =+        TheorySolver+        { thAssertLit = \_ l -> do+            if abs l > nv then+              return True+            else do+              m <- readIORef ref+              case m of+                [] -> SAT.addClause solver [l]+                xs : xss -> writeIORef ref ((l : xs) : xss)+              return True+        , thCheck = \_ -> do+            xs <- liftM concat $ readIORef ref+            SAT.solveWith solver xs+        , thExplain = \m -> do+            case m of+              Nothing -> SAT.getFailedAssumptions solver+              Just _ -> return []+        , thPushBacktrackPoint = modifyIORef ref ([] :)+        , thPopBacktrackPoint = modifyIORef ref tail+        , thConstructModel = return ()+        }+  return tsolver++prop_solveCNF_using_BooleanTheory :: Property+prop_solveCNF_using_BooleanTheory = QM.monadicIO $ do+  cnf <- QM.pick arbitraryCNF+  let nv = CNF.cnfNumVars cnf+      nc = CNF.cnfNumClauses cnf+      cs = CNF.cnfClauses cnf+      cnf1 = cnf{ CNF.cnfClauses = [c | (i,c) <- zip [(0::Int)..] cs, i `mod` 2 == 0], CNF.cnfNumClauses = nc - (nc `div` 2) }+      cnf2 = cnf{ CNF.cnfClauses = [c | (i,c) <- zip [(0::Int)..] cs, i `mod` 2 /= 0], CNF.cnfNumClauses = nc `div` 2 }++  solver <- arbitrarySolver++  ret <- QM.run $ do+    SAT.newVars_ solver nv++    tsolver <- newTheorySolver cnf1+    SAT.setTheory solver tsolver++    forM_ (CNF.cnfClauses cnf2) $ \c -> SAT.addClause solver (SAT.unpackClause c)+    ret <- SAT.solve solver+    if ret then do+      m <- SAT.getModel solver+      return (Just m)+    else do+      return Nothing++  case ret of+    Just m -> QM.assert $ evalCNF m cnf+    Nothing -> do+      forM_ (allAssignments nv) $ \m -> do+        QM.assert $ not (evalCNF m cnf)++case_QF_LRA :: Assertion+case_QF_LRA = do+  satSolver <- SAT.newSolver+  lraSolver <- Simplex.newSolver++  tblRef <- newIORef $ Map.empty+  defsRef <- newIORef $ IntMap.empty+  let abstractLAAtom :: LA.Atom Rational -> IO SAT.Lit+      abstractLAAtom atom = do+        (v,op,rhs) <- Simplex.simplifyAtom lraSolver atom+        tbl <- readIORef tblRef+        (vLt, vEq, vGt) <-+          case Map.lookup (v,rhs) tbl of+            Just (vLt, vEq, vGt) -> return (vLt, vEq, vGt)+            Nothing -> do+              vLt <- SAT.newVar satSolver+              vEq <- SAT.newVar satSolver+              vGt <- SAT.newVar satSolver+              SAT.addClause satSolver [vLt,vEq,vGt]+              SAT.addClause satSolver [-vLt, -vEq]+              SAT.addClause satSolver [-vLt, -vGt]                 +              SAT.addClause satSolver [-vEq, -vGt]+              writeIORef tblRef (Map.insert (v,rhs) (vLt, vEq, vGt) tbl)+              let xs = IntMap.fromList+                       [ (vEq,  LA.var v .==. LA.constant rhs)+                       , (vLt,  LA.var v .<.  LA.constant rhs)+                       , (vGt,  LA.var v .>.  LA.constant rhs)+                       , (-vLt, LA.var v .>=. LA.constant rhs)+                       , (-vGt, LA.var v .<=. LA.constant rhs)+                       ]+              modifyIORef defsRef (IntMap.union xs)+              return (vLt, vEq, vGt)+        case op of+          Lt  -> return vLt+          Gt  -> return vGt+          Eql -> return vEq+          Le  -> return (-vGt)+          Ge  -> return (-vLt)+          NEq -> return (-vEq)++      abstract :: BoolExpr (Either SAT.Lit (LA.Atom Rational)) -> IO (BoolExpr SAT.Lit)+      abstract = Traversable.mapM f+        where+          f (Left lit) = return lit+          f (Right atom) = abstractLAAtom atom++  let tsolver =+        TheorySolver+        { thAssertLit = \_ l -> do+            defs <- readIORef defsRef+            case IntMap.lookup l defs of+              Nothing -> return True+              Just atom -> do+                Simplex.assertAtomEx' lraSolver atom (Just l)+                return True+        , thCheck = \_ -> do+            Simplex.check lraSolver+        , thExplain = \m -> do+            case m of+              Nothing -> liftM IntSet.toList $ Simplex.explain lraSolver+              Just _ -> return []+        , thPushBacktrackPoint = do+            Simplex.pushBacktrackPoint lraSolver+        , thPopBacktrackPoint = do+            Simplex.popBacktrackPoint lraSolver+        , thConstructModel = do+            return ()+        }+  SAT.setTheory satSolver tsolver++  enc <- Tseitin.newEncoder satSolver+  let addFormula :: BoolExpr (Either SAT.Lit (LA.Atom Rational)) -> IO ()+      addFormula c = Tseitin.addFormula enc =<< abstract c++  a <- SAT.newVar satSolver+  x <- Simplex.newVar lraSolver+  y <- Simplex.newVar lraSolver++  let le1 = LA.fromTerms [(2,x), (1/3,y)] .<=. LA.constant (-4) -- 2 x + (1/3) y <= -4+      eq2 = LA.fromTerms [(1.5,x)] .==. LA.fromTerms [(-2,x)] -- 1.5 y = -2 x+      gt3 = LA.var x .>. LA.var y -- x > y+      lt4 = LA.fromTerms [(3,x)] .<. LA.fromTerms [(-1,LA.unitVar), (1/5,x), (1/5,y)] -- 3 x < -1 + (1/5) (x + y)++      c1, c2 :: BoolExpr (Either SAT.Lit (LA.Atom Rational))+      c1 = ite (Atom (Left a) :: BoolExpr (Either SAT.Lit (LA.Atom Rational))) (Atom $ Right le1) (Atom $ Right eq2)+      c2 = Atom (Right gt3) .||. (Atom (Left a) .<=>. Atom (Right lt4))++  addFormula c1+  addFormula c2++  ret <- SAT.solve satSolver+  ret @?= True++  m1 <- SAT.getModel satSolver+  m2 <- Simplex.getModel lraSolver+  let f (Left lit) = SAT.evalLit m1 lit+      f (Right atom) = LA.eval m2 atom+  fold f c1 @?= True+  fold f c2 @?= True+++case_QF_EUF :: Assertion+case_QF_EUF = do+  satSolver <- SAT.newSolver+  eufSolver <- EUF.newSolver+  enc <- Tseitin.newEncoder satSolver+  +  tblRef <- newIORef (Map.empty :: Map (EUF.Term, EUF.Term) SAT.Var)+  defsRef <- newIORef (IntMap.empty :: IntMap (EUF.Term, EUF.Term))+  eufModelRef <- newIORef (undefined :: EUF.Model)+ +  let abstractEUFAtom :: (EUF.Term, EUF.Term) -> IO SAT.Lit+      abstractEUFAtom (t1,t2) | t1 >= t2 = abstractEUFAtom (t2,t1)+      abstractEUFAtom (t1,t2) = do+        tbl <- readIORef tblRef+        case Map.lookup (t1,t2) tbl of+          Just v -> return v+          Nothing -> do+            v <- SAT.newVar satSolver+            writeIORef tblRef $! Map.insert (t1,t2) v tbl+            modifyIORef' defsRef $! IntMap.insert v (t1,t2)+            return v++      abstract :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term)) -> IO (BoolExpr SAT.Lit)+      abstract = Traversable.mapM f+        where+          f (Left lit) = return lit+          f (Right atom) = abstractEUFAtom atom++  let tsolver =+        TheorySolver+        { thAssertLit = \_ l -> do+            defs <- readIORef defsRef+            case IntMap.lookup (SAT.litVar l) defs of+              Nothing -> return True+              Just (t1,t2) -> do+                if SAT.litPolarity l then+                  EUF.assertEqual' eufSolver t1 t2 (Just l)+                else+                  EUF.assertNotEqual' eufSolver t1 t2 (Just l)+                return True+        , thCheck = \callback -> do+            b <- EUF.check eufSolver+            when b $ do+              defs <- readIORef defsRef+              forM_ (IntMap.toList defs) $ \(v, (t1, t2)) -> do+                b2 <- EUF.areEqual eufSolver t1 t2+                when b2 $ do+                  _ <- callback v+                  return ()+            return b            +        , thExplain = \m -> do+            case m of+              Nothing -> liftM IntSet.toList $ EUF.explain eufSolver Nothing+              Just v -> do+                defs <- readIORef defsRef+                case IntMap.lookup v defs of+                  Nothing -> error "should not happen"+                  Just (t1,t2) -> do+                    liftM IntSet.toList $ EUF.explain eufSolver (Just (t1,t2))+        , thPushBacktrackPoint = do+            EUF.pushBacktrackPoint eufSolver+        , thPopBacktrackPoint = do+            EUF.popBacktrackPoint eufSolver+        , thConstructModel = do+            writeIORef eufModelRef =<< EUF.getModel eufSolver+            return ()+        }+  SAT.setTheory satSolver tsolver++  cTrue  <- EUF.newConst eufSolver+  cFalse <- EUF.newConst eufSolver+  EUF.assertNotEqual eufSolver cTrue cFalse+  boolToTermRef <- newIORef (IntMap.empty :: IntMap EUF.Term)+  termToBoolRef <- newIORef (Map.empty :: Map EUF.Term SAT.Lit)++  let connectBoolTerm :: SAT.Lit -> EUF.Term -> IO ()+      connectBoolTerm lit t = do+        lit1 <- abstractEUFAtom (t, cTrue)+        lit2 <- abstractEUFAtom (t, cFalse)+        SAT.addClause satSolver [-lit, lit1]  --  lit  ->  lit1+        SAT.addClause satSolver [-lit1, lit]  --  lit1 ->  lit+        SAT.addClause satSolver [lit, lit2]   -- -lit  ->  lit2+        SAT.addClause satSolver [-lit2, -lit] --  lit2 -> -lit+        modifyIORef' boolToTermRef $ IntMap.insert lit t+        modifyIORef' termToBoolRef $ Map.insert t lit++      boolToTerm :: SAT.Lit -> IO EUF.Term+      boolToTerm lit = do+        tbl <- readIORef boolToTermRef+        case IntMap.lookup lit tbl of+          Just t -> return t+          Nothing -> do+            t <- EUF.newConst eufSolver+            connectBoolTerm lit t+            return t++      termToBool :: EUF.Term -> IO SAT.Lit+      termToBool t = do+        tbl <- readIORef termToBoolRef+        case Map.lookup t tbl of+          Just lit -> return lit+          Nothing -> do+            lit <- SAT.newVar satSolver+            connectBoolTerm lit t+            return lit++  let addFormula :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term)) -> IO ()+      addFormula c = Tseitin.addFormula enc =<< abstract c++  do+    x <- SAT.newVar satSolver+    x' <- boolToTerm x+    f <- EUF.newFun eufSolver+    fx <- termToBool (f x')+    ftt <- abstractEUFAtom (f cTrue, cTrue)+    ret <- SAT.solveWith satSolver [-fx, ftt]+    ret @?= True++    m1 <- SAT.getModel satSolver+    m2 <- readIORef eufModelRef+    let e (Left lit) = SAT.evalLit m1 lit+        e (Right (lhs,rhs)) = EUF.eval m2 lhs == EUF.eval m2 rhs+    fold e (notB (Atom (Left fx)) .||. (Atom (Right (f cTrue, cTrue)))) @?= True+    SAT.evalLit m1 x @?= False++    ret <- SAT.solveWith satSolver [-fx, ftt, x]+    ret @?= False++  do+    -- a : Bool+    -- f : U -> U+    -- x : U+    -- y : U+    -- (a or x=y)+    -- f x /= f y+    a <- SAT.newVar satSolver+    f <- EUF.newFun eufSolver+    x <- EUF.newConst eufSolver+    y <- EUF.newConst eufSolver+    let c1, c2 :: BoolExpr (Either SAT.Lit (EUF.Term, EUF.Term))+        c1 = Atom (Left a) .||. Atom (Right (x,y))+        c2 = notB $ Atom (Right (f x, f y))+    addFormula c1+    addFormula c2+    ret <- SAT.solve satSolver+    ret @?= True+    m1 <- SAT.getModel satSolver+    m2 <- readIORef eufModelRef+    let e (Left lit) = SAT.evalLit m1 lit+        e (Right (lhs,rhs)) = EUF.eval m2 lhs == EUF.eval m2 rhs+    fold e c1 @?= True+    fold e c2 @?= True++    ret <- SAT.solveWith satSolver [-a]+    ret @?= False+++satTheorySolverTestGroup :: TestTree+satTheorySolverTestGroup = $(testGroupGenerator)
+ test/Test/SAT/Types.hs view
@@ -0,0 +1,254 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.Types (satTypesTestGroup) where++import Control.Monad+import Data.Array.IArray+import Data.List++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH++import qualified ToySolver.SAT.Types as SAT++import Test.SAT.Utils++------------------------------------------------------------------------++-- -4*(not x1) + 3*x1 + 10*(not x2)+-- = -4*(1 - x1) + 3*x1 + 10*(not x2)+-- = -4 + 4*x1 + 3*x1 + 10*(not x2)+-- = 7*x1 + 10*(not x2) - 4+case_normalizePBLinSum_1 :: Assertion+case_normalizePBLinSum_1 = do+  sort e @?= sort [(7,x1),(10,-x2)]+  c @?= -4+  where+    x1 = 1+    x2 = 2+    (e,c) = SAT.normalizePBLinSum ([(-4,-x1),(3,x1),(10,-x2)], 0)++prop_normalizePBLinSum :: Property+prop_normalizePBLinSum = forAll g $ \(nv, (s,n)) ->+    let (s2,n2) = SAT.normalizePBLinSum (s,n)+    in flip all (allAssignments nv) $ \m ->+         SAT.evalPBLinSum m s + n == SAT.evalPBLinSum m s2 + n2+  where+    g :: Gen (Int, (SAT.PBLinSum, Integer))+    g = do+      nv <- choose (0, 10)+      s <- forM [1..nv] $ \x -> do+        c <- arbitrary+        p <- arbitrary+        return (c, SAT.literal x p)+      n <- arbitrary+      return (nv, (s,n))++-- -4*(not x1) + 3*x1 + 10*(not x2) >= 3+-- ⇔ -4*(1 - x1) + 3*x1 + 10*(not x2) >= 3+-- ⇔ -4 + 4*x1 + 3*x1 + 10*(not x2) >= 3+-- ⇔ 7*x1 + 10*(not x2) >= 7+-- ⇔ 7*x1 + 7*(not x2) >= 7+-- ⇔ x1 + (not x2) >= 1+case_normalizePBLinAtLeast_1 :: Assertion+case_normalizePBLinAtLeast_1 = (sort lhs, rhs) @?= (sort [(1,x1),(1,-x2)], 1)+  where+    x1 = 1+    x2 = 2+    (lhs,rhs) = SAT.normalizePBLinAtLeast ([(-4,-x1),(3,x1),(10,-x2)], 3)++prop_normalizePBLinAtLeast :: Property+prop_normalizePBLinAtLeast = forAll g $ \(nv, c) ->+    let c2 = SAT.normalizePBLinAtLeast c+    in flip all (allAssignments nv) $ \m ->+         SAT.evalPBLinAtLeast m c == SAT.evalPBLinAtLeast m c2+  where+    g :: Gen (Int, SAT.PBLinAtLeast)+    g = do+      nv <- choose (0, 10)+      lhs <- forM [1..nv] $ \x -> do+        c <- arbitrary+        p <- arbitrary+        return (c, SAT.literal x p)+      rhs <- arbitrary+      return (nv, (lhs,rhs))++case_normalizePBLinExactly_1 :: Assertion+case_normalizePBLinExactly_1 = (sort lhs, rhs) @?= ([], 1)+  where+    x1 = 1+    x2 = 2+    (lhs,rhs) = SAT.normalizePBLinExactly ([(6,x1),(4,x2)], 2)++case_normalizePBLinExactly_2 :: Assertion+case_normalizePBLinExactly_2 = (sort lhs, rhs) @?= ([], 1)+  where+    x1 = 1+    x2 = 2+    x3 = 3+    (lhs,rhs) = SAT.normalizePBLinExactly ([(2,x1),(2,x2),(2,x3)], 3)++prop_normalizePBLinExactly :: Property+prop_normalizePBLinExactly = forAll g $ \(nv, c) ->+    let c2 = SAT.normalizePBLinExactly c+    in flip all (allAssignments nv) $ \m ->+         SAT.evalPBLinExactly m c == SAT.evalPBLinExactly m c2+  where+    g :: Gen (Int, SAT.PBLinExactly)+    g = do+      nv <- choose (0, 10)+      lhs <- forM [1..nv] $ \x -> do+        c <- arbitrary+        p <- arbitrary+        return (c, SAT.literal x p)+      rhs <- arbitrary+      return (nv, (lhs,rhs))++prop_cutResolve :: Property+prop_cutResolve =+  forAll (choose (1, 10)) $ \nv ->+    forAll (g nv True) $ \c1 ->+      forAll (g nv False) $ \c2 ->+        let c3 = SAT.cutResolve c1 c2 1+        in flip all (allAssignments nv) $ \m ->+             not (SAT.evalPBLinExactly m c1 && SAT.evalPBLinExactly m c2) || SAT.evalPBLinExactly m c3+  where+    g :: Int -> Bool -> Gen SAT.PBLinExactly+    g nv b = do+      lhs <- forM [1..nv] $ \x -> do+        if x==1 then do+          c <- liftM ((1+) . abs) arbitrary+          return (c, SAT.literal x b)+        else do+          c <- arbitrary+          p <- arbitrary+          return (c, SAT.literal x p)+      rhs <- arbitrary+      return (lhs, rhs)++case_cutResolve_1 :: Assertion+case_cutResolve_1 = (sort lhs, rhs) @?= (sort [(1,x3),(1,x4)], 1)+  where+    x1 = 1+    x2 = 2+    x3 = 3+    x4 = 4+    pb1 = ([(1,x1), (1,x2), (1,x3)], 1)+    pb2 = ([(2,-x1), (2,-x2), (1,x4)], 3)+    (lhs,rhs) = SAT.cutResolve pb1 pb2 x1++case_cutResolve_2 :: Assertion+case_cutResolve_2 = (sort lhs, rhs) @?= (sort lhs2, rhs2)+  where+    x1 = 1+    x2 = 2+    x3 = 3+    x4 = 4+    pb1 = ([(3,x1), (2,-x2), (1,x3), (1,x4)], 3)+    pb2 = ([(1,-x3), (1,x4)], 1)+    (lhs,rhs) = SAT.cutResolve pb1 pb2 x3+    (lhs2,rhs2) = ([(2,x1),(1,-x2),(1,x4)],2) -- ([(3,x1),(2,-x2),(2,x4)], 3)++case_cardinalityReduction :: Assertion+case_cardinalityReduction = (sort lhs, rhs) @?= ([1,2,3,4,5],4)+  where+    (lhs, rhs) = SAT.cardinalityReduction ([(6,1),(5,2),(4,3),(3,4),(2,5),(1,6)], 17)++prop_pbLinUpperBound :: Property+prop_pbLinUpperBound =+  forAll (choose (0,10)) $ \nv ->+    forAll (arbitraryPBLinSum nv) $ \s ->+      forAll (arbitraryAssignment nv) $ \m -> +        let ub = SAT.pbLinUpperBound s+         in counterexample (show ub) $ SAT.evalPBLinSum m s <= ub++prop_pbLinLowerBound :: Property+prop_pbLinLowerBound =+  forAll (choose (0,10)) $ \nv ->+    forAll (arbitraryPBLinSum nv) $ \s ->+      forAll (arbitraryAssignment nv) $ \m -> +        let lb = SAT.pbLinLowerBound s+         in counterexample (show lb) $ lb <= SAT.evalPBLinSum m s++case_pbLinSubsume_clause :: Assertion+case_pbLinSubsume_clause = SAT.pbLinSubsume ([(1,1),(1,-3)],1) ([(1,1),(1,2),(1,-3),(1,4)],1) @?= True++case_pbLinSubsume_1 :: Assertion+case_pbLinSubsume_1 = SAT.pbLinSubsume ([(1,1),(1,2),(1,-3)],2) ([(1,1),(2,2),(1,-3),(1,4)],1) @?= True++case_pbLinSubsume_2 :: Assertion+case_pbLinSubsume_2 = SAT.pbLinSubsume ([(1,1),(1,2),(1,-3)],2) ([(1,1),(2,2),(1,-3),(1,4)],3) @?= False++prop_removeNegationFromPBSum :: Property+prop_removeNegationFromPBSum =+  forAll (choose (0,10)) $ \nv ->+    forAll (arbitraryPBSum nv) $ \s ->+      let s' = SAT.removeNegationFromPBSum s+       in counterexample (show s') $ +            forAll (arbitraryAssignment nv) $ \m -> SAT.evalPBSum m s === SAT.evalPBSum m s'++prop_pbUpperBound :: Property+prop_pbUpperBound =+  forAll (choose (0,10)) $ \nv ->+    forAll (arbitraryPBSum nv) $ \s ->+      forAll (arbitraryAssignment nv) $ \m -> +        let ub = SAT.pbUpperBound s+         in counterexample (show ub) $ SAT.evalPBSum m s <= ub++prop_pbLowerBound :: Property+prop_pbLowerBound =+  forAll (choose (0,10)) $ \nv ->+    forAll (arbitraryPBSum nv) $ \s ->+      forAll (arbitraryAssignment nv) $ \m -> +        let lb = SAT.pbLowerBound s+         in counterexample (show lb) $ lb <= SAT.evalPBSum m s++------------------------------------------------------------------------++case_normalizeXORClause_False :: Assertion+case_normalizeXORClause_False =+  SAT.normalizeXORClause ([],True) @?= ([],True)++case_normalizeXORClause_True :: Assertion+case_normalizeXORClause_True =+  SAT.normalizeXORClause ([],False) @?= ([],False)++-- x ⊕ y ⊕ x = y+case_normalizeXORClause_case1 :: Assertion+case_normalizeXORClause_case1 =+  SAT.normalizeXORClause ([1,2,1],True) @?= ([2],True)++-- x ⊕ ¬x = x ⊕ x ⊕ 1 = 1+case_normalizeXORClause_case2 :: Assertion+case_normalizeXORClause_case2 =+  SAT.normalizeXORClause ([1,-1],True) @?= ([],False)++prop_normalizeXORClause :: Property+prop_normalizeXORClause = forAll g $ \(nv, c) ->+    let c2 = SAT.normalizeXORClause c+    in flip all (allAssignments nv) $ \m ->+         SAT.evalXORClause m c == SAT.evalXORClause m c2+  where+    g :: Gen (Int, SAT.XORClause)+    g = do+      nv <- choose (0, 10)+      len <- choose (0, nv)+      lhs <- replicateM len $ choose (-nv, nv) `suchThat` (/= 0)+      rhs <- arbitrary+      return (nv, (lhs,rhs))++case_evalXORClause_case1 :: Assertion+case_evalXORClause_case1 =+  SAT.evalXORClause (array (1,2) [(1,True),(2,True)] :: Array Int Bool) ([1,2], True) @?= False++case_evalXORClause_case2 :: Assertion+case_evalXORClause_case2 =+  SAT.evalXORClause (array (1,2) [(1,False),(2,True)] :: Array Int Bool) ([1,2], True) @?= True++------------------------------------------------------------------------++satTypesTestGroup :: TestTree+satTypesTestGroup = $(testGroupGenerator)
+ test/Test/SAT/Utils.hs view
@@ -0,0 +1,548 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-}+module Test.SAT.Utils where++import Control.Monad+import Data.Array.IArray+import Data.Default.Class+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List+import Data.Maybe+import qualified Data.Vector as V+import qualified System.Random.MWC as Rand++import Test.Tasty.QuickCheck+import qualified Test.QuickCheck.Monadic as QM++import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Cardinality as Cardinality+import qualified ToySolver.SAT.Encoder.PB as PB+import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import qualified ToySolver.SAT.PBO as PBO++import qualified Data.PseudoBoolean as PBFile+import ToySolver.Converter+import qualified ToySolver.FileFormat.CNF as CNF++-- ---------------------------------------------------------------------++allAssignments :: Int -> [SAT.Model]+allAssignments nv = [array (1,nv) (zip [1..nv] xs) | xs <- replicateM nv [True,False]]++forAllAssignments :: Testable prop => Int -> (SAT.Model -> prop) ->  Property+forAllAssignments nv p = conjoin [counterexample (show m) (p m) | m <- allAssignments nv]++arbitraryAssignment :: Int -> Gen SAT.Model+arbitraryAssignment nv = do+  bs <- replicateM nv arbitrary+  return $ array (1,nv) (zip [1..] bs)++-- ---------------------------------------------------------------------  ++arbitraryCNF :: Gen CNF.CNF+arbitraryCNF = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  cs <- replicateM nc $ do+    len <- choose (0,10)+    if nv == 0 then+      return $ SAT.packClause []+    else+      SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+  return $+    CNF.CNF+    { CNF.cnfNumVars = nv+    , CNF.cnfNumClauses = nc+    , CNF.cnfClauses = cs+    }+++evalCNF :: SAT.Model -> CNF.CNF -> Bool+evalCNF m cnf = all (SAT.evalClause m . SAT.unpackClause) (CNF.cnfClauses cnf)++evalCNFCost :: SAT.Model -> CNF.CNF -> Int+evalCNFCost m cnf = sum $ map f (CNF.cnfClauses cnf)+  where+    f c = if SAT.evalClause m (SAT.unpackClause c) then 0 else 1+++arbitraryGCNF :: Gen CNF.GCNF+arbitraryGCNF = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  ng <- choose (0,10)+  cs <- replicateM nc $ do+    g <- choose (0,ng) -- inclusive range+    c <-+      if nv == 0 then do+        return $ SAT.packClause []+      else do+        len <- choose (0,10)+        SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+    return (g,c)+  return $+    CNF.GCNF+    { CNF.gcnfNumVars = nv+    , CNF.gcnfNumClauses = nc+    , CNF.gcnfLastGroupIndex = ng+    , CNF.gcnfClauses = cs+    }+++arbitraryWCNF :: Gen CNF.WCNF+arbitraryWCNF = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  cs <- replicateM nc $ do+    w <- arbitrary+    c <- do+      if nv == 0 then do+        return $ SAT.packClause []+      else do+        len <- choose (0,10)+        SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+    return (fmap getPositive w, c)+  let topCost = sum [w | (Just w, _) <- cs] + 1+  return $+    CNF.WCNF+    { CNF.wcnfNumVars = nv+    , CNF.wcnfNumClauses = nc+    , CNF.wcnfTopCost = topCost+    , CNF.wcnfClauses = [(fromMaybe topCost w, c) | (w,c) <- cs]+    }+++evalWCNF :: SAT.Model -> CNF.WCNF -> Maybe Integer+evalWCNF m wcnf = foldl' (liftM2 (+)) (Just 0)+  [ if SAT.evalClause m (SAT.unpackClause c) then+      Just 0+    else if w == CNF.wcnfTopCost wcnf then+      Nothing+    else+      Just w+  | (w,c) <- CNF.wcnfClauses wcnf+  ]+++evalWCNFCost :: SAT.Model -> CNF.WCNF -> Integer+evalWCNFCost m wcnf = sum $ do+  (w,c) <- CNF.wcnfClauses wcnf+  guard $ not $ SAT.evalClause m (SAT.unpackClause c)+  return w+++arbitraryQDimacs :: Gen CNF.QDimacs+arbitraryQDimacs = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  prefix <- arbitraryPrefix $ IntSet.fromList [1..nv]++  cs <- replicateM nc $ do+    if nv == 0 then+      return $ SAT.packClause []+    else do+      len <- choose (0,10)+      SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+  return $+    CNF.QDimacs+    { CNF.qdimacsNumVars = nv+    , CNF.qdimacsNumClauses = nc+    , CNF.qdimacsPrefix = prefix+    , CNF.qdimacsMatrix = cs+    }++arbitraryPrefix :: IntSet -> Gen [CNF.QuantSet]+arbitraryPrefix xs = do+  if IntSet.null xs then+    return []+  else do+    b <- arbitrary+    if b then+      return []+    else do+      xs1 <- subsetof xs `suchThat` (not . IntSet.null)+      let xs2 = xs IntSet.\\ xs1+      q <- elements [CNF.E, CNF.A]+      ((q, IntSet.toList xs1) :) <$> arbitraryPrefix xs2++subsetof :: IntSet -> Gen IntSet+subsetof xs = (IntSet.fromList . catMaybes) <$> sequence [elements [Just x, Nothing] | x <- IntSet.toList xs]+++data PBRel = PBRelGE | PBRelEQ | PBRelLE deriving (Eq, Ord, Enum, Bounded, Show)++instance Arbitrary PBRel where+  arbitrary = arbitraryBoundedEnum++evalPBRel :: Ord a => PBRel -> a -> a -> Bool+evalPBRel PBRelGE = (>=)+evalPBRel PBRelLE = (<=)+evalPBRel PBRelEQ = (==)+++type PBLin = (Int,[(PBRel,SAT.PBLinSum,Integer)])++arbitraryPB :: Gen PBLin+arbitraryPB = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  cs <- replicateM nc $ do+    rel <- arbitrary+    lhs <- arbitraryPBLinSum nv+    rhs <- arbitrary+    return $ (rel,lhs,rhs)+  return (nv, cs)++arbitraryPBLinSum :: Int -> Gen SAT.PBLinSum+arbitraryPBLinSum nv = do+  len <- choose (0,10)+  if nv == 0 then+    return []+  else+    replicateM len $ do+      l <- choose (-nv, nv) `suchThat` (/= 0)+      c <- arbitrary+      return (c,l)++evalPB :: SAT.Model -> PBLin -> Bool+evalPB m (_,cs) = all (\(o,lhs,rhs) -> evalPBRel o (SAT.evalPBLinSum m lhs) rhs) cs+++type WBOLin = (Int, [(Maybe Integer, (PBRel,SAT.PBLinSum,Integer))], Maybe Integer)++evalWBO :: SAT.Model -> WBOLin -> Maybe Integer+evalWBO m (_nv,cs,top) = do+  cost <- liftM sum $ forM cs $ \(w,(o,lhs,rhs)) -> do+    if evalPBRel o (SAT.evalPBLinSum m lhs) rhs then+      return 0+    else+      w+  case top of+    Just t -> guard (cost < t)+    Nothing -> return ()+  return cost++arbitraryWBO :: Gen WBOLin+arbitraryWBO = do+  (nv,cs) <- arbitraryPB+  cs2 <- forM cs $ \c -> do+    b <- arbitrary+    cost <- if b then return Nothing+            else liftM (Just . (1+) . abs) arbitrary+    return (cost, c)+  b <- arbitrary+  top <- if b then return Nothing+         else liftM (Just . (1+) . abs) arbitrary+  return (nv,cs2,top)+++arbitraryPBNLC :: Gen (Int,[(PBRel,SAT.PBSum,Integer)])+arbitraryPBNLC = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  cs <- replicateM nc $ do+    rel <- arbitrary+    len <- choose (0,10)+    lhs <-+      if nv == 0 then+        return []+      else+        replicateM len $ do+          ls <- listOf $ choose (-nv, nv) `suchThat` (/= 0)+          c <- arbitrary+          return (c,ls)+    rhs <- arbitrary+    return $ (rel,lhs,rhs)+  return (nv, cs)++evalPBNLC :: SAT.Model -> (Int,[(PBRel,SAT.PBSum,Integer)]) -> Bool+evalPBNLC m (_,cs) = all (\(o,lhs,rhs) -> evalPBRel o (SAT.evalPBSum m lhs) rhs) cs+++arbitraryXOR :: Gen (Int,[SAT.XORClause])+arbitraryXOR = do+  nv <- choose (0,10)+  nc <- choose (0,50)+  cs <- replicateM nc $ do+    len <- choose (0,10)    +    lhs <-+      if nv == 0 then+        return []+      else+        replicateM len $ choose (-nv, nv) `suchThat` (/= 0)+    rhs <- arbitrary+    return (lhs,rhs)+  return (nv, cs)++evalXOR :: SAT.Model -> (Int,[SAT.XORClause]) -> Bool+evalXOR m (_,cs) = all (SAT.evalXORClause m) cs+++arbitraryNAESAT :: Gen NAESAT+arbitraryNAESAT = do+  cnf <- arbitraryCNF+  return (CNF.cnfNumVars cnf, CNF.cnfClauses cnf)+++arbitraryMaxSAT2 :: Gen (CNF.WCNF, Integer)+arbitraryMaxSAT2 = do+  nv <- choose (0,5)+  nc <- choose (0,10)+  cs <- replicateM nc $ do+    len <- choose (0,2)+    c <- if nv == 0 then+           return $ SAT.packClause []+         else+           SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+    return (1,c)+  th <- choose (0,nc)+  return $+    ( CNF.WCNF+      { CNF.wcnfNumVars = nv+      , CNF.wcnfNumClauses = nc+      , CNF.wcnfClauses = cs+      , CNF.wcnfTopCost = fromIntegral nc + 1+      }+    , fromIntegral th+    )++------------------------------------------------------------------------++solveCNF :: SAT.Solver -> CNF.CNF -> IO (Maybe SAT.Model)+solveCNF solver cnf = do+  SAT.newVars_ solver (CNF.cnfNumVars cnf)+  forM_ (CNF.cnfClauses cnf) $ \c -> SAT.addClause solver (SAT.unpackClause c)+  ret <- SAT.solve solver+  if ret then do+    m <- SAT.getModel solver+    return (Just m)+  else do+    return Nothing+++solvePB :: SAT.Solver -> PBLin -> IO (Maybe SAT.Model)+solvePB solver (nv,cs) = do+  SAT.newVars_ solver nv+  forM_ cs $ \(o,lhs,rhs) -> do+    case o of+      PBRelGE -> SAT.addPBAtLeast solver lhs rhs+      PBRelLE -> SAT.addPBAtMost solver lhs rhs+      PBRelEQ -> SAT.addPBExactly solver lhs rhs+  ret <- SAT.solve solver+  if ret then do+    m <- SAT.getModel solver+    return (Just m)+  else do+    return Nothing+++optimizePBO :: SAT.Solver -> PBO.Optimizer -> PBLin -> IO (Maybe (SAT.Model, Integer))+optimizePBO solver opt (nv,cs) = do+  SAT.newVars_ solver nv+  forM_ cs $ \(o,lhs,rhs) -> do+    case o of+      PBRelGE -> SAT.addPBAtLeast solver lhs rhs+      PBRelLE -> SAT.addPBAtMost solver lhs rhs+      PBRelEQ -> SAT.addPBExactly solver lhs rhs+  PBO.optimize opt+  PBO.getBestSolution opt+++optimizeWBO+  :: SAT.Solver+  -> PBO.Method+  -> WBOLin+  -> IO (Maybe (SAT.Model, Integer))+optimizeWBO solver method (nv,cs,top) = do+  SAT.newVars_ solver nv+  obj <- liftM catMaybes $ forM cs $ \(cost, (o,lhs,rhs)) -> do+    case cost of+      Nothing -> do+        case o of+          PBRelGE -> SAT.addPBAtLeast solver lhs rhs+          PBRelLE -> SAT.addPBAtMost solver lhs rhs+          PBRelEQ -> SAT.addPBExactly solver lhs rhs+        return Nothing+      Just w -> do+        sel <- SAT.newVar solver+        case o of+          PBRelGE -> SAT.addPBAtLeastSoft solver sel lhs rhs+          PBRelLE -> SAT.addPBAtMostSoft solver sel lhs rhs+          PBRelEQ -> SAT.addPBExactlySoft solver sel lhs rhs+        return $ Just (w,-sel)+  case top of+    Nothing -> return ()+    Just c -> SAT.addPBAtMost solver obj (c-1)+  opt <- PBO.newOptimizer solver obj+  PBO.setMethod opt method+  PBO.optimize opt+  liftM (fmap (\(m, val) -> (SAT.restrictModel nv m, val))) $ PBO.getBestSolution opt+++solvePBNLC :: SAT.Solver -> (Int,[(PBRel,SAT.PBSum,Integer)]) -> IO (Maybe SAT.Model)+solvePBNLC solver (nv,cs) = do+  SAT.newVars_ solver nv+  enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver+  forM_ cs $ \(o,lhs,rhs) -> do+    case o of+      PBRelGE -> PBNLC.addPBNLAtLeast enc lhs rhs+      PBRelLE -> PBNLC.addPBNLAtMost enc lhs rhs+      PBRelEQ -> PBNLC.addPBNLExactly enc lhs rhs+  ret <- SAT.solve solver+  if ret then do+    m <- SAT.getModel solver+    return $ Just $ SAT.restrictModel nv m+  else do+    return Nothing+++optimizePBNLC+  :: SAT.Solver+  -> PBO.Method+  -> (Int, SAT.PBSum, [(PBRel,SAT.PBSum,Integer)])+  -> IO (Maybe (SAT.Model, Integer))+optimizePBNLC solver method (nv,obj,cs) = do+  SAT.newVars_ solver nv+  enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver+  forM_ cs $ \(o,lhs,rhs) -> do+    case o of+      PBRelGE -> PBNLC.addPBNLAtLeast enc lhs rhs+      PBRelLE -> PBNLC.addPBNLAtMost enc lhs rhs+      PBRelEQ -> PBNLC.addPBNLExactly enc lhs rhs+  obj2 <- PBNLC.linearizePBSumWithPolarity enc Tseitin.polarityNeg obj+  opt <- PBO.newOptimizer2 solver obj2 (\m -> SAT.evalPBSum m obj)+  PBO.setMethod opt method+  PBO.optimize opt+  liftM (fmap (\(m, val) -> (SAT.restrictModel nv m, val))) $ PBO.getBestSolution opt++------------------------------------------------------------------------++instance Arbitrary SAT.LearningStrategy where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary SAT.RestartStrategy where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary SAT.BranchingStrategy where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary SAT.PBHandlerType where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary SAT.Config where+  arbitrary = do+    restartStrategy <- arbitrary+    restartFirst <- arbitrary+    restartInc <- liftM ((1.01 +) . abs) arbitrary+    learningStrategy <- arbitrary+    learntSizeFirst <- arbitrary+    learntSizeInc <- liftM ((1.01 +) . abs) arbitrary+    branchingStrategy <- arbitrary+    erwaStepSizeFirst <- choose (0, 1)+    erwaStepSizeMin   <- choose (0, 1)+    erwaStepSizeDec   <- choose (0, 1)+    pbhandler <- arbitrary+    ccmin <- choose (0,2)+    phaseSaving <- arbitrary+    forwardSubsumptionRemoval <- arbitrary+    backwardSubsumptionRemoval <- arbitrary+    randomFreq <- choose (0,1)+    splitClausePart <- arbitrary+    return $ def+      { SAT.configRestartStrategy = restartStrategy+      , SAT.configRestartFirst = restartFirst+      , SAT.configRestartInc = restartInc+      , SAT.configLearningStrategy = learningStrategy+      , SAT.configLearntSizeFirst = learntSizeFirst+      , SAT.configLearntSizeInc = learntSizeInc+      , SAT.configPBHandlerType = pbhandler+      , SAT.configCCMin = ccmin+      , SAT.configBranchingStrategy = branchingStrategy+      , SAT.configERWAStepSizeFirst = erwaStepSizeFirst+      , SAT.configERWAStepSizeDec   = erwaStepSizeDec+      , SAT.configERWAStepSizeMin   = erwaStepSizeMin+      , SAT.configEnablePhaseSaving = phaseSaving+      , SAT.configEnableForwardSubsumptionRemoval = forwardSubsumptionRemoval+      , SAT.configEnableBackwardSubsumptionRemoval = backwardSubsumptionRemoval+      , SAT.configRandomFreq = randomFreq+      , SAT.configEnablePBSplitClausePart = splitClausePart+      }++arbitrarySolver :: QM.PropertyM IO SAT.Solver+arbitrarySolver = do+  seed <- QM.pick arbitrary+  config <- QM.pick arbitrary+  QM.run $ do+    solver <- SAT.newSolverWithConfig config{ SAT.configCheckModel = True }+    SAT.setRandomGen solver =<< Rand.initialize (V.singleton seed)+    return solver++arbitraryOptimizer :: SAT.Solver -> SAT.PBLinSum -> QM.PropertyM IO PBO.Optimizer+arbitraryOptimizer solver obj = do+  method <- QM.pick arbitrary+  QM.run $ do+    opt <- PBO.newOptimizer solver obj+    PBO.setMethod opt method+    return opt++instance Arbitrary PBO.Method where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary Cardinality.Strategy where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary PB.Strategy where+  arbitrary = arbitraryBoundedEnum++arbitraryPBSum :: Int -> Gen SAT.PBSum+arbitraryPBSum nv = do+  nt <- choose (0,10)+  replicateM nt $ do+    ls <-+      if nv==0+      then return []+      else do+        m <- choose (0,nv)+        replicateM m $ do+          x <- choose (1,m)+          b <- arbitrary+          return $ if b then x else -x+    c <- arbitrary+    return (c,ls)++arbitraryPBFormula :: Gen PBFile.Formula+arbitraryPBFormula = do+  nv <- choose (0,10)+  obj <- do+    b <- arbitrary+    if b then+      liftM Just $ arbitraryPBSum nv+    else+      return Nothing+  nc <- choose (0,10)+  cs <- replicateM nc $ do+    lhs <- arbitraryPBSum nv+    op <- arbitrary+    rhs <- arbitrary+    return (lhs,op,rhs)+  return $+    PBFile.Formula+    { PBFile.pbObjectiveFunction = obj+    , PBFile.pbNumVars = nv+    , PBFile.pbNumConstraints = nc+    , PBFile.pbConstraints = cs+    }++instance Arbitrary PBFile.Op where+  arbitrary = arbitraryBoundedEnum++-- ---------------------------------------------------------------------++#if !MIN_VERSION_QuickCheck(2,8,0)+sublistOf :: [a] -> Gen [a]+sublistOf xs = filterM (\_ -> choose (False, True)) xs+#endif
test/Test/SDPFile.hs view
@@ -50,22 +50,22 @@  case_test1 = checkParsed example1b example1   where-    s = toLazyByteString $ render example1+    s = toLazyByteString $ renderData example1     example1b = parseData "" s  case_test2 = checkParsed example1b example1   where-    s = toLazyByteString $ renderSparse example1+    s = toLazyByteString $ renderSparseData example1     example1b = parseSparseData "" s  case_test3 = checkParsed example2b example2   where-    s = toLazyByteString $ render example2+    s = toLazyByteString $ renderData example2     example2b = parseData "" s  case_test4 = checkParsed example2b example2   where-    s = toLazyByteString $ renderSparse example2+    s = toLazyByteString $ renderSparseData example2     example2b = parseSparseData "" s  -- checkParsed :: Either ParseError Problem -> Problem -> Assertion
test/Test/SMT.hs view
@@ -47,7 +47,7 @@ case_QF_EUF_1 = do   solver <- SMT.newSolver   x <- SMT.declareConst solver "x" SMT.sBool-  f <- SMT.declareFun solver "f" [SMT.sBool] SMT.sBool  +  f <- SMT.declareFun solver "f" [SMT.sBool] SMT.sBool    let c1 = f true .==. true       c2 = notB (f x)@@ -72,7 +72,7 @@   a <- SMT.declareConst solver "a" SMT.sBool   x <- SMT.declareConst solver "x" sU   y <- SMT.declareConst solver "y" sU-  f <- SMT.declareFun solver "f" [sU] sU  +  f <- SMT.declareFun solver "f" [sU] sU    let c1 = a .||. (x .==. y)       c2 = f x ./=. f y
test/Test/SimplexTextbook.hs view
@@ -63,7 +63,7 @@   let (ret,result) = phaseI example_5_3_phase1 (IntSet.fromList [6,7])   assertBool "phase1 failed" ret   assertBool "invalid tableau" (isValidTableau result)-  assertBool "infeasible tableau" (isFeasible result)    +  assertBool "infeasible tableau" (isFeasible result)  -- 退化して巡回の起こるKuhnの7変数3制約の例 kuhn_7_3 :: Tableau Rational
test/Test/Smtlib.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Test.Smtlib (smtlibTestGroup) where -import Control.Applicative import Control.DeepSeq import Control.Monad import qualified Data.Set as Set@@ -17,9 +16,8 @@ import Smtlib.Parsers.CommonParsers import Smtlib.Parsers.CommandsParsers import Smtlib.Parsers.ResponseParsers-import Text.Parsec (parse, ParseError)+import Text.Parsec (parse) -import Debug.Trace  prop_parseTerm :: Property prop_parseTerm = forAll arbitrary $ \(t :: Term) ->@@ -367,7 +365,7 @@   where     g :: Gen Char     g = oneof [elements (Set.toList xs), choose (toEnum 128, maxBound)]-    xs = Set.fromList (['\t','\n','\r'] ++ [' ' .. toEnum 126]) `Set.difference` Set.fromList ['\\', '|']    +    xs = Set.fromList (['\t','\n','\r'] ++ [' ' .. toEnum 126]) `Set.difference` Set.fromList ['\\', '|']  genKeyword :: Gen String genKeyword = oneof
test/TestPolynomial.hs view
@@ -573,7 +573,7 @@ polynomials = do   size <- choose (0, 5)   xs <- replicateM size genTerms-  return $ sum $ map P.fromTerm xs +  return $ sum $ map P.fromTerm xs  umonicMonomials :: Gen UMonomial umonicMonomials = do@@ -593,7 +593,7 @@ upolynomials = do   size <- choose (0, 5)   xs <- replicateM size genUTerms-  return $ sum $ map P.fromTerm xs +  return $ sum $ map P.fromTerm xs  genUTermsZ :: Gen (UTerm Integer) genUTermsZ = do@@ -605,7 +605,7 @@ upolynomialsZ = do   size <- choose (0, 5)   xs <- replicateM size genUTermsZ-  return $ sum $ map P.fromTerm xs +  return $ sum $ map P.fromTerm xs  ------------------------------------------------------------------------
test/TestSuite.hs view
@@ -9,6 +9,8 @@ import Test.BoolExpr import Test.CongruenceClosure import Test.ContiTraverso+import Test.Converter+import Test.CNF import Test.Delta import Test.FiniteModelFinder import Test.GraphShortestPath@@ -19,10 +21,17 @@ import Test.MIPSolver import Test.MIPSolver2 import Test.MPSFile+import Test.ProbSAT import Test.SDPFile import Test.Misc import Test.QBF+import Test.QUBO import Test.SAT+import Test.SAT.Encoder+import Test.SAT.ExistentialQuantification+import Test.SAT.MUS+import Test.SAT.TheorySolver+import Test.SAT.Types import Test.Simplex import Test.SimplexTextbook import Test.SMT@@ -39,6 +48,8 @@   , bitVectorTestGroup   , boolExprTestGroup   , ccTestGroup+  , cnfTestGroup+  , converterTestGroup   , ctTestGroup   , deltaTestGroup   , fmfTestGroup@@ -51,8 +62,15 @@   , mipSolverTestGroup   , mipSolver2TestGroup   , mpsTestGroup+  , probSATTestGroup   , qbfTestGroup+  , quboTestGroup   , satTestGroup+  , satEncoderTestGroup+  , satExistentialQuantificationTestGroup+  , satMUSTestGroup+  , satTheorySolverTestGroup+  , satTypesTestGroup   , sdpTestGroup   , simplexTestGroup   , simplexTextbookTestGroup
toysolver.cabal view
@@ -1,19 +1,21 @@ Name:		toysolver-Version:	0.5.0+Version:	0.6.0 License:	BSD3 License-File:	COPYING Author:		Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer:	masahiro.sakai@gmail.com-Category:	Algorithms, Optimisation, Optimization, Theorem Provers, Constraints, Logic, Formal Methods-Cabal-Version:	>= 1.18+Category:	Algorithms, Optimisation, Optimization, Theorem Provers, Constraints, Logic, Formal Methods, SMT+Cabal-Version:	1.18 Synopsis:	Assorted decision procedures for SAT, SMT, Max-SAT, PB, MIP, etc-Description:	Toy-level implementation of some decision procedures+Description:	Toy-level solver implementation of various problems including SAT, SMT, Max-SAT, PBS/PBO (Pseudo Boolean Satisfaction/Optimization), MILP (Mixed Integer Linear Programming) and non-linear real arithmetic. Homepage:	https://github.com/msakai/toysolver/ Bug-Reports:	https://github.com/msakai/toysolver/issues Tested-With:-   GHC ==7.8.4    GHC ==7.10.3-   GHC ==8.0.1+   GHC ==8.0.2+   GHC ==8.2.2+   GHC ==8.4.4+   GHC ==8.6.4 Extra-Source-Files:    README.md    CHANGELOG.markdown@@ -26,12 +28,15 @@    misc/build_bdist_maxsat_evaluation.sh    misc/build_bdist_pb_evaluation.sh    misc/build_bdist_qbf_evaluation.sh+   misc/build_bdist_smtcomp.sh    misc/maxsat/toysat/README.md    misc/maxsat/toysat/toysat    misc/maxsat/toysat_ls/README.md    misc/maxsat/toysat_ls/toysat_ls    misc/pb/README.md    misc/qbf/README.md+   misc/smtcomp/bin/starexec_run_default+   misc/smtcomp/starexec_description.txt    src/ToySolver/Data/Polyhedron.hs    src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl    samples/gcnf/*.cnf@@ -86,6 +91,11 @@   Default: False   Manual: True +Flag WithZlib+  Description: Use zlib package to support gzipped files+  Default: True+  Manual: True+ Flag BuildToyFMF   Description: build toyfmf command   Default: False@@ -155,9 +165,12 @@   Hs-source-dirs: src   Build-Depends:      array >=0.4.0.0,-     base >=4.7 && <5,+     -- GHC >=7.10+     base >=4.8 && <5,      bytestring >=0.9.2.1 && <0.11,      bytestring-builder,+     bytestring-encoding,+     case-insensitive,      clock >=0.7.1,      -- IntMap.mergeWithKey and IntMap.toDescList require containers >=0.5.0      containers >=0.5.0,@@ -177,11 +190,12 @@      mtl >=2.1.2,      multiset,      -- createSystemRandom requires mwc-random >=0.13.1.0-     mwc-random >=0.13.1 && <0.14,+     mwc-random >=0.13.1 && <0.15,      OptDir,      lattices,-     megaparsec >=4 && <7,-     prettyclass >=1.0.0,+     megaparsec >=4 && <8,+     -- Text.PrettyPrint.HughesPJClass is available on pretty >=1.1.2.0+     pretty >=1.1.2.0 && <1.2,      primes,      primitive >=0.6,      process >=1.1.0.2,@@ -201,6 +215,9 @@      vector,      vector-space >=0.8.6,      xml-conduit+  if flag(WithZlib)+     Build-Depends: zlib+     CPP-Options: "-DWITH_ZLIB"   if flag(OpenCL)      Build-Depends: OpenCL >=1.0.3.4      Exposed-Modules: ToySolver.SAT.MessagePassing.SurveyPropagation.OpenCL@@ -274,24 +291,24 @@      ToySolver.Combinatorial.Knapsack.DPDense      ToySolver.Combinatorial.Knapsack.DPSparse      ToySolver.Combinatorial.SubsetSum+     ToySolver.Converter+     ToySolver.Converter.Base      ToySolver.Converter.GCNF2MaxSAT      ToySolver.Converter.ObjType      ToySolver.Converter.MIP2PB      ToySolver.Converter.MIP2SMT-     ToySolver.Converter.MaxSAT2IP-     ToySolver.Converter.MaxSAT2WBO+     ToySolver.Converter.NAESAT+     ToySolver.Converter.PB      ToySolver.Converter.PB2IP-     ToySolver.Converter.PBLinearization      ToySolver.Converter.PB2LSP-     ToySolver.Converter.PB2SAT-     ToySolver.Converter.PB2WBO      ToySolver.Converter.PBSetObj      ToySolver.Converter.PB2SMP+     ToySolver.Converter.QBF2IPC+     ToySolver.Converter.QUBO      ToySolver.Converter.SAT2KSAT-     ToySolver.Converter.SAT2PB-     ToySolver.Converter.SAT2IP-     ToySolver.Converter.WBO2MaxSAT-     ToySolver.Converter.WBO2PB+     ToySolver.Converter.SAT2MaxCut+     ToySolver.Converter.SAT2MaxSAT+     ToySolver.Converter.Tseitin      ToySolver.Data.AlgebraicNumber.Complex      ToySolver.Data.AlgebraicNumber.Real      ToySolver.Data.AlgebraicNumber.Root@@ -308,6 +325,7 @@      ToySolver.Data.LBool      ToySolver.Data.MIP      ToySolver.Data.MIP.Base+     ToySolver.Data.MIP.FileUtils      ToySolver.Data.MIP.LPFile      ToySolver.Data.MIP.MPSFile      ToySolver.Data.MIP.Solution.CBC@@ -335,8 +353,13 @@      ToySolver.Data.Polynomial.Factorization.Zassenhaus      ToySolver.Data.Polynomial.GroebnerBasis      ToySolver.Data.Polynomial.Interpolation.Lagrange+     ToySolver.FileFormat+     ToySolver.FileFormat.Base+     ToySolver.FileFormat.CNF      ToySolver.Graph.ShortestPath+     ToySolver.MaxCut      ToySolver.QBF+     ToySolver.QUBO      ToySolver.SAT      ToySolver.SAT.Config      ToySolver.SAT.Encoder.Integer@@ -345,6 +368,9 @@      ToySolver.SAT.Encoder.PB.Internal.BDD      ToySolver.SAT.Encoder.PB.Internal.Sorter      ToySolver.SAT.Encoder.PBNLC+     ToySolver.SAT.Encoder.Cardinality+     ToySolver.SAT.Encoder.Cardinality.Internal.Naive+     ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter      ToySolver.SAT.Encoder.Tseitin      ToySolver.SAT.ExistentialQuantification      ToySolver.SAT.MessagePassing.SurveyPropagation@@ -358,17 +384,19 @@      ToySolver.SAT.PBO.BCD2      ToySolver.SAT.PBO.MSU4      ToySolver.SAT.PBO.UnsatBased+     ToySolver.SAT.SLS.ProbSAT      ToySolver.SAT.Store.CNF      ToySolver.SAT.Store.PB      ToySolver.SAT.TheorySolver      ToySolver.SAT.Types      ToySolver.SAT.Printer+     ToySolver.SDP      ToySolver.SMT      ToySolver.Text.CNF      ToySolver.Text.GCNF-     ToySolver.Text.MaxSAT      ToySolver.Text.QDimacs      ToySolver.Text.SDPFile+     ToySolver.Text.WCNF      ToySolver.Internal.Data.IndexedPriorityQueue      ToySolver.Internal.Data.IOURef      ToySolver.Internal.Data.PriorityQueue@@ -380,6 +408,8 @@      ToySolver.Wang      ToySolver.Version   Other-Modules:+     ToySolver.Converter.PB.Internal.LargestIntersectionFinder+     ToySolver.Converter.PB.Internal.Product      ToySolver.Data.AlgebraicNumber.Graeffe      ToySolver.Data.Polynomial.Base      ToySolver.SAT.MUS.Base@@ -402,6 +432,7 @@     data-default-class,     filepath,     OptDir,+    optparse-applicative,     pseudo-boolean,     scientific,     toysolver@@ -430,6 +461,7 @@     filepath,     megaparsec,     mwc-random,+    optparse-applicative,     process >=1.1.0.2,     pseudo-boolean,     scientific,@@ -444,6 +476,8 @@   -- GHC-Prof-Options: -auto-all   if flag(ForceChar8)     CPP-OPtions: "-DFORCE_CHAR8"+  if flag(WithZlib)+    CPP-Options: "-DWITH_ZLIB"   if flag(LinuxStatic)     GHC-Options: -static -optl-static -optl-pthread @@ -463,10 +497,10 @@   Build-Depends:     base,     containers,-    data-default-class,     -- TODO: remove intern dependency     intern,     mtl,+    optparse-applicative,     parsec >=3.1.2 && <4,     toysolver,     text,@@ -491,6 +525,7 @@     base,     containers,     data-default-class,+    optparse-applicative,     toysolver   Default-Language: Haskell2010   Other-Extensions: ScopedTypeVariables, CPP@@ -514,6 +549,7 @@       -- logic-TPTP <=0.4.3 has build error on ghc <7.9 and transformers >=0.5.1.       -- https://github.com/DanielSchuessler/logic-TPTP/pull/4       logic-TPTP >=0.4.4.0,+      optparse-applicative,       text,       toysolver     -- logic-TPTP <=0.4.4.0 is not compatible with transformers-compat >=0.5@@ -524,6 +560,9 @@       else         Build-Depends:           transformers-compat <0.5+    -- for Semigroup (as superclass of) Monoid Proposal+    if impl(ghc >=8.4)+      Build-Depends: logic-TPTP >=0.4.6.0   Default-Language: Haskell2010   Other-Extensions: CPP   GHC-Options: -rtsopts@@ -540,10 +579,12 @@   HS-Source-Dirs: app   Build-Depends:     base,+    ansi-wl-pprint,     bytestring,     bytestring-builder,     data-default-class,     filepath,+    optparse-applicative,     pseudo-boolean,     scientific,     text,@@ -554,6 +595,8 @@   -- GHC-Prof-Options: -auto-all   if flag(ForceChar8)     CPP-OPtions: "-DFORCE_CHAR8"+  if flag(WithZlib)+    CPP-Options: "-DWITH_ZLIB"   if flag(LinuxStatic)     GHC-Options: -static -optl-static -optl-pthread @@ -757,6 +800,28 @@   if flag(LinuxStatic)     GHC-Options: -static -optl-static -optl-pthread +Executable probsat+  if !flag(BuildSamplePrograms)+    Buildable: False    +  Main-is: probsat.hs+  HS-Source-Dirs: samples/programs/probsat+  Build-Depends:+    base,+    clock,+    data-default-class,+    mwc-random,+    optparse-applicative,+    vector,+    toysolver+  Default-Language: Haskell2010+  Other-Extensions: CPP+  GHC-Options: -rtsopts+  -- GHC-Prof-Options: -auto-all+  if flag(ForceChar8)+    CPP-Options: "-DFORCE_CHAR8"+  if flag(LinuxStatic)+    GHC-Options: -static -optl-static -optl-pthread+ -- Misc Programs  Executable pigeonhole@@ -766,6 +831,7 @@   HS-Source-Dirs: app   Build-Depends:     base,+    bytestring,     containers,     pseudo-boolean,     toysolver@@ -826,10 +892,10 @@     containers,     data-interval,     finite-field >=0.7.0 && <1.0.0,-    prettyclass >=1.0.0,+    pretty,     tasty >=0.10.1,-    tasty-hunit ==0.9.*,-    tasty-quickcheck >=0.8 && <0.10,+    tasty-hunit >=0.9 && <0.11,+    tasty-quickcheck >=0.8 && <0.11,     tasty-th,     toysolver   Default-Language: Haskell2010@@ -846,8 +912,10 @@     Test.BitVector     Test.BoolExpr     Test.BipartiteMatching+    Test.CNF     Test.CongruenceClosure     Test.ContiTraverso+    Test.Converter     Test.Delta     Test.FiniteModelFinder     Test.GraphShortestPath@@ -859,8 +927,16 @@     Test.MIPSolver     Test.MIPSolver2     Test.MPSFile+    Test.ProbSAT     Test.QBF+    Test.QUBO     Test.SAT+    Test.SAT.Encoder+    Test.SAT.ExistentialQuantification+    Test.SAT.MUS+    Test.SAT.TheorySolver+    Test.SAT.Types+    Test.SAT.Utils     Test.SDPFile     Test.Simplex     Test.SimplexTextbook@@ -893,9 +969,10 @@     parsec >=3.1.2 && <4,     pseudo-boolean,     QuickCheck >=2.5 && <3,+    scientific,     tasty >=0.10.1,-    tasty-hunit ==0.9.*,-    tasty-quickcheck >=0.8 && <0.10,+    tasty-hunit >=0.9 && <0.11,+    tasty-quickcheck >=0.8 && <0.11,     tasty-th,     text,     toysolver,@@ -926,7 +1003,7 @@   build-depends:     array,     base,-    criterion >=1.0 && <1.3,+    criterion >=1.0 && <1.6,     data-default-class,     toysolver   Default-Language: Haskell2010@@ -937,7 +1014,7 @@   main-is:          BenchmarkKnapsack.hs   build-depends:     base,-    criterion >=1.0 && <1.3,+    criterion >=1.0 && <1.6,     toysolver   Default-Language: Haskell2010 @@ -947,7 +1024,7 @@   main-is:          BenchmarkSubsetSum.hs   build-depends:     base,-    criterion >=1.0 && <1.3,+    criterion >=1.0 && <1.6,     toysolver,     vector   Default-Language: Haskell2010