toysolver 0.8.1 → 0.9.0
raw patch · 86 files changed
+3747/−2368 lines, 86 filesdep +aesondep +prettyprinterdep −OpenCLdep ~MIPdep ~basedep ~bytestring
Dependencies added: aeson, prettyprinter
Dependencies removed: OpenCL
Dependency ranges changed: MIP, base, bytestring, containers, hashable, logic-TPTP, optparse-applicative, tasty-quickcheck
Files
- CHANGELOG.markdown +27/−2
- INSTALL.md +1/−1
- README.md +3/−6
- app/toyconvert.hs +222/−87
- app/toysat/toysat.hs +15/−8
- misc/build_bdist_linux.sh +0/−28
- misc/build_bdist_macos.sh +0/−28
- misc/build_bdist_maxsat_evaluation.sh +0/−44
- misc/build_bdist_pb_evaluation.sh +0/−26
- misc/build_bdist_qbf_evaluation.sh +0/−27
- misc/build_bdist_smtcomp.sh +0/−26
- misc/build_bdist_win32.sh +0/−31
- misc/build_bdist_win64.sh +0/−31
- misc/maxsat/toysat/README.md +0/−26
- misc/maxsat/toysat/toysat +0/−5
- misc/maxsat/toysat_ls/README.md +0/−34
- misc/maxsat/toysat_ls/toysat_ls +0/−4
- misc/pb/README.md +0/−61
- misc/qbf/README.md +0/−34
- misc/smtcomp/bin/starexec_run_default +0/−2
- misc/smtcomp/starexec_description.txt +0/−1
- samples/programs/survey-propagation/survey-propagation.hs +12/−84
- samples/programs/svm2lp/svm2lp.hs +10/−11
- src/ToySolver/Arith/CAD.hs +1/−0
- src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs +1/−0
- src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs +2/−1
- src/ToySolver/Combinatorial/Knapsack/BB.hs +1/−0
- src/ToySolver/Converter.hs +2/−8
- src/ToySolver/Converter/Base.hs +38/−1
- src/ToySolver/Converter/GCNF2MaxSAT.hs +16/−1
- src/ToySolver/Converter/MIP.hs +521/−0
- src/ToySolver/Converter/MIP2PB.hs +0/−157
- src/ToySolver/Converter/MIP2SMT.hs +3/−4
- src/ToySolver/Converter/NAESAT.hs +49/−3
- src/ToySolver/Converter/ObjType.hs +0/−18
- src/ToySolver/Converter/PB.hs +419/−55
- src/ToySolver/Converter/PB2IP.hs +0/−212
- src/ToySolver/Converter/PB2LSP.hs +0/−104
- src/ToySolver/Converter/PB2SMP.hs +0/−87
- src/ToySolver/Converter/PBSetObj.hs +0/−31
- src/ToySolver/Converter/QUBO.hs +69/−14
- src/ToySolver/Converter/SAT2KSAT.hs +12/−31
- src/ToySolver/Converter/SAT2MIS.hs +43/−0
- src/ToySolver/Converter/SAT2MaxCut.hs +13/−0
- src/ToySolver/Converter/SAT2MaxSAT.hs +44/−45
- src/ToySolver/Converter/Tseitin.hs +38/−4
- src/ToySolver/FileFormat/CNF.hs +2/−2
- src/ToySolver/Graph/Base.hs +139/−11
- src/ToySolver/Graph/ShortestPath.hs +0/−1
- src/ToySolver/Internal/JSON.hs +14/−0
- src/ToySolver/SAT/Encoder/Cardinality.hs +21/−7
- src/ToySolver/SAT/Encoder/Cardinality/Internal/Naive.hs +7/−7
- src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs +15/−16
- src/ToySolver/SAT/Encoder/Cardinality/Internal/Totalizer.hs +12/−13
- src/ToySolver/SAT/Encoder/Integer.hs +1/−1
- src/ToySolver/SAT/Encoder/PB.hs +60/−16
- src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs +4/−4
- src/ToySolver/SAT/Encoder/PB/Internal/BCCNF.hs +238/−0
- src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs +8/−8
- src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs +1/−0
- src/ToySolver/SAT/Encoder/Tseitin.hs +17/−9
- src/ToySolver/SAT/ExistentialQuantification.hs +1/−1
- src/ToySolver/SAT/Formula.hs +57/−0
- src/ToySolver/SAT/Internal/JSON.hs +160/−0
- src/ToySolver/SAT/PBO/BCD2.hs +1/−1
- src/ToySolver/SAT/Solver/CDCL.hs +9/−0
- src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/OpenCL.hs +0/−456
- src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl +0/−193
- src/ToySolver/SAT/Solver/SLS/ProbSAT.hs +5/−0
- src/ToySolver/SAT/Types.hs +42/−0
- src/ToySolver/SDP.hs +19/−0
- src/ToySolver/Version.hs +0/−3
- test/Test/Converter.hs +662/−88
- test/Test/Graph.hs +99/−0
- test/Test/GraphShortestPath.hs +0/−1
- test/Test/HittingSets.hs +3/−1
- test/Test/QBF.hs +3/−1
- test/Test/QUBO.hs +66/−4
- test/Test/SAT.hs +60/−32
- test/Test/SAT/Encoder.hs +238/−25
- test/Test/SAT/MUS.hs +1/−1
- test/Test/SAT/Types.hs +1/−1
- test/Test/SAT/Utils.hs +120/−8
- test/Test/SDPFile.hs +17/−0
- test/TestSuite.hs +2/−0
- toysolver.cabal +80/−74
CHANGELOG.markdown view
@@ -1,7 +1,32 @@-0.8.1+0.9.0 (2025-02-18) ----- -* Support GHC 9.4+* Converters updates+ * Add `--dump-info` option to `toyconvert` (#119, #120, #125)+ * Change the signs of QUBO-related converter's representation of offset (#126)+ * Change `WBO2IPInfo` not to store weights (#124)+ * Change `SAT2KSATInfo`, `SimplifyMaxSAT2Info` and `SAT3ToMaxSAT2Info` to be synonyms of `TseitinInfo` (#121, #123)+ * Use `SAT.VarMap` to represent definitions in SAT-related encoders/converters (#127)+ * Add instances for transforming objective function values between PB↔WBO conversion (#132)+ * Change `ReversedTransformer`, `GCNF2MaxSATInfo`, `PBAsQUBOInfo`, `QUBO2IsingInfo`, `Ising2QUBOInfo` from `data` to `newtype` (#134)+ * Fix `mip2pb`’s handling of indicator constraints (#137)+ * Add more converter instances (#138)+ * Restructure converter modules (#142)+ * Support SOS constraints over non-binary variables in `mip2pb` (#140)+ * Rename `mip2pb` to `ip2pb`+* Pseudo-boolean and cardinality constarint encoder updates+ * Consider polarity in encoding of pseudo-boolean and cardinality constraints (#88)+ * Add BC-CNF pseudo boolean constraint encoder (#85)+ * Support specifying PB encoding strategy (#77)+* Dependencies+ * Support GHC 9.4 (#92), 9.6, 9.8, 9.10+ * Use `prettyprinter` package if `optparse-applicative` is `>=0.18` (#106)+ * Upgrade `MIP` package to 0.2.* (#144)+* Misc+ * Do not rely on `StarIsType` extension (#84)+ * Add `BuildForeignLibraries` flag (#94)+ * Remove features that depend on OpenCL (#90)+ * Improve `ToySolver.Graph` module (#130, #150) 0.8.0 -----
INSTALL.md view
@@ -29,5 +29,5 @@ To run `toysat` using Docker for solving `samples/pbs/normalized-j3025_1-sat.opb`: ```-docker run -it --rm -v `pwd`:/data msakai/toysolver toysat samples/pbs/normalized-j3025_1-sat.opb`+docker run -it --rm -v `pwd`:/data msakai/toysolver toysat samples/pbs/normalized-j3025_1-sat.opb ```
README.md view
@@ -6,17 +6,14 @@ Hackage: [](https://hackage.haskell.org/package/toysolver)-[](https://packdeps.haskellers.com/feed?needle=toysolver)-[](https://matrix.hackage.haskell.org/#/package/toysolver) Dev:-[](https://ci.appveyor.com/project/msakai/toysolver/branch/master)-[](https://github.com/msakai/toysolver/actions)+[](https://github.com/msakai/toysolver/actions) [](https://coveralls.io/r/msakai/toysolver) 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. -In particular it contains moderately-fast pure-Haskell SAT solver 'toysat'.+In particular, it contains moderately-fast pure-Haskell SAT solver 'toysat'. Installation ------------@@ -32,7 +29,7 @@ Arithmetic solver for the following problems: -* Mixed Integer Liner Programming (MILP or MIP)+* Mixed Integer Linear Programming (MILP or MIP) * Boolean SATisfiability problem (SAT) * PB * Pseudo Boolean Satisfaction (PBS)
app/toyconvert.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} -----------------------------------------------------------------------------@@ -17,39 +18,49 @@ import Control.Applicative import Control.Monad+import qualified Data.Aeson as J import qualified Data.ByteString.Builder as ByteStringBuilder import Data.Char import Data.Default.Class import qualified Data.Foldable as F+import Data.List+import Data.Map.Lazy (Map) import Data.Maybe 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 Options.Applicative+import Options.Applicative hiding (info)+import qualified Options.Applicative import System.IO import System.Exit import System.FilePath+#if MIN_VERSION_optparse_applicative(0,18,0)+import Prettyprinter ((<+>))+import qualified Prettyprinter as PP+#else import Text.PrettyPrint.ANSI.Leijen ((<+>)) import qualified Text.PrettyPrint.ANSI.Leijen as PP+#endif import qualified Data.PseudoBoolean as PBFile import qualified Numeric.Optimization.MIP as MIP import ToySolver.Converter-import ToySolver.Converter.ObjType import qualified ToySolver.Converter.MIP2SMT as MIP2SMT-import qualified ToySolver.Converter.PBSetObj as PBSetObj import qualified ToySolver.FileFormat as FF import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.QUBO as QUBO+import qualified ToySolver.SAT as SAT+import qualified ToySolver.SAT.Encoder.PB as PB import ToySolver.Version import ToySolver.Internal.Util (setEncodingChar8) data Options = Options { optInput :: FilePath , optOutput :: Maybe FilePath+ , optInfoOutput :: Maybe FilePath , optAsMaxSAT :: Bool , optObjType :: ObjType , optIndicatorConstraint :: Bool@@ -65,12 +76,14 @@ , optRemoveUserCuts :: Bool , optNewWCNF :: Bool , optPBFastParser :: Bool+ , optPBEncoding :: PB.Strategy } deriving (Eq, Show) optionsParser :: Parser Options optionsParser = Options <$> fileInput <*> outputOption+ <*> infoOutputOption <*> maxsatOption <*> objOption <*> indicatorConstraintOption@@ -86,6 +99,7 @@ <*> removeUserCutsOption <*> newWCNFOption <*> pbFastParserOption+ <*> pbEncoding where fileInput :: Parser FilePath fileInput = argument str (metavar "FILE")@@ -97,6 +111,12 @@ <> metavar "FILE" <> help "output filename" + infoOutputOption :: Parser (Maybe FilePath)+ infoOutputOption = optional $ strOption+ $ long "dump-info"+ <> metavar "FILE"+ <> help "filename for dumping conversion information"+ maxsatOption :: Parser Bool maxsatOption = switch $ long "maxsat"@@ -191,8 +211,16 @@ $ long "pb-fast-parser" <> help "use attoparsec-based parser instead of megaparsec-based one for speed" + pbEncoding :: Parser PB.Strategy+ pbEncoding = option (maybeReader PB.parseStrategy)+ $ long "pb-encoding"+ <> metavar "STR"+ <> help ("PB to SAT encoding: " ++ intercalate ", " [PB.showStrategy m | m <- [minBound..maxBound]])+ <> value def+ <> showDefaultWith PB.showStrategy+ parserInfo :: ParserInfo Options-parserInfo = info (helper <*> versionOption <*> optionsParser)+parserInfo = Options.Applicative.info (helper <*> versionOption <*> optionsParser) $ fullDesc <> header "toyconvert - converter between various kind of problem files" <> footerDoc (Just supportedFormatsDoc)@@ -203,6 +231,20 @@ <> long "version" <> help "Show version" +#if MIN_VERSION_optparse_applicative(0,18,0)++supportedFormatsDoc :: PP.Doc ann+supportedFormatsDoc =+ PP.vsep+ [ PP.pretty "Supported formats:"+ , PP.indent 2 $ PP.vsep+ [ PP.pretty "input:" <+> (PP.align $ PP.fillSep $ map PP.pretty $ words ".cnf .wcnf .opb .wbo .gcnf .lp .mps .qubo")+ , PP.pretty "output:" <+> (PP.align $ PP.fillSep $ map PP.pretty $ words ".cnf .wcnf .opb .wbo .lsp .lp .mps .smp .smt2 .ys .qubo")+ ]+ ]++#else+ supportedFormatsDoc :: PP.Doc supportedFormatsDoc = PP.vsep@@ -213,39 +255,65 @@ ] ] +#endif++data Trail sol where+ Trail :: (Transformer a, J.ToJSON a) => a -> Trail (Target a)+ data Problem- = ProbOPB PBFile.Formula- | ProbWBO PBFile.SoftFormula- | ProbMIP (MIP.Problem Scientific)+ = ProbOPB PBFile.Formula (Trail SAT.Model)+ | ProbWBO PBFile.SoftFormula (Trail SAT.Model)+ | ProbMIP (MIP.Problem Scientific) (Trail (Map MIP.Var Rational)) readProblem :: Options -> String -> IO Problem readProblem o fname = do enc <- T.mapM mkTextEncoding (optFileEncoding o) case getExt fname of ".cnf"- | optAsMaxSAT o ->- liftM (ProbWBO . fst . maxsat2wbo) $ FF.readFile fname+ | optAsMaxSAT o -> do+ prob <- FF.readFile fname+ case maxsat2wbo prob of+ (prob', info) -> return $ ProbWBO prob' (Trail info) | otherwise -> do- liftM (ProbOPB . fst . sat2pb) $ FF.readFile fname- ".wcnf" ->- liftM (ProbWBO . fst . maxsat2wbo) $ FF.readFile fname- ".opb" -> liftM ProbOPB $ do- if optPBFastParser o then- liftM FF.unWithFastParser $ FF.readFile fname- else- FF.readFile fname- ".wbo" -> liftM ProbWBO $ do- if optPBFastParser o then- liftM FF.unWithFastParser $ FF.readFile fname- else- 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+ prob <- FF.readFile fname+ case sat2pb prob of+ (prob', info) -> return $ ProbOPB prob' (Trail info)+ ".wcnf" -> do+ prob <- FF.readFile fname+ case maxsat2wbo prob of+ (prob', info) -> return $ ProbWBO prob' (Trail info)+ ".opb" -> do+ prob <-+ if optPBFastParser o then+ liftM FF.unWithFastParser $ FF.readFile fname+ else+ FF.readFile fname+ return $ ProbOPB prob (Trail IdentityTransformer)+ ".wbo" -> do+ prob <-+ if optPBFastParser o then+ liftM FF.unWithFastParser $ FF.readFile fname+ else+ FF.readFile fname+ return $ ProbWBO prob (Trail IdentityTransformer)+ ".gcnf" -> do+ prob <- FF.readFile fname+ case gcnf2maxsat prob of+ (prob1, info1) ->+ case maxsat2wbo prob1 of+ (prob2, info2) ->+ return $ ProbWBO prob2 (Trail (ComposedTransformer info1 info2))+ ".lp" -> do+ prob <- MIP.readLPFile def{ MIP.optFileEncoding = enc } fname+ return $ ProbMIP prob (Trail IdentityTransformer)+ ".mps" -> do+ prob <- MIP.readMPSFile def{ MIP.optFileEncoding = enc } fname+ return $ ProbMIP prob (Trail IdentityTransformer) ".qubo" -> do (qubo :: QUBO.Problem Scientific) <- FF.readFile fname- return $ ProbOPB $ fst $ qubo2pb qubo+ case qubo2pb qubo of+ (prob', info) ->+ return $ ProbOPB prob' (Trail info) ext -> error $ "unknown file extension: " ++ show ext @@ -263,26 +331,53 @@ transformObj :: Options -> Problem -> Problem transformObj o problem = case problem of- ProbOPB opb | isNothing (PBFile.pbObjectiveFunction opb) -> ProbOPB $ PBSetObj.setObj (optObjType o) opb+ ProbOPB opb info | isNothing (PBFile.pbObjectiveFunction opb) -> ProbOPB (setObj (optObjType o) opb) info _ -> problem transformPBLinearization :: Options -> Problem -> Problem transformPBLinearization o problem | optLinearization o = case problem of- ProbOPB opb -> ProbOPB $ fst $ linearizePB opb (optLinearizationUsingPB o)- ProbWBO wbo -> ProbWBO $ fst $ linearizeWBO wbo (optLinearizationUsingPB o)- ProbMIP mip -> ProbMIP mip+ ProbOPB opb (Trail info) ->+ case linearizePB opb (optLinearizationUsingPB o) of+ (opb', info') -> ProbOPB opb' (Trail (ComposedTransformer info info'))+ ProbWBO wbo (Trail info) ->+ case linearizeWBO wbo (optLinearizationUsingPB o) of+ (wbo', info') -> ProbWBO wbo' (Trail (ComposedTransformer info info'))+ ProbMIP mip info -> ProbMIP mip info | otherwise = problem transformMIPRemoveUserCuts :: Options -> Problem -> Problem transformMIPRemoveUserCuts o problem | optRemoveUserCuts o = case problem of- ProbMIP mip -> ProbMIP $ mip{ MIP.userCuts = [] }+ ProbMIP mip info -> ProbMIP (mip{ MIP.userCuts = [] }) info _ -> problem | otherwise = problem +transformKSat :: Options -> (CNF.CNF, Trail SAT.Model) -> (CNF.CNF, Trail SAT.Model)+transformKSat o (cnf, Trail info) =+ case optKSat o of+ Nothing -> (cnf, Trail info)+ Just k ->+ case sat2ksat k cnf of+ (cnf2, info2) -> (cnf2, Trail (ComposedTransformer info info2))++transformPB2SAT :: Options -> (PBFile.Formula, Trail SAT.Model) -> (CNF.CNF, Trail SAT.Model)+transformPB2SAT o (opb, Trail info) =+ case pb2satWith (optPBEncoding o) opb of+ (cnf, info') -> (cnf, Trail (ComposedTransformer info info'))++transformWBO2MaxSAT :: Options -> (PBFile.SoftFormula, Trail SAT.Model) -> (CNF.WCNF, Trail SAT.Model)+transformWBO2MaxSAT o (wbo, Trail info) =+ case wbo2maxsatWith (optPBEncoding o) wbo of+ (wcnf, info') -> (wcnf, Trail (ComposedTransformer info info'))++transformPB2QUBO :: (PBFile.Formula, Trail SAT.Model) -> ((QUBO.Problem Integer, Integer), Trail QUBO.Solution)+transformPB2QUBO (opb, Trail info) =+ case pb2qubo opb of+ ((qubo, th), info') -> ((qubo, th), Trail (ComposedTransformer info info'))+ writeProblem :: Options -> Problem -> IO () writeProblem o problem = do enc <- T.mapM mkTextEncoding (optFileEncoding o)@@ -293,89 +388,129 @@ , MIP2SMT.optProduceModel = not (optSMTNoProduceModel o) , MIP2SMT.optOptimize = optSMTOptimize o }++ writeInfo :: (Transformer a, J.ToJSON a) => a -> IO ()+ writeInfo info =+ case optInfoOutput o of+ Just fname -> J.encodeFile fname info+ Nothing -> return ()++ writeInfo' :: Trail a -> IO ()+ writeInfo' (Trail info) = writeInfo info+ case optOutput o of Nothing -> do hSetBinaryMode stdout True hSetBuffering stdout (BlockBuffering Nothing) case problem of- ProbOPB opb -> ByteStringBuilder.hPutBuilder stdout $ FF.render opb- ProbWBO wbo -> ByteStringBuilder.hPutBuilder stdout $ FF.render wbo- ProbMIP mip -> do+ ProbOPB opb (Trail info) -> do+ ByteStringBuilder.hPutBuilder stdout $ FF.render opb+ writeInfo info+ ProbWBO wbo (Trail info) -> do+ ByteStringBuilder.hPutBuilder stdout $ FF.render wbo+ writeInfo info+ ProbMIP mip (Trail info) -> do case MIP.toLPString def mip of Left err -> hPutStrLn stderr ("conversion failure: " ++ err) >> exitFailure Right s -> do F.mapM_ (hSetEncoding stdout) enc TLIO.hPutStr stdout s+ writeInfo info+ Just fname -> do- let opb = case problem of- ProbOPB opb -> opb- ProbWBO wbo ->- case wbo2pb wbo of- (opb, _)- | optLinearization o ->- -- WBO->OPB conversion may have introduced non-linearity- fst $ linearizePB opb (optLinearizationUsingPB o)- | otherwise -> opb- ProbMIP mip ->- case mip2pb (fmap toRational mip) of- Left err -> error err- Right (opb, _) -> opb- wbo = case problem of- ProbOPB opb -> fst $ pb2wbo opb- ProbWBO wbo -> wbo- ProbMIP _ -> fst $ pb2wbo opb- lp = case problem of- ProbOPB opb ->- case pb2ip opb of- (ip, _) -> fmap fromInteger ip- ProbWBO wbo ->- case wbo2ip (optIndicatorConstraint o) wbo of- (ip, _) -> fmap fromInteger ip- ProbMIP mip -> mip- lsp = case problem of- ProbOPB opb -> pb2lsp opb- ProbWBO wbo -> wbo2lsp wbo- ProbMIP _ -> pb2lsp opb+ let opbAndTrail =+ case problem of+ ProbOPB opb info -> (opb, info)+ ProbWBO wbo (Trail info) ->+ case wbo2pb wbo of+ (opb, info')+ | optLinearization o ->+ -- WBO->OPB conversion may have introduced non-linearity+ case linearizePB opb (optLinearizationUsingPB o) of+ (opb', info'') -> (opb', Trail (ComposedTransformer info (ComposedTransformer info' info'')))+ | otherwise -> (opb, Trail (ComposedTransformer info info'))+ ProbMIP mip (Trail info) ->+ case ip2pb (fmap toRational mip) of+ Left err -> error err+ Right (opb, info') -> (opb, Trail (ComposedTransformer info info'))+ wboAndTrail =+ case problem of+ ProbOPB opb (Trail info) ->+ case pb2wbo opb of+ (wbo, info') -> (wbo, Trail (ComposedTransformer info info'))+ ProbWBO wbo info -> (wbo, info)+ ProbMIP _ _ ->+ case (pb2wbo (fst opbAndTrail), snd opbAndTrail) of+ ((wbo, info'), Trail info) -> (wbo, Trail (ComposedTransformer info info'))+ mipAndTrail =+ case problem of+ ProbOPB opb (Trail info) ->+ case pb2ip opb of+ (ip, info') -> (fmap fromInteger ip, Trail (ComposedTransformer info info'))+ ProbWBO wbo (Trail info) ->+ case wbo2ip (optIndicatorConstraint o) wbo of+ (ip, info') -> (fmap fromInteger ip, Trail (ComposedTransformer info info'))+ ProbMIP mip info -> (mip, info)+ lsp =+ case problem of+ ProbOPB opb _ -> pb2lsp opb+ ProbWBO wbo _ -> wbo2lsp wbo+ ProbMIP _ _ -> pb2lsp (fst opbAndTrail) case getExt fname of- ".opb" -> FF.writeFile fname $ normalizePB opb- ".wbo" -> FF.writeFile fname $ normalizeWBO wbo+ ".opb" -> do+ FF.writeFile fname $ normalizePB (fst opbAndTrail)+ writeInfo' (snd opbAndTrail)+ ".wbo" -> do+ FF.writeFile fname $ normalizeWBO (fst wboAndTrail)+ writeInfo' (snd wboAndTrail) ".cnf" ->- case pb2sat opb of- (cnf, _) ->- case optKSat o of- Nothing -> FF.writeFile fname cnf- Just k ->- let (cnf2, _) = sat2ksat k cnf- in FF.writeFile fname cnf2+ case transformKSat o $ transformPB2SAT o opbAndTrail of+ (cnf, Trail info) -> do+ FF.writeFile fname cnf+ writeInfo info ".wcnf" ->- case wbo2maxsat wbo of- (wcnf, _)- | optNewWCNF o -> do- let nwcnf = CNF.NewWCNF [(if w >= CNF.wcnfTopCost wcnf then Nothing else Just w, c) | (w, c) <- CNF.wcnfClauses wcnf]- FF.writeFile fname nwcnf- | otherwise -> FF.writeFile fname wcnf- ".lsp" ->+ case transformWBO2MaxSAT o wboAndTrail of+ (wcnf, Trail info) -> do+ if optNewWCNF o then do+ let nwcnf = CNF.NewWCNF [(if w >= CNF.wcnfTopCost wcnf then Nothing else Just w, c) | (w, c) <- CNF.wcnfClauses wcnf]+ FF.writeFile fname nwcnf+ else do+ FF.writeFile fname wcnf+ writeInfo info+ ".lsp" -> do withBinaryFile fname WriteMode $ \h -> ByteStringBuilder.hPutBuilder h lsp- ".lp" -> MIP.writeLPFile def{ MIP.optFileEncoding = enc } fname lp- ".mps" -> MIP.writeMPSFile def{ MIP.optFileEncoding = enc } fname lp+ case optInfoOutput o of+ Just _ -> error "--dump-info is not supported for LSP output"+ Nothing -> return ()+ ".lp" -> do+ MIP.writeLPFile def{ MIP.optFileEncoding = enc } fname (fst mipAndTrail)+ writeInfo' (snd mipAndTrail)+ ".mps" -> do+ MIP.writeMPSFile def{ MIP.optFileEncoding = enc } fname (fst mipAndTrail)+ writeInfo' (snd mipAndTrail) ".smp" -> do withBinaryFile fname WriteMode $ \h ->- ByteStringBuilder.hPutBuilder h (pb2smp False opb)+ ByteStringBuilder.hPutBuilder h (pb2smp False (fst opbAndTrail))+ writeInfo' (snd opbAndTrail) ".smt2" -> do withFile fname WriteMode $ \h -> do F.mapM_ (hSetEncoding h) enc TLIO.hPutStr h $ TextBuilder.toLazyText $- MIP2SMT.mip2smt mip2smtOpt (fmap toRational lp)+ MIP2SMT.mip2smt mip2smtOpt (fmap toRational (fst mipAndTrail))+ writeInfo' (snd mipAndTrail) ".ys" -> do 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.mip2smt mip2smtOpt{ MIP2SMT.optLanguage = lang } (fmap toRational lp)+ MIP2SMT.mip2smt mip2smtOpt{ MIP2SMT.optLanguage = lang } (fmap toRational (fst mipAndTrail))+ writeInfo' (snd mipAndTrail) ".qubo" ->- case pb2qubo opb of- ((qubo, _th), _) -> FF.writeFile fname (fmap (fromInteger :: Integer -> Scientific) qubo)+ case transformPB2QUBO opbAndTrail of+ ((qubo, _th), Trail info) -> do+ FF.writeFile fname (fmap (fromInteger :: Integer -> Scientific) qubo)+ writeInfo info ext -> do error $ "unknown file extension: " ++ show ext
app/toysat/toysat.hs view
@@ -41,7 +41,9 @@ import Data.Ord import qualified Data.Vector.Unboxed as V import Data.Version+import Data.Ratio import Data.Scientific as Scientific+import Data.String import Data.Time import Options.Applicative hiding (info) import qualified Options.Applicative@@ -852,7 +854,7 @@ where -- Use BOXED array to tie the knot a :: Array SAT.Var Bool- a = array (1,nv') $ assocs m ++ [(v, Tseitin.evalFormula a phi) | (v,phi) <- defs]+ a = array (1,nv') $ assocs m ++ [(v, Tseitin.evalFormula a phi) | (v,phi) <- IntMap.toList defs] pbo <- PBO.newOptimizer2 solver obj'' (\m -> SAT.evalPBSum m obj') setupOptimizer pbo opt@@ -959,8 +961,8 @@ a :: Array SAT.Var Bool a = array (1,nv') $ assocs m ++- [(v, Tseitin.evalFormula a phi) | (v, phi) <- defsTseitin] ++- [(v, SAT.evalPBConstraint a constr) | (v, constr) <- defsPB]+ [(v, Tseitin.evalFormula a phi) | (v, phi) <- IntMap.toList defsTseitin] +++ [(v, SAT.evalPBConstraint a constr) | (v, constr) <- IntMap.toList defsPB] let softConstrs = [(c, constr) | (Just c, constr) <- PBFile.wboConstraints formula] @@ -1064,13 +1066,13 @@ let transformObjValBackward :: Integer -> Rational transformObjValBackward val = transformObjValueBackward info (val + linObjOffset) - printModel :: Map MIP.Var Integer -> IO ()+ printModel :: Map MIP.Var Rational -> IO () printModel m = do forM_ (Map.toList m) $ \(v, val) -> do- printf "v %s = %d\n" (MIP.fromVar v) val+ printf "v %s = %d\n" (MIP.varName v) (asInteger val) hFlush stdout - writeSol :: Map MIP.Var Integer -> Rational -> IO ()+ writeSol :: Map MIP.Var Rational -> Rational -> IO () writeSol m objVal = do case optWriteFile opt of Nothing -> return ()@@ -1078,10 +1080,15 @@ let sol = MIP.Solution { MIP.solStatus = MIP.StatusUnknown , MIP.solObjectiveValue = Just $ Scientific.fromFloatDigits (fromRational objVal :: Double)- , MIP.solVariables = Map.fromList [(v, fromIntegral val) | (v,val) <- Map.toList m]+ , MIP.solVariables = Map.fromList [(v, fromIntegral (asInteger val)) | (v,val) <- Map.toList m] } GurobiSol.writeFile fname sol + asInteger :: Rational -> Integer+ asInteger r+ | denominator r /= 1 = error (show r ++ " is not integer")+ | otherwise = numerator r+ pbo <- PBO.newOptimizer solver linObj setupOptimizer pbo opt PBO.setOnUpdateBestSolution pbo $ \_ val -> do@@ -1115,7 +1122,7 @@ let sol = MIP.Solution { MIP.solStatus = MIP.StatusUnknown , MIP.solObjectiveValue = fmap fromIntegral obj- , MIP.solVariables = Map.fromList [(MIP.toVar ("x" ++ show x), if b then 1.0 else 0.0) | (x,b) <- assocs m, x <= nbvar]+ , MIP.solVariables = Map.fromList [(fromString ("x" ++ show x), if b then 1.0 else 0.0) | (x,b) <- assocs m, x <= nbvar] } GurobiSol.writeFile fname sol
− misc/build_bdist_linux.sh
@@ -1,28 +0,0 @@-#!/bin/bash--STACK_YAML=stack.yaml-RESOLVER=lts-9.2--# wget -qO- https://get.haskellstack.org/ | sh-PATH=$HOME/.local/bin:$PATH--stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER --install-ghc build \- --flag toysolver:BuildToyFMF \- --flag toysolver:BuildSamplePrograms--VER=`stack exec ghc -- -ignore-dot-ghci -e ":m + Control.Monad Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Parse Distribution.Verbosity Data.Version" -e 'putStrLn =<< liftM (showVersion . pkgVersion . package . packageDescription) (readPackageDescription silent "toysolver.cabal")'`-STACK_LOCAL_INSTALL_ROOT=`stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER path --local-install-root`-OS=`stack exec ghc -- -ignore-dot-ghci -e ":m +System.Info" -e "putStrLn os"`-ARCH=`stack exec ghc -- -ignore-dot-ghci -e ":m +System.Info" -e "putStrLn arch"`-PLATFORM=$ARCH-$OS--PKG=toysolver-${VER}-${OS}-${ARCH}--rm -r $PKG-mkdir $PKG-mkdir $PKG/bin-cp $STACK_LOCAL_INSTALL_ROOT/bin/{toyconvert,toyfmf,toyqbf,toysat,toysmt,toysolver} $PKG/bin/-cp $STACK_LOCAL_INSTALL_ROOT/bin/{assign,htc,knapsack,nonogram,nqueens,numberlink,shortest-path,sudoku} $PKG/bin/-cp -a samples $PKG/-cp COPYING-GPL README.md CHANGELOG.markdown $PKG/-tar Jcf $PKG.tar.xz $PKG --owner=sakai --group=sakai
− misc/build_bdist_macos.sh
@@ -1,28 +0,0 @@-#!/bin/bash--export MACOSX_DEPLOYMENT_TARGET=10.11--STACK_YAML=stack.yaml-RESOLVER=lts-9.2--# curl -sSL https://get.haskellstack.org/ | sh-PATH=$HOME/.local/bin:$PATH--stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER --install-ghc build \- --flag toysolver:BuildToyFMF \- --flag toysolver:BuildSamplePrograms \- --flag toysolver:OpenCL--VER=`stack exec ghc -- -ignore-dot-ghci -e ":m + Control.Monad Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Parse Distribution.Verbosity Data.Version" -e 'putStrLn =<< liftM (showVersion . pkgVersion . package . packageDescription) (readPackageDescription silent "toysolver.cabal")'`-STACK_LOCAL_INSTALL_ROOT=`stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER path --local-install-root`--PKG=toysolver-$VER-macos--rm -r $PKG-mkdir $PKG-mkdir $PKG/bin-cp $STACK_LOCAL_INSTALL_ROOT/bin/{toyconvert,toyfmf,toyqbf,toysat,toysmt,toysolver} $PKG/bin/-cp $STACK_LOCAL_INSTALL_ROOT/bin/{assign,htc,knapsack,nonogram,nqueens,numberlink,shortest-path,sudoku} $PKG/bin/-cp -a samples $PKG/-cp COPYING-GPL README.md CHANGELOG.markdown $PKG/-zip -r $PKG.zip $PKG
− misc/build_bdist_maxsat_evaluation.sh
@@ -1,44 +0,0 @@-#!/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=toysat-maxsat`date +%Y`-`date +%Y%m%d`-`git rev-parse --short HEAD`-rm -r $PKG-mkdir $PKG-cp dist/build/toysat/toysat $PKG/toysat_main-cp COPYING misc/maxsat/toysat/README.md misc/maxsat/toysat/toysat $PKG/-tar Jcf $PKG.tar.xz $PKG --owner=sakai --group=sakai--if [ ! -f ubcsat-beta-12-b18.tar.gz ]; then- wget http://ubcsat.dtompkins.com/downloads/ubcsat-beta-12-b18.tar.gz-fi-rm -r ubcsat-beta-12-b18-mkdir ubcsat-beta-12-b18-cd ubcsat-beta-12-b18-tar zxf ../ubcsat-beta-12-b18.tar.gz-gcc -Wall -O3 -static -o ubcsat src/adaptnovelty.c src/algorithms.c src/ddfw.c src/derandomized.c src/g2wsat.c src/gsat-tabu.c src/gsat.c src/gwsat.c src/hsat.c src/hwsat.c src/irots.c src/jack.c src/mt19937ar.c src/mylocal.c src/novelty+p.c src/novelty.c src/parameters.c src/paws.c src/random.c src/reports.c src/rgsat.c src/rnovelty.c src/rots.c src/samd.c src/saps.c src/sparrow.c src/ubcsat-help.c src/ubcsat-internal.c src/ubcsat-io.c src/ubcsat-mem.c src/ubcsat-reports.c src/ubcsat-time.c src/ubcsat-triggers.c src/ubcsat-version.c src/ubcsat.c src/vw.c src/walksat-tabu.c src/walksat.c src/weighted.c -lm-cd ..--PKG=toysat_ls-maxsat`date +%Y`-`date +%Y%m%d`-`git rev-parse --short HEAD`-rm -r $PKG-mkdir $PKG-cp dist/build/toysat/toysat $PKG/toysat_main-cp COPYING misc/maxsat/toysat_ls/README.md misc/maxsat/toysat_ls/toysat_ls $PKG/-cp ubcsat-beta-12-b18/ubcsat $PKG/-tar Jcf $PKG.tar.xz $PKG --owner=sakai --group=sakai
− misc/build_bdist_pb_evaluation.sh
@@ -1,26 +0,0 @@-#!/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=toysat-pb`date +%Y`-`date +%Y%m%d`-`git rev-parse --short HEAD`-rm -r $PKG-mkdir $PKG-cp dist/build/toysat/toysat $PKG/-cp COPYING misc/pb/README.md $PKG/-tar Jcf $PKG.tar.xz $PKG --owner=sakai --group=sakai
− misc/build_bdist_qbf_evaluation.sh
@@ -1,27 +0,0 @@-#!/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=toyqbf-qbfeval`date +%Y`-`date +%Y%m%d`-`git rev-parse --short HEAD`-rm -r $PKG-mkdir $PKG-cp dist/build/toyqbf/toyqbf $PKG/-cp misc/qbf/README.md $PKG/-cp COPYING $PKG/-tar Jcf $PKG.tar.xz $PKG --owner=sakai --group=sakai
− misc/build_bdist_smtcomp.sh
@@ -1,26 +0,0 @@-#!/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/build_bdist_win32.sh
@@ -1,31 +0,0 @@-#!/bin/bash--STACK_YAML=stack.yaml-RESOLVER=lts-9.2-ARCH=win32--if [ ! -f stack-windows-i386.zip ]; then- curl -ostack-windows-i386.zip -L --insecure http://www.stackage.org/stack/windows-i386-fi-unzip stack-windows-i386.zip stack.exe--#sudo apt-get update-#sudo apt-get install wine--wine stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER --install-ghc build \- --flag toysolver:BuildToyFMF \- --flag toysolver:BuildSamplePrograms--VER=`wine stack exec ghc -- -ignore-dot-ghci -e ":m + Control.Monad Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Parse Distribution.Verbosity Data.Version System.IO" -e "hSetBinaryMode stdout True" -e 'putStrLn =<< liftM (showVersion . pkgVersion . package . packageDescription) (readPackageDescription silent "toysolver.cabal")'`-STACK_LOCAL_INSTALL_ROOT=`wine stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER path --local-install-root`--PKG=toysolver-${VER}-$ARCH--rm -r $PKG-mkdir $PKG-mkdir $PKG/bin-cp $STACK_LOCAL_INSTALL_ROOT/bin/{toyconvert,toyfmf,toyqbf,toysat,toysmt,toysolver}.exe $PKG/bin/-cp $STACK_LOCAL_INSTALL_ROOT/bin/{assign,htc,knapsack,nonogram,nqueens,numberlink,shortest-path,sudoku}.exe $PKG/bin/-cp -a samples $PKG/-cp COPYING-GPL README.md CHANGELOG.markdown $PKG/-zip -r $PKG.zip $PKG
− misc/build_bdist_win64.sh
@@ -1,31 +0,0 @@-#!/bin/bash--STACK_YAML=stack.yaml-RESOLVER=lts-9.2-ARCH=win64--if [ ! -f stack-windows-x86_64.zip ]; then- curl -ostack-windows-x86_64.zip -L --insecure http://www.stackage.org/stack/windows-x86_64-fi-unzip stack-windows-x86_64.zip stack.exe--#sudo apt-get update-#sudo apt-get install wine--wine stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER --install-ghc build \- --flag toysolver:BuildToyFMF \- --flag toysolver:BuildSamplePrograms--VER=`wine stack exec ghc -- -ignore-dot-ghci -e ":m + Control.Monad Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Parse Distribution.Verbosity Data.Version System.IO" -e "hSetBinaryMode stdout True" -e 'putStrLn =<< liftM (showVersion . pkgVersion . package . packageDescription) (readPackageDescription silent "toysolver.cabal")'`-STACK_LOCAL_INSTALL_ROOT=`wine stack --stack-yaml=$STACK_YAML --resolver=$RESOLVER path --local-install-root`--PKG=toysolver-${VER}-$ARCH--rm -r $PKG-mkdir $PKG-mkdir $PKG/bin-cp $STACK_LOCAL_INSTALL_ROOT/bin/{toyconvert,toyfmf,toyqbf,toysat,toysmt,toysolver}.exe $PKG/bin/-cp $STACK_LOCAL_INSTALL_ROOT/bin/{assign,htc,knapsack,nonogram,nqueens,numberlink,shortest-path,sudoku}.exe $PKG/bin/-cp -a samples $PKG/-cp COPYING-GPL README.md CHANGELOG.markdown $PKG/-zip -r $PKG.zip $PKG
− misc/maxsat/toysat/README.md
@@ -1,26 +0,0 @@-toysat-======--Usage-------- ./toysat [file.cnf|file.wcnf]--Algorithm------------We have implemented BCD2 algorithm [1] on top on our own CDCL SAT solver-'toysat' with watch-literal based cardinality constraint handler and-counter-based linear pseudo boolean constraint handler. One of the major-difference from the original BCD2 is that our implementation uses incremental-solving features of SAT solver to keep the information such as learnt clauses-in the successive invocations of SAT solver.--References-------------* [1] A. Morgado, F. Heras, and J. Marques-Silva,- Improvements to Core-Guided binary search for MaxSAT,- in Theory and Applications of Satisfiability Testing (SAT 2012),- pp. 284-297.- <https://doi.org/10.1007/978-3-642-31612-8_22>
− misc/maxsat/toysat/toysat
@@ -1,5 +0,0 @@-#!/bin/sh-tempdir=/tmp/toysat-$$-$1-./toysat_main +RTS -H1G -K1G -RTS --search=bcd2 --temp-dir=$tempdir --maxsat $@-rm -r $tempdir-
− misc/maxsat/toysat_ls/README.md
@@ -1,34 +0,0 @@-toysat_ls-=========--Usage-------- ./toysat_ls [file.cnf|file.wcnf]--Algorithm------------We have implemented BCD2 algorithm [1] on top on our own CDCL SAT solver-'toysat' with watch-literal based cardinality constraint handler and-counter-based linear pseudo boolean constraint handler. One of the major-difference from the original BCD2 is that our implementation uses incremental-solving features of SAT solver to keep the information such as learnt clauses-in the successive invocations of SAT solver.--In addition to that, toysat_ls uses UBCSAT (ubcsat-beta-12-b18.tar.gz) [2] to-find compute initial solution quickly.--References-------------* [1] A. Morgado, F. Heras, and J. Marques-Silva,- Improvements to Core-Guided binary search for MaxSAT,- in Theory and Applications of Satisfiability Testing (SAT 2012),- pp. 284-297.- <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.- <https://doi.org/10.1007/11527695_24>
− misc/maxsat/toysat_ls/toysat_ls
@@ -1,4 +0,0 @@-#!/bin/sh-tempdir=/tmp/toysat_ls-$$-$1-./toysat_main +RTS -H1G -K1G -RTS --maxsat --search=bcd2 --temp-dir=$tempdir --with-ubcsat=./ubcsat --ls-initial $@-rm -r $tempdir
− misc/pb/README.md
@@ -1,61 +0,0 @@-Toysat submission for the Pseudo-Boolean Competition 2016-=========================================================--Usage-------- toysat +RTS -H1G -MMEMLIMITm -K1G -RTS --pb --search=bcd2 BENCHNAME-- toysat +RTS -H1G -MMEMLIMITm -K1G -RTS --wbo --search=bcd2 BENCHNAME--Categories of benchmarks---------------------------* PB- * DEC-BIGINT-LIN (no optimisation, big integers, linear constraints) - * DEC-BIGINT-NLC (no optimisation, big integers, non linear constraints) - * DEC-SMALLINT-LIN (no optimisation, small integers, linear constraints) - * DEC-SMALLINT-NLC (no optimisation, small integers, non linear constraints) - * DEC-SMALLINT-NLC (no optimisation, small integers, non linear constraints) - * OPT-BIGINT-LIN (optimisation, big integers, linear constraints) - * OPT-BIGINT-NLC (optimisation, big integers, non linear constraints) - * OPT-SMALLINT-LIN (optimisation, small integers, linear constraints) - * OPT-SMALLINT-NLC (optimisation, small integers, non linear constraints) -* WBO- * PARTIAL-BIGINT-LIN (both soft and hard constraints, big integers, linear constraints) - * PARTIAL-BIGINT-NLC (both soft and hard constraints, big integers, non linear constraints) - * PARTIAL-SMALLINT-LIN (both soft and hard constraints, small integers, linear constraints) - * PARTIAL-SMALLINT-NLC (both soft and hard constraints, small integers, non linear constraints) - * SOFT-BIGINT-LIN (only soft constraints, big integers, linear constraints) - * SOFT-BIGINT-NLC (only soft constraints, big integers, non linear constraints) - * SOFT-SMALLINT-LIN (only soft constraints, small integers, linear constraints) - * SOFT-SMALLINT-NLC (only soft constraints, small integers, non linear constraints) --Algorithm------------We have implemented BCD2 algorithm [1] on top on our own CDCL SAT solver-'toysat' [2] with watch-literal based cardinality constraint handler and-counter-based linear pseudo boolean constraint handler. One of the major-difference from the original BCD2 is that our implementation uses incremental-solving features of SAT solver to keep the information such as learnt clauses-in the successive invocations of SAT solver.--Non-linear constraints and objective functions are handled by linearization-using a variant of Tseitin transformation that take the polarity into account-[3].--References-------------* [1] A. Morgado, F. Heras, and J. Marques-Silva,- Improvements to Core-Guided binary search for MaxSAT,- in Theory and Applications of Satisfiability Testing (SAT 2012),- pp. 284-297.- <https://doi.org/10.1007/978-3-642-31612-8_22>--* [2] Masahiro Sakai. <https://github.com/msakai/toysolver>--* [3] N. Eén and N. Sörensson,- Translating pseudo-boolean constraints into SAT, Journal on Satisfiability,- Boolean Modeling and Computation, vol. 2, pp. 1-26, 2006.
− misc/qbf/README.md
@@ -1,34 +0,0 @@-Toyqbf submission for the QBFEVAL'16-====================================--Usage-------- ./toyqbf +RTS -H1G -K1G -RTS file.cnf- ./toyqbf +RTS -H1G -K1G -RTS file.qdimacs--Algorithm------------We have implemented Counterexample Guided Refinement algorithm for QBF [1] on-top on our own CDCL SAT solver 'toysat'.--Source Code--------------The source code is available from <https://github.com/msakai/toysolver>.--License----------This program is licenced under the BSD-style license.-(See the file 'COPYING'.)--References-------------* [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.- <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
@@ -1,2 +0,0 @@-#!/bin/sh-./toysmt "$1"
− misc/smtcomp/starexec_description.txt
@@ -1,1 +0,0 @@-A toylevel SMT solver for QFUFLRA and its sublogics
samples/programs/survey-propagation/survey-propagation.hs view
@@ -11,34 +11,21 @@ import qualified ToySolver.FileFormat as FF import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Solver.MessagePassing.SurveyPropagation as SP-#ifdef ENABLE_OPENCL-import Control.Parallel.OpenCL-import qualified ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL as SPCL-#endif data Options = Options- { optOpenCL :: Bool- , optOpenCLPlatform :: Maybe String- , optOpenCLDevice :: Int- , optNThreads :: Int+ { optNThreads :: Int } instance Default Options where def = Options- { optOpenCL = False- , optOpenCLPlatform = Nothing- , optOpenCLDevice = 0- , optNThreads = 1+ { optNThreads = 1 } options :: [OptDescr (Options -> Options)] options =- [ Option [] ["opencl"] (NoArg (\opt -> opt{ optOpenCL = True })) "use OpenCL version"- , Option [] ["opencl-platform"] (ReqArg (\val opt -> opt{ optOpenCLPlatform = Just val }) "<string>") "OpenCL platform to use"- , Option [] ["opencl-device"] (ReqArg (\val opt -> opt{ optOpenCLDevice = read val }) "<integer>") "OpenCL device to use"- , Option [] ["threads"] (ReqArg (\val opt -> opt{ optNThreads = read val }) "<integer>") "number of threads"+ [ Option [] ["threads"] (ReqArg (\val opt -> opt{ optNThreads = read val }) "<integer>") "number of threads" ] showHelp :: Handle -> IO ()@@ -52,40 +39,6 @@ , "Options:" ] -#ifdef ENABLE_OPENCL--getPlatform :: Maybe String -> IO CLPlatformID-getPlatform m = do- putStrLn "Listing OpenCL platforms..."- platforms <- clGetPlatformIDs- case platforms of- [] -> error "No OpenCL platform found"- _ -> do- tbl <- forM platforms $ \platform -> do- s <- clGetPlatformInfo platform CL_PLATFORM_NAME- devs <- clGetDeviceIDs platform CL_DEVICE_TYPE_ALL- putStrLn $ " " ++ s ++ " (" ++ show (length devs) ++ " devices)"- forM_ (zip [0..] devs) $ \(i,dev) -> do- devname <- clGetDeviceName dev- ts <- clGetDeviceType dev- let f t =- case t of- CL_DEVICE_TYPE_CPU -> "CPU"- CL_DEVICE_TYPE_GPU -> "GPU"- CL_DEVICE_TYPE_ACCELERATOR -> "ACCELERATOR"- CL_DEVICE_TYPE_DEFAULT -> "DEFAULT"- CL_DEVICE_TYPE_ALL -> "ALL"- putStrLn $ " " ++ show i ++ ": " ++ devname ++ " (" ++ intercalate "," (map f ts) ++ ")"- return (s,platform)- case m of- Nothing -> return (snd (head tbl))- Just name ->- case lookup name tbl of- Nothing -> error ("no such platform: " ++ name)- Just p -> return p--#endif- main :: IO () main = do args <- getArgs@@ -98,40 +51,15 @@ let opt = foldl (flip id) def o handle (\(e::SomeException) -> hPrint stderr e) $ do wcnf <- FF.readFile fname--#ifdef ENABLE_OPENCL- if optOpenCL opt then do- platform <- getPlatform (optOpenCLPlatform opt)- devs <- clGetDeviceIDs platform CL_DEVICE_TYPE_ALL- dev <-- if optOpenCLDevice opt < length devs then- return (devs !! optOpenCLDevice opt)- else do- name <- clGetPlatformInfo platform CL_PLATFORM_NAME- error ("platform " ++ name ++ " has only " ++ show (length devs) ++ " devices")- context <- clCreateContext [] [dev] print- solver <- SPCL.newSolver putStrLn context dev- (CNF.wcnfNumVars wcnf) [(fromIntegral w, clause) | (w,clause) <- CNF.wcnfClauses wcnf]- -- Rand.withSystemRandom $ SPCL.initializeRandom solver- print =<< SPCL.propagate solver- forM_ [1 .. CNF.wcnfNumVars wcnf] $ \v -> do- prob <- SPCL.getVarProb solver v- print (v,prob)- SPCL.deleteSolver solver-#else- if False then do- return ()-#endif- else do- solver <- SP.newSolver- (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 .. CNF.wcnfNumVars wcnf] $ \v -> do- prob <- SP.getVarProb solver v- print (v,prob)- SP.deleteSolver solver+ solver <- SP.newSolver+ (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 .. CNF.wcnfNumVars wcnf] $ \v -> do+ prob <- SP.getVarProb solver v+ print (v,prob)+ SP.deleteSolver solver _ -> do showHelp stderr
samples/programs/svm2lp/svm2lp.hs view
@@ -10,6 +10,7 @@ import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Scientific+import Data.String import qualified Data.Text.Lazy.IO as TLIO import System.Console.GetOpt import System.Environment@@ -49,20 +50,19 @@ .>=. 1 - (if isJust c then MIP.varExpr xi_i else 0) | ((y_i, xs_i), xi_i) <- zip prob xi ]- , MIP.varType = Map.fromList [(x, MIP.ContinuousVariable) | x <- b : [w_j | w_j <- IntMap.elems w] ++ [xi_i | isJust c, xi_i <- xi]]- , MIP.varBounds =+ , MIP.varDomains = Map.unions- [ Map.singleton b (MIP.NegInf, MIP.PosInf)- , Map.fromList [(w_j, (MIP.NegInf, MIP.PosInf)) | w_j <- IntMap.elems w]- , Map.fromList [(xi_i, (0, MIP.PosInf)) | isJust c, xi_i <- xi]+ [ Map.singleton b (MIP.ContinuousVariable, (MIP.NegInf, MIP.PosInf))+ , Map.fromList [(w_j, (MIP.ContinuousVariable, (MIP.NegInf, MIP.PosInf))) | w_j <- IntMap.elems w]+ , Map.fromList [(xi_i, (MIP.ContinuousVariable, (0, MIP.PosInf))) | isJust c, xi_i <- xi] ] } where m = length prob n = fst $ IntMap.findMax $ IntMap.unions (map snd prob)- w = IntMap.fromList [(j, MIP.toVar ("w_" ++ show j)) | j <- [1..n]]- b = MIP.toVar "b"- xi = [MIP.toVar ("xi_" ++ show i) | i <- [1..m]]+ w = IntMap.fromList [(j, fromString ("w_" ++ show j)) | j <- [1..n]]+ b = fromString "b"+ xi = [fromString ("xi_" ++ show i) | i <- [1..m]] dual :: Maybe Double@@ -82,12 +82,11 @@ } , MIP.constraints = [ MIP.Expr [ MIP.Term (fromIntegral y_i) [a_i] | ((y_i, _xs_i), a_i) <- zip prob a ] .==. 0 ]- , MIP.varType = Map.fromList [(a_i, MIP.ContinuousVariable) | a_i <- a]- , MIP.varBounds = Map.fromList [(a_i, (0, if isJust c then MIP.Finite (realToFrac (fromJust c)) else MIP.PosInf)) | a_i <- a]+ , MIP.varDomains = Map.fromList [(a_i, (MIP.ContinuousVariable, (0, if isJust c then MIP.Finite (realToFrac (fromJust c)) else MIP.PosInf))) | a_i <- a] } where m = length prob- a = [MIP.toVar ("a_" ++ show i) | i <- [1..m]]+ a = [fromString ("a_" ++ show i) | i <- [1..m]] dot :: Num a => IntMap a -> IntMap a -> a dot a b = sum $ IntMap.elems $ IntMap.intersectionWith (*) a b
src/ToySolver/Arith/CAD.hs view
@@ -50,6 +50,7 @@ ) where import Control.Exception+import Control.Monad import Control.Monad.State import Data.List import Data.Maybe
src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs view
@@ -35,6 +35,7 @@ ) where import Control.Exception+import Control.Monad import Control.Monad.State import Data.Default.Class import Data.Ord
src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs view
@@ -44,6 +44,7 @@ import Data.Default.Class import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+import Data.Kind (Type) import Data.Set (Set) import qualified Data.Set as Set import qualified ToySolver.Combinatorial.HittingSet.Simple as HTC@@ -150,7 +151,7 @@ UninterestingSet ys -> liftM UninterestingSet $ shrink prob ys InterestingSet ys -> liftM InterestingSet $ grow prob ys -data SimpleProblem (m :: * -> *) = SimpleProblem IntSet (IntSet -> Bool)+data SimpleProblem (m :: Type -> Type) = SimpleProblem IntSet (IntSet -> Bool) instance Monad m => IsProblem (SimpleProblem m) m where universe (SimpleProblem univ _) = univ
src/ToySolver/Combinatorial/Knapsack/BB.hs view
@@ -20,6 +20,7 @@ , solve ) where +import Control.Monad import Control.Monad.State.Strict import Data.Function (on) import Data.IntSet (IntSet)
src/ToySolver/Converter.hs view
@@ -13,12 +13,9 @@ 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.MIP , module ToySolver.Converter.QBF2IPC , module ToySolver.Converter.QUBO , module ToySolver.Converter.SAT2KSAT@@ -30,12 +27,9 @@ 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.MIP import ToySolver.Converter.QBF2IPC import ToySolver.Converter.QUBO import ToySolver.Converter.SAT2KSAT
src/ToySolver/Converter/Base.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -----------------------------------------------------------------------------@@ -26,6 +27,9 @@ , ReversedTransformer (..) ) where +import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:))+import ToySolver.Internal.JSON (withTypedObject) class (Eq a, Show a) => Transformer a where type Source a@@ -78,8 +82,21 @@ => ObjValueBackwardTransformer (ComposedTransformer a b) where transformObjValueBackward (ComposedTransformer a b) = transformObjValueBackward a . transformObjValueBackward b +instance (J.ToJSON a, J.ToJSON b) => J.ToJSON (ComposedTransformer a b) where+ toJSON (ComposedTransformer a b) =+ J.object+ [ "type" .= J.String "ComposedTransformer"+ , "first" .= a+ , "second" .= b+ ] +instance (J.FromJSON a, J.FromJSON b) => J.FromJSON (ComposedTransformer a b) where+ parseJSON = withTypedObject "ComposedTransformer" $ \obj -> do+ ComposedTransformer+ <$> obj .: "first"+ <*> obj .: "second" + data IdentityTransformer a = IdentityTransformer deriving (Eq, Show, Read) @@ -93,8 +110,17 @@ instance BackwardTransformer (IdentityTransformer a) where transformBackward IdentityTransformer = id +instance J.ToJSON (IdentityTransformer a) where+ toJSON IdentityTransformer =+ J.object+ [ "type" .= J.String "IdentityTransformer"+ ] -data ReversedTransformer t = ReversedTransformer t+instance J.FromJSON (IdentityTransformer a) where+ parseJSON = withTypedObject "IdentityTransformer" $ \_ -> pure IdentityTransformer+++newtype ReversedTransformer t = ReversedTransformer t deriving (Eq, Show, Read) instance Transformer t => Transformer (ReversedTransformer t) where@@ -116,3 +142,14 @@ instance ObjValueForwardTransformer t => ObjValueBackwardTransformer (ReversedTransformer t) where transformObjValueBackward (ReversedTransformer t) = transformObjValueForward t++instance J.ToJSON t => J.ToJSON (ReversedTransformer t) where+ toJSON (ReversedTransformer t) =+ J.object+ [ "type" .= ("ReversedTransformer" :: J.Value)+ , "base" .= t+ ]++instance J.FromJSON t => J.FromJSON (ReversedTransformer t) where+ parseJSON = withTypedObject "ReversedTransformer" $ \v ->+ ReversedTransformer <$> v .: "base"
src/ToySolver/Converter/GCNF2MaxSAT.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -17,12 +18,15 @@ , GCNF2MaxSATInfo (..) ) where +import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import qualified Data.Vector.Generic as VG import ToySolver.Converter.Base import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Internal.JSON import qualified ToySolver.SAT.Types as SAT -data GCNF2MaxSATInfo = GCNF2MaxSATInfo !Int+newtype GCNF2MaxSATInfo = GCNF2MaxSATInfo Int deriving (Eq, Show, Read) instance Transformer GCNF2MaxSATInfo where@@ -31,6 +35,17 @@ instance BackwardTransformer GCNF2MaxSATInfo where transformBackward (GCNF2MaxSATInfo nv1) = SAT.restrictModel nv1++instance J.ToJSON GCNF2MaxSATInfo where+ toJSON (GCNF2MaxSATInfo nv) =+ J.object+ [ "type" .= ("GCNF2MaxSATInfo" :: J.Value)+ , "num_original_variables" .= nv+ ]++instance J.FromJSON GCNF2MaxSATInfo where+ parseJSON = withTypedObject "GCNF2MaxSATInfo" $ \obj ->+ GCNF2MaxSATInfo <$> obj .: "num_original_variables" gcnf2maxsat :: CNF.GCNF -> (CNF.WCNF, GCNF2MaxSATInfo) gcnf2maxsat
+ src/ToySolver/Converter/MIP.hs view
@@ -0,0 +1,521 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : ToySolver.Converter.MIP+-- Copyright : (c) Masahiro Sakai 2011-2016+-- License : BSD-style+--+-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module ToySolver.Converter.MIP+ (+ -- * PB/WBO to IP+ pb2ip+ , PB2IPInfo+ , wbo2ip+ , WBO2IPInfo++ -- * SAT/Max-SAT to IP+ , sat2ip+ , SAT2IPInfo+ , maxsat2ip+ , MaxSAT2IPInfo++ -- * IP to PB+ , ip2pb+ , IP2PBInfo (..)+ , addMIP+ ) where++import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad.Trans+import Control.Monad.Trans.Except+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+#endif+import Data.Aeson ((.=), (.:))+import Data.Array.IArray+import Data.Default.Class+import qualified Data.IntSet as IntSet+import Data.List (intercalate, foldl', sortBy)+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Ord+import Data.Primitive.MutVar+import Data.Ratio+import qualified Data.Set as Set+import Data.String+import qualified Data.Text as T+import Data.VectorSpace++import qualified Data.PseudoBoolean as PBFile+import qualified Numeric.Optimization.MIP as MIP++import ToySolver.Converter.Base+import ToySolver.Converter.PB+import ToySolver.Data.OrdRel+import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Internal.JSON+import ToySolver.SAT.Internal.JSON+import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Integer as Integer+import ToySolver.SAT.Store.PB+import ToySolver.Internal.Util (revForM)++-- -----------------------------------------------------------------------------++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++instance ObjValueTransformer PB2IPInfo where+ type SourceObjValue PB2IPInfo = Integer+ type TargetObjValue PB2IPInfo = Rational++instance ObjValueForwardTransformer PB2IPInfo where+ transformObjValueForward _ = fromIntegral++instance ObjValueBackwardTransformer PB2IPInfo where+ transformObjValueBackward _ = round++instance J.ToJSON PB2IPInfo where+ toJSON (PB2IPInfo nv) =+ J.object+ [ "type" .= ("PB2IPInfo" :: J.Value)+ , "num_original_variables" .= nv+ ]++instance J.FromJSON PB2IPInfo where+ parseJSON =+ withTypedObject "PB2IPInfo" $ \obj ->+ PB2IPInfo <$> obj .: "num_original_variables"++pb2ip :: PBFile.Formula -> (MIP.Problem Integer, PB2IPInfo)+pb2ip formula = (mip, PB2IPInfo (PBFile.pbNumVars formula))+ where+ mip = def+ { MIP.objectiveFunction = obj2+ , MIP.constraints = cs2+ , MIP.varDomains = Map.fromList [(v, (MIP.IntegerVariable, (0,1))) | v <- vs]+ }++ vs = [convVar v | v <- [1..PBFile.pbNumVars formula]]++ obj2 =+ case PBFile.pbObjectiveFunction formula of+ Just obj' -> def{ MIP.objDir = MIP.OptMin, MIP.objExpr = convExpr obj' }+ Nothing -> def{ MIP.objDir = MIP.OptMin, MIP.objExpr = 0 }++ cs2 = do+ (lhs,op,rhs) <- PBFile.pbConstraints formula+ let (lhs2,c) = splitConst $ convExpr lhs+ rhs2 = rhs - c+ return $ case op of+ 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 }+++convExpr :: PBFile.Sum -> MIP.Expr Integer+convExpr s = sum [product (fromIntegral w : map f tm) | (w,tm) <- s]+ where+ f :: PBFile.Lit -> MIP.Expr Integer+ f x+ | x > 0 = MIP.varExpr (convVar x)+ | otherwise = 1 - MIP.varExpr (convVar (abs x))++convVar :: PBFile.Var -> MIP.Var+convVar x = fromString ("x" ++ show x)++-- -----------------------------------------------------------------------------++data WBO2IPInfo = WBO2IPInfo !Int [(MIP.Var, PBFile.Constraint)]+ 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, c) <- relaxVariables]++instance BackwardTransformer WBO2IPInfo where+ transformBackward (WBO2IPInfo nv _relaxVariables) = mtrans nv++instance ObjValueTransformer WBO2IPInfo where+ type SourceObjValue WBO2IPInfo = Integer+ type TargetObjValue WBO2IPInfo = Rational++instance ObjValueForwardTransformer WBO2IPInfo where+ transformObjValueForward _ = fromIntegral++instance ObjValueBackwardTransformer WBO2IPInfo where+ transformObjValueBackward _ = round++instance J.ToJSON WBO2IPInfo where+ toJSON (WBO2IPInfo nv relaxVariables) =+ J.object+ [ "type" .= ("WBO2IPInfo" :: J.Value)+ , "num_original_variables" .= nv+ , "relax_variables" .= J.object+ [ toKey (MIP.varName v) .= jPBConstraint constr+ | (v, constr) <- relaxVariables+ ]+ ]+ where+#if MIN_VERSION_aeson(2,0,0)+ toKey = Key.fromText+#else+ toKey = id+#endif++instance J.FromJSON WBO2IPInfo where+ parseJSON =+ withTypedObject "WBO2IPInfo" $ \obj -> do+ xs <- obj .: "relax_variables"+ WBO2IPInfo+ <$> obj .: "num_original_variables"+ <*> mapM f (Map.toList xs)+ where+ f :: (T.Text, J.Value) -> J.Parser (MIP.Var, PBFile.Constraint)+ f (name, val) = do+ constr <- parsePBConstraint val+ pure (MIP.Var name, constr)++wbo2ip :: Bool -> PBFile.SoftFormula -> (MIP.Problem Integer, WBO2IPInfo)+wbo2ip useIndicator formula = (mip, WBO2IPInfo (PBFile.wboNumVars formula) [(r, c) | (r, (Just _, c)) <- relaxVariables])+ where+ mip = def+ { MIP.objectiveFunction = obj2+ , MIP.constraints = topConstr ++ map snd cs2+ , MIP.varDomains = Map.fromList [(v, (MIP.IntegerVariable, (0,1))) | v <- vs]+ }++ vs = [convVar v | v <- [1..PBFile.wboNumVars formula]] ++ [v | (ts, _) <- cs2, (_, v) <- ts]++ obj2 = def+ { MIP.objDir = MIP.OptMin+ , MIP.objExpr = MIP.Expr [MIP.Term w [v] | (ts, _) <- cs2, (w, v) <- ts]+ }++ topConstr :: [MIP.Constraint Integer]+ topConstr =+ case PBFile.wboTopCost formula of+ Nothing -> []+ Just t ->+ [ def{ MIP.constrExpr = MIP.objExpr obj2, MIP.constrUB = MIP.Finite (fromInteger t - 1) } ]++ relaxVariables :: [(MIP.Var, PBFile.SoftConstraint)]+ relaxVariables = [(fromString ("r" ++ show n), c) | (n, c) <- zip [(0::Int)..] (PBFile.wboConstraints formula)]++ cs2 :: [([(Integer, MIP.Var)], MIP.Constraint Integer)]+ cs2 = do+ (v, (w, (lhs,op,rhs))) <- relaxVariables+ let (lhs2,c) = splitConst $ convExpr lhs+ rhs2 = rhs - c+ (ts,ind) =+ case w of+ Nothing -> ([], Nothing)+ Just w2 -> ([(w2,v)], Just (v,0))+ if isNothing w || useIndicator then do+ let c =+ case op of+ PBFile.Ge -> (lhs2 MIP..>=. MIP.constExpr rhs2) { MIP.constrIndicator = ind }+ PBFile.Eq -> (lhs2 MIP..==. MIP.constExpr rhs2) { MIP.constrIndicator = ind }+ return (ts, c)+ else do+ let (lhsGE,rhsGE) = relaxGE v (lhs2,rhs2)+ c1 = lhsGE MIP..>=. MIP.constExpr rhsGE+ case op of+ PBFile.Ge -> do+ return (ts, c1)+ PBFile.Eq -> do+ let (lhsLE,rhsLE) = relaxLE v (lhs2,rhs2)+ c2 = lhsLE MIP..<=. MIP.constExpr rhsLE+ [ (ts, c1), ([], c2) ]++splitConst :: MIP.Expr Integer -> (MIP.Expr Integer, Integer)+splitConst e = (e2, c)+ where+ e2 = MIP.Expr [t | t@(MIP.Term _ (_:_)) <- MIP.terms e]+ c = sum [c | MIP.Term c [] <- MIP.terms e]++relaxGE :: MIP.Var -> (MIP.Expr Integer, Integer) -> (MIP.Expr Integer, Integer)+relaxGE v (lhs, rhs) = (MIP.constExpr (rhs - lhs_lb) * MIP.varExpr v + lhs, rhs)+ where+ lhs_lb = sum [min c 0 | MIP.Term c _ <- MIP.terms lhs]++relaxLE :: MIP.Var -> (MIP.Expr Integer, Integer) -> (MIP.Expr Integer, Integer)+relaxLE v (lhs, rhs) = (MIP.constExpr (rhs - lhs_ub) * MIP.varExpr v + lhs, rhs)+ where+ lhs_ub = sum [max c 0 | MIP.Term c _ <- MIP.terms lhs]++mtrans :: Int -> Map MIP.Var Rational -> SAT.Model+mtrans nvar m =+ array (1, nvar)+ [ (i, val)+ | i <- [1 .. nvar]+ , let val =+ case Map.findWithDefault 0 (convVar i) m of+ 0 -> False+ 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++-- -----------------------------------------------------------------------------++ip2pb :: MIP.Problem Rational -> Either String (PBFile.Formula, IP2PBInfo)+ip2pb mip = runST $ runExceptT $ m+ where+ m :: ExceptT String (ST s) (PBFile.Formula, IP2PBInfo)+ m = do+ db <- lift $ newPBStore+ (Integer.Expr obj, info) <- addMIP' db mip+ formula <- lift $ getPBFormula db+ return $ (formula{ PBFile.pbObjectiveFunction = Just obj }, info)++data IP2PBInfo = IP2PBInfo (Map MIP.Var Integer.Expr) (Map MIP.Var SAT.Lit) !Integer+ deriving (Eq, Show)++instance Transformer IP2PBInfo where+ type Source IP2PBInfo = Map MIP.Var Rational+ type Target IP2PBInfo = SAT.Model++instance ForwardTransformer IP2PBInfo where+ transformForward (IP2PBInfo vmap nonZeroTable _d) sol+ | Map.keysSet vmap /= Map.keysSet sol = error "variables mismatch"+ | otherwise = array (1, x_max) $+ [(x, val) | (var, Integer.Expr s) <- Map.toList vmap, (x, val) <- f s (sol Map.! var)] +++ [(y, (sol Map.! var) /= 0) | (var, y) <- Map.toList nonZeroTable]+ where+ x_max :: SAT.Var+ x_max = IntSet.findMax xs+ where+ xs = IntSet.unions $+ [IntSet.fromList (map SAT.litVar lits) | Integer.Expr s <- Map.elems vmap, (_, lits) <- s] +++ [IntSet.fromList (map SAT.litVar (Map.elems nonZeroTable))] +++ [IntSet.singleton 0]++ f :: SAT.PBSum -> Rational -> [(SAT.Var, Bool)]+ f s val+ | denominator val /= 1 = error "value should be integer"+ | otherwise = g (numerator val - sum [c | (c, []) <- s]) (Map.toDescList tmp)+ where+ tmp :: Map Integer SAT.Var+ tmp =+ Map.fromList+ [ if c < 0 then+ error "coefficient should be non-negative"+ else if length ls > 1 then+ error "variable definition should be linear"+ else+ (c, head ls)+ | (c, ls) <- s, not (null ls), c /= 0+ ]++ g :: Integer -> [(Integer, SAT.Var)] -> [(SAT.Var, Bool)]+ g 0 [] = []+ g _ [] = error "no more variables"+ g v ((c,l) : ys)+ | v >= c = (l, True) : g (v - c) ys+ | otherwise = (l, False) : g v ys++instance BackwardTransformer IP2PBInfo where+ transformBackward (IP2PBInfo vmap _nonZeroTable _d) m = fmap (toRational . Integer.eval m) vmap++instance ObjValueTransformer IP2PBInfo where+ type SourceObjValue IP2PBInfo = Rational+ type TargetObjValue IP2PBInfo = Integer++instance ObjValueForwardTransformer IP2PBInfo where+ transformObjValueForward (IP2PBInfo _vmap _nonZeroTable d) val = asInteger (val * fromIntegral d)++instance ObjValueBackwardTransformer IP2PBInfo where+ transformObjValueBackward (IP2PBInfo _vmap _nonZeroTable d) val = fromIntegral val / fromIntegral d++instance J.ToJSON IP2PBInfo where+ toJSON (IP2PBInfo vmap nonZeroTable d) =+ J.object+ [ "type" .= ("IP2PBInfo" :: J.Value)+ , "substitutions" .= J.object+ [ toKey (MIP.varName v) .= jPBSum s+ | (v, Integer.Expr s) <- Map.toList vmap+ ]+ , "nonzero_indicators" .= J.object+ [ toKey (MIP.varName v) .= (jLitName lit :: J.Value)+ | (v, lit) <- Map.toList nonZeroTable+ ]+ , "objective_function_scale_factor" .= d+ ]+ where+#if MIN_VERSION_aeson(2,0,0)+ toKey = Key.fromText+#else+ toKey = id+#endif++instance J.FromJSON IP2PBInfo where+ parseJSON = withTypedObject "IP2PBInfo" $ \obj -> do+ tmp1 <- obj .: "substitutions"+ subst <- liftM Map.fromList $ forM (Map.toList tmp1) $ \(name, expr) -> do+ s <- parsePBSum expr+ return (MIP.Var name, Integer.Expr s)+ tmp2 <- obj .: "nonzero_indicators"+ nonZeroTable <- liftM Map.fromList $ forM (Map.toList tmp2) $ \(name, s) -> do+ lit <- parseLitName s+ return (MIP.Var name, lit)+ d <- obj .: "objective_function_scale_factor"+ pure $ IP2PBInfo subst nonZeroTable d++addMIP :: (SAT.AddPBNL m enc, PrimMonad m) => enc -> MIP.Problem Rational -> m (Either String (Integer.Expr, IP2PBInfo))+addMIP enc mip = runExceptT $ addMIP' enc mip++addMIP' :: forall m enc. (SAT.AddPBNL m enc, PrimMonad m) => enc -> MIP.Problem Rational -> ExceptT String m (Integer.Expr, IP2PBInfo)+addMIP' enc mip = do+ if not (Set.null nivs) then do+ throwE $ "cannot handle non-integer variables: " ++ intercalate ", " (map (T.unpack . MIP.varName) (Set.toList nivs))+ else do+ vmap <- liftM Map.fromList $ revForM (Set.toList ivs) $ \v -> do+ case MIP.getBounds mip v of+ (MIP.Finite lb, MIP.Finite ub) -> do+ v2 <- lift $ Integer.newVar enc (ceiling lb) (floor ub)+ return (v,v2)+ _ -> do+ throwE $ "cannot handle unbounded variable: " ++ T.unpack (MIP.varName v)+ forM_ (MIP.constraints mip) $ \c -> do+ let lhs = MIP.constrExpr c+ let f op rhs = do+ let d = foldl' lcm 1 (map denominator (rhs:[r | MIP.Term r _ <- MIP.terms lhs]))+ lhs' = sumV [asInteger (r * fromIntegral d) *^ product [vmap Map.! v | v <- vs] | MIP.Term r vs <- MIP.terms lhs]+ rhs' = asInteger (rhs * fromIntegral d)+ c2 = case op of+ MIP.Le -> lhs' .<=. fromInteger rhs'+ MIP.Ge -> lhs' .>=. fromInteger rhs'+ MIP.Eql -> lhs' .==. fromInteger rhs'+ case MIP.constrIndicator c of+ Nothing -> lift $ Integer.addConstraint enc c2+ Just (var, val) -> do+ let var' = asBin (vmap Map.! var)+ case val of+ 1 -> lift $ Integer.addConstraintSoft enc var' c2+ 0 -> lift $ Integer.addConstraintSoft enc (SAT.litNot var') c2+ _ -> return ()+ g = do+ case MIP.constrIndicator c of+ Nothing -> lift $ SAT.addClause enc []+ Just (var, val) -> do+ let var' = asBin (vmap Map.! var)+ case val of+ 1 -> lift $ SAT.addClause enc [- var']+ 0 -> lift $ SAT.addClause enc [var']+ _ -> return ()+ case (MIP.constrLB c, MIP.constrUB c) of+ (MIP.Finite x1, MIP.Finite x2) | x1==x2 -> f MIP.Eql x2+ (lb, ub) -> do+ case lb of+ MIP.NegInf -> return ()+ MIP.Finite x -> f MIP.Ge x+ MIP.PosInf -> g+ case ub of+ MIP.NegInf -> g+ MIP.Finite x -> f MIP.Le x+ MIP.PosInf -> return ()++ nonZeroTableRef <- lift $ newMutVar Map.empty+ let isNonZero :: MIP.Var -> ExceptT String m SAT.Lit+ isNonZero v = do+ tbl <- lift $ readMutVar nonZeroTableRef+ case Map.lookup v tbl of+ Just lit -> pure lit+ Nothing -> do+ let (MIP.Finite lb, MIP.Finite ub) = MIP.getBounds mip v+ e@(Integer.Expr s) = vmap Map.! v+ lit <-+ if lb == 0 && ub == 1 then do+ return (asBin e)+ else do+ v <- lift $ SAT.newVar enc+ -- F(v) → F(s ≠ 0)+ -- ⇐ s≠0 → v+ -- ⇔ ¬v → s=0+ lift $ SAT.addPBNLExactlySoft enc (- v) s 0+ return v+ lift $ writeMutVar nonZeroTableRef (Map.insert v lit tbl)+ pure lit++ forM_ (MIP.sosConstraints mip) $ \MIP.SOSConstraint{ MIP.sosType = typ, MIP.sosBody = xs } -> do+ case typ of+ MIP.S1 -> do+ ys <- mapM (isNonZero . fst) xs+ lift $ SAT.addAtMost enc ys 1+ MIP.S2 -> do+ ys <- mapM (isNonZero . fst) $ sortBy (comparing snd) xs+ lift $ SAT.addSOS2 enc ys++ let obj = MIP.objectiveFunction mip+ d = foldl' lcm 1 [denominator r | MIP.Term r _ <- MIP.terms (MIP.objExpr obj)] *+ (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)]++ nonZeroTable <- readMutVar nonZeroTableRef++ return (obj2, IP2PBInfo vmap nonZeroTable d)++ where+ ivs = MIP.integerVariables mip+ nivs = MIP.variables mip `Set.difference` ivs++ 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/MIP2PB.hs
@@ -1,157 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.MIP2PB--- Copyright : (c) Masahiro Sakai 2016--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module ToySolver.Converter.MIP2PB- ( mip2pb- , MIP2PBInfo (..)- , addMIP- ) where--import Control.Monad-import Control.Monad.ST-import Control.Monad.Trans-import Control.Monad.Trans.Except-import Data.List (intercalate, foldl', sortBy)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Ord-import Data.Ratio-import qualified Data.Set as Set-import Data.VectorSpace--import qualified Data.PseudoBoolean as PBFile-import qualified Numeric.Optimization.MIP as MIP--import ToySolver.Converter.Base-import ToySolver.Data.OrdRel-import qualified ToySolver.SAT.Types as SAT-import qualified ToySolver.SAT.Encoder.Integer as Integer-import ToySolver.SAT.Store.PB-import ToySolver.Internal.Util (revForM)---- -------------------------------------------------------------------------------mip2pb :: MIP.Problem Rational -> Either String (PBFile.Formula, MIP2PBInfo)-mip2pb mip = runST $ runExceptT $ m- where- m :: ExceptT String (ST s) (PBFile.Formula, MIP2PBInfo)- m = do- db <- lift $ newPBStore- (Integer.Expr obj, info) <- addMIP' db mip- formula <- lift $ getPBFormula db- 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, MIP2PBInfo))-addMIP enc mip = runExceptT $ addMIP' enc mip--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))- else do- vmap <- liftM Map.fromList $ revForM (Set.toList ivs) $ \v -> do- case MIP.getBounds mip v of- (MIP.Finite lb, MIP.Finite ub) -> do- v2 <- lift $ Integer.newVar enc (ceiling lb) (floor ub)- return (v,v2)- _ -> do- throwE $ "cannot handle unbounded variable: " ++ MIP.fromVar v- forM_ (MIP.constraints mip) $ \c -> do- let lhs = MIP.constrExpr c- let f op rhs = do- let d = foldl' lcm 1 (map denominator (rhs:[r | MIP.Term r _ <- MIP.terms lhs]))- lhs' = sumV [asInteger (r * fromIntegral d) *^ product [vmap Map.! v | v <- vs] | MIP.Term r vs <- MIP.terms lhs]- rhs' = asInteger (rhs * fromIntegral d)- c2 = case op of- MIP.Le -> lhs' .<=. fromInteger rhs'- MIP.Ge -> lhs' .>=. fromInteger rhs'- MIP.Eql -> lhs' .==. fromInteger rhs'- case MIP.constrIndicator c of- Nothing -> lift $ Integer.addConstraint enc c2- Just (var, val) -> do- let var' = asBin (vmap Map.! var)- case val of- 1 -> lift $ Integer.addConstraintSoft enc var' c2- 0 -> lift $ Integer.addConstraintSoft enc (SAT.litNot var') c2- _ -> return ()- case (MIP.constrLB c, MIP.constrUB c) of- (MIP.Finite x1, MIP.Finite x2) | x1==x2 -> f MIP.Eql x2- (lb, ub) -> do- case lb of- MIP.NegInf -> return ()- MIP.Finite x -> f MIP.Ge x- MIP.PosInf -> lift $ SAT.addClause enc []- case ub of- MIP.NegInf -> lift $ SAT.addClause enc []- MIP.Finite x -> f MIP.Le x- MIP.PosInf -> return ()-- forM_ (MIP.sosConstraints mip) $ \MIP.SOSConstraint{ MIP.sosType = typ, MIP.sosBody = xs } -> do- case typ of- MIP.S1 -> lift $ SAT.addAtMost enc (map (asBin . (vmap Map.!) . fst) xs) 1- MIP.S2 -> do- let ps = nonAdjacentPairs $ map fst $ sortBy (comparing snd) $ xs- forM_ ps $ \(x1,x2) -> do- lift $ SAT.addClause enc [SAT.litNot $ asBin $ vmap Map.! v | v <- [x1,x2]]-- let obj = MIP.objectiveFunction mip- d = foldl' lcm 1 [denominator r | MIP.Term r _ <- MIP.terms (MIP.objExpr obj)] *- (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)]-- return (obj2, MIP2PBInfo vmap d)-- where- ivs = MIP.integerVariables mip- nivs = MIP.variables mip `Set.difference` ivs-- nonAdjacentPairs :: [a] -> [(a,a)]- nonAdjacentPairs (x1:x2:xs) = [(x1,x3) | x3 <- xs] ++ nonAdjacentPairs (x2:xs)- nonAdjacentPairs _ = []-- 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
@@ -21,7 +21,6 @@ import Data.Char import Data.Default.Class-import Data.Interned import Data.Ord import Data.List import Data.Ratio@@ -335,10 +334,10 @@ YICES _ -> "int" ts = [(v, realType) | v <- Set.toList real_vs] ++ [(v, intType) | v <- Set.toList int_vs] obj = MIP.objectiveFunction mip- env = Map.fromList [(v, encode opt (unintern v)) | v <- Set.toList vs]+ env = Map.fromList [(v, encode opt (MIP.varName v)) | v <- Set.toList vs] -- Note that identifiers of LPFile does not contain '-'. -- So that there are no name crash.- env2 = Map.fromList [(v, encode opt (unintern v <> "-2")) | v <- Set.toList vs]+ env2 = Map.fromList [(v, encode opt (MIP.varName v <> "-2")) | v <- Set.toList vs] options = [ case optLanguage opt of@@ -358,7 +357,7 @@ return $ case optLanguage opt of SMTLIB2 -> "(declare-fun " <> B.fromText v2 <> " () " <> B.fromString t <> ")"- YICES _ -> "(define " <> B.fromText v2 <> "::" <> B.fromString t <> ") ; " <> B.fromString (MIP.fromVar v)+ YICES _ -> "(define " <> B.fromText v2 <> "::" <> B.fromString t <> ") ; " <> B.fromText (MIP.varName v) optimality = list ["forall", decl, body] where
src/ToySolver/Converter/NAESAT.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -41,13 +42,18 @@ , nae3sat2max2sat ) where +import Control.Monad import Control.Monad.State.Strict+import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) 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 ToySolver.Internal.JSON import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.SAT.Internal.JSON import qualified ToySolver.SAT.Types as SAT type NAESAT = (Int, [NAEClause])@@ -67,7 +73,7 @@ newtype SAT2NAESATInfo = SAT2NAESATInfo SAT.Var deriving (Eq, Show, Read) --- | Convert a CNF formula φ to an equisatifiable NAE-SAT formula ψ,+-- | Convert a CNF formula φ to an equisatisfiable NAE-SAT formula ψ, -- together with a 'SAT2NAESATInfo' sat2naesat :: CNF.CNF -> (NAESAT, SAT2NAESATInfo) sat2naesat cnf = (ret, SAT2NAESATInfo z)@@ -90,10 +96,22 @@ SAT.restrictModel (z - 1) $ if SAT.evalVar m z then amap not m else m +instance J.ToJSON SAT2NAESATInfo where+ toJSON (SAT2NAESATInfo z) =+ J.object+ [ "type" .= ("SAT2NAESATInfo" :: J.Value)+ , "special_variable" .= (jVarName z :: J.Value)+ ]++instance J.FromJSON SAT2NAESATInfo where+ parseJSON = withTypedObject "SAT2NAESATInfo" $ \obj -> do+ z <- parseVarName =<< (obj .: "special_variable")+ pure $ SAT2NAESATInfo z+ -- | Information of 'naesat2sat' conversion type NAESAT2SATInfo = IdentityTransformer SAT.Model --- | Convert a NAE-SAT formula φ to an equisatifiable CNF formula ψ,+-- | Convert a NAE-SAT formula φ to an equisatisfiable CNF formula ψ, -- together with a 'NAESAT2SATInfo' naesat2sat :: NAESAT -> (CNF.CNF, NAESAT2SATInfo) naesat2sat (n,cs) =@@ -107,7 +125,7 @@ -- ------------------------------------------------------------------------ --- Information of 'naesat2naeksta' conversion+-- Information of 'naesat2naeksat' conversion data NAESAT2NAEKSATInfo = NAESAT2NAEKSATInfo !Int !Int [(SAT.Var, NAEClause, NAEClause)] deriving (Eq, Show, Read) @@ -152,6 +170,34 @@ instance BackwardTransformer NAESAT2NAEKSATInfo where transformBackward (NAESAT2NAEKSATInfo n1 _n2 _table) = SAT.restrictModel n1++instance J.ToJSON NAESAT2NAEKSATInfo where+ toJSON (NAESAT2NAEKSATInfo nv1 nv2 table) =+ J.object+ [ "type" .= J.String "NAESAT2NAEKSATInfo"+ , "num_original_variables" .= nv1+ , "num_transformed_variables" .= nv2+ , "table" .=+ [ ( jVarName v :: J.Value+ , map (jLitName . SAT.unpackLit) (VG.toList cs1) :: [J.Value]+ , map (jLitName . SAT.unpackLit) (VG.toList cs2) :: [J.Value]+ )+ | (v, cs1, cs2) <- table+ ]+ ]++instance J.FromJSON NAESAT2NAEKSATInfo where+ parseJSON = withTypedObject "NAESAT2NAEKSATInfo" $ \obj -> do+ NAESAT2NAEKSATInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "num_transformed_variables"+ <*> (mapM f =<< obj .: "table")+ where+ f (v, cs1, cs2) = do+ v' <- parseVarNameText v+ cs1' <- mapM parseLitNameText cs1+ cs2' <- mapM parseLitNameText cs2+ return (v', VG.fromList (map SAT.packLit cs1'), VG.fromList (map SAT.packLit cs2')) -- ------------------------------------------------------------------------
− src/ToySolver/Converter/ObjType.hs
@@ -1,18 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.ObjType--- Copyright : (c) Masahiro Sakai 2011-2012--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : portable----------------------------------------------------------------------------------module ToySolver.Converter.ObjType- ( ObjType (..)- ) where--data ObjType = ObjNone | ObjMaxOne | ObjMaxZero- deriving (Eq, Ord, Enum, Bounded, Show)
src/ToySolver/Converter/PB.hs view
@@ -1,11 +1,12 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.PB--- Copyright : (c) Masahiro Sakai 2013,2016-2018+-- Copyright : (c) Masahiro Sakai 2011-2014,2016-2018 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com@@ -21,6 +22,10 @@ , normalizePB , normalizeWBO + -- * Modify objective function+ , ObjType (..)+ , setObj+ -- * Linealization of PB/WBO problems , linearizePB , linearizeWBO@@ -33,15 +38,15 @@ -- * Converting inequality constraints into equality constraints , inequalitiesToEqualitiesPB- , PBInequalitiesToEqualitiesInfo+ , PBInequalitiesToEqualitiesInfo (..) -- * Converting constraints into penalty terms in objective function , unconstrainPB- , PBUnconstrainInfo+ , PBUnconstrainInfo (..) -- * PB↔WBO conversion , pb2wbo- , PB2WBOInfo+ , PB2WBOInfo (..) , wbo2pb , WBO2PBInfo (..) , addWBO@@ -50,24 +55,39 @@ , sat2pb , SAT2PBInfo , pb2sat+ , pb2satWith , PB2SATInfo -- * MaxSAT↔WBO conversion , maxsat2wbo , MaxSAT2WBOInfo , wbo2maxsat+ , wbo2maxsatWith , WBO2MaxSATInfo -- * PB→QUBO conversion , pb2qubo' , PB2QUBOInfo'++ -- * General data types+ , PBIdentityInfo (..)+ , PBTseitinInfo (..)++ -- * misc+ , pb2lsp+ , wbo2lsp+ , pb2smp ) where import Control.Monad import Control.Monad.Primitive import Control.Monad.ST+import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import Data.Array.IArray import Data.Bits hiding (And (..))+import Data.ByteString.Builder+import Data.Default.Class import qualified Data.Foldable as F import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap@@ -87,11 +107,13 @@ import qualified ToySolver.Converter.PB.Internal.Product as Product import ToySolver.Converter.Tseitin import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.Internal.JSON import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin import ToySolver.SAT.Encoder.Tseitin (Formula (..)) import qualified ToySolver.SAT.Encoder.PB as PB import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC+import ToySolver.SAT.Internal.JSON import ToySolver.SAT.Store.CNF import ToySolver.SAT.Store.PB @@ -129,8 +151,94 @@ -- ----------------------------------------------------------------------------- -type PBLinearizeInfo = TseitinInfo+data ObjType = ObjNone | ObjMaxOne | ObjMaxZero+ deriving (Eq, Ord, Enum, Bounded, Show) +setObj :: ObjType -> PBFile.Formula -> PBFile.Formula+setObj objType formula = formula{ PBFile.pbObjectiveFunction = Just obj2 }+ where+ obj2 = genObj objType formula++genObj :: ObjType -> PBFile.Formula -> PBFile.Sum+genObj objType formula =+ case objType of+ ObjNone -> []+ ObjMaxOne -> [(1,[-v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize false literals+ ObjMaxZero -> [(1,[ v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize true literals++-- -----------------------------------------------------------------------------++data PBIdentityInfo = PBIdentityInfo+ deriving (Show, Eq)++instance Transformer PBIdentityInfo where+ type Source PBIdentityInfo = SAT.Model+ type Target PBIdentityInfo = SAT.Model++instance ForwardTransformer PBIdentityInfo where+ transformForward _ = id++instance BackwardTransformer PBIdentityInfo where+ transformBackward _ = id++instance ObjValueTransformer PBIdentityInfo where+ type SourceObjValue PBIdentityInfo = Integer+ type TargetObjValue PBIdentityInfo = Integer++instance ObjValueForwardTransformer PBIdentityInfo where+ transformObjValueForward _ = id++instance ObjValueBackwardTransformer PBIdentityInfo where+ transformObjValueBackward _ = id++instance J.ToJSON PBIdentityInfo where+ toJSON PBIdentityInfo =+ J.object+ [ "type" .= ("PBIdentityInfo" :: J.Value)+ ]++instance J.FromJSON PBIdentityInfo where+ parseJSON = withTypedObject "PBIdentityInfo" $ \_ -> pure PBIdentityInfo+++newtype PBTseitinInfo = PBTseitinInfo TseitinInfo+ deriving (Eq, Show)++instance Transformer PBTseitinInfo where+ type Source PBTseitinInfo = SAT.Model+ type Target PBTseitinInfo = SAT.Model++instance ForwardTransformer PBTseitinInfo where+ transformForward (PBTseitinInfo info) = transformForward info++instance BackwardTransformer PBTseitinInfo where+ transformBackward (PBTseitinInfo info) = transformBackward info++instance ObjValueTransformer PBTseitinInfo where+ type SourceObjValue PBTseitinInfo = Integer+ type TargetObjValue PBTseitinInfo = Integer++instance ObjValueForwardTransformer PBTseitinInfo where+ transformObjValueForward _ = id++instance ObjValueBackwardTransformer PBTseitinInfo where+ transformObjValueBackward _ = id++instance J.ToJSON PBTseitinInfo where+ toJSON (PBTseitinInfo info) =+ J.object+ [ "type" .= ("PBTseitinInfo" :: J.Value)+ , "base" .= info+ ]++instance J.FromJSON PBTseitinInfo where+ parseJSON = withTypedObject "PBTseitinInfo" $ \obj ->+ PBTseitinInfo <$> obj .: "base"++-- -----------------------------------------------------------------------------++type PBLinearizeInfo = PBTseitinInfo+ linearizePB :: PBFile.Formula -> Bool -> (PBFile.Formula, PBLinearizeInfo) linearizePB formula usePB = runST $ do db <- newPBStore@@ -158,7 +266,7 @@ , PBFile.pbConstraints = cs' ++ PBFile.pbConstraints formula' , PBFile.pbNumConstraints = PBFile.pbNumConstraints formula + PBFile.pbNumConstraints formula' }- , TseitinInfo (PBFile.pbNumVars formula) (PBFile.pbNumVars formula') defs+ , PBTseitinInfo $ TseitinInfo (PBFile.pbNumVars formula) (PBFile.pbNumVars formula') defs ) -- -----------------------------------------------------------------------------@@ -185,11 +293,13 @@ , PBFile.wboNumVars = PBFile.pbNumVars formula' , PBFile.wboNumConstraints = PBFile.wboNumConstraints formula + PBFile.pbNumConstraints formula' }- , TseitinInfo (PBFile.wboNumVars formula) (PBFile.pbNumVars formula') defs+ , PBTseitinInfo $ TseitinInfo (PBFile.wboNumVars formula) (PBFile.pbNumVars formula') defs ) -- ----------------------------------------------------------------------------- +type PBQuadratizeInfo = PBTseitinInfo+ -- | Quandratize PBO/PBS problem without introducing additional constraints. quadratizePB :: PBFile.Formula -> ((PBFile.Formula, Integer), PBQuadratizeInfo) quadratizePB formula = quadratizePB' (formula, SAT.pbUpperBound obj)@@ -207,7 +317,7 @@ } , maxObj )- , PBQuadratizeInfo $ TseitinInfo nv1 nv2 [(v, And [Atom l1, Atom l2]) | (v, (l1,l2)) <- prodDefs]+ , PBTseitinInfo $ TseitinInfo nv1 nv2 (IntMap.fromList [(v, And [atom l1, atom l2]) | (v, (l1,l2)) <- prodDefs]) ) where nv1 = PBFile.pbNumVars formula@@ -278,7 +388,12 @@ | IntSet.size t == 1 = head $ IntSet.toList t | otherwise = toV Map.! t + atom :: SAT.Lit -> Formula+ atom l+ | l < 0 = Not (Atom (- l))+ | otherwise = Atom l + collectDegGe3Terms :: PBFile.Formula -> Set IntSet collectDegGe3Terms formula = Set.fromList [t' | t <- terms, let t' = IntSet.fromList t, IntSet.size t' >= 3] where@@ -286,29 +401,6 @@ [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.@@ -385,6 +477,37 @@ instance ObjValueBackwardTransformer PBInequalitiesToEqualitiesInfo where transformObjValueBackward _ = id +instance J.ToJSON PBInequalitiesToEqualitiesInfo where+ toJSON (PBInequalitiesToEqualitiesInfo nv1 nv2 defs) =+ J.object+ [ "type" .= ("PBInequalitiesToEqualitiesInfo" :: J.Value)+ , "num_original_variables" .= nv1+ , "num_transformed_variables" .= nv2+ , "slack" .=+ [ J.object+ [ "lhs" .= jPBSum lhs+ , "rhs" .= rhs+ , "slack" .= [jVarName v :: J.Value | v <- vs]+ ]+ | (lhs, rhs, vs) <- defs+ ]+ ]++instance J.FromJSON PBInequalitiesToEqualitiesInfo where+ parseJSON = withTypedObject "PBInequalitiesToEqualitiesInfo" $ \obj -> do+ PBInequalitiesToEqualitiesInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "num_transformed_variables"+ <*> (mapM f =<< obj .: "slack")+ where+ f = J.withObject "slack" $ \obj -> do+ lhs <- parsePBSum =<< obj .: "lhs"+ rhs <- obj .: "rhs"+ vs <- mapM g =<< obj .: "slack"+ return (lhs, rhs, vs)+ g ('x' : rest) = pure $! read rest+ g s = fail ("fail to parse variable: " ++ show s)+ -- ----------------------------------------------------------------------------- unconstrainPB :: PBFile.Formula -> ((PBFile.Formula, Integer), PBUnconstrainInfo)@@ -419,6 +542,17 @@ instance ObjValueBackwardTransformer PBUnconstrainInfo where transformObjValueBackward (PBUnconstrainInfo info) = transformObjValueBackward info +instance J.ToJSON PBUnconstrainInfo where+ toJSON (PBUnconstrainInfo info) =+ J.object+ [ "type" .= ("PBUnconstrainInfo" :: J.Value)+ , "base" .= info+ ]++instance J.FromJSON PBUnconstrainInfo where+ parseJSON = withTypedObject "PBUnconstrainInfo" $ \obj ->+ PBUnconstrainInfo <$> obj .: "base"+ unconstrainPB' :: PBFile.Formula -> (PBFile.Formula, Integer) unconstrainPB' formula = ( formula@@ -455,8 +589,6 @@ -- ----------------------------------------------------------------------------- -type PB2WBOInfo = IdentityTransformer SAT.Model- pb2wbo :: PBFile.Formula -> (PBFile.SoftFormula, PB2WBOInfo) pb2wbo formula = ( PBFile.SoftFormula@@ -465,19 +597,58 @@ , PBFile.wboNumVars = PBFile.pbNumVars formula , PBFile.wboNumConstraints = PBFile.pbNumConstraints formula + length cs2 }- , IdentityTransformer+ , PB2WBOInfo offset ) 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- ]+ (cs2, offset) =+ case PBFile.pbObjectiveFunction formula of+ Nothing -> ([], 0)+ 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+ ]+ , sum [if w >= 0 then 0 else - w | (w, _) <- e]+ ) +newtype PB2WBOInfo = PB2WBOInfo Integer+ deriving (Eq, Show)++instance Transformer PB2WBOInfo where+ type Source PB2WBOInfo = SAT.Model+ type Target PB2WBOInfo = SAT.Model++instance ForwardTransformer PB2WBOInfo where+ transformForward _ = id++instance BackwardTransformer PB2WBOInfo where+ transformBackward _ = id++instance ObjValueTransformer PB2WBOInfo where+ type SourceObjValue PB2WBOInfo = Integer+ type TargetObjValue PB2WBOInfo = Integer++instance ObjValueForwardTransformer PB2WBOInfo where+ transformObjValueForward (PB2WBOInfo offset) obj = obj + offset++instance ObjValueBackwardTransformer PB2WBOInfo where+ transformObjValueBackward (PB2WBOInfo offset) obj = obj - offset++instance J.ToJSON PB2WBOInfo where+ toJSON (PB2WBOInfo offset) =+ J.object+ [ "type" .= J.String "PB2WBOInfo"+ , "objective_function_offset" .= offset+ ]++instance J.FromJSON PB2WBOInfo where+ parseJSON =+ withTypedObject "PB2WBOInfo" $ \obj -> do+ offset <- obj .: "objective_function_offset"+ pure (PB2WBOInfo offset)+ wbo2pb :: PBFile.SoftFormula -> (PBFile.Formula, WBO2PBInfo) wbo2pb wbo = runST $ do let nv = PBFile.wboNumVars wbo@@ -489,8 +660,8 @@ , WBO2PBInfo nv (PBFile.pbNumVars formula) defs ) -data WBO2PBInfo = WBO2PBInfo !Int !Int [(SAT.Var, PBFile.Constraint)]- deriving (Eq, Show)+data WBO2PBInfo = WBO2PBInfo !Int !Int (SAT.VarMap PBFile.Constraint)+ deriving (Show, Eq) instance Transformer WBO2PBInfo where type Source WBO2PBInfo = SAT.Model@@ -498,12 +669,47 @@ instance ForwardTransformer WBO2PBInfo where transformForward (WBO2PBInfo _nv1 nv2 defs) m =- array (1, nv2) $ assocs m ++ [(v, SAT.evalPBConstraint m constr) | (v, constr) <- defs]+ array (1, nv2) $ assocs m ++ [(v, SAT.evalPBConstraint m constr) | (v, constr) <- IntMap.toList 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)])+instance ObjValueTransformer WBO2PBInfo where+ type SourceObjValue WBO2PBInfo = Integer+ type TargetObjValue WBO2PBInfo = Integer++instance ObjValueForwardTransformer WBO2PBInfo where+ transformObjValueForward _ = id++instance ObjValueBackwardTransformer WBO2PBInfo where+ transformObjValueBackward _ = id++instance J.ToJSON WBO2PBInfo where+ toJSON (WBO2PBInfo nv1 nv2 defs) =+ J.object+ [ "type" .= J.String "WBO2PBInfo"+ , "num_original_variables" .= nv1+ , "num_transformed_variables" .= nv2+ , "definitions" .= J.object+ [ jVarName v .= jPBConstraint constr+ | (v, constr) <- IntMap.toList defs+ ]+ ]++instance J.FromJSON WBO2PBInfo where+ parseJSON = withTypedObject "WBO2PBInfo" $ \obj -> do+ defs <- obj .: "definitions"+ WBO2PBInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "num_transformed_variables"+ <*> (IntMap.fromList <$> mapM f (Map.toList defs))+ where+ f (name, constr) = do+ v <- parseVarNameText name+ constr' <- parsePBConstraint constr+ return (v, constr')++addWBO :: (PrimMonad m, SAT.AddPBNL m enc) => enc -> PBFile.SoftFormula -> m (SAT.PBSum, (SAT.VarMap PBFile.Constraint)) addWBO db wbo = do SAT.newVars_ db $ PBFile.wboNumVars wbo @@ -574,7 +780,7 @@ modifyMutVar objRef ((offset,[trueLit]) :) obj <- liftM reverse $ readMutVar objRef- defs <- liftM reverse $ readMutVar defsRef+ defs <- liftM IntMap.fromList $ readMutVar defsRef case PBFile.wboTopCost wbo of Nothing -> return ()@@ -625,12 +831,15 @@ -- * if M ⊨ ψ then g(M) ⊨ φ -- pb2sat :: PBFile.Formula -> (CNF.CNF, PB2SATInfo)-pb2sat formula = runST $ do+pb2sat = pb2satWith def++pb2satWith :: PB.Strategy -> PBFile.Formula -> (CNF.CNF, PB2SATInfo)+pb2satWith strategy formula = runST $ do db <- newCNFStore let nv1 = PBFile.pbNumVars formula SAT.newVars_ db nv1 tseitin <- Tseitin.newEncoder db- pb <- PB.newEncoder tseitin+ pb <- PB.newEncoderWithStrategy tseitin strategy pbnlc <- PBNLC.newEncoder pb tseitin forM_ (PBFile.pbConstraints formula) $ \(lhs,op,rhs) -> do case op of@@ -642,7 +851,7 @@ -- ----------------------------------------------------------------------------- -type MaxSAT2WBOInfo = IdentityTransformer SAT.Model+type MaxSAT2WBOInfo = PBIdentityInfo maxsat2wbo :: CNF.WCNF -> (PBFile.SoftFormula, MaxSAT2WBOInfo) maxsat2wbo@@ -658,7 +867,7 @@ , PBFile.wboNumVars = nv , PBFile.wboNumConstraints = nc }- , IdentityTransformer+ , PBIdentityInfo ) where f (w,c)@@ -667,14 +876,17 @@ where p = ([(1,[l]) | l <- SAT.unpackClause c], PBFile.Ge, 1) -type WBO2MaxSATInfo = TseitinInfo+type WBO2MaxSATInfo = PBTseitinInfo wbo2maxsat :: PBFile.SoftFormula -> (CNF.WCNF, WBO2MaxSATInfo)-wbo2maxsat formula = runST $ do+wbo2maxsat = wbo2maxsatWith def++wbo2maxsatWith :: PB.Strategy -> PBFile.SoftFormula -> (CNF.WCNF, WBO2MaxSATInfo)+wbo2maxsatWith strategy formula = runST $ do db <- newCNFStore SAT.newVars_ db (PBFile.wboNumVars formula) tseitin <- Tseitin.newEncoder db- pb <- PB.newEncoder tseitin+ pb <- PB.newEncoderWithStrategy tseitin strategy pbnlc <- PBNLC.newEncoder pb tseitin softClauses <- liftM mconcat $ forM (PBFile.wboConstraints formula) $ \(cost, (lhs,op,rhs)) -> do@@ -714,6 +926,158 @@ , CNF.wcnfClauses = F.toList cs } defs <- Tseitin.getDefinitions tseitin- return (wcnf, TseitinInfo (PBFile.wboNumVars formula) (CNF.cnfNumVars cnf) defs)+ return (wcnf, PBTseitinInfo (TseitinInfo (PBFile.wboNumVars formula) (CNF.cnfNumVars cnf) defs))++-- -----------------------------------------------------------------------------++pb2lsp :: PBFile.Formula -> Builder+pb2lsp formula =+ byteString "function model() {\n" <>+ decls <>+ constrs <>+ obj2 <>+ "}\n"+ where+ nv = PBFile.pbNumVars formula++ decls = byteString " for [i in 1.." <> intDec nv <> byteString "] x[i] <- bool();\n"++ constrs = mconcat+ [ byteString " constraint " <>+ showConstrLSP c <>+ ";\n"+ | c <- PBFile.pbConstraints formula+ ]++ obj2 =+ case PBFile.pbObjectiveFunction formula of+ Just obj' -> byteString " minimize " <> showSumLSP obj' <> ";\n"+ Nothing -> mempty++wbo2lsp :: PBFile.SoftFormula -> Builder+wbo2lsp softFormula =+ byteString "function model() {\n" <>+ decls <>+ constrs <>+ costDef <>+ topConstr <>+ byteString " minimize cost;\n}\n"+ where+ nv = PBFile.wboNumVars softFormula++ decls = byteString " for [i in 1.." <> intDec nv <> byteString "] x[i] <- bool();\n"++ constrs = mconcat+ [ byteString " constraint " <>+ showConstrLSP c <>+ ";\n"+ | (Nothing, c) <- PBFile.wboConstraints softFormula+ ]++ costDef = byteString " cost <- sum(\n" <> s <> ");\n"+ where+ s = mconcat . intersperse (",\n") $ xs+ xs = [" " <> integerDec w <> "*!(" <> showConstrLSP c <> ")"+ | (Just w, c) <- PBFile.wboConstraints softFormula]++ topConstr =+ case PBFile.wboTopCost softFormula of+ Nothing -> mempty+ Just t -> byteString " constraint cost <= " <> integerDec t <> ";\n"++showConstrLSP :: PBFile.Constraint -> Builder+showConstrLSP (lhs, PBFile.Ge, 1) | and [c==1 | (c,_) <- lhs] =+ "or(" <> mconcat (intersperse "," (map (f . snd) lhs)) <> ")"+ where+ f [l] = showLitLSP l+ f ls = "and(" <> mconcat (intersperse "," (map showLitLSP ls)) <> ")"+showConstrLSP (lhs, op, rhs) = showSumLSP lhs <> op2 <> integerDec rhs+ where+ op2 = case op of+ PBFile.Ge -> " >= "+ PBFile.Eq -> " == "++sum' :: [Builder] -> Builder+sum' xs = "sum(" <> mconcat (intersperse ", " xs) <> ")"++showSumLSP :: PBFile.Sum -> Builder+showSumLSP = sum' . map showTermLSP++showTermLSP :: PBFile.WeightedTerm -> Builder+showTermLSP (n,ls) = mconcat $ intersperse "*" $ [integerDec n | n /= 1] ++ [showLitLSP l | l<-ls]++showLitLSP :: PBFile.Lit -> Builder+showLitLSP l =+ if l < 0+ then "!x[" <> intDec (abs l) <> "]"+ else "x[" <> intDec l <> "]"++-- -----------------------------------------------------------------------------++pb2smp :: Bool -> PBFile.Formula -> Builder+pb2smp isUnix formula =+ header <>+ decls <>+ char7 '\n' <>+ obj2 <>+ char7 '\n' <>+ constrs <>+ char7 '\n' <>+ actions <>+ footer+ where+ nv = PBFile.pbNumVars formula++ header =+ if isUnix+ then byteString "#include \"simple.h\"\nvoid ufun()\n{\n\n"+ else mempty++ footer =+ if isUnix+ then "\n}\n"+ else mempty++ actions = byteString $+ "solve();\n" <>+ "x[i].val.print();\n" <>+ "cost.val.print();\n"++ decls =+ byteString "Element i(set=\"1 .. " <> intDec nv <>+ byteString "\");\nIntegerVariable x(type=binary, index=i);\n"++ constrs = mconcat+ [ showSum lhs <>+ op2 <>+ integerDec rhs <>+ ";\n"+ | (lhs, op, rhs) <- PBFile.pbConstraints formula+ , let op2 = case op of+ PBFile.Ge -> " >= "+ PBFile.Eq -> " == "+ ]++ showSum :: PBFile.Sum -> Builder+ showSum [] = char7 '0'+ showSum xs = mconcat $ intersperse " + " $ map showTerm xs++ showTerm (n,ls) = mconcat $ intersperse (char7 '*') $ showCoeff n ++ [showLit l | l<-ls]++ showCoeff n+ | n == 1 = []+ | n < 0 = [char7 '(' <> integerDec n <> char7 ')']+ | otherwise = [integerDec n]++ showLit l =+ if l < 0+ then "(1-x[" <> intDec (abs l) <> "])"+ else "x[" <> intDec l <> "]"++ obj2 =+ case PBFile.pbObjectiveFunction formula of+ Just obj' ->+ byteString "Objective cost(type=minimize);\ncost = " <> showSum obj' <> ";\n"+ Nothing -> mempty -- -----------------------------------------------------------------------------
− src/ToySolver/Converter/PB2IP.hs
@@ -1,212 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.PB2IP--- Copyright : (c) Masahiro Sakai 2011-2015--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module ToySolver.Converter.PB2IP- ( pb2ip- , PB2IPInfo- , wbo2ip- , WBO2IPInfo-- , sat2ip- , SAT2IPInfo- , maxsat2ip- , MaxSAT2IPInfo- ) where--import Data.Array.IArray-import Data.Default.Class-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map--import qualified Data.PseudoBoolean as PBFile-import qualified Numeric.Optimization.MIP as MIP-import Numeric.Optimization.MIP ((.==.), (.<=.), (.>=.))--import ToySolver.Converter.Base-import ToySolver.Converter.PB-import qualified ToySolver.FileFormat.CNF as CNF-import qualified ToySolver.SAT.Types as SAT---- -------------------------------------------------------------------------------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- , MIP.constraints = cs2- , MIP.varType = Map.fromList [(v, MIP.IntegerVariable) | v <- vs]- , MIP.varBounds = Map.fromList [(v, (0,1)) | v <- vs]- }-- vs = [convVar v | v <- [1..PBFile.pbNumVars formula]]-- obj2 =- case PBFile.pbObjectiveFunction formula of- Just obj' -> def{ MIP.objDir = MIP.OptMin, MIP.objExpr = convExpr obj' }- Nothing -> def{ MIP.objDir = MIP.OptMin, MIP.objExpr = 0 }-- cs2 = do- (lhs,op,rhs) <- PBFile.pbConstraints formula- let (lhs2,c) = splitConst $ convExpr lhs- rhs2 = rhs - c- return $ case op of- 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 }---convExpr :: PBFile.Sum -> MIP.Expr Integer-convExpr s = sum [product (fromIntegral w : map f tm) | (w,tm) <- s]- where- f :: PBFile.Lit -> MIP.Expr Integer- f x- | x > 0 = MIP.varExpr (convVar x)- | otherwise = 1 - MIP.varExpr (convVar (abs x))--convVar :: PBFile.Var -> MIP.Var-convVar x = MIP.toVar ("x" ++ show x)---- -------------------------------------------------------------------------------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- , MIP.constraints = topConstr ++ map snd cs2- , MIP.varType = Map.fromList [(v, MIP.IntegerVariable) | v <- vs]- , MIP.varBounds = Map.fromList [(v, (0,1)) | v <- vs]- }-- vs = [convVar v | v <- [1..PBFile.wboNumVars formula]] ++ [v | (ts, _) <- cs2, (_, v) <- ts]-- obj2 = def- { MIP.objDir = MIP.OptMin- , MIP.objExpr = MIP.Expr [MIP.Term w [v] | (ts, _) <- cs2, (w, v) <- ts]- }-- topConstr :: [MIP.Constraint Integer]- topConstr =- case PBFile.wboTopCost formula of- Nothing -> []- Just t ->- [ def{ MIP.constrExpr = MIP.objExpr obj2, MIP.constrUB = MIP.Finite (fromInteger t - 1) } ]-- relaxVariables :: [(MIP.Var, PBFile.SoftConstraint)]- relaxVariables = [(MIP.toVar ("r" ++ show n), c) | (n, c) <- zip [(0::Int)..] (PBFile.wboConstraints formula)]-- cs2 :: [([(Integer, MIP.Var)], MIP.Constraint Integer)]- cs2 = do- (v, (w, (lhs,op,rhs))) <- relaxVariables- let (lhs2,c) = splitConst $ convExpr lhs- rhs2 = rhs - c- (ts,ind) =- case w of- Nothing -> ([], Nothing)- Just w2 -> ([(w2,v)], Just (v,0))- if isNothing w || useIndicator then do- let c =- case op of- PBFile.Ge -> (lhs2 .>=. MIP.constExpr rhs2) { MIP.constrIndicator = ind }- PBFile.Eq -> (lhs2 .==. MIP.constExpr rhs2) { MIP.constrIndicator = ind }- return (ts, c)- else do- let (lhsGE,rhsGE) = relaxGE v (lhs2,rhs2)- c1 = lhsGE .>=. MIP.constExpr rhsGE- case op of- PBFile.Ge -> do- return (ts, c1)- PBFile.Eq -> do- let (lhsLE,rhsLE) = relaxLE v (lhs2,rhs2)- c2 = lhsLE .<=. MIP.constExpr rhsLE- [ (ts, c1), ([], c2) ]--splitConst :: MIP.Expr Integer -> (MIP.Expr Integer, Integer)-splitConst e = (e2, c)- where- e2 = MIP.Expr [t | t@(MIP.Term _ (_:_)) <- MIP.terms e]- c = sum [c | MIP.Term c [] <- MIP.terms e]--relaxGE :: MIP.Var -> (MIP.Expr Integer, Integer) -> (MIP.Expr Integer, Integer)-relaxGE v (lhs, rhs) = (MIP.constExpr (rhs - lhs_lb) * MIP.varExpr v + lhs, rhs)- where- lhs_lb = sum [min c 0 | MIP.Term c _ <- MIP.terms lhs]--relaxLE :: MIP.Var -> (MIP.Expr Integer, Integer) -> (MIP.Expr Integer, Integer)-relaxLE v (lhs, rhs) = (MIP.constExpr (rhs - lhs_ub) * MIP.varExpr v + lhs, rhs)- where- lhs_ub = sum [max c 0 | MIP.Term c _ <- MIP.terms lhs]--mtrans :: Int -> Map MIP.Var Rational -> SAT.Model-mtrans nvar m =- array (1, nvar)- [ (i, val)- | i <- [1 .. nvar]- , let val =- case Map.findWithDefault 0 (convVar i) m of- 0 -> False- 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
@@ -1,104 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.PB2LSP--- Copyright : (c) Masahiro Sakai 2013-2014,2016--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module ToySolver.Converter.PB2LSP- ( pb2lsp- , wbo2lsp- ) where--import Data.ByteString.Builder-import Data.List-import qualified Data.PseudoBoolean as PBFile--pb2lsp :: PBFile.Formula -> Builder-pb2lsp formula =- byteString "function model() {\n" <>- decls <>- constrs <>- obj2 <>- "}\n"- where- nv = PBFile.pbNumVars formula-- decls = byteString " for [i in 1.." <> intDec nv <> byteString "] x[i] <- bool();\n"-- constrs = mconcat- [ byteString " constraint " <>- showConstr c <>- ";\n"- | c <- PBFile.pbConstraints formula- ]-- obj2 =- case PBFile.pbObjectiveFunction formula of- Just obj' -> byteString " minimize " <> showSum obj' <> ";\n"- Nothing -> mempty--wbo2lsp :: PBFile.SoftFormula -> Builder-wbo2lsp softFormula =- byteString "function model() {\n" <>- decls <>- constrs <>- costDef <>- topConstr <>- byteString " minimize cost;\n}\n"- where- nv = PBFile.wboNumVars softFormula-- decls = byteString " for [i in 1.." <> intDec nv <> byteString "] x[i] <- bool();\n"-- constrs = mconcat- [ byteString " constraint " <>- showConstr c <>- ";\n"- | (Nothing, c) <- PBFile.wboConstraints softFormula- ]-- costDef = byteString " cost <- sum(\n" <> s <> ");\n"- where- s = mconcat . intersperse (",\n") $ xs- xs = [" " <> integerDec w <> "*!(" <> showConstr c <> ")"- | (Just w, c) <- PBFile.wboConstraints softFormula]-- topConstr =- case PBFile.wboTopCost softFormula of- Nothing -> mempty- Just t -> byteString " constraint cost <= " <> integerDec t <> ";\n"--showConstr :: PBFile.Constraint -> Builder-showConstr (lhs, PBFile.Ge, 1) | and [c==1 | (c,_) <- lhs] =- "or(" <> mconcat (intersperse "," (map (f . snd) lhs)) <> ")"- where- f [l] = showLit l- f ls = "and(" <> mconcat (intersperse "," (map showLit ls)) <> ")"-showConstr (lhs, op, rhs) = showSum lhs <> op2 <> integerDec rhs- where- op2 = case op of- PBFile.Ge -> " >= "- PBFile.Eq -> " == "--sum' :: [Builder] -> Builder-sum' xs = "sum(" <> mconcat (intersperse ", " xs) <> ")"--showSum :: PBFile.Sum -> Builder-showSum = sum' . map showTerm--showTerm :: PBFile.WeightedTerm -> Builder-showTerm (n,ls) = mconcat $ intersperse "*" $ [integerDec n | n /= 1] ++ [showLit l | l<-ls]--showLit :: PBFile.Lit -> Builder-showLit l =- if l < 0- then "!x[" <> intDec (abs l) <> "]"- else "x[" <> intDec l <> "]"
− src/ToySolver/Converter/PB2SMP.hs
@@ -1,87 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.PB2SMP--- Copyright : (c) Masahiro Sakai 2013,2016--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module ToySolver.Converter.PB2SMP- ( pb2smp- ) where--import Data.ByteString.Builder-import Data.List-import qualified Data.PseudoBoolean as PBFile--pb2smp :: Bool -> PBFile.Formula -> Builder-pb2smp isUnix formula =- header <>- decls <>- char7 '\n' <>- obj2 <>- char7 '\n' <>- constrs <>- char7 '\n' <>- actions <>- footer- where- nv = PBFile.pbNumVars formula-- header =- if isUnix- then byteString "#include \"simple.h\"\nvoid ufun()\n{\n\n"- else mempty-- footer =- if isUnix- then "\n}\n"- else mempty-- actions = byteString $- "solve();\n" <>- "x[i].val.print();\n" <>- "cost.val.print();\n"-- decls =- byteString "Element i(set=\"1 .. " <> intDec nv <>- byteString "\");\nIntegerVariable x(type=binary, index=i);\n"-- constrs = mconcat- [ showSum lhs <>- op2 <>- integerDec rhs <>- ";\n"- | (lhs, op, rhs) <- PBFile.pbConstraints formula- , let op2 = case op of- PBFile.Ge -> " >= "- PBFile.Eq -> " == "- ]-- showSum :: PBFile.Sum -> Builder- showSum [] = char7 '0'- showSum xs = mconcat $ intersperse " + " $ map showTerm xs-- showTerm (n,ls) = mconcat $ intersperse (char7 '*') $ showCoeff n ++ [showLit l | l<-ls]-- showCoeff n- | n == 1 = []- | n < 0 = [char7 '(' <> integerDec n <> char7 ')']- | otherwise = [integerDec n]-- showLit l =- if l < 0- then "(1-x[" <> intDec (abs l) <> "])"- else "x[" <> intDec l <> "]"-- obj2 =- case PBFile.pbObjectiveFunction formula of- Just obj' ->- byteString "Objective cost(type=minimize);\ncost = " <> showSum obj' <> ";\n"- Nothing -> mempty
− src/ToySolver/Converter/PBSetObj.hs
@@ -1,31 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.Converter.PBSetObj--- Copyright : (c) Masahiro Sakai 2013--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : portable----------------------------------------------------------------------------------module ToySolver.Converter.PBSetObj- ( ObjType (..)- , setObj- ) where--import qualified Data.PseudoBoolean as PBFile-import ToySolver.Converter.ObjType--setObj :: ObjType -> PBFile.Formula -> PBFile.Formula-setObj objType formula = formula{ PBFile.pbObjectiveFunction = Just obj2 }- where- obj2 = genObj objType formula--genObj :: ObjType -> PBFile.Formula -> PBFile.Sum-genObj objType formula =- case objType of- ObjNone -> []- ObjMaxOne -> [(1,[-v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize false literals- ObjMaxZero -> [(1,[ v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize true literals
src/ToySolver/Converter/QUBO.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -----------------------------------------------------------------------------@@ -32,6 +33,8 @@ import Control.Monad import Control.Monad.State+import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import Data.Array.Unboxed import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap@@ -41,6 +44,7 @@ import Data.Ratio import ToySolver.Converter.Base import ToySolver.Converter.PB (pb2qubo', PB2QUBOInfo')+import ToySolver.Internal.JSON (withTypedObject) import qualified ToySolver.QUBO as QUBO import qualified ToySolver.SAT.Types as SAT @@ -92,6 +96,18 @@ instance (Eq a, Show a, Read a, Num a) => ObjValueBackwardTransformer (QUBO2PBInfo a) where transformObjValueBackward (QUBO2PBInfo d) obj = fromInteger $ (obj + d - 1) `div` d +instance J.ToJSON (QUBO2PBInfo a) where+ toJSON (QUBO2PBInfo d) =+ J.object+ [ "type" .= ("QUBO2PBInfo" :: J.Value)+ , "objective_function_scale_factor" .= d+ ]++instance J.FromJSON (QUBO2PBInfo a) where+ parseJSON =+ withTypedObject "QUBO2PBInfo" $ \obj ->+ QUBO2PBInfo <$> obj .: "objective_function_scale_factor"+ -- ----------------------------------------------------------------------------- pbAsQUBO :: forall a. Real a => PBFile.Formula -> Maybe (QUBO.Problem a, PBAsQUBOInfo a)@@ -103,7 +119,7 @@ body = do guard $ null (PBFile.pbConstraints formula) let f :: PBFile.WeightedTerm -> StateT Integer Maybe [(Integer, Int, Int)]- f (c,[]) = modify (+c) >> return []+ f (c,[]) = modify (subtract c) >> return [] f (c,[x]) = return [(c,x,x)] f (c,[x1,x2]) = return [(c,x1,x2)] f _ = mzero@@ -117,7 +133,7 @@ ] } -data PBAsQUBOInfo a = PBAsQUBOInfo !Integer+newtype PBAsQUBOInfo a = PBAsQUBOInfo Integer deriving (Eq, Show, Read) instance Transformer (PBAsQUBOInfo a) where@@ -139,18 +155,31 @@ type TargetObjValue (PBAsQUBOInfo a) = a instance Num a => ObjValueForwardTransformer (PBAsQUBOInfo a) where- transformObjValueForward (PBAsQUBOInfo offset) obj = fromInteger (obj - offset)+ transformObjValueForward (PBAsQUBOInfo offset) obj = fromInteger (obj + offset) instance Real a => ObjValueBackwardTransformer (PBAsQUBOInfo a) where- transformObjValueBackward (PBAsQUBOInfo offset) obj = round (toRational obj) + offset+ transformObjValueBackward (PBAsQUBOInfo offset) obj = round (toRational obj) - offset +instance J.ToJSON (PBAsQUBOInfo a) where+ toJSON (PBAsQUBOInfo offset) =+ J.object+ [ "type" .= ("PBAsQUBOInfo" :: J.Value)+ , "objective_function_offset" .= offset+ ]++instance J.FromJSON (PBAsQUBOInfo a) where+ parseJSON =+ withTypedObject "PBAsQUBOInfo" $ \obj -> do+ offset <- obj .: "objective_function_offset"+ pure (PBAsQUBOInfo offset)+ -- ----------------------------------------------------------------------------- pb2qubo :: Real a => PBFile.Formula -> ((QUBO.Problem a, a), PB2QUBOInfo a)-pb2qubo formula = ((qubo, fromInteger (th - offset)), ComposedTransformer info1 info2)+pb2qubo formula = ((qubo, transformObjValueForward info2 th), ComposedTransformer info1 info2) where ((qubo', th), info1) = pb2qubo' formula- Just (qubo, info2@(PBAsQUBOInfo offset)) = pbAsQUBO qubo'+ Just (qubo, info2) = pbAsQUBO qubo' type PB2QUBOInfo a = ComposedTransformer PB2QUBOInfo' (PBAsQUBOInfo a) @@ -163,7 +192,7 @@ , QUBO.isingInteraction = normalizeMat $ jj' , QUBO.isingExternalMagneticField = normalizeVec h' }- , QUBO2IsingInfo c'+ , QUBO2IsingInfo (- c') ) where {-@@ -202,7 +231,7 @@ , c1+c2 ) -data QUBO2IsingInfo a = QUBO2IsingInfo a+newtype QUBO2IsingInfo a = QUBO2IsingInfo a deriving (Eq, Show, Read) instance (Eq a, Show a) => Transformer (QUBO2IsingInfo a) where@@ -220,11 +249,24 @@ type TargetObjValue (QUBO2IsingInfo a) = a instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (QUBO2IsingInfo a) where- transformObjValueForward (QUBO2IsingInfo offset) obj = obj - offset+ transformObjValueForward (QUBO2IsingInfo offset) obj = obj + offset instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (QUBO2IsingInfo a) where- transformObjValueBackward (QUBO2IsingInfo offset) obj = obj + offset+ transformObjValueBackward (QUBO2IsingInfo offset) obj = obj - offset +instance J.ToJSON a => J.ToJSON (QUBO2IsingInfo a) where+ toJSON (QUBO2IsingInfo offset) =+ J.object+ [ "type" .= J.String "QUBO2IsingInfo"+ , "objective_function_offset" .= offset+ ]++instance J.FromJSON a => J.FromJSON (QUBO2IsingInfo a) where+ parseJSON =+ withTypedObject "QUBO2IsingInfo" $ \obj -> do+ offset <- obj .: "objective_function_offset"+ pure (QUBO2IsingInfo offset)+ -- ----------------------------------------------------------------------------- ising2qubo :: (Eq a, Num a) => QUBO.IsingModel a -> (QUBO.Problem a, Ising2QUBOInfo a)@@ -233,7 +275,7 @@ { QUBO.quboNumVars = n , QUBO.quboMatrix = mkMat m }- , Ising2QUBOInfo offset+ , Ising2QUBOInfo (- offset) ) where {-@@ -261,7 +303,7 @@ sum [jj_ij | row <- IntMap.elems jj, jj_ij <- IntMap.elems row] - sum (IntMap.elems h) -data Ising2QUBOInfo a = Ising2QUBOInfo a+newtype Ising2QUBOInfo a = Ising2QUBOInfo a deriving (Eq, Show, Read) instance (Eq a, Show a) => Transformer (Ising2QUBOInfo a) where@@ -279,10 +321,23 @@ type TargetObjValue (Ising2QUBOInfo a) = a instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (Ising2QUBOInfo a) where- transformObjValueForward (Ising2QUBOInfo offset) obj = obj - offset+ transformObjValueForward (Ising2QUBOInfo offset) obj = obj + offset instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (Ising2QUBOInfo a) where- transformObjValueBackward (Ising2QUBOInfo offset) obj = obj + offset+ transformObjValueBackward (Ising2QUBOInfo offset) obj = obj - offset++instance J.ToJSON a => J.ToJSON (Ising2QUBOInfo a) where+ toJSON (Ising2QUBOInfo offset) =+ J.object+ [ "type" .= J.String "Ising2QUBOInfo"+ , "objective_function_offset" .= offset+ ]++instance J.FromJSON a => J.FromJSON (Ising2QUBOInfo a) where+ parseJSON =+ withTypedObject "Ising2QUBOInfo" $ \obj -> do+ offset <- obj .: "objective_function_offset"+ pure (Ising2QUBOInfo offset) -- -----------------------------------------------------------------------------
src/ToySolver/Converter/SAT2KSAT.hs view
@@ -16,20 +16,20 @@ ----------------------------------------------------------------------------- module ToySolver.Converter.SAT2KSAT ( sat2ksat- , SAT2KSATInfo (..)+ , SAT2KSATInfo ) where import Control.Monad import Control.Monad.ST-import Data.Array.MArray-import Data.Array.ST import Data.Foldable (toList)+import qualified Data.IntMap.Lazy as IntMap import Data.Sequence ((<|), (|>)) import qualified Data.Sequence as Seq import Data.STRef -import ToySolver.Converter.Base+import ToySolver.Converter.Tseitin import qualified ToySolver.FileFormat.CNF as CNF+import ToySolver.SAT.Formula import qualified ToySolver.SAT.Types as SAT import ToySolver.SAT.Store.CNF @@ -39,7 +39,7 @@ sat2ksat k cnf = runST $ do let nv1 = CNF.cnfNumVars cnf db <- newCNFStore- defsRef <- newSTRef Seq.empty+ defsRef <- newSTRef IntMap.empty SAT.newVars_ db nv1 forM_ (CNF.cnfClauses cnf) $ \clause -> do let loop lits = do@@ -50,37 +50,18 @@ case Seq.splitAt (k-1) lits of (lits1, lits2) -> do SAT.addClause db (toList (lits1 |> (-v)))- modifySTRef' defsRef (|> (v, toList lits1))+ modifySTRef' defsRef (IntMap.insert v (toList lits1)) loop (v <| lits2) loop $ Seq.fromList $ SAT.unpackClause clause cnf2 <- getCNFFormula db defs <- readSTRef defsRef- return (cnf2, SAT2KSATInfo nv1 (CNF.cnfNumVars cnf2) defs)+ return (cnf2, TseitinInfo nv1 (CNF.cnfNumVars cnf2) (fmap (\clause -> Or [atom lit | lit <- clause]) defs))+ where+ atom l+ | l < 0 = Not (Atom (- l))+ | otherwise = Atom l -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+type SAT2KSATInfo = TseitinInfo -- -----------------------------------------------------------------------------
src/ToySolver/Converter/SAT2MIS.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-} module ToySolver.Converter.SAT2MIS ( -- * SAT to independent set problem conversion@@ -16,8 +17,11 @@ , IS2SATInfo ) where +import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.ST+import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import Data.Array.IArray import Data.Array.ST import Data.Array.Unboxed@@ -33,6 +37,8 @@ import ToySolver.Converter.SAT2KSAT import qualified ToySolver.FileFormat.CNF as CNF import ToySolver.Graph.Base+import ToySolver.Internal.JSON+import ToySolver.SAT.Internal.JSON import ToySolver.SAT.Store.CNF import ToySolver.SAT.Store.PB import qualified ToySolver.SAT.Types as SAT@@ -111,6 +117,31 @@ where lits = IntSet.map (nodeToLit !) indep_set +instance J.ToJSON SAT3ToISInfo where+ toJSON (SAT3ToISInfo nv clusters nodeToLit) =+ J.object+ [ "type" .= ("SAT3ToISInfo" :: J.Value)+ , "num_original_variables" .= nv+ , "clusters" .= clusters+ , "node_to_literal" .= (J.toJSONList+ [ (node, jLit lit)+ | (node, lit) <- assocs nodeToLit+ ])+ ]++instance J.FromJSON SAT3ToISInfo where+ parseJSON =+ withTypedObject "SAT3ToISInfo" $ \obj -> do+ xs <- obj .: "node_to_literal"+ SAT3ToISInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "clusters"+ <*> (if null xs then pure (array (0, -1) []) else (array ((minimum &&& maximum) (map fst xs)) <$> mapM f xs))+ where+ f (node, val) = do+ lit <- parseLit val+ pure (node, lit)+ -- ------------------------------------------------------------------------ is2pb :: (Graph, Int) -> (PBFile.Formula, IS2SATInfo)@@ -177,6 +208,18 @@ instance ObjValueBackwardTransformer IS2SATInfo where transformObjValueBackward (IS2SATInfo (lb, ub)) k = (ub - lb + 1) - fromIntegral k++instance J.ToJSON IS2SATInfo where+ toJSON (IS2SATInfo (lb, ub)) =+ J.object+ [ "type" .= ("IS2SATInfo" :: J.Value)+ , "node_bounds" .= (lb, ub)+ ]++instance J.FromJSON IS2SATInfo where+ parseJSON =+ withTypedObject "IS2SATInfo" $ \obj ->+ IS2SATInfo <$> obj .: "node_bounds" -- ------------------------------------------------------------------------
src/ToySolver/Converter/SAT2MaxCut.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -32,6 +33,8 @@ , nae3sat2maxcut ) where +import qualified Data.Aeson as J+import Data.Aeson ((.=)) import Data.Array.Unboxed import qualified Data.IntSet as IntSet import qualified Data.Vector.Generic as VG@@ -40,6 +43,7 @@ import qualified ToySolver.FileFormat.CNF as CNF import ToySolver.Graph.Base import qualified ToySolver.Graph.MaxCut as MaxCut+import ToySolver.Internal.JSON (withTypedObject) import qualified ToySolver.SAT.Types as SAT import ToySolver.Converter.Base import ToySolver.Converter.NAESAT (NAESAT)@@ -118,6 +122,15 @@ where (_,n') = bounds sol n = (n'+1) `div` 2++instance J.ToJSON NAE3SAT2MaxCutInfo where+ toJSON _ =+ J.object+ [ "type" .= ("NAE3SAT2MaxCutInfo" :: J.Value)+ ]++instance J.FromJSON NAE3SAT2MaxCutInfo where+ parseJSON = withTypedObject "NAE3SAT2MaxCutInfo" $ \_ -> pure NAE3SAT2MaxCutInfo -- ------------------------------------------------------------------------
src/ToySolver/Converter/SAT2MaxSAT.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -38,12 +39,12 @@ -- * Low-level conversion -- ** 3-SAT to Max-2-SAT conversion- , SAT3ToMaxSAT2Info (..)+ , SAT3ToMaxSAT2Info , sat3ToMaxSAT2 -- ** Max-2-SAT to SimpleMaxSAT2 conversion , SimpleMaxSAT2- , SimplifyMaxSAT2Info (..)+ , SimplifyMaxSAT2Info , simplifyMaxSAT2 -- ** SimpleMaxSAT2 to simple Max-Cut conversion@@ -51,11 +52,9 @@ , simpleMaxSAT2ToSimpleMaxCut ) where -import Control.Monad-import Data.Array.MArray-import Data.Array.ST+import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import Data.Array.Unboxed-import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.List hiding (insert)@@ -65,9 +64,12 @@ import qualified ToySolver.FileFormat.CNF as CNF import ToySolver.Converter.Base import ToySolver.Converter.SAT2KSAT+import ToySolver.Converter.Tseitin import ToySolver.Graph.Base import qualified ToySolver.Graph.MaxCut as MaxCut+import ToySolver.Internal.JSON (withTypedObject) import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Formula as SAT -- ------------------------------------------------------------------------ @@ -92,7 +94,11 @@ } , t )- , SAT3ToMaxSAT2Info (CNF.cnfNumVars cnf) nv (IntMap.fromList ds)+ , TseitinInfo (CNF.cnfNumVars cnf) nv $ IntMap.fromList+ [ (d, SAT.And [atom a, atom b, atom c])+ -- we define d as "a && b && c", but "a + b + c >= 2" is also fine.+ | (d, (a,b,c)) <- ds+ ] ) where f :: (Int, Int, [CNF.WeightedClause], [(SAT.Var,(SAT.Lit,SAT.Lit,SAT.Lit))], Integer)@@ -109,31 +115,13 @@ 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)+ atom :: SAT.Lit -> SAT.Formula+ atom l+ | l < 0 = SAT.Not (SAT.Atom (- l))+ | otherwise = SAT.Atom l -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 SAT3ToMaxSAT2Info = TseitinInfo -- ------------------------------------------------------------------------ @@ -152,7 +140,11 @@ 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)+ (nv2, cs, defs, threshold2) ->+ ( (nv2, cs, threshold2)+ , TseitinInfo nv1 nv2 (fmap (\(a, _b) -> atom (- a)) defs)+ -- we deine v as "~a" but "~b" is also fine.+ ) where nv1 = CNF.wcnfNumVars wcnf f r@(nv, cs, defs, t) (w, clause) =@@ -167,23 +159,15 @@ where v = nv + 1 + atom :: SAT.Lit -> SAT.Formula+ atom l+ | l < 0 = SAT.Not (SAT.Atom (- l))+ | otherwise = SAT.Atom l+ 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+type SimplifyMaxSAT2Info = TseitinInfo -- ------------------------------------------------------------------------ @@ -268,6 +252,21 @@ where (_numNodes, _tt, ff, _t, _f ,xp, _xn, _l) = simpleMaxSAT2ToSimpleMaxCutNodes n p b = not (sol ! ff 0)++instance J.ToJSON SimpleMaxSAT2ToSimpleMaxCutInfo where+ toJSON (SimpleMaxSAT2ToSimpleMaxCutInfo n p) =+ J.object+ [ "type" .= ("SimpleMaxSAT2ToSimpleMaxCutInfo" :: J.Value)+ , "num_original_variables" .= n+ , "num_transformed_nodes" .= p+ ]++instance J.FromJSON SimpleMaxSAT2ToSimpleMaxCutInfo where+ parseJSON =+ withTypedObject "SimpleMaxSAT2ToSimpleMaxCutInfo" $ \obj ->+ SimpleMaxSAT2ToSimpleMaxCutInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "num_transformed_nodes" -- ------------------------------------------------------------------------
src/ToySolver/Converter/Tseitin.hs view
@@ -1,6 +1,6 @@- {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -17,13 +17,22 @@ ( TseitinInfo (..) ) where +import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import Data.Aeson ((.=), (.:)) import Data.Array.IArray+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Lazy as Map+import qualified Data.Text as T import ToySolver.Converter.Base+import ToySolver.Internal.JSON+import qualified ToySolver.SAT.Formula as SAT+import ToySolver.SAT.Internal.JSON 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)+data TseitinInfo = TseitinInfo !Int !Int (SAT.VarMap Tseitin.Formula)+ deriving (Show, Read, Eq) instance Transformer TseitinInfo where type Source TseitinInfo = SAT.Model@@ -35,9 +44,34 @@ -- 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]+ assocs m ++ [(v, Tseitin.evalFormula a phi) | (v, phi) <- IntMap.toList defs] instance BackwardTransformer TseitinInfo where transformBackward (TseitinInfo nv1 _nv2 _defs) = SAT.restrictModel nv1++instance J.ToJSON TseitinInfo where+ toJSON (TseitinInfo nv1 nv2 defs) =+ J.object+ [ "type" .= ("TseitinInfo" :: J.Value)+ , "num_original_variables" .= nv1+ , "num_transformed_variables" .= nv2+ , "definitions" .= J.object+ [ jVarName v .= formula+ | (v, formula) <- IntMap.toList defs+ ]+ ]++instance J.FromJSON TseitinInfo where+ parseJSON = withTypedObject "TseitinInfo" $ \obj -> do+ defs <- obj .: "definitions"+ TseitinInfo+ <$> obj .: "num_original_variables"+ <*> obj .: "num_transformed_variables"+ <*> (IntMap.fromList <$> mapM f (Map.toList defs))+ where+ f :: (T.Text, SAT.Formula) -> J.Parser (SAT.Var, SAT.Formula)+ f (name, formula) = do+ x <- parseVarNameText name+ pure (x, formula) -- -----------------------------------------------------------------------------
src/ToySolver/FileFormat/CNF.hs view
@@ -239,7 +239,7 @@ , wcnfClauses = [(fromMaybe top w, c) | (w, c) <- cs] } where- top = sum [w | (Just w, c) <- cs] + 1+ top = sum [w | (Just w, _c) <- cs] + 1 toNewWCNF :: WCNF -> NewWCNF toNewWCNF wcnf = NewWCNF [(if w >= wcnfTopCost wcnf then Nothing else Just w, c) | (w, c) <- wcnfClauses wcnf]@@ -294,7 +294,7 @@ -- -- References: ----- * <http://www.satcompetition.org/2011/rules.pdf>+-- * <https://web.archive.org/web/20131116055022/http://www.satcompetition.org/2011/rules.pdf> data GCNF = GCNF { gcnfNumVars :: !Int
src/ToySolver/Graph/Base.hs view
@@ -11,12 +11,37 @@ -- ----------------------------------------------------------------------------- module ToySolver.Graph.Base- ( EdgeLabeledGraph+ (+ -- * Graph data types+ EdgeLabeledGraph , Graph- , graphToUnorderedEdges+ , Vertex+ , VertexSet+ , Edge++ -- * Conversion++ -- ** Directed graphs+ , graphFromEdges+ , graphFromEdgesWith+ , graphToEdges++ -- ** Undirected graphs , graphFromUnorderedEdges , graphFromUnorderedEdgesWith+ , graphToUnorderedEdges++ -- * Operations+ , converseGraph+ , complementGraph+ , complementSimpleGraph++ -- * Properties+ , numVertexes+ , isSimpleGraph , isIndependentSet+ , isIndependentSetOf+ , isCliqueOf ) where import Control.Monad@@ -26,21 +51,77 @@ import Data.IntMap.Lazy (IntMap) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)+import Data.Maybe (maybeToList)+import GHC.Stack (HasCallStack) -type EdgeLabeledGraph a = Array Int (IntMap a)+-- | Labelled directed graph without multiple edges+--+-- We also represent undirected graphs as symmetric directed graphs.+type EdgeLabeledGraph a = Array Vertex (IntMap a) +-- | Directed graph without multiple edges+--+-- We also represent undirected graphs as symmetric directed graphs. type Graph = EdgeLabeledGraph () -graphToUnorderedEdges :: EdgeLabeledGraph a -> [(Int, Int, a)]-graphToUnorderedEdges g = do+-- | Vertex data type+type Vertex = Int++-- | Set of vertexes+type VertexSet = IntSet++-- | Edge data type+type Edge a = (Vertex, Vertex, a)++-- | Set of edges of directed graph+graphToEdges :: EdgeLabeledGraph a -> [Edge a]+graphToEdges g = do (node1, nodes) <- assocs g- (node2, a) <- IntMap.toList $ snd $ IntMap.split node1 nodes+ (node2, a) <- IntMap.toList nodes return (node1, node2, a) -graphFromUnorderedEdges :: Int -> [(Int, Int, a)] -> EdgeLabeledGraph a+-- | Construct a directed graph from edges.+--+-- If there are multiple edges with the same starting and ending+-- vertexes, the last label is used.+graphFromEdges :: HasCallStack => Int -> [Edge a] -> EdgeLabeledGraph a+graphFromEdges = graphFromEdgesWith const++-- | Construct a directed graph from edges.+--+-- If there are multiple edges with the same starting and ending+-- vertexes, the labels are combined using the given function.+graphFromEdgesWith :: HasCallStack => (a -> a -> a) -> Int -> [Edge a] -> EdgeLabeledGraph a+graphFromEdgesWith _ n _ | n < 0 = error "graphFromEdgesWith: number of vertexes should be non-negative"+graphFromEdgesWith f n es = runSTArray $ do+ g <- newArray (0, n-1) IntMap.empty+ forM_ es $ \(node1, node2, a) -> do+ m <- readArray g node1+ writeArray g node1 $! IntMap.insertWith f node2 a m+ return g++-- | Set of edges of undirected graph represented as a symmetric directed graph.+graphToUnorderedEdges :: EdgeLabeledGraph a -> [Edge a]+graphToUnorderedEdges g = do+ (node1, nodes) <- assocs g+ case IntMap.splitLookup node1 nodes of+ (_, m, nodes2) ->+ [(node1, node1, a) | a <- maybeToList m] +++ [(node1, node2, a) | (node2, a) <- IntMap.toList nodes2]++-- | Construct a symmetric directed graph from unordered edges.+--+-- If there are multiple edges with the same starting and ending+-- vertexes, the last label is used.+graphFromUnorderedEdges :: HasCallStack => Int -> [Edge a] -> EdgeLabeledGraph a graphFromUnorderedEdges = graphFromUnorderedEdgesWith const -graphFromUnorderedEdgesWith :: (a -> a -> a) -> Int -> [(Int, Int, a)] -> EdgeLabeledGraph a+-- | Construct a symmetric directed graph from unordered edges.+--+-- If there are multiple edges with the same starting and ending+-- vertexes, the labels are combined using the given function.+graphFromUnorderedEdgesWith :: HasCallStack => (a -> a -> a) -> Int -> [Edge a] -> EdgeLabeledGraph a+graphFromUnorderedEdgesWith _ n _ | n < 0 = error "graphFromUnorderedEdgesWith: number of vertexes should be non-negative" graphFromUnorderedEdgesWith f n es = runSTArray $ do a <- newArray (0, n-1) IntMap.empty let ins i x l = do@@ -48,12 +129,59 @@ writeArray a i $! IntMap.insertWith f x l m forM_ es $ \(node1, node2, a) -> do ins node1 node2 a- ins node2 node1 a+ unless (node1 == node2) $ ins node2 node1 a return a -isIndependentSet :: EdgeLabeledGraph a -> IntSet -> Bool-isIndependentSet g s = null $ do+-- | Converse of a graph.+--+-- It returns another directed graph on the same set of vertices with all of the edges reversed.+-- This is also called /transpose/ or /reverse/ of a graph.+converseGraph :: EdgeLabeledGraph a -> EdgeLabeledGraph a+converseGraph g = graphFromEdges (numVertexes g) [(n2, n1, l) | (n1, n2, l) <- graphToEdges g]++-- | Complement of a graph+--+-- Note that applying it to a graph with no self-loops results in a graph with self-loops on all vertices.+complementGraph :: EdgeLabeledGraph a -> EdgeLabeledGraph ()+complementGraph g = array (bounds g) [(node, toAllNodes IntMap.\\ outEdges) | (node, outEdges) <- assocs g]+ where+ toAllNodes = IntMap.fromAscList [(node, ()) | node <- indices g]++-- | Complement of a simple graph+--+-- It ignores self-loops in the input graph and also does not add self-loops to the output graph.+complementSimpleGraph :: EdgeLabeledGraph a -> EdgeLabeledGraph ()+complementSimpleGraph g = array (bounds g) [(node, IntMap.delete node toAllNodes IntMap.\\ outEdges) | (node, outEdges) <- assocs g]+ where+ toAllNodes = IntMap.fromAscList [(node, ()) | node <- indices g]++-- | Number of vertexes of a graph+numVertexes :: EdgeLabeledGraph a -> Int+numVertexes g =+ case bounds g of+ (lb, ub)+ | lb /= 0 -> error "numVertexes: lower bound should be 0"+ | otherwise -> ub + 1++-- | A graph is /simple/ if it contains no self-loops.+isSimpleGraph :: EdgeLabeledGraph a -> Bool+isSimpleGraph g = and [v `IntMap.notMember` es | (v, es) <- assocs g]++-- | Alias of 'isIndependentSetOf'+{-# DEPRECATED isIndependentSet "Use isIndependentSetOf instead" #-}+isIndependentSet :: EdgeLabeledGraph a -> VertexSet -> Bool+isIndependentSet = flip isIndependentSetOf++-- | An independent set of a graph is a set of vertices such that no two vertices in the set are adjacent.+--+-- This function ignores self-loops in the input graph.+isIndependentSetOf :: VertexSet -> EdgeLabeledGraph a -> Bool+isIndependentSetOf s g = null $ do (node1, node2, _) <- graphToUnorderedEdges g guard $ node1 `IntSet.member` s guard $ node2 `IntSet.member` s return ()++-- | A clique of a graph is a subset of vertices such that every two distinct vertices in the clique are adjacent.+isCliqueOf :: VertexSet -> EdgeLabeledGraph a -> Bool+isCliqueOf s g = all (\node -> IntSet.delete node s `IntSet.isSubsetOf` IntMap.keysSet (g ! node)) (IntSet.toList s)
src/ToySolver/Graph/ShortestPath.hs view
@@ -68,7 +68,6 @@ import Control.Monad.ST import Control.Monad.Trans import Control.Monad.Trans.Except-import Data.Hashable import qualified Data.HashTable.Class as H import qualified Data.HashTable.ST.Cuckoo as C import Data.IntMap.Strict (IntMap)
+ src/ToySolver/Internal/JSON.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings #-}+module ToySolver.Internal.JSON where++import Control.Monad+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import Data.Aeson ((.:))++withTypedObject :: String -> (J.Object -> J.Parser a) -> J.Value -> J.Parser a+withTypedObject name k = J.withObject name $ \obj -> do+ t <- obj .: "type"+ unless (t == name) $ fail ("expected type " ++ show name ++ ", but found type " ++ show t)+ k obj
src/ToySolver/SAT/Encoder/Cardinality.hs view
@@ -20,16 +20,27 @@ , newEncoder , newEncoderWithStrategy , encodeAtLeast+ , encodeAtLeastWithPolarity+ , getTseitinEncoder -- XXX , TotalizerDefinitions , getTotalizerDefinitions , evalTotalizerDefinitions++ -- * Polarity+ , Polarity (..)+ , negatePolarity+ , polarityPos+ , polarityNeg+ , polarityBoth+ , polarityNone ) where import Control.Monad.Primitive import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import ToySolver.SAT.Encoder.Tseitin (Polarity (..), negatePolarity, polarityPos, polarityNeg, polarityBoth, polarityNone) import ToySolver.SAT.Encoder.Cardinality.Internal.Naive import ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter import ToySolver.SAT.Encoder.PB.Internal.BDD as BDD@@ -72,8 +83,8 @@ evalTotalizerDefinitions :: SAT.IModel m => m -> TotalizerDefinitions -> [(SAT.Var, Bool)] evalTotalizerDefinitions m defs = Totalizer.evalDefinitions m defs --- getTseitinEncoder :: Encoder m -> Tseitin.Encoder m--- getTseitinEncoder (Encoder tseitin _) = tseitin+getTseitinEncoder :: Encoder m -> Tseitin.Encoder m+getTseitinEncoder (Encoder (Totalizer.Encoder tseitin _) _) = tseitin instance Monad m => SAT.NewVar m (Encoder m) where newVar (Encoder base _) = SAT.newVar base@@ -94,9 +105,12 @@ Totalizer -> Totalizer.addAtLeast base (lhs,rhs) encodeAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m SAT.Lit-encodeAtLeast (Encoder base@(Totalizer.Encoder tseitin _) strategy) =+encodeAtLeast enc = encodeAtLeastWithPolarity enc polarityBoth++encodeAtLeastWithPolarity :: PrimMonad m => Encoder m -> Polarity -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastWithPolarity (Encoder base@(Totalizer.Encoder tseitin _) strategy) polarity = case strategy of- Naive -> encodeAtLeastNaive tseitin- ParallelCounter -> encodeAtLeastParallelCounter tseitin- SequentialCounter -> \(lhs,rhs) -> BDD.encodePBLinAtLeastBDD tseitin ([(1,l) | l <- lhs], fromIntegral rhs)- Totalizer -> Totalizer.encodeAtLeast base+ Naive -> encodeAtLeastWithPolarityNaive tseitin polarity+ ParallelCounter -> encodeAtLeastWithPolarityParallelCounter tseitin polarity+ SequentialCounter -> \(lhs,rhs) -> BDD.encodePBLinAtLeastWithPolarityBDD tseitin polarity ([(1,l) | l <- lhs], fromIntegral rhs)+ Totalizer -> Totalizer.encodeAtLeastWithPolarity base polarity
src/ToySolver/SAT/Encoder/Cardinality/Internal/Naive.hs view
@@ -12,12 +12,13 @@ ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.Cardinality.Internal.Naive ( addAtLeastNaive- , encodeAtLeastNaive+ , encodeAtLeastWithPolarityNaive ) where import Control.Monad.Primitive import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin+import ToySolver.SAT.Encoder.Tseitin (Polarity ()) addAtLeastNaive :: PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m () addAtLeastNaive enc (lhs,rhs) = do@@ -27,15 +28,14 @@ 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+encodeAtLeastWithPolarityNaive :: PrimMonad m => Tseitin.Encoder m -> Polarity -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastWithPolarityNaive enc polarity (lhs,rhs) = do let n = length lhs if n < rhs then do- Tseitin.encodeDisj enc []+ Tseitin.encodeDisjWithPolarity enc polarity [] else do- ls <- mapM (Tseitin.encodeDisj enc) (comb (n - rhs + 1) lhs)- Tseitin.encodeConj enc ls+ ls <- mapM (Tseitin.encodeDisjWithPolarity enc polarity) (comb (n - rhs + 1) lhs)+ Tseitin.encodeConjWithPolarity enc polarity ls comb :: Int -> [a] -> [[a]] comb 0 _ = [[]]
src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs view
@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter ( addAtLeastParallelCounter- , encodeAtLeastParallelCounter+ , encodeAtLeastWithPolarityParallelCounter ) where import Control.Monad.Primitive@@ -28,21 +28,20 @@ addAtLeastParallelCounter :: PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m () addAtLeastParallelCounter enc constr = do- l <- encodeAtLeastParallelCounter enc constr+ l <- encodeAtLeastWithPolarityParallelCounter enc Tseitin.polarityPos 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+encodeAtLeastWithPolarityParallelCounter :: forall m. PrimMonad m => Tseitin.Encoder m -> Tseitin.Polarity -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastWithPolarityParallelCounter enc polarity (lhs,rhs) = do if rhs <= 0 then- Tseitin.encodeConj enc []+ Tseitin.encodeConjWithPolarity enc polarity [] else if length lhs < rhs then- Tseitin.encodeDisj enc []+ Tseitin.encodeDisjWithPolarity enc polarity [] else 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+ isGE <- encodeGE enc polarity cnt rhs_bits+ Tseitin.encodeDisjWithPolarity enc polarity $ isGE : overflowBits where bits :: Integer -> [Bool] bits n = f n 0@@ -81,17 +80,17 @@ runStateT (f (V.fromList lits)) [] -encodeGE :: forall m. PrimMonad m => Tseitin.Encoder m -> [SAT.Lit] -> [Bool] -> m SAT.Lit-encodeGE enc lhs rhs = do+encodeGE :: forall m. PrimMonad m => Tseitin.Encoder m -> Tseitin.Polarity -> [SAT.Lit] -> [Bool] -> m SAT.Lit+encodeGE enc polarity lhs rhs = do let f :: [SAT.Lit] -> [Bool] -> SAT.Lit -> m SAT.Lit f [] [] r = return r- f [] (True : _) _ = Tseitin.encodeDisj enc [] -- false+ f [] (True : _) _ = Tseitin.encodeDisjWithPolarity enc polarity [] -- false f [] (False : bs) r = f [] bs r f (l : ls) (True : bs) r = do- f ls bs =<< Tseitin.encodeConj enc [l, r]+ f ls bs =<< Tseitin.encodeConjWithPolarity enc polarity [l, r] f (l : ls) (False : bs) r = do- f ls bs =<< Tseitin.encodeDisj enc [l, r]+ f ls bs =<< Tseitin.encodeDisjWithPolarity enc polarity [l, r] f (l : ls) [] r = do- f ls [] =<< Tseitin.encodeDisj enc [l, r]- t <- Tseitin.encodeConj enc [] -- true+ f ls [] =<< Tseitin.encodeDisjWithPolarity enc polarity [l, r]+ t <- Tseitin.encodeConjWithPolarity enc polarity [] -- true f lhs rhs t
src/ToySolver/SAT/Encoder/Cardinality/Internal/Totalizer.hs view
@@ -24,16 +24,16 @@ , evalDefinitions , addAtLeast- , encodeAtLeast+ , encodeAtLeastWithPolarity , addCardinality- , encodeCardinality+ , encodeCardinalityWithPolarity , encodeSum ) where +import Control.Monad import Control.Monad.Primitive-import Control.Monad.State.Strict import qualified Data.IntSet as IntSet import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -94,25 +94,24 @@ forM_ (drop ub lits') $ \l -> SAT.addClause enc [- l] --- TODO: consider polarity-encodeAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m SAT.Lit-encodeAtLeast enc (lhs,rhs) = do- encodeCardinality enc lhs (rhs, length lhs) +encodeAtLeastWithPolarity :: PrimMonad m => Encoder m -> Tseitin.Polarity -> SAT.AtLeast -> m SAT.Lit+encodeAtLeastWithPolarity enc polarity (lhs,rhs) = do+ encodeCardinalityWithPolarity enc polarity lhs (rhs, length lhs) --- TODO: consider polarity-encodeCardinality :: PrimMonad m => Encoder m -> [SAT.Lit] -> (Int, Int) -> m SAT.Lit-encodeCardinality enc@(Encoder tseitin _) lits (lb, ub) = do++encodeCardinalityWithPolarity :: PrimMonad m => Encoder m -> Tseitin.Polarity -> [SAT.Lit] -> (Int, Int) -> m SAT.Lit+encodeCardinalityWithPolarity enc@(Encoder tseitin _) polarity lits (lb, ub) = do let n = length lits if lb <= 0 && n <= ub then- Tseitin.encodeConj tseitin []+ Tseitin.encodeConjWithPolarity tseitin polarity [] else if n < lb || ub < 0 then- Tseitin.encodeDisj tseitin []+ Tseitin.encodeDisjWithPolarity tseitin polarity [] else do lits' <- encodeSum enc lits forM_ (zip lits' (tail lits')) $ \(l1, l2) -> do SAT.addClause enc [-l2, l1] -- l2→l1 or equivalently ¬l1→¬l2- Tseitin.encodeConj tseitin $+ Tseitin.encodeConjWithPolarity tseitin polarity $ [lits' !! (lb - 1) | lb > 0] ++ [- (lits' !! (ub + 1 - 1)) | ub < n]
src/ToySolver/SAT/Encoder/Integer.hs view
@@ -45,7 +45,7 @@ vs <- SAT.newVars enc bitWidth let xs = zip (iterate (2*) 1) vs SAT.addPBAtMost enc xs hi'- return $ Expr ((lo,[]) : [(c,[x]) | (c,x) <- xs])+ return $ Expr $ [(lo,[]) | lo /= 0] ++ [(c,[x]) | (c,x) <- xs] instance AdditiveGroup Expr where Expr xs1 ^+^ Expr xs2 = Expr (xs1++xs2)
src/ToySolver/SAT/Encoder/PB.hs view
@@ -21,38 +21,75 @@ -- ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.PB- ( Encoder- , Strategy (..)+ ( Encoder (..) , newEncoder , newEncoderWithStrategy , encodePBLinAtLeast+ , encodePBLinAtLeastWithPolarity++ -- * Configulation+ , Strategy (..)+ , showStrategy+ , parseStrategy++ -- * Polarity+ , Polarity (..)+ , negatePolarity+ , polarityPos+ , polarityNeg+ , polarityBoth+ , polarityNone ) where import Control.Monad.Primitive+import Data.Char import Data.Default.Class import qualified ToySolver.SAT.Types as SAT+import qualified ToySolver.SAT.Encoder.Cardinality as Card import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin-import ToySolver.SAT.Encoder.PB.Internal.Adder (addPBLinAtLeastAdder, encodePBLinAtLeastAdder)-import ToySolver.SAT.Encoder.PB.Internal.BDD (addPBLinAtLeastBDD, encodePBLinAtLeastBDD)+import ToySolver.SAT.Encoder.Tseitin (Polarity (..), negatePolarity, polarityPos, polarityNeg, polarityBoth, polarityNone)+import ToySolver.SAT.Encoder.PB.Internal.Adder (addPBLinAtLeastAdder, encodePBLinAtLeastWithPolarityAdder)+import ToySolver.SAT.Encoder.PB.Internal.BCCNF (addPBLinAtLeastBCCNF, encodePBLinAtLeastWithPolarityBCCNF)+import ToySolver.SAT.Encoder.PB.Internal.BDD (addPBLinAtLeastBDD, encodePBLinAtLeastWithPolarityBDD) import ToySolver.SAT.Encoder.PB.Internal.Sorter (addPBLinAtLeastSorter, encodePBLinAtLeastSorter) -data Encoder m = Encoder (Tseitin.Encoder m) Strategy+data Encoder m = Encoder (Card.Encoder m) Strategy data Strategy = BDD | Adder | Sorter+ | BCCNF | Hybrid -- not implemented yet deriving (Show, Eq, Ord, Enum, Bounded) instance Default Strategy where def = Hybrid -newEncoder :: Monad m => Tseitin.Encoder m -> m (Encoder m)+showStrategy :: Strategy -> String+showStrategy BDD = "bdd"+showStrategy Adder = "adder"+showStrategy Sorter = "sorter"+showStrategy BCCNF = "bccnf"+showStrategy Hybrid = "hybrid"++parseStrategy :: String -> Maybe Strategy+parseStrategy s =+ case map toLower s of+ "bdd" -> Just BDD+ "adder" -> Just Adder+ "sorter" -> Just Sorter+ "bccnf" -> Just BCCNF+ "hybrid" -> Just Hybrid+ _ -> Nothing++newEncoder :: PrimMonad m => Tseitin.Encoder m -> m (Encoder m) newEncoder tseitin = newEncoderWithStrategy tseitin Hybrid -newEncoderWithStrategy :: Monad m => Tseitin.Encoder m -> Strategy -> m (Encoder m)-newEncoderWithStrategy tseitin strategy = return (Encoder tseitin strategy)+newEncoderWithStrategy :: PrimMonad m => Tseitin.Encoder m -> Strategy -> m (Encoder m)+newEncoderWithStrategy tseitin strategy = do+ card <- Card.newEncoderWithStrategy tseitin Card.SequentialCounter+ return (Encoder card strategy) instance Monad m => SAT.NewVar m (Encoder m) where newVar (Encoder a _) = SAT.newVar a@@ -74,24 +111,31 @@ addPBLinAtLeast' enc (lhs',rhs') encodePBLinAtLeast :: forall m. PrimMonad m => Encoder m -> SAT.PBLinAtLeast -> m SAT.Lit-encodePBLinAtLeast enc constr =- encodePBLinAtLeast' enc $ SAT.normalizePBLinAtLeast constr+encodePBLinAtLeast enc constr = encodePBLinAtLeastWithPolarity enc polarityBoth constr +encodePBLinAtLeastWithPolarity :: forall m. PrimMonad m => Encoder m -> Polarity -> SAT.PBLinAtLeast -> m SAT.Lit+encodePBLinAtLeastWithPolarity enc polarity constr =+ encodePBLinAtLeastWithPolarity' enc polarity $ SAT.normalizePBLinAtLeast constr+ -- ----------------------------------------------------------------------- addPBLinAtLeast' :: PrimMonad m => Encoder m -> SAT.PBLinAtLeast -> m ()-addPBLinAtLeast' (Encoder tseitin strategy) =+addPBLinAtLeast' (Encoder card strategy) = do+ let tseitin = Card.getTseitinEncoder card case strategy of Adder -> addPBLinAtLeastAdder tseitin Sorter -> addPBLinAtLeastSorter tseitin+ BCCNF -> addPBLinAtLeastBCCNF card _ -> addPBLinAtLeastBDD tseitin -encodePBLinAtLeast' :: PrimMonad m => Encoder m -> SAT.PBLinAtLeast -> m SAT.Lit-encodePBLinAtLeast' (Encoder tseitin strategy) =+encodePBLinAtLeastWithPolarity' :: PrimMonad m => Encoder m -> Polarity -> SAT.PBLinAtLeast -> m SAT.Lit+encodePBLinAtLeastWithPolarity' (Encoder card strategy) polarity constr = do+ let tseitin = Card.getTseitinEncoder card case strategy of- Adder -> encodePBLinAtLeastAdder tseitin- Sorter -> encodePBLinAtLeastSorter tseitin- _ -> encodePBLinAtLeastBDD tseitin+ Adder -> encodePBLinAtLeastWithPolarityAdder tseitin polarity constr+ Sorter -> encodePBLinAtLeastSorter tseitin constr+ BCCNF -> encodePBLinAtLeastWithPolarityBCCNF card polarity constr+ _ -> encodePBLinAtLeastWithPolarityBDD tseitin polarity constr -- -----------------------------------------------------------------------
src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs view
@@ -21,7 +21,7 @@ ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.PB.Internal.Adder ( addPBLinAtLeastAdder- , encodePBLinAtLeastAdder+ , encodePBLinAtLeastWithPolarityAdder ) where import Control.Monad@@ -42,10 +42,10 @@ formula <- encodePBLinAtLeastAdder' enc constr Tseitin.addFormula enc formula -encodePBLinAtLeastAdder :: PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m SAT.Lit-encodePBLinAtLeastAdder enc constr = do+encodePBLinAtLeastWithPolarityAdder :: PrimMonad m => Tseitin.Encoder m -> Tseitin.Polarity -> SAT.PBLinAtLeast -> m SAT.Lit+encodePBLinAtLeastWithPolarityAdder enc polarity constr = do formula <- encodePBLinAtLeastAdder' enc constr- Tseitin.encodeFormula enc formula+ Tseitin.encodeFormulaWithPolarity enc polarity formula encodePBLinAtLeastAdder' :: PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m Tseitin.Formula encodePBLinAtLeastAdder' _ (_,rhs) | rhs <= 0 = return true
+ src/ToySolver/SAT/Encoder/PB/Internal/BCCNF.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_HADDOCK show-extensions #-}+-----------------------------------------------------------------------------+-- |+-- Module : ToySolver.SAT.Encoder.PB.Internal.BCCNF+-- Copyright : (c) Masahiro Sakai 2022+-- License : BSD-style+--+-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : non-portable+--+-- References+--+-- * 南 雄之 (Yushi Minami), 宋 剛秀 (Takehide Soh), 番原 睦則+-- (Mutsunori Banbara), 田村 直之 (Naoyuki Tamura). ブール基数制約を+-- 経由した擬似ブール制約のSAT符号化手法 (A SAT Encoding of+-- Pseudo-Boolean Constraints via Boolean Cardinality Constraints).+-- Computer Software, 2018, volume 35, issue 3, pages 65-78,+-- <https://doi.org/10.11309/jssst.35.3_65>+--+-----------------------------------------------------------------------------+module ToySolver.SAT.Encoder.PB.Internal.BCCNF+ (+ -- * Monadic interface+ addPBLinAtLeastBCCNF+ , encodePBLinAtLeastWithPolarityBCCNF++ -- * High-level pure encoder+ , encode++ -- * Low-level implementation+ , preprocess++ -- ** Prefix sum+ , PrefixSum+ , toPrefixSum+ , encodePrefixSum+ , encodePrefixSumBuggy+ , encodePrefixSumNaive++ -- ** Boolean cardinality constraints+ , BCLit+ , toAtLeast+ , implyBCLit++ -- ** Clause over boolean cardinality constraints+ , BCClause+ , reduceBCClause+ , implyBCClause++ -- ** CNF over boolean cardinality constraints+ , BCCNF+ , reduceBCCNF+ ) where++import Control.Exception (assert)+import Control.Monad+import Control.Monad.Primitive+import Data.Function (on)+import Data.List (sortBy)+import Data.Maybe (listToMaybe)+import Data.Ord (comparing)++import ToySolver.SAT.Types+import qualified ToySolver.SAT.Encoder.Cardinality as Card+import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin++-- ------------------------------------------------------------------------++-- | \(\sum_{j=1}^i b_j s_j = \sum_{j=1}^i b_j (x_1, \ldots, x_j)\) is represented+-- as a list of tuples consisting of \(b_j, j, [x_1, \ldots, x_j]\).+type PrefixSum = [(Integer, Int, [Lit])]++-- | Convert 'PBLinSum' to 'PrefixSum'.+-- The 'PBLinSum' must be 'preprocess'ed before calling the function.+toPrefixSum :: PBLinSum -> PrefixSum+toPrefixSum s =+ assert (and [c > 0 | (c, _) <- s] && and (zipWith ((>=) `on` fst) s (tail s))) $+ go 0 [] s+ where+ go :: Int -> [Lit] -> PBLinSum -> PrefixSum+ go _ _ [] = []+ go !i prefix ((c, l) : ts)+ | c > c1 = (c - c1, i + 1, reverse (l : prefix)) : go (i + 1) (l : prefix) ts+ | otherwise = go (i + 1) (l : prefix) ts+ where+ c1 = maybe 0 fst (listToMaybe ts)++-- ------------------------------------------------------------------------++-- | A constraint \(s_i \ge c\) where \(s_i = x_1 + \ldots + x_i\) is represnted as+-- a tuple of \(i\), \([x_1, \ldots, x_i]\), and \(c\).+type BCLit = (Int, [Lit], Int)++-- | Disjunction of 'BCLit'+type BCClause = [BCLit]++-- | Conjunction of 'BCClause'+type BCCNF = [BCClause]++-- | Forget \(s_i\) and returns \(x_1 + \ldots + x_i \ge c\).+toAtLeast :: BCLit -> AtLeast+toAtLeast (_, lhs, rhs) = (lhs, rhs)++-- | \((s_i \ge a) \Rightarrow (s_j \ge b)\) is defined as+-- \((i \le j \wedge a \ge b) \vee (i \ge b \wedge i - a \le j - b)\).+implyBCLit :: BCLit -> BCLit -> Bool+implyBCLit (i,_,a) (j,_,b)+ | i <= j = a >= b+ | otherwise = i - a <= j - b++-- | Remove redundant literals based on 'implyBCLit'.+reduceBCClause :: BCClause -> BCClause+reduceBCClause lits = assert (isAsc lits2) $ lits2+ where+ isAsc ls = and [i1 <= i2 | let is = [i | (i,_,_) <- ls], (i1,i2) <- zip is (tail is)]+ isDesc ls = and [i1 >= i2 | let is = [i | (i,_,_) <- ls], (i1,i2) <- zip is (tail is)]++ lits1 = assert (isAsc lits) $ f1 [] minBound lits+ lits2 = assert (isDesc lits1) $ f2 [] maxBound lits1++ f1 r !_ [] = r+ f1 r !jb (l@(i,_,a) : ls)+ | ia > jb = f1 (l : r) ia ls+ | otherwise = f1 r jb ls+ where+ ia = i - a++ f2 r !_ [] = r+ f2 r !b (l@(_,_,a) : ls)+ | a < b = f2 (l : r) a ls+ | otherwise = f2 r b ls++-- | \(C \Rightarrow C'\) is defined as \(\forall l\in C \exists l' \in C' (l \Rightarrow l')\).+implyBCClause :: BCClause -> BCClause -> Bool+implyBCClause lits1 lits2 = all (\lit1 -> any (implyBCLit lit1) lits2) lits1++-- | Reduce 'BCCNF' by reducing each clause using 'reduceBCClause' and then+-- remove redundant clauses based on 'implyBCClause'.+reduceBCCNF :: BCCNF -> BCCNF+reduceBCCNF = reduceBCCNF' . map reduceBCClause++reduceBCCNF' :: BCCNF -> BCCNF+reduceBCCNF' = go []+ where+ go r [] = reverse r+ go r (c : cs)+ | any (\c' -> implyBCClause c' c) (r ++ cs) = go r cs+ | otherwise = go (c : r) cs++-- ------------------------------------------------------------------------++-- | Encode a given pseudo boolean constraint \(\sum_i a_i x_i \ge c\)+-- into an equilavent formula in the form of+-- \(\bigwedge_j \bigvee_k \sum_{l \in L_{j,k}} l \ge d_{j,k}\).+encode :: PBLinAtLeast -> [[AtLeast]]+encode constr = map (map toAtLeast) $ reduceBCCNF $ encodePrefixSum (toPrefixSum lhs) rhs+ where+ (lhs, rhs) = preprocess constr++-- | Perform 'normalizePBLinAtLeast' and sort the terms in descending order of coefficients+preprocess :: PBLinAtLeast -> PBLinAtLeast+preprocess constr = (lhs2, rhs1)+ where+ (lhs1, rhs1) = normalizePBLinAtLeast constr+ lhs2 = sortBy (flip (comparing fst) <> comparing (abs . snd)) lhs1++-- | Algorithm 2 in the paper but with a bug fixed+encodePrefixSum :: PrefixSum -> Integer -> [[BCLit]]+encodePrefixSum = f 0 0+ where+ f !_ !_ [] !c = if c > 0 then [[]] else []+ f i0 d0 ((0,_,_) : bss) c = f i0 d0 bss c+ f i0 d0 ((b,i,ls) : bss) c =+ [ [(i, ls, maximum ds' + 1)] | not (null ds') ]+ +++ [ if d+1 > i then theta else (i, ls, d+1) : theta+ | d <- ds, theta <- f i d bss (fromIntegral (c - b * fromIntegral d))+ ]+ where+ bssMax d = bssMin d + sum [b' * fromIntegral (i' - i) | (b', i', _) <- bss]+ bssMin d = sum [b' | (b', _, _) <- bss] * fromIntegral d+ ds = [d | d <- [d0 .. d0 + i - i0], let bd = b * fromIntegral d, c - bssMax d <= bd, bd < c - bssMin d]+ ds' = [d | d <- [d0 .. d0 + i - i0], b * fromIntegral d < c - bssMax d]++-- | Algorithm 2 in the paper+encodePrefixSumBuggy :: PrefixSum -> Integer -> [[BCLit]]+encodePrefixSumBuggy = f 0 0+ where+ f !_ !_ [] !c = if c > 0 then [[]] else []+ f i0 d0 ((0,_,_) : bss) c = f i0 d0 bss c+ f i0 d0 ((b,i,ls) : bss) c =+ [ [(i, ls, max (maximum ds' + 1) d0)] | not (null ds') ]+ +++ [ if d+1 > i then theta else (i, ls, d+1) : theta+ | d <- ds, theta <- f i d bss (fromIntegral (c - b * fromIntegral d))+ ]+ where+ bssMax d = bssMin d + sum [b' * fromIntegral (i' - i) | (b', i', _) <- bss]+ bssMin d = sum [b' | (b', _, _) <- bss] * fromIntegral d+ ds = [d | d <- [d0 .. d0 + i - i0], let bd = b * fromIntegral d, c - bssMax d <= bd, bd < c - bssMin d]+ ds' = [d | d <- [0..i], b * fromIntegral d < c - bssMax d]++-- | Algorithm 1 in the paper+encodePrefixSumNaive :: PrefixSum -> Integer -> [[BCLit]]+encodePrefixSumNaive = f+ where+ f [] !c = if c > 0 then [[]] else []+ f ((0,_,_) : bss) c = f bss c+ f ((b,i,ls) : bss) c =+ [ [(i, ls, maximum ds' + 1)] | not (null ds') ]+ +++ [ if d+1 > i then theta else (i, ls, d+1) : theta+ | d <- ds, theta <- f bss (fromIntegral (c - b * fromIntegral d))+ ]+ where+ bssMax = sum [b' * fromIntegral i' | (b', i', _) <- bss]+ bssMin = 0+ ds = [d | d <- [0..i], let bd = b * fromIntegral d, c - bssMax <= bd, bd < c - bssMin]+ ds' = [d | d <- [0..i], b * fromIntegral d < c - bssMax]++-- ------------------------------------------------------------------------++addPBLinAtLeastBCCNF :: PrimMonad m => Card.Encoder m -> PBLinAtLeast -> m ()+addPBLinAtLeastBCCNF enc constr = do+ forM_ (encode constr) $ \clause -> do+ addClause enc =<< mapM (Card.encodeAtLeast enc) clause++encodePBLinAtLeastWithPolarityBCCNF :: PrimMonad m => Card.Encoder m -> Tseitin.Polarity -> PBLinAtLeast -> m Lit+encodePBLinAtLeastWithPolarityBCCNF enc polarity constr = do+ let tseitin = Card.getTseitinEncoder enc+ ls <- forM (encode constr) $ \clause -> do+ Tseitin.encodeDisjWithPolarity tseitin polarity =<< mapM (Card.encodeAtLeastWithPolarity enc polarity) clause+ Tseitin.encodeConjWithPolarity tseitin polarity ls++-- ------------------------------------------------------------------------
src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs view
@@ -20,7 +20,7 @@ ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.PB.Internal.BDD ( addPBLinAtLeastBDD- , encodePBLinAtLeastBDD+ , encodePBLinAtLeastWithPolarityBDD ) where import Control.Monad.State.Strict@@ -34,17 +34,17 @@ addPBLinAtLeastBDD :: PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m () addPBLinAtLeastBDD enc constr = do- l <- encodePBLinAtLeastBDD enc constr+ l <- encodePBLinAtLeastWithPolarityBDD enc Tseitin.polarityPos constr SAT.addClause enc [l] -encodePBLinAtLeastBDD :: forall m. PrimMonad m => Tseitin.Encoder m -> SAT.PBLinAtLeast -> m SAT.Lit-encodePBLinAtLeastBDD enc (lhs,rhs) = do+encodePBLinAtLeastWithPolarityBDD :: forall m. PrimMonad m => Tseitin.Encoder m -> Tseitin.Polarity -> SAT.PBLinAtLeast -> m SAT.Lit+encodePBLinAtLeastWithPolarityBDD enc polarity (lhs,rhs) = do let lhs' = sortBy (flip (comparing fst)) lhs flip evalStateT Map.empty $ do let f :: SAT.PBLinSum -> Integer -> Integer -> StateT (Map (SAT.PBLinSum, Integer) SAT.Lit) m SAT.Lit f xs rhs slack- | rhs <= 0 = lift $ Tseitin.encodeConj enc [] -- true- | slack < 0 = lift $ Tseitin.encodeDisj enc [] -- false+ | rhs <= 0 = lift $ Tseitin.encodeConjWithPolarity enc polarity [] -- true+ | slack < 0 = lift $ Tseitin.encodeDisjWithPolarity enc polarity [] -- false | otherwise = do m <- get case Map.lookup (xs,rhs) m of@@ -55,12 +55,12 @@ [(_,l)] -> return l (c,l) : xs' -> do thenLit <- f xs' (rhs - c) slack- l2 <- lift $ Tseitin.encodeConjWithPolarity enc Tseitin.polarityPos [l, thenLit]+ l2 <- lift $ Tseitin.encodeConjWithPolarity enc polarity [l, thenLit] l3 <- if c > slack then return l2 else do elseLit <- f xs' rhs (slack - c)- lift $ Tseitin.encodeDisjWithPolarity enc Tseitin.polarityPos [l2, elseLit]+ lift $ Tseitin.encodeDisjWithPolarity enc polarity [l2, elseLit] modify (Map.insert (xs,rhs) l3) return l3 f lhs' rhs (sum [c | (c,_) <- lhs'] - rhs)
src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs view
@@ -36,6 +36,7 @@ , encodePBLinAtLeastSorter ) where +import Control.Monad import Control.Monad.Primitive import Control.Monad.State import Control.Monad.Writer
src/ToySolver/SAT/Encoder/Tseitin.hs view
@@ -89,6 +89,7 @@ import Control.Monad import Control.Monad.Primitive import Data.Primitive.MutVar+import qualified Data.IntMap.Lazy as IntMap import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntSet as IntSet@@ -429,21 +430,28 @@ encodeWithPolarityHelper encoder (encFACarryTable encoder) definePos defineNeg polarity (a,b,c) -getDefinitions :: PrimMonad m => Encoder m -> m [(SAT.Var, Formula)]+getDefinitions :: PrimMonad m => Encoder m -> m (SAT.VarMap Formula) getDefinitions encoder = do tableConj <- readMutVar (encConjTable encoder) tableITE <- readMutVar (encITETable encoder) tableXOR <- readMutVar (encXORTable encoder) tableFASum <- readMutVar (encFASumTable encoder) tableFACarry <- readMutVar (encFACarryTable encoder)- let m1 = [(v, andB [Atom l1 | l1 <- IntSet.toList ls]) | (ls, (v, _, _)) <- Map.toList tableConj]- m2 = [(v, ite (Atom c) (Atom t) (Atom e)) | ((c,t,e), (v, _, _)) <- Map.toList tableITE]- m3 = [(v, (Atom a .||. Atom b) .&&. (Atom (-a) .||. Atom (-b))) | ((a,b), (v, _, _)) <- Map.toList tableXOR]- m4 = [(v, orB [andB [Atom l | l <- ls] | ls <- [[a,b,c],[a,-b,-c],[-a,b,-c],[-a,-b,c]]])- | ((a,b,c), (v, _, _)) <- Map.toList tableFASum]- m5 = [(v, orB [andB [Atom l | l <- ls] | ls <- [[a,b],[a,c],[b,c]]])- | ((a,b,c), (v, _, _)) <- Map.toList tableFACarry]- return $ concat [m1, m2, m3, m4, m5]+ let atom l+ | l < 0 = Not (Atom (- l))+ | otherwise = Atom l+ m1 = IntMap.fromList [(v, andB [atom l1 | l1 <- IntSet.toList ls]) | (ls, (v, _, _)) <- Map.toList tableConj]+ m2 = IntMap.fromList [(v, ite (atom c) (atom t) (atom e)) | ((c,t,e), (v, _, _)) <- Map.toList tableITE]+ m3 = IntMap.fromList [(v, (atom a .||. atom b) .&&. (atom (-a) .||. atom (-b))) | ((a,b), (v, _, _)) <- Map.toList tableXOR]+ m4 = IntMap.fromList+ [ (v, orB [andB [atom l | l <- ls] | ls <- [[a,b,c],[a,-b,-c],[-a,b,-c],[-a,-b,c]]])+ | ((a,b,c), (v, _, _)) <- Map.toList tableFASum+ ]+ m5 = IntMap.fromList+ [ (v, orB [andB [atom l | l <- ls] | ls <- [[a,b],[a,c],[b,c]]])+ | ((a,b,c), (v, _, _)) <- Map.toList tableFACarry+ ]+ return $ IntMap.unions [m1, m2, m3, m4, m5] data Polarity
src/ToySolver/SAT/ExistentialQuantification.hs view
@@ -17,7 +17,7 @@ -- "Existential quantification as incremental SAT," in Computer Aided -- Verification (CAV 2011), G. Gopalakrishnan and S. Qadeer, Eds. -- pp. 191-207.--- <https://www.embedded.rwth-aachen.de/lib/exe/fetch.php?media=bib:bkk11a.pdf>+-- <https://www.cs.kent.ac.uk/pubs/2011/3094/content.pdf> -- ---------------------------------------------------------------------- module ToySolver.SAT.ExistentialQuantification
src/ToySolver/SAT/Formula.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -26,7 +27,10 @@ , simplify ) where +import Control.Monad import Control.Monad.ST+import qualified Data.Aeson as J+import Data.Aeson ((.=)) import Data.Hashable import qualified Data.HashTable.Class as H import qualified Data.HashTable.ST.Cuckoo as C@@ -35,6 +39,7 @@ import ToySolver.Data.Boolean import qualified ToySolver.Data.BoolExpr as BoolExpr import qualified ToySolver.SAT.Types as SAT+import ToySolver.SAT.Internal.JSON -- Should this module be merged into ToySolver.SAT.Types module? @@ -222,5 +227,57 @@ isFalse :: Formula -> Bool isFalse (Or []) = True isFalse _ = False++-- ------------------------------------------------------------------------++newtype JSON = JSON{ getJSON :: J.Value }++instance Complement JSON where+ notB (JSON x) = JSON $ jNot x++instance MonotoneBoolean JSON where+ andB xs = JSON $ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("and" :: J.Value)+ , "operands" .= [x | JSON x <- xs]+ ]+ orB xs = JSON $ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("or" :: J.Value)+ , "operands" .= [x | JSON x <- xs]+ ]++instance IfThenElse JSON JSON where+ ite (JSON c) (JSON t) (JSON e) = JSON $ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("ite" :: J.Value)+ , "operands" .= [c, t, e]+ ]++instance Boolean JSON where+ (.=>.) (JSON p) (JSON q) = JSON $ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("=>" :: J.Value)+ , "operands" .= [p, q]+ ]+ (.<=>.) (JSON p) (JSON q) = JSON $ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("<=>" :: J.Value)+ , "operands" .= [p, q]+ ]++instance J.ToJSON Formula where+ toJSON = getJSON . fold (JSON . jLit)++instance J.FromJSON Formula where+ parseJSON x = msum+ [ Atom <$> parseVar x+ , withNot (\y -> Not <$> J.parseJSON y) x+ , withAnd (\xs -> And <$> mapM J.parseJSON xs) x+ , withOr (\xs -> Or <$> mapM J.parseJSON xs) x+ , withITE (\c t e -> ITE <$> J.parseJSON c <*> J.parseJSON t <*> J.parseJSON e) x+ , withImply (\a b -> Imply <$> J.parseJSON a <*> J.parseJSON b) x+ , withEquiv (\a b -> Equiv <$> J.parseJSON a <*> J.parseJSON b) x+ ] -- ------------------------------------------------------------------------
+ src/ToySolver/SAT/Internal/JSON.hs view
@@ -0,0 +1,160 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module ToySolver.SAT.Internal.JSON where++import Control.Applicative+import Control.Arrow ((***))+import Control.Monad+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import Data.Aeson ((.=), (.:))+import Data.String+import qualified Data.Text as T++import qualified Data.PseudoBoolean as PBFile+import ToySolver.Internal.JSON+import qualified ToySolver.SAT.Types as SAT++jVar :: SAT.Var -> J.Value+jVar v = J.object+ [ "type" .= ("variable" :: J.Value)+ , "name" .= (jVarName v :: J.Value)+ ]++jVarName :: IsString a => SAT.Var -> a+jVarName v = fromString ("x" ++ show v)++jLitName :: IsString a => SAT.Var -> a+jLitName v+ | v >= 0 = jVarName v+ | otherwise = fromString ("~x" ++ show (- v))++parseVar :: J.Value -> J.Parser SAT.Var+parseVar = withTypedObject "variable" $ \obj -> parseVarName =<< obj .: "name"++parseVarName :: J.Value -> J.Parser SAT.Var+parseVarName = J.withText "variable name" parseVarNameText++parseVarNameText :: T.Text -> J.Parser SAT.Var+parseVarNameText name =+ case T.uncons name of+ Just ('x', rest) | (x,[]) : _ <- reads (T.unpack rest) -> pure x+ _ -> fail ("failed to parse variable name: " ++ show name)++jNot :: J.Value -> J.Value+jNot x = J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("not" :: J.Value)+ , "operands" .= [x]+ ]++jLit :: SAT.Lit -> J.Value+jLit l+ | l > 0 = jVar l+ | otherwise = jNot $ jVar (- l)++parseLit :: J.Value -> J.Parser SAT.Lit+parseLit x = parseVar x <|> withNot (fmap negate . parseVar) x++parseLitName :: J.Value -> J.Parser SAT.Lit+parseLitName = J.withText "literal" parseLitNameText++parseLitNameText :: T.Text -> J.Parser SAT.Lit+parseLitNameText name =+ case T.uncons name of+ Just ('~', rest) -> negate <$> parseVarNameText rest+ _ -> parseVarNameText name++jConst :: J.ToJSON a => a -> J.Value+jConst x = J.object ["type" .= ("constant" :: J.Value), "value" .= x]++parseConst :: J.FromJSON a => J.Value -> J.Parser a+parseConst = withTypedObject "constant" $ \obj -> obj .: "value"++jPBSum :: SAT.PBSum -> J.Value+jPBSum s = J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("+" :: J.Value)+ , "operands" .=+ [ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= ("*" :: J.Value)+ , "operands" .= (jConst c : [jLit lit | lit <- lits])+ ]+ | (c, lits) <- s+ ]+ ]++parsePBSum :: J.Value -> J.Parser SAT.PBSum+parsePBSum x = msum+ [ withOperator "+" (fmap concat . mapM parsePBSum) x+ , f x >>= \term -> pure [term]+ ]+ where+ f :: J.Value -> J.Parser (Integer, [SAT.Lit])+ f y = msum+ [ parseConst y >>= \c -> pure (c, [])+ , parseLit y >>= \lit -> pure (1, [lit])+ , withOperator "*" (fmap ((product *** concat) . unzip) . mapM f) y+ ]++jPBConstraint :: PBFile.Constraint -> J.Value+jPBConstraint (lhs, op, rhs) =+ J.object+ [ "type" .= ("operator" :: J.Value)+ , "name" .= (case op of{ PBFile.Ge -> ">="; PBFile.Eq -> "=" } :: J.Value)+ , "operands" .= [jPBSum lhs, jConst rhs]+ ]++parsePBConstraint :: J.Value -> J.Parser PBFile.Constraint+parsePBConstraint x = msum+ [ withOperator ">=" (f PBFile.Ge ">=") x+ , withOperator "=" (f PBFile.Eq "=") x+ ]+ where+ f :: PBFile.Op -> String -> [J.Value] -> J.Parser PBFile.Constraint+ f op _opStr [lhs, rhs] = do+ lhs' <- parsePBSum lhs+ rhs' <- parseConst rhs+ pure (lhs', op, rhs')+ f _ opStr operands = fail ("wrong number of arguments for " ++ show opStr ++ " (given " ++ show (length operands) ++ ", expected 1)")+++withOperator :: String -> ([J.Value] -> J.Parser a) -> J.Value -> J.Parser a+withOperator name k = withTypedObject "operator" $ \obj -> do+ op <- obj .: "name"+ unless (name == op) $ fail ("expected operator name " ++ show name ++ ", but found type " ++ show op)+ operands <- obj .: "operands"+ k operands++withNot :: (J.Value -> J.Parser a) -> J.Value -> J.Parser a+withNot k = withOperator "not" $ \operands -> do+ case operands of+ [x] -> k x+ _ -> fail ("wrong number of arguments for \"not\" (given " ++ show (length operands) ++ ", expected 1)")++withAnd :: ([J.Value] -> J.Parser a) -> J.Value -> J.Parser a+withAnd = withOperator "and"++withOr :: ([J.Value] -> J.Parser a) -> J.Value -> J.Parser a+withOr = withOperator "or"++withITE :: (J.Value -> J.Value -> J.Value -> J.Parser a) -> J.Value -> J.Parser a+withITE k = withOperator "ite" $ \operands -> do+ case operands of+ [c, t, e] -> k c t e+ _ -> fail ("wrong number of arguments for \"ite\" (given " ++ show (length operands) ++ ", expected 3)")++withImply :: (J.Value -> J.Value -> J.Parser a) -> J.Value -> J.Parser a+withImply k = withOperator "=>" $ \operands -> do+ case operands of+ [a, b] -> k a b+ _ -> fail ("wrong number of arguments for \"=>\" (given " ++ show (length operands) ++ ", expected 2)")++withEquiv :: (J.Value -> J.Value -> J.Parser a) -> J.Value -> J.Parser a+withEquiv k = withOperator "<=>" $ \operands -> do+ case operands of+ [a, b] -> k a b+ _ -> fail ("wrong number of arguments for \"<=>\" (given " ++ show (length operands) ++ ", expected 2)")
src/ToySolver/SAT/PBO/BCD2.hs view
@@ -217,7 +217,7 @@ _ -> do let torelax = unrelaxed `IntSet.intersection` failed intersected = IntMap.elems (IntMap.restrictKeys sels failed)- disjoint = [core | (sel,(core,_)) <- IntMap.toList (IntMap.withoutKeys sels failed)]+ disjoint = [core | (_sel,(core,_)) <- IntMap.toList (IntMap.withoutKeys sels failed)] modifyIORef unrelaxedRef (`IntSet.difference` torelax) modifyIORef relaxedRef (`IntSet.union` torelax) delta <- do
src/ToySolver/SAT/Solver/CDCL.hs view
@@ -81,6 +81,9 @@ , AddXORClause (..) , XORClause , evalXORClause+ -- ** Type-2 SOS constraints+ , addSOS2+ , evalSOS2 -- ** Theory , setTheory @@ -139,7 +142,9 @@ import Data.Array.IO import Data.Array.Unsafe (unsafeFreeze) import Data.Array.Base (unsafeRead, unsafeWrite)+#if !MIN_VERSION_hashable(1,4,3) import Data.Bits (xor) -- for defining 'combine' function+#endif import Data.Coerce import Data.Default.Class import Data.Either@@ -3619,11 +3624,15 @@ writeIORef ref xs return x +#if !MIN_VERSION_hashable(1,4,3)+ defaultHashWithSalt :: Hashable a => Int -> a -> Int defaultHashWithSalt salt x = salt `combine` hash x where combine :: Int -> Int -> Int combine h1 h2 = (h1 * 16777619) `xor` h2++#endif {-------------------------------------------------------------------- debug
− src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/OpenCL.hs
@@ -1,456 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_HADDOCK show-extensions #-}--------------------------------------------------------------------------------- |--- Module : ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL--- Copyright : (c) Masahiro Sakai 2016--- License : BSD-style------ Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : non-portable------ References:------ * Alfredo Braunstein, Marc Mézard and Riccardo Zecchina.--- Survey Propagation: An Algorithm for Satisfiability,--- <http://arxiv.org/abs/cs/0212002>------ * Corrie Scalisi. Visualizing Survey Propagation in 3-SAT Factor Graphs,--- <http://classes.soe.ucsc.edu/cmps290c/Winter06/proj/corriereport.pdf>.----------------------------------------------------------------------------------module ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL- (- -- * The Solver type- Solver- , newSolver- , deleteSolver-- -- * Problem information- , getNVars- , getNConstraints-- -- * Parameters- , getTolerance- , setTolerance- , getIterationLimit- , setIterationLimit-- -- * Computing marginal distributions- , initializeRandom- , initializeRandomDirichlet- , propagate- , getVarProb-- -- * Solving- , fixLit- , unfixLit- ) where--import Control.Exception-import Control.Loop-import Control.Monad-import Control.Parallel.OpenCL-import Data.Bits-import Data.Int-import Data.IORef-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as VM-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Storable.Mutable as VSM-import Data.Vector.Generic ((!))-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Generic.Mutable as VGM-import Foreign( castPtr, nullPtr, sizeOf )-import Foreign.C.Types( CFloat )-import Language.Haskell.TH (runIO, litE, stringL)-import Language.Haskell.TH.Syntax (addDependentFile)-import qualified Numeric.Log as L-import System.IO-import qualified System.Random.MWC as Rand-import qualified System.Random.MWC.Distributions as Rand-import Text.Printf--import qualified ToySolver.SAT.Types as SAT--data Solver- = Solver- { svOutputMessage :: !(String -> IO ())-- , svContext :: !CLContext- , svDevice :: !CLDeviceID- , svQueue :: !CLCommandQueue- , svUpdateEdgeProb :: !CLKernel- , svUpdateEdgeSurvey :: !CLKernel- , svComputeVarProb :: !CLKernel-- , svVarEdges :: !(VSM.IOVector CLint)- , svVarEdgesWeight :: !(VSM.IOVector CFloat)- , svVarOffset :: !(VSM.IOVector CLint)- , svVarLength :: !(VSM.IOVector CLint)- , svVarFixed :: !(VSM.IOVector Int8)- , svVarProb :: !(VSM.IOVector (L.Log CFloat))- , svClauseOffset :: !(VSM.IOVector CLint)- , svClauseLength :: !(VSM.IOVector CLint)- , svEdgeSurvey :: !(VSM.IOVector (L.Log CFloat)) -- η_{a → i}- , svEdgeProbU :: !(VSM.IOVector (L.Log CFloat)) -- Π^u_{i → a} / (Π^u_{i → a} + Π^s_{i → a} + Π^0_{i → a})-- , svTolRef :: !(IORef Double)- , svIterLimRef :: !(IORef (Maybe Int))- }--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 [VG.length c | (_,c) <- clauses]-- (varEdgesTmp :: VM.IOVector [(Int,Bool,Double)]) <- VGM.replicate nv []- clauseOffset <- VGM.new num_clauses- clauseLength <- VGM.new num_clauses-- ref <- newIORef 0- forM_ (zip [0..] clauses) $ \(i,(w,c)) -> do- VGM.write clauseOffset i =<< liftM fromIntegral (readIORef ref)- VGM.write clauseLength i (fromIntegral (VG.length c))- forM_ (SAT.unpackClause c) $ \lit -> do- e <- readIORef ref- modifyIORef' ref (+1)- VGM.modify varEdgesTmp ((e,lit>0,w) :) (abs lit - 1)-- varOffset <- VGM.new nv- varLength <- VGM.new nv- varFixed <- VGM.new nv- varEdges <- VGM.new num_edges- varEdgesWeight <- VGM.new num_edges- let loop !i !offset- | i >= nv = return ()- | otherwise = do- xs <- VGM.read (varEdgesTmp) i- let len = length xs- VGM.write varOffset i (fromIntegral offset)- VGM.write varLength i (fromIntegral len)- VGM.write varFixed i 0- forM_ (zip [offset..] (reverse xs)) $ \(j, (e,polarity,w)) -> do- VGM.write varEdges j $ (fromIntegral e `shiftL` 1) .|. (if polarity then 1 else 0)- VGM.write varEdgesWeight j (realToFrac w)- loop (i+1) (offset + len)- loop 0 0-- -- Initialize all surveys with non-zero values.- -- If we initialize to zero, following trivial solution exists:- --- -- η_{a→i} = 0 for all i and a.- --- -- Π^0_{i→a} = 1, Π^u_{i→a} = Π^s_{i→a} = 0 for all i and a,- --- -- \^{Π}^{0}_i = 1, \^{Π}^{+}_i = \^{Π}^{-}_i = 0- --- edgeSurvey <- VGM.replicate num_edges (L.Exp (log 0.5))- edgeProbU <- VGM.new num_edges-- varProb <- VGM.new (nv*2)-- tolRef <- newIORef 0.01- maxIterRef <- newIORef (Just 1000)-- -- Compile- let byteSize :: forall a. VSM.Storable a => VSM.IOVector a -> Int- byteSize v = VGM.length v * sizeOf (undefined :: a)- (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev- let reqConstantBufferSize =- byteSize varEdges + byteSize varEdgesWeight +- byteSize varOffset + byteSize varLength +- byteSize clauseOffset + byteSize clauseLength- let flags =- ["-DUSE_CONSTANT_BUFFER" | maxConstantBufferSize >= reqConstantBufferSize]- -- programSource <- openBinaryFile "sp.cl" ReadMode >>= hGetContents- let programSource = $(runIO (do{ h <- openFile "src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl" ReadMode; hSetEncoding h utf8; hGetContents h }) >>= \s -> addDependentFile "src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl" >> litE (stringL s))- outputMessage $ "Compiling kernels with options: " ++ unwords flags- program <- clCreateProgramWithSource context programSource- finally (clBuildProgram program [dev] (unwords flags))- (outputMessage =<< clGetProgramBuildLog program dev)- update_edge_prob <- clCreateKernel program "update_edge_prob"- update_edge_survey <- clCreateKernel program "update_edge_survey"- compute_var_prob <- clCreateKernel program "compute_var_prob"-- return $- Solver- { svOutputMessage = outputMessage-- , svContext = context- , svDevice = dev- , svQueue = queue- , svUpdateEdgeProb = update_edge_prob- , svUpdateEdgeSurvey = update_edge_survey- , svComputeVarProb = compute_var_prob-- , svVarEdges = varEdges- , svVarEdgesWeight = varEdgesWeight- , svVarOffset = varOffset- , svVarLength = varLength- , svVarFixed = varFixed- , svVarProb = varProb- , svClauseOffset = clauseOffset- , svClauseLength = clauseLength- , svEdgeSurvey = edgeSurvey- , svEdgeProbU = edgeProbU-- , svTolRef = tolRef- , svIterLimRef = maxIterRef- }--deleteSolver :: Solver -> IO ()-deleteSolver solver = do- _ <- clReleaseKernel (svUpdateEdgeProb solver)- _ <- clReleaseKernel (svUpdateEdgeSurvey solver)- _ <- clReleaseKernel (svComputeVarProb solver)- _ <- clReleaseCommandQueue (svQueue solver)- _ <- clReleaseContext (svContext solver)- return ()--initializeRandom :: Solver -> Rand.GenIO -> IO ()-initializeRandom solver gen = do- n <- getNConstraints solver- numLoop 0 (n-1) $ \i -> do- off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i- len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i- case len of- 0 -> return ()- 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0)- _ -> do- let p :: Double- p = 1 / fromIntegral len- numLoop 0 (len-1) $ \i -> do- d <- Rand.uniformR (p*0.5, p*1.5) gen- VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log d)))--initializeRandomDirichlet :: Solver -> Rand.GenIO -> IO ()-initializeRandomDirichlet solver gen = do- n <- getNConstraints solver- numLoop 0 (n-1) $ \i -> do- off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i- len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i- case len of- 0 -> return ()- 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0)- _ -> do- (ps :: V.Vector Double) <- Rand.dirichlet (VG.replicate len 1) gen- numLoop 0 (len-1) $ \i -> do- VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log (ps ! i))))---- | number of variables of the problem.-getNVars :: Solver -> IO Int-getNVars solver = return $ VGM.length (svVarOffset solver)---- | number of constraints of the problem.-getNConstraints :: Solver -> IO Int-getNConstraints solver = return $ VGM.length (svClauseOffset solver)---- | number of edges of the factor graph-getNEdges :: Solver -> IO Int-getNEdges solver = return $ VGM.length (svEdgeSurvey solver)--getTolerance :: Solver -> IO Double-getTolerance solver = readIORef (svTolRef solver)--setTolerance :: Solver -> Double -> IO ()-setTolerance solver !tol = writeIORef (svTolRef solver) tol--getIterationLimit :: Solver -> IO (Maybe Int)-getIterationLimit solver = readIORef (svIterLimRef solver)--setIterationLimit :: Solver -> Maybe Int -> IO ()-setIterationLimit solver val = writeIORef (svIterLimRef solver) val---- | Get the marginal probability of the variable to be @True@, @False@ and unspecified respectively.-getVarProb :: Solver -> SAT.Var -> IO (Double, Double, Double)-getVarProb solver v = do- let i = v - 1- pt <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2)- pf <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2+1)- return (pt, pf, 1 - (pt + pf))--propagate :: Solver -> IO Bool-propagate solver = do- tol <- getTolerance solver- lim <- getIterationLimit solver- nv <- getNVars solver- nc <- getNConstraints solver- let ne = VGM.length (svEdgeSurvey solver)-- let context = svContext solver- dev = svDevice solver- queue = svQueue solver- platform <- clGetDevicePlatform dev-- let infos = [CL_PLATFORM_PROFILE, CL_PLATFORM_VERSION, CL_PLATFORM_NAME, CL_PLATFORM_VENDOR, CL_PLATFORM_EXTENSIONS]- forM_ infos $ \info -> do- s <- clGetPlatformInfo platform info- svOutputMessage solver $ show info ++ " = " ++ s- devname <- clGetDeviceName dev- svOutputMessage solver $ "DEVICE = " ++ devname-- (maxComputeUnits :: Int) <- fromIntegral <$> clGetDeviceMaxComputeUnits dev- (maxWorkGroupSize :: Int) <- fromIntegral <$> clGetDeviceMaxWorkGroupSize dev- maxWorkItemSizes@(maxWorkItemSize:_) <- fmap fromIntegral <$> clGetDeviceMaxWorkItemSizes dev- svOutputMessage solver $ "MAX_COMPUTE_UNITS = " ++ show maxComputeUnits- svOutputMessage solver $ "MAX_WORK_GROUP_SIZE = " ++ show maxWorkGroupSize- svOutputMessage solver $ "MAX_WORK_ITEM_SIZES = " ++ show maxWorkItemSizes- (globalMemSize :: Int) <- fromIntegral <$> clGetDeviceGlobalMemSize dev- (localMemSize :: Int) <- fromIntegral <$> clGetDeviceLocalMemSize dev- (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev- (maxConstantArgs :: Int) <- fromIntegral <$> clGetDeviceMaxConstantArgs dev- svOutputMessage solver $ "GLOBAL_MEM_SIZE = " ++ show globalMemSize- svOutputMessage solver $ "LOCAL_MEM_SIZE = " ++ show localMemSize- svOutputMessage solver $ "MAX_CONSTANT_BUFFER_SIZE = " ++ show maxConstantBufferSize- svOutputMessage solver $ "MAX_CONSTANT_ARGS = " ++ show maxConstantArgs-- let defaultNumGroups = maxComputeUnits * 4-- (updateEdgeProb_kernel_workgroup_size :: Int)- <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeProb solver) dev- let updateEdgeProb_local_size = min 32 updateEdgeProb_kernel_workgroup_size- updateEdgeProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeProb_local_size)- updateEdgeProb_global_size = updateEdgeProb_num_groups * updateEdgeProb_local_size- svOutputMessage solver $- printf "update_edge_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d"- updateEdgeProb_kernel_workgroup_size updateEdgeProb_local_size updateEdgeProb_num_groups updateEdgeProb_global_size-- (updateEdgeSurvey_kernel_workgroup_size :: Int)- <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeSurvey solver) dev- let updateEdgeSurvey_local_size = min 32 updateEdgeSurvey_kernel_workgroup_size- updateEdgeSurvey_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeSurvey_local_size)- updateEdgeSurvey_global_size = updateEdgeSurvey_num_groups * updateEdgeSurvey_local_size- svOutputMessage solver $- printf "update_edge_survey kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d"- updateEdgeSurvey_kernel_workgroup_size updateEdgeSurvey_local_size updateEdgeSurvey_num_groups updateEdgeSurvey_global_size-- (computeVarProb_kernel_workgroup_size :: Int)- <- fromIntegral <$> clGetKernelWorkGroupSize (svComputeVarProb solver) dev- let computeVarProb_local_size = min 32 computeVarProb_kernel_workgroup_size- computeVarProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` computeVarProb_local_size)- computeVarProb_global_size = computeVarProb_num_groups * computeVarProb_local_size- svOutputMessage solver $- printf "compute_var_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d"- computeVarProb_kernel_workgroup_size computeVarProb_local_size computeVarProb_num_groups computeVarProb_global_size-- let createBufferFromVector :: forall a. VSM.Storable a => [CLMemFlag] -> VSM.IOVector a -> IO CLMem- createBufferFromVector flags v = do- VSM.unsafeWith v $ \ptr ->- clCreateBuffer context (CL_MEM_COPY_HOST_PTR : flags)- (VGM.length v * sizeOf (undefined :: a), castPtr ptr)-- readBufferToVectorAsync :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO CLEvent- readBufferToVectorAsync mem vec = do- VSM.unsafeWith vec $ \ptr -> do- clEnqueueReadBuffer queue mem False- 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) []-- readBufferToVector :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO ()- readBufferToVector mem vec = do- VSM.unsafeWith vec $ \ptr -> do- ev <- clEnqueueReadBuffer queue mem True- 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) []- _ <- clReleaseEvent ev- return ()-- var_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarOffset solver- var_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarLength solver- var_fixed <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarFixed solver- var_edges <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdges solver- var_edges_weight <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdgesWeight solver- clause_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseOffset solver- clause_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseLength solver- edge_survey <- createBufferFromVector [CL_MEM_READ_WRITE] $ svEdgeSurvey solver- edge_prob_u <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}]- (ne * sizeOf (undefined :: CFloat), nullPtr)-- global_buf <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}]- (ne * sizeOf (undefined :: CFloat) * 2, nullPtr)- var_prob <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}]- (nv * sizeOf (undefined :: CFloat) * 2, nullPtr)- group_max_delta <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}]- (updateEdgeSurvey_num_groups * sizeOf (undefined :: CFloat), nullPtr)-- clSetKernelArgSto (svUpdateEdgeProb solver) 0 (fromIntegral nv :: CLint)- clSetKernelArgSto (svUpdateEdgeProb solver) 1 var_offset- clSetKernelArgSto (svUpdateEdgeProb solver) 2 var_degree- clSetKernelArgSto (svUpdateEdgeProb solver) 3 var_fixed- clSetKernelArgSto (svUpdateEdgeProb solver) 4 var_edges- clSetKernelArgSto (svUpdateEdgeProb solver) 5 var_edges_weight- clSetKernelArgSto (svUpdateEdgeProb solver) 6 global_buf- clSetKernelArgSto (svUpdateEdgeProb solver) 7 edge_survey- clSetKernelArgSto (svUpdateEdgeProb solver) 8 edge_prob_u-- clSetKernelArgSto (svUpdateEdgeSurvey solver) 0 (fromIntegral nc :: CLint)- clSetKernelArgSto (svUpdateEdgeSurvey solver) 1 clause_offset- clSetKernelArgSto (svUpdateEdgeSurvey solver) 2 clause_degree- clSetKernelArgSto (svUpdateEdgeSurvey solver) 3 edge_survey- clSetKernelArgSto (svUpdateEdgeSurvey solver) 4 edge_prob_u- clSetKernelArgSto (svUpdateEdgeSurvey solver) 5 global_buf- clSetKernelArgSto (svUpdateEdgeSurvey solver) 6 group_max_delta- clSetKernelArg (svUpdateEdgeSurvey solver) 7 (updateEdgeSurvey_local_size * sizeOf (undefined :: CFloat)) nullPtr -- reduce_buf-- clSetKernelArgSto (svComputeVarProb solver) 0 (fromIntegral nv :: CLint)- clSetKernelArgSto (svComputeVarProb solver) 1 var_offset- clSetKernelArgSto (svComputeVarProb solver) 2 var_degree- clSetKernelArgSto (svComputeVarProb solver) 3 var_prob- clSetKernelArgSto (svComputeVarProb solver) 4 var_edges- clSetKernelArgSto (svComputeVarProb solver) 5 var_edges_weight- clSetKernelArgSto (svComputeVarProb solver) 6 edge_survey-- (group_max_delta_vec :: VSM.IOVector CFloat) <- VGM.new updateEdgeSurvey_num_groups-- let loop !i- | Just l <- lim, i >= l = return (False,i)- | otherwise = do- _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeProb solver)- [updateEdgeProb_global_size] [updateEdgeProb_local_size] []- _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeSurvey solver)- [updateEdgeSurvey_global_size] [updateEdgeSurvey_local_size] []- readBufferToVector group_max_delta group_max_delta_vec- !delta <- VG.maximum <$> VS.unsafeFreeze group_max_delta_vec- if realToFrac delta <= tol then do- return (True,i)- else- loop (i+1)-- (b,_steps) <- loop 0-- _ <- clReleaseEvent =<< readBufferToVectorAsync edge_survey (svEdgeSurvey solver)- when b $ do- _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svComputeVarProb solver)- [computeVarProb_global_size] [computeVarProb_local_size] []- _ <- clReleaseEvent =<< readBufferToVectorAsync var_prob (svVarProb solver)- return ()-- _ <- clFinish queue-- _ <- clReleaseMemObject var_offset- _ <- clReleaseMemObject var_degree- _ <- clReleaseMemObject var_edges- _ <- clReleaseMemObject var_edges_weight- _ <- clReleaseMemObject clause_offset- _ <- clReleaseMemObject clause_degree- _ <- clReleaseMemObject edge_survey- _ <- clReleaseMemObject edge_prob_u- _ <- clReleaseMemObject global_buf- _ <- clReleaseMemObject var_prob- _ <- clReleaseMemObject group_max_delta-- return b--fixLit :: Solver -> SAT.Lit -> IO ()-fixLit solver lit = do- VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) (if lit > 0 then 1 else -1)--unfixLit :: Solver -> SAT.Lit -> IO ()-unfixLit solver lit = do- VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) 0
− src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl
@@ -1,193 +0,0 @@-/* -*- mode: c -*- */--#ifdef USE_CONSTANT_BUFFER-#define CONSTANT __constant-#else-#define CONSTANT __global-#endif--typedef float logfloat;-typedef float2 logfloat2;--static inline logfloat comp(logfloat x) {- return log1p(fmax(-1.0f, -exp(x)));-}--__kernel void-update_edge_prob(- int n_vars,- CONSTANT int *var_offset, // int[n_vars]- CONSTANT int *var_degree, // int[n_vars]- CONSTANT char *var_fixed, // char[n_vars]- CONSTANT int *var_edges, // int[M]- CONSTANT float *var_edges_weight, // float[M]- __global logfloat2 *var_edges_buf,// logfloat2[M]- __global logfloat *edge_survey, // logfloat[n_edges]- __global logfloat *edge_prob_u // logfloat[n_edges]- )-{- int global_size = get_global_size(0);- for (int i = get_global_id(0); i < n_vars; i += global_size) {- int offset = var_offset[i];- int degree = var_degree[i];- int fixed = var_fixed[i];-- if (fixed != 0) {- for (int j = 0; j < degree; j++) {- int tmp = var_edges[offset+j];- int e = tmp >> 1;- bool polarity = tmp & 1;- if (polarity == (bool)(tmp > 0))- edge_prob_u[e] = log(0.0f);- else- edge_prob_u[e] = log(1.0f);- }- }-- logfloat val1_pre = log(1.0f);- logfloat val2_pre = log(1.0f);- for (int j = 0; j < degree; j++) {- var_edges_buf[offset+j] = (float2)(val1_pre, val2_pre);-- int tmp = var_edges[offset+j];- int e = tmp >> 1;- bool polarity = tmp & 1;- logfloat eta_ai = edge_survey[e];- logfloat w = var_edges_weight[offset+j];-- if (polarity) {- val1_pre += comp(eta_ai) * w;- } else {- val2_pre += comp(eta_ai) * w;- }- }-- logfloat val1_post = log(1.0f);- logfloat val2_post = log(1.0f);- for (int j = degree - 1; j >= 0; j--) {- int tmp = var_edges[offset+j];- int e = tmp >> 1;- bool polarity = tmp & 1;- logfloat eta_ai = edge_survey[e];- float w = var_edges_weight[offset+j];-- logfloat2 pre = var_edges_buf[offset+j];- logfloat val1 = pre.x + val1_post; // probability that other edges do not depends on v=1.- logfloat val2 = pre.y + val2_post; // probability that other edges do not depends on v=0.- logfloat pi_0 = val1 + val2; // Π^0_{i→a}- logfloat pi_u; // Π^u_{i→a}- logfloat pi_s; // Π^s_{i→a}- if (polarity) {- pi_u = comp(val2) + val1;- pi_s = comp(val1) + val2;- val1_post += comp(eta_ai) * w;- } else {- pi_u = comp(val1) + val2;- pi_s = comp(val2) + val1;- val2_post += comp(eta_ai) * w;- }- float psum = exp(pi_0) + exp(pi_u) + exp(pi_s);- if (psum > 0) {- edge_prob_u[e] = pi_u - log(psum);- } else {- edge_prob_u[e] = log(0.0f); // is that ok?- }- }- }-}---__kernel void-update_edge_survey(- int n_clauses,- CONSTANT int *clause_offset, // int[n_clauses]- CONSTANT int *clause_degree, // int[n_clauses]- __global logfloat *edge_survey, // logfloat[n_edges]- __global logfloat *edge_prob_u, // logfloat[n_edges]- __global logfloat *edge_buf, // logfloat[n_edges]- __global float *group_max_delta, // float[get_num_groups(0)]- __local float *reduce_buf // float[get_local_size(0)]- )-{- float max_delta = 0;-- int global_size = get_global_size(0);- for (int a = get_global_id(0); a < n_clauses; a += global_size) {- int len = clause_degree[a];- int offset = clause_offset[a];-- logfloat pre = log(1.0f);- for (int j = 0; j < len; j++) {- int e = offset+j;- edge_buf[e] = pre;- pre += edge_prob_u[e];- }-- logfloat post = log(1.0f);- for (int j = len-1; j >=0; j--) {- int e = offset+j;- logfloat pre = edge_buf[e];- logfloat eta_ai_orig = edge_survey[e];- logfloat eta_ai_new = pre + post;- edge_survey[e] = eta_ai_new;- max_delta = fmax(max_delta, fabs(exp(eta_ai_new) - exp(eta_ai_orig)));- post += edge_prob_u[e];- }- }-- // reduction- int local_id = get_local_id(0);- int local_size = get_local_size(0);- barrier(CLK_LOCAL_MEM_FENCE);- reduce_buf[local_id] = max_delta;- for (int stride = local_size / 2; stride > 0; stride /= 2) {- barrier(CLK_LOCAL_MEM_FENCE);- if (local_id < stride) {- reduce_buf[local_id] = fmax(reduce_buf[local_id], reduce_buf[local_id + stride]);- }- }- if (local_id==0)- group_max_delta[get_group_id(0)] = reduce_buf[0];-}--__kernel void-compute_var_prob(- int n_vars,- CONSTANT int *var_offset, // int[n_vars]- CONSTANT int *var_degree, // int[n_vars]- __global logfloat2 *var_prob, // logfloat2[n_vars]- CONSTANT int *var_edges, // int[M]- CONSTANT logfloat *var_edges_weight, // logfloat[M]- __global logfloat *edge_survey // logfloat[E]- )-{- int global_size = get_global_size(0);-- for (int i = get_global_id(0); i < n_vars; i += global_size) {- int offset = var_offset[i];- int degree = var_degree[i];-- logfloat val1 = log(1.0f);- logfloat val2 = log(1.0f);- for (int j = 0; j < degree; j++) {- int tmp = var_edges[offset+j];- int e = tmp >> 1;- bool polarity = tmp & 1;- float eta_ai = edge_survey[e];- float w = var_edges_weight[offset+j];-- if (polarity) {- val1 += comp(eta_ai) * w;- } else {- val2 += comp(eta_ai) * w;- }- }-- float p0 = val1 + val2; // \^{Π}^{0}_i- float pp = comp(val1) + val2; // \^{Π}^{+}_i- float pn = comp(val2) + val1; // \^{Π}^{-}_i- float wp = pp - log(exp(pp) + exp(pn) + exp(p0)); // W^{(+)}_i- float wn = pn - log(exp(pp) + exp(pn) + exp(p0)); // W^{(-)}_i- var_prob[i] = (float2)(wp, wn);- }-}
src/ToySolver/SAT/Solver/SLS/ProbSAT.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -528,11 +529,15 @@ -- ------------------------------------------------------------------- +#if !MIN_VERSION_array(0,5,6)+ {-# 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)++#endif {-# INLINE forAssocsM_ #-} forAssocsM_ :: (IArray a e, Monad m) => a Int e -> ((Int,e) -> m ()) -> m ()
src/ToySolver/SAT/Types.hs view
@@ -91,6 +91,7 @@ , evalPBSum , evalPBConstraint , evalPBFormula+ , evalPBSoftFormula , pbLowerBound , pbUpperBound , removeNegationFromPBSum@@ -108,6 +109,10 @@ , AddPBLin (..) , AddPBNL (..) , AddXORClause (..)++ -- * Type-2 SOS constraints+ , addSOS2+ , evalSOS2 ) where import Control.Monad@@ -477,6 +482,21 @@ guard $ all (evalPBConstraint m) $ PBFile.pbConstraints formula return $ evalPBSum m $ fromMaybe [] $ PBFile.pbObjectiveFunction formula +evalPBSoftFormula :: IModel m => m -> PBFile.SoftFormula -> Maybe Integer+evalPBSoftFormula m formula = do+ obj <- liftM sum $ forM (PBFile.wboConstraints formula) $ \(cost, constr) -> do+ case cost of+ Nothing -> do+ guard $ evalPBConstraint m constr+ return 0+ Just w+ | evalPBConstraint m constr -> return 0+ | otherwise -> return w+ case PBFile.wboTopCost formula of+ Nothing -> return ()+ Just c -> guard (obj < c)+ return obj+ pbLowerBound :: PBSum -> Integer pbLowerBound xs = sum [c | (c,ls) <- xs, c < 0 || null ls] @@ -735,3 +755,25 @@ reified <- newVar a addXORClause a (litNot reified : lits) rhs addClause a [litNot sel, reified] -- sel ⇒ reified++-- | Add a type-2 SOS constraint+--+-- At most two adjacnt literals can be true.+addSOS2 :: AddClause m a => a -> [Lit] -> m ()+addSOS2 a xs =+ forM_ (nonAdjacentPairs xs) $ \(x1,x2) -> do+ addClause a [litNot v | v <- [x1,x2]]+ where+ nonAdjacentPairs :: [a] -> [(a,a)]+ nonAdjacentPairs (x1:x2:xs) = [(x1,x3) | x3 <- xs] ++ nonAdjacentPairs (x2:xs)+ nonAdjacentPairs _ = []++-- | Evaluate type-2 SOS constraint+evalSOS2 :: IModel m => m -> [Lit] -> Bool+evalSOS2 m = f+ where+ f [] = True+ f [_] = True+ f (l1 : l2 : ls)+ | evalLit m l1 = all (not . evalLit m) ls+ | otherwise = f (l2 : ls)
src/ToySolver/SDP.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -23,9 +24,12 @@ , DualizeInfo (..) ) where +import qualified Data.Aeson as J+import Data.Aeson ((.=), (.:)) import qualified Data.Map.Strict as Map import Data.Scientific (Scientific) import ToySolver.Converter.Base+import ToySolver.Internal.JSON (withTypedObject) import qualified ToySolver.Text.SDPFile as SDPFile -- | Given a primal-dual pair (P), (D), it returns another primal-dual pair (P'), (D')@@ -185,6 +189,21 @@ case splitAt (blockIndexesLen block) zV1 of (vals, zV2) -> symblock (zip (blockIndexes block) vals) : f blocks zV2 _ -> error "ToySolver.SDP.transformSolutionBackward: invalid solution"++instance J.ToJSON DualizeInfo where+ toJSON (DualizeInfo origM origBlockStruct) =+ J.object+ [ "type" .= ("DualizeInfo" :: J.Value)+ , "num_original_matrices" .= origM+ , "original_block_structure" .= origBlockStruct+ ]++instance J.FromJSON DualizeInfo where+ parseJSON =+ withTypedObject "DualizeInfo" $ \obj ->+ DualizeInfo+ <$> obj .: "num_original_matrices"+ <*> obj .: "original_block_structure" symblock :: [((Int,Int), Scientific)] -> SDPFile.Block symblock es = Map.fromList $ do
src/ToySolver/Version.hs view
@@ -31,9 +31,6 @@ #ifdef VERSION_MIP , ("MIP", VERSION_MIP) #endif-#ifdef VERSION_OpenCL- , ("OpenCL", VERSION_OpenCL)-#endif #ifdef VERSION_OptDir , ("OptDir", VERSION_OptDir) #endif
test/Test/Converter.hs view
@@ -1,21 +1,28 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Test.Converter (converterTestGroup) where import Control.Monad+import qualified Data.Aeson as J import Data.Array.IArray import qualified Data.Foldable as F+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+import Data.String import qualified Data.Vector.Generic as VG+import qualified Numeric.Optimization.MIP as MIP import Test.Tasty+import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding ((.&&.), (.||.)) import Test.Tasty.TH import qualified Test.QuickCheck as QC@@ -32,7 +39,24 @@ import Test.SAT.Utils +------------------------------------------------------------------------ +case_identity_transformer_json :: Assertion+case_identity_transformer_json = do+ let info :: IdentityTransformer SAT.Model+ info = IdentityTransformer+ json = J.encode info+ J.eitherDecode json @?= Right info++case_reversed_transformer_json :: Assertion+case_reversed_transformer_json = do+ let info :: ReversedTransformer (IdentityTransformer SAT.Model)+ info = ReversedTransformer IdentityTransformer+ json = J.encode info+ J.eitherDecode json @?= Right info++------------------------------------------------------------------------+ prop_sat2naesat_forward :: Property prop_sat2naesat_forward = forAll arbitraryCNF $ \cnf -> let ret@(nae,info) = sat2naesat cnf@@ -47,6 +71,13 @@ forAllAssignments (fst nae) $ \m -> evalCNF (transformBackward info m) cnf === evalNAESAT m nae +prop_sat2naesat_json :: Property+prop_sat2naesat_json = forAll arbitraryCNF $ \cnf ->+ let ret@(_,info) = sat2naesat cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_naesat2sat_forward :: Property prop_naesat2sat_forward = forAll arbitraryNAESAT $ \nae -> let ret@(cnf,info) = naesat2sat nae@@ -61,6 +92,13 @@ forAllAssignments (CNF.cnfNumVars cnf) $ \m -> evalNAESAT (transformBackward info m) nae === evalCNF m cnf +prop_naesat2sat_json :: Property+prop_naesat2sat_json = forAll arbitraryNAESAT $ \nae ->+ let ret@(_,info) = naesat2sat nae+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_naesat2naeksat_forward :: Property prop_naesat2naeksat_forward = forAll arbitraryNAESAT $ \nae ->@@ -81,6 +119,15 @@ forAll (arbitraryAssignment (fst nae')) $ \m -> evalNAESAT (transformBackward info m) nae || not (evalNAESAT m nae') +prop_naesat2naeksat_json :: Property+prop_naesat2naeksat_json =+ forAll arbitraryNAESAT $ \nae ->+ forAll (choose (3,10)) $ \k ->+ let ret@(_,info) = naesat2naeksat k nae+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_naesat2maxcut_forward :: Property prop_naesat2maxcut_forward = forAll arbitraryNAESAT $ \nae ->@@ -89,6 +136,24 @@ forAllAssignments (fst nae) $ \m -> evalNAESAT m nae === (MaxCut.eval (transformForward info m) maxcut >= threshold) +prop_naesat2maxcut_backward :: Property+prop_naesat2maxcut_backward = forAll arbitraryNAESAT $ \nae ->+ let ret@((g, threshold),info) = naesat2maxcut nae+ in counterexample (show ret) $+ forAll (arbitraryCut g) $ \cut ->+ if MaxCut.eval cut g >= threshold then+ evalNAESAT (transformBackward info cut) nae+ else+ True++prop_naesat2maxcut_json :: Property+prop_naesat2maxcut_json =+ forAll arbitraryNAESAT $ \nae ->+ let ret@(_, info) = naesat2maxcut nae+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_naesat2max2sat_forward :: Property prop_naesat2max2sat_forward = forAll arbitraryNAESAT $ \nae ->@@ -99,6 +164,57 @@ Nothing -> property False Just v -> evalNAESAT m nae === (v <= threshold) +prop_naesat2max2sat_backward :: Property+prop_naesat2max2sat_backward =+ forAll arbitraryNAESAT $ \nae ->+ let ret@((wcnf, threshold), info) = naesat2max2sat nae+ in counterexample (show ret) $+ forAll (arbitraryAssignment (CNF.wcnfNumVars wcnf)) $ \m ->+ case evalWCNF m wcnf of+ Just v | v <= threshold -> evalNAESAT (transformBackward info m) nae+ _ -> True++prop_naesat2max2sat_json :: Property+prop_naesat2max2sat_json =+ forAll arbitraryNAESAT $ \nae ->+ let ret@(_, info) = naesat2max2sat nae+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_sat2maxcut_forward :: Property+prop_sat2maxcut_forward =+ forAll arbitraryCNF $ \cnf ->+ let ret@((g, threshold), info) = sat2maxcut cnf+ in counterexample (show ret) $+ forAllAssignments (CNF.cnfNumVars cnf) $ \m ->+ evalCNF m cnf === (MaxCut.eval (transformForward info m) g >= threshold)++prop_sat2maxcut_backward :: Property+prop_sat2maxcut_backward = forAll arbitraryCNF $ \cnf ->+ let ret@((g, threshold),info) = sat2maxcut cnf+ in counterexample (show ret) $+ forAll (arbitraryCut g) $ \cut ->+ if MaxCut.eval cut g >= threshold then+ -- TODO: maybe it's difficult to come here+ evalCNF (transformBackward info cut) cnf+ else+ True++prop_sat2maxcut_json :: Property+prop_sat2maxcut_json =+ forAll arbitraryCNF $ \cnf ->+ let ret@(_, info) = sat2maxcut cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++arbitraryCut :: MaxCut.Problem a -> Gen MaxCut.Solution+arbitraryCut g = do+ let b = bounds g+ xs <- replicateM (rangeSize b) arbitrary+ return $ array b (zip (range b) xs)+ ------------------------------------------------------------------------ prop_satToMaxSAT2_forward :: Property@@ -114,6 +230,14 @@ Just v -> v <= threshold ] +prop_satToMaxSAT2_json :: Property+prop_satToMaxSAT2_json =+ forAll arbitraryCNF $ \cnf ->+ let ret@(_, info) = satToMaxSAT2 cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_simplifyMaxSAT2_forward :: Property prop_simplifyMaxSAT2_forward = forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->@@ -128,6 +252,14 @@ b2 = o2 <= th2 ] +prop_simplifyMaxSAT2_json :: Property+prop_simplifyMaxSAT2_json =+ forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->+ let ret@(_, info) = simplifyMaxSAT2 (wcnf, th1)+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_maxSAT2ToSimpleMaxCut_forward :: Property prop_maxSAT2ToSimpleMaxCut_forward = forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->@@ -142,6 +274,55 @@ b2 = o2 >= th2 ] +prop_maxSAT2ToSimpleMaxCut_backward :: Property+prop_maxSAT2ToSimpleMaxCut_backward =+ forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->+ let r@((g, th2), info) = maxSAT2ToSimpleMaxCut (wcnf, th1)+ in counterexample (show r) $+ forAll (arbitraryCut g) $ \cut ->+ if MaxCut.eval cut g >= th2 then+ case evalWCNF (transformBackward info cut) wcnf of+ Nothing -> False+ Just v -> v <= th1+ else+ True++prop_maxSAT2ToSimpleMaxCut_json :: Property+prop_maxSAT2ToSimpleMaxCut_json =+ forAll arbitraryMaxSAT2 $ \(wcnf, th1) ->+ let ret@(_, info) = maxSAT2ToSimpleMaxCut (wcnf, th1)+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++-- -- Too Slow+-- prop_satToSimpleMaxCut_forward :: Property+-- prop_satToSimpleMaxCut_forward =+-- forAll arbitraryCNF $ \cnf ->+-- let ret@((g, threshold), info) = satToSimpleMaxCut cnf+-- in counterexample (show ret) $+-- forAllAssignments (CNF.cnfNumVars cnf) $ \m ->+-- evalCNF m cnf === (MaxCut.eval (transformForward info m) g >= threshold)++-- -- Too Slow+-- prop_satToSimpleMaxCut_backward :: Property+-- prop_satToSimpleMaxCut_backward = forAll arbitraryCNF $ \cnf ->+-- let ret@((g, threshold),info) = satToSimpleMaxCut cnf+-- in counterexample (show ret) $+-- forAll (arbitraryCut g) $ \cut ->+-- if MaxCut.eval cut g >= threshold then+-- evalCNF (transformBackward info cut) cnf+-- else+-- True++prop_satToSimpleMaxCut_json :: Property+prop_satToSimpleMaxCut_json =+ forAll arbitraryCNF $ \cnf ->+ let ret@(_, info) = satToSimpleMaxCut cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ ------------------------------------------------------------------------ prop_satToIS_forward :: Property@@ -150,7 +331,7 @@ let r@((g,k), info) = satToIS cnf in counterexample (show r) $ conjoin [ counterexample (show m) $ counterexample (show set) $- not (evalCNF m cnf) || (isIndependentSet g set && IntSet.size set >= k)+ not (evalCNF m cnf) || (set `isIndependentSetOf` g && IntSet.size set >= k) | m <- allAssignments (CNF.cnfNumVars cnf) , let set = transformForward info m ]@@ -165,6 +346,14 @@ in counterexample (show m) $ not (IntSet.size set >= k) || evalCNF m cnf +prop_satToIS_json :: Property+prop_satToIS_json =+ forAll arbitraryCNF $ \cnf -> do+ let r@(_, info) = satToIS cnf+ json = J.encode info+ in counterexample (show r) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_mis2MaxSAT_forward :: Property prop_mis2MaxSAT_forward = forAll arbitraryGraph $ \g -> do@@ -173,7 +362,7 @@ [ counterexample (show set) $ counterexample (show m) $ o1 === o2 | set <- map IntSet.fromList $ allSubsets $ range $ bounds g , let m = transformForward info set- o1 = if isIndependentSet g set+ o1 = if set `isIndependentSetOf` g then Just (transformObjValueForward info (IntSet.size set)) else Nothing o2 = evalWCNF m wcnf@@ -190,12 +379,58 @@ [ counterexample (show m) $ counterexample (show set) $ o1 === o2 | m <- allAssignments (CNF.wcnfNumVars wcnf) , let set = transformBackward info m- o1 = if isIndependentSet g set+ o1 = if set `isIndependentSetOf` g then Just (IntSet.size set) else Nothing o2 = fmap (transformObjValueBackward info) $ evalWCNF m wcnf ] +prop_mis2MaxSAT_json :: Property+prop_mis2MaxSAT_json =+ forAll arbitraryGraph $ \g -> do+ let r@(_, info) = mis2MaxSAT g+ json = J.encode info+ in counterexample (show r) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_is2pb_forward :: Property+prop_is2pb_forward =+ forAll arbitraryGraph $ \g ->+ forAll arbitrary $ \(Positive k) ->+ let ret@(opb,info) = is2pb (g, k)+ in counterexample (show ret) $ conjoin+ [ counterexample (show set) $ counterexample (show m) $ o1 === o2+ | set <- map IntSet.fromList $ allSubsets $ range $ bounds g+ , let m = transformForward info set+ o1 = set `isIndependentSetOf` g && IntSet.size set >= k+ o2 = isJust $ SAT.evalPBFormula m opb+ ]+ where+ allSubsets :: [a] -> [[a]]+ allSubsets = filterM (const [False, True])++prop_is2pb_backward :: Property+prop_is2pb_backward =+ forAll arbitraryGraph $ \g ->+ forAll arbitrary $ \(Positive k) ->+ let ret@(opb,info) = is2pb (g, k)+ in counterexample (show ret) $ conjoin+ [ counterexample (show m) $ counterexample (show set) $ o1 === o2+ | m <- allAssignments (PBFile.pbNumVars opb)+ , let set = transformBackward info m+ o1 = set `isIndependentSetOf` g && IntSet.size set >= k+ o2 = isJust $ SAT.evalPBFormula m opb+ ]++prop_is2pb_json :: Property+prop_is2pb_json =+ forAll arbitraryGraph $ \g ->+ forAll arbitrary $ \(Positive k) ->+ let ret@(_,info) = is2pb (g, k)+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ arbitraryGraph :: Gen Graph arbitraryGraph = do n <- choose (0, 8) -- inclusive range@@ -230,23 +465,58 @@ ------------------------------------------------------------------------ +prop_sat2pb_forward :: Property+prop_sat2pb_forward = forAll arbitraryCNF $ \cnf ->+ let ret@(opb,info) = sat2pb cnf+ in counterexample (show ret) $+ forAllAssignments (CNF.cnfNumVars cnf) $ \m ->+ evalCNF m cnf === isJust (SAT.evalPBFormula (transformForward info m) opb)++prop_sat2pb_backward :: Property+prop_sat2pb_backward = forAll arbitraryCNF $ \cnf ->+ let ret@(opb,info) = sat2pb cnf+ in counterexample (show ret) $+ forAllAssignments (PBFile.pbNumVars opb) $ \m ->+ evalCNF (transformBackward info m) cnf === isJust (SAT.evalPBFormula m opb)++prop_sat2pb_json :: Property+prop_sat2pb_json = forAll arbitraryCNF $ \cnf ->+ let ret@(_,info) = sat2pb cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_maxsat2wbo_forward :: Property+prop_maxsat2wbo_forward = forAll arbitraryWCNF $ \cnf ->+ let ret@(wbo,info) = maxsat2wbo cnf+ in counterexample (show ret) $+ forAllAssignments (CNF.wcnfNumVars cnf) $ \m ->+ fmap (transformObjValueForward info) (evalWCNF m cnf) === SAT.evalPBSoftFormula (transformForward info m) wbo++prop_maxsat2wbo_backward :: Property+prop_maxsat2wbo_backward = forAll arbitraryWCNF $ \cnf ->+ let ret@(wbo,info) = maxsat2wbo cnf+ in counterexample (show ret) $+ forAllAssignments (PBFile.wboNumVars wbo) $ \m ->+ evalWCNF (transformBackward info m) cnf === fmap (transformObjValueBackward info) (SAT.evalPBSoftFormula m wbo)++prop_maxsat2wbo_json :: Property+prop_maxsat2wbo_json = forAll arbitraryWCNF $ \cnf ->+ let ret@(_,info) = maxsat2wbo cnf+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ 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+ opb <- QM.pick arbitraryPBFormula + strategy <- QM.pick arbitrary+ let (cnf, info) = pb2satWith strategy opb+ solver1 <- arbitrarySolver solver2 <- arbitrarySolver- ret1 <- QM.run $ solvePB solver1 pb+ ret1 <- QM.run $ solvePBFormula solver1 opb ret2 <- QM.run $ solveCNF solver2 cnf QM.assert $ isJust ret1 == isJust ret2 case ret1 of@@ -259,80 +529,99 @@ Nothing -> return () Just m2 -> do let m1 = transformBackward info m2- QM.assert $ bounds m1 == (1, nv)- QM.assert $ evalPB m1 pb+ QM.assert $ bounds m1 == (1, PBFile.pbNumVars opb)+ QM.assert $ isJust $ SAT.evalPBFormula m1 opb +prop_pb2sat_json :: Property+prop_pb2sat_json =+ forAll arbitraryPBFormula $ \opb ->+ forAll arbitrary $ \strategy ->+ let ret@(_, info) = pb2satWith strategy opb+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ 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- )+ wbo <- QM.pick arbitraryPBSoftFormula+ let (wcnf, info) = wbo2maxsat wbo solver1 <- arbitrarySolver solver2 <- arbitrarySolver method <- QM.pick arbitrary- ret1 <- QM.run $ optimizeWBO solver1 method wbo1- ret2 <- QM.run $ optimizeWBO solver2 method wbo2+ ret1 <- QM.run $ optimizePBSoftFormula solver1 method wbo+ ret2 <- QM.run $ optimizeWCNF solver2 method wcnf 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+ QM.assert $ evalWCNF m2 wcnf == Just (transformObjValueForward info 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+ QM.assert $ bounds m1 == (1, PBFile.wboNumVars wbo)+ QM.assert $ SAT.evalPBSoftFormula m1 wbo == Just (transformObjValueBackward info val) +prop_wbo2maxsat_json :: Property+prop_wbo2maxsat_json =+ forAll arbitraryPBSoftFormula $ \wbo ->+ let ret@(_, info) = wbo2maxsat wbo+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_pb2wbo :: Property+prop_pb2wbo = QM.monadicIO $ do+ opb <- QM.pick arbitraryPBFormula+ let (wbo, info) = pb2wbo opb+ QM.monitor $ counterexample (show wbo)++ solver1 <- arbitrarySolver+ solver2 <- arbitrarySolver+ method <- QM.pick arbitrary+ ret1 <- QM.run $ optimizePBFormula solver2 method opb+ ret2 <- QM.run $ optimizePBSoftFormula solver1 method wbo+ QM.monitor $ counterexample (show ret1)+ QM.monitor $ counterexample (show ret2)+ 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.wboNumVars wbo)+ QM.assert $ SAT.evalPBSoftFormula m2 wbo == Just (transformObjValueForward info val1)+ case ret2 of+ Nothing -> return ()+ Just (m2,val2) -> do+ let m1 = transformBackward info m2+ QM.assert $ bounds m1 == (1, PBFile.wboNumVars wbo)+ QM.assert $ SAT.evalPBFormula m1 opb == Just (transformObjValueBackward info val2)++prop_pb2wbo_json :: Property+prop_pb2wbo_json =+ forAll arbitraryPBFormula $ \opb ->+ let ret@(_, info) = pb2wbo opb+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ 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)-- QM.monitor $ counterexample (show wbo')+ wbo <- QM.pick arbitraryPBSoftFormula+ let (opb, info) = wbo2pb wbo QM.monitor $ counterexample (show opb) -- no constant terms in objective function- QM.assert $ all (\(_,ls) -> length ls > 0) obj+ QM.assert $ all (\(_,ls) -> length ls > 0) $ fromMaybe [] (PBFile.pbObjectiveFunction opb) solver1 <- arbitrarySolver solver2 <- arbitrarySolver method <- QM.pick arbitrary- ret1 <- QM.run $ optimizeWBO solver1 method wbo- ret2 <- QM.run $ optimizePBNLC solver2 method pb+ ret1 <- QM.run $ optimizePBSoftFormula solver1 method wbo+ ret2 <- QM.run $ optimizePBFormula solver2 method opb QM.monitor $ counterexample (show ret1) QM.monitor $ counterexample (show ret2) QM.assert $ isJust ret1 == isJust ret2@@ -341,15 +630,22 @@ 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+ QM.assert $ SAT.evalPBFormula m2 opb == Just (transformObjValueForward info 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+ QM.assert $ bounds m1 == (1, PBFile.wboNumVars wbo)+ QM.assert $ SAT.evalPBSoftFormula m1 wbo == Just (transformObjValueBackward info val2) +prop_wbo2pb_json :: Property+prop_wbo2pb_json =+ forAll arbitraryPBSoftFormula $ \wbo ->+ let ret@(_, info) = wbo2pb wbo+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_sat2ksat :: Property prop_sat2ksat = QM.monadicIO $ do k <- QM.pick $ choose (3,10)@@ -375,6 +671,75 @@ QM.assert $ bounds m1 == (1, CNF.cnfNumVars cnf1) QM.assert $ evalCNF m1 cnf1 +prop_sat2ksat_json :: Property+prop_sat2ksat_json =+ forAll (choose (3,10)) $ \k ->+ forAll arbitraryCNF $ \cnf1 ->+ let ret@(_, info) = sat2ksat k cnf1+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_linearizePB_forward :: Property+prop_linearizePB_forward =+ forAll arbitraryPBFormula $ \pb ->+ forAll arbitrary $ \b ->+ let ret@(pb2, info) = linearizePB pb b+ in counterexample (show ret) $+ forAllAssignments (PBFile.pbNumVars pb) $ \m ->+ fmap (transformObjValueForward info) (SAT.evalPBFormula m pb) === SAT.evalPBFormula (transformForward info m) pb2++prop_linearizePB_backward :: Property+prop_linearizePB_backward =+ forAll arbitraryPBFormula $ \pb ->+ forAll arbitrary $ \b ->+ let ret@(pb2, info) = linearizePB pb b+ in counterexample (show ret) $+ forAll (arbitraryAssignment (PBFile.pbNumVars pb2)) $ \m2 ->+ case (SAT.evalPBFormula (transformBackward info m2) pb, SAT.evalPBFormula m2 pb2) of+ pair@(Just val1, Just val2) -> counterexample (show pair) $ val1 <= transformObjValueBackward info val2+ pair@(Nothing, Just _) -> counterexample (show pair) $ False+ (_, Nothing) -> property True++prop_linearizePB_json :: Property+prop_linearizePB_json =+ forAll arbitraryPBFormula $ \pb ->+ forAll arbitrary $ \b ->+ let ret@(_, info) = linearizePB pb b+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_linearizeWBO_forward :: Property+prop_linearizeWBO_forward =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(wbo2, info) = linearizeWBO wbo b+ in counterexample (show ret) $+ forAllAssignments (PBFile.wboNumVars wbo) $ \m ->+ fmap (transformObjValueForward info) (SAT.evalPBSoftFormula m wbo) === SAT.evalPBSoftFormula (transformForward info m) wbo2++prop_linearizeWBO_backward :: Property+prop_linearizeWBO_backward =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(wbo2, info) = linearizeWBO wbo b+ in counterexample (show ret) $+ forAll (arbitraryAssignment (PBFile.wboNumVars wbo2)) $ \m2 ->+ case (SAT.evalPBSoftFormula (transformBackward info m2) wbo, SAT.evalPBSoftFormula m2 wbo2) of+ pair@(Just val1, Just val2) -> counterexample (show pair) $ val1 <= transformObjValueBackward info val2+ pair@(Nothing, Just _) -> counterexample (show pair) $ False+ (_, Nothing) -> property True++prop_linearizeWBO_json :: Property+prop_linearizeWBO_json =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(_, info) = linearizeWBO wbo b+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_quadratizePB :: Property prop_quadratizePB = forAll arbitraryPBFormula $ \pb ->@@ -384,10 +749,10 @@ [ 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)+ fmap (transformObjValueForward info) (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+ Just o -> SAT.evalPBFormula (transformBackward info m) pb === Just (transformObjValueBackward info o) Nothing -> property True ] where@@ -404,43 +769,252 @@ guard $ o <= th return o +prop_quadratizePB_json :: Property+prop_quadratizePB_json =+ forAll arbitraryPBFormula $ \pb ->+ let ret@(_, info) = quadratizePB pb+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ 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)+ opb <- QM.pick arbitraryPBFormula 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+ ret1 <- QM.run $ solvePBFormula solver1 opb+ ret2 <- QM.run $ solvePBFormula solver2 opb2 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+ QM.assert $ isJust $ SAT.evalPBFormula m2 opb2 case ret2 of Nothing -> return () Just m2 -> do let m1 = transformBackward info m2- QM.assert $ bounds m1 == (1, nv)- QM.assert $ evalPBNLC m1 pb+ QM.assert $ bounds m1 == (1, PBFile.pbNumVars opb)+ QM.assert $ isJust $ SAT.evalPBFormula m1 opb +prop_inequalitiesToEqualitiesPB_json :: Property+prop_inequalitiesToEqualitiesPB_json = forAll arbitraryPBFormula $ \opb ->+ let ret@(_, info) = inequalitiesToEqualitiesPB opb+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json == Right info++------------------------------------------------------------------------++prop_pb2ip_forward :: Property+prop_pb2ip_forward =+ forAll arbitraryPBFormula $ \pb ->+ let ret@(mip, info) = pb2ip pb+ in counterexample (show ret) $+ forAll (arbitraryAssignment (PBFile.pbNumVars pb)) $ \m ->+ fmap (transformObjValueForward info) (SAT.evalPBFormula m pb)+ ===+ evalMIP (transformForward info m) (fmap fromIntegral mip)++prop_pb2ip_backward :: Property+prop_pb2ip_backward =+ forAll arbitraryPBFormula $ \pb ->+ let ret@(mip, info) = pb2ip pb+ in counterexample (show ret) $+ forAll (arbitraryAssignmentBinaryIP mip) $ \sol ->+ SAT.evalPBFormula (transformBackward info sol) pb+ ===+ fmap (transformObjValueBackward info) (evalMIP sol (fmap fromIntegral mip))++prop_pb2ip_json :: Property+prop_pb2ip_json =+ forAll arbitraryPBFormula $ \pb ->+ let ret@(_, info) = pb2ip pb+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_wbo2ip_forward :: Property+prop_wbo2ip_forward =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(mip, info) = wbo2ip b wbo+ in counterexample (show ret) $+ forAll (arbitraryAssignment (PBFile.wboNumVars wbo)) $ \m ->+ fmap (transformObjValueForward info) (SAT.evalPBSoftFormula m wbo)+ ===+ evalMIP (transformForward info m) (fmap fromIntegral mip)++prop_wbo2ip_backward :: Property+prop_wbo2ip_backward =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(mip, info) = wbo2ip b wbo+ in counterexample (show ret) $+ forAll (arbitraryAssignmentBinaryIP mip) $ \sol ->+ case evalMIP sol (fmap fromIntegral mip) of+ Nothing -> True+ Just val2 ->+ case SAT.evalPBSoftFormula (transformBackward info sol) wbo of+ Nothing -> False+ Just val1 -> val1 <= transformObjValueBackward info val2++prop_wbo2ip_json :: Property+prop_wbo2ip_json =+ forAll arbitraryPBSoftFormula $ \wbo ->+ forAll arbitrary $ \b ->+ let ret@(_, info) = wbo2ip b wbo+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_ip2pb_forward :: Property+prop_ip2pb_forward =+ forAll arbitraryBoundedIP $ \ip ->+ case ip2pb ip of+ Left err -> counterexample err $ property False+ Right ret@(pb, info) ->+ counterexample (show ret) $+ forAll (arbitraryAssignmentBoundedIP ip) $ \sol ->+ fmap (transformObjValueForward info) (evalMIP sol ip)+ ===+ SAT.evalPBFormula (transformForward info sol) pb++prop_ip2pb_backward :: Property+prop_ip2pb_backward =+ forAll arbitraryBoundedIP $ \ip ->+ case ip2pb ip of+ Left err -> counterexample err $ property False+ Right ret@(pb, info) ->+ counterexample (show ret) $+ forAll (arbitraryAssignment (PBFile.pbNumVars pb)) $ \m ->+ case SAT.evalPBFormula m pb of+ Nothing -> property True+ Just val -> evalMIP (transformBackward info m) ip === Just (transformObjValueBackward info val)++prop_ip2pb_backward' :: Property+prop_ip2pb_backward' =+ forAll arbitraryBoundedIP $ \ip ->+ case ip2pb ip of+ Left err -> counterexample err $ property False+ Right ret@(pb, info) ->+ counterexample (show ret) $+ QM.monadicIO $ do+ solver <- arbitrarySolver+ -- Using optimizePBFormula is too slow for using in QuickCheck+ ret2 <- QM.run $ solvePBFormula solver pb+ case ret2 of+ Nothing -> return ()+ Just m -> QM.assert $ isJust $ evalMIP (transformBackward info m) ip++prop_ip2pb_json :: Property+prop_ip2pb_json =+ forAll arbitraryBoundedIP $ \ip ->+ case ip2pb ip of+ Left err -> counterexample err $ property False+ Right ret@(_, info) ->+ let json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++arbitraryBoundedIP :: Gen (MIP.Problem Rational)+arbitraryBoundedIP = do+ nv <- choose (0,10)+ bs <- liftM Map.fromList $ forM [0..nv-1] $ \(i :: Int) -> do+ let v = fromString ("z" ++ show i)+ b <- arbitrary+ if b then+ pure (v, (MIP.Finite 0, MIP.Finite 1))+ else do+ lb <- arbitrary+ NonNegative w <- arbitrary+ let ub = fromInteger (ceiling lb) + w+ return (v, (MIP.Finite lb, MIP.Finite ub))+ let vs = Map.keys bs+ vs_bin = [v | (v, (MIP.Finite 0, MIP.Finite 1)) <- Map.toList bs]++ dir <- elements [MIP.OptMin, MIP.OptMax]+ obj <- arbitraryMIPExpr vs++ nc <- choose (0,3)+ cs <- replicateM nc $ do+ ind <-+ if null vs_bin then+ pure Nothing+ else do+ b <- arbitrary+ if b then+ pure Nothing+ else do+ v <- elements vs_bin+ rhs <- elements [0, 1]+ pure $ Just (v, rhs)+ e <- arbitraryMIPExpr vs+ lb <- oneof [pure MIP.NegInf, MIP.Finite <$> arbitrary, pure MIP.PosInf]+ ub <- oneof $ [pure MIP.NegInf, MIP.Finite <$> arbitrary, pure MIP.PosInf] ++ [pure lb | case lb of{ MIP.Finite _ -> True; _ -> False }]+ isLazy <- arbitrary+ return $ MIP.def+ { MIP.constrIndicator = ind+ , MIP.constrExpr = e+ , MIP.constrLB = lb+ , MIP.constrUB = ub+ , MIP.constrIsLazy = isLazy+ }++ sos <-+ if length vs == 0 then+ pure []+ else do+ n <- choose (0, 1)+ replicateM n $ do+ t <- elements [MIP.S1, MIP.S2]+ m <- choose (0, length vs `div` 2)+ xs <- liftM (take m) $ shuffle vs+ ns <- shuffle (map fromIntegral [0 .. length xs - 1])+ pure (MIP.SOSConstraint{ MIP.sosLabel = Nothing, MIP.sosType = t, MIP.sosBody = zip xs ns })++ return $ MIP.def+ { MIP.objectiveFunction = MIP.def{ MIP.objDir = dir, MIP.objExpr = obj }+ , MIP.varDomains = fmap (\b -> (MIP.IntegerVariable, b)) bs+ , MIP.constraints = cs+ , MIP.sosConstraints = sos+ }++arbitraryMIPExpr :: [MIP.Var] -> Gen (MIP.Expr Rational)+arbitraryMIPExpr vs = do+ let nv = length vs+ nt <- choose (0,3)+ liftM MIP.Expr $ replicateM nt $ do+ ls <-+ if nv==0+ then return []+ else do+ m <- choose (0,2)+ replicateM m (elements vs)+ c <- arbitrary+ return $ MIP.Term c ls++arbitraryAssignmentBinaryIP :: MIP.Problem a -> Gen (Map MIP.Var Rational)+arbitraryAssignmentBinaryIP mip = liftM Map.fromList $ do+ forM (Map.keys (MIP.varTypes mip)) $ \v -> do+ val <- choose (0, 1)+ pure (v, fromInteger val)++arbitraryAssignmentBoundedIP :: RealFrac a => MIP.Problem a -> Gen (Map MIP.Var Rational)+arbitraryAssignmentBoundedIP mip = liftM Map.fromList $ do+ forM (Map.toList (MIP.varBounds mip)) $ \case+ (v, (MIP.Finite lb, MIP.Finite ub)) -> do+ val <- choose (ceiling lb, floor ub)+ pure (v, fromInteger val)+ _ -> error "should not happen"++evalMIP :: Map MIP.Var Rational -> MIP.Problem Rational -> Maybe Rational+evalMIP = MIP.eval MIP.zeroTol++------------------------------------------------------------------------ converterTestGroup :: TestTree converterTestGroup = $(testGroupGenerator)
+ test/Test/Graph.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Test.Graph (graphTestGroup) where++import Control.Monad+import Data.Array+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.Tasty.TH++import ToySolver.Graph.Base+++-- ------------------------------------------------------------------------++arbitraryGraph :: Int -> Gen Graph+arbitraryGraph n = do+ m <- choose (0, n*n-1)+ fmap (graphFromUnorderedEdges n) $ replicateM m $ do+ node1 <- choose (0, n-1)+ node2 <- fmap (\i -> (node1 + i) `mod` n) $ choose (0, n-1)+ return (node1, node2, ())++arbitraryDiGraph :: Int -> Gen Graph+arbitraryDiGraph n = do+ m <- choose (0, n*n-1)+ fmap (graphFromEdges n) $ replicateM m $ do+ node1 <- choose (0, n-1)+ node2 <- fmap (\i -> (node1 + i) `mod` n) $ choose (0, n-1)+ return (node1, node2, ())++arbitrarySimpleGraph :: Int -> Gen Graph+arbitrarySimpleGraph n = do+ m <- choose (0, n*n-1)+ fmap (graphFromUnorderedEdges n) $ replicateM m $ do+ node1 <- choose (0, n-1)+ node2 <- fmap (\i -> (node1 + i) `mod` n) $ choose (1, n-1)+ return (node1, node2, ())++vertexes :: EdgeLabeledGraph a -> IntSet+vertexes = IntSet.fromAscList . uncurry enumFromTo . bounds++arbitrarySubset :: IntSet -> Gen IntSet+arbitrarySubset = fmap IntSet.fromAscList . sublistOf . IntSet.toAscList++-- ------------------------------------------------------------------------++case_graphFromEdgesWith :: Assertion+case_graphFromEdgesWith = do+ let g = graphFromEdgesWith (++) 2 [(0, 1, ["world"]), (0, 1, ["hello"])]+ graphToEdges g @?= [(0, 1, ["hello", "world"])]++case_graphFromUnorderedEdgesWith :: Assertion+case_graphFromUnorderedEdgesWith = do+ let g = graphFromUnorderedEdgesWith (++) 2 [(0, 1, ["world"]), (1, 0, ["hello"])]+ graphToUnorderedEdges g @?= [(0, 1, ["hello", "world"])]++prop_graphToEdges :: Property+prop_graphToEdges =+ forAll arbitrary $ \(NonNegative n) -> do+ forAll (arbitraryDiGraph n) $ \g ->+ g === graphFromEdges n (graphToEdges g)++prop_converseGraph_involution :: Property+prop_converseGraph_involution =+ forAll arbitrary $ \(NonNegative n) -> do+ forAll (arbitraryDiGraph n) $ \g ->+ g === converseGraph (converseGraph g)++prop_converseGraph_unordered :: Property+prop_converseGraph_unordered =+ forAll arbitrary $ \(NonNegative n) -> do+ forAll (arbitraryGraph n) $ \g ->+ g === converseGraph g++prop_graphToUnorderedEdges :: Property+prop_graphToUnorderedEdges =+ forAll arbitrary $ \(NonNegative n) -> do+ forAll (arbitraryGraph n) $ \g ->+ g === graphFromUnorderedEdges n (graphToUnorderedEdges g)++prop_independent_set_and_clique :: Property+prop_independent_set_and_clique =+ forAll arbitrary $ \(NonNegative n) -> do+ forAll (arbitrarySimpleGraph n) $ \g ->+ forAll (arbitrarySubset (vertexes g)) $ \s -> do+ counterexample (show (graphToUnorderedEdges g)) $+ s `isIndependentSetOf` g === s `isCliqueOf` complementSimpleGraph g++-- ------------------------------------------------------------------------+-- Test harness++graphTestGroup :: TestTree+graphTestGroup = $(testGroupGenerator)
test/Test/GraphShortestPath.hs view
@@ -4,7 +4,6 @@ module Test.GraphShortestPath (graphShortestPathTestGroup) where import Control.Monad-import Data.Hashable import Data.Monoid import Test.Tasty import Test.Tasty.HUnit
test/Test/HittingSets.hs view
@@ -106,7 +106,9 @@ return $ Set.singleton $ IntSet.delete x is | not (IntSet.null is) ]- return (f,g)+ f' <- mutate f+ g' <- mutate g+ return (f', g') prop_FredmanKhachiyan1996_checkDualityA_prop1 :: Property prop_FredmanKhachiyan1996_checkDualityA_prop1 =
test/Test/QBF.hs view
@@ -18,6 +18,8 @@ import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin import qualified ToySolver.QBF as QBF +import Test.SAT.Utils (arbitraryLit)+ -- ------------------------------------------------------------------- prop_solveCEGAR :: Property@@ -136,7 +138,7 @@ if nv == 0 then return [] else- replicateM len $ choose (-nv, nv) `suchThat` (/= 0)+ replicateM len $ arbitraryLit nv return ( nv
test/Test/QUBO.hs view
@@ -4,6 +4,7 @@ module Test.QUBO (quboTestGroup) where import Control.Monad+import qualified Data.Aeson as J import Data.Array.IArray import Data.ByteString.Builder import qualified Data.IntMap.Strict as IntMap@@ -90,6 +91,27 @@ let (pbo,_) = qubo2pb qubo in Just qubo === fmap fst (pbAsQUBO pbo) +prop_qubo2pb_forward :: Property+prop_qubo2pb_forward = forAll arbitrary $ \(qubo :: QUBO.Problem Integer) ->+ let (pbo, info) = qubo2pb qubo+ in counterexample (show pbo) $+ forAll (arbitrarySolution (QUBO.quboNumVars qubo)) $ \sol ->+ Just (transformObjValueForward info (QUBO.eval sol qubo)) === SAT.evalPBFormula (transformForward info sol) pbo++prop_qubo2pb_backward :: Property+prop_qubo2pb_backward = forAll arbitrary $ \(qubo :: QUBO.Problem Integer) ->+ let (pbo, info) = qubo2pb qubo+ in counterexample (show pbo) $+ forAll (arbitraryAssignment (PBFile.pbNumVars pbo)) $ \m ->+ Just (QUBO.eval (transformBackward info m) qubo) === fmap (transformObjValueBackward info) (SAT.evalPBFormula m pbo)++prop_qubo2pb_json :: Property+prop_qubo2pb_json = forAll arbitrary $ \(qubo :: QUBO.Problem Integer) ->+ let ret@(pbo, info) = qubo2pb qubo+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_pb2qubo :: Property prop_pb2qubo = forAll arbitraryPBFormula $ \formula -> let ((qubo :: QUBO.Problem Integer, th), info) = pb2qubo formula@@ -115,19 +137,59 @@ property True ] +prop_pb2qubo_json :: Property+prop_pb2qubo_json = forAll arbitraryPBFormula $ \formula ->+ let ret@(_, info) = pb2qubo formula+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info+ prop_qubo2ising :: Property prop_qubo2ising = forAll arbitrary $ \(qubo :: QUBO.Problem Rational) ->+ let (ising, _) = qubo2ising qubo+ in qubo === fst (ising2qubo ising)++prop_qubo2ising_forward :: Property+prop_qubo2ising_forward = 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+ transformObjValueForward info (QUBO.eval sol qubo) === QUBO.evalIsingModel (transformForward info sol) ising -prop_ising2qubo :: Property-prop_ising2qubo = forAll arbitrary $ \(ising :: QUBO.IsingModel Integer) ->+prop_qubo2ising_backward :: Property+prop_qubo2ising_backward = forAll arbitrary $ \(qubo :: QUBO.Problem Rational) ->+ let (ising, info) = qubo2ising qubo+ in counterexample (show ising) $+ forAll (arbitrarySolution (QUBO.isingNumVars ising)) $ \sol ->+ QUBO.eval (transformBackward info sol) qubo === transformObjValueBackward info (QUBO.evalIsingModel sol ising)++prop_qubo2ising_json :: Property+prop_qubo2ising_json = forAll arbitrary $ \(qubo :: QUBO.Problem Rational) ->+ let ret@(_, info) = qubo2ising qubo+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info++prop_ising2qubo_forward :: Property+prop_ising2qubo_forward = 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+ transformObjValueForward info (QUBO.evalIsingModel sol ising) === QUBO.eval (transformForward info sol) qubo++prop_ising2qubo_backward :: Property+prop_ising2qubo_backward = forAll arbitrary $ \(ising :: QUBO.IsingModel Integer) ->+ let (qubo, info) = ising2qubo ising+ in counterexample (show qubo) $+ forAll (arbitrarySolution (QUBO.quboNumVars qubo)) $ \sol ->+ QUBO.evalIsingModel (transformBackward info sol) ising === transformObjValueBackward info (QUBO.eval sol qubo)++prop_ising2qubo_json :: Property+prop_ising2qubo_json = forAll arbitrary $ \(ising :: QUBO.IsingModel Integer) ->+ let ret@(_, info) = ising2qubo ising+ json = J.encode info+ in counterexample (show ret) $ counterexample (show json) $+ J.eitherDecode json === Right info ------------------------------------------------------------------------ -- Test harness
test/Test/SAT.hs view
@@ -148,8 +148,8 @@ ret @?= True SAT.addClause solver [-x1, x2] -- not x1 or x2- ret <- SAT.solve solver -- unsat- ret @?= False+ ret2 <- SAT.solve solver -- unsat+ ret2 @?= False -- 制約なし case_empty_constraint :: Assertion@@ -209,8 +209,8 @@ ret @?= True SAT.addAtLeast solver [-x1,-x2,-x3,-x4] 2- ret <- SAT.solve solver- ret @?= True+ ret2 <- SAT.solve solver+ ret2 @?= True case_inconsistent_AtLeast :: Assertion case_inconsistent_AtLeast = do@@ -223,19 +223,20 @@ 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+ do+ solver <- SAT.newSolver+ x1 <- SAT.newVar solver+ x2 <- SAT.newVar solver+ SAT.addAtLeast solver [x1,x2] 0+ ret <- SAT.solve solver+ ret @?= True+ do+ 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@@ -340,14 +341,14 @@ 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+ ret2 <- SAT.solve solver -- sat+ ret2 @?= True - ret <- SAT.solveWith solver [x3] -- unsat- ret @?= False+ ret3 <- SAT.solveWith solver [x3] -- unsat+ ret3 @?= False - ret <- SAT.solve solver -- sat- ret @?= True+ ret4 <- SAT.solve solver -- sat+ ret4 @?= True case_solveWith_2 :: Assertion case_solveWith_2 = do@@ -360,8 +361,8 @@ ret <- SAT.solveWith solver [x2] ret @?= True - ret <- SAT.solveWith solver [-x2]- ret @?= False+ ret2 <- SAT.solveWith solver [-x2]+ ret2 @?= False case_getVarFixed :: Assertion case_getVarFixed = do@@ -375,14 +376,14 @@ SAT.addClause solver [-x1] - ret <- SAT.getVarFixed solver x1- ret @?= lFalse+ ret2 <- SAT.getVarFixed solver x1+ ret2 @?= lFalse - ret <- SAT.getLitFixed solver (-x1)- ret @?= lTrue+ ret3 <- SAT.getLitFixed solver (-x1)+ ret3 @?= lTrue - ret <- SAT.getLitFixed solver x2- ret @?= lTrue+ ret4 <- SAT.getLitFixed solver x2+ ret4 @?= lTrue case_getAssumptionsImplications_case1 :: Assertion case_getAssumptionsImplications_case1 = do@@ -617,7 +618,7 @@ m <- try (SAT.solve solver) case m of- Left (e :: SAT.Canceled) -> return ()+ Left (_ :: SAT.Canceled) -> return () Right x -> assertFailure ("Canceled should be thrown: " ++ show x) case_clearTerminateCallback :: IO ()@@ -655,6 +656,33 @@ _ <- SAT.solve solver learnt <- readIORef learntRef assertBool "learn callback should not have been called" (null learnt)++------------------------------------------------------------------------++prop_SOS2 :: Property+prop_SOS2 = QM.monadicIO $ do+ cnf <- QM.pick arbitraryCNF+ sos2 <- QM.pick $ do+ n <- choose (0, CNF.cnfNumVars cnf)+ replicateM n (arbitraryLit (CNF.cnfNumVars cnf))++ solver <- arbitrarySolver+ ret <- QM.run $ do+ SAT.newVars_ solver (CNF.cnfNumVars cnf)+ forM_ (CNF.cnfClauses cnf) $ \c -> SAT.addClause solver (SAT.unpackClause c)+ SAT.addSOS2 solver sos2+ 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 && SAT.evalSOS2 m sos2+ Nothing -> do+ forM_ (allAssignments (CNF.cnfNumVars cnf)) $ \m -> do+ QM.assert $ not (evalCNF m cnf && SAT.evalSOS2 m sos2) ------------------------------------------------------------------------ -- Test harness
test/Test/SAT/Encoder.hs view
@@ -30,6 +30,7 @@ import qualified ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer as Totalizer import qualified ToySolver.SAT.Encoder.PB as PB import qualified ToySolver.SAT.Encoder.PB.Internal.Sorter as PBEncSorter+import qualified ToySolver.SAT.Encoder.PB.Internal.BCCNF as BCCNF import qualified ToySolver.SAT.Store.CNF as CNFStore import Test.SAT.Utils@@ -160,11 +161,69 @@ 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]+ m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- IntMap.toList defs] b1 = SAT.evalPBLinAtLeast m (lhs,rhs) b2 = evalCNF (array (bounds m2) (assocs m2)) cnf QM.assert $ b1 == b2 +prop_PBEncoder_encodePBLinAtLeastWithPolarity :: Property+prop_PBEncoder_encodePBLinAtLeastWithPolarity = QM.monadicIO $ do+ let nv = 4+ constr <- QM.pick $ do+ lhs <- arbitraryPBLinSum nv+ rhs <- arbitrary+ return (lhs, rhs)+ strategy <- QM.pick arbitrary+ polarity <- QM.pick arbitrary+ (l,cnf,defs,defs2) <- QM.run $ do+ db <- CNFStore.newCNFStore+ SAT.newVars_ db nv+ tseitin <- Tseitin.newEncoder db+ encoder@(PB.Encoder card _) <- PB.newEncoderWithStrategy tseitin strategy+ l <- PB.encodePBLinAtLeastWithPolarity encoder polarity constr+ cnf <- CNFStore.getCNFFormula db+ defs <- Tseitin.getDefinitions tseitin+ defs2 <- Cardinality.getTotalizerDefinitions card+ return (l, cnf, defs, defs2)+ 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) <- IntMap.toList defs] +++ Cardinality.evalTotalizerDefinitions m2 defs2+ b1 = evalCNF (array (bounds m2) (assocs m2)) cnf+ cmp a b = isJust $ do+ when (Tseitin.polarityPosOccurs polarity) $ guard (not a || b)+ when (Tseitin.polarityNegOccurs polarity) $ guard (not b || a)+ QM.assert $ not b1 || (SAT.evalLit m2 l `cmp` SAT.evalPBLinAtLeast m constr)++prop_PBEncoder_encodePBLinAtLeastWithPolarity_2 :: Property+prop_PBEncoder_encodePBLinAtLeastWithPolarity_2 = QM.monadicIO $ do+ nv <- QM.pick $ choose (1, 10)+ constr <- QM.pick $ do+ lhs <- arbitraryPBLinSum nv+ rhs <- arbitrary+ return (lhs, rhs)+ strategy <- QM.pick arbitrary+ polarity <- QM.pick arbitrary+ join $ QM.run $ do+ solver <- SAT.newSolver+ SAT.newVars_ solver nv+ tseitin <- Tseitin.newEncoder solver+ encoder <- PB.newEncoderWithStrategy tseitin strategy+ l <- PB.encodePBLinAtLeastWithPolarity encoder polarity constr+ ret <- SAT.solve solver+ if not ret then do+ return $ QM.assert False+ else do+ m <- SAT.getModel solver+ let a = SAT.evalLit m l+ b = SAT.evalPBLinAtLeast m constr+ return $ do+ QM.monitor $ counterexample (show (a,b))+ when (Tseitin.polarityPosOccurs polarity) $ QM.assert (not a || b)+ when (Tseitin.polarityNegOccurs polarity) $ QM.assert (not b || a)+ prop_PBEncoder_Sorter_genSorter :: [Int] -> Bool prop_PBEncoder_Sorter_genSorter xs = V.toList (PBEncSorter.sortVector (V.fromList xs)) == sort xs@@ -178,18 +237,23 @@ ==> (PBEncSorter.decode base . PBEncSorter.encode base) x == x ++arbitraryAtLeast :: Int -> Gen SAT.AtLeast+arbitraryAtLeast nv = 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)++ 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)+ (lhs,rhs) <- QM.pick $ arbitraryAtLeast nv strategy <- QM.pick arbitrary (cnf,defs,defs2) <- QM.run $ do db <- CNFStore.newCNFStore@@ -205,7 +269,7 @@ let m2 :: Array SAT.Var Bool m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++- [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs] +++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- IntMap.toList defs] ++ Cardinality.evalTotalizerDefinitions m2 defs2 b1 = SAT.evalAtLeast m (lhs,rhs) b2 = evalCNF (array (bounds m2) (assocs m2)) cnf@@ -291,25 +355,18 @@ QM.assert $ and [x `elem` xs1 || x `elem` xs2 || lbs !! (x-1) == liftBool e | x <- xs] -prop_encodeAtLeast :: Property-prop_encodeAtLeast = QM.monadicIO $ do+prop_encodeAtLeastWithPolarity :: Property+prop_encodeAtLeastWithPolarity = 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)+ (lhs,rhs) <- QM.pick $ arbitraryAtLeast nv strategy <- QM.pick arbitrary+ polarity <- QM.pick arbitrary (l,cnf,defs,defs2) <- QM.run $ do db <- CNFStore.newCNFStore SAT.newVars_ db nv tseitin <- Tseitin.newEncoder db card <- Cardinality.newEncoderWithStrategy tseitin strategy- l <- Cardinality.encodeAtLeast card (lhs, rhs)+ l <- Cardinality.encodeAtLeastWithPolarity card polarity (lhs, rhs) cnf <- CNFStore.getCNFFormula db defs <- Tseitin.getDefinitions tseitin defs2 <- Cardinality.getTotalizerDefinitions card@@ -318,11 +375,167 @@ let m2 :: Array SAT.Var Bool m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++- [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs] +++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- IntMap.toList defs] ++ Cardinality.evalTotalizerDefinitions m2 defs2 b1 = evalCNF (array (bounds m2) (assocs m2)) cnf- QM.assert $ not b1 || (SAT.evalLit m2 l == SAT.evalAtLeast m (lhs,rhs))+ cmp a b = isJust $ do+ when (Tseitin.polarityPosOccurs polarity) $ guard (not a || b)+ when (Tseitin.polarityNegOccurs polarity) $ guard (not b || a)+ QM.assert $ not b1 || (SAT.evalLit m2 l `cmp` SAT.evalAtLeast m (lhs,rhs)) +prop_encodeAtLeastWithPolarity_2 :: Property+prop_encodeAtLeastWithPolarity_2 = QM.monadicIO $ do+ nv <- QM.pick $ choose (1, 10)+ constr <- QM.pick $ arbitraryAtLeast nv+ strategy <- QM.pick arbitrary+ polarity <- QM.pick arbitrary+ join $ QM.run $ do+ solver <- SAT.newSolver+ SAT.newVars_ solver nv+ tseitin <- Tseitin.newEncoder solver+ card <- Cardinality.newEncoderWithStrategy tseitin strategy+ l <- Cardinality.encodeAtLeastWithPolarity card polarity constr+ ret <- SAT.solve solver+ if not ret then do+ return $ QM.assert False+ else do+ m <- SAT.getModel solver+ let a = SAT.evalLit m l+ b = SAT.evalAtLeast m constr+ return $ do+ QM.monitor $ counterexample (show (a,b))+ when (Tseitin.polarityPosOccurs polarity) $ QM.assert (not a || b)+ when (Tseitin.polarityNegOccurs polarity) $ QM.assert (not b || a)++-- ------------------------------------------------------------------------++case_BCCNF_example :: Assertion+case_BCCNF_example = do+ let -- 5 x1 + 3 x2 + 3 x3 + 3 x4 + 3 x5 + x6 >= 9+ input = ([(5,1),(3,2),(3,3),(3,4),(3,5),(1,6)], 9)+ -- (s1 ≥ 1 ∨ s5 ≥ 3) ∧ (s6 ≥ 3)+ expected =+ [ [([1], 1), ([1,2,3,4,5], 3)]+ , [([1,2,3,4,5,6], 3)]+ ]++ -- 2 s1 + 2 s5 + s6+ let lhs' = [(2,1,[1]), (2,5,[1..5]), (1,6,[1..6])]+ BCCNF.toPrefixSum (fst input) @?= lhs'++ let _bccnf0, bccnf1 :: BCCNF.BCCNF+ _bccnf0 =+ [ [(1,[1..1],1), (2,[1..2],2)]+ , [(1,[1..1],1), (5,[1..5],3), (6,[1..6],5)]+ , [(1,[1..1],1), (5,[1..5],4), (6,[1..6],3)]+ , [(1,[1..1],1), (5,[1..5],5), (6,[1..6],1)]+ , [(5,[1..5],1)]+ , [(5,[1..5],2), (6,[1..6],5)]+ , [(5,[1..5],3), (6,[1..6],3)]+ , [(5,[1..5],4), (6,[1..6],1)]+ ]+ bccnf1 =+ [ [(1,[1..1],1), (5,[1..5],3)]+ , [(5,[1..5],2)]+ , [(5,[1..5],3), (6,[1..6],3)]+ ]+ bccnf2 =+ [ [(1,[1..1],1), (5,[1..5],3)]+ , [(6,[1..6],3)]+ ]+ BCCNF.encodePrefixSum lhs' 9 @?= bccnf1++ assertBool "(s5 >= 3) should imply (s6 >= 3)" $ BCCNF.implyBCLit (5,[1..5],3) (6,[1..6],3)+ assertBool "(s6 >= 3) should imply (s5 >= 2)" $ BCCNF.implyBCLit (6,[1..6],3) (5,[1..5],2)+ assertBool "((s5 >= 3) or (s6 >= 3)) should imply (s5 >= 2) as clauses" $ BCCNF.implyBCClause [(5,[1..5],3), (6,[1..6],3)] [(5,[1..5],2)]+ assertBool "(s6 >= 3) should imply (s5 >= 2) as clauses" $ BCCNF.implyBCClause [(6,[1..6],3)] [(5,[1..5],2)]++ BCCNF.reduceBCCNF bccnf1 @?= bccnf2++ BCCNF.encode input @?= expected++case_BCCNF_algorithm2_bug :: Assertion+case_BCCNF_algorithm2_bug = do+ let lhs = [(7,1),(6,2),(5,3),(4,4),(3,5)]+ rhs = 14+ lhs' = BCCNF.toPrefixSum lhs+ bccnf = BCCNF.encodePrefixSumBuggy lhs' rhs+ m :: SAT.Model+ m = array (1,5) [(1,True),(2,False),(3,False),(4,True),(5,True)]+ a = SAT.evalPBLinAtLeast m (lhs,rhs)+ b = eval m bccnf+ assertBool ("Original constraint should be true under (" ++ show m ++ ")") a+ assertBool ("Encoded BCNF is false under (" ++ show m ++ ") due to the bug of Algorithm 2") (not b)+ where+ eval m = and . map (or . map (SAT.evalAtLeast m . BCCNF.toAtLeast))++case_BCCNF_algorithm2_bug_fixed :: Assertion+case_BCCNF_algorithm2_bug_fixed = do+ let lhs = [(7,1),(6,2),(5,3),(4,4),(3,5)]+ rhs = 14+ lhs' = BCCNF.toPrefixSum lhs+ bccnf = BCCNF.encodePrefixSum lhs' rhs+ forM_ (allAssignments 5) $ \m -> do+ assertEqual ("evalution under " ++ show m)+ (SAT.evalPBLinAtLeast m (lhs,rhs)) (eval m bccnf)+ where+ eval m = and . map (or . map (SAT.evalAtLeast m . BCCNF.toAtLeast))++arbitraryPBLinSumForBCCNF :: Int -> Gen SAT.PBLinAtLeast+arbitraryPBLinSumForBCCNF n = BCCNF.preprocess <$> ((,) <$> arbitraryPBLinSum n <*> arbitrary)+{-+arbitraryPBLinSumForBCCNF n = do+ as <- vectorOf n (liftM getPositive arbitrary)+ let bs = init $ scanr (+) 0 as+ c <- arbitrary+ return (zip bs [1..], c)+-}++prop_BCCNF_encodePrefixSumNaive :: Property+prop_BCCNF_encodePrefixSumNaive =+ forAll (choose (1, 8)) $ \nv ->+ forAll (arbitraryPBLinSumForBCCNF nv) $ \constr@(lhs, rhs) ->+ let lhs' = BCCNF.toPrefixSum lhs+ bccnf = BCCNF.encodePrefixSumNaive lhs' rhs+ in counterexample (show lhs') $ counterexample (show bccnf) $ conjoin+ [ counterexample (show m) $+ counterexample (show (map (map (SAT.evalAtLeast m . BCCNF.toAtLeast)) bccnf)) $+ eval m bccnf === SAT.evalPBLinAtLeast m constr+ | m <- allAssignments nv+ ]+ where+ eval m = and . map (or . map (SAT.evalAtLeast m . BCCNF.toAtLeast))++prop_BCCNF_encodePrefixSum :: Property+prop_BCCNF_encodePrefixSum =+ forAll (choose (1, 10)) $ \nv ->+ forAll (arbitraryPBLinSumForBCCNF nv) $ \constr@(lhs, rhs) ->+ let lhs' = BCCNF.toPrefixSum lhs+ bccnf = BCCNF.encodePrefixSum lhs' rhs+ in counterexample (show lhs') $ counterexample (show bccnf) $ conjoin+ [ counterexample (show m) $+ counterexample (show (map (map (SAT.evalAtLeast m . BCCNF.toAtLeast)) bccnf)) $+ eval m bccnf === SAT.evalPBLinAtLeast m constr+ | m <- allAssignments nv+ ]+ where+ eval m = and . map (or . map (SAT.evalAtLeast m . BCCNF.toAtLeast))++prop_BCCNF_encode :: Property+prop_BCCNF_encode =+ forAll (choose (1, 6)) $ \nv ->+ forAll (arbitraryPBLinSumForBCCNF nv) $ \constr ->+ let bccnf = BCCNF.encode constr+ in counterexample (show bccnf) $ conjoin+ [ counterexample (show m) $+ counterexample (show (map (map (SAT.evalAtLeast m)) bccnf)) $+ eval m bccnf === SAT.evalPBLinAtLeast m constr+ | m <- allAssignments nv+ ]+ where+ eval m = and . map (or . map (SAT.evalAtLeast m))++-- ------------------------------------------------------------------------ satEncoderTestGroup :: TestTree satEncoderTestGroup = $(testGroupGenerator)
test/Test/SAT/MUS.hs view
@@ -215,7 +215,7 @@ , [y2,y3,y5,y7,y8,y11] , [y2,y4,y5,y6,y7,y8] -- (*) ]- mcses =+ _mcses = [ [y0,y1,y7] , [y0,y1,y8] , [y0,y3,y4]
test/Test/SAT/Types.hs view
@@ -237,7 +237,7 @@ g = do nv <- choose (0, 10) len <- choose (0, nv)- lhs <- replicateM len $ choose (-nv, nv) `suchThat` (/= 0)+ lhs <- replicateM len $ arbitraryLit nv rhs <- arbitrary return (nv, (lhs,rhs))
test/Test/SAT/Utils.hs view
@@ -42,6 +42,9 @@ bs <- replicateM nv arbitrary return $ array (1,nv) (zip [1..] bs) +arbitraryLit :: Int -> Gen SAT.Lit+arbitraryLit nv = choose (-nv, nv) `suchThat` (/= 0)+ -- --------------------------------------------------------------------- arbitraryCNF :: Gen CNF.CNF@@ -53,7 +56,7 @@ if nv == 0 then return $ SAT.packClause [] else- SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+ SAT.packClause <$> replicateM len (arbitraryLit nv) return $ CNF.CNF { CNF.cnfNumVars = nv@@ -83,7 +86,7 @@ return $ SAT.packClause [] else do len <- choose (0,10)- SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+ SAT.packClause <$> replicateM len (arbitraryLit nv) return (g,c) return $ CNF.GCNF@@ -105,7 +108,7 @@ return $ SAT.packClause [] else do len <- choose (0,10)- SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+ SAT.packClause <$> replicateM len (arbitraryLit nv) return (fmap getPositive w, c) let topCost = sum [w | (Just w, _) <- cs] + 1 return $@@ -153,7 +156,7 @@ return $ SAT.packClause [] else do len <- choose (0,10)- SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+ SAT.packClause <$> replicateM len (arbitraryLit nv) return $ CNF.QDimacs { CNF.qdimacsNumVars = nv@@ -211,7 +214,7 @@ return [] else replicateM len $ do- l <- choose (-nv, nv) `suchThat` (/= 0)+ l <- arbitraryLit nv c <- arbitrary return (c,l) @@ -259,7 +262,7 @@ return [] else replicateM len $ do- ls <- listOf $ choose (-nv, nv) `suchThat` (/= 0)+ ls <- listOf (arbitraryLit nv) c <- arbitrary return (c,ls) rhs <- arbitrary@@ -280,7 +283,7 @@ if nv == 0 then return [] else- replicateM len $ choose (-nv, nv) `suchThat` (/= 0)+ replicateM len $ arbitraryLit nv rhs <- arbitrary return (lhs,rhs) return (nv, cs)@@ -304,7 +307,7 @@ c <- if nv == 0 then return $ SAT.packClause [] else- SAT.packClause <$> (replicateM len $ choose (-nv, nv) `suchThat` (/= 0))+ SAT.packClause <$> replicateM len (arbitraryLit nv) return (1,c) th <- choose (0,nc) return $@@ -426,6 +429,88 @@ PBO.optimize opt liftM (fmap (\(m, val) -> (SAT.restrictModel nv m, val))) $ PBO.getBestSolution opt ++solvePBFormula :: SAT.Solver -> PBFile.Formula -> IO (Maybe SAT.Model)+solvePBFormula solver opb = do+ SAT.newVars_ solver (PBFile.pbNumVars opb)+ enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver+ forM_ (PBFile.pbConstraints opb) $ \(lhs, op, rhs) -> do+ case op of+ PBFile.Ge -> PBNLC.addPBNLAtLeast enc lhs rhs+ PBFile.Eq -> PBNLC.addPBNLExactly enc lhs rhs+ ret <- SAT.solve solver+ if ret then do+ m <- SAT.getModel solver+ return $ Just $ SAT.restrictModel (PBFile.pbNumVars opb) m+ else do+ return Nothing+++optimizePBFormula+ :: SAT.Solver+ -> PBO.Method+ -> PBFile.Formula+ -> IO (Maybe (SAT.Model, Integer))+optimizePBFormula solver method opb = do+ SAT.newVars_ solver (PBFile.pbNumVars opb)+ enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver+ forM_ (PBFile.pbConstraints opb) $ \(lhs, op, rhs) -> do+ case op of+ PBFile.Ge -> PBNLC.addPBNLAtLeast enc lhs rhs+ PBFile.Eq -> PBNLC.addPBNLExactly enc lhs rhs+ let obj = fromMaybe [] $ PBFile.pbObjectiveFunction opb+ 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 (PBFile.pbNumVars opb) m, val))) $ PBO.getBestSolution opt+++optimizePBSoftFormula+ :: SAT.Solver+ -> PBO.Method+ -> PBFile.SoftFormula+ -> IO (Maybe (SAT.Model, Integer))+optimizePBSoftFormula solver method wbo = do+ SAT.newVars_ solver (PBFile.wboNumVars wbo)+ enc <- PBNLC.newEncoder solver =<< Tseitin.newEncoder solver+ obj <- liftM catMaybes $ forM (PBFile.wboConstraints wbo) $ \(cost, (lhs,op,rhs)) -> do+ case cost of+ Nothing -> do+ case op of+ PBFile.Ge -> PBNLC.addPBNLAtLeast enc lhs rhs+ PBFile.Eq -> PBNLC.addPBNLExactly enc lhs rhs+ return Nothing+ Just w -> do+ sel <- SAT.newVar solver+ case op of+ PBFile.Ge -> PBNLC.addPBNLAtLeastSoft enc sel lhs rhs+ PBFile.Eq -> PBNLC.addPBNLExactlySoft enc sel lhs rhs+ return $ Just (w,-sel)+ case PBFile.wboTopCost wbo 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 (PBFile.wboNumVars wbo) m, val))) $ PBO.getBestSolution opt+++optimizeWCNF+ :: SAT.Solver+ -> PBO.Method+ -> CNF.WCNF+ -> IO (Maybe (SAT.Model, Integer))+optimizeWCNF solver method wcnf = do+ let (wbo, info) = maxsat2wbo wcnf+ ret <- optimizePBSoftFormula solver method wbo+ case ret of+ Nothing -> return Nothing+ Just (m, obj) -> do+ let m' = transformBackward info m+ obj' = transformObjValueBackward info obj+ return $ Just (m', obj')+ ------------------------------------------------------------------------ instance Arbitrary SAT.LearningStrategy where@@ -544,7 +629,34 @@ , PBFile.pbConstraints = cs } +arbitraryPBSoftFormula :: Gen PBFile.SoftFormula+arbitraryPBSoftFormula = do+ nv <- choose (0,10)+ nc <- choose (0,10)+ cs <- replicateM nc $ do+ cost <- fmap getPositive <$> arbitrary+ lhs <- arbitraryPBSum nv+ op <- arbitrary+ rhs <- arbitrary+ return (cost, (lhs,op,rhs))+ top <- fmap getPositive <$> arbitrary+ return $+ PBFile.SoftFormula+ { PBFile.wboNumVars = nv+ , PBFile.wboNumConstraints = nc+ , PBFile.wboConstraints = cs+ , PBFile.wboTopCost = top+ }+ instance Arbitrary PBFile.Op where arbitrary = arbitraryBoundedEnum++instance Arbitrary Tseitin.Polarity where+ arbitrary = elements+ [ Tseitin.polarityPos+ , Tseitin.polarityNeg+ , Tseitin.polarityBoth+ , Tseitin.polarityNone+ ] -- ---------------------------------------------------------------------
test/Test/SDPFile.hs view
@@ -2,6 +2,7 @@ module Test.SDPFile (sdpTestGroup) where import Control.Monad+import qualified Data.Aeson as J import Data.List import Data.Maybe import Data.ByteString.Builder (toLazyByteString)@@ -9,6 +10,8 @@ import Test.Tasty.QuickCheck import Test.Tasty.HUnit import Test.Tasty.TH++import qualified ToySolver.SDP as SDP import ToySolver.Text.SDPFile ------------------------------------------------------------------------@@ -73,6 +76,20 @@ case actual of Left err -> assertFailure $ show err Right prob -> prob @?= expected++------------------------------------------------------------------------++case_dualize_json_example1 :: Assertion+case_dualize_json_example1 = do+ let ret@(_, info) = SDP.dualize example1+ json = J.encode info+ J.eitherDecode json @?= Right info++case_dualize_json_example2 :: Assertion+case_dualize_json_example2 = do+ let ret@(_, info) = SDP.dualize example2+ json = J.encode info+ J.eitherDecode json @?= Right info ------------------------------------------------------------------------ -- Test harness
test/TestSuite.hs view
@@ -13,6 +13,7 @@ import Test.CNF import Test.Delta import Test.FiniteModelFinder+import Test.Graph import Test.GraphShortestPath import Test.HittingSets import Test.Knapsack@@ -49,6 +50,7 @@ , ctTestGroup , deltaTestGroup , fmfTestGroup+ , graphTestGroup , graphShortestPathTestGroup , hittingSetsTestGroup , knapsackTestGroup
toysolver.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 Name: toysolver-Version: 0.8.1+Version: 0.9.0 License: BSD-3-Clause License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com)@@ -11,37 +11,24 @@ Homepage: https://github.com/msakai/toysolver/ Bug-Reports: https://github.com/msakai/toysolver/issues Tested-With:- GHC ==8.6.5+ GHC ==8.6.3 GHC ==8.8.4 GHC ==8.10.7 GHC ==9.0.2- GHC ==9.2.3-Extra-Source-Files:+ GHC ==9.2.8+ GHC ==9.4.8+ GHC ==9.6.6+ GHC ==9.8.2+Extra-Doc-Files: README.md INSTALL.md CHANGELOG.markdown COPYING COPYING-GPL+Extra-Source-Files: app/toysat-ipasir/ipasir.h app/toysat-ipasir/ipasir.map- misc/build_bdist_linux.sh- misc/build_bdist_macos.sh- misc/build_bdist_win32.sh- misc/build_bdist_win64.sh- 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/Solver/MessagePassing/SurveyPropagation/sp.cl samples/gcnf/*.cnf samples/gcnf/*.gcnf samples/lp/*.lp@@ -97,6 +84,11 @@ Default: False Manual: True +Flag BuildForeignLibraries+ Description: build foreign libraries+ Default: True+ Manual: True + Flag BuildSamplePrograms Description: build sample programs Default: False@@ -113,7 +105,7 @@ Default: True Flag OpenCL- Description: use opencl package+ Description: use opencl package (deprecated) Manual: True Default: False @@ -122,6 +114,11 @@ Manual: True Default: False +Flag optparse-applicative-018+ Description: use optparse-applicative >=0.18+ Manual: False+ Default: False+ source-repository head type: git location: git://github.com/msakai/toysolver.git@@ -130,10 +127,11 @@ Exposed: True Hs-source-dirs: src Build-Depends:+ aeson >=1.4.2.0 && <2.3, array >=0.5,- -- GHC >=8.6 && <9.5- base >=4.12 && <4.18,- bytestring >=0.9.2.1 && <0.12,+ -- GHC >=8.6 && <9.11+ base >=4.12 && <4.21,+ bytestring >=0.9.2.1 && <0.13, bytestring-builder, bytestring-encoding >=0.1.1.0, case-insensitive,@@ -149,14 +147,14 @@ filepath, finite-field >=0.9.0 && <1.0.0, -- hashUsing is available on hashable >=1.2- hashable >=1.2 && <1.5.0.0,+ hashable >=1.2 && <1.6.0.0, hashtables, heaps, intern >=0.9.1.2 && <1.0.0.0, log-domain, -- numLoopState requires loop >=0.3.0 loop >=0.3.0 && < 1.0.0,- MIP >=0.1.1.0 && <0.2,+ MIP >=0.2.0.0 && <0.3, mtl >=2.1.2, multiset, -- createSystemRandom requires mwc-random >=0.13.1.0@@ -190,9 +188,6 @@ if flag(WithZlib) Build-Depends: zlib CPP-Options: "-DWITH_ZLIB"- if flag(OpenCL)- Build-Depends: OpenCL >=1.0.3.4- Exposed-Modules: ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL if flag(ExtraBoundsChecking) CPP-Options: "-DEXTRA_BOUNDS_CHECKING" if impl(ghc)@@ -274,15 +269,10 @@ ToySolver.Converter ToySolver.Converter.Base ToySolver.Converter.GCNF2MaxSAT- ToySolver.Converter.ObjType- ToySolver.Converter.MIP2PB ToySolver.Converter.MIP2SMT ToySolver.Converter.NAESAT ToySolver.Converter.PB- ToySolver.Converter.PB2IP- ToySolver.Converter.PB2LSP- ToySolver.Converter.PBSetObj- ToySolver.Converter.PB2SMP+ ToySolver.Converter.MIP ToySolver.Converter.QBF2IPC ToySolver.Converter.QUBO ToySolver.Converter.SAT2MIS@@ -329,6 +319,7 @@ ToySolver.SAT.Encoder.Integer ToySolver.SAT.Encoder.PB ToySolver.SAT.Encoder.PB.Internal.Adder+ ToySolver.SAT.Encoder.PB.Internal.BCCNF ToySolver.SAT.Encoder.PB.Internal.BDD ToySolver.SAT.Encoder.PB.Internal.Sorter ToySolver.SAT.Encoder.PBNLC@@ -377,6 +368,8 @@ ToySolver.Converter.PB.Internal.Product ToySolver.Data.AlgebraicNumber.Graeffe ToySolver.Data.Polynomial.Base+ ToySolver.Internal.JSON+ ToySolver.SAT.Internal.JSON ToySolver.SAT.MUS.Base ToySolver.SAT.MUS.Deletion ToySolver.SAT.MUS.Insertion@@ -394,7 +387,7 @@ HS-Source-Dirs: app Build-Depends: array,- base,+ base >=4.12 && <4.21, containers, data-default-class, filepath,@@ -419,7 +412,7 @@ HS-Source-Dirs: app/toysat Build-Depends: array,- base,+ base >=4.12 && <4.21, bytestring, containers, clock,@@ -449,13 +442,15 @@ Foreign-Library toysat-ipasir type: native-shared+ if !flag(BuildForeignLibraries)+ buildable: False if os(Windows) options: standalone mod-def-file: app/toysat-ipasir/ipasir.def if os(Linux) ld-options: -Wl,--version-script=app/toysat-ipasir/ipasir.map build-depends:- base,+ base >=4.12 && <4.21, containers, toysolver hs-source-dirs: app/toysat-ipasir@@ -481,7 +476,7 @@ Smtlib.Syntax.Syntax, Smtlib.Syntax.ShowSL Build-Depends:- base,+ base >=4.12 && <4.21, containers, -- TODO: remove intern dependency intern,@@ -508,7 +503,7 @@ Main-is: toyqbf.hs HS-Source-Dirs: app Build-Depends:- base,+ base >=4.12 && <4.21, containers, data-default-class, optparse-applicative,@@ -529,10 +524,10 @@ HS-Source-Dirs: app If flag(BuildToyFMF) Build-Depends:- base,+ base >=4.12 && <4.21, containers, intern,- logic-TPTP >=0.4.6.0 && <0.5,+ logic-TPTP >=0.4.6.0 && <0.7, optparse-applicative, text, toysolver@@ -551,18 +546,26 @@ Main-is: toyconvert.hs HS-Source-Dirs: app Build-Depends:- base,- ansi-wl-pprint,+ aeson,+ base >=4.12 && <4.21, bytestring, bytestring-builder,+ containers, data-default-class, filepath, MIP,- optparse-applicative, pseudo-boolean, scientific, text, toysolver+ if flag(optparse-applicative-018)+ Build-Depends:+ optparse-applicative >=0.18,+ prettyprinter >=1+ else+ Build-Depends:+ optparse-applicative <0.18,+ ansi-wl-pprint Default-Language: Haskell2010 Other-Extensions: CPP GHC-Options: -rtsopts@@ -583,7 +586,7 @@ HS-Source-Dirs: samples/programs/sudoku Build-Depends: array,- base,+ base >=4.12 && <4.21, toysolver Default-Language: Haskell2010 Other-Extensions: CPP@@ -600,7 +603,7 @@ HS-Source-Dirs: samples/programs/nonogram Build-Depends: array,- base,+ base >=4.12 && <4.21, containers, toysolver Default-Language: Haskell2010@@ -619,7 +622,7 @@ HS-Source-Dirs: samples/programs/nqueens Build-Depends: array,- base,+ base >=4.12 && <4.21, toysolver Default-Language: Haskell2010 Other-Extensions: CPP@@ -637,7 +640,7 @@ HS-Source-Dirs: samples/programs/numberlink Build-Depends: array,- base,+ base >=4.12 && <4.21, bytestring, containers, data-default-class,@@ -659,7 +662,7 @@ Main-is: knapsack.hs HS-Source-Dirs: samples/programs/knapsack Build-Depends:- base,+ base >=4.12 && <4.21, toysolver Default-Language: Haskell2010 Other-Extensions: CPP@@ -677,7 +680,7 @@ HS-Source-Dirs: samples/programs/assign Build-Depends: attoparsec,- base,+ base >=4.12 && <4.21, bytestring, containers, toysolver,@@ -697,7 +700,7 @@ Main-is: shortest-path.hs HS-Source-Dirs: samples/programs/shortest-path Build-Depends:- base,+ base >=4.12 && <4.21, bytestring, containers, unordered-containers,@@ -717,7 +720,7 @@ Main-is: htc.hs HS-Source-Dirs: samples/programs/htc Build-Depends:- base,+ base >=4.12 && <4.21, containers, toysolver Default-Language: Haskell2010@@ -735,7 +738,7 @@ Main-is: svm2lp.hs HS-Source-Dirs: samples/programs/svm2lp Build-Depends:- base,+ base >=4.12 && <4.21, containers, data-default-class, MIP,@@ -758,17 +761,12 @@ Main-is: survey-propagation.hs HS-Source-Dirs: samples/programs/survey-propagation Build-Depends:- base,+ base >=4.12 && <4.21, data-default-class, toysolver- if flag(OpenCL)- Build-Depends: OpenCL- CPP-Options: "-DENABLE_OPENCL" Default-Language: Haskell2010 Other-Extensions: CPP- -- We use threaded RTS to avoid the error "schedule: re-entered unsafely.- -- Perhaps a 'foreign import unsafe' should be 'safe'?" on NVIDIA CUDA.- GHC-Options: -rtsopts -threaded+ GHC-Options: -rtsopts -- GHC-Prof-Options: -auto-all if flag(ForceChar8) CPP-Options: "-DFORCE_CHAR8"@@ -781,7 +779,7 @@ Main-is: probsat.hs HS-Source-Dirs: samples/programs/probsat Build-Depends:- base,+ base >=4.12 && <4.21, clock, data-default-class, mwc-random,@@ -805,7 +803,7 @@ Main-is: pigeonhole.hs HS-Source-Dirs: app Build-Depends:- base,+ base >=4.12 && <4.21, bytestring, containers, pseudo-boolean,@@ -826,7 +824,7 @@ HS-Source-Dirs: app Build-Depends: array,- base,+ base >=4.12 && <4.21, toysolver Default-Language: Haskell2010 Other-Extensions: CPP@@ -844,7 +842,7 @@ HS-Source-Dirs: app Build-Depends: array,- base,+ base >=4.12 && <4.21, pseudo-boolean, toysolver Default-Language: Haskell2010@@ -863,18 +861,20 @@ HS-Source-Dirs: test Main-is: TestPolynomial.hs Build-depends:- base,+ base >=4.12 && <4.21, containers, data-interval, finite-field >=0.7.0 && <1.0.0, pretty, tasty >=0.10.1, tasty-hunit >=0.9 && <0.11,- tasty-quickcheck >=0.8 && <0.11,+ tasty-quickcheck >=0.8 && <0.12, tasty-th, toysolver Default-Language: Haskell2010- Other-Extensions: TemplateHaskell+ Other-Extensions:+ DataKinds+ TemplateHaskell Test-suite TestSuite Type: exitcode-stdio-1.0@@ -893,6 +893,7 @@ Test.Converter Test.Delta Test.FiniteModelFinder+ Test.Graph Test.GraphShortestPath Test.HittingSets Test.Knapsack@@ -922,8 +923,9 @@ Smtlib.Syntax.Syntax Smtlib.Syntax.ShowSL Build-depends:+ aeson, array,- base,+ base >=4.12 && <4.21, bytestring, bytestring-builder, containers,@@ -934,6 +936,7 @@ intern, lattices, megaparsec,+ MIP, mtl, mwc-random, OptDir,@@ -944,7 +947,7 @@ scientific, tasty >=0.10.1, tasty-hunit >=0.9 && <0.11,- tasty-quickcheck >=0.8 && <0.11,+ tasty-quickcheck >=0.8 && <0.12, tasty-th, text, toysolver,@@ -957,8 +960,11 @@ Other-Extensions: CPP DataKinds+ FlexibleContexts+ LambdaCase ScopedTypeVariables TemplateHaskell+ TupleSections Benchmark BenchmarkSATLIB type: exitcode-stdio-1.0@@ -966,7 +972,7 @@ main-is: BenchmarkSATLIB.hs build-depends: array,- base,+ base >=4.12 && <4.21, criterion >=1.0 && <1.7, data-default-class, toysolver@@ -977,7 +983,7 @@ hs-source-dirs: benchmarks main-is: BenchmarkKnapsack.hs build-depends:- base,+ base >=4.12 && <4.21, criterion >=1.0 && <1.7, toysolver Default-Language: Haskell2010@@ -987,7 +993,7 @@ hs-source-dirs: benchmarks main-is: BenchmarkSubsetSum.hs build-depends:- base,+ base >=4.12 && <4.21, criterion >=1.0 && <1.7, toysolver, vector